VBA学习(76)：文件合并神器/代码

1.定义变量

Dim savePath As String
Dim SaveFile As String
Dim dataFolder As String
Dim FileSystem As Object
Dim folder As Object
Dim FileExtn As String
Dim t As Integer
Dim blnCkb As Boolean

2.自定保存文件名、选择待合并文件所在文件夹

Private Sub CkbName_Click()
    If Me.CkbName Then
        Me.TxbTitle.Visible = True
        Me.TxbTitle = "请输入保存的文件名"
    Else
        Me.TxbTitle.Visible = False
    End If
End Sub

Private Sub CmdChoosePath_Click()
    With Application.FileDialog(msoFileDialogFolderPicker)
        If .Show = -1 Then
            dataFolder = .SelectedItems(1)
        Else
            Exit Sub
        End If
    End With
    Me.TxbTargetPath = dataFolder
End Sub

 3.确认按钮

Private Sub CmdConfirm_Click()
    On Error Resume Next
    Application.ScreenUpdating = False
    Set FileSystem = CreateObject("Scripting.FileSystemObject")
    Set folder = FileSystem.GetFolder(dataFolder)

    If Me.TxbTargetPath = "" Then
        MsgBox "请选择待合并文件所在文件夹！"
        Exit Sub
    Else
        If FileSystem.folderexists(Me.TxbTargetPath) Then
            
            dataFolder = Me.TxbTargetPath
        Else
            MsgBox "源文件夹不存在，请重新选择！"
            Exit Sub
        End If
        
    End If
    If Me.TxtSavePath = "" Then
        MsgBox "请选择合并文件保存文件夹！"
        Exit Sub
    Else
        If FileSystem.folderexists(Me.TxtSavePath) Then
             savePath = Me.TxtSavePath
        Else
            MsgBox "目标文件夹不存在，请重新选择！"
            Exit Sub
        End If
    End If
    If Not wContinue("即将合并文件！") Then Exit Sub
    If Me.OptExcel Then
        Call CombineExcel
    ElseIf Me.OptPDF Then
        Call CombinePDF
    ElseIf Me.OptWord Then
        Call CombineWord
    ElseIf Me.OptPictureToPDF Then
        Call CombinePicturesToPDF
    End If
    Application.ScreenUpdating = True
    Shell "explorer.exe " & savePath, vbMaximizedFocus
    Unload Me
End Sub

4.退出、选择保存文件夹、窗体初始化 

Private Sub CmdExit_Click()
    Unload Me
End Sub

Private Sub CmdChooseSavePath_Click()
    With Application.FileDialog(msoFileDialogFolderPicker)
        If .Show = -1 Then
            savePath = .SelectedItems(1)
        Else
            Exit Sub
        End If
    End With
    Me.TxtSavePath = savePath
End Sub

Private Sub UserForm_Initialize()
    Me.TxtSavePath = ThisWorkbook.path
    savePath = Me.TxtSavePath
End Sub

5. 合并EXCEL文件

