Insert picture in excel macro which takes the file name refrence [Solved/Closed]
V Kanagu1
Posts Friday August 23, 2013Registration date
August 23, 2013
Last seen
-
Aug 23, 2013 at 01:38 PM - Latest reply: TrowaD2396
Posts Sunday September 12, 2010Registration dateModeratorStatus
July 19, 2018
Last seen
- Mar 14, 2017 at 12:18 PM
Private Sub Worksheet_Change(ByVal Target As Range)
If Intersect(Target, Range("D5")) Is Nothing Then Exit Sub
Dim myPict As Picture
With Range("I7:J12")
Set myPict = Range("I7:J12").Parent.Pictures.Insert("F:\" & Target.Value & ".jpg")
myPict.Top = .Top
myPict.Width = .Width
myPict.Height = .Height
myPict.Left = .Left
myPict.Placement = xlMoveAndSize
End With
End Sub
To try it out, right-click on your sheets tab, select View code.
Paste the code in the big white field.
Now change the value in D5 and see if the picture shows in your merged range.
However, I have an additional requirement. i.e. when i delete the value in D5 the loaded image should also get cleared (or) when i change the value in D5, the earlier loaded image should be cleared and a new image need to be loaded in i7:j12.
Private Sub Worksheet_Change(ByVal Target As Range)
If Intersect(Target, Range("D5")) Is Nothing Then Exit Sub
Dim myPict As Picture
ActiveSheet.Pictures.Delete
If Target.Value = vbNullString Then Exit Sub
With Range("I7:J12")
Set myPict = Range("I7:J12").Parent.Pictures.Insert("F:\" & Target.Value & ".jpg")
myPict.Top = .Top
myPict.Width = .Width
myPict.Height = .Height
myPict.Left = .Left
myPict.Placement = xlMoveAndSize
End With
End Sub
hi TrowaD,
thanks so much... one question again, please help me... how insert two or three pictures with different target... example : D5 to apple.jpg and H5 to orange.jpg .... i had try like code up but failed ... please and thanks again for your time
this is my code please corectly and thanks so much for your time....
i save my pictures in folder kelas 1 .... i try insert two photos but failed
example in cell c11 i type banana then banana.jpg come then i type apple to cell v2 then apple.jpg come .... two pictures take in one sheet ("lookupgambar").
Option Explicit
Private Sub Worksheet_Change(ByVal Target As Range)
Dim InsertPict As Object
Dim bolo As Object
Dim NamaFile As String
If Not Intersect(Target, Range("$C$11")) Is Nothing Then
Private Sub Worksheet_Change(ByVal Target As Range)
Dim myPict As Picture
If Not Intersect(Target, Range("C11")) Is Nothing Then
With Range("G3:L8")
Set myPict = Range("G3:L8").Parent.Pictures.Insert(ThisWorkbook.Path & "\KELAS1\" & Target.Value & ".jpg")
myPict.Top = .Top
myPict.Width = .Width
myPict.Height = .Height
myPict.Left = .Left
myPict.Placement = xlMoveAndSize
End With
ElseIf Not Intersect(Target, Range("V2")) Is Nothing Then
With Range("N3:Q8")
Set myPict = Range("N3:Q8").Parent.Pictures.Insert(ThisWorkbook.Path & "\KELAS1\" & Target.Value & ".jpg")
myPict.Top = .Top
myPict.Width = .Width
myPict.Height = .Height
myPict.Left = .Left
myPict.Placement = xlMoveAndSize
End With
Else
Exit Sub
End If
End Sub
Try the code below.
The picture height is determined by the row height and not the other way around, because screen size is also a factor.
Here is the code:
Private Sub Worksheet_Change(ByVal Target As Range)
If Intersect(Target, Columns("A:A")) Is Nothing Then Exit Sub
Dim myPict As Picture
With Cells(Target.Row, "D")
Set myPict = Cells(Target.Row, "D").Parent.Pictures.Insert("D:\images\" & Target.Value & ".jpg")
myPict.Top = .Top
myPict.Width = .Width
myPict.Height = .Height
myPict.Left = .Left
myPict.Placement = xlMoveAndSize
End With
End Sub
Here is the code I am using for my excel macro with a button.
While using it I have seen that I need some more modification which lets me to :
1. Keep aspect ratio of pictures
2. Move and size with cells.
for the images.
Is it possible to do that?
Thanks.
Private Sub CommandButton1_Click() Dim pictureNameColumn As String 'column where picture name is found Dim picturePasteColumn As String 'column where picture is to be pasted
Dim pictureName As String 'picture name Dim lastPictureRow As Long 'last row in use where picture names are Dim pictureRow As Long 'current picture row to be processed Dim pathForPicture As String 'path of pictures
pictureNameColumn = "A" picturePasteColumn = "H"
pictureRow = 5 'starts from this row
'error handler On Error GoTo Err_Handler
'find row of the last cell in use in the column where picture names are lastPictureRow = Cells(Rows.Count, pictureNameColumn).End(xlUp).Row
'stop screen updates while macro is running Application.ScreenUpdating = False
pathForPicture = "C:\images\" 'loop till last row Do While (pictureRow <= lastPictureRow)
pictureName = Cells(pictureRow, "A") 'This is the picture name
'if picture name is not blank then If (pictureName <> vbNullString) Then 'check if pic is present If (Dir(pathForPicture & pictureName & ".jpg") <> vbNullString) Then
Cells(pictureRow, picturePasteColumn).Select 'This is where picture will be inserted ActiveSheet.Pictures.Insert(pathForPicture & pictureName & ".jpg").Select 'Path to where pictures are stored
With Selection .Left = Cells(pictureRow, picturePasteColumn).Left .Top = Cells(pictureRow, picturePasteColumn).Top .ShapeRange.LockAspectRatio = msoFalse .ShapeRange.Height = 100# .ShapeRange.Width = 130# .ShapeRange.Rotation = 0# End With Else 'picture name was there, but no such picture Cells(pictureRow, picturePasteColumn) = "No Picture Found" End If Else 'picture name cell was blank End If 'increment row count pictureRow = pictureRow + 1 Loop
Exit_Sub: Range("A10").Select Application.ScreenUpdating = True Exit Sub
At the moment I can only add photos of a certain file such as .jpg or .jpeg. In my older its all mixed and thats where the problem is. All of them are not the same.
I need to add photos for everycode in coloumn "A" to the same row coloumn "E"
and I want to run a macro to add photos just after I filled up the codes coloumn and other necessary information.
Lets say image files are found in "D:\images\" folder with the same names mentioned in coloumn "A"
Besides when I add the photos I want the images to be 4,6 cm height plus pictures should be placed in the center of the cell and I need the cell height to be arranged automatically also which will fit to pictures height.
I added two of them in the code of Cakmak. Look for the green text to see the start and end of these ElseIf blocks, so you could add more if needed.
Here is the adjusted code:
Private Sub CommandButton1_Click()
Dim pictureNameColumn As String 'column where picture name is found
Dim picturePasteColumn As String 'column where picture is to be pasted
Dim pictureName As String 'picture name
Dim lastPictureRow As Long 'last row in use where picture names are
Dim pictureRow As Long 'current picture row to be processed
Dim pathForPicture As String 'path of pictures
pictureNameColumn = "A"
picturePasteColumn = "H"
pictureRow = 5 'starts from this row
'error handler
On Error GoTo Err_Handler
'find row of the last cell in use in the column where picture names are
lastPictureRow = Cells(Rows.Count, pictureNameColumn).End(xlUp).Row
'stop screen updates while macro is running
Application.ScreenUpdating = False
pathForPicture = "C:\images\"
'loop till last row
Do While (pictureRow <= lastPictureRow)
pictureName = Cells(pictureRow, "A") 'This is the picture name
'if picture name is not blank then
If (pictureName <> vbNullString) Then
'check if pic is present
'Start If block with .JPG
If (Dir(pathForPicture & pictureName & ".jpg") <> vbNullString) Then
Cells(pictureRow, picturePasteColumn).Select 'This is where picture will be inserted
ActiveSheet.Pictures.Insert(pathForPicture & pictureName & ".jpg").Select 'Path to where pictures are stored
With Selection
.Left = Cells(pictureRow, picturePasteColumn).Left
.Top = Cells(pictureRow, picturePasteColumn).Top
.ShapeRange.LockAspectRatio = msoFalse
.ShapeRange.Height = 100#
.ShapeRange.Width = 130#
.ShapeRange.Rotation = 0#
End With
'End If block with .JPG
'Start ElseIf block with .PNG
ElseIf (Dir(pathForPicture & pictureName & ".png") <> vbNullString) Then
Cells(pictureRow, picturePasteColumn).Select 'This is where picture will be inserted
ActiveSheet.Pictures.Insert(pathForPicture & pictureName & ".png").Select 'Path to where pictures are stored
With Selection
.Left = Cells(pictureRow, picturePasteColumn).Left
.Top = Cells(pictureRow, picturePasteColumn).Top
.ShapeRange.LockAspectRatio = msoFalse
.ShapeRange.Height = 100#
.ShapeRange.Width = 130#
.ShapeRange.Rotation = 0#
End With
'End ElseIf block with .PNG
'Start ElseIf block with .BMP
ElseIf (Dir(pathForPicture & pictureName & ".bmp") <> vbNullString) Then
Cells(pictureRow, picturePasteColumn).Select 'This is where picture will be inserted
ActiveSheet.Pictures.Insert(pathForPicture & pictureName & ".bmp").Select 'Path to where pictures are stored
With Selection
.Left = Cells(pictureRow, picturePasteColumn).Left
.Top = Cells(pictureRow, picturePasteColumn).Top
.ShapeRange.LockAspectRatio = msoFalse
.ShapeRange.Height = 100#
.ShapeRange.Width = 130#
.ShapeRange.Rotation = 0#
End With
'End ElseIf block with .BMP
Else
'picture name was there, but no such picture
Cells(pictureRow, picturePasteColumn) = "No Picture Found"
End If
Else
'picture name cell was blank
End If
'increment row count
pictureRow = pictureRow + 1
Loop
Exit_Sub:
Range("A10").Select
Application.ScreenUpdating = True
Exit Sub
Err_Handler:
MsgBox "Error encountered. " & Err.Description, vbCritical, "Error"
GoTo Exit_Sub
End Sub
I really found this helpful a lot but I stumbled unto something. The Pictures keep pasting over each other making the workbook increase in size. Is there a way to have the Pictures replaced the ones that are there?
Pls. Thank you very much for the codes. But in some cases if the images are missing the next image is copied in to that cell instead of showing No picture found.
has helped 1679 users this month
I don't understand. When you make a change to either cell D5 or H5, that cells value will be used as picture name.
Best regards,
Trowa
i save my pictures in folder kelas 1 .... i try insert two photos but failed
example in cell c11 i type banana then banana.jpg come then i type apple to cell v2 then apple.jpg come .... two pictures take in one sheet ("lookupgambar").
Option Explicit
Private Sub Worksheet_Change(ByVal Target As Range)
Dim InsertPict As Object
Dim bolo As Object
Dim NamaFile As String
If Not Intersect(Target, Range("$C$11")) Is Nothing Then
End If
NamaFile = ThisWorkbook.Path & "\KELAS1\" & Target.Value & ".jpg"
If Dir(NamaFile) = "" Then NamaFile = ThisWorkbook.Path & "\NoPhoto.jpg"
Call Hapus
Set InsertPict = ActiveSheet.Pictures.Insert(NamaFile)
With InsertPict
.Name = "SuperHero"
.Top = [G3].Top
.Left = [G3].Left
.Width = [G3:L8].Width
.Height = [G3:L8].Height
.ShapeRange.Line.Visible = msoTrue
.ShapeRange.Line.Weight = 2.25
End With
If Intersect(Target, Range("$v$2")) Is Nothing Then Exit Sub
NamaFile = ThisWorkbook.Path & "\KELAS1\" & Target.Value & ".jpg"
If Dir(NamaFile) = "" Then NamaFile = ThisWorkbook.Path & "\NoPhoto.jpg"
Call Hapus1
Set bolo = ActiveSheet.Pictures.Insert(NamaFile)
With bolo
.Name = "Bandi"
.Top = [n3].Top
.Left = [n3].Left
.Width = [n3:q8].Width
.Height = [n3:q8].Height
.ShapeRange.Line.Visible = msoTrue
.ShapeRange.Line.Weight = 2.25
End With
End Sub
Private Sub Hapus()
On Error Resume Next
ActiveSheet.Pictures("SuperHero").Delete
End Sub
Private Sub Hapus1()
On Error Resume Next
ActiveSheet.Pictures("Bandi").Delete
End Sub
Give the code below a try:
Private Sub Worksheet_Change(ByVal Target As Range) Dim myPict As Picture If Not Intersect(Target, Range("C11")) Is Nothing Then With Range("G3:L8") Set myPict = Range("G3:L8").Parent.Pictures.Insert(ThisWorkbook.Path & "\KELAS1\" & Target.Value & ".jpg") myPict.Top = .Top myPict.Width = .Width myPict.Height = .Height myPict.Left = .Left myPict.Placement = xlMoveAndSize End With ElseIf Not Intersect(Target, Range("V2")) Is Nothing Then With Range("N3:Q8") Set myPict = Range("N3:Q8").Parent.Pictures.Insert(ThisWorkbook.Path & "\KELAS1\" & Target.Value & ".jpg") myPict.Top = .Top myPict.Width = .Width myPict.Height = .Height myPict.Left = .Left myPict.Placement = xlMoveAndSize End With Else Exit Sub End If End SubBest regards,
Trowa
very help... thanks again