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,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