整理贴：插入导出表格图片及区域导出图片等

liulang0808

整理了几个插入导出图片的案例。供大家参考



一个档案的处理
http://club.excelhome.net/forum. ... 1451492&pid=9758310
怎么批量修改图片，并自动保存
http://club.excelhome.net/forum. ... 1459584&pid=9812666


以上方法为旧版方法，兼容性有时有问题
以下为新版

ActiveSheet.Shapes.addpicture f, msoFalse, msoCTrue, Rng.Left, Rng.Top, Rng.Width, Rng.Height

liulang0808

1. Sub addpicture()
   
2.     Set fso = CreateObject("Scripting.FileSystemObject")
   
3.     Application.ScreenUpdating = False
   
4.     For Each shp In ActiveSheet.Shapes
   
5.         If shp.Type = 13 Then shp.Delete
   
6.     Next shp
   
7.     For j = 3 To 13 Step 5
   
8.         For i = 2 To Cells(Rows.Count, 1).End(3).Row Step 11
   
9.             Cells(i, j).Select
   
10.             Set rng = Selection
    
11.             str1 = ThisWorkbook.Path & "\插入图片" & Cells(i, j - 1) & ".jpg"
    
12.             If fso.FileExists(str1) Then
    
13.                 ActiveSheet.Pictures.Insert(str1).Select
    
14.                 With Selection
    
15.                     .ShapeRange.LockAspectRatio = msoFalse
    
16.                     .Left = rng.Left + 1
    
17.                     .Top = rng.Top + 1
    
18.                     .Width = rng.Offset(0, 1).Left - rng.Left - 2
    
19.                     w = rng.Offset(1, 0).Top
    
20.                     y = rng.Top
    
21.                     .Height = w - y - 2
    
22.                 End With
    
23.             End If
    
24.         Next i
    
25.     Next j
    
26.     Application.ScreenUpdating = True
    
27. End Sub
    

复制代码

将指定文件夹的照片按照姓名插入到表格内

liulang0808

1. Sub 按钮1_Click()
   
2.     Application.ScreenUpdating = False
   
3.     pth = ThisWorkbook.Path & "\导出图片"
   
4.     For Each shp In ActiveSheet.Shapes
   
5.         If shp.Type = 13 Then
   
6.             n = n + 1
   
7.             shp.Copy
   
8.             With ActiveSheet.ChartObjects.Add(0, 0, shp.Width, shp.Height).Chart
   
9.                 .Paste
   
10.                 .Export pth & shp.TopLeftCell.Offset(0, -1) & ".jpg"
    
11.                 .Parent.Delete
    
12.             End With
    
13.         End If
    
14.     Next
    
15.     Application.ScreenUpdating = True
    
16. End Sub
    

复制代码

导出照片，将excel里的照片按照姓名保存成图片

如果仅仅是提取excel里的文件，可以直接将excel保存为html格式，即可获取图片，不过图片名称不是姓名，各位可以自己测试

liulang0808

1. Sub 按钮3_Click()
   
2.     For j = 1 To 13 Step 5
   
3.         For i = 1 To Cells(Rows.Count, 1).End(3).Row Step 11
   
4.             Cells(i, j).Resize(10, 3).CopyPicture 1, 2
   
5.             ActiveSheet.Pictures.Paste.Select
   
6.             With Selection
   
7.                 .Copy
   
8.                 With ActiveSheet.ChartObjects.Add(0, 0, Selection.Width, Selection.Height).Chart
   
9.                     .Paste
   
10.                     fnm = ThisWorkbook.Path & "\导出区域图片" & Cells(i + 1, j + 1) & ".jpg"
    
11.                     .Export fnm
    
12.                     .Parent.Delete
    
13.                 End With
    
14.                 .Delete
    
15.             End With
    
16.         Next i
    
17.     Next j
    
18. End Sub
    

复制代码

将准考证区域保存为图片，在数据有变动的时候，不要关闭刷屏，不然导出图片会有异常，各位可以自行尝试

02761752696

谢谢  老师分享   很实用

blackttea1

谢谢  老师分享   很实用

技术白

liulang0808 发表于 2018-10-22 15:52
将指定文件夹的照片按照姓名插入到表格内

这个代码复制到哪里去啊。。。。。。就是不会这个步骤

技术白

技术白 发表于 2018-11-6 15:45
这个代码复制到哪里去啊。。。。。。就是不会这个步骤

不会用 模块是什么。。。。。
大神能不能把我发的表格给做一下  (可怜，JPG)

xl6403

下载学习了一下。发现插入照片有用，运行导出照片，相应文件夹里没有照片，导出区域照片得到的是空白照片。我不知道是何原因。

liulang0808

xl6403 发表于 2018-11-15 20:39
下载学习了一下。发现插入照片有用，运行导出照片，相应文件夹里没有照片，导出区域照片得到的是空白照片。 ...

下载不见运行也出现这个问题吗