Private Sub CombineExcel()
    Dim CombineWs As Worksheet
    Dim lastRow As Integer, lastCol As Integer
    Dim rng As Range
    Dim ws As Worksheet
    Dim wb As Workbook, CombineWb As Workbook
    If Me.CkbName Then
        If Me.TxbTitle = "" Then
            MsgBox "请输入保存的文件名"
            Exit Sub
        End If
        SaveFile = savePath & "\" & Me.TxbTitle & ".xlsx"
    Else
        SaveFile = savePath & "\合并" & Format(Now, "YYYYMMDDhhmmss") & ".xlsx"
    End If
    blnCkb = Me.CkbTitle
    Set CombineWb = Workbooks.Add
    On Error Resume Next
    Set CombineWs = CombineWb.Worksheets("合并")
    On Error GoTo 0
    If CombineWs Is Nothing Then
        Set CombineWs = CombineWb.Worksheets.Add
        CombineWs.Name = "合并"
    Else
        CombineWs.Cells.Clear
    End If
    For Each file In folder.Files
        FileExtn = LCase(Right(file.Name, Len(file.Name) - InStrRev(file.Name, ".") + 1))
        If FileExtn = ".xlsx" Or FileExtn = ".xls" Then
            Set wb = Workbooks.Open(file.path)
            For Each ws In wb.Sheets
                If t = 0 Then
                    ws.UsedRange.Copy CombineWs.Cells(1, 1)
                Else
                    lastRow = ws.Cells(Rows.Count, 1).End(xlUp).Row
                    lastCol = ws.Cells(1, Columns.Count).End(xlToLeft).Column
                    If blnCkb Then
                        Set rng = ws.Range(Cells(2, 1), Cells(lastRow, lastCol))
                    Else
                        Set rng = ws.Range(Cells(1, 1), Cells(lastRow, lastCol))
                    End If
                    rng.Copy CombineWs.Cells(CombineWs.Cells(Rows.Count, 1).End(xlUp).Row + 1, 1)
                End If
                t = t + 1
            Next
            wb.Close savechanges:=False
        End If
    Next
    CombineWb.SaveAs SaveFile
    CombineWb.Close
    Set CombineWb = Nothing
    MsgBox "成功合并【" & t & "】个明细表！"
End Sub

6.合并PDF文件 

Private Sub CombinePDF()
    Dim SinglePDF As Object, CombinePDF As Object
    Dim pdfName As String
    Dim pageNum As Long
    
    If Me.CkbName Then
        If Me.TxbTitle = "" Then
            MsgBox "请输入保存的文件名"
            Exit Sub
        End If
        SaveFile = savePath & "\" & Me.TxbTitle & ".PDF"
    Else
        SaveFile = savePath & "\合并" & Format(Now, "YYYYMMDDhhmmss") & ".PDF"
    End If
    
    Set SinglePDF = CreateObject("AcroExch.PDDoc")
    Set CombinePDF = CreateObject("AcroExch.PDDoc")
    
    CombinePDF.Create
    t = 0
    For Each file In folder.Files
        FileExtn = LCase(Right(file.Name, Len(file.Name) - InStrRev(file.Name, ".") + 1))
        If FileExtn = ".pdf" Then
            If SinglePDF.Open(file) Then
                pageNum = SinglePDF.GetNumPages
                CombinePDF.InsertPages CombinePDF.GetNumPages - 1, SinglePDF, 0, pageNum, 0
                SinglePDF.Close
                t = t + 1
            End If
        End If
    Next
    CombinePDF.Save PDSaveFull, SaveFile
    CombinePDF.Close
    Set SinglePDF = Nothing
    Set CombinePDF = Nothing
    
    MsgBox "成功合并【" & t & "】个文件！"
End Sub

 7.合并WORD文件

Private Sub CombineWord()
    Dim WordApp As Object
    Dim WordDoc As Object
    Dim wdRng As Object
    
    If Me.CkbName Then
        If Me.TxbTitle = "" Then
            MsgBox "请输入保存的文件名"
            Exit Sub
        End If
        SaveFile = savePath & "\" & Me.TxbTitle & ".docx"
    Else
        SaveFile = savePath & "\合并" & Format(Now, "YYYYMMDDhhmmss") & ".docx"
    End If
    Set WordApp = CreateObject("Word.Application")
    WordApp.Visible = False
    Set WordDoc = WordApp.Documents.Add
    t = 0
    For Each file In folder.Files
        FileExtn = LCase(Right(file.Name, Len(file.Name) - InStrRev(file.Name, ".") + 1))
        If FileExtn = ".doc" Or FileExtn = ".docx" Then
            WordDoc.Application.Selection.InsertFile file.path, "", False, False
            WordDoc.Application.Selection.EndKey 6
            If Me.CkbPageBreak Then
                WordDoc.Application.Selection.InsertBreak Type:=7 ' wdPageBreak
            End If
            t = t + 1
        End If
    Next
    WordDoc.SaveAs2 SaveFile, 16
    WordDoc.Close
    WordApp.Quit
    
    Set WordDoc = Nothing
    Set WordApp = Nothing
    
    MsgBox "成功合并【" & t & "】个文件！"
