Code to insert file attachment as icon, to defined cell

[TashaWard]

Hi,
Pretty new to VBA, anything I've learnt so far has come from threads on this page - it's amazing!
Needing some help that I haven't seen an answer for so far
I need to add a button to a workbook which will allow the user to add a file (this will vary in extension and file name)
I also need this file to be added as an icon and attached to a particular cell for other users to open
So far I have:

Application.Dialogs(xlDialogInsertObject).Show
ActiveSheet.OLEObjects.Add(FileName:=ftopen, Link:=False, _
DisplayAsIcon:=True, IconFileName:=MyFileName, Link:=True, _
IconIndex:=0, IconLabel:=MyFileName).Show

I've tried adding in a line to dictate where the icon should be added - it hasn't worked
Also, this has only seemed to add the file path, not the file itself
Can someone help me write the code to do what I need it to?
TIA

 

[John_w]

Welcome to MrExcel forums.

The main difficulty with this is determining the correct icon to insert, depending on the file extension. For this, I have used the GetIcon function, along with the related registry functions from https://www.excelforum.com/excel-pr...or-attachments-added-via-vba.html#post1685523.

The following code allows the user to browse for a file and inserts it as an object with the appropriate icon positioned at the active cell (or you can specify a cell in the code).

Put this main code in one module (e.g. Module1):

Option Explicit

Public Sub Insert_File_With_Icon()

    Dim initialFolder As String
    Dim file As Variant
    Dim destCell As Range
    Dim fileExt As String
    
    initialFolder = ThisWorkbook.Path  'or a specific folder - "C:\Temp\Excel"
        
    Set destCell = ActiveCell 'or a specific cell - ActiveSheet.Range("G10")
    
    With Application.FileDialog(msoFileDialogOpen)
        .InitialFileName = initialFolder
        .AllowMultiSelect = False
        .Filters.Add "All files", "*.*", 1
        
        If .Show Then
            file = .SelectedItems(1)
            fileExt = Mid(file, InStrRev(file, "."))
            destCell.Worksheet.OLEObjects.Add Filename:=file, Link:=False, DisplayAsIcon:=True, _
                IconFileName:=GetIcon(fileExt), IconIndex:=0, IconLabel:=file
        End If
        
    End With
        
End Sub

Put the following code in another module (e.g. Module2):

'Code from https://www.excelforum.com/excel-programming-vba-macros/569810-icons-for-attachments-added-via-vba.html#post1685523

Option Explicit

