Attribute VB_Name = "NewMacros1"
Option Explicit

Private Const CROP_MARGIN_MM As Long = 1
Private Const PNG_DPI As Long = 300

Private Type PdfBoundingBox
    Llx As Double
    Lly As Double
    Urx As Double
    Ury As Double
End Type

Sub mk_pdf()
Attribute mk_pdf.VB_ProcData.VB_Invoke_Func = "q"
    ExportCurrentPageFromVisioPdf "pdf"
End Sub

Sub mk_svg()
Attribute mk_svg.VB_ProcData.VB_Invoke_Func = "r"
    ExportCurrentPageFromVisioPdf "svg"
End Sub

Sub mk_png()
Attribute mk_png.VB_ProcData.VB_Invoke_Func = "t"
    ExportCurrentPageFromVisioPdf "png"
End Sub

Private Sub ExportCurrentPageFromVisioPdf(ByVal extensionName As String)
    Dim doc As Visio.Document
    Dim win As Visio.Window
    Dim page As Visio.Page
    Dim fso As Object
    Dim outputPath As String
    Dim tempVisioPdfPath As String
    Dim tempCroppedPdfPath As String
    Dim tempPlainSvgPath As String
    Dim tempPngPath As String
    Dim errText As String

    On Error GoTo ErrorHandler

    Set doc = Visio.ActiveDocument
    Set win = Visio.ActiveWindow
    If doc Is Nothing Then Err.Raise vbObjectError + 100, , "No active document."
    If win Is Nothing Then Err.Raise vbObjectError + 101, , "No active window."

    Set page = win.Page
    If page Is Nothing Then Err.Raise vbObjectError + 102, , "No active page."
    If Len(doc.FullName) = 0 Then Err.Raise vbObjectError + 103, , "Please save the Visio document first."

    extensionName = LCase$(Replace(extensionName, ".", ""))
    If extensionName <> "pdf" And extensionName <> "svg" And extensionName <> "png" Then
        Err.Raise vbObjectError + 104, , "Unsupported export type: " & extensionName
    End If

    Set fso = CreateObject("Scripting.FileSystemObject")
    outputPath = BuildOutputPath(doc, page, extensionName)
    tempVisioPdfPath = BuildTempPath(doc, page, "visio.pdf")
    tempCroppedPdfPath = BuildTempPath(doc, page, "cropped.pdf")
    tempPlainSvgPath = BuildTempPath(doc, page, "plain.svg")
    tempPngPath = BuildTempPath(doc, page, "png")

    DeleteFileIfExists fso, tempVisioPdfPath
    DeleteFileIfExists fso, tempCroppedPdfPath
    DeleteFileIfExists fso, tempPlainSvgPath
    DeleteFileIfExists fso, tempPngPath

    ExportCurrentPageAsPdf doc, tempVisioPdfPath
    CropPdfWithGhostscript tempVisioPdfPath, tempCroppedPdfPath

    If extensionName = "pdf" Then
        ReplaceFile fso, tempCroppedPdfPath, outputPath
    ElseIf extensionName = "svg" Then
        ConvertPdfToPlainSvg tempCroppedPdfPath, tempPlainSvgPath
        ReplaceFile fso, tempPlainSvgPath, outputPath
    Else
        ConvertPdfToPng tempCroppedPdfPath, tempPngPath
        ReplaceFile fso, tempPngPath, outputPath
    End If

    DeleteFileIfExists fso, tempVisioPdfPath
    DeleteFileIfExists fso, tempCroppedPdfPath
    DeleteFileIfExists fso, tempPlainSvgPath
    DeleteFileIfExists fso, tempPngPath
    Exit Sub

ErrorHandler:
    errText = Err.Description
    On Error Resume Next
    If Not fso Is Nothing Then
        DeleteFileIfExists fso, tempVisioPdfPath
        DeleteFileIfExists fso, tempCroppedPdfPath
        DeleteFileIfExists fso, tempPlainSvgPath
        DeleteFileIfExists fso, tempPngPath
    End If
    On Error GoTo 0
    MsgBox "Export failed." & vbCrLf & errText, vbExclamation
