vba 在 Word 中更改自定义文档属性

Change a custom document property within Word

提问by David Gard

I'm trying to change the properties of a document before I save it, but none of my properties below are being added.

我试图在保存文档之前更改它的属性，但没有添加下面的任何属性。

How can I fix this problem? Thanks.

我该如何解决这个问题？谢谢。

'**
 ' Set the required properties for this document
 '*
Function SetProperties(ByVal DocumentName As String, _
                          ByRef tempDoc As Document) As Boolean

    Call UpdateCustomDocumentProperty(tempDoc, "Title", DocumentName & ".pdf", 4)
    Call UpdateCustomDocumentProperty(tempDoc, "Subject", "New Starter Guides", 4)
    Call UpdateCustomDocumentProperty(tempDoc, "Keywords", "new starters, guide, help", 4)

    SetProperties = True

End Function

'**
 ' Update a single custom value
 '*
Function UpdateCustomDocumentProperty(ByRef doc As Document, _
                                      ByVal propertyName As String, _
                                      ByVal propertyValue As Variant, _
                                      ByVal propertyType As Office.MsoDocProperties)

    On Error Resume Next
    doc.CustomDocumentProperties(propertyName).value = propertyValue
    If Err.Number > 0 Then
        doc.CustomDocumentProperties.Add _
            Name:=propertyName, _
            LinkToContent:=False, _
            Type:=propertyType, _
            value:=propertyValue
    End If

    UpdateCustomDocumentProperty = True

End Function

回答by David Zemens

I don't see anything obvious but I don't like your On Error Resume Next. It's almost always better to trap that error, and you can do that with a function that checks whether a property exists, rather than trying to assign to a non-existent property and handle the err.Number.

我没有看到任何明显的东西，但我不喜欢你的On Error Resume Next. 捕获该错误几乎总是更好，您可以使用检查属性是否存在的函数来做到这一点，而不是尝试分配给不存在的属性并处理err.Number.

I have also modified both of your functions so that they returna value to the calling procedure and therefore can be used in boolean statements to evaluate whether the properties were assigned without error. Your previous functions were always returning Truefor some reason...

我还修改了您的两个函数，以便它们向调用过程返回一个值，因此可以在布尔语句中用于评估属性是否正确分配。您以前的功能总是True出于某种原因返回......

This seems to work for me and persists beyond save/close of the document.

这似乎对我有用，并且在保存/关闭文档后仍然存在。

Option Explicit
Sub setProps()
    'I use this to invoke the functions and save the document.

    If Not SetProperties("Another!", ThisDocument) Then
        MsgBox "Unable to set 1 or more of the Custom Document Properties.", vbInformation
        GoTo EarlyExit
    End If

    'Only save if there was not an error setting these
    ThisDocument.Save


    Debug.Print ThisDocument.CustomDocumentProperties(1)
    Debug.Print ThisDocument.CustomDocumentProperties(2)
    Debug.Print ThisDocument.CustomDocumentProperties(3)

EarlyExit:

End Sub


Function SetProperties(ByVal DocumentName As String, _
                          ByRef tempDoc As Document) As Boolean
'**
 ' Set the required properties for this document
 '*
    Dim ret As Boolean

    If UpdateCustomDocumentProperty(tempDoc, "Title", DocumentName & ".pdf", 4) Then
        If UpdateCustomDocumentProperty(tempDoc, "Subject", "New Starter Guides", 4) Then
            If UpdateCustomDocumentProperty(tempDoc, "Keywords", "new starters, guide, help", 4) Then
                ret = True
            End If
        Else
            ret = False
        End If
    Else
        ret = False
    End If

    SetProperties = ret


End Function


Function UpdateCustomDocumentProperty(ByRef doc As Document, _
                                      ByVal propertyName As String, _
                                      ByVal propertyValue As Variant, _
                                      ByVal propertyType As Office.MsoDocProperties)
'**
 ' Update a single custom value
 '*
    Dim ret As Boolean
    ret = False

    If PropertyExists(doc, propertyName) Then
        doc.CustomDocumentProperties(propertyName).Value = propertyValue
    Else:
        doc.CustomDocumentProperties.Add _
            name:=propertyName, _
            LinkToContent:=False, _
            Type:=propertyType, _
            Value:=propertyValue
    End If

    On Error Resume Next
    ret = (doc.CustomDocumentProperties(propertyName).Value = propertyValue)
    On Error GoTo 0

    UpdateCustomDocumentProperty = ret
End Function

Function PropertyExists(doc As Document, name As String)
'Checks whether a property exists by name
Dim i, cdp

For i = 1 To doc.CustomDocumentProperties.Count
    If doc.CustomDocumentProperties(i).name = name Then
        PropertyExists = True
        Exit Function
    End If
Next

End Function

回答by Tahtu

For me, this solution works fine:

对我来说，这个解决方案工作正常：

Private Sub SetCustomDocumentProperty(Name_ As String, LinkToContent, Type_, Value)
  For Each Prop In ActiveDocument.CustomDocumentProperties
    If Prop.Name = Name_ Then
      ActiveDocument.CustomDocumentProperties(Name).Value = Value
      Exit Sub
    End If
  Next

  ActiveDocument.CustomDocumentProperties.Add _
    Name:=Name_, LinkToContent:=LinkToContent, Type:=Type_, Value:=Value
End Sub

回答by Starnes Student

It is working. The problem is simply that you have to finish saving the document before it will take place.

这是工作。问题很简单，您必须在保存文档之前完成它。