mc12951
06-30-2022, 02:54 PM
I have been working on the below to bring an image into Column A where the full file path to the .jpg exists in Column B.
Other values may also exist in Column B so I want to check that the path is valid. When it is I want to import the image and when it isn't valid I want to move to the next cell.
I've found that the code works when selecting single cells and even 2 cells, but 3 or more in the range and it fails by generating a 1004 runtime error.
'macro that will insert an image in a selected range based on the path.jpg in the column to the right
Sub InsertPic()
'set some parameters
Dim Pic As String 'file path of pic
Dim myPicture As Picture 'embedded pic
Dim rng As Range 'range over which we will iterate
Dim cl As Range 'iterator
Dim FileName As String 'for checking if file exists
'use the user selected cells as the selection range
Set rng = Selection
'look in the cell to the right for the image value
For Each cl In rng
Pic = cl.Offset(0, 1)
'set a filename for the image link in the adjacent cell
'check if the filename is valid
'if it isn't valid move down to "NextRow" which is towards the bottom of this macro
On Error GoTo NextRow:
FileName = VBA.FileSystem.Dir(Pic)
If FileName <> VBA.Constants.vbNullString Then
'if no errors found and the filename is valid then import the image and set dimensions
Set myPicture = ActiveSheet.Pictures.Insert(Pic)
With myPicture
.ShapeRange.LockAspectRatio = msoTrue
.Height = 150
'.Width = cl.Width
.Top = Rows(cl.Row).Top + 4
.Left = Columns(cl.Column).Left + 4
cl.RowHeight = myPicture.Height + 4
'cl.ColumnWidth = myPicture.Width + 4
LinkToFile = msoFalse
SaveWithDocument = msoTrue
End With
Else
End If
NextRow:
'move to the next cell
Next
End Sub
It feels like I'm very close to the solution but have spent a good few hours trying to get to a point where it's error free and have failed. Any help really appreciated!!
Other values may also exist in Column B so I want to check that the path is valid. When it is I want to import the image and when it isn't valid I want to move to the next cell.
I've found that the code works when selecting single cells and even 2 cells, but 3 or more in the range and it fails by generating a 1004 runtime error.
'macro that will insert an image in a selected range based on the path.jpg in the column to the right
Sub InsertPic()
'set some parameters
Dim Pic As String 'file path of pic
Dim myPicture As Picture 'embedded pic
Dim rng As Range 'range over which we will iterate
Dim cl As Range 'iterator
Dim FileName As String 'for checking if file exists
'use the user selected cells as the selection range
Set rng = Selection
'look in the cell to the right for the image value
For Each cl In rng
Pic = cl.Offset(0, 1)
'set a filename for the image link in the adjacent cell
'check if the filename is valid
'if it isn't valid move down to "NextRow" which is towards the bottom of this macro
On Error GoTo NextRow:
FileName = VBA.FileSystem.Dir(Pic)
If FileName <> VBA.Constants.vbNullString Then
'if no errors found and the filename is valid then import the image and set dimensions
Set myPicture = ActiveSheet.Pictures.Insert(Pic)
With myPicture
.ShapeRange.LockAspectRatio = msoTrue
.Height = 150
'.Width = cl.Width
.Top = Rows(cl.Row).Top + 4
.Left = Columns(cl.Column).Left + 4
cl.RowHeight = myPicture.Height + 4
'cl.ColumnWidth = myPicture.Width + 4
LinkToFile = msoFalse
SaveWithDocument = msoTrue
End With
Else
End If
NextRow:
'move to the next cell
Next
End Sub
It feels like I'm very close to the solution but have spent a good few hours trying to get to a point where it's error free and have failed. Any help really appreciated!!