Import picture file name along with photo into cell

[brundag5]

Hello. Thanks in advance for your time.

I use the below macro to import pictures into cells and resize the photo. It works great. However I would also like to import the text from the file name (minus the file extension) and past that into an adjacent cell (15 cells below the active cell). Is this possible? Thanks!


Sub InsertPic()
Dim PicLocation As Variant

PicLocation = Application.GetOpenFilename()
If PicLocation = False Then
Range("B32") = ""
Else
ActiveSheet.Shapes.AddPicture(PicLocation, False, True, ActiveCell.Left, ActiveCell.Top, 246, 176).Select
With Selection
.ShapeRange.LockAspectRatio = msoFalse
.ShapeRange.Rotation = 0#
Selection.ShapeRange.IncrementTop 2
Selection.ShapeRange.IncrementLeft 2

End With
End If
End Sub

 

[brundag5]

Okay, I've made some progress. Below almost does what I want. However, it imports the whole photo location string along with the name. I'm just looking for the imported picture name. Any suggestions?

Sub InsertPic()
Dim PicLocation As Variant

PicLocation = Application.GetOpenFilename()
If PicLocation = False Then
Range("B32") = ""
Else
ActiveSheet.Shapes.AddPicture(PicLocation, False, True, ActiveCell.Left, ActiveCell.Top, 246, 176).Select
With Selection
.ShapeRange.LockAspectRatio = msoFalse
.ShapeRange.Rotation = 0#
Selection.ShapeRange.IncrementTop 2
Selection.ShapeRange.IncrementLeft 2
'Selection.Copy
GetPName = PicLocation
ActiveCell.Offset(15, 0).Select
ActiveCell = GetPName
'ActiveSheet.Range("B21") = GetPName

End With
End If
End Sub