ExcelHome技术论坛

 找回密码
 免费注册

QQ登录

只需一步,快速开始

快捷登录

搜索
EH技术汇-专业的职场技能充电站 妙哉!函数段子手趣味讲函数 Excel服务器-会Excel,做管理系统 Excel Home精品图文教程库
HR薪酬管理数字化实战 Excel 2021函数公式学习大典 Excel数据透视表实战秘技 打造核心竞争力的职场宝典
让更多数据处理,一键完成 数据工作者的案头书 免费直播课集锦 ExcelHome出品 - VBA代码宝免费下载
用ChatGPT与VBA一键搞定Excel WPS表格从入门到精通 Excel VBA经典代码实践指南
查看: 5486|回复: 27

[求助] 如何导出图片并自动命名

[复制链接]

TA的精华主题

TA的得分主题

发表于 2018-5-8 22:18 | 显示全部楼层 |阅读模式
本帖最后由 witkeylaw 于 2018-5-8 22:20 编辑

WORD文档内容如下:

图片.jpg

请问:
如何自动导出全部的图片,并按第一列文字命名。例如:第一行第一张图片为“猫1.jpg”,第二张图片为“猫-2.jpg”
如何导出图片并自动命名.rar (67.72 KB, 下载次数: 80)

TA的精华主题

TA的得分主题

发表于 2018-5-8 23:08 来自手机 | 显示全部楼层
VBA循环导出。。。。。。

TA的精华主题

TA的得分主题

