word+ppt vba

最新推荐文章于 2025-04-03 13:44:14 发布

一把年纪学编程

最新推荐文章于 2025-04-03 13:44:14 发布

阅读量742

点赞数 6

文章标签： word powerpoint

本文链接：https://blog.youkuaiyun.com/waterice0717/article/details/135294579

版权

word 编号黑框问题

Sub test()
    For Each templ In ActiveDocument.ListTemplates
    For Each lev In templ.ListLevels
    lev.Font.Reset
    Next lev
    Next templ
End Sub

导出PPT备注

感谢知乎大佬

作者：Emrys
链接：https://www.zhihu.com/question/547915281/answer/2655781983


' 如果不想要导出全部幻灯片的备注，可以在代码里面修改页码范围，即把下面的代码
' For i = 1 To num_slides修改成你想要的范围（如第 4 页 到第 8 页）：For i = 4 To 8Sub ExportNote()
Sub ExportText()
  Dim oPres As Presentation
  Dim oSlides As Slides
  Dim oSld As Slide         'Slide Object
  Dim oShp As Shape         'Shape Object
  Dim iFile As Integer      'File handle for output
  iFile = FreeFile          'Get a free file number
  Dim PathSep As String
  Dim path As String
  Dim FileNum As Integer
  Dim sTempString As String

  Set oPres = ActivePresentation
  Set oSlides = oPres.Slides
  filename = oPres.FullName

  #If Mac Then
    PathSep = "/"
    path = MacScript("return POSIX path of (path to desktop folder)")
    if Right(path, 1) = PathSep And Len(path) > 1 Then
        path = Mid(path, 1, Len(path) - 1)
    End If
  #Else
    PathSep = "\"
    path = oPres.Path
  #End If

  FileNum = FreeFile

  'Open output file
  ' NOTE:  errors here if file hasn't been saved
  Open path & PathSep & filename & ".txt" For Output As FileNum

  On Error GoTo ErrorHandler   ' Enable error-handling routine.

  num_slides = ActivePresentation.Slides.Count

  For i = 1 To num_slides
    Set oSld = ActivePresentation.Slides(i)
    Print #iFile, "(Page " & CStr(oSld.SlideNumber) & ")" & vbNewLine

    Print #iFile, oSld.NotesPage.Shapes.Placeholders(2).TextFrame.TextRange

    Print #iFile, "--------------------------" & vbNewLine & vbNewLine & vbNewLine
    Next i
  Close #iFile

  MsgBox "文件已创建在'" & path & PathSep & filename & ".txt'"

  Exit Sub       ' Exit to avoid handler.
  ErrorHandler:  ' Error-handling routine.
    Print #iFile, "(Error)" & vbNewLine
    Resume Next  ' Resume execution at the statement immediately
                 ' following the statement where the error occurred.
End Sub




' ' Windows 上从单页或多页 PPT 中提取所有文本框内的文字


' 作者：Emrys
' 链接：https://www.zhihu.com/question/387555935/answer/1160380698
' 来源：知乎
' 著作权归作者所有。商业转载请联系作者获得授权，非商业转载请注明出处。

' 运行之后，就会在 PPT 同目录下生成与 PTT 文件同名的 .txt 文件，其中内容格式如下：Slide: [页码编号][这一页第1个形状的名称]: [文本内容][这一页第2个形状的名称]: [文本内容]Slide: [页码编号][这一页第1个形状的名称]: [文本内容]……<img src="https://pic4.zhimg.com/v2-b21f804fae7fb6313caac4e29e094293_b.jpg" data-size="normal" data-rawwidth="1497" data-rawheight="877" data-default-watermark-src="https://pic1.zhimg.com/v2-8693b062705e0c7c6b9a77165d6f20e8_b.jpg" class="origin_image zh-lightbox-thumb" width="1497" data-original="https://pic4.zhimg.com/v2-b21f804fae7fb6313caac4e29e094293_r.jpg"/>导出文本的格式上面用到的 VBA 代码如下（也适用于 Mac）：如果不想要导出全部幻灯片的文本，可以在代码里面修改页码范围，即把下面的代码For i = 1 To num_slides修改成你想要的范围（如第 4 页 到第 8 页）：For i = 4 To 8Sub ExportText()
  Dim oPres As Presentation
  Dim oSlides As Slides
  Dim oSld As Slide         'Slide Object
  Dim oShp As Shape         'Shape Object
  Dim iFile As Integer      'File handle for output
  iFile = FreeFile          'Get a free file number
  Dim PathSep As String
  Dim FileNum As Integer
  Dim sTempString As String

  #If Mac Then
    PathSep = "/"
  #Else
    PathSep = "\"
  #End If

  Set oPres = ActivePresentation
  Set oSlides = oPres.Slides

  FileNum = FreeFile

  'Open output file
  ' NOTE:  errors here if file hasn't been saved
  'Open oPres.Path & PathSep & "AllText.txt" For Output As FileNum
  Open oPres.Path & PathSep & oPres.Name & ".txt" For Output As FileNum
  
  num_slides = ActivePresentation.Slides.Count

  For i = 1 To num_slides
    Set oSld = ActivePresentation.Slides(i)
    Print #iFile, "Slide:" & vbTab & CStr(oSld.SlideNumber)

    For Each oShp In oSld.Shapes
      'Check to see if shape has a text frame and text
      If oShp.HasTextFrame And oShp.TextFrame.HasText Then
        If oShp.Type = msoPlaceholder Then
            Select Case oShp.PlaceholderFormat.Type
                Case Is = ppPlaceholderTitle, ppPlaceholderCenterTitle
                    Print #iFile, "标题：" & vbTab & oShp.TextFrame.TextRange
                Case Is = ppPlaceholderBody
                    Print #iFile, "正文：" & vbTab & oShp.TextFrame.TextRange
                Case Is = ppPlaceholderSubtitle
                    Print #iFile, "副标题：" & vbTab & oShp.TextFrame.TextRange
                Case Else
                    Print #iFile, "其他占位符：" & vbTab & oShp.TextFrame.TextRange
            End Select
        Else
            Print #iFile, vbTab & oShp.TextFrame.TextRange
        End If  ' msoPlaceholder
      Else  ' it doesn't have a textframe - it might be a group that contains text so:
        If oShp.Type = msoGroup Then
            sTempString = TextFromGroupShape(oShp)
            If Len(sTempString) > 0 Then
                Print #iFile, sTempString
            End If
        End If
      End If    ' Has text frame/Has text
    Next oShp
    
    Print #iFile, vbCrLf
    Next i
  Close #iFile

  'MsgBox "文件已创建在 '" & oPres.Path & PathSep & "AllText.txt'"
  MsgBox "文件已创建在 '" & oPres.Path & PathSep & oPres.Name & ".txt'"
