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 ThenMe.TxbTitle.Visible = TrueMe.TxbTitle = "请输入保存的文件名"ElseMe.TxbTitle.Visible = FalseEnd If
End SubPrivate Sub CmdChoosePath_Click()With Application.FileDialog(msoFileDialogFolderPicker)If .Show = -1 ThendataFolder = .SelectedItems(1)ElseExit SubEnd IfEnd WithMe.TxbTargetPath = dataFolder
End Sub

 3.确认按钮

Private Sub CmdConfirm_Click()On Error Resume NextApplication.ScreenUpdating = FalseSet FileSystem = CreateObject("Scripting.FileSystemObject")Set folder = FileSystem.GetFolder(dataFolder)If Me.TxbTargetPath = "" ThenMsgBox "请选择待合并文件所在文件夹！"Exit SubElseIf FileSystem.folderexists(Me.TxbTargetPath) ThendataFolder = Me.TxbTargetPathElseMsgBox "源文件夹不存在，请重新选择！"Exit SubEnd IfEnd IfIf Me.TxtSavePath = "" ThenMsgBox "请选择合并文件保存文件夹！"Exit SubElseIf FileSystem.folderexists(Me.TxtSavePath) ThensavePath = Me.TxtSavePathElseMsgBox "目标文件夹不存在，请重新选择！"Exit SubEnd IfEnd IfIf Not wContinue("即将合并文件！") Then Exit SubIf Me.OptExcel ThenCall CombineExcelElseIf Me.OptPDF ThenCall CombinePDFElseIf Me.OptWord ThenCall CombineWordElseIf Me.OptPictureToPDF ThenCall CombinePicturesToPDFEnd IfApplication.ScreenUpdating = TrueShell "explorer.exe " & savePath, vbMaximizedFocusUnload Me
End Sub

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

Private Sub CmdExit_Click()Unload Me
End SubPrivate Sub CmdChooseSavePath_Click()With Application.FileDialog(msoFileDialogFolderPicker)If .Show = -1 ThensavePath = .SelectedItems(1)ElseExit SubEnd IfEnd WithMe.TxtSavePath = savePath
End SubPrivate Sub UserForm_Initialize()Me.TxtSavePath = ThisWorkbook.pathsavePath = Me.TxtSavePath
End Sub

5. 合并EXCEL文件

Private Sub CombineExcel()Dim CombineWs As WorksheetDim lastRow As Integer, lastCol As IntegerDim rng As RangeDim ws As WorksheetDim wb As Workbook, CombineWb As WorkbookIf Me.CkbName ThenIf Me.TxbTitle = "" ThenMsgBox "请输入保存的文件名"Exit SubEnd IfSaveFile = savePath & "\" & Me.TxbTitle & ".xlsx"ElseSaveFile = savePath & "\合并" & Format(Now, "YYYYMMDDhhmmss") & ".xlsx"End IfblnCkb = Me.CkbTitleSet CombineWb = Workbooks.AddOn Error Resume NextSet CombineWs = CombineWb.Worksheets("合并")On Error GoTo 0If CombineWs Is Nothing ThenSet CombineWs = CombineWb.Worksheets.AddCombineWs.Name = "合并"ElseCombineWs.Cells.ClearEnd IfFor Each file In folder.FilesFileExtn = LCase(Right(file.Name, Len(file.Name) - InStrRev(file.Name, ".") + 1))If FileExtn = ".xlsx" Or FileExtn = ".xls" ThenSet wb = Workbooks.Open(file.path)For Each ws In wb.SheetsIf t = 0 Thenws.UsedRange.Copy CombineWs.Cells(1, 1)ElselastRow = ws.Cells(Rows.Count, 1).End(xlUp).RowlastCol = ws.Cells(1, Columns.Count).End(xlToLeft).ColumnIf blnCkb ThenSet rng = ws.Range(Cells(2, 1), Cells(lastRow, lastCol))ElseSet rng = ws.Range(Cells(1, 1), Cells(lastRow, lastCol))End Ifrng.Copy CombineWs.Cells(CombineWs.Cells(Rows.Count, 1).End(xlUp).Row + 1, 1)End Ift = t + 1Nextwb.Close savechanges:=FalseEnd IfNextCombineWb.SaveAs SaveFileCombineWb.CloseSet CombineWb = NothingMsgBox "成功合并【" & t & "】个明细表！"
End Sub

6.合并PDF文件 

Private Sub CombinePDF()Dim SinglePDF As Object, CombinePDF As ObjectDim pdfName As StringDim pageNum As LongIf Me.CkbName ThenIf Me.TxbTitle = "" ThenMsgBox "请输入保存的文件名"Exit SubEnd IfSaveFile = savePath & "\" & Me.TxbTitle & ".PDF"ElseSaveFile = savePath & "\合并" & Format(Now, "YYYYMMDDhhmmss") & ".PDF"End IfSet SinglePDF = CreateObject("AcroExch.PDDoc")Set CombinePDF = CreateObject("AcroExch.PDDoc")CombinePDF.Createt = 0For Each file In folder.FilesFileExtn = LCase(Right(file.Name, Len(file.Name) - InStrRev(file.Name, ".") + 1))If FileExtn = ".pdf" ThenIf SinglePDF.Open(file) ThenpageNum = SinglePDF.GetNumPagesCombinePDF.InsertPages CombinePDF.GetNumPages - 1, SinglePDF, 0, pageNum, 0SinglePDF.Closet = t + 1End IfEnd IfNextCombinePDF.Save PDSaveFull, SaveFileCombinePDF.CloseSet SinglePDF = NothingSet CombinePDF = NothingMsgBox "成功合并【" & t & "】个文件！"
End Sub

 7.合并WORD文件

Private Sub CombineWord()Dim WordApp As ObjectDim WordDoc As ObjectDim wdRng As ObjectIf Me.CkbName ThenIf Me.TxbTitle = "" ThenMsgBox "请输入保存的文件名"Exit SubEnd IfSaveFile = savePath & "\" & Me.TxbTitle & ".docx"ElseSaveFile = savePath & "\合并" & Format(Now, "YYYYMMDDhhmmss") & ".docx"End IfSet WordApp = CreateObject("Word.Application")WordApp.Visible = FalseSet WordDoc = WordApp.Documents.Addt = 0For Each file In folder.FilesFileExtn = LCase(Right(file.Name, Len(file.Name) - InStrRev(file.Name, ".") + 1))If FileExtn = ".doc" Or FileExtn = ".docx" ThenWordDoc.Application.Selection.InsertFile file.path, "", False, FalseWordDoc.Application.Selection.EndKey 6If Me.CkbPageBreak ThenWordDoc.Application.Selection.InsertBreak Type:=7 ' wdPageBreakEnd Ift = t + 1End IfNextWordDoc.SaveAs2 SaveFile, 16WordDoc.CloseWordApp.QuitSet WordDoc = NothingSet WordApp = NothingMsgBox "成功合并【" & t & "】个文件！"
End Sub

8.合并图片文件为PDF 

Private Sub CombinePicturesToPDF()Dim SinglePDF As Object, CombinePDF As ObjectDim pdfName As StringDim pageNum As LongIf Me.CkbName ThenIf Me.TxbTitle = "" ThenMsgBox "请输入保存的文件名"Exit SubEnd IfSaveFile = savePath & "\" & Me.TxbTitle & ".PDF"ElseSaveFile = savePath & "\合并" & Format(Now, "YYYYMMDDhhmmss") & ".PDF"End IftempFolder = Environ("TEMP")Set SinglePDF = CreateObject("AcroExch.PDDoc")Set CombinePDF = CreateObject("AcroExch.PDDoc")CombinePDF.Createt = 0For Each file In folder.FilesFileExtn = 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" ThenpdfName = ConvertPicToPDF(file, tempFolder)If SinglePDF.Open(pdfName) ThenpageNum = SinglePDF.GetNumPagesCombinePDF.InsertPages CombinePDF.GetNumPages - 1, SinglePDF, 0, pageNum, 0SinglePDF.CloseEnd Ift = t + 1End IfNextCombinePDF.Save PDSaveFull, SaveFileCombinePDF.CloseSet SinglePDF = NothingSet CombinePDF = NothingMsgBox "成功合并【" & t & "】个文件！"
End Sub

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

Function ConvertPicToPDF(picName, pdfPath) As StringDim acroAVDoc As ObjectDim newPDF As ObjectDim acroApp As ObjectDim pdfName As StringSet acroApp = CreateObject("AcroExch.App")acroApp.ShowSet acroAVDoc = CreateObject("AcroExch.AVDoc")FileExtn = LCase(Right(picName, Len(picName) - InStrRev(picName, ".") + 1))'StopIf FileExtn Like ".jpg" Or FileExtn Like ".jpeg" Or FileExtn Like ".png" Or FileExtn Like ".bmp" ThenpdfName = Mid(picName, InStrRev(picName, "\") + 1, InStrRev(picName, ".") - InStrRev(picName, "\") - 1) & "_" & Format(Now, "YYYYMMDDhhmmss") & ".pdf"acroAVDoc.Open picName, "Acrobat"Do Until acroAVDoc.IsValidDoEventsLoopSet newPDF = acroAVDoc.GetPDDocnewPDF.Save 1, pdfPath & "\" & pdfName ' 1 is AcroAVDocSaveAsType.acSaveFullnewPDF.CloseEnd IfacroAVDoc.Close 1ConvertPicToPDF = pdfPath & "\" & pdfName
End Function
Function wContinue(Msg) As Boolean'确认继续函数Dim Config As LongDim a As LongConfig = vbYesNo + vbQuestion + vbDefaultButton2Ans = MsgBox(Msg & Chr(10) & Chr(10) & "是(Y)继续?" & Chr(10) & Chr(10) & "否(N)退出！", Config)wContinue = Ans = vbYes
End Function