End Sub

Private Sub ExportCurrentPageAsPdf(ByVal doc As Visio.Document, ByVal pdfPath As String)
    doc.ExportAsFixedFormat _
        visFixedFormatPDF, _
        pdfPath, _
        visDocExIntentPrint, _
        visPrintCurrentPage, _
        1, 1, _
        False, True, True, True, False
End Sub

Private Sub CropPdfWithGhostscript(ByVal sourcePdfPath As String, ByVal croppedPdfPath As String)
    Dim bbox As PdfBoundingBox
    Dim gsPath As String
    Dim fso As Object
    Dim marginPts As Double
    Dim cropLeft As Long
    Dim cropBottom As Long
    Dim cropRight As Long
    Dim cropTop As Long
    Dim cropWidth As Long
    Dim cropHeight As Long
    Dim command As String
    Dim pageOffset As String

    Set fso = CreateObject("Scripting.FileSystemObject")
    DeleteFileIfExists fso, croppedPdfPath

    gsPath = FindGhostscriptPath()
    If Len(gsPath) = 0 Then
        Err.Raise vbObjectError + 500, , "Could not find Ghostscript gswin64c.exe or gswin32c.exe."
    End If

    bbox = GetPdfBoundingBox(gsPath, sourcePdfPath)
    marginPts = CROP_MARGIN_MM * 72# / 25.4

    cropLeft = FloorToLong(bbox.Llx - marginPts)
    cropBottom = FloorToLong(bbox.Lly - marginPts)
    cropRight = CeilingToLong(bbox.Urx + marginPts)
    cropTop = CeilingToLong(bbox.Ury + marginPts)
    cropWidth = cropRight - cropLeft
    cropHeight = cropTop - cropBottom

    If cropWidth <= 0 Or cropHeight <= 0 Then
        Err.Raise vbObjectError + 501, , "Could not determine a valid PDF crop box."
    End If

    pageOffset = "<</PageOffset [" & CStr(-cropLeft) & " " & CStr(-cropBottom) & "]>> setpagedevice"
    command = QuoteArg(gsPath) & _
        " -dNOPAUSE -dBATCH -sDEVICE=pdfwrite -dFIXEDMEDIA" & _
        " -dDEVICEWIDTHPOINTS=" & CStr(cropWidth) & _
        " -dDEVICEHEIGHTPOINTS=" & CStr(cropHeight) & _
        " -o " & QuoteArg(croppedPdfPath) & _
        " -c " & QuoteArg(pageOffset) & _
        " -f " & QuoteArg(sourcePdfPath)

    If Not RunCommandAndCreated(command, croppedPdfPath) Then
        Err.Raise vbObjectError + 502, , "Ghostscript failed to crop the PDF."
    End If
End Sub

Private Function GetPdfBoundingBox(ByVal gsPath As String, ByVal pdfPath As String) As PdfBoundingBox
    Dim command As String
    Dim outputText As String
    Dim bboxLine As String

    command = QuoteArg(gsPath) & " -dNOPAUSE -dBATCH -sDEVICE=bbox " & QuoteArg(pdfPath)
    outputText = RunCommandAndCapture(command)

    bboxLine = FindLastLineContaining(outputText, "%%HiResBoundingBox:")
    If Len(bboxLine) = 0 Then bboxLine = FindLastLineContaining(outputText, "%%BoundingBox:")
    If Len(bboxLine) = 0 Then
        Err.Raise vbObjectError + 503, , "Ghostscript did not report a PDF bounding box."
    End If

    GetPdfBoundingBox = ParseBoundingBoxLine(bboxLine)
End Function

