通过VBA从Excel生成FDF/XFDF文件或为PDF添加批注

我希望编写一个VBA宏，实现两个功能之一：要么直接调用Excel中创建的批注给PDF文件添加批注，要么生成FDF/XFDF文件以将批注导入PDF报告。目前尝试通过Acrobat相关代码创建批注时遇到问题：已安装Acrobat Exchange，但仅能打开软件，无法打开目标PDF文件。附上现有代码，恳请提供技术帮助。

Sub Import_Commment
Function text_annotation(FileName, path, Proj_No, Dept_no, New_tag, sizex, sizey)
    Dim pdDoc As Object
    Dim app As Object
    Dim jso As Object
    Dim point(2) As Integer
    Dim popupRect(3) As Integer
    Dim rect(3) As Integer
    Dim pageRect As Object
    Dim annot As Object
    Dim props As Object
    Dim text As Object

    Set pdDoc = Nothing
    Set app = CreateObject("AcroExch.App")
    Set pdDoc = CreateObject("AcroExch.PDDoc")

    FileName = Range("Q2").Value & ".pdf"
          folder = Replace(Range("Q2").Value, "/", "\")
          path = Environ("HomeDrive") & Environ("HomePath") & "\OneDrive - NAME\" & folder & "\"
    fullpath = path & FileName
    pdDoc.Open (fullpath)
    Set jso = pdDoc.GetJSObject

    If Not jso Is Nothing Then
        Set page = pdDoc.AcquirePage(0)
        Set pageRect = page.GetSize
        Set annot = jso.AddAnnot

        ' Set annotation properties
        Set props = annot.getprops
        props.page = 0
        props.Name = "Entry_Stamp"
        props.Type = "FreeText"
        props.rect = popupRect
        props.Author = "user"
        props.Width = 1#
        props.strokeColor = jso.color.blue
        props.contents = "text mesg"

        ' Modify font properties (adjust as needed)
        props.textSize = 24
        ' props.textcolor = jso.color.red
        ' props.textFont = "Font.Helv"

        annot.setProps props
    End If
End Function
End Sub

核心问题点 #

• 路径与文件打开问题：OneDrive路径可能存在同步延迟或权限问题，且函数参数FileName被重复赋值，路径拼接逻辑易出错；未检查pdDoc.Open是否成功，无法定位文件打不开的原因。
• 批注参数错误：popupRect未初始化，FreeText批注需要明确的位置和大小（rect数组需包含[左, 下, 右, 上]四个坐标）。
• 对象管理缺失：未保存修改后的PDF，也未释放Acrobat对象，易导致进程残留。
• 函数逻辑冗余：text_annotation的多个参数未使用，且主过程Import_Commment未调用该函数。

修正后的代码 #

Sub AddPDFAnnotationsFromExcel()
    Dim pdDoc As Object
    Dim app As Object
    Dim jso As Object
    Dim page As Object
    Dim pageRect As Object
    Dim annot As Object
    Dim props As Object
    Dim fullPath As String
    Dim pdfName As String
    Dim folderPath As String
    Dim excelCommentText As String
    Dim rect(3) As Double ' 存储批注位置：[左, 下, 右, 上]

    ' 获取Excel中的批注内容（示例取A1单元格批注）
    If Not Range("A1").Comment Is Nothing Then
        excelCommentText = Range("A1").Comment.Text
    Else
        excelCommentText = "默认批注内容"
    End If

    ' 构建PDF路径
    pdfName = Range("Q2").Value & ".pdf"
    folderPath = Replace(Range("Q2").Value, "/", "\")
    fullPath = Environ("HomeDrive") & Environ("HomePath") & "\OneDrive - NAME\" & folderPath & "\" & pdfName

    ' 初始化Acrobat对象
    Set app = CreateObject("AcroExch.App")
    Set pdDoc = CreateObject("AcroExch.PDDoc")

    ' 检查文件是否存在并尝试打开
    If Dir(fullPath) = "" Then
        MsgBox "目标PDF文件不存在：" & fullPath, vbCritical
        GoTo Cleanup
    End If

    If Not pdDoc.Open(fullPath) Then
        MsgBox "无法打开PDF文件，请检查路径权限或Acrobat版本", vbCritical
        GoTo Cleanup
    End If

    Set jso = pdDoc.GetJSObject
    If jso Is Nothing Then
        MsgBox "无法获取JS对象，请确保安装了Acrobat Pro（而非Reader）", vbCritical
        GoTo Cleanup
    End If

    ' 获取第一页尺寸，设置批注位置（示例：页面右下角，宽300高100）
    Set page = pdDoc.AcquirePage(0)
    Set pageRect = page.GetSize
    rect(0) = pageRect(0) - 320 ' 左
    rect(1) = pageRect(1) + 20  ' 下
    rect(2) = pageRect(0) - 20  ' 右
    rect(3) = pageRect(1) + 120 ' 上

    ' 创建FreeText批注
    Set annot = jso.AddAnnot
    Set props = annot.getprops
    With props
        .page = 0
        .Name = "Excel_Comment"
        .Type = "FreeText"
        .rect = rect
        .Author = Application.UserName ' 获取当前Excel用户名
        .strokeColor = jso.color.blue
        .contents = excelCommentText
        .textSize = 12
        .fillColor = jso.color.yellow ' 设置批注背景色
    End With
    annot.setProps props

    ' 保存修改后的PDF（可改为另存为：pdDoc.Save 1, fullPath & "_annotated.pdf"）
    If Not pdDoc.Save(1, fullPath) Then
        MsgBox "保存PDF失败", vbCritical
    End If

Cleanup:
    ' 释放对象
    If Not pdDoc Is Nothing Then pdDoc.Close
    If Not app Is Nothing Then app.Exit
    Set pdDoc = Nothing
    Set app = Nothing
    Set jso = Nothing
End Sub

额外说明 #

1. Acrobat版本要求：必须安装Acrobat Pro（Reader无API权限），且确保启用了Acrobat COM组件。
2. OneDrive路径优化：若仍无法打开文件，可尝试将PDF复制到本地非OneDrive目录测试，排除同步或权限问题。
3. FDF/XFDF生成替代方案：若直接操作PDF仍有问题，可生成XFDF文件后导入，示例逻辑：
   • 构建包含批注信息的XFDF XML结构
   • 将XML保存为.xfdf文件
   • 通过Acrobat的ImportAnnosFromXFDF方法导入

内容的提问来源于stack exchange，提问作者Claudinha Scragg