如何导出图片并自动命名

witkeylaw

WORD文档内容如下：

请问：

如何自动导出全部的图片，并按第一列文字命名。例如：第一行第一张图片为“猫1.jpg”，第二张图片为“猫-2.jpg”

如何导出图片并自动命名.rar (67.72 KB, 下载次数: 80)

2018-5-8 22:18 上传

点击文件名下载附件

duquancai

VBA循环导出。。。。。。

jiaxinl

1. <div class="blockcode"><blockquote>Private Sub Document_Open() '打开事件
   
2. '为宏指定快捷键(Alt+Q\B)
   
3.   KeyBindings.Add wdKeyCategoryMacro, "通过API访问粘贴板并另存图片数据", BuildKeyCode(wdKeyAlt, wdKeyQ)
   
4.   KeyBindings.Add wdKeyCategoryMacro, "复制到Excel后输出1", BuildKeyCode(wdKeyAlt, wdKeyB)
   
5.   MsgBox "创建的快捷键如下：" & Chr(13) & "方法1：通过API访问粘贴板并另存图片数据一>Alt+Q" & Chr(13) _
   
6.    & "方法2：复制到Excel后输出1一>Alt+B", , "快捷键"
   
7. End Sub
   
8. 
   
9. Sub 查找和清除快捷键()
   
10. MsgBox FindKey(BuildKeyCode(wdKeyF1)).Command '查找
    
11. FindKey(BuildKeyCode(wdKeyAlt, wdKeyQ)).Clear '清除
    
12. End Sub
    
13. 
    
14. Private Type GUID
    
15.    Data1 As Long
    
16.    Data2 As Integer
    
17.    Data3 As Integer
    
18.    Data4(0 To 7) As Byte
    
19. End Type
    
20. Private Type GdiplusStartupInput
    
21.    GdiplusVersion As Long
    
22.    DebugEventCallback As Long
    
23.    SuppressBackgroundThread As Long
    
24.    SuppresexternalCodecs As Long
    
25. End Type
    
26. Private Type EncoderParameter
    
27.    GUID As GUID
    
28.    NumberOfValues As Long
    
29.    type As Long
    
30.    Value As Long
    
31. End Type
    
32. Private Type EncoderParameters
    
33.    Count As Long
    
34.    Parameter As EncoderParameter
    
35. End Type
    
36. Private Declare Function GdiplusStartup Lib "GDIPlus" (token As Long, inputbuf As GdiplusStartupInput, ByVal outputbuf As Long) As Long
    
37. Private Declare Function GdiplusShutdown Lib "GDIPlus" (ByVal token As Long) As Long
    
38. Private Declare Function GdipCreateBitmapFromHBITMAP Lib "GDIPlus" (ByVal hbm As Long, ByValhpal As Long, Bitmap As Long) As Long
    
39. Private Declare Function GdipDisposeImage Lib "GDIPlus" (ByVal Image As Long) As Long
    
40. Private Declare Function GdipSaveImageToFile Lib "GDIPlus" (ByVal Image As Long, ByVal FileName As Long, clsidEncoder As GUID, encoderParams As Any) As Long
    
41. Private Declare Function CLSIDFromString Lib "ole32" (ByVal str As Long, id As GUID) As Long
    
42. Private Declare Function IsClipboardFormatAvailable Lib "user32" (ByVal wFormat As Integer) As Long
    
43. Private Declare Function GetClipboardData Lib "user32" (ByVal wFormat As Integer) As Long
    
44. Private Declare Function OpenClipboard Lib "user32" (ByVal hwnd As Long) As Long
    
45. Private Declare Function CloseClipboard Lib "user32" () As Long
    
46. Const CF_BITMAP = 2
    
47. 
    
48. '①通过Windows API访问粘贴板中的图片数据
    
49. '基本思路是在doc中找到需要保存的图片，复制到粘贴板后，调用API从粘贴板中抓出数据并另存为。
    
50. '此方法中Inlineshape和shape会表现不同的特性，具体讲，就是前者会以原始分辨率输出，后者以doc中所表现的分辨率输出。
    
51. '但相对于第一种方法，可加入图片筛选等行为。
    
52. '下面调用API的代码，实现从单个doc中导出全部图片。
    
53. 
    
54. Sub 通过API访问粘贴板并另存图片数据()
    
