Question

我下面有一个宏，用于将文件从excel的保存文件导入PowerPoint，我需要更新宏以使每张幻灯片带一个文件，而不是将所有文件放到一张幻灯片中

Sub CreatePagePerComment()
Dim PowerPointApp As Object
Dim myPPTX As Object
Dim mySlide As Object
Dim pptxNm As String
Dim pptNm As Range
Dim rSht As Worksheet
Dim oSht As Worksheet
Dim oPicture As Object

Set pptNm = ThisWorkbook.Sheets("Sheet1").[PPTX_File]
    Sheets("Sheet1").[PPTX_File].Value = pptNm.Value



CONFIRM_PPTX_APP:
'Create an Instance of PowerPoint
  On Error Resume Next
    'Is PowerPoint already opened?
      Set PowerPointApp = GetObject(class:="PowerPoint.Application")
    'Clear the error between errors
      Err.Clear
    'If PowerPoint is not already open then open PowerPoint
        If PowerPointApp Is Nothing Then
            'Set PowerPointApp = CreateObject(class:="PowerPoint.Application")
            With pptNm.Validation
                .Delete 'delete previous validation
            End With
            MsgBox "No PowerPoint file is open. Please open the PowerPoint file to where you " & _
                        "would like to export this table.", vbOKOnly + vbCritical, ThisWorkbook.Name
        Exit Sub
        End If

'Handle if the PowerPoint Application is not found
      If Err.Number = 429 Then
        MsgBox "PowerPoint could not be found, aborting."
        Exit Sub
      End If
  On Error GoTo 0

GET_PPTX_FILENAME:
If pptNm.Value = "" Then
    MsgBox "Please select the PowerPoint file name, from the drop down list, to where you want to export the Headcount Review summary table." & _
                Chr(10) & Chr(10) & "This Macro has selected the cell that contains a list of all open PowerPoint files. " & Chr(10) & Chr(10) & _
                "If your file is not listed, please confirm it is open, then select any other cell, then return to this cell for " & _
                "a refreshed file name list.", vbOKOnly + vbCritical, "No PowerPoint File Selected"
    pptNm.Select
    Exit Sub
Else:
    If InStr(1, pptNm.Value, "ppt") > 0 Then
        pptxNm = pptNm.Value
    ElseIf InStr(1, pptNm.Value, "pptx") > 0 Then
        pptxNm = pptNm.Value & ".pptx"
    ElseIf InStr(1, pptNm.Value, "pptm") > 0 Then
        pptxNm = pptNm.Value & ".pptm"
    End If
End If

pptxNm = "NN Commitment Cards.pptm"
Set myPPTX = PowerPointApp.Presentations(pptxNm)

PowerPointApp.Visible = True
PowerPointApp.Activate


'Adds second slide
'MsgBox SlideShowWindows(1).View.Slide.SlideIndex
Dim Nm_shp As Shape, sld_no As Integer
Dim pIndex As Integer, pName As String

    sld_no = myPPTX.Slides.Count
    pName = "Blue Transition"
    pIndex = 3

ADD_NEW_SLIDE:
Dim SlideCnt As Integer
    Set mySlide = myPPTX.Slides.Add(sld_no + 1, 12)
    mySlide.Select
    mySlide.CustomLayout = myPPTX.Designs("N_PPTX_Theme").SlideMaster.CustomLayouts(pIndex)

'mySlide.Shapes.AddOLEObject Left:=10, Top:=10, Width:=(7.5 * 72), Height:=(10 * 72),
'   Filename:=[B1].Value & "\" & [A132].Value & ".pdf", displayasicon:=msoFalse, link:=msoTrue

For Each cel In [A3:A4]

If Cells(cel.Row, [A1].Column).Value <> "" Then
Set oPicture = mySlide.Shapes.AddPicture([B1].Value & "\" & cel.Value & ".png", _
    msoFalse, msoTrue, Left:=10, Top:=10, Width:=(6 * 72), Height:=(7 * 72))
Set oSlide = myPPTX.Slides(1)
With oPicture
  .Width = 7 * 72
  .Height = 8 * 72
  .PictureFormat.CropLeft = 0
  .PictureFormat.CropTop = 0
  .PictureFormat.CropRight = 0
  .PictureFormat.CropBottom = oPicture.Height / 1.85
  .Name = cel.Value
  .Line.Weight = 0.5
  .Line.Visible = msoTrue
  .LockAspectRatio = msoTrue
  .Left = 1.5 * 72
  .Top = 1.5 * 72
   With myPPTX.PageSetup
   oPicture.Left = (.SlideWidth \ 2) - (oPicture.Width \ 2)
   oPicture.Top = (.SlideHeight \ 2) - (oPicture.Height \ 2)
   End With
End With
End If


End Sub

为此我需要在宏中进行哪些必要的调整？

Answer 1

我假设您的其余代码都在工作，并且只专注于您的特定问题。首先，您的代码中没有引用oSlide，因此我认为这是一些错字。从我对代码的阅读中，您可以在当前幻灯片中添加一张新幻灯片，并在其中添加图片（，否则，因为该部分代码已被注释，所以不会添加图片）。然后，根据[A3:A4]的内容，您想添加新的幻灯片，每张幻灯片都有新的图片。在提供此解决方案时，我已经放弃了注释代码，并尽可能不修改您的代码（更改代码的必需部分）：

'Adds second slide
'MsgBox SlideShowWindows(1).View.Slide.SlideIndex
Dim Nm_shp As Shape, sld_no As Integer
Dim pIndex As Integer, pName As String

sld_no = myPPTX.Slides.Count
pName = "Blue Transition"
pIndex = 3

ADD_NEW_SLIDE:
Dim SlideCnt As Integer
SlidCnt = 0

For Each cel In [A3:A4]

    If Cells(cel.Row, [A1].Column).Value <> "" Then
        SlideCnt = SlideCnt + 1
        Set mySlide = myPPTX.Slides.Add(sld_no + SlideCnt, 12)
        mySlide.CustomLayout = myPPTX.Designs("N_PPTX_Theme").SlideMaster.CustomLayouts(pIndex)
        Set oPicture = mySlide.Shapes.AddPicture([B1].Value & "\" & cel.Value & ".png", _
            msoFalse, msoTrue, Left:=10, Top:=10, Width:=(6 * 72), Height:=(7 * 72))
        With oPicture
            .Width = 7 * 72
            .Height = 8 * 72
            .PictureFormat.CropLeft = 0
            .PictureFormat.CropTop = 0
            .PictureFormat.CropRight = 0
            .PictureFormat.CropBottom = oPicture.Height / 1.85
            .Name = cel.Value
            .Line.Weight = 0.5
            .Line.Visible = msoTrue
            .LockAspectRatio = msoTrue
            .Left = 1.5 * 72
            .Top = 1.5 * 72
            With myPPTX.PageSetup
                oPicture.Left = (.SlideWidth \ 2) - (oPicture.Width \ 2)
                oPicture.Top = (.SlideHeight \ 2) - (oPicture.Height \ 2)
            End With
        End With
    End If
Next cel

按图片创建幻灯片

1 个答案: