Office中国论坛/Access中国论坛

标题: 批量导出图片到Excel [打印本页]
作者: roych    时间: 2019-5-5 15:03
标题: 批量导出图片到Excel
前段时间，有网友在群里问，如何把图片导出到Excel上。当时分享了一个之前写的示例批量插入图片并调整大小，建议他把里面的语句修改下，也不知道后来他有没有完成。


为什么非要导出到Excel上呢？我很奇怪为什么会有这样的需求。是因为Access的窗体放图片不好吗？还是因为用报表格式导出PDF不好吗？还是因为很多人习惯用Excel？……对于想不明白的事情，我向来不会花太多时间去想，照做就是了。于是就把之前的例子找过来，随手改改，做成以下例子。

按惯例先上代码：
  1. Sub exportImg()
  2.     Dim rst As New ADODB.Recordset
  3.     Dim exl As New Excel.Application
  4.     Dim wb As Workbook
  5.     Dim ws As Worksheet
  6.     Dim i As Long
  7.     Dim j  As Long
  8.     Dim img As ImageSize
  9.    
  10.     rst.Open "tblPic", CurrentProject.Connection, adOpenKeyset, adLockOptimistic
  11.     Set wb = exl.Workbooks.Add(CurrentProject.Path & "\test.xltx")
  12.     Set ws = wb.ActiveSheet
  13.    
  14.     '初始化
  15.     i = 0
  16.     j = 0
  17.    
  18.     '写入表头
  19.     For i = 0 To rst.Fields.Count - 1
  20.         ws.Range("A1").Offset(0, i) = rst.Fields(i).Name
  21.     Next

  23.    
  24.     '写入数据
  25.     Do Until rst.EOF
  26.         ws.Range("2:2").Offset(j, 0).Insert xlUp, xlFormatFromRightOrBelow
  27.         For i = 0 To rst.Fields.Count - 1
  28.         '如果不是最后一个（即图片列）
  29.             If i < rst.Fields.Count - 1 Then
  30.             '居中对齐
  31.                 With ws.Range("A2").Offset(j, i)
  32.                     .Value = rst(i)
  33.                     .HorizontalAlignment = xlCenter
  34.                     .VerticalAlignment = xlCenter
  35.                 End With
  36.             Else
  37.                 img = GetImageSize(rst(i))
  38.                 ws.Shapes.AddPicture rst(i), msoFalse, msoTrue, ws.Range("A2").Offset(j, i).Left + 2, ws.Range("A2").Offset(j, i).Top + 2, img.Width, img.Height
  39.                 ws.Range("A2").Offset(j, i).RowHeight = img.Height + 2
  40.             End If
  41.         Next
  42.         j = j + 1
  43.         rst.MoveNext
  44.     Loop
  45.    
  46.     rst.Close
  47.     '删除已有文件
  48.     If Len(Dir(CurrentProject.Path & "\test0.xlsx")) > 0 Then Kill CurrentProject.Path & "\test0.xlsx"
  49.    
  50.     '删除最后一列后保存
  51.     ws.Range("2:2").Offset(j, 0).Delete
  52.     wb.SaveAs CurrentProject.Path & "\test0.xlsx"
  53.     wb.Close
  54.     exl.Quit
  55. End Sub
复制代码
主体思想是通过ADO把数据写入，在涉及图片的字段，通过插入图片的形式进行处理。此外，这里预设了模板，这样便于处理一些必要的格式问题（例如，字体大小，居中等等）。这里同样也提出了一个问题：
当图片尺寸差异比较大的时候，可能并不是那么美观（请留意小图片的显示），除非预先调整到固定的一个尺寸。
[attach]63352[/attach]
PS：这里不打算处理2003版本，主要原因在于2003版本的shapes方法和2007的有所不同。如需查看2003格式下的处理方式，请留意以下链接：
批量插入图片并调整大小
作者: admin    时间: 2019-5-5 16:53
赞！
作者: zpy2    时间: 2019-5-5 17:08
赞一个
作者: yanwei82123300    时间: 2019-5-7 07:14

赞一个
来自: 微社区
作者: wuwu200222    时间: 2020-11-19 15:33
学习



欢迎光临 Office中国论坛/Access中国论坛 (http://www.office-cn.net/) Powered by Discuz! X3.3