3
\$\begingroup\$

I have a series of images ("1.bmp", "2.bmp", "3.bmp",... ,"30.bmp" in "F:\Images" folder) and I am trying to insert these images one by one into Microsoft PowerPoint with VBA program. The base slide (as template) has been set down in page 2. The image object which is named Image1 in that template slide is going to be replaced into "F:\Images\1.bmp", "F:\Images\2.bmp"... separately in new slides after the base slide.

The experimental implementation

The main entry method is InsertFigures.

Sub InsertFigures()
    'Reference: (Show object name) https://stackoverflow.com/a/52088805
    'Reference: (Replace image) https://stackoverflow.com/a/18083223
    
    Dim BaseSlideNumber As Integer
    Dim StartNum, EndNum As Integer
    StartNum = 1
    EndNum = 30
    BaseSlideNumber = 2
    Dim LoopNumber As Integer
    For LoopNumber = StartNum To EndNum
      Set newSlide = ActivePresentation.Slides(BaseSlideNumber).Duplicate
    Next LoopNumber
    
    For LoopNumber = StartNum To EndNum
        NewPictureFilename = "F:\Images\" & CStr(LoopNumber) & ".bmp"  ' Source Image Path
        Dim TargetSlideNumber As Integer
        TargetSlideNumber = BaseSlideNumber + (LoopNumber - StartNum + 1)
        Set ObjectForGettingProperties = getShapeByName("Image1", TargetSlideNumber)
        'Capture properties of exisitng picture such as location and size
        With ObjectForGettingProperties
            TopProperty = .Top
            LeftProperty = .Left
            HeightProperty = .Height
            WidthProperty = .Width
            'SoftEdgeProperty = .SoftEdge
        End With
        ObjectForGettingProperties.Delete                       ' Delete origin placeholder
        
        Set NewImageObject = ActivePresentation.Slides(TargetSlideNumber).Shapes.AddPicture(NewPictureFilename, msoFalse, msoTrue, LeftProperty, TopProperty, WidthProperty, HeightProperty)
        NewImageObject.Name = "NewImage"                  ' Set image name
        NewImageObject.SoftEdge.Radius = 8.86
    Next LoopNumber
    
    
End Sub

Function getShapeByName(shapeName As String, Slide As Integer)
    'Reference: https://stackoverflow.com/a/5527604
    Set getShapeByName = ActivePresentation.Slides(Slide).Shapes(shapeName)
End Function

All suggestions are welcome.

\$\endgroup\$
1
\$\begingroup\$

Overall, there's not much to comment on for the code logic -- it does what you need it to do. But there are some details to pay attention to that will help in this and future code.

  1. Always use Option Explicit. There are a couple of undeclared variables/objects in your code that leads me to believe this directive is not present. Turn it on and leave it on.
  2. Be careful when declaring multiple variables on a single line.

In your code where you have

Dim StartNum, EndNum As Integer

Then StartNum will be a Variant and EndNum will be an Integer, which is not exactly what you want. It might be a pain, but save yourself and declare each variable on a separate line (once it's a habit, it's not as bad as you think).

  1. Declare your number variables as Long, not Integer. This answer gives a very detailed explanation, but just know it's considered a "best practice" to always use Long.
  2. This point is more of a stylistic convention, but it's considered "standard" (personal preferences apply) to declare variables with camelCase and procedure names with PascalCase and constants with SHOUTY_SNAKE_CASE (reference). If you read that reference, PLEASE don't fall down the Hungarian case rabbit hole. (These conventions can lead to highly entertaining comments and emotional battles about the merits of these conventions. Do what I do: get some popcorn and enjoy the show ;) )
  3. Pay attention to the arguments in your functions or subs and identify each parameters as ByRef or ByVal. Microsoft explains the difference (using Visual Basic, but it's essentially the same in VBA), and there are other good references to read to learn more about it.
  4. This is really my own personal preference, but I do try to limit the line length of each statement to around 80 characters. It it's longer, I add the continuation character. This is more of a guideline than a hard rule (for me), but it does make code easier to read.

The example below is my implementation of your code, as modified by my comments.

Option Explicit

Sub InsertFigures()
    'Reference: (Show object name) https://stackoverflow.com/a/52088805
    'Reference: (Replace image) https://stackoverflow.com/a/18083223
    
    Dim baseSlideNumber As Long
    Dim startNum As Long
    Dim endNum As Long
    startNum = 1
    endNum = 30
    baseSlideNumber = 2
    
    Dim loopNumber As Long
    Dim newSlide As SlideRange
    For loopNumber = startNum To endNum
      Set newSlide = ActivePresentation.Slides(baseSlideNumber).Duplicate
    Next loopNumber
    
    For loopNumber = startNum To endNum
        Dim newPictureFilename As String
        Dim targetSlideNumber As Long
        newPictureFilename = "F:\Images\" & CStr(loopNumber) & ".bmp"  ' Source Image Path
        targetSlideNumber = baseSlideNumber + (loopNumber - startNum + 1)
        
        Dim topProperty As Double
        Dim leftProperty As Double
        Dim heightProperty As Double
        Dim widthProperty As Double
        Dim softEdgeProperty As Double
        
        'Capture properties of exisitng picture such as location and size
        Dim objectForGettingProperties As Shape
        Set objectForGettingProperties = GetShapeByName("Image1", targetSlideNumber)
        With objectForGettingProperties
            topProperty = .Top
            leftProperty = .Left
            heightProperty = .Height
            widthProperty = .Width
            'SoftEdgeProperty = .SoftEdge
        End With
        objectForGettingProperties.Delete           ' Delete origin placeholder
        
        Dim newImageObject As Object
        Set newImageObject = ActivePresentation.Slides(targetSlideNumber) _
                                     .Shapes.AddPicture(newPictureFilename, _
                                                        msoFalse, msoTrue, _
                                                        leftProperty, _
                                                        topProperty, _
                                                        widthProperty, _
                                                        heightProperty)
        newImageObject.Name = "NewImage"        'Set image name
        newImageObject.SoftEdge.Radius = 8.86
    Next loopNumber
End Sub

Function GetShapeByName(ByVal shapeName As String, ByVal Slide As Long) As Shape
    'Reference: https://stackoverflow.com/a/5527604
    Set GetShapeByName = ActivePresentation.Slides(Slide).Shapes(shapeName)
End Function
\$\endgroup\$

Your Answer

By clicking “Post Your Answer”, you agree to our terms of service, privacy policy and cookie policy

Not the answer you're looking for? Browse other questions tagged or ask your own question.