Help Modifying VBA Code to create Excel Prod Catalog ?

[mave27]

Below is VBA Macro Code which uploads Prod images from Desktop Folder onto Worksheet to create Prod Catalog.

I found this useful piece of code from this forum.

The code is Functional ie it works fine, but need some modification.

Sub InsertPic()
Dim path As String, pic As String, pname As String
Dim lastrow As Long, r As Range
Dim bExists As Boolean

path = "C:\Users\user\Desktop\NewArrivals\images" 'change as req
lastrow = Range("A" & Rows.Count).End(xlUp).Row

For Each r In Range("A2:A" & lastrow)
bExists = False
pic = r.Value
pname = path & pic & ".jpg"
' check existence of file as jpg
If Dir(pname) = vbNullString Then
' check existence of file as png
pname = path & pic & ".png"
If Dir(pname) <> vbNullString Then bExists = True
Else
bExists = True
End If

If bExists Then
Rows(r.Row).RowHeight = 150
With ActiveSheet.Pictures.Insert(pname)
With .ShapeRange
.LockAspectRatio = msoTrue
.Height = 100
.Width = 100
End With
.Left = Columns("E").Left + Columns("E").Width / 2 - .Width / 2
.Top = Rows(r.Row).Top + Rows(r.Row).Height / 2 - .Height / 2
End With
r.Offset(0, 2).Value = pic
Else
Cells(r.Row, "E") = "**** File Not Found *****"
End If
Next
End Sub

The code seems to **ALTER** the size of image during upload, which I DON'T want it to.

I have already created standard, uniform size of all images & stored in the folder.

I simply want the code to pick the image & place it on Worksheet, without re-sizing it.

The Image size is 210 px X 150 px. - the code should also adjust size of Row Height & Col Width accordingly.

Anyone care to modify the code to address that specific aspect of it's functionality ie re-sizing & also, ensure ROW / Col height/ Width ?

Thanks in Advance.

 

[Luke M]

I think this gets close to what you want. I'm a little unsure as to what your sizing requirements are.

Sub InsertPic()
Dim path As String, pic As String, pname As String
Dim lastrow As Long, r As Range
Dim bExists As Boolean
Dim sh As Picture

path = "C:\Users\user\Desktop\NewArrivals\images" 'change as req
lastrow = Range("A" & Rows.Count).End(xlUp).Row

'Error check
If Right(path, 1) <> "\" Then
    path = path & "\"
End If

For Each r In Range("A2:A" & lastrow)
    bExists = False
    pic = r.Value
    pname = path & pic & ".jpg"
    ' check existence of file as jpg
    If Dir(pname) = vbNullString Then
        ' check existence of file as png
        pname = path & pic & ".png"
        If Dir(pname) <> vbNullString Then bExists = True
    Else
        bExists = True
    End If
   
   
    'Change as needed
    Range("e1").ColumnWidth = 35
    If bExists Then
        'Since all pictures are uniform height
        Rows(r.Row).RowHeight = 150
       
        Set sh = ActiveSheet.Pictures.Insert(pname)
        With sh
'            With .ShapeRange
'                .LockAspectRatio = msoTrue
'                .Height = 100
'                .Width = 100
'            End With

            .Left = Columns("E").Left '+ Columns("E").Width / 2 - .Width / 2
            .Top = Rows(r.Row).Top '+ Rows(r.Row).Height / 2 - .Height / 2
        End With
        r.Offset(0, 2).Value = pic
    Else
        Cells(r.Row, "E") = "**** File Not Found *****"
    End If
Next
End Sub