[此贴子已经被作者于2020-8-23 20:41编辑过]
Private Sub Command7_Click() Dim Conn1 As New ADODB.Connection Dim Rs1 As New ADODB.Recordset 'On Error GoTo ErrDlog Dim sql1 As String, cnStr1 As String Dim exPath As String, Biao As String exPath = App.Path & "\Exc.xls" 'excel文件名称 cnStr1 = "Provider=Microsoft.Jet.OLEDB.4.0;Data Source=" & exPath & ";Persist Security Info=False;Extended Properties='Excel 8.0;HDR=Yes'" Biao = "123" '表名称 Conn1.Open cnStr1 sql1 = "select * from [" & Biao & "$]" Rs1.Open sql1, Conn1, adOpenStatic, adLockOptimistic For i = 1 To ListView1.ListItems.Count Rs1.AddNew Rs1.Fields(0) = ListView1.ListItems(i).Text Rs1.Fields(1) = ListView1.ListItems(i).SubItems(1) Rs1.Fields(2) = ListView1.ListItems(i).SubItems(2) Rs1.Fields(3) = ListView1.ListItems(i).SubItems(3) Rs1.Fields(4) = ListView1.ListItems(i).SubItems(4) Rs1.Fields(5) = ListView1.ListItems(i).SubItems(5) Rs1.Update Next MsgBox "数据导出完成!", , "提示" Rs1.Close Conn1.Close End Sub
Private Sub Command8_Click() Dim Exlpath As String Exlpath = App.Path & "\exl.csv" Open Exlpath For Output As #1 Print #1, "流水单号,姓名,金额,村组,金额类型,填表日期" For i = 1 To ListView1.ListItems.Count Print #1, ListView1.ListItems(i).Text & "," & ListView1.ListItems(i).SubItems(1) & "," & ListView1.ListItems(i).SubItems(2) & "," & ListView1.ListItems(i).SubItems(3) & "," & ListView1.ListItems(i).SubItems(4) & "," & ListView1.ListItems(i).SubItems(5) Next Close #1 MsgBox "数据导出完成!", , "提示" End Sub
[此贴子已经被作者于2020-8-25 12:06编辑过]
[此贴子已经被作者于2020-8-25 17:36编辑过]
Private Sub reOutExcel(scr As Recordset, fileName As String) Dim xlApp As Excel.Application Dim xlBook As Excel.Workbook Dim xlSheet As Excel.Worksheet Dim r As Long Dim c As Long Set xlApp = CreateObject("Excel.Application") '创建EXCEL对象 If Dir(App.Path & "\" & fileName) = "" Then Set xlBook = xlApp.Workbooks.Add() xlBook.SaveAs App.Path & "\" & fileName Else Set xlBook = xlApp.Workbooks.Open(App.Path & "\" & fileName) End If Set xlSheet = xlBook.Worksheets("sheet1") For c = 0 To scr.Fields.Count - 1 xlSheet.Cells(1, c + 1) = scr.Fields.Item(c).Name Next scr.MoveFirst r = 1 Do While (scr.EOF <> True) For c = 0 To scr.Fields.Count - 1 xlSheet.Cells(r, c + 1) = scr.Fields(c) Next scr.MoveNext r = r + 1 Loop xlBook.Save xlBook.Close Set xlSheet = Nothing Set xlBook = Nothing xlApp.Quit Set xlApp = Nothing End Sub