End Sub

Function TextFromGroupShape(oSh As Shape) As String
' Returns the text from the shapes in a group
' and recursively, text within shapes within groups within groups etc.

    Dim oGpSh As Shape
    Dim sTempText As String

    If oSh.Type = msoGroup Then
        For Each oGpSh In oSh.GroupItems
            With oGpSh
                If .Type = msoGroup Then
                    sTempText = sTempText & TextFromGroupShape(oGpSh)
                Else
                    If .HasTextFrame Then
                        If .TextFrame.HasText Then
                            sTempText = sTempText & "(Gp:) " & .TextFrame.TextRange.Text & vbCrLf
                        End If
                    End If
                End If
            End With
        Next
    End If

    TextFromGroupShape = sTempText

NormalExit:
    Exit Function

Errorhandler:
    Resume Next

End Function

其他功能

'* +++++++++++++++++++++++++++++++++++++++
'功能简介:可以对指定长度的段落进行删除，当LEN=1时可对空白段落进行删除。
Sub DelBlank() 
    Dim i As Paragraph, n As Long 
    Application.ScreenUpdating = False '关闭屏幕刷新 
    For Each i In ActiveDocument.Paragraphs '在活动文档的段落集合中循环 
        If Len(i.Range) = 1 Then '判断段落长段,此处可根据文档实际情况 
            i.Range.Delete '进行必要的修改可将任意长度段落删除 
            n = n + 1 '计数 
        End If 
    Next 
    MsgBox "共删除空白段落" & n & "个!" 
    Application.ScreenUpdating = True '恢复屏幕刷新 
End Sub



'* +++++++++++++++++++++++++++++++++++++++
'以指定字符重新划分段落并插入时间序列数
'^The Code CopyIn [ThisDocument-ThisDocument]^'
'* --------------------------------------------------------------------------
Sub CreateParagraph() 
    Dim I As Long, N As Integer 
    On Error Resume Next '忽略错误 
    Application.ScreenUpdating = False '关闭屏幕更新 
    With ActiveDocument 
        '将文档中所有段落标记删除 
        .Content.Find.Execute FindText:="^p", ReplaceWith:="", Replace:=wdReplaceAll 
        For I = 0 To .Content.End Step 10 '以10个字符位置(包括非打印字符)为步长循环 
            '每段十个字符部分分成段落(注意插入的段落标记也是一个字符) 
            .Range(I, I + 10 + N).InsertAfter Chr(13) 
            N = N + 1 '计算插处的段落标记个数 
        Next 
    End With 
    Application.ScreenUpdating = True '恢复屏幕更新 
    InsertTimer 
End Sub 
'---------------------- 
Sub InsertTimer() 
    Dim I As Paragraph, N As Integer, TimeStr As String 
    On Error Resume Next '忽略错误 
    Application.ScreenUpdating = False '关闭屏幕更新
    For Each I In ActiveDocument.Paragraphs '在文档新的段落中循环 
        If N < 10 Then '<10,TimeStr的分钟值为5(保持两位数05) 
            TimeStr = "[00:0" & N & ".00]" 
        ElseIf N = 60 Then 'N=60时时间数进一并保持该数据(不再向上) 
            TimeStr = "[01:00.00]" N = 0 
        Else 'TimeStr的分钟数照计(两位数) 
            TimeStr = "[00:" & N & ".00]" 
        End If 
            I.Range.InsertBefore TimeStr '每个段前插入时间数值 
            N = N + 5 '以5为步长累加 
    Next 
    Application.ScreenUpdating = True '恢复屏幕更新 
End Sub '---------------------


'* +++++++++++++++++++++++++++++++++++++++
'四) 段落样式与格式的应用
'功能简介:由于手动录入的段落编号不能被WORD所识别,为以后的样式与格式的设置以及目录索引等带来一系列的问题,本代码即是将其转换为指定样式的过程.

'^The Code CopyIn [ThisDocument-ThisDocument]^'
'* --------------------------------------------------------------------------
Sub Sample()
    Dim i As Paragraph, MyStr As String 
    Application.ScreenUpdating = False 
    MyStr = "一二三四五六七八九十" '假定为手动加注每个段落开头为中文大写数字 
    For Each i In Me.Paragraphs 
        If i.Range Like "（#）*" = True Then 
            i.Style = wdStyleHeading9 '标题9是以（1）等开头的数字 
        ElseIf i.Range Like "#.#.#.#*" = True Then 
            i.Style = wdStyleHeading8 '标题8是以1.1.1.1的形式开头的段落 
        ElseIf i.Range Like "#.#.#*" = True Then 
            i.Style = wdStyleHeading7 '标题7是以1.1.1的形式开头的段落 
        ElseIf i.Range Like "#.#*" = True Then 
            i.Style = wdStyleHeading6 '标题6是以1.1形式开头的段落 
        ElseIf InStr(MyStr, Me.Range(i.Range.Start, i.Range.Start + 1).Text) > 0 Then 
            i.Style = wdStyleHeading5 '标题5是以一等形式开头的段落 
        Else 
            i.Style = wdStyleNormal '其它为正文样式 
        End If 
    Next 
    Application.ScreenUpdating = True
End Sub


