word批量导出visio图

修改word格式

将word文档修改为docm格式

打开VBA窗口

打开开发工具VisualBasic项，如果没有右键在自定义功能区添加

插入代码

插入 -> 模块，代码如下：

Sub ExportAllVisioDiagrams()Dim shp As InlineShapeDim i As IntegerDim savePath As StringDim docName As StringDim visioApp As ObjectDim visioDoc As ObjectDim startTime As Double' 设置保存路径（修改为您想要的路径）savePath = "C:\Users\"' 创建文件夹（如果不存在）If Dir(savePath, vbDirectory) = "" Then MkDir savePath' 获取文档名称（不含扩展名）If ActiveDocument.Name Like "*.*" ThendocName = Left(ActiveDocument.Name, InStrRev(ActiveDocument.Name, ".") - 1)ElsedocName = ActiveDocument.NameEnd If' 创建Visio应用实例Set visioApp = CreateObject("Visio.Application")visioApp.Visible = True ' 设置为可见以便调试i = 1For Each shp In ActiveDocument.InlineShapesIf shp.Type = wdInlineShapeEmbeddedOLEObject ThenIf InStr(1, shp.OLEFormat.ProgID, "Visio", vbTextCompare) > 0 ThenOn Error Resume Next' 激活并选择Visio对象内容shp.OLEFormat.Activateshp.OLEFormat.Object.Application.ActiveWindow.SelectAllshp.OLEFormat.Object.Application.ActiveWindow.Selection.Copy' 创建新Visio文档Set visioDoc = visioApp.Documents.Add("")' 添加延迟确保复制完成startTime = TimerDo While Timer < startTime + 1DoEventsLoop' 粘贴内容visioApp.ActiveWindow.Page.Paste' 保存文件visioDoc.SaveAs savePath & docName & "_Diagram" & i & ".vsdx"If Err.Number <> 0 ThenvisioDoc.SaveAs savePath & docName & "_Diagram" & i & ".vsd"End IfvisioDoc.CloseSet visioDoc = Nothingi = i + 1' 每处理3个图表后增加延迟If i Mod 3 = 0 ThenstartTime = TimerDo While Timer < startTime + 2 ' 延迟2秒DoEventsLoopEnd IfOn Error GoTo 0End IfEnd IfNext shp' 关闭VisiovisioApp.QuitSet visioApp = NothingMsgBox "已导出 " & (i - 1) & " 个Visio图表到 " & savePath
End Sub

运行代码

点击运行 -> 运行子过程即可