Copy the object path to cell in vba

[Vincent88]

I use the code to get the object. How to add code to get the full path of the object and paste it to the active cell.

Sub SelectOLE()
Dim objFileDialog As Office.FileDialog

    Set objFileDialog = Application.FileDialog(MsoFileDialogType.msoFileDialogFilePicker)

        objFileDialog.AllowMultiSelect = False
        objFileDialog.ButtonName = "Select File"
        objFileDialog.Title = "Select File"
        objFileDialog.Show

        If (objFileDialog.SelectedItems.Count > 0) Then
                    
        Set f = ActiveSheet.OLEObjects.Add _
            (Filename:=objFileDialog.SelectedItems(1), _
              Link:=False, _
              DisplayAsIcon:=True, _
              IconLabel:=objFileDialog.SelectedItems(1), _
              Top:=ActiveCell.Top, _
              Left:=ActiveCell.Left _
           )
        f.Select
        
        With f
       .ShapeRange.LockAspectRatio = msoFalse
       .Width = ActiveCell.Width
       .Height = ActiveCell.Height
        End With
                  
        End If
      
End Sub

 

[HaHoBe]

Hi Vincent88,

code writes path and filename with extension to the next cell to the shape:

Sub SelectOLE_120521()
'https://www.mrexcel.com/board/threads/copy-the-object-path-to-cell-in-vba.1170676/

  Dim objFileDialog As Object
  Dim f As Object

  Set objFileDialog = Application.FileDialog(MsoFileDialogType.msoFileDialogFilePicker)

  With objFileDialog
    .AllowMultiSelect = False
    .ButtonName = "Select File"
    .Title = "Select File"
    .Show
  End With
 
  If objFileDialog.SelectedItems.Count > 0 Then
             
    Set f = ActiveSheet.OLEObjects.Add _
        (filename:=objFileDialog.SelectedItems(1), _
          Link:=False, _
          DisplayAsIcon:=True, _
          IconLabel:=objFileDialog.SelectedItems(1), _
          Top:=ActiveCell.Top, _
          Left:=ActiveCell.Left)
   
    With f
      .ShapeRange.LockAspectRatio = msoFalse
      .Width = ActiveCell.Width
      .Height = ActiveCell.Height
    End With
    ActiveCell.Offset(0, 1).Value = objFileDialog.SelectedItems(1)
  
  End If
 
  Set f = Nothing
  Set objFileDialog = Nothing
     
End Sub

Ciao,
Holger