'五) 根据预定义段落进行段落样式的设置和插入目录
'* +++++++++++++++++++++++++++++++++++++++
'^The Code CopyIn [ThisDocument-ThisDocument]^'
'* --------------------------------------------------------------------------
'功能简介：对于网上复制的一些非正规编排的文档，没有大纲级别，也没有很好地样式格式以区分，
'利用此功能，可以根据先前的手动目录，更改为自动生成的目录，便于文档管理。
Sub Contents() 
    Dim I As Paragraph, N As Byte, A As Byte, B As Byte, X As Long, DelRange As Range 
    Application.ScreenUpdating = False 
    A = 2 
    B = 13 
    With ActiveDocument 
        For Each I In .Paragraphs '在段落中循环 X = X + 1 '计数 
            For N = A To B '进入文档第二段落到第十三段落间的循环 
                If X > B Then 
                    If I.Range = .Paragraphs(N).Range Then 
                        I.Style = .Styles(wdStyleHeading1) '将 A = A + 1 '累计 
                    End If 
                End If 
            Next 
        Next
        Set DelRange = Range(.Paragraphs(2).Range.Start, .Paragraphs(13).Range.End) 
            DelRange.Delete '删除原文档的第二~第十三个段落 
            .Paragraphs(2).Range.Select '插入/引用/索引与目录 
            .TablesOfContents.Add Range:=Selection.Range, RightAlignPageNumbers:= _ True, UseHeadingStyles:=True, UpperHeadingLevel:=1, _ LowerHeadingLevel:=3, IncludePageNumbers:=True, AddedStyles:="", _ UseHyperlinks:=True, HidePageNumbersInWeb:=True
        .TablesOfContents(1).TabLeader = wdTabLeaderDots 
        .TablesOfContents.Format = wdIndexIndent 
    End With 
    Application.ScreenUpdating = True 
End Sub


'九) 查找与替换的基本代码用法之一
'* +++++++++++++++++++++++++++++++++++++++
'^The Code CopyIn [ThisDocument-ThisDocument]^'
'* --------------------------------------------------------------------------
Sub Example() 
    With ActiveDocument.Content.Find 
        .ClearFormatting '清除格式设置 
        .Font.Name = "华文细黑" '查找的字体格式 
        With .Replacement '替换条件 
            .ClearFormatting '清除格式设置 
            .Font.Name = "黑体" '替换成黑体 
        End With 
        .Execute FindText:="", ReplaceWith:="", Format:=True, _ Replace:=wdReplaceAll '是格式替换,全部替换 
    End With 
End Sub 
'----------------------


十一) 查找与替换的基本代码用法之三(批量替换)
功能简介：同时进行多个查找与替换，支持非通配符下的特殊字符的替换。
比如，适用于ISO文件，因组织机构调整，对所有原有部门一次输入后替换为新部门。
查找的各个内容之间，用英文逗号分隔（","），查找数量不限。
替换的各个内容之间，用英文逗号分隔（","），替换数量必须等同于查找数量，如是删除某个查找内容，替换中键入""(空空)
'* ＋＋＋＋＋＋＋＋＋＋＋＋＋＋＋＋＋＋＋＋＋＋＋＋＋＋＋＋＋ '^The Code CopyIn [ThisDocument-ThisDocument]^' '* －－－－－－－－－－－－－－－－－－－－－－－－－－－－－
Private Sub Document_Close() 
    On Error Resume Next 
    Application.CommandBars("Edit").Controls("多个替换").Delete '恢复原有菜单 
End Sub 
'---------------------- 
Private Sub Document_Open() 
    On Error Resume Next 
    Dim NewButton As CommandBarButton 
    CustomizationContext = ActiveDocument '将自定义组合键和工具命令保存于活动文档中 
    '指定CTRL+F为键盘快捷方式 
    KeyBindings.Add wdKeyCategoryMacro, "MySub", BuildKeyCode(wdKeyControl, wdKeyF) 
    '指定F5为快捷方式 
    KeyBindings.Add wdKeyCategoryMacro, "MySub", BuildKeyCode(wdKeyF5) 
    Application.CommandBars("Edit").Controls("多个替换").Delete 
    '预防性删除 
    Set NewButton = Application.CommandBars("Edit").Controls.Add(Type:=msoControlButton, Before:=11) 
    With NewButton 
        .Caption = "多个替换" '命令名称 
        .FaceId = 100 '命令的FaceId 
        .Visible = True '可见 
        .OnAction = "MySub" '指定响应过程名 
    End With 
End Sub '---------------------- 
Sub MySub() 
    UserForm1.Show 
End Sub '---------------------- 
Sub ComReset() 
'恢复默认设置
    Application.CommandBars("Edit").Reset 
End Sub



' 十二) 查找与替换的基本代码用法之四-全文件夹替换
' 功能简介:批量多文件（全文件夹）的多文本一次性替换操作。
' 运行本程序后，先输入需查找和与之对应的替换的文本，然后点击“选择文件夹”，
' 您可以找到指定的文件夹中的部分或者所有文件，注意，您需要全选文件（CTRL+A），
' 或者使用SHIFT/CTRL配合鼠标键选取多个文件），确定后自动进行批量替换。
'* ＋＋＋＋＋＋＋＋＋＋＋＋＋＋＋＋＋＋＋＋＋＋＋＋＋＋＋＋＋ '^The Code CopyIn [ThisDocument-ThisDocument]^' '* －－－－－－－－－－－－－－－－－－－－－－－－－－－－－
Private Sub Document_Open() 
    Application.Windows(ThisDocument.Name).Visible = False 
    MySub 
End Sub '---------------------- 
Sub MySub() 
    UserForm1.Show 
End Sub
 '---------------------- 
 '* ＋＋＋＋＋＋＋＋＋＋＋＋＋＋＋＋＋＋＋＋＋＋＋＋＋＋＋＋＋ 
 '^The Code CopyIn [用户窗体-UserForm1]^' '* －－－－－－－－－－－－－－－－－－－－－－－－－－－－－
Private Sub CommandButton1_Click() 
    Me.TextBox1 = "" 
    Me.TextBox2 = "" 
    Me.TextBox1.SetFocus 
End Sub '---------------------- 
Private Sub CommandButton2_Click() 
    Dim MyFind() As String, MyRep() As String, i As Integer, aStory As Variant 
    Dim MyDialog As FileDialog, vrtSelectdeItem As Variant, Doc As Document 
    On Error Resume Next '检查是否为空 
    MsgBox "请先正确录入查找与对应替换的内容,以英文逗号分隔" & vbCrLf & _ "在选定文件夹中,您可以全选或部分选定文件(CTRL/SHIFT)+鼠标单击", vbInformation
    If Me.TextBox1 = "" And Me.TextBox2 = "" Then Exit Sub 
    MyFind = Split(Me.TextBox1, ",") 
    MyRep = Split(Me.TextBox2, ",") 
    If UBound(MyRep) <> UBound(MyFind) Then 
        '如果两个文本框的分隔数目不一致,提示 
        MsgBox "替换的数目与查找数目不一致!", vbExclamation + vbOKOnly, "Warnning" 
        Me.TextBox2.SetFocus 
        Exit Sub 
    End If '定义一个文件夹选取对话框 
    Set MyDialog = Application.FileDialog(msoFileDialogFilePicker) 
    With MyDialog 
        .Filters.Clear '清除所有文件筛选器中的项目 
        .Filters.Add "所有 WORD 文件", "*.doc", 1 '增加筛选器的项目为所有WORD文件 
        .AllowMultiSelect = True '允许多项选择 
        If .Show = -1 Then '确定 
            Application.ScreenUpdating = False 
            For Each vrtselecteditem In .SelectedItems '在所有选取项目中循环 
                Set Doc = Documents.Open(FileName:=vrtselecteditem, Visible:=False) '定义两个数组,以","分隔 
                With Doc 
                For i = 0 To UBound(MyFind) '一个从下标为0的循环替换 
                    For Each aStory In .StoryRanges '在文档的各个文字部分 '如果是"",则相当于删除原查找内容 
                        aStory.Find.Execute findtext:=MyFind(i), _ replacewith:=VBA.IIf(MyRep(i) = """""", "", MyRep(i)), Replace:=2 '如果有下一节中相同内容文字部分,也进行替换 
                        If Not aStory.NextStoryRange Is Nothing Then _ aStory.NextStoryRange.Find.Execute findtext:=MyFind(i), _ replacewith:=VBA.IIf(MyRep(i) = """""", "", MyRep(i)), Replace:=2 
                    Next 
                Next 
                Doc.Close True 
                End With 
            Next vrtselecteditem 
        End If 
    End With 
    Application.ScreenUpdating = True 
    Unload Me '卸载窗体 
End Sub '---------------------- 
Private Sub UserForm_Initialize()
    Me.Caption = "多文本替换操作" 
    Me.TextBox1.SetFocus 
    Me.CommandButton2.Default = True 
End Sub '---------------------- 
Private Sub UserForm_QueryClose(Cancel As Integer, CloseMode As Integer) 
    ThisDocument.Close False 
End Sub '----------------------


' 四十一) 后台解除已知密码的VBA工程的代码
' 功能简介:用于后台解除VBA工程代码并完成相应修改的代码,亦可用于EXCEL中
'* +++++++++++++++++++++++++++++++++++++++
'^The Code CopyIn [ThisDocument-ThisDocument]^'
'* --------------------------------------------------------------------------
Sub UnProtectPassWord() 
    Dim MyPw As String '最新修改时间:2004-12-11 16:15:04 
    MyPw = "123" '假设密码为123,可修改 
    Application.ScreenUpdating = False '打开VBE/工具/Project属性对话框 
    Application.VBE.CommandBars.FindControl(ID:=2578).Execute '发送密码和回车,第二次回车为确定属性对话框框 
    SendKeys MyPw & "{Enter 2}", True 
    Call ReWork 
    Application.ScreenUpdating = True
End Sub '----------------------
Sub ReWork()
'测试用于修改VBA代码的代码,注意宏安全性的可靠性来源中勾选信 
'任对于VB项目的访问 
    Me.VBProject.VBComponents(1).CodeModule.ReplaceLine 3, "'最新修改时间:" & Now'将当前时间写在代码中 
End Sub '----------------------


' 五十) 批量重命名文件
'* +++++++++++++++++++++++++++++++++++++++
'^The Code CopyIn [ThisDocument-ThisDocument]^'
'* --------------------------------------------------------------------------
Sub FileNewName() 
    Dim FSO As Object, FDR As Object, F As Object, i As Variant, OldName As String, NewName As String 
    On Error Resume Next '忽略错误 
    Set FSO = CreateObject("Scripting.FileSystemObject") '创建计算机文件系统以向其访问 
    Set FDR = FSO.GetFolder("D:\Test") '指定其中访问的文件夹对象 
    Set F = FDR.Files '定义该文件夹中的所有文件集合 
    For Each i In F '在指定文件下的文件中循环 
        OldName = FDR & "\" & i.Name NewName = FDR & "\" & Mid(i.Name, 3) '去掉前两个字符 
        Name OldName As NewName 
    Next i 
End Sub '----------------------




' 设置字体的格式，下例将活动文档首段的格式设置为 24 磅Arial 和倾斜
Set myRange = ActiveDocument.Paragraphs(1).Range
With myRange.Font
.Bold = True
.Name = "Arial"
.Size = 24
End With


' 下例将活动文档中标题 2 的样式更改为 Arial 和加粗
With ActiveDocument.Styles(wdStyleHeading2).Font
.Name = "Arial"
.Italic = True
End With

' 关键字“New”来创建一个独立应用的新 Font 对象。然后将该 Font 对象应用于活动文档的首段
Set myFont = New Font
myFont.Bold = True
myFont.Name = "Arial"
ActiveDocument.Paragraphs(1).Range.Font = myFont

' 通过使用 ParagraphFormat 对象可以设置文本中段落的格式。将活动文档第三段居中对齐
ActiveDocument.Paragraphs(3).Format.Alignment = _WdAlignParagraphCenter
' 定段落的段前距离设置为12 磅
Selection.FormatParagraph.SpaceBefore = 12

' 应用于活动文档的第一个段落
Dim myParaF As New ParagraphFormat
myParaF.Alignment = wdAlignParagraphCenter
myParaF.Borders.Enable = True
ActiveDocument.Paragraphs(1).Format = 




'------------------------PPT-------------------------------------------
'vba如何给每张PPT批量插入一张（各种格式无固定命名的)图片，且确保图片大小是一样的

作者：Emrys
链接：https://www.zhihu.com/question/547915281/answer/2655781983
来源：知乎
著作权归作者所有。商业转载请联系作者获得授权，非商业转载请注明出处。

