導出excel兩個例子

在vb中利用excel導出報表,寫的兩個公用函數

'*****************************************************************
'Spspread導出到EXCEL
'Head:為導出在EXCEL的台頭﹐Commondialog_All﹕為公共對話框對象﹐spd﹕為fpSpread對象
'*****************************************************************
Public Sub ExportExcel(Head As String, Commondialog_All As CommonDialog, spd As fpSpread)
Dim Lhead
Dim path As String
Dim yi As String
Dim i As Integer
       
    Commondialog_All.CancelError = True
'    On Error GoTo Errorhandler
   
    With Commondialog_All
        .FileName = Head & ".xls"
        .InitDir = "C:/"
        .DefaultExt = "xls"
        .DialogTitle = "Save As New Excel Spread"
        .Filter = "MicroSoft Excel 活頁簿(*.xls)"
        .ShowSave
       
     End With
    path = Commondialog_All.FileName
   
    '導出到EXCEL過程出現進度條
    Frm_Progress.Label1.Caption = "正在導出﹕" & Head & " 到EXCEL..."
    Frm_Progress.Label2.Caption = "Finished 0%"
    Frm_Progress.Show
   
    spd.ExportToExcel Commondialog_All.FileName, "sheet1", ""
   
    Frm_Progress.ProgressBar1.Value = 5
    Frm_Progress.Label2.Caption = "Finished 5%"
   
    Dim app As New Excel.Application
    Dim wkbk As New Workbook
    Dim wkst As New Worksheet
    Set wkbk = app.Workbooks.Open(path)
    Set wkst = wkbk.Worksheets(1)
    wkst.Unprotect
    wkst.Rows("1:1").Insert
   
    Frm_Progress.ProgressBar1.Value = 7
    Frm_Progress.Label2.Caption = "Finished 7%"
   
    wkst.Rows("1:1").Insert
    wkst.Rows("1:1").Insert
   
     Frm_Progress.ProgressBar1.Value = 10
    Frm_Progress.Label2.Caption = "Finished 10%"
   
    wkst.Range("a1") = Head
    wkst.Range("a1").Font.Size = 20
    wkst.Range("a1").Font.Bold = True
    wkst.Rows("1:1").RowHeight = 40
    wkst.Range("a1:" & Chr(96 + spd.DataColCnt) & "1").Merge
    wkst.Range("a1:" & Chr(96 + spd.DataColCnt) & "1").HorizontalAlignment = xlCenter
    wkst.Range("a3:" & Chr(96 + spd.DataColCnt) & "3").HorizontalAlignment = xlCenter
    wkst.Range(Chr(96 + spd.DataColCnt) & "2") = "制表日期﹕" & Format(GetServerTime, "yyyy/mm/dd")
    wkst.Range(Chr(96 + spd.DataColCnt) & "2").HorizontalAlignment = xlRight
   
    Frm_Progress.ProgressBar1.Value = 15
    Frm_Progress.Label2.Caption = "Finished 15%"
   
    wkst.Range("b" & CStr(spd.DataRowCnt + 5)) = "核准﹕"
    wkst.Range("d" & CStr(spd.DataRowCnt + 5)) = "主管﹕"
    wkst.Range("f" & CStr(spd.DataRowCnt + 5)) = "制表﹕" & Erp_XM
   
    Frm_Progress.ProgressBar1.Value = 20
    Frm_Progress.Label2.Caption = "Finished 20%"
   
    For i = 1 To spd.DataColCnt
'        yi = Chr(96 + i)
        spd.GetText i, 0, Lhead