Private Function ParseBoundingBoxLine(ByVal bboxLine As String) As PdfBoundingBox
    Dim valuesText As String
    Dim parts As Variant
    Dim colonPosition As Long
    Dim box As PdfBoundingBox

    colonPosition = InStr(1, bboxLine, ":", vbTextCompare)
    If colonPosition = 0 Then Err.Raise vbObjectError + 504, , "Invalid bounding box line: " & bboxLine

    valuesText = Trim$(Mid$(bboxLine, colonPosition + 1))
    valuesText = Replace(valuesText, vbTab, " ")
    Do While InStr(valuesText, "  ") > 0
        valuesText = Replace(valuesText, "  ", " ")
    Loop

    parts = Split(valuesText, " ")
    If UBound(parts) < 3 Then Err.Raise vbObjectError + 505, , "Invalid bounding box values: " & bboxLine

    box.Llx = Val(CStr(parts(0)))
    box.Lly = Val(CStr(parts(1)))
    box.Urx = Val(CStr(parts(2)))
    box.Ury = Val(CStr(parts(3)))

    ParseBoundingBoxLine = box
End Function

Private Sub ConvertPdfToPlainSvg(ByVal pdfPath As String, ByVal plainSvgPath As String)
    Dim fso As Object
    Set fso = CreateObject("Scripting.FileSystemObject")

    DeleteFileIfExists fso, plainSvgPath

    If TryConvertPdfToPlainSvgWithInkscape(pdfPath, plainSvgPath, True) Then Exit Sub
    If TryConvertPdfToPlainSvgWithInkscape(pdfPath, plainSvgPath, False) Then Exit Sub

    Err.Raise vbObjectError + 510, , _
        "Could not convert cropped PDF to Plain SVG. Please install Inkscape or add inkscape.com to PATH."
End Sub

Private Function TryConvertPdfToPlainSvgWithInkscape( _
    ByVal pdfPath As String, _
    ByVal plainSvgPath As String, _
    ByVal usePoppler As Boolean) As Boolean

    Dim exePath As String
    Dim command As String

    exePath = FindInkscapePath()
    If Len(exePath) = 0 Then Exit Function

    If usePoppler Then
        command = QuoteArg(exePath) & " --pdf-poppler --export-plain-svg --export-filename=" & _
            QuoteArg(plainSvgPath) & " " & QuoteArg(pdfPath)
    Else
        command = QuoteArg(exePath) & " --export-plain-svg --export-filename=" & _
            QuoteArg(plainSvgPath) & " " & QuoteArg(pdfPath)
    End If

    TryConvertPdfToPlainSvgWithInkscape = RunCommandAndCreated(command, plainSvgPath)
End Function

Private Sub ConvertPdfToPng(ByVal pdfPath As String, ByVal pngPath As String)
    Dim fso As Object
    Set fso = CreateObject("Scripting.FileSystemObject")

    DeleteFileIfExists fso, pngPath

    If TryConvertPdfToPngWithInkscape(pdfPath, pngPath, True) Then Exit Sub
    If TryConvertPdfToPngWithInkscape(pdfPath, pngPath, False) Then Exit Sub

    Err.Raise vbObjectError + 520, , _
        "Could not convert cropped PDF to PNG. Please install Inkscape or add inkscape.com to PATH."
End Sub

Private Function TryConvertPdfToPngWithInkscape( _
    ByVal pdfPath As String, _
    ByVal pngPath As String, _
    ByVal usePoppler As Boolean) As Boolean

    Dim exePath As String
    Dim command As String

    exePath = FindInkscapePath()
    If Len(exePath) = 0 Then Exit Function

    If usePoppler Then
        command = QuoteArg(exePath) & " --pdf-poppler --export-type=png --export-dpi=" & _
            CStr(PNG_DPI) & " --export-filename=" & QuoteArg(pngPath) & " " & QuoteArg(pdfPath)
    Else
        command = QuoteArg(exePath) & " --export-type=png --export-dpi=" & _
            CStr(PNG_DPI) & " --export-filename=" & QuoteArg(pngPath) & " " & QuoteArg(pdfPath)
    End If

    TryConvertPdfToPngWithInkscape = RunCommandAndCreated(command, pngPath)
End Function

