如何把文件夹内的n个ppt批量设置嵌入字体？

zzpsx

zzpsx

来顶一下。

shenjianrong163

1. Sub test() '嵌入字体
   
2.     Dim Pre As Object
   
3.     Dim Savetime As Single
   
4.     On Error Resume Next
   
5.     With Application.FileDialog(msoFileDialogOpen)
   
6.         .Title = "选择文件"
   
7.         .Filters.Clear
   
8.         .InitialFileName = CreateObject("WScript.Shell").SpecialFolders("Desktop") & ""    '定义桌面为默认路径
   
9.         .Filters.Add "PPT文件", "*.ppt*"
   
10.         .AllowMultiSelect = True    '允许多选
    
11.         .Show
    
12.         If .SelectedItems.Count = 0 Then Exit Sub
    
13.         For Each f In .SelectedItems
    
14.             If Dir(f) <> ActivePresentation.Name Then
    
15.                 Savetime = Timer '记下开始的时间
    
16.                 Set Pre = Presentations.Open(f)
    
17.                 Pre.SaveAs ActivePresentation.FullName, ppSaveAsDefault, msoTrue
    
18.                 While Timer < Savetime + 3 '循环等待
    
19.                     DoEvents '转让控制权，以便让操作系统处理其它的事件
    
20.                 Wend
    
21.                 Pre.Close
    
22.             End If
    
23.         Next
    
24.     End With
    
25. End Sub
    

复制代码

shenjianrong163

注意手动添加代码中的“\”符号：
.InitialFileName = CreateObject("WScript.Shell").SpecialFolders("Desktop") & "\"    '定义桌面为默认路径