Nhờ các anh chỉ điểm lỗi đoạn code VBA chuyển file word sang PDF giúp mình với ạ

Liên hệ QC
Tôi tuân thủ nội quy khi đăng bài
Có
T

TayMonKhanh

Thành viên mới
Tham gia
9/11/08
Bài viết
34
Được thích
5
Mình tìm thấy đoạn code này trên internet, với chức năng là chuyển hàng loạt các file word sang pdf.
Nguồn nó ở đây: https://gitiho.com/blog/cach-chuyen-doi-doc-sang-docx-va-word-sang-pdf-hang-loat-dong-thoi.html

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

Mình làm theo đúng như hướng dẫn, nhưng khi chọn folder chứa các file word thì nó luôn báo folder này rỗng, không có file word nào cả. Mình đã cố gắng tìm lỗi nhưng bó tay. Máy mình dùng word 2016. Anh/ Chị nào biết mình đã thao tác sai điều gì xin chỉ giúp mình với ạ. Cảm ơn nhiều!
1669539268756.png
 
Lần chỉnh sửa cuối:
Sắp xếp theo thời gian sắp xếp theo bầu chọn
PHP: 
Set xDlg = Application.FileDialog(msoFileDialogFolderPicker)
Vì code là chọn Folder chứ không phải là chọn từng File. Nên sẽ không hiển thị file chứ không phải rỗng. Code này sẽ chuyển đồng loạt tất cả các file định dạng *.doc và *.docx có trong folder đó.
 
Lần chỉnh sửa cuối:
Upvote 0
huhumalu đã viết:
PHP: 
Set xDlg = Application.FileDialog(msoFileDialogFolderPicker)
Vì code là chọn Folder chứ không phải là chọn từng File. Nên sẽ không hiển thị file chứ không phải rỗng. Code này sẽ chuyển đồng loạt tất cả các file định dạng *.doc và *.docx có trong folder đó.
Nhấp chuột vào đây để mở rộng...
Cảm ơn anh Huhumalu rất nhiều. Mình mới phát hiện ra có một nguyên nhân nữa là do mình để các file ở chế độ ẩn đuôi file (.docx) nên code nó ko chạy. :)
Bây giờ nó hoạt động rồi nhưng bây giờ nếu mình muốn cố định folder chứa các file word đó luôn ở địa chỉ: "C:\Users\LEGION\Desktop\New folder" luôn thì mình phải xử lý như thế nào?

Lúc nào rảnh rỗi, anh gợi ý giúp mình với được ko? Cảm ơn anh!
 
Lần chỉnh sửa cuối:
Upvote 0
Cách 1: Folder mặc định.
PHP: 
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:\Users\LEGION\Desktop\New 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
PHP: 
Sub ConvertWordsToPdfs()
    'Updated by Extendoffice 20181123
    Dim xIndex      As String
    Dim xFolder     As Variant
    Dim xNewName    As String
    Dim xFileName   As String
    xFolder = "C:\Users\LEGION\Desktop\New 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
 
Upvote 0
huhumalu đã viết:
Cách 1: Folder mặc định.
PHP: 
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:\Users\LEGION\Desktop\New 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
PHP: 
Sub ConvertWordsToPdfs()
    'Updated by Extendoffice 20181123
    Dim xIndex      As String
    Dim xFolder     As Variant
    Dim xNewName    As String
    Dim xFileName   As String
    xFolder = "C:\Users\LEGION\Desktop\New 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
Nhấp chuột vào đây để mở rộng...
Đú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ỉ. Cảm ơn anh Huhumalu rất nhiều về sự giúp đỡ! Chúc Anh và gia đình một buổi tối vui vẻ, an lành. Cảm ơn!
 
Upvote 0
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?
 
Upvote 0
TayMonKhanh đã viết:
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?
Nhấp chuột vào đây để mở rộng...
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.
 