Private Function RunCommandAndCapture(ByVal command As String) As String
    Dim shell As Object
    Dim exec As Object

    Set shell = CreateObject("WScript.Shell")
    Set exec = shell.Exec(command)

    Do While exec.Status = 0
        DoEvents
    Loop

    RunCommandAndCapture = exec.StdOut.ReadAll & vbCrLf & exec.StdErr.ReadAll
End Function

Private Function RunCommandAndCreated(ByVal command As String, ByVal outputPath As String) As Boolean
    Dim shell As Object
    Dim exitCode As Long

    Set shell = CreateObject("WScript.Shell")
    exitCode = shell.Run(command, 0, True)

    RunCommandAndCreated = (exitCode = 0 And FileExists(outputPath))
End Function

Private Function FindLastLineContaining(ByVal text As String, ByVal pattern As String) As String
    Dim normalizedText As String
    Dim lines As Variant
    Dim lineItem As Variant

    normalizedText = Replace(text, vbCr, vbLf)
    lines = Split(normalizedText, vbLf)

    For Each lineItem In lines
        If InStr(1, CStr(lineItem), pattern, vbTextCompare) > 0 Then
            FindLastLineContaining = CStr(lineItem)
        End If
    Next
End Function

Private Function FindInkscapePath() As String
    Dim shell As Object
    Dim candidates As Variant
    Dim candidate As Variant

    FindInkscapePath = FindExecutable("inkscape.com")
    If Len(FindInkscapePath) > 0 Then Exit Function
    FindInkscapePath = FindExecutable("inkscape.exe")
    If Len(FindInkscapePath) > 0 Then Exit Function

    Set shell = CreateObject("WScript.Shell")
    candidates = Array( _
        shell.ExpandEnvironmentStrings("%ProgramFiles%") & "\Inkscape\bin\inkscape.com", _
        shell.ExpandEnvironmentStrings("%ProgramFiles%") & "\Inkscape\bin\inkscape.exe", _
        shell.ExpandEnvironmentStrings("%ProgramFiles(x86)%") & "\Inkscape\bin\inkscape.com", _
        shell.ExpandEnvironmentStrings("%ProgramFiles(x86)%") & "\Inkscape\bin\inkscape.exe")

    For Each candidate In candidates
        If FileExists(CStr(candidate)) Then
            FindInkscapePath = CStr(candidate)
            Exit Function
        End If
    Next
End Function

Private Function FindGhostscriptPath() As String
    Dim shell As Object

    FindGhostscriptPath = FindExecutable("gswin64c.exe")
    If Len(FindGhostscriptPath) > 0 Then Exit Function
    FindGhostscriptPath = FindExecutable("gswin32c.exe")
    If Len(FindGhostscriptPath) > 0 Then Exit Function

    Set shell = CreateObject("WScript.Shell")
    FindGhostscriptPath = FindGhostscriptInRoot(shell.ExpandEnvironmentStrings("%ProgramFiles%") & "\gs")
    If Len(FindGhostscriptPath) > 0 Then Exit Function
    FindGhostscriptPath = FindGhostscriptInRoot(shell.ExpandEnvironmentStrings("%ProgramFiles(x86)%") & "\gs")
End Function

Private Function FindGhostscriptInRoot(ByVal gsRoot As String) As String
    Dim fso As Object
    Dim rootFolder As Object
    Dim subFolder As Object
    Dim candidate As String

    Set fso = CreateObject("Scripting.FileSystemObject")
    If Not fso.FolderExists(gsRoot) Then Exit Function

    Set rootFolder = fso.GetFolder(gsRoot)
    For Each subFolder In rootFolder.SubFolders
        candidate = subFolder.Path & "\bin\gswin64c.exe"
        If fso.FileExists(candidate) Then
            FindGhostscriptInRoot = candidate
            Exit Function
        End If

        candidate = subFolder.Path & "\bin\gswin32c.exe"
        If fso.FileExists(candidate) Then
            FindGhostscriptInRoot = candidate
            Exit Function
        End If
    Next
End Function