代码中的 numPicturePerSlide 的值需要根据实际需要进行调整，这里默认设置为 3， 即每页 PPT 插入 3 张图片。Sub InsertPicturesToPPT()
  Dim sld As Slide
  Dim shp As Shape
  Dim i, count, numPicturePerSlide As Long
  Dim slideWidth, slideHeight As Single

  '用这个变量设置每页 PPT 要插入的图片数量
  numPicturePerSlide = 3

  fd = Split(FileDialogOpen, vbLf)
  If Left(fd(0), 1) = "-" Then
    Debug.Print "Canceled"
    Exit Sub
  End If

  slideWidth = ActivePresentation.PageSetup.SlideWidth
  slideHeight = ActivePresentation.PageSetup.SlideHeight

  count = 0
  For Each sld In ActivePresentation.Slides
    ' 跳过隐藏的 PPT 页
    If sld.SlideShowTransition.Hidden = msoFalse Then
      If count + LBound(fd) > UBound(fd) Then
        ' No picture to insert
        Exit For
      End If

      For i = 1 To numPicturePerSlide
        If count + LBound(fd) <= UBound(fd) Then
          Set shp = sld.Shapes.AddPicture( _
            FileName:=fd(count + LBound(fd)), _
            LinkToFile:=msoFalse, _
            SaveWithDocument:=msoTrue, _
            Left:=0, _
            Top:=0, _
            Width:=-1, _
            Height:=-1 _
          )
          With shp
            .LockAspectRatio = msoTrue  ' 锁定纵横比
            '.ScaleHeight 0.75, msoTrue
            .Left = slideWidth / numPicturePerSlide * i - .Width / 2
            .Top = (slideHeight - .Height) / 2
            '.ZOrder msoSendToBack   ' 将图片设置为最底层
          End With
          count = count + 1
        Else
          Exit For
        End If
      Next i
    End If
  Next sld

  'MsgBox "Processing finished. Inserted (" & count & ") pictures in total"
  MsgBox "插入图片完成，共插入 " & count & " 张图片"

End Sub

