引用
Public Function ExporToExcel(strOpen As String)
'*********************************************************
'* 名稱：ExporToExcel
'* 功能：導(dǎo)出數(shù)據(jù)到EXCEL
'* 用法：ExporToExcel(sql查詢字符串)
'*********************************************************
   On Error Resume Next
    Dim cn As New ADODB.Connection
    Dim Rs_Data As New ADODB.Recordset
    Dim Irowcount As Integer
    Dim Icolcount As Integer

    Dim xlApp As New Excel.Application
    Dim xlBook As Excel.Workbook
    Dim xlSheet As Excel.Worksheet
    Dim xlQuery As Excel.QueryTable
    
    Dim line As Integer, M As Integer, n As Integer
    
    Dim savepath As String  '定義保存路徑
    
    CommonDialog1.CancelError = True   '設(shè)置cancelError為ture
    
'    On Error GoTo errhandler
    CommonDialog1.Flags = cdlOFNHideReadOnly
    
    
    CommonDialog1.FileName = "Report"
    
    CommonDialog1.DefaultExt = ".xls"
    
    CommonDialog1.Filter = "Excel(*.xls)|*.xls|Text(*.txt)|*.txt"
    
    CommonDialog1.FilterIndex = 1
    
    CommonDialog1.Flags = &H2
    
    CommonDialog1.ShowSave
    
    If Err.Number = cdlCancel Then
        MsgBox "按取消按扭將取消本次操作！", vbInformation + vbOKOnly, "提示"
        Exit Function

    End If
    
    savepath = CommonDialog1.FileName
    cn.Open "Provider=Microsoft.Jet.OLEDB.4.0;Data Source ='" + App.Path & "\info.mdb" + "'  ;Persist Security Info=False"
    With Rs_Data
        If .State = adStateOpen Then
            .Close
        End If
        .ActiveConnection = cn
        .CursorLocation = adUseClient
        .CursorType = adOpenStatic
        .LockType = adLockReadOnly
        .Source = strOpen
        .Open
    End With
  '  Rs_Data.Open strOpen, Cn, adOpenStatic, adLockReadOnly
    With Rs_Data
      '  .MoveFirst
        If .RecordCount < 1 Then
            MsgBox ("沒有記錄!")
            Exit Function
        End If
        '記錄總數(shù)
        Irowcount = .RecordCount
        '字段總數(shù)
        Icolcount = .Fields.Count
    End With
    Set xlApp = CreateObject("Excel.Application")
    Set xlBook = Nothing
    Set xlSheet = Nothing
    Set xlBook = xlApp.Workbooks().Add
    Set xlSheet = xlBook.Worksheets("sheet1")
    xlApp.Visible = False
    '添加查詢語句，導(dǎo)入EXCEL數(shù)據(jù)
    Set xlQuery = xlSheet.QueryTables.Add(Rs_Data, xlSheet.Range("a1"))

    With xlQuery
        .FieldNames = True
        .RowNumbers = False
        .FillAdjacentFormulas = False
        .PreserveFormatting = True
        .RefreshOnFileOpen = False
        .BackgroundQuery = True
        .RefreshStyle = xlInsertDeleteCells
        .SavePassword = True
        .SaveData = True
        .AdjustColumnWidth = True
        .RefreshPeriod = 0
        .PreserveColumnInfo = True
    End With

    xlQuery.FieldNames = True '顯示字段名
    xlQuery.Refresh

    With xlSheet
        .Range(.Cells(1, 1), .Cells(1, Icolcount)).Font.Name = "黑體"
        '設(shè)標題為黑體字
        .Range(.Cells(1, 1), .Cells(1, Icolcount)).Font.Bold = True
        '標題字體加粗
        .Range(.Cells(1, 1), .Cells(Irowcount + 1, Icolcount)).Borders.LineStyle = xlContinuous
        '設(shè)表格邊框樣式
    End With
    ActiveWorkbook.SaveAs FileName:=savepath, FileFormat:=xlNormal, _
    PassWord:="", WriteResPassword:="", ReadOnlyRecommended:=False, _
    CreateBackup:=False
    ActiveWorkbook.Saved = True   '保存到Excel
   ' MsgBox "保存成功！", vbOKOnly, "信息"
    '結(jié)束EXcel進程
    xlApp.Quit  '
    Set xlSheet = Nothing
    Set xlBook = Nothing
    Set xlApp = Nothing
End Function


'將數(shù)據(jù)導(dǎo)出 mdb﹐成為Excel文件
Private Sub Command3_Click()
 conn.Execute "select * into [Excel 8.0;database=e:\test\test4.xls].[test4] from Phonebook"
 Unload Me
End Sub