VBA 调用 Ghostscript API 将PDF转换为图片

ycz22

Option Explicit
'备注:低版本的不支持中文路径(要9.0或更高版本)
'------------------------------------------------
'API 调用开始
'------------------------------------------------
'Win32 API 声明
Public Declare Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" (ByVal dest As Long, ByVal source As Long, ByVal bytes As Long)
'此函数将一定字节长度的数据从内存中的一个位置（源）复制到另一个位置（目的地）.

'GhostScript API 声明
Private Declare Function gsapi_revision Lib "gsdll32.dll" (ByVal pGSRevisionInfo As Long, ByVal intLen As Long) As Long
'此函数返回 GhostScript 解释器库包括版本号相关信息的字符串, 您应该在任何其他解释器库函数之前将其调用, 以确保已加载正确版本的 GhostScript 解释器
Private Declare Function gsapi_new_instance Lib "gsdll32.dll" (ByRef lngGSInstance As Long, ByVal lngCallerHandle As Long) As Long
'创建 Ghostscript 新的实例.此实例传递给大多数其他 gsapi 函数. lngCallerHandle 将提供给回调函数. 在这个阶段, Ghostscript 只支持一个实例.
Private Declare Function gsapi_set_stdio Lib "gsdll32.dll" (ByVal lngGSInstance As Long, ByVal gsdll_stdin As Long, ByVal gsdll_stdout As Long, ByVal gsdll_stderr As Long) As Long
'设置 stdio 的回调函数. 回调中使用的 handle 将取自传递给 gsapi_new_instance() 的值. 否则, 此函数的行为将与 gsapi_set_stdio_with_handle()匹配.
Private Declare Sub gsapi_delete_instance Lib "gsdll32.dll" (ByVal lngGSInstance As Long)
'销毁 GhostScript 的实例. 在您调用此之前, GhostScript 必须已经完成. 如果 GhostScript 已初始化, 则必须在 gsapi_delete_instance（）之前调用 gsapi_exit()
Private Declare Function gsapi_init_with_args Lib "gsdll32.dll" (ByVal lngGSInstance As Long, ByVal lngArgumentCount As Long, ByVal lngArguments As Long) As Long
'初始化解释器.这在 imainarg.c 中调用 gs_main_init_with_args().返回代码请参阅返回代码列表. 参数与 "C" 主函数相同: argv(0)将被忽略, 用户提供的参数是从 argv(1)至 argv(Ubound(argv)).
Private Declare Function gsapi_run_file Lib "gsdll32.dll" (ByVal lngGSInstance As Long, ByVal strFileName As String, ByVal intErrors As Long, ByVal intExitCode As Long) As Long
'gsapi_run_file 函数与 gs_main_run_file 类似，只是省略了 error_object. 如果此函数返回 <= -100, 则表示退出或发生致命错误. 接下来必须调用 gsapi_exit().
Private Declare Function gsapi_exit Lib "gsdll32.dll" (ByVal lngGSInstance As Long) As Long
'退出 GhostScript 解释器,如果已调用 gsapi_init_with_args（）,则必须在关闭时调用该命令, 并且在 gsapi_delete_instance（）之前调用

'------------------------------------------------
'API 调用开始结束
'------------------------------------------------

'------------------------------------------------
'回调函数开始
'------------------------------------------------
'只有使用 gsapi_set_stdio() 时才需要这些

Public Function gsdll_stdin(ByVal intGSInstanceHandle As Long, ByVal strz As Long, ByVal intBytes As Long) As Long
    'VBA 没有 console, 只需返回 EOF
    gsdll_stdin = 0
End Function

Public Function gsdll_stdout(ByVal intGSInstanceHandle As Long, ByVal strz As Long, ByVal intBytes As Long) As Long
    '如果你能想到更有效率的方法, 请告知.
    '我们需要从字节缓冲区转换为字符串
    '首先, 我们创建一个适当大小的字节数组
    Dim aByte() As Byte
    ReDim aByte(intBytes)
    '然后我们获取字节数组的地址
    Dim ptrByte As Long
    ptrByte = VarPtr(aByte(0))
    '然后我们字节将缓冲区复制到字节数组
    CopyMemory ptrByte, strz, intBytes
    '然后我们将字节数组逐个字符复制到字符串
    Dim str As String
    Dim i As Long
    For i = 0 To intBytes - 1
        str = str + Chr(aByte(i))
    Next
    '最后,我们输出信息
    gsdll_stdout = intBytes
End Function

Public Function gsdll_stderr(ByVal intGSInstanceHandle As Long, ByVal strz As Long, ByVal intBytes As Long) As Long
    gsdll_stderr = gsdll_stdout(intGSInstanceHandle, strz, intBytes)
End Function
'------------------------------------------------
'回调函数结束
'------------------------------------------------


'------------------------------------------------
'用户自定义函数开始
'------------------------------------------------
Public Function AnsiZtoString(ByVal strz As Long) As String
    '我们需要从字节缓冲区转换为字符串
    Dim byteCh(1) As Byte
    Dim bOK As Boolean
    bOK = True
    Dim ptrByte As Long
    ptrByte = VarPtr(byteCh(0))
    Dim j As Long
    j = 0
    Dim str As String
    While bOK
        '这就是指针算术的方法！
        CopyMemory ptrByte, strz + j, 1
        If byteCh(0) = 0 Then
            bOK = False
        Else
            str = str + Chr(byteCh(0))
        End If
        j = j + 1
    Wend
    AnsiZtoString = str