55.    Dim tSI As GdiplusStartupInput
    
56.    Dim lRes As Long
    
57.    Dim lGDIP As Long
    
58.    Dim lBitmap As Long
    
59.    Dim hBitmap As Long
    
60.    Dim FSO As Object, WordDoc As Object, ExcelApp As Object, sFolder$, sPath$, FileName$, inShp As InlineShape, N As Long
    
61.    Set FSO = CreateObject("Scripting.FileSystemObject") '创建文件系统对象
    
62.    sPath = ThisDocument.Path '代码所在的Word文件路径
    
63.    sFolder = sPath & "" & Split(ThisDocument.Name, ".")(0) '文件夹路径
    
64.    If FSO.FolderExists(sFolder) Then FSO.DeleteFolder sFolder '当文件夹存在时,则删除文件夹
    
65.    FSO.CreateFolder sFolder '创建文件夹
    
66. '   MkDir sFolder  '创建文件夹
    
67.    Set WordDoc = Documents.Open(sPath & "" & "如何导出图片并自动命名.docx", Visible:=False) '打开指定路径下的Word文件,并不显示
    
68.    Set ExcelApp = CreateObject("Excel.Application") '创建ExcelApp程序
    
69.    
    
70.    '获取所有图片要重命名的名称
    
71.    Dim arr(), hhhh&, kkkk&, rrrr&, jjjj&, jj&, iiii&
    
72.    hhhh = WordDoc.InlineShapes.Count  'Word文件中所有的Inlineshape图片
    
73.    ReDim Preserve arr(1 To hhhh)  '重定义数组
    
74.    For kkkk = 1 To WordDoc.Tables.Count '在Word文件中所有的表格中循环
    
75.         For rrrr = 1 To WordDoc.Tables(kkkk).Range.Rows.Count '在每个表格的所有行中循环
    
76.             jjjj = WordDoc.Tables(kkkk).Cell(rrrr, 2).Range.InlineShapes.Count '获取每个表格中第2栏中单元格中的图片数量
    
77.             If jjjj > 1 Then '当图片数量> 1 时
    
78.                 For jj = 1 To jjjj
    
79.                     iiii = iiii + 1
    
80.                     A = WordDoc.Tables(kkkk).Cell(rrrr, 1).Range.Text & jj '图片要重命名的名称+序号
    
81.                     arr(iiii) = ExcelApp.WorksheetFunction.Clean(A) '目的提取不带不可见的字符
    
82.                 Next
    
83.             ElseIf jjjj = 1 Then '当图片数量=1 时
    
84.                   iiii = iiii + 1
    
85.                   A = WordDoc.Tables(kkkk).Cell(rrrr, 1).Range.Text
    
86.                   arr(iiii) = ExcelApp.WorksheetFunction.Clean(A)
    
87.             Else
    
88.             End If
    
89.         Next
    
90.    Next
    
91.    
    
92.    For Each inShp In WordDoc.InlineShapes '在打开的Word文件中所有的【嵌入型】图片中遍历
    
93.    '如果是shape，此处改为 ActiveDocument.Shapes，当然inShp的声明也要改
    
94.        N = N + 1
    
95. '       A = inShp.Range.Cells(1).Range.Text  '图片所在的表格中的单元格的文本
    
96. '       AA = Trim(Mid(A, 2, Len(A) - 3)) '目的提取不带不可见的字符
    
97.        AA = arr(N)
    
98.        FileName = sFolder & "" & AA & ".jpg"
    
99. '       FileName = sFolder & "" & Format(N, "000.jpg") '代码Word文件所在的路径+流水号+(.gif、.jpg、.jpeg、.png、.bmp、.tif等)
    
100.        inShp.Range.CopyAsPicture '复制为图片
     
101.        '如果为shape，CopyAsPicture方法无效，可能因为shape本身就是pic，
     
102.        '所以对于shape直接select，再copy，即以图片形式装入了粘贴板，
     
103.        '后续操作相同。
     
104.        OpenClipboard 0&  '打开粘贴板
     
105.        hBitmap = GetClipboardData(CF_BITMAP) '获取粘贴板的数据
     
106.        CloseClipboard '关闭粘贴板
     
107.        tSI.GdiplusVersion = 1
     
108.        lRes = GdiplusStartup(lGDIP, tSI, 0)
     
