Chuyển files word sang PDF hàng loạt

Trong công việc, HR thường xuyên phải chuyển đổi hồ sơ từ Word sang PDF để đáp ứng các yêu cầu cụ thể. Khi phải xử lý hàng trăm tệp, công việc này có thể tốn rất nhiều thời gian và công sức. Bài viết này sẽ cung cấp giải pháp hữu ích nếu bạn đang gặp phải tình huống tương tự. Code này sẽ chuyển đồng loạt tất cả các file định dạng *.doc và *.docx có trong folder đó, có thể chuyển PDF cả thư mục con của thư mục gốc

============================================
Sub ConvertWordtoPDF()
    Dim FSO, selectFolder, folder, ddp As Integer, actPath
    Set FSO = CreateObject("Scripting.FileSystemObject")
    actPath = ThisDocument.Path

selectFolder = InputBox("Input Path", "Vui long nhap duong dan xu ly", actPath)

If FSO.FolderExists(selectFolder) = True Then
        Set folder = FSO.GetFolder(selectFolder)

ddp = Application.Assistant.DoAlert(UniTelex("Truy Vaasn Xuwr Lys"), _
            UniTelex("Cos quest thuw mujc con hay khoong?"), msoAlertButtonYesNo, msoAlertIconQuery, 0, 0, True)

Call ScanFilePDF(folder, ddp)

Else
        If selectFolder = "" Then
            MsgBox "Cancel"
        Else
            Application.Assistant.DoAlert UniTelex("Chus YS!"), _
            UniTelex("DDuwowfng daaxn khoong toofn taji:") & vbNewLine & "-" & selectFolder, 0, 0, 0, 0, True
        End If
    End If

End Sub

Sub ScanFilePDF(folder, Optional ddp As Integer = 7)
    Dim file, folderSub, extFile, nameFile, dcmActivate

If folder.Files.Count > 0 Then
        For Each file In folder.Files
            If file.Name Like "*.doc" Or file.Name Like "*.docx" Then

extFile = Right(file.Name, InStr(StrReverse(file.Name), ".") - 1)
                nameFile = Replace(file.Name, "." & extFile, "")

Set dcmActivate = Documents.Open(FileName:=folder.Path & "" & file.Name, _
                    ConfirmConversions:=False, ReadOnly:=False, AddToRecentFiles:=False, _
                    PasswordDocument:="", PasswordTemplate:="", Revert:=False, _
                    WritePasswordDocument:="", WritePasswordTemplate:="", Format:= _
                    wdOpenFormatAuto, XMLTransform:="")

dcmActivate.ExportAsFixedFormat OutputFileName:=folder.Path & "" & nameFile & ".pdf", _
                    ExportFormat:=wdExportFormatPDF, OpenAfterExport:=False, OptimizeFor:= _
                    wdExportOptimizeForPrint, Range:=wdExportAllDocument, From:=1, To:=1, _
                    Item:=wdExportDocumentContent, IncludeDocProps:=True, KeepIRM:=True, _
                    CreateBookmarks:=wdExportCreateNoBookmarks, DocStructureTags:=True, _
                    BitmapMissingFonts:=True, UseISO19005_1:=False

dcmActivate.Close

Set dcmActivate = Nothing

End If
        Next file
    End If

If ddp = 6 Then
        If folder.SubFolders.Count > 0 Then
            For Each folderSub In folder.SubFolders
                Call ScanFilePDF(folderSub, ddp)
            Next folderSub
        End If
    End If

End Sub

Function UniTelex(Text As String) As String
  Dim Telex_Type, CharCode, I As Long
  UniTelex = Text
  Telex_Type = Array("aws", "awf", "awr", "awx", "awj", "aas", "aaf", "aar", "aax", "aaj", "ees", _
      "eef", "eer", "eex", "eej", "oos", "oof", "oor", "oox", "ooj", "ows", "owf", "owr", "owx", _
      "owj", "uws", "uwf", "uwr", "uwx", "uwj", "as", "af", "ar", "ax", "aj", "aw", "aa", "dd", _
      "es", "ef", "er", "ex", "ej", "ee", "is", "if", "ir", "ix", "ij", "os", "of", "or", "ox", _
      "oj", "oo", "ow", "us", "uf", "ur", "ux", "uj", "uw", "ys", "yf", "yr", "yx", "yj")
  CharCode = Array(ChrW(7855), ChrW(7857), ChrW(7859), ChrW(7861), ChrW(7863), ChrW(7845), ChrW(7847), _
      ChrW(7849), ChrW(7851), ChrW(7853), ChrW(7871), ChrW(7873), ChrW(7875), ChrW(7877), ChrW(7879), _
      ChrW(7889), ChrW(7891), ChrW(7893), ChrW(7895), ChrW(7897), ChrW(7899), ChrW(7901), ChrW(7903), _
      ChrW(7905), ChrW(7907), ChrW(7913), ChrW(7915), ChrW(7917), ChrW(7919), ChrW(7921), ChrW(225), _
      ChrW(224), ChrW(7843), ChrW(227), ChrW(7841), ChrW(259), ChrW(226), ChrW(273), ChrW(233), ChrW(232), _
      ChrW(7867), ChrW(7869), ChrW(7865), ChrW(234), ChrW(237), ChrW(236), ChrW(7881), ChrW(297), ChrW(7883), _
      ChrW(243), ChrW(242), ChrW(7887), ChrW(245), ChrW(7885), ChrW(244), ChrW(417), ChrW(250), ChrW(249), _
      ChrW(7911), ChrW(361), ChrW(7909), ChrW(432), ChrW(253), ChrW(7923), ChrW(7927), ChrW(7929), ChrW(7925))
  For I = 0 To UBound(CharCode)
    UniTelex = Replace(UniTelex, Telex_Type(I), CharCode(I))
    UniTelex = Replace(UniTelex, UCase(Telex_Type(I)), UCase(CharCode(I)))
  Next I