End Sub

8.合并图片文件为PDF 

Private Sub CombinePicturesToPDF()
    Dim SinglePDF As Object, CombinePDF As Object
    Dim pdfName As String
    Dim pageNum As Long
    If Me.CkbName Then
        If Me.TxbTitle = "" Then
            MsgBox "请输入保存的文件名"
            Exit Sub
        End If
        SaveFile = savePath & "\" & Me.TxbTitle & ".PDF"
    Else
        SaveFile = savePath & "\合并" & Format(Now, "YYYYMMDDhhmmss") & ".PDF"
    End If
    tempFolder = Environ("TEMP")
    Set SinglePDF = CreateObject("AcroExch.PDDoc")
    Set CombinePDF = CreateObject("AcroExch.PDDoc")
    CombinePDF.Create
    t = 0
    For Each file In folder.Files
        FileExtn = LCase(Right(file.Name, Len(file.Name) - InStrRev(file.Name, ".") + 1))
        If FileExtn Like ".jpg" Or FileExtn Like ".jpeg" Or FileExtn Like ".png" Or FileExtn Like ".bmp" Then
        pdfName = ConvertPicToPDF(file, tempFolder)
            If SinglePDF.Open(pdfName) Then
                pageNum = SinglePDF.GetNumPages
                CombinePDF.InsertPages CombinePDF.GetNumPages - 1, SinglePDF, 0, pageNum, 0
                SinglePDF.Close
            End If
            t = t + 1
        End If
    Next
    
    CombinePDF.Save PDSaveFull, SaveFile
    CombinePDF.Close
    Set SinglePDF = Nothing
    Set CombinePDF = Nothing
        MsgBox "成功合并【" & t & "】个文件！"
End Sub

9.自定义函数取得图片转PDF文件名、确认继续 

Function ConvertPicToPDF(picName, pdfPath) As String
    Dim acroAVDoc As Object
    Dim newPDF As Object
    Dim acroApp As Object
    Dim pdfName As String
    Set acroApp = CreateObject("AcroExch.App")
    acroApp.Show
    Set acroAVDoc = CreateObject("AcroExch.AVDoc")
    FileExtn = LCase(Right(picName, Len(picName) - InStrRev(picName, ".") + 1))
    'Stop
    If FileExtn Like ".jpg" Or FileExtn Like ".jpeg" Or FileExtn Like ".png" Or FileExtn Like ".bmp" Then
        pdfName = Mid(picName, InStrRev(picName, "\") + 1, InStrRev(picName, ".") - InStrRev(picName, "\") - 1) & "_" & Format(Now, "YYYYMMDDhhmmss") & ".pdf"
        acroAVDoc.Open picName, "Acrobat"
        Do Until acroAVDoc.IsValid
            DoEvents
        Loop
        Set newPDF = acroAVDoc.GetPDDoc
        newPDF.Save 1, pdfPath & "\" & pdfName ' 1 is AcroAVDocSaveAsType.acSaveFull
        newPDF.Close
    End If
    acroAVDoc.Close 1
    ConvertPicToPDF = pdfPath & "\" & pdfName
End Function
Function wContinue(Msg) As Boolean
    '确认继续函数
    Dim Config As Long
    Dim a As Long
    Config = vbYesNo + vbQuestion + vbDefaultButton2
    Ans = MsgBox(Msg & Chr(10) & Chr(10) & "是(Y)继续?" & Chr(10) & Chr(10) & "否(N)退出！", Config)
    wContinue = Ans = vbYes
End Function