Option ExplicitPrivate Const m_Msg = "此功能需要Microsoft Excel 支持,请先安装 Office ！"Private Const M_DEUBG = False'---------------------------------------------------------------------'导出列表到Excel'普通的模板，'作者：甲甲虫'Accept: rsobject , the recordset what need export' rstitlle , the report's title' replaceZero , replace the zeroCell in the report'----------------------------------------------------------------------Public Sub ExportToExcel(strTitle As String, rsObject As Recordset, Optional ByVal ReplaceZero As Boolean = False)'表中字段的个数，记录个数Dim lFieldsCount As Long, lRecordCount As LongDim strHead() As String '记录的字段名称Dim xlsApp As ObjectDim xlsBook As ObjectDim xlsSheet As ObjectDim i As Integer'报表标题，表格字段名，表格内容的地址,表头和表格的合地址,记录所在列的地址Dim strTitleAddress As StringDim strHeadAddress As StringDim strBorderAddress As StringDim strHeadAndBorderAddress As StringDim strTitleAndHeadAddress As StringDim strCol As String '列的标志On Error GoTo ErrLab:Screen.MousePointer = 11'创建一个Excel进程Set xlsApp = CreateObject("Excel.Application")xlsApp.Visible = True'创建工作簿Set xlsBook = xlsApp.Workbooks.Add'创建工作表Set xlsSheet = xlsBook.Worksheets(1)'列的长度'表中数据的个数lFieldsCount = rsObject.Fields.CountlRecordCount = rsObject.RecordCount'计算各个部分的地址方便引用'列是 26 进制的数据，两位，第一位为 LfieldsCount/26,第二位为 lFieldsCount mod 26If lFieldsCount < 26 ThenstrCol = Chr(Asc("a") + lFieldsCount - 1)ElsestrCol = Chr(Asc("a") + (Int(lFieldsCount / 26)) - 1) & Chr(Asc("a") + (lFieldsCount Mod 26) - 1)End IfstrTitleAddress = Trim("a1:" & strCol & "1")strHeadAddress = Trim("a2:" & strCol & "2")strBorderAddress = Trim("a3:" & strCol & 2 + lRecordCount)strHeadAndBorderAddress = Trim("a2:" & strCol & 2 + lRecordCount)strTitleAndHeadAddress = Trim("a1:" & strCol & "2")xlsSheet.cells.Font.Name = "宋体"'设置标题格式With xlsSheet.range(strTitleAddress).Font.Size = 16.mergeEnd With'设置标题和表头的格式With xlsSheet.range(strTitleAndHeadAddress).HorizontalAlignment = -4108 'xlCenter.VerticalAlignment = -4108 'xlCenter.Font.FontStyle = "加粗"End With'设置表头和记录内容部分的格式:边框，宋体，9号字体With xlsSheet.range(strHeadAndBorderAddress).Font.Size = 9.Borders.LineStyle = 1.Borders.Weight = 2.Borders.ColorIndex = -4105End With'写入标题内容xlsSheet.Name = strTitlexlsSheet.range(strTitleAddress) = strTitle'写表头内容ReDim strHead(1 To lFieldsCount)For i = 1 To lFieldsCountstrHead(i) = rsObject.Fields(i - 1).NameNext ixlsSheet.range(strHeadAddress).Value = strHeadxlsSheet.range("A3").CopyFromRecordset rsObjectWith xlsSheet.cellsIf ReplaceZero Then'删除所有为"0"的单元格,也可以指定不删除（不删除可以方便比较）.Replace What:="0", Replacement:="", LookAt:=1, SearchOrder _:=1, MatchCase:=FalseEnd IfEnd With' '每页都有标题' 必须要安装了打印机才能进行此操作If Printers.Count > 0 Then'如果打印机不可用这里会出错On Error Resume NextxlsSheet.PageSetup.PrintTitleRows = "$2:$2"With xlsSheet.PageSetup' 上下左右的页边距.LEFTMARGIN = xlsApp.InchesToPoints(0.078740157480315).RIGHTMARGIN = xlsApp.InchesToPoints(0.196850393700787).TopMargin = xlsApp.InchesToPoints(0.078740157480315).BOTTOMMARGIN = xlsApp.InchesToPoints(0.078740157480315).HeaderMargin = xlsApp.InchesToPoints(0.078740157480315).FooterMargin = xlsApp.InchesToPoints(0.078740157480315).CenterHorizontally = True '水平居中.Zoom = 100End WithEnd IfxlsSheet.cells(2, 1).SelectScreen.MousePointer = 0Exit SubErrLab:If Err.Number = 429 ThenMsgBox m_Msg, vbInformation, "错误"ElseMsgBox "错误：" & Err.Description & " 错误号：" & Err.Number, vbInformation, "导出"End IfScreen.MousePointer = 0End Sub

评论