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

zinah

Active Member
Joined
Nov 28, 2018
Messages
353
Office Version
  1. 365
Platform
  1. Windows
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!
 

Excel Facts

Test for Multiple Conditions in IF?
Use AND(test, test, test, test) or OR(test, test, test, ...) as the logical_test argument of IF.
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
 
Upvote 0

Forum statistics

Threads
1,213,535
Messages
6,114,192
Members
448,554
Latest member
Gleisner2

We've detected that you are using an adblocker.

We have a great community of people providing Excel help here, but the hosting costs are enormous. You can help keep this site running by allowing ads on MrExcel.com.
Allow Ads at MrExcel

Which adblocker are you using?

Disable AdBlock

Follow these easy steps to disable AdBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the icon in the browser’s toolbar.
2)Click on the "Pause on this site" option.
Go back

Disable AdBlock Plus

Follow these easy steps to disable AdBlock Plus

1)Click on the icon in the browser’s toolbar.
2)Click on the toggle to disable it for "mrexcel.com".
Go back

Disable uBlock Origin

Follow these easy steps to disable uBlock Origin

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back

Disable uBlock

Follow these easy steps to disable uBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back
Back
Top