End Function

Public Function CallGS(ByRef astrGSArgs() As String) As Boolean
    Dim intReturn As Long
    Dim intGSInstanceHandle As Long
    Dim aAnsiArgs() As String
    Dim aPtrArgs() As Long
    Dim intCounter As Long
    Dim intElementCount As Long
    Dim iTemp As Long
    Dim callerHandle As Long
    Dim ptrArgs As Long

    ' 加载 Ghostscript 并获取实例的 handle
    intReturn = gsapi_new_instance(intGSInstanceHandle, callerHandle)
    If (intReturn < 0) Then
        CallGS = False
        Return
    End If

    '捕获 stdio
    intReturn = gsapi_set_stdio(intGSInstanceHandle, AddressOf gsdll_stdin, AddressOf gsdll_stdout, AddressOf gsdll_stderr)

    If (intReturn >= 0) Then
        '将 Unicode 字符串转换为以 null 结尾的 ANSI 字节数组
        '然后获取指向字节数组的指针.
        intElementCount = UBound(astrGSArgs)
        ReDim aAnsiArgs(intElementCount)
        ReDim aPtrArgs(intElementCount)
      
        For intCounter = 0 To intElementCount
            aAnsiArgs(intCounter) = StrConv(astrGSArgs(intCounter), vbFromUnicode)
            aPtrArgs(intCounter) = StrPtr(aAnsiArgs(intCounter))
        Next
        ptrArgs = VarPtr(aPtrArgs(0))
      
        intReturn = gsapi_init_with_args(intGSInstanceHandle, intElementCount + 1, ptrArgs)

        ' 停止 Ghostscript 解释器
        gsapi_exit (intGSInstanceHandle)
    End If

    ' 释放 Ghostscript 实例 handle
    gsapi_delete_instance (intGSInstanceHandle)

    If (intReturn >= 0) Then
        CallGS = True
    Else
        CallGS = False
    End If

End Function

Function getPdfPageNum(ByVal sPath As String) As Long '获取PDF文件的总页数
         Dim iFN As Integer, bPos As Long
         iFN = FreeFile
         Dim bFileSize As Long
         bFileSize = FileLen(sPath)
         Open sPath For Binary Access Read As iFN
         Dim arrResult() As Byte
         '读取字节流
         arrResult = InputB(bFileSize, iFN)
         Dim arrFind() As Byte
         '要查找的字节串,"/Count"为pdf总页数的特征字符标识
         arrFind = StrConv("/Count", vbFromUnicode)
         '设置查找的起始位置
         bPos = 0
         bPos = InStrB(bPos + 1, arrResult, arrFind, vbBinaryCompare)
         '设置个变量预装"/Count"之后的字符
         Dim sResult As String
         sResult = Space(1000)
         Get iFN, bPos + 6, sResult
         getPdfPageNum = Val(sResult)
         Close iFN
End Function

Private Function Pdf2Img(InputFile As String, OutputFile As String, Optional DPI As Long = 300) As Boolean
    Dim DeviceFormat As String, fp As Long, lp As Long, OFile As String, astrArgs(11) As String
    If LCase(Right(OutputFile, 3)) = "jpg" Then
       DeviceFormat = "jpeg"
    ElseIf LCase(Right(OutputFile, 3)) = "png" Then
       DeviceFormat = "png16m"
    ElseIf LCase(Right(OutputFile, 3)) = "bmp" Then
       DeviceFormat = "bmp16m"
    End If
    If getPdfPageNum(InputFile) > 1 Then
       fp = 1
       lp = getPdfPageNum(InputFile)
       OFile = Split(OutputFile, ".")(0) & "_%02d." & Split(OutputFile, ".")(1)  '页码01代表1位数,02代表2位数,依次类推.
    Else
       fp = 1
       lp = 1
       OFile = OutputFile
    End If
    astrArgs(0) = "pdf2img"                     '首个参数将被忽略
    astrArgs(1) = "-dNOPAUSE"                   '每一页转换之间没有停顿
    astrArgs(2) = "-dBATCH"                     '防止 gs 进入交互模式
    astrArgs(3) = "-dPARANOIDSAFER"             '在安全模式下运行此命令
    astrArgs(4) = "-sDEVICE=" & DeviceFormat    '转换输出的文件类型格式
    astrArgs(5) = "-r" & DPI                    '图像分辨率
    astrArgs(6) = "-dQUIET"                     '静默的意思,指代执行过程中尽可能少的输出日志等信息.（也可以简写为"-q"）
    astrArgs(7) = "-dNOPROMPT"                  '禁用用户交互提示
    astrArgs(8) = "-dFirstPage=" & fp           '从第几页开始
    astrArgs(9) = "-dLastPage=" & lp            '到第几页结束
    astrArgs(10) = "-sOutputFile=" & OFile      '输出文件路径,使用%d或%ld输出页数
    astrArgs(11) = InputFile                    '输入文件路径

    Pdf2Img = CallGS(astrArgs)                  '提交参数数组执行转换
End Function

'------------------------------------------------
'用户自定义函数结束
'------------------------------------------------

cyhwy

非常好，能改成64位也可以使用的吗

perfect131

getPdfPageNum不通用 有的PDF根本没有/count 还是用我的pq获取页数 通用不管有没有/Count

ycz22

perfect131 发表于 2024-10-13 10:04
getPdfPageNum不通用 有的PDF根本没有/count 还是用我的pq获取页数 通用不管有没有/Count

网上找的,谢谢反馈