Using VBA to insert images in a grid pattern

[legg1979]

I am after some help if i may.

I'm very new to VBA & trying to get my head round it with not a lot of sucsses.
I can edit & add to already written codes so they meet my needs but i have hit a brick wall with this 1.

I have a great code found on this forum written by @Domenic MrExcel MVP

It inserts pictures in a grid format but the problem is it uses .Pictures.Insert so the pictures are linked to a folder.
I need them to embed to the Excel workbook.
In the past i have been able achieve this by using the .AddPicture then LinkToFile set as True.

I have tried changing this code but am getting errors. I can only assume it is to do with how the code gets the file names?
Cant work out what the (i) is or how i would use it with .AddPicture
The code is a bit over my head if im honest & i could do with some help please.

Thanks in advance

Sub InsertPictures() 
    Dim vFilename           As Variant
    Dim oPic                As Picture
    Dim StartRow            As Long
    Dim StartCol            As Long
    Dim NumCols             As Long
    Dim i                   As Long
    Dim r                   As Long
    Dim c                   As Long
    
    vFilename = Application.GetOpenFilename( _
        FileFilter:="Pictures (*.gif;*.jpg;*.png), *.gif;*.jpg;*.png", _
        Title:="Select Picture", _
        MultiSelect:=True) 'change the file filter accordingly
        
    If Not IsArray(vFilename) Then Exit Sub
    
    StartRow = 5 'change the start row accordingly
    StartCol = 1 'change the start column accordingly
    NumCols = 3 'change the number of columns accordingly
    
    r = StartRow
    c = StartCol
    For i = LBound(vFilename) To UBound(vFilename)
        Set oPic = ActiveSheet.Pictures.Insert(vFilename(i))
        With oPic
            .ShapeRange.LockAspectRatio = msoFalse
            .Left = Cells(r, c).MergeArea.Left
            .Top = Cells(r, c).MergeArea.Top
            .Width = Cells(r, c).MergeArea.Width
            .Height = Cells(r, c).MergeArea.Height
        End With
        If i Mod NumCols = 0 Then
            r = r + 13
            c = StartCol
        Else
            c = c + 6
        End If
    Next i
 
End Sub

 

[tugkan]

Hi,

Please try the codes below. But you have to configure for yourself

Private Sub MAKRO1()
ActiveSheet.DrawingObjects.Delete

Dim x

For i = 1 To 100

x = i * 1

Cells(x, "F").Select
picturename = LoadPicture("")
picturename = Cells(x, "B").Text & ".jpg"
On Error Resume Next
ActiveSheet.Pictures.Insert("c:\pictures\" & picturename).Select
Selection.ShapeRange.LockAspectRatio = msoFalse
Selection.ShapeRange.Height = 50
Selection.ShapeRange.Width = 110
Selection.ShapeRange.Rotation = 0#
Selection.ShapeRange.IncrementLeft 0.49
Selection.ShapeRange.IncrementTop 0.31


Next


End Sub

This code inserts the pictures to column "F" which matches the names written column "B"
You can change the pictures attributes from the selection height,width,rotation,increment

 

[legg1979]

Hi Tugkan

Thanks for your reply.

Unfortunately your code doesn't really work for my needs.

I need to be able to select multiple pictures via GetFile UI, I dont need the file names to be shown in any cells & more importantly this code is also LinkedToFile which is not going to be usable as the Workbook will be sent to another computer where the photos do not exist. Therefore they need to be embeded / saved with Excel file.

The code i previously posted is doing exactly what i need all apart from embeding / saving the pictures with the workbook.