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

zinah

Board Regular
Joined
Nov 28, 2018
Messages
164
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 pathGROWTHINNOVATIONOPERATIONAL EXCELLENCETALENT
Card#CommitmentsNOTESCustomerSellRevenueProfitCommercialMarketPipelineNCSSSRClientLaunchScal*SalesGROWTHInnovationINNOVATIONCIContinuous ImprovementWasteLeanwhat * whyOp*sNOSSafetyPQVCSilent Operations212PID6sigmaLEANCulture4ETalentDev*RetentionTRPTrainingLead*TeamEngagePromo*CommunicateNN VoiceLearn*HREducationCore Value*PeoplecareerTALENT
NN19_CC001AAAFALSETRUEFALSEFALSEFALSEFALSEFALSEFALSEFALSEFALSEFALSEFALSEFALSE1FALSE0TRUEFALSEFALSEFALSEFALSETRUEFALSEFALSEFALSETRUEFALSEFALSEFALSE3FALSEFALSETRUEFALSEFALSEFALSEFALSEFALSEFALSEFALSEFALSEFALSEFALSEFALSEFALSEFALSEFALSEFALSEFALSE1
NN19_CC002BBBFALSEFALSEFALSEFALSEFALSEFALSEFALSEFALSEFALSEFALSEFALSEFALSEFALSE0FALSE0TRUEFALSETRUEFALSEFALSEFALSEFALSEFALSEFALSEFALSEFALSEFALSEFALSE2FALSEFALSEFALSEFALSEFALSEFALSEFALSEFALSETRUETRUEFALSEFALSEFALSEFALSEFALSEFALSEFALSEFALSEFALSE2
NN19_CC003CCCFALSEFALSEFALSEFALSEFALSEFALSEFALSEFALSEFALSEFALSEFALSEFALSEFALSE0FALSE0FALSEFALSEFALSEFALSEFALSEFALSEFALSEFALSEFALSEFALSEFALSEFALSEFALSE0FALSETRUEFALSETRUEFALSEFALSEFALSEFALSEFALSEFALSEFALSEFALSEFALSETRUEFALSEFALSEFALSEFALSEFALSE3
NN19_CC004AAATRUEFALSEFALSEFALSEFALSEFALSEFALSEFALSEFALSETRUEFALSEFALSEFALSE2FALSE0FALSEFALSEFALSEFALSEFALSEFALSEFALSETRUEFALSEFALSEFALSEFALSEFALSE1FALSEFALSEFALSEFALSEFALSEFALSETRUEFALSEFALSEFALSEFALSEFALSEFALSEFALSEFALSEFALSEFALSEFALSEFALSE1
NN19_CC005BBBFALSEFALSEFALSEFALSETRUEFALSEFALSEFALSEFALSEFALSEFALSEFALSEFALSE1FALSE0TRUEFALSEFALSEFALSEFALSEFALSETRUEFALSEFALSEFALSEFALSETRUEFALSE3FALSEFALSEFALSEFALSEFALSEFALSEFALSEFALSETRUEFALSETRUETRUEFALSEFALSEFALSEFALSEFALSEFALSEFALSE3

<tbody>
</tbody>


Thank you!
 

Some videos you may like

Excel Facts

Bring active cell back into view
Start at A1 and select to A9999 while writing a formula, you can't see A1 anymore. Press Ctrl+Backspace to bring active cell into view.

zinah

Board Regular
Joined
Nov 28, 2018
Messages
164
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
 

Watch MrExcel Video

Forum statistics

Threads
1,095,479
Messages
5,444,732
Members
405,298
Latest member
fxtrtr17

This Week's Hot Topics

Top