Function FileDialogOpen() As String

  #If Mac Then
    ' 默认路径
    mypath = MacScript("return (path to desktop folder) as String")

    sMacScript = "set applescript's text item delimiters to "","" " & vbNewLine & _
    "try " & vbNewLine & _
    "set theFiles to (choose file of type {""png"", ""jpg"", ""jpeg"", ""svg"", ""tiff"", ""gif""}" & _
    "with prompt ""请选择一个或多个要插入的图片"" default location alias """ & _
    mypath & """ multiple selections allowed true)" & vbNewLine & _
    "set applescript's text item delimiters to """" " & vbNewLine & _
    "on error errStr number errorNumber" & vbNewLine & _
    "return errorNumber " & vbNewLine & _
    "end try " & vbNewLine & _
    "repeat with i from 1 to length of theFiles" & vbNewLine & _
    "if i = 1 then" & vbNewLine & _
    "set fpath to POSIX path of item i of theFiles" & vbNewLine & _
    "else" & vbNewLine & _
    "set fpath to fpath & """ & vbNewLine & _
    """ & POSIX path of item i of theFiles" & vbNewLine & _
    "end if" & vbNewLine & _
    "end repeat" & vbNewLine & _
    "return fpath"

    FileDialogOpen = MacScript(sMacScript)

  #Else
    With Application.FileDialog(msoFileDialogOpen)
      .AllowMultiSelect = True
      .Title = "请选择要一个或多个要插入的图片"
      .Filters.Add "图片", "*.png; *.jpg; *.jpeg; *.svg; *.tiff; *.gif", 1
      If .Show = -1 Then
        FileDialogOpen = ""
        For i = 1 To .SelectedItems.Count
          If i = 1 Then
            FileDialogOpen = .SelectedItems.Item(i)
          Else
            FileDialogOpen = FileDialogOpen & vbLf & .SelectedItems.Item(i)
          End If
        Next
      Else
        FileDialogOpen = "-"
      End If
    End With

  #End If
End Function

'上述代码插入的图片没有进行统一的位置和大小调整，如果需要进行调整，可以在插入完成之后，再使用下列回答中的方法解决：

'选中的那些形状会被作为参考，之后其他页中与它们类型相同且距离最近的形状，会被设置为与之相同的位置和大小
作者：Emrys
链接：https://www.zhihu.com/question/546616706/answer/2607870575
来源：知乎
著作权归作者所有。商业转载请联系作者获得授权，非商业转载请注明出处。

Sub AlignToSelectedShapes()
    Dim sld As Slide
    Dim slideIndex As Long
    Dim shp, selectedShp, closestShp As Shape
    Dim distance, minDistance, MAX_DIST As Double
    Dim count As Long

    MAX_DIST = 9E+307
    If ActiveWindow.Selection.Type = ppSelectionShapes Then
        Dim num As Long
        Dim shapeIDs() As Long
        num = ActiveWindow.Selection.ShapeRange.Count
        ReDim shapeIDs(num)

        count = 0
        slideIndex = ActiveWindow.Selection.SlideRange.SlideIndex
        For Each sld In ActivePresentation.Slides
            If sld.SlideIndex <> slideIndex Then
                ' 清空 shapeIDs 数组
                For i = 1 To num
                    shapeIDs(i) = -1
                Next i

                num = 0
                For Each selectedShp In ActiveWindow.Selection.ShapeRange
                    num = num + 1
                    minDistance = MAX_DIST
                    For Each shp In sld.Shapes
                        If shp.Type = selectedShp.Type And Not IsInArray(shp.Id, shapeIDs) Then
                            distance = GetDistance(shp, selectedShp)
                            If distance < minDistance Then
                                minDistance = distance
                                Set closestShp = shp
                            End If
                        End If
                    Next shp

                    If minDistance < MAX_DIST Then
                        ' 找到了最近的未经处理的形状
                        shapeIDs(num) = closestShp.Id
                        ProcessOneShape closestShp, selectedShp.Left, selectedShp.Top, selectedShp.Width, selectedShp.Height
                    End If
                    count = count + 1
                Next selectedShp
            End If
        Next sld
        MsgBox "共对齐了" & count & "个形状。"
    Else
        MsgBox "未发现任何选中的形状", vbExclamation, "No Shape Found"
    End If
End Sub


Function ProcessOneShape(oSh As Shape, left As Single, top As Single, width As Single, Height As Single)
    Dim lockAspectRatio As Boolean

    oSh.Left = left
    oSh.Top = top

    lockAspectRatio = oSh.LockAspectRatio
    oSh.LockAspectRatio = msoFalse
    oSh.Width = width
    oSh.Height = height
    oSh.LockAspectRatio = lockAspectRatio
End Function


Function GetDistance(ByVal oSh1 As Shape, ByVal oSh2 As Shape) As Double
    Dim distX, distY As Double

    centerX1 = oSh1.Left + oSh1.Width * 0.5
    centerX2 = oSh2.Left + oSh2.Width * 0.5
    centerY1 = oSh1.Top + oSh1.Height * 0.5
    centerY2 = oSh2.Top + oSh2.Height * 0.5

    distX = centerX1 - centerX2
    distY = centerY1 - centerY2

    GetDistance = Sqr(distX * distX + distY * distY)
End Function


'https://wellsr.com/vba/2016/excel/check-if-value-is-in-array-vba/
Private Function IsInArray(valToBeFound As Long, arr() As Long) As Boolean
Dim element As Variant
On Error GoTo IsInArrayError: 'array is empty
    For Each element In arr
        If element = valToBeFound Then
            IsInArray = True
            Exit Function
        End If
    Next element
Exit Function
IsInArrayError:
On Error GoTo 0
IsInArray = False
End Function
'选中的那些形状会被作为参考，之后其他页中与它们名字相同且类型相同的形状，会被设置为与之相同的位置、大小、格式
' 【注意】：这里的名字是指选中某个形状后，在「选择窗格」的形状列表中对应被选中项的名字。

作者：Emrys
链接：https://www.zhihu.com/question/442816732/answer/1790328897
来源：知乎
著作权归作者所有。商业转载请联系作者获得授权，非商业转载请注明出处。

Sub AlignToSelectedShape()
    Dim sld As Slide
    Dim shp, selectedShp As Shape
    Dim slideIndex As Long
    Dim count As Long

    If ActiveWindow.Selection.Type = ppSelectionShapes Or ActiveWindow.Selection.Type = ppSelectionText Then
        ' A shape is selected or a textbox is focused (text is selected)
        count = 0
        slideIndex = ActiveWindow.Selection.SlideRange.SlideIndex
        For Each selectedShp In ActiveWindow.Selection.ShapeRange
            For Each sld In ActivePresentation.Slides
                If sld.SlideIndex <> slideIndex Then
                    For Each shp In sld.Shapes
                        If shp.Type = selectedShp.Type And shp.Name = selectedShp.Name Then
                            shp.Left = selectedShp.Left
                            shp.Top = selectedShp.Top
                            shp.Width = selectedShp.Width
                            shp.Height = selectedShp.Height
                            ' Copy format from the selected shape
                            selectedShp.PickUp
                            shp.Apply
                            count = count + 1
                        End If
                    Next shp
                End If
            Next sld
        Next selectedShp
        MsgBox "共对齐了" & count & "个形状。"
    Else
        MsgBox "未发现任何选中的形状或文本框", vbExclamation, "No Shape Found"
    End If
End Sub


'ppt插入参考文献

' 注：需要事先将每一页中对应参考文献的文本框名称统一改为 tb_ref
' （或者其他名字也可以，在下面代码中由 tb_name 变量定义），才能使用下面的代码自动进行处理。

作者：Emrys
链接：https://www.zhihu.com/question/35443903/answer/2672495862
来源：知乎
著作权归作者所有。商业转载请联系作者获得授权，非商业转载请注明出处。

Sub CollectAllRefs()
    Dim i, j, p, num_slides, count, slide_id As Long
    Dim oSld As Slide
    Dim shp As Shape
    Dim flag As Boolean
    Dim tb_name, tb_text, ret, slide_name As String
    Dim to_write() As String
    Dim tmp As String
    Dim ref_pages() As String
    Dim ref_p() As String

    'tb_name = InputBox("Please enter the name of textboxes that contain references", "Processing references", "tb_ref")
    tb_name = InputBox("请输入含有参考文献的文本框名称", "批量整理参考文献", "tb_ref")
    If StrPtr(tb_name) = 0 Then
        ' User cancels
        Exit Sub
    End If

    ReDim Preserve to_write(0 To 0)
    ReDim Preserve ref_pages(0 To 0)

    num_slides = ActivePresentation.Slides.Count
    For i = 1 To num_slides
        Set oSld = ActivePresentation.Slides(i)

        ' Skip hidden slides
        If oSld.SlideShowTransition.Hidden = msoFalse Then
            For Each oShp In oSld.Shapes
                ' Check to see if shape has a text frame and text
                If oShp.Name = tb_name And oShp.HasTextFrame And oShp.TextFrame.HasText Then
                    For p = 1 To oShp.TextFrame.TextRange.Paragraphs.Count
                        tb_text = oShp.TextFrame.TextRange.Paragraphs(p).Text
                        tb_text = Replace(tb_text, vbCrLf, "")
                        tb_text = Replace(tb_text, vbCr, "")
                        tb_text = Replace(tb_text, vbLf, "")
                        tb_text = Replace(tb_text, vbNewLine, "")
                        If Trim(tb_text & vbNullString) <> vbNullString Then
                            ' Not an empty string
                            ret = ProcessOneString(tb_text, to_write)

                            If Left(ret, 1) <> "*" Then
                                ' Add a new reference
                                ReDim Preserve to_write(0 To (UBound(to_write, 1) + 1))
                                j = UBound(to_write, 1)
                                to_write(j) = ret
                                ReDim Preserve ref_pages(0 To (UBound(ref_pages, 1) + 1))
                                ref_pages(UBound(ref_pages, 1)) = CStr(i)
                            Else
                                ' Found an existing reference
                                j = CLng(Mid(ret, 2, Len(ret)))
                                ret = to_write(j)
                                ref_pages(j) = ref_pages(j) & "," & CStr(i)
                            End If

                            ' Modify the numbering in each slide
                            count= InStr(1, oShp.TextFrame.TextRange.Paragraphs(p).Text, ret, vbTextCompare)
                            If count = 0 Then
                                ' This should not happen for normal cases
                                Debug.Print tb_text & vbNewLine & ret & vbNewLine & "==========" & vbNewLine
                            End If
                            With oShp.TextFrame.TextRange.Paragraphs(p)
                                .Characters(1, count - 1) = ""
                                .InsertBefore("[" & j - LBound(to_write) & "] ")
                            End With
                        End If
                    Next p
                End If
            Next oShp
        End If
    Next i

    Set oSld = ActivePresentation.Slides.Add(Index:=ActivePresentation.Slides.count + 1, Layout:=ppLayoutBlank)
    With oSld.Shapes.AddTextbox( _
        Orientation:=msoTextOrientationHorizontal, _
        Left:=ActivePresentation.PageSetup.SlideWidth * 0.1, _
        Top:=ActivePresentation.PageSetup.SlideHeight * 0.1, _
        Width:=ActivePresentation.PageSetup.SlideWidth * 0.8, _
        Height:=ActivePresentation.PageSetup.SlideHeight * 0.8 _
    ).TextFrame
        count = 0
        For i = LBound(to_write) To UBound(to_write)
            If Trim(to_write(i) & vbNullString) <> vbNullString Then
                count = count + 1
                tmp = "[" & count & "] " & to_write(i) & " "
                With .TextRange.InsertAfter(tmp)
                    .Font.Superscript = msoFalse
                End With

                ' Add link to pages that refer to the references
                ref_p = Split(ref_pages(i), ",")
                flag = msoFalse
                For j = LBound(ref_p) To UBound(ref_p)
                    If Trim(ref_p(j) & vbNullString) <> vbNullString Then
                        If flag Then
                            With .TextRange.InsertAfter(", ")
                                .Font.Superscript = msoTrue
                            End With
                        End If
                        With .TextRange.InsertAfter(ref_p(j))
                            slide_id = ActivePresentation.Slides(CLng(ref_p(j))).SlideID
                            slide_name = ActivePresentation.Slides(CLng(ref_p(j))).Name
                            .ActionSettings(1).Hyperlink.SubAddress = slide_id & "," & ref_p(j) & "," & slide_name
                            .Font.Superscript = msoTrue
                        End With
                        flag = msoTrue
                    End If
                Next j
                If i < UBound(to_write) Then
                    With .TextRange.InsertAfter(vbNewLine)
                        .Font.Superscript = msoFalse
                    End With
                End If
            End If
        Next i
        .AutoSize = ppAutoSizeShapeToFitText
    End With

    If count > 0 Then
        'MsgBox "Added " & count & " references at the end"
        MsgBox "已在尾页添加 " & count & " 条参考文献"
    Else
        oSld.Delete
        'MsgBox "No reference is found"
        MsgBox "未找到参考文献"
    End If
End Sub


Function ProcessOneString(in_text As Variant, all_text As Variant) As String
    Dim j As Long
    Dim found_match As Boolean
    Dim record As String

    Dim strPattern As String
    #If Mac Then
        sMacScript = "set s to """ & in_text & """" & vbNewLine & _
        "set srpt to ""echo \"""" & s & ""\"" | sed -r \""s/^([0-9]+([[:space:]]|\\.)|[[【][0-9]+[]】]|\\*)[[:space:]]*//\""""" & vbNewLine & _
        "return (do shell script srpt)"

        Debug.Print sMacScript
        in_text = MacScript(sMacScript)
    #Else
        strPattern = "^([0-9]+[\s\.]|[\[【][0-9]+[\]】]|\*)\s*"
        Set regEx = CreateObject("VBScript.RegExp")
        With regEx
            .Global = True
            .MultiLine = False
            .IgnoreCase = True
            .Pattern = strPattern
        End With

        If regEx.TEST(in_text) Then
            in_text = regEx.Replace(in_text, "")
        End If
    #End If

    found_match = msoFalse
    For j = LBound(all_text) To UBound(all_text)
        record = CStr(all_text(j))
        If Trim(record & vbNullString) <> vbNullString Then
            If InStr(1, record, in_text, vbTextCompare) > 0 Then
                found_match = msoTrue
                ProcessOneString = "*" & CStr(j)
                Exit For
            End If
        End If
    Next j
    If found_match = msoFalse Then
        ProcessOneString = in_text
    End If

