Visioで今開いている図面を特定の解像度でPNGでエクスポートするマクロ（関数をショートカットに登録してね）

Visio-SaveAsPng.vba

Sub SaveAsPng()

    Dim ExportFileName As String
    ExportFileName = Application.ActivePage.Name + ".png"
    Dim PathPrefix As String
    PathPrefix = "images/"
    
    '(Re)Create export folder
    If Not DirExists(PathPrefix) Then
        MkDir PathPrefix
    End If

    'Enable diagram services
    Dim DiagramServices As Integer
    DiagramServices = ActiveDocument.DiagramServicesEnabled
    ActiveDocument.DiagramServicesEnabled = visServiceVersion140 + visServiceVersion150

    Application.Settings.SetRasterExportResolution visRasterUseCustomResolution, 600#, 600#, visRasterPixelsPerInch
    Application.Settings.SetRasterExportSize visRasterFitToSourceSize
    Application.Settings.RasterExportDataFormat = visRasterInterlace
    Application.Settings.RasterExportColorFormat = visRaster24Bit
    Application.Settings.RasterExportRotation = visRasterNoRotation
    Application.Settings.RasterExportFlip = visRasterNoFlip
    Application.Settings.RasterExportBackgroundColor = 16777215
    Application.Settings.RasterExportTransparencyColor = 16777215
    Application.Settings.RasterExportUseTransparencyColor = False
    Application.ActiveWindow.Page.Export Application.ActiveDocument.Path + PathPrefix + ExportFileName
    'Restore diagram services
    ActiveDocument.DiagramServicesEnabled = DiagramServices
    
    MsgBox "PNG Exported: " + ExportFileName

End Sub
'see http://www.vbaexpress.com/forum/showthread.php?7866-Check-for-folder-create-if-it-does-not-exist
Function DirExists(DirName As String) As Boolean
    On Error GoTo ErrorHandler
    DirExists = GetAttr(DirName) And vbDirectory
ErrorHandler:
End Function