'        wkst.Range(yi & "3") = CStr(Lhead)
        wkst.Cells(3, i).Value = CStr(Lhead)
       
        Frm_Progress.ProgressBar1.Value = Frm_Progress.ProgressBar1.Value + CInt(78 / spd.DataColCnt) - 1
        Frm_Progress.Label2.Caption = "Finished " & CStr(Frm_Progress.ProgressBar1.Value) & "%"
       
    Next
   
    On Error Resume Next
    With wkst.PageSetup
        .PrintHeadings = False
        .LeftMargin = Application.InchesToPoints(0.2)
        .RightMargin = Application.InchesToPoints(0.2)
        .TopMargin = Application.InchesToPoints(0.2)
        .BottomMargin = Application.InchesToPoints(0.2)
        .HeaderMargin = Application.InchesToPoints(0)
        .FooterMargin = Application.InchesToPoints(0)
    End With
   
    With app.ActiveWindow
            .DisplayGridlines = True
            .GridlineColorIndex = xlAutomatic
    End With
   
    app.Application.ReferenceStyle = xlA1
   
    Frm_Progress.ProgressBar1.Value = 100
    Frm_Progress.Label2.Caption = "Finished 100%"
    Unload Frm_Progress
   
    app.ActiveWorkbook.Save
   
'    app.OnKey "^a", "" '屏蔽Ctrl+a
'    app.OnKey "^c", "" '屏蔽Ctrl+c
'    app.Visible = True
'    Cells.Select
'    app.ActiveWindow.SelectedSheets.PrintPreview
'    wkbk.Close False
'    Set app = Nothing
   
   
    If MsgBox("是否要打開此文件", vbYesNo, "提示") = vbYes Then
        app.Visible = True
        Set app = Nothing
    Else
        app.Workbooks.Close
        Set app = Nothing
    End If
    Exit Sub
Errorhandler:
    app.Workbooks.Close
    Set app = Nothing
    MsgBox "文件導出失敗", vbInformation, "提示"
    Unload Frm_Progress
End Sub

Public Function ExporToExcel(strOpen As String, headStr As String)
'*********************************************************
'* 名稱：ExporToExcel
'* 功能：SQL導出資料到EXCEL
'* 用法：ExporToExcel(sql查詢字串)
'* 參數﹕strOpen(SQL 查詢字符串)﹐headStr(報表標題名)
'*********************************************************
Dim Rs_Data As New ADODB.Recordset
Dim Irowcount As Long
Dim Icolcount As Long
   
    Dim xlApp As New Excel.Application
    Dim xlBook As Excel.Workbook
    Dim xlSheet As Excel.Worksheet
    Dim xlQuery As Excel.QueryTable
   
    With Rs_Data
        If .State = adStateOpen Then
            .Close
        End If
        .ActiveConnection = Cnn
        .CursorLocation = adUseClient
        .CursorType = adOpenStatic
        .LockType = adLockReadOnly
        .Source = strOpen
        .Open
    End With
    With Rs_Data
        If .recordcount < 1 Then
            MsgBox ("沒有記錄!")
            Exit Function
        End If
        '記錄總數
        Irowcount = .recordcount
        '欄位總數
        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 = True
   
    '添加查詢語句，導入EXCEL資料
    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 = "黑體"
        '設標題?黑體字
        .Range(.Cells(1, 1), .Cells(1, Icolcount)).Font.Bold = True
        '標題字體加粗
        .Range(.Cells(1, 1), .Cells(Irowcount + 1, Icolcount)).Borders.LineStyle = xlContinuous
        '設表格邊框樣式
    End With
   
    With xlSheet.PageSetup
        .LeftHeader = "" & Chr(10) & "&""楷體_GB2312,常規""&10公司名稱：可寫公司名稱"   ' & Gsmc
        .CenterHeader = "&""楷體_GB2312,黑體""&14 " & headStr & " &""宋體,常規""" & Chr(10) & "&""楷體_GB2312,常規""&10日 期：" & GetServerDate
'        .RightHeader = "" & Chr(10) & "&""楷體_GB2312,常規""&10單位：倉庫"
        .LeftFooter = "&""楷體_GB2312,常規""&10制表人："
        .CenterFooter = "&""楷體_GB2312,常規""&10制表日期：" & GetServerDate
        .RightFooter = "&""楷體_GB2312,常規""&10第&P頁 共&N頁"
    End With
   
    xlApp.Application.Visible = True
    Set xlApp = Nothing  '"交還控制給Excel
    Set xlBook = Nothing
    Set xlSheet = Nothing
End Function

'調用       

   ExportExcel "test2", CommonDialog1, spd  'spd為spread控件名

 sqlstr = "select a from test"

   ExporToExcel sqlstr, "test"