Option Explicit

Private 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 Long
Dim strHead() As String '记录的字段名称
Dim xlsApp As Object
Dim xlsBook As Object
Dim xlsSheet As Object
Dim i As Integer

'报表标题，表格字段名，表格内容的地址,表头和表格的合地址,记录所在列的地址
Dim strTitleAddress As String
Dim strHeadAddress As String
Dim strBorderAddress As String
Dim strHeadAndBorderAddress As String
Dim strTitleAndHeadAddress As String
Dim 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.Count
lRecordCount = rsObject.RecordCount


'计算各个部分的地址方便引用
'列是 26 进制的数据，两位，第一位为 LfieldsCount/26,第二位为 lFieldsCount mod 26
If lFieldsCount < 26 Then
strCol = Chr(Asc("a") + lFieldsCount - 1)
Else
strCol = Chr(Asc("a") + (Int(lFieldsCount / 26)) - 1) & Chr(Asc("a") + (lFieldsCount Mod 26) - 1)
End If

strTitleAddress = 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
.merge
End 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 = -4105
End With

'写入标题内容
xlsSheet.Name = strTitle
xlsSheet.range(strTitleAddress) = strTitle

'写表头内容
ReDim strHead(1 To lFieldsCount)
For i = 1 To lFieldsCount
strHead(i) = rsObject.Fields(i - 1).Name
Next i

xlsSheet.range(strHeadAddress).Value = strHead
xlsSheet.range("A3").CopyFromRecordset rsObject

With xlsSheet.cells
If ReplaceZero Then
'删除所有为"0"的单元格,也可以指定不删除（不删除可以方便比较）
.Replace What:="0", Replacement:="", LookAt:=1, SearchOrder _
:=1, MatchCase:=False
End If
End With


' '每页都有标题
' 必须要安装了打印机才能进行此操作
If Printers.Count > 0 Then

'如果打印机不可用这里会出错
On Error Resume Next

xlsSheet.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 = 100

End With
End If

xlsSheet.cells(2, 1).Select
Screen.MousePointer = 0

Exit Sub

ErrLab:

If Err.Number = 429 Then
MsgBox m_Msg, vbInformation, "错误"
Else
MsgBox "错误：" & Err.Description & " 错误号：" & Err.Number, vbInformation, "导出"
End If
Screen.MousePointer = 0


End Sub