Question

我认为这可以解决许多人的问题，他们将乏味的图像从一个目录粘贴到PowerPoint中，然后调整其大小。

我的问题是我在一个目录中有16张图像，每个月都需要更新，而一张一张地做起来很慢。任务是：

打开目录
打开第一张图片
将图像粘贴到PowerPoint中
将图像重新定位到左上方
按宽度960将图像调整为高度550（填充A4页面）
向后发送图像
移至下一张幻灯片
重复第二张图片
继续，直到目录中没有图像

目录是（例如）“ C：\ Users \ xxxxxx \ Documents \ Work \ Procurement Project \ Slides”

第一个图片名称是（例如）“ 01摘要”，第二个图片名称是“ 02客户合同”等

我想我需要一个str和一个路径以及一个用于str的表，以将其添加到path中，以使用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的某种组合在目录中没有剩下的东西为止……但是整个代码远远超出了我，非常令人沮丧。

有人可以提供一些建议吗？非常感谢！

谢谢！

Answer 1

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-很棒的小网站！

Answer 2

有一个想法可以使其自动化/或在手动启动新的启用宏的PowerPoint模板文件时。要在打开文件时自动执行宏，请添加customUI：onLoad="ImagesToPowerPoint"。在“ CustomUI编辑器”中搜索它。

请注意，我尚未完全测试自动化部分。

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

Powerpoint VBA插入图像并更改大小

2 个答案: