雁滩高清摄像头:Listview导出EXCEL功能模块007

 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
           
          '   询问使用者汇出范围。
          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