Private Sub cmdExport_Click()
Dim strTemplateFile As String
Dim strFileName As String
Dim FSO As New FileSystemObject
Dim excelApp As Excel.Application
Dim excelBook As Excel.Workbook
Dim excelSheet As Excel.Worksheet
Dim lngLineNo As Long
Dim i As Long
On Error GoTo ErrHandle
strTemplateFile = gStrXlt & "\模板文件名.xls"
If Not FSO.FileExists(strTemplateFile) Then
MsgBox "模板文件不存在", vbCritical, Me.Caption
Exit Sub
End If
strFileName = gStrOther & "\新文件名" & Format(Date, "YYYYMMDD") & ".xls"
If FSO.FileExists(strFileName) Then
FSO.DeleteFile strFileName
End If
Set excelApp = CreateObject("Excel.Application")
Set excelBook = excelApp.Workbooks.Open(strTemplateFile)
Set excelSheet = excelBook.Worksheets(1)
excelApp.Visible = False
excelApp.DisplayAlerts = False '禁止Excel提示
excelApp.Columns("A:L").NumberFormatLocal = "@" '设置成文本格式
With prg
.Max = lvData.ListItems.Count
.Min = 0
.Value = 0
End With
lngLineNo = 4 '从第四行开始写
For i = 1 To lvData.ListItems.Count
excelSheet.Cells(lngLineNo, 1) = lvData.ListItems(i).SubItems(1)
excelSheet.Cells(lngLineNo, 2) = lvData.ListItems(i).SubItems(2)
excelSheet.Cells(lngLineNo, 3) = lvData.ListItems(i).SubItems(3)
excelSheet.Cells(lngLineNo, 4) = lvData.ListItems(i).SubItems(4)
excelSheet.Cells(lngLineNo, 5) = lvData.ListItems(i).SubItems(5)
lngLineNo = lngLineNo + 1
If prg.Value < prg.Max Then
prg.Value = prg.Value + 1
End If
DoEvents
Next
prg.Value = prg.Max
With excelSheet
.Range(.Cells(1, 1), Cells(lvData.ListItems.Count + 3, 5)).Borders.LineStyle = xlContinuous
.Range(.Cells(1, 1), Cells(lvData.ListItems.Count + 3, 5)).Font.Size = 9
End With
excelBook.Saved = True
excelBook.SaveAs strFileName
'关闭Excel进程
excelBook.Close
excelApp.Quit
Set excelBook = Nothing
Set excelApp = Nothing
MsgBox "导出完毕!" & vbCrLf & "文件路径:" & strFileName, vbInformation, Me.Caption
On Error GoTo 0
Exit Sub
ErrHandle:
Call gErrList("frmFenQiQiShuRpt.cmdExport_Click", Err.Description, Err.Number, True)
End Sub
Dim strTemplateFile As String
Dim strFileName As String
Dim FSO As New FileSystemObject
Dim excelApp As Excel.Application
Dim excelBook As Excel.Workbook
Dim excelSheet As Excel.Worksheet
Dim lngLineNo As Long
Dim i As Long
On Error GoTo ErrHandle
strTemplateFile = gStrXlt & "\模板文件名.xls"
If Not FSO.FileExists(strTemplateFile) Then
MsgBox "模板文件不存在", vbCritical, Me.Caption
Exit Sub
End If
strFileName = gStrOther & "\新文件名" & Format(Date, "YYYYMMDD") & ".xls"
If FSO.FileExists(strFileName) Then
FSO.DeleteFile strFileName
End If
Set excelApp = CreateObject("Excel.Application")
Set excelBook = excelApp.Workbooks.Open(strTemplateFile)
Set excelSheet = excelBook.Worksheets(1)
excelApp.Visible = False
excelApp.DisplayAlerts = False '禁止Excel提示
excelApp.Columns("A:L").NumberFormatLocal = "@" '设置成文本格式
With prg
.Max = lvData.ListItems.Count
.Min = 0
.Value = 0
End With
lngLineNo = 4 '从第四行开始写
For i = 1 To lvData.ListItems.Count
excelSheet.Cells(lngLineNo, 1) = lvData.ListItems(i).SubItems(1)
excelSheet.Cells(lngLineNo, 2) = lvData.ListItems(i).SubItems(2)
excelSheet.Cells(lngLineNo, 3) = lvData.ListItems(i).SubItems(3)
excelSheet.Cells(lngLineNo, 4) = lvData.ListItems(i).SubItems(4)
excelSheet.Cells(lngLineNo, 5) = lvData.ListItems(i).SubItems(5)
lngLineNo = lngLineNo + 1
If prg.Value < prg.Max Then
prg.Value = prg.Value + 1
End If
DoEvents
Next
prg.Value = prg.Max
With excelSheet
.Range(.Cells(1, 1), Cells(lvData.ListItems.Count + 3, 5)).Borders.LineStyle = xlContinuous
.Range(.Cells(1, 1), Cells(lvData.ListItems.Count + 3, 5)).Font.Size = 9
End With
excelBook.Saved = True
excelBook.SaveAs strFileName
'关闭Excel进程
excelBook.Close
excelApp.Quit
Set excelBook = Nothing
Set excelApp = Nothing
MsgBox "导出完毕!" & vbCrLf & "文件路径:" & strFileName, vbInformation, Me.Caption
On Error GoTo 0
Exit Sub
ErrHandle:
Call gErrList("frmFenQiQiShuRpt.cmdExport_Click", Err.Description, Err.Number, True)
End Sub