End Function


'ppt删除备注
Sub RemoveAllSpeakerNotes()
    Dim sld As Slide
    For Each sld In ActivePresentation.Slides
        sld.NotesPage.Shapes.Placeholders(2).TextFrame.TextRange = ""
    Next sld
End Sub


' 如果不想要导出全部幻灯片的备注，可以在代码里面修改页码范围，即把下面的代码
' For i = 1 To num_slides修改成你想要的范围（如第 4 页 到第 8 页）：For i = 4 To 8Sub ExportNote()
Sub ExportText()
  Dim oPres As Presentation
  Dim oSlides As Slides
  Dim oSld As Slide         'Slide Object
  Dim oShp As Shape         'Shape Object
  Dim iFile As Integer      'File handle for output
  iFile = FreeFile          'Get a free file number
  Dim PathSep As String
  Dim path As String
  Dim FileNum As Integer
  Dim sTempString As String

  Set oPres = ActivePresentation
  Set oSlides = oPres.Slides
  filename = oPres.FullName

  #If Mac Then
    PathSep = "/"
    path = MacScript("return POSIX path of (path to desktop folder)")
    if Right(path, 1) = PathSep And Len(path) > 1 Then
        path = Mid(path, 1, Len(path) - 1)
    End If
  #Else
    PathSep = "\"
    path = oPres.Path
  #End If

  FileNum = FreeFile

  'Open output file
  ' NOTE:  errors here if file hasn't been saved
  Open path & PathSep & filename & ".txt" For Output As FileNum

  On Error GoTo ErrorHandler   ' Enable error-handling routine.

  num_slides = ActivePresentation.Slides.Count

  For i = 1 To num_slides
    Set oSld = ActivePresentation.Slides(i)
    Print #iFile, "(Page " & CStr(oSld.SlideNumber) & ")" & vbNewLine

    Print #iFile, oSld.NotesPage.Shapes.Placeholders(2).TextFrame.TextRange

    Print #iFile, "--------------------------" & vbNewLine & vbNewLine & vbNewLine
    Next i
  Close #iFile

  MsgBox "文件已创建在'" & path & PathSep & filename & ".txt'"

  Exit Sub       ' Exit to avoid handler.
  ErrorHandler:  ' Error-handling routine.
    Print #iFile, "(Error)" & vbNewLine
    Resume Next  ' Resume execution at the statement immediately
                 ' following the statement where the error occurred.
End Sub




' ' Windows 上从单页或多页 PPT 中提取所有文本框内的文字


' 作者：Emrys
' 链接：https://www.zhihu.com/question/387555935/answer/1160380698
' 来源：知乎
' 著作权归作者所有。商业转载请联系作者获得授权，非商业转载请注明出处。