发表于 2018-5-10 14:18 | 显示全部楼层
  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. Sub 查找和清除快捷键()
  9. MsgBox FindKey(BuildKeyCode(wdKeyF1)).Command '查找
  10. FindKey(BuildKeyCode(wdKeyAlt, wdKeyQ)).Clear '清除
  11. End Sub

  12. Private Type GUID
  13.    Data1 As Long
  14.    Data2 As Integer
  15.    Data3 As Integer
  16.    Data4(0 To 7) As Byte
  17. End Type
  18. Private Type GdiplusStartupInput
  19.    GdiplusVersion As Long
  20.    DebugEventCallback As Long
  21.    SuppressBackgroundThread As Long
  22.    SuppresexternalCodecs As Long
  23. End Type
  24. Private Type EncoderParameter
  25.    GUID As GUID
  26.    NumberOfValues As Long
  27.    type As Long
  28.    Value As Long
  29. End Type
  30. Private Type EncoderParameters
  31.    Count As Long
  32.    Parameter As EncoderParameter
  33. End Type
  34. Private Declare Function GdiplusStartup Lib "GDIPlus" (token As Long, inputbuf As GdiplusStartupInput, ByVal outputbuf As Long) As Long
  35. Private Declare Function GdiplusShutdown Lib "GDIPlus" (ByVal token As Long) As Long
  36. Private Declare Function GdipCreateBitmapFromHBITMAP Lib "GDIPlus" (ByVal hbm As Long, ByValhpal As Long, Bitmap As Long) As Long
  37. Private Declare Function GdipDisposeImage Lib "GDIPlus" (ByVal Image As Long) As Long
  38. Private Declare Function GdipSaveImageToFile Lib "GDIPlus" (ByVal Image As Long, ByVal FileName As Long, clsidEncoder As GUID, encoderParams As Any) As Long
  39. Private Declare Function CLSIDFromString Lib "ole32" (ByVal str As Long, id As GUID) As Long
  40. Private Declare Function IsClipboardFormatAvailable Lib "user32" (ByVal wFormat As Integer) As Long
  41. Private Declare Function GetClipboardData Lib "user32" (ByVal wFormat As Integer) As Long
  42. Private Declare Function OpenClipboard Lib "user32" (ByVal hwnd As Long) As Long
  43. Private Declare Function CloseClipboard Lib "user32" () As Long
  44. Const CF_BITMAP = 2

  45. '①通过Windows API访问粘贴板中的图片数据
  46. '基本思路是在doc中找到需要保存的图片,复制到粘贴板后,调用API从粘贴板中抓出数据并另存为。
  47. '此方法中Inlineshape和shape会表现不同的特性,具体讲,就是前者会以原始分辨率输出,后者以doc中所表现的分辨率输出。
  48. '但相对于第一种方法,可加入图片筛选等行为。
  49. '下面调用API的代码,实现从单个doc中导出全部图片。

  50. Sub 通过API访问粘贴板并另存图片数据()
  51.    Dim tSI As GdiplusStartupInput
  52.    Dim lRes As Long
  53.    Dim lGDIP As Long
  54.    Dim lBitmap As Long
  55.    Dim hBitmap As Long
  56.    Dim FSO As Object, WordDoc As Object, ExcelApp As Object, sFolder$, sPath$, FileName$, inShp As InlineShape, N As Long
  57.    Set FSO = CreateObject("Scripting.FileSystemObject") '创建文件系统对象
  58.    sPath = ThisDocument.Path '代码所在的Word文件路径
  59.    sFolder = sPath & "" & Split(ThisDocument.Name, ".")(0) '文件夹路径
  60.    If FSO.FolderExists(sFolder) Then FSO.DeleteFolder sFolder '当文件夹存在时,则删除文件夹
  61.    FSO.CreateFolder sFolder '创建文件夹
  62. '   MkDir sFolder  '创建文件夹
  63.    Set WordDoc = Documents.Open(sPath & "" & "如何导出图片并自动命名.docx", Visible:=False) '打开指定路径下的Word文件,并不显示
  64.    Set ExcelApp = CreateObject("Excel.Application") '创建ExcelApp程序
  65.    
  66.    '获取所有图片要重命名的名称
  67.    Dim arr(), hhhh&, kkkk&, rrrr&, jjjj&, jj&, iiii&
  68.    hhhh = WordDoc.InlineShapes.Count  'Word文件中所有的Inlineshape图片
  69.    ReDim Preserve arr(1 To hhhh)  '重定义数组
  70.    For kkkk = 1 To WordDoc.Tables.Count '在Word文件中所有的表格中循环
  71.         For rrrr = 1 To WordDoc.Tables(kkkk).Range.Rows.Count '在每个表格的所有行中循环
  72.             jjjj = WordDoc.Tables(kkkk).Cell(rrrr, 2).Range.InlineShapes.Count '获取每个表格中第2栏中单元格中的图片数量
  73.             If jjjj > 1 Then '当图片数量> 1 时
  74.                 For jj = 1 To jjjj
  75.                     iiii = iiii + 1
  76.                     A = WordDoc.Tables(kkkk).Cell(rrrr, 1).Range.Text & jj '图片要重命名的名称+序号
  77.                     arr(iiii) = ExcelApp.WorksheetFunction.Clean(A) '目的提取不带不可见的字符
  78.                 Next
  79.             ElseIf jjjj = 1 Then '当图片数量=1 时
  80.                   iiii = iiii + 1
  81.                   A = WordDoc.Tables(kkkk).Cell(rrrr, 1).Range.Text
  82.                   arr(iiii) = ExcelApp.WorksheetFunction.Clean(A)
  83.             Else
  84.             End If
  85.         Next
  86.    Next
  87.    
  88.    For Each inShp In WordDoc.InlineShapes '在打开的Word文件中所有的【嵌入型】图片中遍历
  89.    '如果是shape,此处改为 ActiveDocument.Shapes,当然inShp的声明也要改
  90.        N = N + 1
  91. '       A = inShp.Range.Cells(1).Range.Text  '图片所在的表格中的单元格的文本
  92. '       AA = Trim(Mid(A, 2, Len(A) - 3)) '目的提取不带不可见的字符
  93.        AA = arr(N)
  94.        FileName = sFolder & "" & AA & ".jpg"
  95. '       FileName = sFolder & "" & Format(N, "000.jpg") '代码Word文件所在的路径+流水号+(.gif、.jpg、.jpeg、.png、.bmp、.tif等)
  96.        inShp.Range.CopyAsPicture '复制为图片
  97.        '如果为shape,CopyAsPicture方法无效,可能因为shape本身就是pic,
  98.        '所以对于shape直接select,再copy,即以图片形式装入了粘贴板,
  99.        '后续操作相同。
  100.        OpenClipboard 0&  '打开粘贴板
  101.        hBitmap = GetClipboardData(CF_BITMAP) '获取粘贴板的数据
  102.        CloseClipboard '关闭粘贴板
  103.        tSI.GdiplusVersion = 1
  104.        lRes = GdiplusStartup(lGDIP, tSI, 0)
  105.        If lRes = 0 Then
  106.             lRes = GdipCreateBitmapFromHBITMAP(hBitmap, 0, lBitmap)
  107.            If lRes = 0 Then
  108.                Dim tJpgEncoder As GUID
  109.                Dim tParams As EncoderParameters
  110.                CLSIDFromString StrPtr("{557CF401-1A04-11D3-9A73-0000F81EF32E}"), tJpgEncoder
  111.                tParams.Count = 1
  112.                With tParams.Parameter
  113.                    CLSIDFromString StrPtr("{1D5BE4B5-FA4A-452D-9CDD-5DB35105E7EB}"), .GUID
  114.                    .NumberOfValues = 1
  115.                    .type = 4
  116.                    .Value = VarPtr(100)
  117.                End With
  118.                lRes = GdipSaveImageToFile(lBitmap, StrPtr(FileName), tJpgEncoder, tParams)
  119.                GdipDisposeImage lBitmap
  120.            End If
  121.            GdiplusShutdown lGDIP
  122.        End If
  123.    Next inShp
  124.    WordDoc.Close (0) '关闭活动Word文件,并不保存
  125.    Set ExcelApp = Nothing
  126.    MsgBox "图片已另存为成功!" & Chr(13) & "一共 " & N & " 个", 64, "提示"
  127. End Sub