Upvote 0
Chủ thớt còn cần code xử lý chuyển Word sang PDF ko?, tôi sẽ nghiên cứu code riêng gửi cho bạn test thử
 
Upvote 0
Code cho AE dùng thử nhé, 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
 
Upvote 0
Bạn phải đăng nhập hoặc đăng ký để trả lời bài viết tại đây.
Web KT

Bài viết mới nhất

hunganh.nguyen
Xin giúp code tách dòng tổng thành những dòng chi tiết với giá trị là 1
Trả lời
6
Đọc
297
DeTong
D
T
cả nhà hỗ trợ giúp em là em phải dùng hàm gì cho đúng ạ, em làm mãi không được
    • Cười
Trả lời
2
Đọc
65
DeTong
D
N
cộng các dữ liệu không trùng nhau
Trả lời
7
Đọc
109
SA_DQ
SA_DQ
nguyenanhhoa
Nhờ các bác giúp: e muốn tô màu khác nhau đối với các ô giống nhau về giá trị
    • Cười
Trả lời
7
Đọc
117
SA_DQ
SA_DQ
K
  • Question
Sử dụng Power Query để xử lý nhật ký chung nhiều nợ nhiều có
    • Cười
Trả lời
6
Đọc
104
ptm0412
ptm0412
LuuAnh980
Từ "cân đối" trong tiếng Anh là gì?
2 3
Trả lời
44
Đọc
2K
VetMini
V
Hai Lúa Miền Tây
  • Question
Hàm chuyển dữ liệu từ cột sang dòng (Hàm melt + wide_to_long của Python trong Excel)
    • Thích
    • Cảm ơn
    • Yêu thích
Trả lời
11
Đọc
611
VetMini
V
C
Tiếng Việt
    • Cười
2
Trả lời
32
Đọc
1K
VetMini
V
N
Công thức tính số phù hợp với % mong muốn
Trả lời
8
Đọc
104
cantl
C
B
Giúp em xử lý lỗi macro khi chạy VBA
Trả lời
18
Đọc
377
cantl
C
HeSanbi
  • Question
Hàm FilterA và FilterV - Bổ trợ tận dụng bộ lọc AutoFilter và AdvancedFilter
    • Thích
    • Yêu thích
    • Cảm ơn
2 3
Trả lời
48
Đọc
4K
Manhhung90
Manhhung90
T
Chèn dữ liệu từ sheet này qua sheet khác theo điều kiện
Trả lời
1
Đọc
83
HieuCD
H
N
Giúp em công thức lấy dữ liệu không trùng để in phiếu thu bán hàng
Trả lời
5
Đọc
181
nguyenthieny
N
ongke0711
  • Question
Tải hóa đơn điện tử (https://hoadondientu.gdt.gov.vn/) Excel Vba
    • Thích
    • Yêu thích
7 8 9
Trả lời
173
Đọc
9K
ongke0711
ongke0711
N
  • Question
Xin mã code ẩn hiện dòng theo điều kiện
Trả lời
1
Đọc
38
HUONGHCKT
H
vova2209
Index kết hợp với match 2 điều kiện
Trả lời
13
Đọc
1K
hoangtuaotrang_hp_vn
H
vova2209
  • Question
Tìm địa chỉ ô với 2đk và chuyển thành links
Trả lời
17
Đọc
391
vova2209
vova2209
Huy@@*
Giải đáp giùm em, cách khắc phục lỗi này trên VBA
Trả lời
0
Đọc
27
Huy@@*
Huy@@*
A
Công thức tính tổng chi phí nhiều điều kiện
Trả lời
6
Đọc
107
adad
A
T
Lọc lấy đơn giá nhập mới nhất của các mặt hàng
2
Trả lời
20
Đọc
14K
honguyentruong
H
Xem thêm…

Thành viên có số lượng bài viết cao nhất tháng

Thành viên có điểm tương tác cao nhất tháng

Back
Top Bottom