关于从Excel中批量导出图片，并按Excel中名称命名，求完善

f13145205920

前面有同事让帮从Excel中批量导出图片，
并按Excel中的名称加规格命名，
发现网上很多资料都只有批量导出的，
但同时按要求命名的确没有找到。
于是，只好用自己仅有的一点点VBA知识，弄出这个粗糙的代码。
这个代码没有自动建立存放导出图片的文件夹，需要事先手动建立一个文件夹。
且，如果Excel中的图片如果太不规范，也会有问题。不过只要偏移量不超过其图片的2/3也是没有问题的。
批量导出图片.rar (779.03 KB, 下载次数: 376)

2013-10-9 09:44 上传

点击文件名下载附件
希望有人可以补充完善。

1. 
   
2. Sub zldccmx()
   
3.     Dim obj As Object
   
4.     Dim name
   
5.     Dim arr
   
6.     arr = Array("", "/", "|", "< ", " > ", "~*")
   
7.     For i = LBound(arr) To UBound(arr)
   
8.       Cells.Replace What:=arr(i), Replacement:="-", LookAt:=xlPart, SearchOrder _
   
9.         :=xlByRows, MatchCase:=False, SearchFormat:=False, ReplaceFormat:=False
   
10.     Next i
    
11.     x = InputBox("请输入图片所在行的上一行行号:") + 0
    
12.     a = InputBox("请输入图片所在列的列列号:") + 0
    
13.     y = InputBox("请输入要图片命名信息存放的列号:") + 0
    
14.     Z = InputBox("请输入要图片命名信息存放的次列号:") + 0
    
15.    
    
16.     Application.ScreenUpdating = False
    
17.    
    
18.     With ActiveSheet
    
19.         name = .name
    
20.         h = .Rows(x + 1 & ":" & x + 1).RowHeight
    
21.         .Rows("1:" & .Range("B65536").End(3).Row).RowHeight = h
    
22.         
    
23.         b = 1
    
24.         For Each obj In ActiveSheet.Shapes
    
25.             k = obj.Top
    
26.             l = obj.Left
    
27.             m = obj.Height
    
28.             n = Application.Round((k + m) / h, 0)
    
29.         With .Shapes(b)
    
30.              .LockAspectRatio = msoFalse
    
31.              .Top = Cells(n, a).Top
    
32.              .Left = Cells(n, a).Left
    
33.              .Width = Cells(n, a).Width
    
34.              .Height = Cells(n, a).Height
    
35.         End With
    
36.         b = b + 1
    
37.         Next obj
    
38.    
    
39.     End With
    
40.     For Each obj In ActiveSheet.Shapes
    
41.             k = obj.Top
    
42.             l = obj.Height
    
43.             m = obj.Left
    
44.             n = obj.Width
    
45.         Select Case obj.Left
    
46.         Case m To m + n
    
47.             j = y
    
48.             Select Case obj.Top
    
49.             Case k To k + l
    
50.                 i = Application.RoundUp(k / (h - 1), 0)
    
51.             End Select
    
52.          End Select
    
53.         obj.Select
    
54.         obj.Copy
    
55.         If Z = 0 Then
    
56.             F_n = "D:\导出图片" & Cells(i, j).Value & ".jpg"
    
57.         Else
    
58.             F_n = "D:\导出图片" & Cells(i, j).Value & "(" & Cells(i, Z).Value & ")" & ".jpg"
    
59.         End If
    
60.         Charts.Add
    
61.         With ActiveChart
    
62.             .ChartType = xlColumnClustered
    
63.             .Location Where:=xlLocationAsObject, name:=name
    
64.         End With
    
65.         With Selection
    
66.             .Border.LineStyle = 0
    
67.             .Interior.ColorIndex = xlNone
    
68.         End With
    
69.         '贴图/导出图像/并删除刚刚建立的图表对象
    
70.         ActiveChart.Paste
    
71.         With ActiveSheet.Shapes(ActiveSheet.Shapes.Count)
    
72.             .Height = obj.Height * 2
    
73.             .Width = obj.Width * 2
    
74.         End With
    
75.             ActiveChart.Shapes.Range(Array("Picture 1")).Select
    
76.                 Selection.ShapeRange.Height = 213
    
77.                 Selection.ShapeRange.Width = 369
    
78.          Worksheets(name).ChartObjects(ChartObjects.Count).Chart.Export F_n, "JPG"
    
79.         ActiveSheet.ChartObjects.Delete
    
80.     Next obj
    
81.    
    
82.     Application.ScreenUpdating = True
    
83. 
    
84.     MsgBox ("图片导出完毕！")
    
85. 
    
86. End Sub
    

复制代码

f13145205920

难道不设回复可见就没人回复吗？

aarondzy

我是来学习的

我下载了，就是没太看懂，应该是不错的东西

吴雨生

学习