0

我在 VB 6.0 中将 ListView 控件的所有数据导出到 Excel 工作表。

我的代码如下：

Private Sub cmdExport_Click()

'general
Dim objExcel As New Excel.Application

 Dim objExcelSheet As Excel.Worksheet
'-----------------------------------

'check whether data is there
 If LstLog.ListItems.count > 0 Then
objExcel.Workbooks.Add
Set objExcelSheet = objExcel.Worksheets.Add


For Col = 1 To LstLog.ColumnHeaders.count
    objExcelSheet.Cells(1, Col).Value = LstLog.ColumnHeaders(Col)
Next

For Row = 2 To LstLog.ListItems.count
    For Col = 1 To LstLog.ColumnHeaders.count
    If Col = 1 Then
            objExcelSheet.Cells(Row, Col).Value = LstLog.ListItems(Row).Text
    Else
            objExcelSheet.Cells(Row, Col).Value = LstLog.ListItems(Row).SubItems(Col - 1)
    End If
    Next
 Next

objExcelSheet.Columns.AutoFit
CommonDialog1.ShowOpen
A = CommonDialog1.FileName

objExcelSheet.SaveAs A & ".xls"
MsgBox "Export Completed", vbInformation, Me.Caption

objExcel.Workbooks.Open A & ".xls"
objExcel.Visible = True
'objExcel.Quit
Else
MsgBox "No data to export", vbInformation, Me.Caption
End If

End Sub

问题是 ListView 的第一行被 ListView 标题中的文本覆盖。

4

2 回答 2

1

由于某种原因，您没有复制所有行。尝试这个：

For Row = 2 To LstLog.ListItems.count + 1
    For Col = 1 To LstLog.ColumnHeaders.count
    If Col = 1 Then
            objExcelSheet.Cells(Row, Col).Value = LstLog.ListItems(Row - 1).Text
    Else
            objExcelSheet.Cells(Row, Col).Value = LstLog.ListItems(Row - 1).SubItems(Col - 1)
    End If
    Next
 Next Row
于 2013-04-12T09:15:36.677 回答
0

试试这个希望这会帮助你

Function Export2XLS(sQuery As String)
    Dim oExcel          As Object
    Dim oExcelWrkBk     As Object
    Dim oExcelWrSht     As Object
    Dim bExcelOpened    As Boolean
    Dim db              As DAO.Database
    Dim rs              As DAO.Recordset
    Dim iCols           As Integer
    Const xlCenter = -4108

    'Start Excel
    On Error Resume Next
    Set oExcel = GetObject(, "Excel.Application")    'Bind to existing instance of Excel

    If Err.Number <> 0 Then    'Could not get instance of Excel, so create a new one
        Err.Clear
        On Error GoTo Error_Handler
        Set oExcel = CreateObject("excel.application")
        bExcelOpened = False
    Else    'Excel was already running
        bExcelOpened = True
    End If
    On Error GoTo Error_Handler
    oExcel.ScreenUpdating = False
    oExcel.Visible = False   'Keep Excel hidden until we are done with our manipulation
    Set oExcelWrkBk = oExcel.Workbooks.Add()    'Start a new workbook
    Set oExcelWrSht = oExcelWrkBk.Sheets(1)

    'Open our SQL Statement, Table, Query
    Set db = CurrentDb
    Set rs = db.OpenRecordset(sQuery, dbOpenSnapshot)
    With rs
        If .RecordCount <> 0 Then
            'Build our Header
            For iCols = 0 To rs.Fields.Count - 1
                oExcelWrSht.Cells(1, iCols + 1).Value = rs.Fields(iCols).Name
            Next
            With oExcelWrSht.Range(oExcelWrSht.Cells(1, 1), _
                                   oExcelWrSht.Cells(1, rs.Fields.Count))
                .Font.Bold = True
                .Font.ColorIndex = 2
                .Interior.ColorIndex = 1
                .HorizontalAlignment = xlCenter
            End With
            oExcelWrSht.Range(oExcelWrSht.Cells(1, 1), _
                              oExcelWrSht.Cells(1, rs.Fields.Count)).Columns.AutoFit    'Resize our Columns based on the headings
            'Copy the data from our query into Excel
            oExcelWrSht.Range("A2").CopyFromRecordset rs
            oExcelWrSht.Range("A1").Select  'Return to the top of the page
        Else
            MsgBox "There are no records returned by the specified queries/SQL statement.", vbCritical + vbOKOnly, "No data to generate an Excel spreadsheet with"
            GoTo Error_Handler_Exit
        End If
    End With

    '    oExcelWrkBk.Close True, sFileName 'Save and close the generated workbook

    '    'Close excel if is wasn't originally running
    '    If bExcelOpened = False Then
    '        oExcel.Quit
    '    End If

Error_Handler_Exit:
    On Error Resume Next
    oExcel.Visible = True   'Make excel visible to the user
    rs.Close
    Set rs = Nothing
    Set db = Nothing
    Set oExcelWrSht = Nothing
    Set oExcelWrkBk = Nothing
    oExcel.ScreenUpdating = True
    Set oExcel = Nothing
    Exit Function

Error_Handler:
    MsgBox "The following error has occured" & vbCrLf & vbCrLf & _
           "Error Number: " & Err.Number & vbCrLf & _
           "Error Source: Export2XLS" & vbCrLf & _
           "Error Description: " & Err.Description _
           , vbOKOnly + vbCritical, "An Error has Occured!"
    Resume Error_Handler_Exit
End Function
于 2015-04-06T10:45:55.440 回答