Listview中的数导入到excel表格中

Question

Listview中的数导入到excel表格中, 要用户选择路径保存！

Answer 1

2.2 程式碼摘要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 = TrueExitFunction:    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

Answer 2

http://www.microsoft.com/china/community/Column/32.mspx
VB6 中将数据导出到 Excel 提速之法
看老大写的