多级文件夹下多个word文档，不打开情况下批量转为PDF

today77

一级文件夹下有多个二级文件夹（二级名称不固定），二级文件夹下有多个word，需要批量把这些word转换成PDF，并保存在原文件夹下，效果如下：




请老师帮忙，十分感谢。

ykcbf1100

word转PDF文件，win11+office2021下测试通过

ykcbf1100

word文档转PDF文件

1. Sub ykcbf()   '//2024.7.18   word转PDF文件
   
2.     Application.ScreenUpdating = False
   
3.     Application.DisplayAlerts = False
   
4.     Set fso = CreateObject("scripting.filesystemobject")
   
5.     Set wdoc = CreateObject("Word.Application")
   
6.     wdoc.Visible = False
   
7.     Set ws = ThisWorkbook
   
8.     p = ws.Path & ""
   
9.     On Error Resume Next
   
10.     Set ff = fso.GetFolder(p)
    
11.     For Each fd In ff.SubFolders
    
12.         For Each f In fd.Files
    
13.             If LCase(f.Name) Like "*.doc*" Then
    
14.                 fnx = fso.GetExtensionName(f)
    
15.                 ofn = f.Path
    
16.                 fn = Replace(f.Path, f.Name, Replace(f.Name, fnx, ".pdf"))
    
17.                 If Not fso.FileExists(fn) Then
    
18.                     Set wd = wdoc.Documents.Open(ofn)
    
19.                     wd.SaveAs2 Filename:=fn, FileFormat:=17
    
20.                     wd.Close
    
21.                 Else
    
22.                     MsgBox "PDF已经存在: " & fn
    
23.                 End If
    
24.             End If
    
25.         Next f
    
26.     Next
    
27.     wdoc.Quit
    
28.     Set wd = Nothing
    
29.     Set wdoc = Nothing
    
30.     Set fso = Nothing
    
31.     Application.ScreenUpdating = True
    
32.     MsgBox "OK！"
    
33. End Sub
    

复制代码

today77

ykcbf1100 发表于 2024-7-18 10:00
word转PDF文件，win11+office2021下测试通过

已测试，非常好用，word转PDF我看到的最好的作品，感谢。

today77

ykcbf1100 发表于 2024-7-18 10:00
word转PDF文件，win11+office2021下测试通过

老师，可以可以在添加个功能，点击后弹窗，然后自己选择路径。

ykcbf1100

today77 发表于 2024-7-18 10:13
老师，可以可以在添加个功能，点击后弹窗，然后自己选择路径。

可以的，文件夹自选，如果是当前文件夹，直接点确定即可。

ykcbf1100

文件夹自选。

1. Sub ykcbf()   '//2024.7.18   word转PDF文件,文件夹自选
   
2.     Application.ScreenUpdating = False
   
3.     Application.DisplayAlerts = False
   
4.     Set fso = CreateObject("scripting.filesystemobject")
   
5.     Set wdoc = CreateObject("Word.Application")
   
6.     wdoc.Visible = False
   
7.     With Application.FileDialog(msoFileDialogFolderPicker)
   
8.         .Title = "请选择文件夹"
   
9.         .InitialFileName = ThisWorkbook.Path & ""
   
10.         If .Show = -1 Then
    
11.             p = .SelectedItems(1) & ""
    
12.         End If
    
13.     End With
    
14.     Set ff = fso.GetFolder(p)
    
15.     For Each fd In ff.SubFolders
    
16.         For Each f In fd.Files
    
17.             If LCase(f.Name) Like "*.doc*" Then
    
18.                 fnx = fso.GetExtensionName(f)
    
19.                 ofn = f.Path
    
20.                 fn = Replace(f.Path, f.Name, Replace(f.Name, fnx, ".pdf"))
    
21.                 If Not fso.FileExists(fn) Then
    
22.                     Set wd = wdoc.Documents.Open(ofn)
    
23.                     wd.SaveAs2 Filename:=fn, FileFormat:=17
    
24.                     wd.Close
    
25.                 Else
    
26.                     MsgBox "PDF已经存在: " & fn
    
27.                 End If
    
28.             End If
    
29.         Next f
    
30.     Next
    
31.     wdoc.Quit
    
32.     Set wd = Nothing
    
33.     Set wdoc = Nothing
    
34.     Set fso = Nothing
    
35.     Application.ScreenUpdating = True
    
36.     MsgBox "OK！"
    
37. End Sub
    

复制代码