Call a specific picture (PNG) to PPTX according to condition
Results 1 to 2 of 2

Thread: Call a specific picture (PNG) to PPTX according to condition
Thanks Thanks: 0 Likes Likes: 0

  1. #1
    Board Regular
    Join Date
    Nov 2018
    Location
    US, TX
    Posts
    118
    Post Thanks / Like
    Mentioned
    1 Post(s)
    Tagged
    0 Thread(s)

    Default Call a specific picture (PNG) to PPTX according to condition

    Hi,

    I have a list in excel sheet that has themes (words analysis) this list is generated from pictures that have these words. What I need is to create a macro to call any picture to pptx if it meets the condition below:

    If I choose the theme "Growth", then I need all the pictures that under is them to be called and pasted in my pptx.
    Below is the example of my list and I have a simple macro that calls the picture but without a condition, here's the macro:

    Code:
    Sub SavePDF()Dim PowerPointApp As Object
    Dim myPPTX As Object
    Dim mySlide As Object
    Dim pptxNm As String
    Dim oPicture As Object
    
    
    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
    
    
    
    
    pptxNm = "Cards.pptm"
    Set myPPTX = PowerPointApp.Presentations(pptxNm)
    
    
    PowerPointApp.Visible = True
    PowerPointApp.Activate
    
    
    
    
    'Adds second slide
    Set mySlide = myPPTX.Slides.Add(myPPTX.Slides.Count + 1, 12)
    mySlide.Select
    
    
    'mySlide.Shapes.AddOLEObject Left:=10, Top:=10, Width:=(7.5 * 72), Height:=(10 * 72), _
        Filename:=[B1].Value & "\" & [A132].Value & ".pdf", displayasicon:=msoFalse, link:=msoTrue
    
    
    Set oPicture = mySlide.Shapes.AddPicture([B1].Value & "\" & [A132].Value & ".png", _
        msoFalse, msoTrue, Left:=10, Top:=10, Width:=(7.5 * 72), Height:=(10 * 72))
    
    
    With oPicture
      .PictureFormat.CropLeft = 0
      .PictureFormat.CropTop = 0
      .PictureFormat.CropRight = 0
      .PictureFormat.CropBottom = oPicture.Height / 1.85
      .Name = [A132].Value
    End With
    
    
    
    
    
    
    End Sub
    Dropdown list *picture saved path GROWTH INNOVATION OPERATIONAL EXCELLENCE TALENT
    Card# Commitments NOTES Customer Sell Revenue Profit Commercial Market Pipeline NCS SSR Client Launch Scal* Sales GROWTH Innovation INNOVATION CI Continuous Improvement Waste Lean what * why Op*s NOS Safety PQVC Silent Operations 212 PID 6sigma LEAN Culture 4E Talent Dev* Retention TRP Training Lead* Team Engage Promo* Communicate NN Voice Learn* HR Education Core Value* People career TALENT
    NN19_CC001 AAA FALSE TRUE FALSE FALSE FALSE FALSE FALSE FALSE FALSE FALSE FALSE FALSE FALSE 1 FALSE 0 TRUE FALSE FALSE FALSE FALSE TRUE FALSE FALSE FALSE TRUE FALSE FALSE FALSE 3 FALSE FALSE TRUE FALSE FALSE FALSE FALSE FALSE FALSE FALSE FALSE FALSE FALSE FALSE FALSE FALSE FALSE FALSE FALSE 1
    NN19_CC002 BBB FALSE FALSE FALSE FALSE FALSE FALSE FALSE FALSE FALSE FALSE FALSE FALSE FALSE 0 FALSE 0 TRUE FALSE TRUE FALSE FALSE FALSE FALSE FALSE FALSE FALSE FALSE FALSE FALSE 2 FALSE FALSE FALSE FALSE FALSE FALSE FALSE FALSE TRUE TRUE FALSE FALSE FALSE FALSE FALSE FALSE FALSE FALSE FALSE 2
    NN19_CC003 CCC FALSE FALSE FALSE FALSE FALSE FALSE FALSE FALSE FALSE FALSE FALSE FALSE FALSE 0 FALSE 0 FALSE FALSE FALSE FALSE FALSE FALSE FALSE FALSE FALSE FALSE FALSE FALSE FALSE 0 FALSE TRUE FALSE TRUE FALSE FALSE FALSE FALSE FALSE FALSE FALSE FALSE FALSE TRUE FALSE FALSE FALSE FALSE FALSE 3
    NN19_CC004 AAA TRUE FALSE FALSE FALSE FALSE FALSE FALSE FALSE FALSE TRUE FALSE FALSE FALSE 2 FALSE 0 FALSE FALSE FALSE FALSE FALSE FALSE FALSE TRUE FALSE FALSE FALSE FALSE FALSE 1 FALSE FALSE FALSE FALSE FALSE FALSE TRUE FALSE FALSE FALSE FALSE FALSE FALSE FALSE FALSE FALSE FALSE FALSE FALSE 1
    NN19_CC005 BBB FALSE FALSE FALSE FALSE TRUE FALSE FALSE FALSE FALSE FALSE FALSE FALSE FALSE 1 FALSE 0 TRUE FALSE FALSE FALSE FALSE FALSE TRUE FALSE FALSE FALSE FALSE TRUE FALSE 3 FALSE FALSE FALSE FALSE FALSE FALSE FALSE FALSE TRUE FALSE TRUE TRUE FALSE FALSE FALSE FALSE FALSE FALSE FALSE 3


    Thank you!

  2. #2
    Board Regular
    Join Date
    Nov 2018
    Location
    US, TX
    Posts
    118
    Post Thanks / Like
    Mentioned
    1 Post(s)
    Tagged
    0 Thread(s)

    Default Re: Call a specific picture (PNG) to PPTX according to condition

    Here's an updated macro, what I need is instead of having the pictures in one slide, I need a picture in each slide. How can I do that?

    Code:
    Sub CreatePagePerComment()Dim PowerPointApp As Object
    Dim myPPTX As Object
    Dim mySlide As Object
    Dim pptxNm As String
    
    
    Dim oPicture As Object
    
    
    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
    
    
    
    
    pptxNm = "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("NN_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:A6]
    
    
    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

Some videos you may like

User Tag List

Tags for this Thread

Like this thread? Share it with others

Like this thread? Share it with others

Posting Permissions

  • You may not post new threads
  • You may not post replies
  • You may not post attachments
  • You may not edit your posts
  •