End Function

Kết quả:
18109

Hoặc tham khảo cách 1: Folder mặc định.

Sub ConvertWordsToPdfs()
    'Updated by Extendoffice 20181123
    Dim xIndex      As String
    Dim xDlg        As FileDialog
    Dim xFolder     As Variant
    Dim xNewName    As String
    Dim xFileName   As String
    Set xDlg = Application.FileDialog(msoFileDialogFolderPicker)
        xDlg.InitialFileName = "C:UsersLEGIONDesktopNew folder"
    If xDlg.Show <> -1 Then Exit Sub
    xFolder = xDlg.SelectedItems(1) + ""
    xFileName = Dir(xFolder & "*.*", vbNormal)
    While xFileName <> ""
        If ((Right(xFileName, 4)) <> ".doc" Or Right(xFileName, 4) <> ".docx") Then
            xIndex = InStr(xFileName, ".") + 1
            xNewName = Replace(xFileName, Mid(xFileName, xIndex), "pdf")
            Documents.Open Filename:=xFolder & xFileName, _
                           ConfirmConversions:=False, ReadOnly:=False, AddToRecentFiles:=False, _
                           PasswordDocument:="", PasswordTemplate:="", Revert:=False, _
                           WritePasswordDocument:="", WritePasswordTemplate:="", Format:= _
                           wdOpenFormatAuto, XMLTransform:=""
            ActiveDocument.ExportAsFixedFormat OutputFileName:=xFolder & xNewName, _
                           ExportFormat:=wdExportFormatPDF, OpenAfterExport:=False, OptimizeFor:= _
                           wdExportOptimizeForPrint, Range:=wdExportAllDocument, From:=1, To:=1, _
                           Item:=wdExportDocumentContent, IncludeDocProps:=True, KeepIRM:=True, _
                           CreateBookmarks:=wdExportCreateNoBookmarks, DocStructureTags:=True, _
                           BitmapMissingFonts:=True, UseISO19005_1:=False
            ActiveDocument.Close
        End If
        xFileName = Dir()
    Wend
End Sub

Cách 2: Chạy mà khộng cần nhìn – Cách này "nguy hiểm" vì thiếu kiểm soát

Sub ConvertWordsToPdfs()
    'Updated by Extendoffice 20181123
    Dim xIndex      As String
    Dim xFolder     As Variant
    Dim xNewName    As String
    Dim xFileName   As String
    xFolder = "C:UsersLEGIONDesktopNew folder"
    xFileName = Dir(xFolder & "*.*", vbNormal)
    While xFileName <> ""
        If ((Right(xFileName, 4)) <> ".doc" Or Right(xFileName, 4) <> ".docx") Then
            xIndex = InStr(xFileName, ".") + 1
            xNewName = Replace(xFileName, Mid(xFileName, xIndex), "pdf")
            Documents.Open Filename:=xFolder & xFileName, _
                           ConfirmConversions:=False, ReadOnly:=False, AddToRecentFiles:=False, _
                           PasswordDocument:="", PasswordTemplate:="", Revert:=False, _
                           WritePasswordDocument:="", WritePasswordTemplate:="", Format:= _
                           wdOpenFormatAuto, XMLTransform:=""
            ActiveDocument.ExportAsFixedFormat OutputFileName:=xFolder & xNewName, _
                           ExportFormat:=wdExportFormatPDF, OpenAfterExport:=False, OptimizeFor:= _
                           wdExportOptimizeForPrint, Range:=wdExportAllDocument, From:=1, To:=1, _
                           Item:=wdExportDocumentContent, IncludeDocProps:=True, KeepIRM:=True, _
                           CreateBookmarks:=wdExportCreateNoBookmarks, DocStructureTags:=True, _
                           BitmapMissingFonts:=True, UseISO19005_1:=False
            ActiveDocument.Close
        End If
        xFileName = Dir()
    Wend
End Sub

Đúng thứ mình đang cần, mình mò mẫm từ chiều đến giờ nhưng không biết cách gán địa chỉ.
If ((Right(xFileName, 4)) <> ".doc" Or Right(xFileName, 4) <> ".docx") Then
xIndex = InStr(xFileName, ".") + 1

Dòng code này theo mình đoán thì nó có nghĩa là sẽ bỏ qua các file có đuôi không phải là ".doc" và ".docx", nhưng không hiểu sao khi gặp trường hợp trong folder file hỗn hợp (có file excel, pdf.v.v.) thì nó vẫn mở các file này lên để rồi hỏi thêm save.v.v. vậy các anh?

Không có file để thử nhưng đoạn đậm đậm chắc chắn sai. Chịu khó tự tìm hiểu sẽ nhớ lâu.

If ((Right(xFileName, 4)) <> ".doc" Or Right(xFileName, 5) <> ".docx")

Sửa thành số 5 mới đúng phải ko a?

Khóa học SprinGO phù hợp

Khóa học Power PI – Ứng dung trong Nhân sự

TỔNG QUAN KHÓA HỌC: POWER BI CHO NGÀNH NHÂN SỰ Khóa học Power BI cho Nhân sự được thiết kế dành riêng cho các...

Xem khóa học