另外,我以前保存EXCEL是这样写的,语句简单一点:
Private Sub saveToXls(ByVal xlsFileName As String)
Dim xlApp As Excel.Application
Dim xlBook As Excel.Workbook
Dim Export_Str As String
Set xlApp = CreateObject("Excel.Application") 'create Excel application
Hide
Export_Str = "select * into [Excel 8.0;database=" & xlsFileName & ".xls].[sheet1] from product"
conn.Execute Export_Str
frmDataOper.Show
xlApp.Quit
End Sub
Private Sub saveToXls(ByVal xlsFileName As String)
Dim xlApp As Excel.Application
Dim xlBook As Excel.Workbook
Dim xlSheet As Excel.Worksheet
Dim oldPointer As Integer 'used to save the current
Dim rPointer As Integer 'current saving record
Dim xlsPointer As Integer 'used to point out the position
'the current record saving
oldPointer = rs_com.Bookmark 'save current pointer of rs_com
xlsPointer = 2 'the first line of Excel sheet
Set xlApp = CreateObject("Excel.Application") 'create Excel application
Set xlBook = xlApp.Workbooks.Add
Set xlSheet = xlBook.Worksheets(1)
Hide
frmSaveProgress.Show 'show the progress status
rs_com.MoveFirst
Dim i As Integer
While Not rs_com.EOF 'save ecah record to Excel file
For i = 0 To 8 'save each field to Excel cell
xlSheet.Cells(xlsPointer, i + 1) = rs_com.Fields(i)
Next
frmSaveProgress.nextStep (rs_com.Bookmark / rs_com.RecordCount)
rs_com.MoveNext
xlsPointer = xlsPointer + 1
Wend
Unload frmSaveProgress 'end save to Excel file
frmDataOper.Show
xlBook.SaveAs (xlsFileName)
xlBook.Close
xlApp.Quit
End Sub
Private Sub cmdSave_Click()
diaSave.Filter = "Excel文件|*.xls" 'set to save as Excel file
Dim bOk As Boolean
bOk = True
If isInFindMode Then
MsgBox "正在查找中,请先退出查找再进行保存!", vbInformation, "注意"
Exit Sub
End If
Do While bOk
diaSave.ShowSave 'show save dialog
If diaSave.FileName = "" Then
Exit Sub
Else
'do save here
bOk = False
Call saveToXls(diaSave.FileName)
MsgBox "保存结束!", vbInformation, "通知"
End If
Loop
End Sub