我有 55,000 个演示文稿中的 500,000 张幻灯片。我想为每张幻灯片添加一张图片。
我可以从 Excel 打开演示文稿，但随后我必须手动将宏添加到其中一个演示文稿并将其设置为循环播放。
我发现一次打开 50 个演示文稿可以防止系统内存不足而崩溃。这很费力。我想打开每个文件运行宏，关闭文件并使用 Excel 循环遍历所有文件。
打开文件的代码。
Sub Open_PPT_Irregular_Files()
Dim arrPPTFiles(500) As Variant 'Change value to amount of presentations
Dim DestinationPPT As String
Dim PowerPointApp As PowerPoint.Application
Dim myPresentation As PowerPoint.Presentation
Dim i, v, w, x, y, z As Integer
Dim strT As String
v = 500 'Change value to amount of presentations
w = 0 'Halting position to stop running out of memory
x = 1 'Starting cell position update as required
y = 9 'Ending cell position update as required
Dim arrPPT(500) As Variant 'Change value to amount of presentations
Sheets("PPTIrregular").Select
'I hold the path to all the presentations on this sheet.... populated from a recursive query
For i = 1 To v
arrPPT(i) = Range("A" & i).Value2
Next
Set PowerPointApp = CreateObject("PowerPoint.Application")
For i = 1 To v
DestinationPPT = arrPPT(i) '"path"
PowerPointApp.Presentations.Open (DestinationPPT)
PowerPointApp.ActiveWindow.WindowState = ppWindowMinimized
'Application.Run "Copyright.xlsm!Paste_CopyrightPPT.Paste_CopyrightPPT"
If w = 50 Then
'at this point i select manually a presentation and then import the macro to it and loop x 50 times
'before continuing the code for next 50 etc...
Stop
w = 0
End If
w = w + 1
Next
End Sub
运行我手动添加的 PowerPoint 宏的代码。
Sub callCopyRight()
For i = 1 To 50
Call Paste_CopyrightPPT
Next
End Sub
Sub Paste_CopyrightPPT()
'PowerPoint Macro Only! Not tested in excel yet.
' In order to run this code first make sure the logo exists in objImageBox
Dim i, y, z As Integer
Dim objPresentaion As Presentation
Dim objSlide As Slide
Dim objImageBox As Shape
i = 2
y = ActivePresentation.Slides.Count
z = 2
For i = 1 To y
Set objPresentaion = ActivePresentation
Set objSlide = objPresentaion.Slides.Item(i)
'Storing the picture below...
Set objImageBox = objSlide.Shapes.AddPicture("C:\Users\Gazza\Desktop\_MasterBreakdowns '\Copyright.jpg", msoCTrue, msoCTrue, 100, 100)
objSlide.Shapes.Item(2).Top = 1
objSlide.Shapes.Item(2).Left = 1
objSlide.Shapes.Item(2).Width = 60
objSlide.Shapes.Item(2).Height = 15
Next
PowerPoint.ActivePresentation.Slides(1).Select
PowerPoint.ActivePresentation.Save
PowerPoint.ActivePresentation.Close
End Sub
我需要在逐个演示文稿的基础上从 Excel 运行此代码的变体。
你可以试试这个：
Const IMG_PATH As String = "C:temp\Copyright.jpg" 'for example
Sub Open_PPT_Irregular_Files()
Dim PowerPointApp As PowerPoint.Application, myPres As PowerPoint.Presentation
Dim i As Long, wsList As Worksheet
Set wsList = ThisWorkbook.Sheets("PPTIrregular")
Set PowerPointApp = CreateObject("PowerPoint.Application")
PowerPointApp.Visible = True
For i = 1 To 500
Set myPres = PowerPointApp.Presentations.Open(wsList.Cells(i, "A").Value)
UpdatePres myPres
myPres.Save
myPres.Close
Next i
End Sub
Sub UpdatePres(pres As PowerPoint.Presentation)
Dim sld As PowerPoint.Slide
For Each sld In pres.Slides
sld.Shapes.AddPicture fileName:=IMG_PATH, linktofile:=msoFalse, _
savewithdocument:=msoTrue, Top:=1, Left:=1, _
Width:=60, Height:=15
Next sld
End Sub
如果幻灯片全部使用相同的母版，则将图像添加到那里可能会比添加到每张单独的幻灯片更快。
我试图通过 Excel 宏控制 powerpoint 演示文稿，但在运行 powerpoint 宏时卡住了，因为我需要为每个演示文稿手动运行它。 将其调整为一次运行 100 个批次，但对于 55000 个演示文稿，每个演示文稿更新 9 张幻灯片仍然非常耗时。
思考了这个问题，决定尝试在powerpoint内完成所有事情。
创建了一个主 PowerPoint 演示文稿，其中包含以下宏，并用它来更新所有内容。
公共子 DoFilesMulti()
将 k 设为整数 Dim arrLists(19) 作为变体
arrLists(1) = "C:\Users\Gazza\Desktop_MasterBreakdowns _Indicative Present\Regular" arrLists(2) = "C:\Users\Gazza\Desktop_MasterBreakdowns _Indicative Future\Regular" arrLists(3) = "C:\Users\Gazza\Desktop_MasterBreakdowns _Indicative Imperfect\Regular" arrLists(4) = "C:\Users\Gazza\Desktop_MasterBreakdowns _Indicative Preterite\Regular" arrLists(5) = "C:\Users\Gazza\Desktop_MasterBreakdowns _Indicative Conditional\Regular" arrLists(6) = "C:\Users\Gazza\Desktop_MasterBreakdowns _Perfect 现在完成时\常规" arrLists(7) = "C:\Users\Gazza\Desktop_MasterBreakdowns _Perfect Future Perfect\Regular" arrLists(8) = "C:\Users\Gazza\Desktop_MasterBreakdowns 8_Perfect Pluperfect\Regular" arrLists(9) = "C:\Users\Gazza\Desktop_MasterBreakdowns 9_Perfect 条件完美\常规" arrLists(10) = "C:\Users\Gazza\Desktop_MasterBreakdowns _Perfect 过去前\常规" arrLists(11) = "C:\Users\Gazza\Desktop_MasterBreakdowns _Subjunctive Present\Regular" arrLists(12) = "C:\Users\Gazza\Desktop_MasterBreakdowns _虚拟语气不完美\常规" arrLists(13) = "C:\Users\Gazza\Desktop_MasterBreakdowns _Subjunctive Imperfect 2\Regular" arrLists(14) = "C:\Users\Gazza\Desktop_MasterBreakdowns _Subjunctive Future\Regular" arrLists(15) = "C:\Users\Gazza\Desktop_MasterBreakdowns _虚拟语气完美现在完成\常规” arrLists(16) = "C:\Users\Gazza\Desktop_MasterBreakdowns _虚拟将来完成时\常规" arrLists(17) = "C:\Users\Gazza\Desktop_MasterBreakdowns _Subjunctive Perfect Pluperfect\Regular" arrLists(18) = "C:\Users\Gazza\Desktop_MasterBreakdowns 8_Subjunctive Perfect Pluperfect 2\Regular" arrLists(19) = "C:\Users\Gazza\Desktop_MasterBreakdowns 9_Commands 命令式\常规" k = 14 '起点......
对于 k = 1 到 19
Dim strFileName As String
Dim strFolderName As String
Dim PP As Presentation
'set default directory here if needed
strFolderName = arrLists(k)
strFileName = Dir(strFolderName & "\*.ppt*")
Do While Len(strFileName) > 0
Set PP = Presentations.Open(strFolderName & "\" & strFileName)
'your code
' In order to run this code first make sure the logo exists in objImageBox
Dim i, y, z As Integer
Dim objPresentaion As Presentation
Dim objSlide As Slide
Dim objImageBox As Shape
i = 2
y = ActivePresentation.Slides.Count
z = 2
For i = 1 To y
Set objPresentaion = ActivePresentation
Set objSlide = objPresentaion.Slides.Item(i)
Set objImageBox = objSlide.Shapes.AddPicture("C:\Users\Gazza\Desktop\_MasterBreakdowns\00_Macros\Copyright.jpg", msoCTrue, msoCTrue, 100, 100)
objSlide.Shapes.Item(2).Top = 1
objSlide.Shapes.Item(2).Left = 1
objSlide.Shapes.Item(2).Width = 60
objSlide.Shapes.Item(2).Height = 15
Next
PowerPoint.ActivePresentation.Slides(1).Select
PowerPoint.ActivePresentation.Save
PowerPoint.ActivePresentation.Close
strFileName = Dir
Loop
下一步 结束子