109.        If lRes = 0 Then
     
110.             lRes = GdipCreateBitmapFromHBITMAP(hBitmap, 0, lBitmap)
     
111.            If lRes = 0 Then
     
112.                Dim tJpgEncoder As GUID
     
113.                Dim tParams As EncoderParameters
     
114.                CLSIDFromString StrPtr("{557CF401-1A04-11D3-9A73-0000F81EF32E}"), tJpgEncoder
     
115.                tParams.Count = 1
     
116.                With tParams.Parameter
     
117.                    CLSIDFromString StrPtr("{1D5BE4B5-FA4A-452D-9CDD-5DB35105E7EB}"), .GUID
     
118.                    .NumberOfValues = 1
     
119.                    .type = 4
     
120.                    .Value = VarPtr(100)
     
121.                End With
     
122.                lRes = GdipSaveImageToFile(lBitmap, StrPtr(FileName), tJpgEncoder, tParams)
     
123.                GdipDisposeImage lBitmap
     
124.            End If
     
125.            GdiplusShutdown lGDIP
     
126.        End If
     
127.    Next inShp
     
128.    WordDoc.Close (0) '关闭活动Word文件,并不保存
     
129.    Set ExcelApp = Nothing
     
130.    MsgBox "图片已另存为成功！" & Chr(13) & "一共 " & N & " 个", 64, "提示"
     
131. End Sub
     

复制代码

jiaxinl

1. '②通过复制到Excel后，用Excel的ChartObjects对象的相关方法实现输出
   
2. '在Excel中，ChartObjects是由指定的图表工作表、对话框工作表或工作表上的所有 ChartObject 对象组成的集合。每个 ChartObject 对象都代表一个嵌入图表。
   
3. 'ChartObject 对象充当 Chart 对象的容器。ChartObject 对象的属性和方法控制工作表上嵌入图表的外观和大小。
   
4. '该方法的亮点是：当利用PasteSpecial将数据从doc传递到xls中时，无论原来对象的类型，都可以靠PasteSpecial实现其分辨率的控制，示例中的"图片(增强型图元文件)"即为原始分辨率复制。
   
5. 
   
6. '综上所述，如果只是导出图片，而对其分辨率没有明确要求，那么多种方法均能很好的实现目标。否则，就必须考虑其在doc中所属对象类型了，或者选择特定方法。
   
7. '从本质上看，两种对象类型在doc中都存储了完整的数据，那么区别只是在于特定的复制方法是否能暴露出其全部的数据。
   
8. 
   
9. '以下代码是直接在WordVBA中实现的，其中对Excel中的对象引用已做处理。
   
10. 
    
11. Sub 复制到Excel后输出1()
    
12. Dim FSO As Object, ExcelApp As Object, NewExcel As Object, Excel_Shape As Object, sPath$, sFolder$, i&
    
13. Set FSO = CreateObject("Scripting.FileSystemObject") '创建文件系统对象
    
14. sPath = ThisDocument.Path '代码所在Word的路径
    
15. sFolder = sPath & "" & Split(ThisDocument.Name, ".")(0) '文件夹路径
    
16. If FSO.FolderExists(sFolder) Then FSO.DeleteFolder sFolder '当文件夹存在时，则删除文件夹
    
17. FSO.CreateFolder sFolder '创建文件夹
    
18. 'MkDir sFolder '创建文件夹
    
19. Set WordDoc = Documents.Open(sPath & "" & "如何导出图片并自动命名.docx", Visible:=False) '打开指定路径下的Word文件,并不显示
    
20. Set ExcelApp = CreateObject("Excel.Application") '创建ExcelApp程序
    
21. Set NewExcel = ExcelApp.Workbooks.Add '新建Excel工作簿
    
22. 'ExcelApp.Visible = True '显示ExcelApp程序
    
23. Application.DisplayAlerts = False '从doc到xls的复制过程可能会报错，故加此句
    
24.    
    
25.    '获取所有图片要重命名的名称
    
26.    Dim arr(), hhhh&, kkkk&, rrrr&, jjjj&, jj&, iiii&
    
27.    hhhh = WordDoc.InlineShapes.Count  'Word文件中所有的Inlineshape图片
    
28.    ReDim Preserve arr(1 To hhhh)  '重定义数组
    