复制代码


用VBA实现Word批量导出图片.gif

用VBA实现Word_Doc文档批量导出图片jpg文件.zip

113.15 KB, 下载次数: 138

评分

1

查看全部评分

TA的精华主题

TA的得分主题

发表于 2018-5-10 14:20 | 显示全部楼层
  1. '②通过复制到Excel后,用Excel的ChartObjects对象的相关方法实现输出
  2. '在Excel中,ChartObjects是由指定的图表工作表、对话框工作表或工作表上的所有 ChartObject 对象组成的集合。每个 ChartObject 对象都代表一个嵌入图表。
  3. 'ChartObject 对象充当 Chart 对象的容器。ChartObject 对象的属性和方法控制工作表上嵌入图表的外观和大小。
  4. '该方法的亮点是:当利用PasteSpecial将数据从doc传递到xls中时,无论原来对象的类型,都可以靠PasteSpecial实现其分辨率的控制,示例中的"图片(增强型图元文件)"即为原始分辨率复制。

  5. '综上所述,如果只是导出图片,而对其分辨率没有明确要求,那么多种方法均能很好的实现目标。否则,就必须考虑其在doc中所属对象类型了,或者选择特定方法。
  6. '从本质上看,两种对象类型在doc中都存储了完整的数据,那么区别只是在于特定的复制方法是否能暴露出其全部的数据。

  7. '以下代码是直接在WordVBA中实现的,其中对Excel中的对象引用已做处理。

  8. Sub 复制到Excel后输出1()
  9. Dim FSO As Object, ExcelApp As Object, NewExcel As Object, Excel_Shape As Object, sPath$, sFolder$, i&
  10. Set FSO = CreateObject("Scripting.FileSystemObject") '创建文件系统对象
  11. sPath = ThisDocument.Path '代码所在Word的路径
  12. sFolder = sPath & "" & Split(ThisDocument.Name, ".")(0) '文件夹路径
  13. If FSO.FolderExists(sFolder) Then FSO.DeleteFolder sFolder '当文件夹存在时,则删除文件夹
  14. FSO.CreateFolder sFolder '创建文件夹
  15. 'MkDir sFolder '创建文件夹
  16. Set WordDoc = Documents.Open(sPath & "" & "如何导出图片并自动命名.docx", Visible:=False) '打开指定路径下的Word文件,并不显示
  17. Set ExcelApp = CreateObject("Excel.Application") '创建ExcelApp程序
  18. Set NewExcel = ExcelApp.Workbooks.Add '新建Excel工作簿
  19. 'ExcelApp.Visible = True '显示ExcelApp程序
  20. Application.DisplayAlerts = False '从doc到xls的复制过程可能会报错,故加此句
  21.    
  22.    '获取所有图片要重命名的名称
  23.    Dim arr(), hhhh&, kkkk&, rrrr&, jjjj&, jj&, iiii&
  24.    hhhh = WordDoc.InlineShapes.Count  'Word文件中所有的Inlineshape图片
  25.    ReDim Preserve arr(1 To hhhh)  '重定义数组
  26.    For kkkk = 1 To WordDoc.Tables.Count '在Word文件中所有的表格中循环
  27.         For rrrr = 1 To WordDoc.Tables(kkkk).Range.Rows.Count '在每个表格的所有行中循环
  28.             jjjj = WordDoc.Tables(kkkk).Cell(rrrr, 2).Range.InlineShapes.Count '获取每个表格中第2栏中单元格中的图片数量
  29.             If jjjj > 1 Then '当图片数量> 1 时
  30.                 For jj = 1 To jjjj
  31.                     iiii = iiii + 1
  32.                     A = WordDoc.Tables(kkkk).Cell(rrrr, 1).Range.Text & jj '图片要重命名的名称+序号
  33.                     arr(iiii) = ExcelApp.WorksheetFunction.Clean(A) '目的提取不带不可见的字符
  34.                 Next
  35.             ElseIf jjjj = 1 Then '当图片数量=1 时
  36.                   iiii = iiii + 1
  37.                   A = WordDoc.Tables(kkkk).Cell(rrrr, 1).Range.Text
  38.                   arr(iiii) = ExcelApp.WorksheetFunction.Clean(A)
  39.             Else
  40.             End If
  41.         Next
  42.    Next

  43. For i = 1 To WordDoc.InlineShapes.Count '在打开的Word文件中所有【嵌入型】图片数量中循
  44. '如果是shape,此处改为 ActiveDocument.Shapes
  45.    WordDoc.InlineShapes(i).Select  '选择Word文件中【嵌入型】图片
  46.    Selection.Copy '复制选中的图片
  47. '   A = Selection.Range.Cells(1).Range.Text  '图片所在的表格中的单元格的文本
  48. '   AA = Trim(Mid(A, 2, Len(A) - 3)) '目的提取不带不可的字符
  49.     N = N + 1
  50.    AA = arr(N)
  51.    NewExcel.WorkSheets(1).Cells(1, 1).Activate
  52.    NewExcel.WorkSheets(1).PasteSpecial Format:="图片(增强型图元文件)", Link:=False, DisplayAsIcon:=False
  53.    Set Excel_Shape = NewExcel.WorkSheets(1).Shapes(1) '因为当单个doc中存在图片量过多,均复制到xls中造成数据量过大,
  54.    '这里采用了复制一个进入Excel,再另存图片后,立即删除Excel中的图片数据,所以遍历时,index永远是1
  55.    NewExcel.WorkSheets(1).Shapes(1).Copy '复制从Word中复制到Excel中的图片
  56.    With NewExcel.WorkSheets(1).ChartObjects.Add(0, 0, Excel_Shape.Width, Excel_Shape.Height).Chart
  57.        .Paste '粘贴
  58.        .Export sFolder & "" & AA & ".jpg" '汇出的路径+图片文件名
  59. '       .Export sfolder & "" & i & ".jpg"
  60.        .Parent.Delete '删除第二次复制产生的图片
  61.    End With
  62.    NewExcel.WorkSheets(1).Shapes(1).Delete '删除第一次复制产生的图片
  63. Next i
  64. WordDoc.Close 0 '关闭活动Word文件,并不保存
  65. NewExcel.Close 0 '关闭活动Excel文件,并不保存
  66. Set ExcelApp = Nothing
  67. MsgBox "图片已另存为成功!" & Chr(13) & "一共 " & i - 1 & " 个", 64, "提示"
  68. End Sub