Private Function FindExecutable(ByVal commandName As String) As String
    Dim shell As Object
    Dim pathText As String
    Dim parts As Variant
    Dim part As Variant
    Dim candidate As String
    Dim names As Variant
    Dim nameItem As Variant

    Set shell = CreateObject("WScript.Shell")

    names = ExecutableNames(commandName)
    pathText = shell.Environment("PROCESS")("PATH")
    parts = Split(pathText, ";")

    For Each part In parts
        If Len(Trim$(CStr(part))) > 0 Then
            For Each nameItem In names
                candidate = AddTrailingBackslash(CStr(part)) & CStr(nameItem)
                If FileExists(candidate) Then
                    FindExecutable = candidate
                    Exit Function
                End If
            Next
        End If
    Next
End Function

Private Function ExecutableNames(ByVal commandName As String) As Variant
    If InStrRev(commandName, ".") > 0 Then
        ExecutableNames = Array(commandName)
    Else
        ExecutableNames = Array(commandName & ".com", commandName & ".exe", commandName & ".cmd", commandName & ".bat")
    End If
End Function

Private Function BuildOutputPath(ByVal doc As Visio.Document, ByVal page As Visio.Page, ByVal extensionName As String) As String
    BuildOutputPath = GetDocumentDirectory(doc) & SafeFileName(page.Name) & "." & extensionName
End Function

Private Function BuildTempPath(ByVal doc As Visio.Document, ByVal page As Visio.Page, ByVal extensionName As String) As String
    BuildTempPath = GetDocumentDirectory(doc) & "~" & SafeFileName(page.Name) & "_export_tmp." & extensionName
End Function

Private Function GetDocumentDirectory(ByVal doc As Visio.Document) As String
    Dim fullPath As String
    Dim lastSlash As Long

    fullPath = doc.FullName
    lastSlash = InStrRev(fullPath, "\")
    If Len(fullPath) = 0 Or lastSlash = 0 Then Err.Raise vbObjectError + 300, , "Please save the Visio document first."
    GetDocumentDirectory = Left$(fullPath, lastSlash)
End Function

Private Function SafeFileName(ByVal text As String) As String
    Dim invalidChars As Variant
    Dim invalidChar As Variant

    invalidChars = Array("\", "/", ":", "*", "?", """", "<", ">", "|")
    For Each invalidChar In invalidChars
        text = Replace(text, CStr(invalidChar), "_")
    Next

    text = Trim$(text)
    Do While Len(text) > 0 And (Right$(text, 1) = "." Or Right$(text, 1) = " ")
        text = Left$(text, Len(text) - 1)
    Loop

    If Len(text) = 0 Then text = "page"
    SafeFileName = text
End Function

Private Function FloorToLong(ByVal value As Double) As Long
    FloorToLong = CLng(Int(value))
End Function

Private Function CeilingToLong(ByVal value As Double) As Long
    CeilingToLong = CLng(-Int(-value))
End Function

Private Function AddTrailingBackslash(ByVal folderPath As String) As String
    If Right$(folderPath, 1) = "\" Then
        AddTrailingBackslash = folderPath
    Else
        AddTrailingBackslash = folderPath & "\"
    End If
End Function

Private Function QuoteArg(ByVal text As String) As String
    QuoteArg = """" & text & """"
End Function

Private Function FileExists(ByVal filePath As String) As Boolean
    Dim fso As Object
    Set fso = CreateObject("Scripting.FileSystemObject")
    FileExists = fso.FileExists(filePath)
End Function

Private Sub DeleteFileIfExists(ByVal fso As Object, ByVal filePath As String)
    If Len(filePath) > 0 Then
        If fso.FileExists(filePath) Then fso.DeleteFile filePath, True
    End If
End Sub

Private Sub ReplaceFile(ByVal fso As Object, ByVal sourcePath As String, ByVal targetPath As String)
    If Not fso.FileExists(sourcePath) Then
        Err.Raise vbObjectError + 400, , "The export file was not created: " & sourcePath
    End If

    fso.CopyFile sourcePath, targetPath, True
    fso.DeleteFile sourcePath, True
End Sub