批量导出图片到Excel

roych

前段时间，有网友在群里问，如何把图片导出到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
    
22. 
    
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把数据写入，在涉及图片的字段，通过插入图片的形式进行处理。此外，这里预设了模板，这样便于处理一些必要的格式问题（例如，字体大小，居中等等）。这里同样也提出了一个问题：
当图片尺寸差异比较大的时候，可能并不是那么美观（请留意小图片的显示），除非预先调整到固定的一个尺寸。

PS：这里不打算处理2003版本，主要原因在于2003版本的shapes方法和2007的有所不同。如需查看2003格式下的处理方式，请留意以下链接：
批量插入图片并调整大小

admin

赞！

zpy2

赞一个
来自: 微社区

yanwei82123300

赞一个
来自: 微社区

wuwu200222

学习