' 运行之后，就会在 PPT 同目录下生成与 PTT 文件同名的 .txt 文件，其中内容格式如下：Slide: [页码编号][这一页第1个形状的名称]: [文本内容][这一页第2个形状的名称]: [文本内容]Slide: [页码编号][这一页第1个形状的名称]: [文本内容]……<img src="https://pic4.zhimg.com/v2-b21f804fae7fb6313caac4e29e094293_b.jpg" data-size="normal" data-rawwidth="1497" data-rawheight="877" data-default-watermark-src="https://pic1.zhimg.com/v2-8693b062705e0c7c6b9a77165d6f20e8_b.jpg" class="origin_image zh-lightbox-thumb" width="1497" data-original="https://pic4.zhimg.com/v2-b21f804fae7fb6313caac4e29e094293_r.jpg"/>导出文本的格式上面用到的 VBA 代码如下（也适用于 Mac）：如果不想要导出全部幻灯片的文本，可以在代码里面修改页码范围，即把下面的代码For i = 1 To num_slides修改成你想要的范围（如第 4 页 到第 8 页）：For i = 4 To 8Sub ExportText()
  Dim oPres As Presentation
  Dim oSlides As Slides
  Dim oSld As Slide         'Slide Object
  Dim oShp As Shape         'Shape Object
  Dim iFile As Integer      'File handle for output
  iFile = FreeFile          'Get a free file number
  Dim PathSep As String
  Dim FileNum As Integer
  Dim sTempString As String

  #If Mac Then
    PathSep = "/"
  #Else
    PathSep = "\"
  #End If

  Set oPres = ActivePresentation
  Set oSlides = oPres.Slides

  FileNum = FreeFile

  'Open output file
  ' NOTE:  errors here if file hasn't been saved
  'Open oPres.Path & PathSep & "AllText.txt" For Output As FileNum
  Open oPres.Path & PathSep & oPres.Name & ".txt" For Output As FileNum
  
  num_slides = ActivePresentation.Slides.Count

  For i = 1 To num_slides
    Set oSld = ActivePresentation.Slides(i)
    Print #iFile, "Slide:" & vbTab & CStr(oSld.SlideNumber)

    For Each oShp In oSld.Shapes
      'Check to see if shape has a text frame and text
      If oShp.HasTextFrame And oShp.TextFrame.HasText Then
        If oShp.Type = msoPlaceholder Then
            Select Case oShp.PlaceholderFormat.Type
                Case Is = ppPlaceholderTitle, ppPlaceholderCenterTitle
                    Print #iFile, "标题：" & vbTab & oShp.TextFrame.TextRange
                Case Is = ppPlaceholderBody
                    Print #iFile, "正文：" & vbTab & oShp.TextFrame.TextRange
                Case Is = ppPlaceholderSubtitle
                    Print #iFile, "副标题：" & vbTab & oShp.TextFrame.TextRange
                Case Else
                    Print #iFile, "其他占位符：" & vbTab & oShp.TextFrame.TextRange
            End Select
        Else
            Print #iFile, vbTab & oShp.TextFrame.TextRange
        End If  ' msoPlaceholder
      Else  ' it doesn't have a textframe - it might be a group that contains text so:
        If oShp.Type = msoGroup Then
            sTempString = TextFromGroupShape(oShp)
            If Len(sTempString) > 0 Then
                Print #iFile, sTempString
            End If
        End If
      End If    ' Has text frame/Has text
    Next oShp
    
    Print #iFile, vbCrLf
    Next i
  Close #iFile

  'MsgBox "文件已创建在 '" & oPres.Path & PathSep & "AllText.txt'"
  MsgBox "文件已创建在 '" & oPres.Path & PathSep & oPres.Name & ".txt'"
End Sub

Function TextFromGroupShape(oSh As Shape) As String
' Returns the text from the shapes in a group
' and recursively, text within shapes within groups within groups etc.

    Dim oGpSh As Shape
    Dim sTempText As String

    If oSh.Type = msoGroup Then
        For Each oGpSh In oSh.GroupItems
            With oGpSh
                If .Type = msoGroup Then
                    sTempText = sTempText & TextFromGroupShape(oGpSh)
                Else
                    If .HasTextFrame Then
                        If .TextFrame.HasText Then
                            sTempText = sTempText & "(Gp:) " & .TextFrame.TextRange.Text & vbCrLf
                        End If
                    End If
                End If
            End With
        Next
    End If

    TextFromGroupShape = sTempText

NormalExit:
    Exit Function

Errorhandler:
    Resume Next

End Function

ppt每页插图



'------------------------PPT-------------------------------------------
'vba如何给每张PPT批量插入一张（各种格式无固定命名的)图片，且确保图片大小是一样的

作者：Emrys
链接：https://www.zhihu.com/question/547915281/answer/2655781983
来源：知乎
著作权归作者所有。商业转载请联系作者获得授权，非商业转载请注明出处。

代码中的 numPicturePerSlide 的值需要根据实际需要进行调整，这里默认设置为 3， 即每页 PPT 插入 3 张图片。Sub InsertPicturesToPPT()
  Dim sld As Slide
  Dim shp As Shape
  Dim i, count, numPicturePerSlide As Long
  Dim slideWidth, slideHeight As Single

  '用这个变量设置每页 PPT 要插入的图片数量
  numPicturePerSlide = 3

  fd = Split(FileDialogOpen, vbLf)
  If Left(fd(0), 1) = "-" Then
    Debug.Print "Canceled"
    Exit Sub
  End If

  slideWidth = ActivePresentation.PageSetup.SlideWidth
  slideHeight = ActivePresentation.PageSetup.SlideHeight

  count = 0
  For Each sld In ActivePresentation.Slides
    ' 跳过隐藏的 PPT 页
    If sld.SlideShowTransition.Hidden = msoFalse Then
      If count + LBound(fd) > UBound(fd) Then
        ' No picture to insert
        Exit For
      End If

      For i = 1 To numPicturePerSlide
        If count + LBound(fd) <= UBound(fd) Then
          Set shp = sld.Shapes.AddPicture( _
            FileName:=fd(count + LBound(fd)), _
            LinkToFile:=msoFalse, _
            SaveWithDocument:=msoTrue, _
            Left:=0, _
            Top:=0, _
            Width:=-1, _
            Height:=-1 _
          )
          With shp
            .LockAspectRatio = msoTrue  ' 锁定纵横比
            '.ScaleHeight 0.75, msoTrue
            .Left = slideWidth / numPicturePerSlide * i - .Width / 2
            .Top = (slideHeight - .Height) / 2
            '.ZOrder msoSendToBack   ' 将图片设置为最底层
          End With
          count = count + 1
        Else
          Exit For
        End If
      Next i
    End If
  Next sld

  'MsgBox "Processing finished. Inserted (" & count & ") pictures in total"
  MsgBox "插入图片完成，共插入 " & count & " 张图片"

End Sub