问题描述
我在UA上发布了此内容，但我也想在这里尝试。在Access 2013中，我有一个将数据导出并格式化为Excel电子表格的过程，包括嵌入图像和文档。在电子表格的附件中循环浏览时，如果附件是图像，则图标只是图像本身的一个小版本。但是，如果附件是文档（Word，Excel等），则使用的图标就是应用程序的图标。
在所附的屏幕截图中，您可以看到导出非常适合图像。但是，对于Excel文件，它在图标下方添加了无法删除的空白，并且图标的大小和比例不正确。对于Word文档，大小是正确的，但是图标上没有显示任何内容。但是您可以双击“看似空的”单元格并打开附件。使用的图标来自Windows Installer图标文件。
下面是摘录的代码。它遍历一个表，该表包含将要导出的附件的路径和类型以及要使用的图标的路径（附件文件未直接存储在数据库中；已被引用）。
关于如何使图标正确显示的任何想法？
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
解决方法
我已经接近并可能达到这个目标。我一直在使用的图标文件（PNG格式）已复制并存储在图标目录中，以供Access使用。在Access中显示图标时，此方法效果很好，但在导出时效果不佳。
尝试了数十种参数和逻辑流程的组合后，我发现了一些“大部分”有效的方法。对于参数，我必须添加图标标签（我只使用文件名），并且必须使用Windows Installer图标文件。在这个复杂的过程中，大小调整仍然存在一些问题：首先在需要附件的位置调整单元格的大小，然后添加附件，再调整附件的大小，然后再次调整单元格的大小。该输出可用于任何图像或MS Office文档附件。
这种方法的问题是：
- 由于PNG文件将无法使用，而且我只能使用Windows Installer图标，因此无法获得非Windows程序的任何图标，例如PDF文件。
- Windows Installer图标位于计算机上的“ C：\ Windows \ Installer {90150000-0011-0000-1000-0000000FF1CE}”中，并且我确定此目录会因用户而异。到目前为止，我无法找到任何类型的环境变量或其他引用来查找图标文件，而又不知道确切的位置。
- 引用文件时，图标不再显示在窗体上的Access中。我认为这是因为图标实际上是可执行文件，而不是图像文件。