访问 VBA - 导出到带有嵌入文件的 Excel

Question

I posted this on UA but thought I'd try here as well. In Access 2013, I have a process to export and format data to an Excel spreadsheet, including embedding images and documents. While looping through attachments for the spreadsheet, if the attachment is an image, then the icon is just a small version of the image itself. But if the attachment is a document (Word, Excel, etc.) then the icon used is the icon of the application.

In the attached screenshot, you can see the export works perfectly for images. However for Excel files, it adds white space below the icon that can't be removed, and the size and proportions of the icon are wrong. For Word documents, the size is correct but there is nothing shown for the icon; yet you can double click the 'seemingly empty' cell and open the attachment. The icons used are from the Windows Installer icon file.

Below is the code for the extract. It loops through a table that contains the path and type of the attachment that will be exported and the path of the icon to be used (the attachment files are not directly stored in the DB; they are referenced).

Any ideas on how to get the icons to show up properly?

Private Sub cmdExport_Click()
On Error GoTo ErrProc
  
  Dim xlApp As Excel.Application    'Create an instance of Excel application
  Dim xlBook As Excel.Workbook      'Create a new Excel workbook
  Dim xlAtch As Excel.Worksheet      'Create a tab with Attachment details
  Dim strSQL As String              'SQL for the Attachment recordset
  Dim rsAtch As DAO.Recordset        'Attachment recordset
  Dim x As Integer                  'Counter for Attachment line numbers
  Dim Img As Excel.Shape            'Process the Image Attachments
  Dim Atch As OLEObject             'Process the non-Image Attachments
    
  'Create an instance of Excel.  Keep it hidden until it is finished
  Set xlApp = Excel.Application
  xlApp.Visible = False
  Set xlBook = xlApp.Workbooks.Add
  xlBook.Worksheets.Add
  
  'Build the Image Reference SQL
  strSQL = "SELECT * FROM tblAttachments"
  Set rsAtch = CurrentDb.OpenRecordset(strSQL, dbOpenSnapshot)
  
  'Add a new worksheet
  Set xlAtch = xlBook.Worksheets(1)
  
  With xlAtch
    'Build Column Headings
    .Range("A1").Value = "Name"
    .Range("B1").Value = "Attachment"
    .Range("C1").Value = "Attachment Path"
      
    .Range("A2:A5").RowHeight = 65
    .Columns("B").ColumnWidth = 17
    
    'Populate the detail data
    x = 2   'Set initial row counter
    Do While Not rsAtch.EOF
      .Range("A" & x).Value = Nz(rsAtch!AttachmentName, "")
      .Range("C" & x).Value = Nz(rsAtch!attachmentpath, "")

      If rsAtch!AttachmentType = "Image" Then
                  
        'Add the image; the initial size is set at 2000 and then resized below.
        Set Img = .Shapes.AddPicture(FileName:=rsAtch!attachmentpath, _
                  linktofile:=msoFalse, savewithdocument:=msoCTrue, _
                  Left:=.Range("B" & x).Left, Width:=2000, _
                  Top:=.Range("B" & x).Top, Height:=2000)
        
        'Resize the image
        Img.Width = .Range("B" & x).Width           'Width = cell width
        Img.Height = .Range("B" & x).Height         'Height = cell height
        Img.Placement = 1                           'Move and size with the cell
    
      Else 'non-image attachment
        Set Atch = .OLEObjects.Add(FileName:=rsAtch!attachmentpath, _
          iconindex:=0, _
          Link:=False, DisplayAsIcon:=True, IconFileName:=rsAtch!iconpath, _
          Left:=ActiveSheet.Range("B" & x).Left, Width:=.Range("B" & x).Width, _
          Top:=ActiveSheet.Range("B" & x).Top, Height:=.Range("B" & x).Height)
          
        Atch.Placement = 1                           'Move and size with the cell
      End If
      
      x = x + 1
      rsAtch.MoveNext
    Loop
    
    'Format the detail section as an Excel table
    .ListObjects.Add(xlSrcRange, Range("$A$1:$C$" & x - 1), , xlYes).Name = "Attachments"
    .Range("Attachments[#All]").Select
    .ListObjects("Attachments").TableStyle = "TableStyleLight8"
    
    .Range("A2").Select     'Put the focus on the first data cell
    .Columns("A:C").AutoFit 'Autofit the column widths
    
  End With

ExitProc:
  On Error Resume Next
  xlApp.Visible = True    'Set Excel to visible
  'Cleanup
  rsAtch.Close
  Set rsAtch = Nothing
  Set Img = Nothing
  Set Atch = Nothing
  
  Exit Sub
  
ErrProc:
  MsgBox Err.Number & "; " & Err.Description, vbOKOnly, "Error"
  Resume ExitProc

End Sub

Answer 1

I got closer and possibly as far as I'll get with this one. The icon files I had been using (PNG format) were copied and stored in an icon directory for Access to use. This worked great when displaying the icons within Access but did not work well with the export.

After trying dozens of combinations of parameters and logic flow, I found something that 'mostly' works. For the parameters, I had to add an icon label (I just use the file name) and had to use the Windows Installer icon files. There are still some issues with the sizing that I got around with this convoluted process: first resize the cell where I want the attachment, then add the attachment, then resize the attachment, then resize the cell again. The output is workable for any image or MS Office document attachments.

The problems with this approach are:

1. Since the PNG files will not work and I am limited to using the Windows Installer icons, I can't get any icons for non-Windows programs, such as a PDF file.
2. The Windows Installer icons are in "C:\\Windows\\Installer{90150000-0011-0000-1000-0000000FF1CE}" on my computer and I am sure that this directory will vary by user. So far I have not been able to find any type of environment variable or other reference to find the icon files without knowing exactly where to look.
3. The icons are no longer showing up within Access on forms when referencing the files. I assume this is because the icons are actually executables and not image files.