我想将图像从目录粘贴到 PowerPoint 中,然后调整它们的大小。
我有 16 张图片都在一个目录中,每个月都需要更新。任务是:
目录是(例如)“C:\Users\xxxxxx\Documents\Work\Procurement Project\Slides”
第一个图像名称是(例如)“01 摘要”,第二个图像名称是“02 客户合同”等。
我认为我需要一个 str 和一个路径以及一个表,以便将 str 添加到路径中,以使用 i 和 i + 1 等创建每个新路径。
我认为需要这样的代码:
Sub Picture_size_and_position()
Dim oShape As Shape
Dim oPresentation As Presentation
Dim oSlide As Slide
Dim oSelection As Selection
ActiveWindow.View.GotoSlide oSlide.SlideIndex
With ActiveWindow.Selection.ShapeRange
.LockAspectRatio = msoFalse
.Height = 550
.Width = 960
.Left = 0
.Top = 0
End With
End Sub
然后我确定我需要一个循环来重复此操作,直到使用 i 和 j 的某种组合在目录中没有任何内容为止。
Sub ImportABunch()
Dim strTemp As String
Dim strPath As String
Dim strFileSpec As String
Dim oSld As Slide
Dim oPic As Shape
' Edit these to suit:
strPath = "C:\Users\username\"
strFileSpec = "*.png"
strTemp = Dir(strPath & strFileSpec)
i = 1
Do While strTemp <> ""
Set oSld = ActivePresentation.Slides(i)
Set oPic = oSld.Shapes.AddPicture(FileName:=strPath & strTemp, _
LinkToFile:=msoFalse, _
SaveWithDocument:=msoTrue, _
Left:=0, _
Top:=0, _
Width:=960, _
Height:=550)
i = i + 1
With oPic
.LockAspectRatio = msoFalse
.ZOrder msoSendToBack
End With
' Or (with thanks to David Marcovitz) make the picture as big as possible on the slide
' without changing the proportions
' Leave the above commented out, uncomment this instead:
' With oPic
' If 3 * .width > 4 * .height Then
' .width = ActivePresentation.PageSetup.Slidewidth
' .Top = 0.5 * (ActivePresentation.PageSetup.Slideheight - .height)
' Else
' .height = ActivePresentation.PageSetup.Slideheight
' .Left = 0.5 * (ActivePresentation.PageSetup.Slidewidth - .width)
' End If
' End With
' Optionally, add the full path of the picture to the image as a tag:
'With oPic
' .Tags.Add "OriginalPath", strPath & strTemp
'End With
' Get the next file that meets the spec and go round again
strTemp = Dir
Loop
End Sub
感谢 http://www.pptfaq.com/index.html - 很棒的小网站!
有一个想法使其自动化/或手动启动新的启用宏的 PowerPoint 模板文件。要在文件打开时自动执行宏,请添加自定义UI:
onLoad="ImagesToPowerPoint"
。搜索“CustomUI Editor”。
注意我还没有完全测试自动化部分。
Option Explicit
Sub ImagesToPowerPoint()
Const FileType As String = "*.png"
Dim sSaveFilePath As String, sSaveFileName As String, sImagesFolder As String
Dim oLayout As CustomLayout, oSlide As Slide, i As Long, sFile As String
sImagesFolder = Environ("USERPROFILE") & "\Documents\Work\Procurement Project\Slides\"
' Prepare auto save PowerPoint file name
sSaveFilePath = Environ("USERPROFILE") & "\Documents\Work\PowerPoints\"
sSaveFileName = Format(Now, "yyyy_mmdd") & "_Procurement.pptx"
With ActivePresentation
' Use the first layout for all new slides
Set oLayout = .SlideMaster.CustomLayouts(1)
' Start processing all files in the folder
sFile = Dir(sImagesFolder & FileType)
Do Until sFile = ""
' Add new slide
Set oSlide = .Slides.AddSlide(.Slides.Count, oLayout)
' Delete all the shapes from that layout
For i = oSlide.Shapes.Count To 1 Step -1
oSlide.Shapes(i).Delete
Next
' Add the image to slide
With oSlide.Shapes.AddPicture(sImagesFolder & sFile, msoFalse, msoTrue, 0, 0, oLayout.Width, oLayout.Height)
.LockAspectRatio = msoFalse
.AlternativeText = Now & " | " & sImagesFolder & sFile
End With
sFile = Dir
Loop
.SaveAs sSaveFilePath & sSaveFileName
End With
Presentations(sSaveFileName).Close
If Presentations.Count = 0 Then Application.Quit
End Sub