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