Public Function dhListviewToExcel( _ ByRef lvw As MSComctlLib.ListView, _ ByVal strFileName As String, _ Optional FileFormat As XlFileFormat = xlWorkbookNormal, _ Optional blnHeaders As Boolean = True) As Boolean
Dim intColCnt As Integer ' 列之计数器。 Dim intColumns As Integer ' 字段数。 Dim intRowCnt As Integer ' 栏之计数器。 Dim intStartRow As Integer ' 开始列数。 Dim intVisibleColumns() As Integer ' 表头资料。
Dim itm As ListItem
Dim lngResults As Long ' 回传数值。
Dim objExcel As Excel.Application Dim objWorkbook As Excel.Workbook Dim objWorksheet As Excel.Worksheet Dim objRange As Excel.Range
Dim strArray() As String ' 表身资料。 Dim strFileExtensionType As String ' 延伸檔名。
'------------------------------------------------ ' A0 侦测作业。 '------------------------------------------------ ' 判断 listview 是否有资料。 If lvw.SelectedItem Is Nothing Then MsgBox "表格没有任何资料。", vbOKOnly + vbInformation, "汇出失败" GoTo ExitFunction End If
Select Case LCase(lvw.ColumnHeaders(intColCnt).Tag) Case "string", "" .NumberFormat = "@" Case "number" .NumberFormat = "#,##0.00_);(#,##0.00)" .HorizontalAlignment = xlRight Case "date" .NumberFormat = "yyyy/mm/dd" .HorizontalAlignment = xlRight End Select
End With
End If Next intColCnt
'------------------------------------------------ ' D0 取得 listview 数据，置入数组。 '------------------------------------------------ ReDim strArray(1 To lvw.ListItems.Count, 1 To intColumns)
intStartRow = 2
For Each itm In lvw.ListItems
If lngResults = vbNo Or itm.Selected Then
intRowCnt = intRowCnt + 1
For intColCnt = 1 To intColumns
If intVisibleColumns(intColCnt) = 1 Then strArray(intRowCnt, 1) = itm.Text Else strArray(intRowCnt, intColCnt) = itm.SubItems(intVisibleColumns(intColCnt) - 1) End If Next intColCnt End If Next itm
'------------------------------------------------ ' E0 数组数据，置入 Excel。 '------------------------------------------------ With objWorksheet .Range(.Cells(2, 1), .Cells(2 + intRowCnt - 1, intColumns)) = strArray End With
objWorksheet.Columns.AutoFit
'------------------------------------------------ ' F0 取得延伸檔名。 ' 参阅 Excel 说明里的「Microsoft Excel 提供的档案格式转换器」 '------------------------------------------------ Select Case FileFormat Case xlSYLK strFileExtensionType = "slk" Case xlWKS strFileExtensionType = "wks" Case xlWK1, xlWK1ALL, xlWK1FMT strFileExtensionType = "wk1" Case xlCSV, xlCSVMac, xlCSVWindows strFileExtensionType = "csv" Case xlDBF2, xlDBF3, xlDBF4 strFileExtensionType = "dbf" Case xlWorkbookNormal, xlExcel2FarEast, xlExcel3, xlExcel4, xlExcel4Workbook, xlExcel5, xlExcel7, xlExcel9795 strFileExtensionType = "xls" Case xlHtml strFileExtensionType = "htm" Case xlTextMac, xlTextWindows, xlUnicodeText, xlCurrentPlatformText strFileExtensionType = "txt" Case xlTextPrinter strFileExtensionType = "prn" Case Else strFileExtensionType = "dat" End Select
'------------------------------------------------ ' G0 另存盘案。 '------------------------------------------------ If InStr(1, strFileName, ".") = 0 Then
ByRef lvw As MSComctlLib.ListView, _
ByVal strFileName As String, _
Optional FileFormat As XlFileFormat = xlWorkbookNormal, _
Optional blnHeaders As Boolean = True) As Boolean
Dim intColCnt As Integer ' 列之计数器。
Dim intColumns As Integer ' 字段数。
Dim intRowCnt As Integer ' 栏之计数器。
Dim intStartRow As Integer ' 开始列数。
Dim intVisibleColumns() As Integer ' 表头资料。
Dim itm As ListItem
Dim lngResults As Long ' 回传数值。
Dim objExcel As Excel.Application
Dim objWorkbook As Excel.Workbook
Dim objWorksheet As Excel.Worksheet
Dim objRange As Excel.Range
Dim strArray() As String ' 表身资料。
Dim strFileExtensionType As String ' 延伸檔名。
'------------------------------------------------
' A0 侦测作业。
'------------------------------------------------
' 判断 listview 是否有资料。
If lvw.SelectedItem Is Nothing Then
MsgBox "表格没有任何资料。", vbOKOnly + vbInformation, "汇出失败"
GoTo ExitFunction
End If
' 询问使用者汇出范围。
lngResults = MsgBox("只汇出选择列数之资料？", vbYesNoCancel + vbQuestion + vbDefaultButton2, "汇出选择列数")
If lngResults = vbCancel Then
GoTo ExitFunction
End If
Screen.MousePointer = vbHourglass
' 测试是否本机是否安装 Excel。
On Error Resume Next
Set objExcel = New Excel.Application
If Err.Number > 0 Then
MsgBox "本机未安装 MS Excel 。", vbOKOnly + vbCritical, "加载 Excel 失败"
GoTo ExitFunction
End If
'------------------------------------------------
' B0 Excel 相关设定作业。
'------------------------------------------------
On Error GoTo ExportToExcel_EH
' 不让使用者操作。
objExcel.Interactive = False
' 背后作业。
If objExcel.Visible = False Then
objExcel.Visible = True
End If
' 窗口最大化。
objExcel.WindowState = xlMaximized
' 设定 Wokkbook 对象。
Set objWorkbook = objExcel.Workbooks.Add
' 设定 Worksheet 对象，指向 Sheet 1。
Set objWorksheet = objWorkbook.Sheets(1)
' 设定 Range 对象，指向 Row 1。
Set objRange = objWorksheet.Rows(1)
' 设定表头字号、粗体。
objRange.Font.Size = 9
objRange.Font.Bold = True
'------------------------------------------------
' C0 Excel 表头部份相关设定作业。
'------------------------------------------------
For intColCnt = 1 To lvw.ColumnHeaders.Count
If lvw.ColumnHeaders(intColCnt).Width <> 0 Then
intColumns = intColumns + 1
ReDim Preserve intVisibleColumns(1 To intColumns)
intVisibleColumns(intColumns) = intColCnt
objRange.Cells(1, intColumns) = lvw.ColumnHeaders(intColCnt).Text
With objWorksheet.Columns(intColumns)
Select Case LCase(lvw.ColumnHeaders(intColCnt).Tag)
Case "string", ""
.NumberFormat = "@"
Case "number"
.NumberFormat = "#,##0.00_);(#,##0.00)"
.HorizontalAlignment = xlRight
Case "date"
.NumberFormat = "yyyy/mm/dd"
.HorizontalAlignment = xlRight
End Select
End With
End If
Next intColCnt
'------------------------------------------------
' D0 取得 listview 数据，置入数组。
'------------------------------------------------
ReDim strArray(1 To lvw.ListItems.Count, 1 To intColumns)
intStartRow = 2
For Each itm In lvw.ListItems
If lngResults = vbNo Or itm.Selected Then
intRowCnt = intRowCnt + 1
For intColCnt = 1 To intColumns
If intVisibleColumns(intColCnt) = 1 Then
strArray(intRowCnt, 1) = itm.Text
Else
strArray(intRowCnt, intColCnt) = itm.SubItems(intVisibleColumns(intColCnt) - 1)
End If
Next intColCnt
End If
Next itm
' E0 数组数据，置入 Excel。
'------------------------------------------------
With objWorksheet
.Range(.Cells(2, 1), .Cells(2 + intRowCnt - 1, intColumns)) = strArray
End With
objWorksheet.Columns.AutoFit
'------------------------------------------------
' F0 取得延伸檔名。
' 参阅 Excel 说明里的「Microsoft Excel 提供的档案格式转换器」
'------------------------------------------------
Select Case FileFormat
Case xlSYLK
strFileExtensionType = "slk"
Case xlWKS
strFileExtensionType = "wks"
Case xlWK1, xlWK1ALL, xlWK1FMT
strFileExtensionType = "wk1"
Case xlCSV, xlCSVMac, xlCSVWindows
strFileExtensionType = "csv"
Case xlDBF2, xlDBF3, xlDBF4
strFileExtensionType = "dbf"
Case xlWorkbookNormal, xlExcel2FarEast, xlExcel3, xlExcel4, xlExcel4Workbook, xlExcel5, xlExcel7, xlExcel9795
strFileExtensionType = "xls"
Case xlHtml
strFileExtensionType = "htm"
Case xlTextMac, xlTextWindows, xlUnicodeText, xlCurrentPlatformText
strFileExtensionType = "txt"
Case xlTextPrinter
strFileExtensionType = "prn"
Case Else
strFileExtensionType = "dat"
End Select
'------------------------------------------------
' G0 另存盘案。
'------------------------------------------------
If InStr(1, strFileName, ".") = 0 Then
' 组合文件名称。
strFileName = strFileName & "." & strFileExtensionType
' 另存盘案。
objWorksheet.SaveAs strFileName, FileFormat
End If
'------------------------------------------------
' Z0 结束作业。
'------------------------------------------------
' 关闭 Workbook。
objWorkbook.Close
' 结束 Excel 作业。
objExcel.Quit
' 载出对象变量。
Set objRange = Nothing
Set objWorksheet = Nothing
Set objWorkbook = Nothing
Set objExcel = Nothing
' 此处可以设定是否可以编辑 Excel。
' objExcel.Interactive = True
dhListviewToExcel = True
ExitFunction:
Screen.MousePointer = vbDefault
Exit Function
ExportToExcel_EH:
' 出现错误讯息。
MsgBox "汇出失败，原因如下：" & vbCrLf & vbCrLf & Err.Number & ": " & Err.Description, _
vbOKOnly + vbCritical, "汇出失败"
' 结束 Excel 作业。
objExcel.Quit
' 载出对象变量。
Set objRange = Nothing
Set objWorksheet = Nothing
Set objWorkbook = Nothing
Set objExcel = Nothing
GoTo ExitFunction
End Function