VB 通过指定Excel模板文件进行另存为新文件操作

本文链接：https://blog.csdn.net/limlimlim/article/details/8818176

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