Consulting

Results 1 to 4 of 4

Thread: Modify a powerpoint VBA

  1. #1
    VBAX Newbie
    Joined
    Jul 2018
    Posts
    2
    Location

    Modify a powerpoint VBA

    Hello! I want that this macro can insert more than one picture per slide.
    For example 4 directories with pictures, and it can insert 4 pictures (one from each directory) in each new slide.
    Thanks
    Sub ImportABunch()

    Dim strTemp As String
    Dim strPath As String
    Dim strFileSpec As String
    Dim oSld As Slide
    Dim oPic As Shape

    Dim lCurrentRound As Long
    lCurrentRound = 1

    ' Edit these to suit:
    'strPath = "C:\Users\dklaz\Desktop\Prep for China\Factory Pictures\Best Beteck"
    strPath = "P:\photos\MakePrints_2008_Japan"
    strFileSpec = "*.jpg"

    strTemp = Dir(strPath & strFileSpec)

    Do While strTemp <> ""

    If lCurrentRound = 1 Then ' add a new slide
    Set oSld = ActivePresentation.Slides.Add(ActivePresentation.Slides.Count + 1, ppLayoutCustom)
    End If
    Set oPic = oSld.Shapes.AddPicture(FileName:=strPath & strTemp, _
    LinkToFile:=msoFalse, _
    SaveWithDocument:=msoTrue, _
    Left:=0, _
    Top:=0, _
    Width:=-1, _
    Height:=-1)

    ' Edit the Left/Top values below if you want to place
    ' the images in specific locations
    ' Select Case lCurrentRound
    ' Case 1
    ' oPic.Left = 0
    ' oPic.Top = 0
    '
    ' Case 2
    ' oPic.Left = 100
    ' oPic.Top = 100
    '
    ' Case 3
    ' oPic.Left = 200
    ' oPic.Top = 200
    '
    ' Case 4
    ' oPic.Left = 300
    ' oPic.Top = 300
    ' End Select

    '' Or try something like this to assign each
    '' image's top/left to a quadrant
    Select Case lCurrentRound
    Case 1
    oPic.Left = 0
    oPic.Top = 0

    Case 2
    oPic.Left = ActivePresentation.PageSetup.SlideWidth / 2
    oPic.Top = 0

    Case 3
    oPic.Left = 0
    oPic.Top = ActivePresentation.PageSetup.SlideHeight / 2

    Case 4
    oPic.Left = ActivePresentation.PageSetup.SlideWidth / 2
    oPic.Top = ActivePresentation.PageSetup.SlideHeight / 2
    End Select

    If lCurrentRound = 4 Then
    lCurrentRound = 1
    Else
    lCurrentRound = lCurrentRound + 1
    End If

    strTemp = Dir

    Loop

    End Sub

  2. #2
    VBAX Master
    Joined
    Feb 2007
    Posts
    1,700
    Location
    John Wilson
    Microsoft PowerPoint MVP
    Amazing Free PowerPoint Tutorials
    http://www.pptalchemy.co.uk/powerpoi...tutorials.html

  3. #3
    VBAX Newbie
    Joined
    Jul 2018
    Posts
    2
    Location

    Trying to modify it mysel, but no success|

    Sub ImportABunch()


    Dim strTemp As String
    Dim strPath As String
    Dim strFileSpec As String
    Dim oSld As Slide
    Dim oPic As Shape


    Dim lCurrentRound As Long
    lCurrentRound = 1


    ' Edit these to suit:
    strPath = "D:\aa"
    strPath1 = "D:\aaa"
    strFileSpec = "*.png"


    strTemp = Dir(strPath & strFileSpec)
    strTemp1 = Dir(strPath1 & strFileSpec)
    Do While strTemp <> ""



    Set oSld = ActivePresentation.Slides.Add(ActivePresentation.Slides.Count + 1, ppLayoutCustom)

    Set oPic = oSld.Shapes.AddPicture(FileName:=strPath & strTemp, _
    LinkToFile:=msoFalse, _
    SaveWithDocument:=msoTrue, _
    Left:=0, _
    Top:=0, _
    Width:=-1, _
    Height:=-1)



    Set oPic = oSld.Shapes.AddPicture(FileName:=strPath1 & strTemp1, _
    LinkToFile:=msoFalse, _
    SaveWithDocument:=msoTrue, _
    Left:=0, _
    Top:=0, _
    Width:=-1, _
    Height:=-1)





    If lCurrentRound = 1 Then

    lCurrentRound = lCurrentRound + 1
    End If


    strTemp = Dir


    Loop


    End Sub
















    ****************************

    Quote Originally Posted by avogadro View Post
    Hello! I want that this macro can insert more than one picture per slide.
    For example 4 directories with pictures, and it can insert 4 pictures (one from each directory) in each new slide.
    Thanks
    Sub ImportABunch()

    Dim strTemp As String
    Dim strPath As String
    Dim strFileSpec As String
    Dim oSld As Slide
    Dim oPic As Shape

    Dim lCurrentRound As Long
    lCurrentRound = 1

    ' Edit these to suit:
    'strPath = "C:\Users\dklaz\Desktop\Prep for China\Factory Pictures\Best Beteck"
    strPath = "P:\photos\MakePrints_2008_Japan"
    strFileSpec = "*.jpg"

    strTemp = Dir(strPath & strFileSpec)

    Do While strTemp <> ""

    If lCurrentRound = 1 Then ' add a new slide
    Set oSld = ActivePresentation.Slides.Add(ActivePresentation.Slides.Count + 1, ppLayoutCustom)
    End If
    Set oPic = oSld.Shapes.AddPicture(FileName:=strPath & strTemp, _
    LinkToFile:=msoFalse, _
    SaveWithDocument:=msoTrue, _
    Left:=0, _
    Top:=0, _
    Width:=-1, _
    Height:=-1)

    ' Edit the Left/Top values below if you want to place
    ' the images in specific locations
    ' Select Case lCurrentRound
    ' Case 1
    ' oPic.Left = 0
    ' oPic.Top = 0
    '
    ' Case 2
    ' oPic.Left = 100
    ' oPic.Top = 100
    '
    ' Case 3
    ' oPic.Left = 200
    ' oPic.Top = 200
    '
    ' Case 4
    ' oPic.Left = 300
    ' oPic.Top = 300
    ' End Select

    '' Or try something like this to assign each
    '' image's top/left to a quadrant
    Select Case lCurrentRound
    Case 1
    oPic.Left = 0
    oPic.Top = 0

    Case 2
    oPic.Left = ActivePresentation.PageSetup.SlideWidth / 2
    oPic.Top = 0

    Case 3
    oPic.Left = 0
    oPic.Top = ActivePresentation.PageSetup.SlideHeight / 2

    Case 4
    oPic.Left = ActivePresentation.PageSetup.SlideWidth / 2
    oPic.Top = ActivePresentation.PageSetup.SlideHeight / 2
    End Select

    If lCurrentRound = 4 Then
    lCurrentRound = 1
    Else
    lCurrentRound = lCurrentRound + 1
    End If

    strTemp = Dir

    Loop

    End Sub

  4. #4
    VBAX Master
    Joined
    Feb 2007
    Posts
    1,700
    Location
    You haven't understood the point of cross posting! You need to tell people helping that you have asked on other forums.

    That said does each directory have the same number of images and are they all jpgs?
    John Wilson
    Microsoft PowerPoint MVP
    Amazing Free PowerPoint Tutorials
    http://www.pptalchemy.co.uk/powerpoi...tutorials.html

Tags for this Thread

Posting Permissions

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