复制代码

评分

2

查看全部评分

TA的精华主题

TA的得分主题

 楼主| 发表于 2018-5-10 20:24 | 显示全部楼层
竟然写了两种方法,竟然还弄了gif。
我无地自容。
一句话,非常感谢。

TA的精华主题

TA的得分主题

发表于 2018-11-19 13:30 | 显示全部楼层

TA的精华主题

TA的得分主题

发表于 2019-3-11 16:39 | 显示全部楼层

TA的精华主题

TA的得分主题

发表于 2019-5-31 11:36 | 显示全部楼层
[广告] VBA代码宝 - VBA编程加强工具 · VBA代码随查随用  · 内置多项VBA编程加强工具       ★ 免费下载 ★      ★使用手册

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

TA的精华主题

TA的得分主题

发表于 2024-2-3 21:59 | 显示全部楼层

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

TA的精华主题

TA的得分主题

发表于 2024-3-9 18:32 | 显示全部楼层
[广告] VBA代码宝 - VBA编程加强工具 · VBA代码随查随用  · 内置多项VBA编程加强工具       ★ 免费下载 ★      ★使用手册

跪求大神,
在32位OK,在64位报错,
我研究,改了二周,没有搞定,
可以给个64位的版本吗?
您需要登录后才可以回帖 登录 | 免费注册

本版积分规则

手机版|关于我们|联系我们|ExcelHome

GMT+8, 2024-7-14 15:20 , Processed in 0.045241 second(s), 11 queries , Gzip On, MemCache On.

Powered by Discuz! X3.4

© 1999-2023 Wooffice Inc.

沪公网安备 31011702000001号 沪ICP备11019229号-2

本论坛言论纯属发表者个人意见,任何违反国家相关法律的言论,本站将协助国家相关部门追究发言者责任!     本站特聘法律顾问:李志群律师

快速回复 返回顶部 返回列表