Visio批量修改图形内容，导出图片，另存为新文件

Sub chenphAutoExport()
    ' 角色
    Dim role(2) As String
    role(0) = "普通教师"
    role(1) = "高级教师"

     ' 分类
    Dim sort(2) As String
    sort(0) = "数学"
    sort(1) = "语文"

     ' 班级
    Dim class(2) As String
    class(0) = "一班"
    class(1) = "二班"

    'Enable diagram services
    Dim DiagramServices As Integer
    DiagramServices = ActiveDocument.DiagramServicesEnabled
    ActiveDocument.DiagramServicesEnabled = visServiceVersion140 + visServiceVersion150
    
    Dim rootPath As String
    'rootPath = "C:\Users\chenph-vm-win7\Desktop\Test\Auto\"
    rootPath = ActiveDocument.Path + "\Auto-Chenph\"
    
    For i = 0 To UBound(role) - 1
        For j = 0 To UBound(sort) - 1
            MakeDir (rootPath + role(i) + "\" + sort(j))
        Next j
    Next i
    
    For i = 0 To UBound(role) - 1
        For j = 0 To UBound(sort) - 1
            For k = 0 To UBound(tradeType) - 1
                Application.ActiveWindow.Page = Application.ActiveDocument.Pages.Item(1)
                
                Dim vsoCharacters1 As Visio.Characters
                Set vsoCharacters1 = Application.ActiveWindow.Page.Shapes.ItemFromID(179).Characters
                vsoCharacters1.Text = "登录（" + role(i) + "）"                
            
                Application.Settings.SetRasterExportResolution visRasterUseScreenResolution, 96#, 96#, visRasterPixelsPerInch
                Application.Settings.SetRasterExportSize visRasterFitToSourceSize, 1.583333, 1.1875, visRasterInch
                Application.Settings.RasterExportColorFormat = visRasterRGB
                Application.Settings.RasterExportOperation = visRasterBaseline
                Application.Settings.RasterExportRotation = visRasterNoRotation
                Application.Settings.RasterExportFlip = visRasterNoFlip
                Application.Settings.RasterExportBackgroundColor = 16777215
                Application.Settings.RasterExportQuality = 75
                Application.ActiveWindow.Page.Export rootPath + "\" + role(i) + "\" + sort(j) + "\" + class(k) + "-" + Application.ActiveWindow.Page.Name + ".jpg"
              
                Dim PageNamesU() As String
                Application.ActiveDocument.ServerPublishOptions.SetPagesToPublish visPublishPageAll, PageNamesU, visLangUniversal
                Dim RecordsetIDs() As Long
                Application.ActiveDocument.ServerPublishOptions.SetRecordsetsToPublish visPublishDataRecordsetAll, RecordsetIDs
                Application.ActiveDocument.SaveAsEx rootPath + "\" + role(i) + "\" + sort(j) + "\" + class(k) + ".vsd", visSaveAsWS + visSaveAsListInMRU
                'Application.ActiveDocument.SaveAsEx rootPath + role(i) + sort(j) + class(k) + ".vsd", visSaveAsWS + visSaveAsListInMRU
            Next k
        Next j
    Next i
    
    'Restore diagram services
    ActiveDocument.DiagramServicesEnabled = DiagramServices
End Sub

Public Sub MakeDir(Path As String)
    On Error Resume Next
    Dim o_strRet As String
    Dim o_intItems As Integer
    Dim o_vntItem As Variant
    Dim o_strItems() As String
    o_strItems() = Split(Path, "\")
    o_intItems = 0
    For Each o_vntItem In o_strItems()
        o_intItems = o_intItems + 1
        If o_intItems = 1 Then
            o_strRet = o_vntItem
        Else
            o_strRet = o_strRet & "\" & o_vntItem
            MkDir o_strRet
        End If
    Next
End Sub

• 原文地址