insert images/pictures

[marc747]

Hi All,

I need help!!!
I have an excel file, the worksheet from cell B1 through K1 has file
names, all different names. I would like to be able to run a macro
that will insert images in the cells right below the file names in
cells B2 through K2, and incase there is no file name in that column
then leave that cell empty. the pictures need to be made smaller but
when sizing it should keep the ratio.
also the file names could be changing monthly so when the file names
change and I run the macro again then the old pictures should be
deleted first and then insert the new ones.
I would greatly appreciate if any one could help me with this, I
reallu need this.
Thanks in advance.

 

[Guest]

This is similar code to the code I posted in your last request. Adjust the
PictureHeight constant as necessary. file names should be complete path
names such as c:\temp\abc.bmp. No quotes or other character are required in
the file name of the pictures.

The code deletes all old pictures and then adds all the pictures. It is not
easy to only delete the pictures that have changed.

Sub add_pictures()

Const PictureHeight = 25

'delete pictures
For Each shp In ActiveSheet.Shapes
If shp.Type = msoPicture Then
shp.Delete
End If
Next shp

LastRow = Cells(Rows.Count, "A").End(xlUp).Row
Rows(2).RowHeight = PictureHeight

For Each cell In Range("B1:K1")
If cell <> "" Then
Set pict = ActiveSheet.Pictures. _
Insert(cell.Value)
pict.ShapeRange.LockAspectRatio = msoTrue
pict.ShapeRange.Height = PictureHeight
pict.Top = cell.Offset(1, 0).Top
pict.Left = cell.Offset(1, 0).Left
End If
Next cell

End Sub

 

[marc747]

This is similar code to the code I posted in your last request. Adjust the
PictureHeight constant as necessary. file names should be complete path
names such as c:\temp\abc.bmp. No quotes or other character are required in
the file name of the pictures.

The code deletes all old pictures and then adds all the pictures. It is not
easy to only delete the pictures that have changed.

Sub add_pictures()

Const PictureHeight = 25

'delete pictures
For Each shp In ActiveSheet.Shapes
If shp.Type = msoPicture Then
shp.Delete
End If
Next shp

LastRow = Cells(Rows.Count, "A").End(xlUp).Row
Rows(2).RowHeight = PictureHeight

For Each cell In Range("B1:K1")
If cell <> "" Then
Set pict = ActiveSheet.Pictures. _
Insert(cell.Value)
pict.ShapeRange.LockAspectRatio = msoTrue
pict.ShapeRange.Height = PictureHeight
pict.Top = cell.Offset(1, 0).Top
pict.Left = cell.Offset(1, 0).Left
End If
Next cell

End Sub






- Show quoted text -

Thank you very much, this worked great.

 

[marc747]

This is similar code to the code I posted in your last request. Adjust the
PictureHeight constant as necessary. file names should be complete path
names such as c:\temp\abc.bmp. No quotes or other character are required in
the file name of the pictures.

The code deletes all old pictures and then adds all the pictures. It is not
easy to only delete the pictures that have changed.

Sub add_pictures()

Const PictureHeight = 25

'delete pictures
For Each shp In ActiveSheet.Shapes
If shp.Type = msoPicture Then
shp.Delete
End If
Next shp

LastRow = Cells(Rows.Count, "A").End(xlUp).Row
Rows(2).RowHeight = PictureHeight

For Each cell In Range("B1:K1")
If cell <> "" Then
Set pict = ActiveSheet.Pictures. _
Insert(cell.Value)
pict.ShapeRange.LockAspectRatio = msoTrue
pict.ShapeRange.Height = PictureHeight
pict.Top = cell.Offset(1, 0).Top
pict.Left = cell.Offset(1, 0).Left
End If
Next cell

End Sub






- Show quoted text -

Hi, the code worked great but I need to add something to it. First, If
possible I would like to add a code that if picture is not available
or can not find then it should insert a text "Picture not Available".
Second, before it inserts the pictures it should delete all pictures &
text in the row and then insert the pictures. Thank you very much...

 

[Ken Johnson]

Hi, the code worked great but I need to add something to it. First, If
possible I would like to add a code that if picture is not available
or can not find then it should insert a text "Picture not Available".
Second, before it inserts the pictures it should delete all pictures &
text in the row and then insert the pictures. Thank you very much...

I've just added six lines (commented with 'new line) to Joel's code to
handle unfound pictures...

Sub add_pictures()

Const PictureHeight = 25

'delete pictures
For Each shp In ActiveSheet.Shapes
If shp.Type = msoPicture Then
shp.Delete
End If
Next shp

LastRow = Cells(Rows.Count, "A").End(xlUp).Row
Rows(2).RowHeight = PictureHeight

For Each cell In Range("B1:K1")
If cell <> "" Then
cell.Offset(1, 0).ClearContents
On Error GoTo NoPict 'new line
Set pict = ActiveSheet.Pictures. _
Insert(cell.Value)
If cell.Offset(1, 0).Value <> "Picture not Available" Then
'new line
pict.ShapeRange.LockAspectRatio = msoTrue
pict.ShapeRange.Height = PictureHeight
pict.Top = cell.Offset(1, 0).Top
pict.Left = cell.Offset(1, 0).Left
End If
End If 'new line
Next cell
Exit Sub 'new line

NoPict: cell.Offset(1, 0).Value = "Picture not Available" 'new line
Resume Next 'new line

End Sub


Also, adding to the top of the code...

Application.ScreenUpdating = False

will reduce most of the screen flashing.

Ken Johnson