word批量导出visio图

具体步骤

修改word格式
打开VBA窗口
插入代码
运行代码

修改word格式

将word文档修改为docm格式

打开VBA窗口

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

插入代码

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

vba 复制代码

Sub ExportAllVisioDiagrams()
    Dim shp As InlineShape
    Dim i As Integer
    Dim savePath As String
    Dim docName As String
    Dim visioApp As Object
    Dim visioDoc As Object
    Dim startTime As Double
    
    ' 设置保存路径（修改为您想要的路径）
    savePath = "C:\Users\"
    
    ' 创建文件夹（如果不存在）
    If Dir(savePath, vbDirectory) = "" Then MkDir savePath
    
    ' 获取文档名称（不含扩展名）
    If ActiveDocument.Name Like "*.*" Then
        docName = Left(ActiveDocument.Name, InStrRev(ActiveDocument.Name, ".") - 1)
    Else
        docName = ActiveDocument.Name
    End If
    
    ' 创建Visio应用实例
    Set visioApp = CreateObject("Visio.Application")
    visioApp.Visible = True ' 设置为可见以便调试
    
    i = 1
    For Each shp In ActiveDocument.InlineShapes
        If shp.Type = wdInlineShapeEmbeddedOLEObject Then
            If InStr(1, shp.OLEFormat.ProgID, "Visio", vbTextCompare) > 0 Then
                On Error Resume Next
                
                ' 激活并选择Visio对象内容
                shp.OLEFormat.Activate
                shp.OLEFormat.Object.Application.ActiveWindow.SelectAll
                shp.OLEFormat.Object.Application.ActiveWindow.Selection.Copy
                
                ' 创建新Visio文档
                Set visioDoc = visioApp.Documents.Add("")
                
                ' 添加延迟确保复制完成
                startTime = Timer
                Do While Timer < startTime + 1
                    DoEvents
                Loop
                
                ' 粘贴内容
                visioApp.ActiveWindow.Page.Paste
                
                ' 保存文件
                visioDoc.SaveAs savePath & docName & "_Diagram" & i & ".vsdx"
                If Err.Number <> 0 Then
                    visioDoc.SaveAs savePath & docName & "_Diagram" & i & ".vsd"
                End If
                
                visioDoc.Close
                Set visioDoc = Nothing
                
                i = i + 1
                
                ' 每处理3个图表后增加延迟
                If i Mod 3 = 0 Then
                    startTime = Timer
                    Do While Timer < startTime + 2 ' 延迟2秒
                        DoEvents
                    Loop
                End If
                
                On Error GoTo 0
            End If
        End If
    Next shp
    
    ' 关闭Visio
    visioApp.Quit
    Set visioApp = Nothing
    
    MsgBox "已导出 " & (i - 1) & " 个Visio图表到 " & savePath
End Sub

运行代码

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