[URL=https://www.mrexcel.com/forum/usertag.php?do=list&action=hash&hash=If]#If[/URL]  VBA7 Then
Declare PtrSafe Function RegCloseKey& Lib "advapi32.dll" (ByVal hKey&)
Declare PtrSafe Function RegOpenKeyExA& Lib "advapi32.dll" (ByVal hKey&, ByVal lpszSubKey$, dwOptions&, ByVal samDesired&, lpHKey&)
Declare PtrSafe Function RegQueryValueExA& Lib "advapi32.dll" (ByVal hKey&, ByVal lpszValueName$, ByVal lpdwRes&, lpdwType&, ByVal lpDataBuff$, nSize&)
Declare PtrSafe Function RegQueryValueEx& Lib "advapi32.dll" Alias "RegQueryValueExA" (ByVal hKey&, ByVal lpszValueName$, ByVal lpdwRes&, lpdwType&, lpDataBuff&, nSize&)
[URL=https://www.mrexcel.com/forum/usertag.php?do=list&action=hash&hash=Else]#Else[/URL] 
Declare Function RegCloseKey& Lib "advapi32.dll" (ByVal hKey&)
Declare Function RegOpenKeyExA& Lib "advapi32.dll" (ByVal hKey&, ByVal lpszSubKey$, dwOptions&, ByVal samDesired&, lpHKey&)
Declare Function RegQueryValueExA& Lib "advapi32.dll" (ByVal hKey&, ByVal lpszValueName$, ByVal lpdwRes&, lpdwType&, ByVal lpDataBuff$, nSize&)
Declare Function RegQueryValueEx& Lib "advapi32.dll" Alias "RegQueryValueExA" (ByVal hKey&, ByVal lpszValueName$, ByVal lpdwRes&, lpdwType&, lpDataBuff&, nSize&)
[URL=https://www.mrexcel.com/forum/usertag.php?do=list&action=hash&hash=End]#End[/URL]  If

Const HKEY_CLASSES_ROOT = &H80000000
Const HKEY_CURRENT_USER = &H80000001
Const HKEY_LOCAL_MACHINE = &H80000002
Const HKEY_USERS = &H80000003

Const ERROR_SUCCESS = 0&
Const REG_SZ = 1& ' Unicode nul terminated string
Const REG_DWORD = 4& ' 32-bit number

Const KEY_QUERY_VALUE = &H1&
Const KEY_SET_VALUE = &H2&
Const KEY_CREATE_SUB_KEY = &H4&
Const KEY_ENUMERATE_SUB_KEYS = &H8&
Const KEY_NOTIFY = &H10&
Const KEY_CREATE_LINK = &H20&
Const READ_CONTROL = &H20000
Const WRITE_DAC = &H40000
Const WRITE_OWNER = &H80000
Const SYNCHRONIZE = &H100000
Const STANDARD_RIGHTS_REQUIRED = &HF0000
Const STANDARD_RIGHTS_READ = READ_CONTROL
Const STANDARD_RIGHTS_WRITE = READ_CONTROL
Const STANDARD_RIGHTS_EXECUTE = READ_CONTROL
Const KEY_READ = STANDARD_RIGHTS_READ Or KEY_QUERY_VALUE Or KEY_ENUMERATE_SUB_KEYS Or KEY_NOTIFY
Const KEY_WRITE = STANDARD_RIGHTS_WRITE Or KEY_SET_VALUE Or KEY_CREATE_SUB_KEY
Const KEY_EXECUTE = KEY_READ


Function RegGetValue$(MainKey&, SubKey$, value$)
    ' MainKey must be one of the Publicly declared HKEY constants.
    Dim sKeyType& 'to return the key type. This function expects REG_SZ or REG_DWORD
    Dim ret& 'returned by registry functions, should be 0&
    Dim lpHKey& 'return handle to opened key
    Dim lpcbData& 'length of data in returned string
    Dim ReturnedString$ 'returned string value
    Dim ReturnedLong& 'returned long value
    
    If MainKey >= &H80000000 And MainKey <= &H80000006 Then
        ' Open key
        ret = RegOpenKeyExA(MainKey, SubKey, 0&, KEY_READ, lpHKey)
        If ret <> ERROR_SUCCESS Then
            RegGetValue = ""
            Exit Function 'No key open, so leave
        End If
    
        ' Set up buffer for data to be returned in.
        ' Adjust next value for larger buffers.
        lpcbData = 255
        ReturnedString = Space$(lpcbData)
        
        ' Read key
        ret& = RegQueryValueExA(lpHKey, value, ByVal 0&, sKeyType, ReturnedString, lpcbData)
        If ret <> ERROR_SUCCESS Then
            RegGetValue = "" 'Value probably doesn't exist
        Else
            If sKeyType = REG_DWORD Then
                ret = RegQueryValueEx(lpHKey, value, ByVal 0&, sKeyType, ReturnedLong, 4)
                If ret = ERROR_SUCCESS Then RegGetValue = CStr(ReturnedLong)
            Else
                RegGetValue = Left$(ReturnedString, lpcbData - 1)
            End If
        End If
        ' Always close opened keys.
        ret = RegCloseKey(lpHKey)
    End If
End Function

Function GetIcon(strExtension As String) As String
    GetIcon = RegGetValue$(HKEY_CLASSES_ROOT, RegGetValue$(HKEY_CLASSES_ROOT, strExtension, "") & "\DefaultIcon", "")
    If InStr(GetIcon, ",") > 0 Then GetIcon = Left(GetIcon, InStrRev(GetIcon, ",") - 1)  'InstrRev instead of Instr
End Function

PS - please use CODE tags - click the # icon in the message editor.

 

[TashaWard]

Hi,
Thank you for replying

I did as you suggested and copied each code into Modules, assigned the macro to a button, it will open the screen to attach a file but it errors saying 'Cannot insert Object' - on Debug it highlights this part of the code:

destCell.Worksheet.OLEObjects.Add FileName:=file, Link:=False, DisplayAsIcon:=True, _
                IconFileName:=GetIcon(fileExt), IconIndex:=0, IconLabel:=file

I'm at a loss as to how to fix?

 

[John_w]

The error might be because the Windows API code which reads the registry (Module2) doesn't work because your Excel is 64-bit Excel. I've only tested those functions on 32-bit Excel running on 64-bit Windows - the functions should also work on 32-bit Windows, but the declarations might need changing for 64-bit Excel.

Try this simpler alternative code to read the registry:

Public Function GetIcon2(strExtension As String) As String
    GetIcon2 = WShellReadReg("HKCR\" & WShellReadReg("HKCR\" & strExtension & "\") & "\DefaultIcon\")
    If InStr(GetIcon2, ",") > 0 Then GetIcon2 = Left(GetIcon2, InStrRev(GetIcon2, ",") - 1)  'InstrRev instead of Instr
End Function

Private Function WShellReadReg(regKey As String)
    WShellReadReg = CreateObject("WScript.Shell").RegRead(regKey)
End Function

Put the above code in Module1. Then change the errant destCell statement to:

            Dim iconFullName As String
            iconFullName = GetIcon2(fileExt)
            destCell.Worksheet.OLEObjects.Add Filename:=file, Link:=False, DisplayAsIcon:=True, _
                IconFileName:=iconFullName, IconIndex:=0, IconLabel:=file

 

[Jaafar Tribak]

The error might be because the Windows API code which reads the registry (Module2) doesn't work because your Excel is 64-bit Excel. I've only tested those functions on 32-bit Excel running on 64-bit Windows - the functions should also work on 32-bit Windows, but the declarations might need changing for 64-bit Excel.

The code works fine with 64bit excel and the API declarations are fine as is.

The error the OP is getting sounds like the worksheet is protected.

 

[John_w]

Hi Jaafar, thanks for testing the code and confirming the declarations on 64-bit Excel.

 

[Jaafar Tribak]

Hi Jaafar, thanks for testing the code and confirming the declarations on 64-bit Excel.

You are welcome.

I have been trying to use the SHGetFileInfo API with the SHGFI_ICONLOCATION and SHGFI_ICON flags as an alternative to using the registry approach for getting the icon file path and icon index but I can only get the icon index not the icon file path . Do you happen to know about some workning code that sucessfully uses this API for getting the path of the icon associated with a file ?

Thanks.

 

[John_w]

Hi Jaafar,

No sorry, I've not come across any code that uses SHGetFileInfo to get the icon file path.

 

[Jaafar Tribak]

Hi Jaafar,

No sorry, I've not come across any code that uses SHGetFileInfo to get the icon file path.

Thanks .. I'll keep on looking

 

[ZVI]

Reading registry is good for me.
But alternatively FindExecutable API function can be used to get icon FileName:

Option Explicit
 
#If  VBA7 Then
  Private Declare PtrSafe Function FindExecutable Lib "shell32.dll" Alias "FindExecutableA" (ByVal lpFile As String, ByVal lpDirectory As String, ByVal lpResult As String) As LongPtr
#Else 
  Private Declare Function FindExecutable Lib "shell32" Alias "FindExecutableA" (ByVal lpFile As String, ByVal lpDirectory As String, ByVal sResult As String) As Long
#End If
 
Function IconFName(PathName As String) As String
  Dim i As Long, s As String
  s = Space(260)
  i = InStrRev(PathName, "")
  If i > 0 Then
    If FindExecutable(Mid(PathName, i + 1), Left(PathName, i), s) > 32 Then
      IconFName = Left(s, InStr(s, Chr(0)) - 1)
    End If
  End If
End Function
 
Public Sub Insert_File_With_Icon()
 
  Dim initialFolder As String
  Dim file As String
  Dim destCell As Range
 
  initialFolder = ThisWorkbook.Path    'or a specific folder - "C:\Temp\Excel"
 
  Set destCell = ActiveCell   'or a specific cell - ActiveSheet.Range("G10")
 
  With Application.FileDialog(msoFileDialogOpen)
    .InitialFileName = initialFolder
    .AllowMultiSelect = False
    .Filters.Add "All files", "*.*", 1
 
    If .Show Then
      file = .SelectedItems(1)
      destCell.Worksheet.OLEObjects.Add FileName:=file, _
                                        Link:=False, _
                                        DisplayAsIcon:=True, _
                                        IconFileName:=IconFName(file), _
                                        IconIndex:=0, _
                                        IconLabel:=Mid(file, InStrRev(file, Chr(92)) + 1)
    End If
 
  End With
 
End Sub

By the way, some file types can't be embedded into Excel, for example - XLL. Manual embedding will help to understand why code does not work.