Inserting Pictures Code change

klarowe

Active Member
Joined
Mar 28, 2011
Messages
389
I need some help asap. I currently have this code that inserts some pictures, resizes them, etc. However, it seems like they are being inserted as an object not a picture. So if the folder name is changed, the pictures are not showing up in the report. Can someone point me in the direction of changing the code so that the pictures will be inserted as pictures, not as objects?
Thanks in advance.
Code:
Sub InsertPictures()    
    Dim i As Long
    Dim rngDest As Range
    Dim arrPics() As String
    Dim objPic As Object
    
    DisableScreen
    
    With Application.FileDialog(msoFileDialogFilePicker)
        .AllowMultiSelect = True
        .Filters.Clear
        .Filters.Add "Images", "*.gif; *.jpg; *.jpeg"
        .InitialFileName = CurDir
        .FilterIndex = 2
        If .Show = -1 Then
            For i = 1 To .SelectedItems.Count
                ReDim Preserve arrPics(1 To i)
                arrPics(i) = .SelectedItems(i)
            Next
        Else
            EnableScreen
            Exit Sub
        End If
    End With
    
    Set rngDest = Range("A65536").End(xlUp).Offset(7, 0)
    For i = 1 To UBound(arrPics)
        Set objPic = ActiveSheet.Pictures.Insert(arrPics(i))
        With objPic
            .Placement = xlMoveAndSize
            .ShapeRange.LockAspectRatio = msoTrue
            .ShapeRange.Width = 215#
            .Left = rngDest.Left
            .Top = rngDest.Top
        End With
        Set rngDest = rngDest.Offset(1 + (objPic.Height \ 20))
    Next
    
    EnableScreen
    Exit Sub
End Sub
 

Excel Facts

Who is Mr Spreadsheet?
Author John Walkenbach was Mr Spreadsheet until his retirement in June 2019.
Could you put the pictures in the sheet as embedded objects then hide them and when made visible by code , postion them where you want them.
 
Upvote 0
Not really sure how to do that. However I did make some progress. Through some searching I was able to get this code to work but it only allows me to select one picture at a time, which will work, but obviously the ability to select multiple pictures would be better. Any way to modify this new code to allow me to select multiple pictures? I tried combining the 2 codes, but anytime I change the 'myPicture' Dim, it throws off one of the code parts.

Code:
Sub InsertPictures()
    Dim oPic As Object
    Dim myPicture As String
    
    DisableScreen
    
    myPicture = Application.GetOpenFilename("Pictures (*.gif; *.jpg; *.bmp; *.tif),*.gif; *.jpg; *.bmp; *.tif", , "Select Picture to Import")
        If myPictures = "False" Then Exit Sub
        Set rngDest = Range("A65536").End(xlUp).Offset(7, 0)
        Set oPic = ActiveSheet.Shapes.AddPicture(myPicture, False, True, rngDest.Left, rngDest.Top, 215, 160)
            oPic.Placement = xlMoveAndSize
       
    EnableScreen
    
End Sub
 
Upvote 0
Here is the code I almost have working:
Code:
Sub InsertPictures()    Dim rngDest As Range
    Dim oPic As Object
    Dim myPictures As Variant
    Dim lngIndex As Long
    
    DisableScreen
    
    myPictures = Application.GetOpenFilename("Pictures (*.gif; *.jpg; *.bmp; *.tif),*.gif; *.jpg; *.bmp; *.tif", , "Select Picture to Import", , True)
        If TypeName(myPictures) <> "Boolean" Then
            For lngIndex = LBound(myPictures) To UBound(myPictures)
                Set rngDest = Range("A65536").End(xlUp).Offset(7, 0)
                Set oPic = ActiveSheet.Shapes.AddPicture(myPictures, False, True, rngDest.Left, rngDest.Top, 215, 160)
                oPic.Placement = xlMoveAndSize
            Next lngIndex
        End If
    
    EnableScreen


End Sub

Unfortunately, in order for the multiple picture select to work, I have to dim myPicture as Variant, but in order to get the .AddPicture to work correctly, I have to dim myPicture as String. I tried adding in a ReDim, but it didn't work either...
 
Upvote 0
I think the Variant thing refers to looping through a for each loop.
In your original code the Multi select option only occurs when you select the Multi files by holding down "Ctrl" as you select,
Did you try that ?????
 
Upvote 0
Not quite sure what you want me to try.. lol. Yes, teh variant refers to the ability to loop through the for, each. And yes, you have to hold CTRL while selecting the pictures. But if I don't have it set as a String, when I try selecting the pictures (either just a single, or multiple) it throws an error. If I change it to Variant then it allows me to select them, but throws an error on the part of the code to actually insert them.

Its really hard to explain, but basically each code works fine on its own, but when brought together it errors out due to the 'Dim' of 'myPictures'. It has to be a Variant in order for the select portion of the code to work, but it has to be a String for the insertion portion of the code.
 
Upvote 0
Got it figured out. Just wasn't implementing enough of my original code. For those wondering, here was the final result:
Code:
Sub InsertPictures()
    Dim rngDest As Range
    Dim oPic As Object
    Dim arrPics() As String
    
    DisableScreen
    
With Application.FileDialog(msoFileDialogFilePicker)
        .AllowMultiSelect = True
        .Filters.Clear
        .Filters.Add "Images", "*.gif; *.jpg; *.jpeg"
        .InitialFileName = CurDir
        .FilterIndex = 2
        If .Show = -1 Then
            For i = 1 To .SelectedItems.Count
                ReDim Preserve arrPics(1 To i)
                arrPics(i) = .SelectedItems(i)
            Next
        Else
            EnableScreen
            Exit Sub
        End If
    End With
    
    Set rngDest = Range("A65536").End(xlUp).Offset(7, 0)
    For i = 1 To UBound(arrPics)
        Set oPic = ActiveSheet.Shapes.AddPicture(arrPics(i), False, True, rngDest.Left, rngDest.Top, 215, 160)
            oPic.Placement = xlMoveAndSize
        Set rngDest = rngDest.Offset(1 + (oPic.Height \ 25))
    Next
    
    EnableScreen
End Sub
 
Upvote 0
Both you codes work for me, in the second code I just altered the line shown in Red.
Rich (BB code):
Sub InsertPictures()
Dim rngDest As Range
    Dim oPic As Object
    Dim myPictures As Variant
    Dim lngIndex As Long
    Dim Ray
    'DisableScreen
    
    myPictures = application.GetOpenFilename("Pictures (*.gif; *.jpg; *.bmp; *.tif),*.gif; *.jpg; *.bmp; *.tif", , "Select Picture to Import", , True)
        If TypeName(myPictures) <> "Boolean" Then
            For lngIndex = LBound(myPictures) To UBound(myPictures)
                Set rngDest = Range("A65536").End(xlUp).Offset(7, 0)
                Set oPic = ActiveSheet.Shapes.AddPicture(myPictures(lngIndex), False, True, rngDest.Left, rngDest.Top, 215, 160)
                oPic.Placement = xlMoveAndSize
            Next lngIndex
        End If
End Sub
 
Upvote 0
That's what I was missing in that code. Oh well, now I have 2 codes to choose from. Thanks for the help!
 
Upvote 0

Forum statistics

Threads
1,213,543
Messages
6,114,240
Members
448,555
Latest member
RobertJones1986

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