Insert picture name in worksheet change

[YasserKhalil]

Hello everyone

I am inserting pictures from different locations manually and I need to put a code in worksheet change that would enable me to insert the picture name (not the whole path neither the extension) and the picture name would be put in the cell below the picture inserted

Thanks advanced for help

[YasserKhalil]

Any help in this topic please

[mdmackillop]

Dim c As Range
Dim x As Long
Dim pic, Ht
Dim FileToOpen
Dim FName, f
Dim i
Set c = ActiveCell
x = c.Top
FileToOpen = Application.GetOpenFilename("Picture Files (*.*), *.*")
FName = Split(FileToOpen, "\")(UBound(Split(FileToOpen, "\")))
f = InStrRev(FName, ".") - 1
FName = Left(FName, f)
Set pic = ActiveSheet.Pictures.Insert(FileToOpen)
Ht = pic.Height
For i = 1 To 1000
If c.Offset(i).Top - x > Ht + 10 Then
c.Offset(i) = FName
Exit For
End If
Next i

[YasserKhalil]

Thank you very much for this great solution
I just wonder if there is a way to make this happens in worksheet change as soon as the picture inserted ..

If not possible : Can the code be adjusted to insert the picture to specific range and adjust its dimensions according to that range (say A1:C5 for example)
Thanks a lot for great help

[mdmackillop]

Dim c As Range
Dim x As Long
Dim pic, Ht
Dim FileToOpen
Dim FName, f
Dim i
Set c = Cells(1, 1)
Ht = Cells(6, 1).Top
FileToOpen = Application.GetOpenFilename("Picture Files (*.*), *.*")
FName = Split(FileToOpen, "\")(UBound(Split(FileToOpen, "\")))
f = InStrRev(FName, ".") - 1
FName = Left(FName, f)
c.Select
Set pic = ActiveSheet.Pictures.Insert(FileToOpen)
pic.Height = Ht
Cells(6, 1) = FName

[YasserKhalil]

Thanks a lot for this wonderful code. I have tried to edit to adopt it for selection and it worked well except for one point ..which I can't figure it out why happened

Sub InsertPicturePath() Dim c As Range
Dim x As Long
Dim pic, Ht
Dim FileToOpen
Dim FName, f
Dim i As Long


Set c = Selection
If c.Count > 1 Then MsgBox "Select One Cell", vbExclamation: Exit Sub
Ht = Selection.Resize(6, 3).Top
FileToOpen = Application.GetOpenFilename("Picture Files (*.*), *.*")
FName = Split(FileToOpen, "\")(UBound(Split(FileToOpen, "\")))
f = InStrRev(FName, ".") - 1
If f = -1 Then Exit Sub
FName = Left(FName, f)
c.Select
Set pic = ActiveSheet.Pictures.Insert(FileToOpen)
pic.Height = Ht
Selection.Offset(6).Value = FName
Set c = Nothing
End Sub




I tried several times but each time according to column position I got different dimensions for the same picture
For example : select A1 and run the code .. then select J5 and run the code then select any other cell and run the code. Every time I got different dimensions
Any ideas ..

[mdmackillop]

Sub InsertPicturePath()
Dim c As Range
Dim x As Long
Dim pic, Ht
Dim FileToOpen
Dim FName, f
Dim i As Long


Set c = Selection
If c.Count > 1 Then MsgBox "Select One Cell", vbExclamation: Exit Sub
Ht = c.Offset(6).Top - c.Top
FileToOpen = Application.GetOpenFilename("Picture Files (*.*), *.*")
FName = Split(FileToOpen, "\")(UBound(Split(FileToOpen, "\")))
f = InStrRev(FName, ".") - 1
If f = -1 Then Exit Sub
FName = Left(FName, f)
Set pic = ActiveSheet.Pictures.Insert(FileToOpen)
pic.Height = Ht
Selection.Offset(6).Value = FName
Set c = Nothing
End Sub

[YasserKhalil]

Thank you very much for this wonderful help
Many thanks ... It is my pleasure to know such a great person like you
Regards