Attaching/ Embedding Files Using VBA

[jamesmev]

I am working on having a sheet allow you to select PDF files from your computer and attach those files to the sheet and then send off the sheet. It does attach however when sending the file out to someone else the file is lost because that file remains on that local computer. Below is the code I am using. I am attaching using a button which activates the VBA and allows the user to attach the file(s)

ideally what i would like is something like this

Attach file (button)

user selects file...

generic icon showing it attached to file

Another button attach additional files.
And so on...
-------------------------------------------------------------------------------------------------------------
Sub insert()


Dim ftopen As Variant


'get file name from open file dialog box.
ftopen = Application.GetOpenFilename(FileFilter:="Adobe Acrobat(*.PDF),*.xls", Title:="DDTS Adobe Acrobat")


'if no file chosen then close sub
If ftopen = False Then
MsgBox ("No file chosen")
Exit Sub
End If
On Error Resume Next
'insert file into sheet.
ActiveSheet.OLEObjects.Add(Filename:=ftopen, Link:=False, _
DisplayAsIcon:=True, IconFileName:= _
"C:\WINDOWS\Installer\{AC76BA86-7AD7-1033-7B44-AA1000000001}\PDFFile_8.ico", _
IconIndex:=0, IconLabel:=0).Activate


End Sub

 

[jamesmev]

Sub Insert()


Dim iconToUse As String
Dim fullFileName As String
Dim FNExtension As String
fullFileName = Application.GetOpenFilename("*.*, All Files", , , , False)

If fullFileName = "False" Then
Exit Sub ' user cancelled
End If


'choose an icon based on filename extension
'get all after last "." in filename
FNExtension = Right(fullFileName, Len(fullFileName) - _
InStrRev(fullFileName, "."))


'select icon based on filename extension
Select Case UCase(FNExtension)
Case Is = "TXT"
iconToUse = "C:\Windows\system32\packager.dll"
Case Is = "XLS", "XLSM", "XLSX"
iconToUse = "C:\Windows\Installer\{91140000-0011-0000-0000-0000000FF1CE}\xlicons.exe"
Case Is = "PDF"
iconToUse = "C:\Windows\Installer\{AC76BA86-1033-F400-7761-000000000004}\_PDFFile.ico"
Case Else
'this is a generic icon
iconToUse = "C:\Windows\system32\packager.dll"


End Select
Sheets("SheetNAMEl").Select
Range("CELL RANGE").Select

ActiveSheet.OLEObjects.Add(FileName:=fullFileName, Link:= _
False, DisplayAsIcon:=True, IconFileName:= _
"C:ICON PATH", _
IconIndex:=0, IconLabel:="Attachment 1").Select
Sheets("SHEET NAME").Select
Range("CELL RANGE TO PLACE ICON").Select
ActiveCell.FormulaR1C1 = "File Added"
Range("CELL TO GO TO AFTER ACTIONS").Select
End Sub

 

[Kenneth Hobson]

Please click the # button to insert code tags and paste code between them.

Works fine for me.

I added an API routine for the unmatched case. You might want to use it rather than forcing cases.

Option Explicit

Declare Function FindExecutable Lib "shell32.dll" Alias "FindExecutableA" _
   (ByVal lpFile As String, ByVal lpDirectory As String, ByVal lpResult As String) As Long
 
'https://www.mrexcel.com/forum/excel-questions/1020429-attaching-embedding-files-using-vba.html
Sub Insert()
  Dim iconToUse As String, fullFileName As String
  Dim FNExtension As String
  Dim o As OLEObject
  
  fullFileName = Application.GetOpenFilename("*.*, All Files", , , , False)
  
  If fullFileName = "False" Then Exit Sub ' user cancelled
  
  'choose an icon based on filename extension
  'get all after last "." in filename
  FNExtension = Right(fullFileName, Len(fullFileName) - _
  InStrRev(fullFileName, "."))
  
  'select icon based on filename extension
  Select Case UCase(FNExtension)
    Case Is = "TXT"
      iconToUse = "C:\Windows\system32\packager.dll"
    Case Is = "XLS", "XLSM", "XLSX"
      iconToUse = "C:\Windows\Installer\{91140000-0011-0000-0000-0000000FF1CE}\xlicons.exe"
    Case Is = "PDF"
      'Adobe Reader?
      iconToUse = "C:\Windows\Installer\{AC76BA86-1033-F400-7761-000000000004}\_PDFFile.ico"
      'Acrobat XI
      iconToUse = "C:\Windows\Installer\{AC76BA86-1033-FFFF-7760-000000000006}\_PDFFile.ico"
    Case Else
      'this is a generic icon
      'iconToUse = "C:\Windows\system32\packager.dll"
      iconToUse = ExePath(fullFileName)
  End Select
  
  Set o = ActiveSheet.OLEObjects.Add(Filename:=fullFileName, _
    Link:=False, DisplayAsIcon:=True, IconFileName:=iconToUse, _
    IconIndex:=0, IconLabel:="Attachment 1")
  o.Top = [C1].Top
  o.Left = [C1].Left
  
  [A1].FormulaR1C1 = "File Added"
  [A1].Select
End Sub


Function ExePath(lpFile As String) As String
   Dim lpDirectory As String, sExePath As String, rc As Long
   lpDirectory = "\"
   sExePath = Space(255)
   rc = FindExecutable(lpFile, lpDirectory, sExePath)
   sExePath = Left$(sExePath, InStr(sExePath, Chr$(0)) - 1)
  ExePath = sExePath
End Function

 

[jamesmev]

Kenneth, I should have noted that this was a solve for my posed question. I was able to achieve what I was intending. Thank you for reviewing the work there.