如何实现调用一个设计好的EXECL表，在把数据库里(SQL 2000库)的东西放到这个设计好的EXECL表里!
解决方案 »
- 数据不一致问题？
- 谁能告诉我如何取出硬盘的序列号！~！~！谢谢在线等
- 问一个有关分辨率的问题：我在做一个程序时，用到Toolbar1,在1024*768时是单行的，如果是800*600的就会变成是两行的,我要如何做才能使在8
- 使用modem通讯，如何传输非文本文件？（比如EXE、jpg文件）
- !!!我要关机!!!
- 一个有关DOS的问题，@@来答者有分呀@@@@@@@@@@@@@@@@@@2
- mshtml
- 求助一个假如的用句
- 一个奇怪的问题（关于程序运行速度），请高手指点！！！
- VB 使用SendMessage获取外部程序的listView控件内容
- 紧急!
- 在VB里如何写，关于EXE文件只能运行一个实例的问题！！
Dim xlapp As Excel.Application, l_set As Recordset, i As Integer, l_sum As Integer, j As Integer
Dim strsource As String, strdestination As String, l_row As Integer
Dim l_sheets As Integer, l_re_counts As Integer
Set xlapp = New Excel.Application
Set xlapp = CreateObject("excel.application")
FileCopy g_cuspath & "\provider_sum.xls", g_cuspath & "\provider_sum.xls_temp.xls"
Set XLBOOK = xlapp.Workbooks.Open(g_cuspath & "\provider_sum.xls_temp.xls")
If i_pici > 23 Then
l_sheets = 1
l_re_counts = i_pici
f_row = 23
Adodc1.Recordset.MoveFirst
Do
i = 6
j = 1
i_yw = 0
i_bhg = 0
Set XLSHEET = XLBOOK.Worksheets(l_sheets)
XLSHEET.Cells(3, 1) = "供应商名称:" & T_p_name.Text
Do While j <= f_row
XLSHEET.Cells(i, 1) = Trim(Adodc1.Recordset("ll_date"))
XLSHEET.Cells(i, 2) = Adodc1.Recordset("stock_code")
XLSHEET.Cells(i, 3) = Adodc1.Recordset("xingneng")
Select Case Adodc1.Recordset("pinming")
Case "m"
XLSHEET.Cells(i, 4) = "√"
Case "p"
XLSHEET.Cells(i, 6) = "√"
End Select
XLSHEET.Cells(i, 7) = Adodc1.Recordset("guige")
XLSHEET.Cells(i, 8) = Adodc1.Recordset("dh_shu")
XLSHEET.Cells(i, 9) = Trim(Adodc1.Recordset("deliver_date"))
If IsNull(Trim(Adodc1.Recordset("dh_detail"))) Then
XLSHEET.Cells(i, 10) = "?"
Else
If IsNumeric(Adodc1.Recordset("dh_detail")) Then
If CInt(Adodc1.Recordset("dh_detail")) < -7 Then
XLSHEET.Cells(i, 10) = "×"
i_yw = i_yw + 1
Else
XLSHEET.Cells(i, 10) = "√"
End If
Else
If Trim(Adodc1.Recordset("dh_detail")) = "准时" Then
XLSHEET.Cells(i, 10) = "√"
Else
XLSHEET.Cells(i, 10) = "×"
i_yw = i_yw + 1
End If
End If
End If
If IsNull(Trim(Adodc1.Recordset("zz_panding"))) Then
XLSHEET.Cells(i, 11) = "?"
Else
If Adodc1.Recordset("zz_panding") = "合格" Then
XLSHEET.Cells(i, 11) = "√"
Else
XLSHEET.Cells(i, 12) = "×"
i_bhg = i_bhg + 1
End If
End If
If Adodc1.Recordset("zz_panding") = "特采" Then
XLSHEET.Cells(i, 13) = "特采"
End If
XLSHEET.Cells(i, 14) = G_OPER
i = i + 1
j = j + 1
Adodc1.Recordset.MoveNext
Loop
XLSHEET.Cells(29, 2) = CStr(f_row)
XLSHEET.Cells(29, 8) = CStr(i_yw)
XLSHEET.Cells(29, 13) = CStr(i_bhg)
l_re_counts = l_re_counts - 23
l_sheets = l_sheets + 1
If l_re_counts > 23 Then
f_row = 23
Else
f_row = l_re_counts
End If
Loop Until l_re_counts <= 0
Else
f_row = i_pici
Set XLSHEET = XLBOOK.Worksheets(1)
XLSHEET.Cells(3, 1) = "供应商名称:" & T_p_name.Text
i = 6
j = 1
i_yw = 0
i_bhg = 0
Adodc1.Recordset.MoveFirst
Do While j <= f_row
XLSHEET.Cells(i, 1) = Trim(Adodc1.Recordset("ll_date"))
XLSHEET.Cells(i, 2) = Adodc1.Recordset("stock_code")
XLSHEET.Cells(i, 3) = Adodc1.Recordset("xingneng")
Select Case Adodc1.Recordset("pinming")
Case "m"
XLSHEET.Cells(i, 4) = "√"
Case "p"
XLSHEET.Cells(i, 6) = "√"
End Select
XLSHEET.Cells(i, 7) = Adodc1.Recordset("guige")
XLSHEET.Cells(i, 8) = Adodc1.Recordset("dh_shu")
XLSHEET.Cells(i, 9) = Trim(Adodc1.Recordset("deliver_date"))
If IsNull(Trim(Adodc1.Recordset("dh_detail"))) Then
XLSHEET.Cells(i, 10) = "?"
Else
If IsNumeric(Adodc1.Recordset("dh_detail")) Then
If CInt(Adodc1.Recordset("dh_detail")) < -7 Then
XLSHEET.Cells(i, 10) = "×"
i_yw = i_yw + 1
Else
XLSHEET.Cells(i, 10) = "√"
End If
Else
If Trim(Adodc1.Recordset("dh_detail")) = "准时" Then
XLSHEET.Cells(i, 10) = "√"
Else
XLSHEET.Cells(i, 10) = "×"
i_yw = i_yw + 1
End If
End If
End If
If IsNull(Trim(Adodc1.Recordset("zz_panding"))) Then
XLSHEET.Cells(i, 11) = "?"
Else
If Adodc1.Recordset("zz_panding") = "合格" Then
XLSHEET.Cells(i, 11) = "√"
Else
XLSHEET.Cells(i, 12) = "×"
i_bhg = i_bhg + 1
End If
End If
If Adodc1.Recordset("zz_panding") = "特采" Then
XLSHEET.Cells(i, 13) = "特采"
End If
XLSHEET.Cells(i, 14) = G_OPER
i = i + 1
j = j + 1
Adodc1.Recordset.MoveNext
Loop
XLSHEET.Cells(29, 2) = CStr(f_row)
XLSHEET.Cells(29, 8) = CStr(i_yw)
XLSHEET.Cells(29, 13) = CStr(i_bhg)
End If
xlapp.Visible = True
End Function
'½«Êý¾Ýµ¼Èëµ½ExcelÎļþÖÐ
'strExcelFullPathΪExcelÎļþµÄȫ·¾¶
Public Function ExportDBToExcel(strExcelFullPath As String)
Dim i As Integer: i = 0
Dim j As Integer: j = 0
Dim oExcel As Object
Dim obook As Object
Set oExcel = CreateObject("Excel.application")
Set obook = oExcel.Workbooks.Open(strExcelFullPath)
oExcel.Visible = False
For i = 0 To UBound(DBStruct)
'Ò»¸ö¸öÊý¾Ý¿â±íµØµ¼³ö,µ¼³öÊý¾Ý¿â±íµ½ExcelÖÐ
If SafeArrayGetDim(DBStruct(i).FieldName) > 0 Then
ExportATableToSheet obook, strExcelFullPath, DBStruct(i).strTableName, DBStruct(i).strTableName
End If
Next i
oExcel.Save
oExcel.quit
Set obook = Nothing
Set oExcel = Nothing
End Function
'
'strExcelFullPathΪExcelÎļþµÄȫ·¾¶
'strTableNameΪÊý¾Ý¿â±íÃû³Æ
'strSheetNameΪExcelÎļþ·¾¶Ãû³Æ
Public Function ExportATableToSheet(obook As Object, strExcelFullPath As String, _
strTableName As String, strSheetName As String, _
Optional lngNumExp As Long = -1, Optional strDBFlag As String = "Access")
On Error Resume Next
strTableName = Trim(strTableName)
strSheetName = Trim(strSheetName)
strExcelFullPath = Trim(strExcelFullPath)
If Not Len(Dir(strExcelFullPath)) > 0 Then Exit Function '²»´æÔÚ¸ÃÊý¾Ý±í
If strTableName = "" Or strSheetName = "" Then Exit Function
Dim i As Long: i = 0
Dim j As Long: j = 0
Dim bExistTable As Boolean: bExistTable = False
Dim RsDB As New ADODB.Recordset
Dim rsExcel As New ADODB.Recordset
Dim strSQL As String: strSQL = ""
For i = 0 To UBound(DBStruct)
If Trim(DBStruct(i).strTableName) = strTableName Then
bExistTable = True
Exit For
End If
Next i
If bExistTable <> True Then Exit Function
'ÒÔÏÂΪSQLµ¼³öÊý¾Ý£¬¸Ã·½·¨½Ì¿ì£¬µ«ÊdzöÏÖ´íÎó£¬ÎÞ·¨½â¾ö
' CnDB.CursorLocation = adUseClient
' Dim strSQL As String: strSQL = ""
'
' strSQL = "insert into [EXCEL 5.0;DATABASE=" & strExcelFullPath & "]." & _
' strSheetName & " select * from " & strTableName
'
' 'osheet.Range("A1").CopyFromRecordset rs
' '´íÎóÔ­Òò:ExcelÖеÄÊý¾Ý³¤¶È̫СÁË.
' On Error Resume Next
' rsDB.Open strSQL, CnDB
If lngNumExp = -1 Then
strSQL = "select * from " & strTableName
Else
Select Case strDBFlag
Case "Access"
strSQL = "select top " & CStr(lngNumExp) & " * from " & strTableName
Case Else
strSQL = "select * from " & strTableName & " where rownum<" & CStr(lngNumExp)
End Select
End If
CnDB.CursorLocation = adUseClient
RsDB.Open strSQL, CnDB
Dim ArrTemp() As String
ReDim ArrTemp(RsDB.RecordCount - 1, RsDB.Fields.Count - 1) As String
Dim osheet As Object
Set osheet = obook.Worksheets(strSheetName)
For i = 0 To RsDB.RecordCount - 1
For j = 0 To RsDB.Fields.Count - 1
ArrTemp(i, j) = CStr(RsDB.Fields(j).Value)
DoEvents
Next j
RsDB.MoveNext
ShowInPB CDbl(i / RsDB.RecordCount)
Next i
osheet.Range("A2").Resize(RsDB.RecordCount + 1, RsDB.Fields.Count + 1).Value = ArrTemp
osheet.Range("A2").Resize(RsDB.RecordCount + 1, RsDB.Fields.Count + 1).autofit
osheet.Close
Set osheet = Nothing
End Function