29.    For kkkk = 1 To WordDoc.Tables.Count '在Word文件中所有的表格中循环
    
30.         For rrrr = 1 To WordDoc.Tables(kkkk).Range.Rows.Count '在每个表格的所有行中循环
    
31.             jjjj = WordDoc.Tables(kkkk).Cell(rrrr, 2).Range.InlineShapes.Count '获取每个表格中第2栏中单元格中的图片数量
    
32.             If jjjj > 1 Then '当图片数量> 1 时
    
33.                 For jj = 1 To jjjj
    
34.                     iiii = iiii + 1
    
35.                     A = WordDoc.Tables(kkkk).Cell(rrrr, 1).Range.Text & jj '图片要重命名的名称+序号
    
36.                     arr(iiii) = ExcelApp.WorksheetFunction.Clean(A) '目的提取不带不可见的字符
    
37.                 Next
    
38.             ElseIf jjjj = 1 Then '当图片数量=1 时
    
39.                   iiii = iiii + 1
    
40.                   A = WordDoc.Tables(kkkk).Cell(rrrr, 1).Range.Text
    
41.                   arr(iiii) = ExcelApp.WorksheetFunction.Clean(A)
    
42.             Else
    
43.             End If
    
44.         Next
    
45.    Next
    
46. 
    
47. For i = 1 To WordDoc.InlineShapes.Count '在打开的Word文件中所有【嵌入型】图片数量中循
    
48. '如果是shape，此处改为 ActiveDocument.Shapes
    
49.    WordDoc.InlineShapes(i).Select  '选择Word文件中【嵌入型】图片
    
50.    Selection.Copy '复制选中的图片
    
51. '   A = Selection.Range.Cells(1).Range.Text  '图片所在的表格中的单元格的文本
    
52. '   AA = Trim(Mid(A, 2, Len(A) - 3)) '目的提取不带不可的字符
    
53.     N = N + 1
    
54.    AA = arr(N)
    
55.    NewExcel.WorkSheets(1).Cells(1, 1).Activate
    
56.    NewExcel.WorkSheets(1).PasteSpecial Format:="图片(增强型图元文件)", Link:=False, DisplayAsIcon:=False
    
57.    Set Excel_Shape = NewExcel.WorkSheets(1).Shapes(1) '因为当单个doc中存在图片量过多，均复制到xls中造成数据量过大，
    
58.    '这里采用了复制一个进入Excel，再另存图片后，立即删除Excel中的图片数据，所以遍历时，index永远是1
    
59.    NewExcel.WorkSheets(1).Shapes(1).Copy '复制从Word中复制到Excel中的图片
    
60.    With NewExcel.WorkSheets(1).ChartObjects.Add(0, 0, Excel_Shape.Width, Excel_Shape.Height).Chart
    
61.        .Paste '粘贴
    
62.        .Export sFolder & "" & AA & ".jpg" '汇出的路径+图片文件名
    
63. '       .Export sfolder & "" & i & ".jpg"
    
64.        .Parent.Delete '删除第二次复制产生的图片
    
65.    End With
    
66.    NewExcel.WorkSheets(1).Shapes(1).Delete '删除第一次复制产生的图片
    
67. Next i
    
68. WordDoc.Close 0 '关闭活动Word文件,并不保存
    
69. NewExcel.Close 0 '关闭活动Excel文件,并不保存
    
70. Set ExcelApp = Nothing
    
71. MsgBox "图片已另存为成功！" & Chr(13) & "一共 " & i - 1 & " 个", 64, "提示"
    
72. End Sub

复制代码

witkeylaw

竟然写了两种方法，竟然还弄了gif。
我无地自容。
一句话，非常感谢。

liumongshi

这个太经典了，感谢分享

40525299999

感谢分享，非常感谢

landyway

jiaxinl 发表于 2018-5-10 14:20

大神，我想直接在excel中实现这个效果，怎么改这个代码啊？求回复。。。。

bluesky_0

jiaxinl 发表于 2018-5-10 14:18

大神,这个在64位报错,我研究,改了二周,没有搞定,
可以给个64位的版本吗?

bluesky_0

jiaxinl 发表于 2018-5-10 14:20

跪求大神,
在32位OK,在64位报错,
我研究,改了二周,没有搞定,
可以给个64位的版本吗?