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