通过 SharePoint 中的 VBA 自定义文档属性添加 MS Word

Question

我最近发现自己无法在 Word 中添加控制内容对象，这些对象链接到链接到 SharePoint 库的文档属性，这些属性在 SharePoint 库中创建新列时会公开。

我发布了我最初的问题：MS Word adding Custom Document Properties (from SharePoint) as a ContentControl via VBA。不幸的是，我不能在那里发布我的解决方案，因为有些人认为我的问题不完整。

幸运的是，一位用户 (@slightlysnarky) 发布了一个解决方案来解决我的部分问题 How can I replicate programmatically in VBS what Word does when I insert a "built-in" property from the Insert->QuickPart->Document Property dropdown?。

Answer 1

以下是我将内容控件链接到从 SharePoint 库继承的文档属性的方法（为用户定义的列提供了一个示例）。

从@slightlysnarky 提供的解决方案中，我不清楚如何找到文档属性的.XMLMapping.SetMapping 路径。

为了找到这些信息，我做了以下工作：

1. 在我的 SharePoint 库中创建一个 MS Word 文件（包含一些用户列）
2. 在word文件中手动插入控件内容（见原问题）
3. 保存文件
4. 将 word 文件扩展名更改为 .zip
5. 提取 [documentName.docx.zip]\word\document.xml 包含在存档中的文档
6. 用我最喜欢的 XML 编辑器打开文件
7. 然后您可以在以下元素\属性中找到文档的一般路径：<w:dataBinding w:prefixMappings="[rootOfProperties]" w:xpath="[pathToProperties]" ....>
   • 就我而言，我有：w:prefixMappings=""xmlns:ns0='http://schemas.microsoft.com/office/2006/metadata/properties' xmlns:ns1='http://www.w3.org/2001/XMLSchema-instance' xmlns:ns2='http://schemas.microsoft.com/office/infopath/2007/PartnerControls' xmlns:ns3='856dd977-5561-4031-9d6b-b2809bca48df'"
   • w:prefixMappings 属性对于所有属性都是相同的。它可能会因不同的库而改变（待验证）
   • w:xpath 属性对于每个属性都不同，并且与我可以找到文档“XML 地图”的信息相匹配（请参阅原始问题的屏幕截图）。
   • 我也意识到，不幸的是，一旦在 SharePoint 中创建列，无论名称是否在 SharePoint 中更改，XML 映射中的名称都不会更改，这是可以预料的。因此，您可以在下面的代码中看到，在某些情况下，映射与最终 SharePoint 中所需的给定名称不同的属性。 经验教训是，最好在创建库列之前仔细考虑命名约定。
8. 有了这些信息，我将@slightlysnarky 提供的代码修改为我的普通模板中的 VBA 宏，一切正常。

为了帮助他人，这是我改编自@slightlysnarky 的代码。请注意，您需要根据您的库设置进行调整，如上所述。 * 更改为：Sub setSharepointProps() * 您需要更改：sharePointPropsMappings=[rootOfProperties] 和 .XMLMapping.SetMapping [pathToProperties] 从 document.xml 中提取（见上文）

' a simple test -  place inside the normal .dotm file VBA content
' or wherever you want the code to reside.
' for a quick test run the test() sub. It will instert a mapped control
' content in your document

Sub insertAndMapProperty(Location, PropertyName) ' As Word.Range, As String
' Location is a Word Range where you want to insert the Content Control
'
' pass the name of the element (since it does not change when you change the user interface language)

    Dim response As Integer
    
    Select Case LCase(Trim(PropertyName))
    Case "abstract"
        setCoverPageProps Location, "Abstract", "Abstract", wdContentControlText
    Case "category"
        setMSCoreProps Location, "category", "Category", wdContentControlText
    Case "company"
        setExtendedProps Location, "Company", "Company", wdContentControlText
    Case "contentstatus"
        setMSCoreProps Location, "contentStatus", "Status", wdContentControlText
    Case "creator"
        setDCoreProps Location, "creator", "Author", wdContentControlText
    Case "companyaddress"
        setCoverPageProps Location, "CompanyAddress", "Company Address", wdContentControlText
    Case "companyemail"
        setCoverPageProps Location, "CompanyEmail", "Company E-mail", wdContentControlText
    Case "companyfax"
        setCoverPageProps Location, "CompanyFax", "Company Fax", wdContentControlText
    Case "companyphone"
        setCoverPageProps Location, "CompanyPhone", "Company Phone", wdContentControlText
    Case "description"
        setDCoreProps Location, "description", "Comments", wdContentControlText
    Case "keywords"
        setMSCoreProps Location, "keywords", "Keywords", wdContentControlText
    Case "manager"
        setExtendedProps Location, "Manager", "Manager", wdContentControlText
    Case "publishdate"
        setCoverPageProps Location, "PublishDate", "Publish Date", wdContentControlDate
    Case "subject"
        setDCoreProps Location, "subject", "Subject", wdContentControlText
    Case "title"
        setDCoreProps Location, "title", "Title", wdContentControlText
    Case "pbp-projectcode"
        setSharepointProps Location, "ProjectName", "PBP-ProjectCode", wdContentControlComboBox
    Case "ectd-title"
        setSharepointProps Location, "eCTD_x002d_Title", "eCTD-Title", wdContentControlComboBox
    Case "ectd-regulator"
        setSharepointProps Location, "Regulator", "eCTD-Regulator", wdContentControlComboBox
    Case "ectd-subtype"
        setSharepointProps Location, "SubmissionType", "eCTD-SubType", wdContentControlComboBox
    Case "ectd-subseq"
        setSharepointProps Location, "eCTD_x002d_SubmissionSequence", "eCTD-SubSeq", wdContentControlComboBox
    Case "ectd-modulelabel"
        setSharepointProps Location, "eCTD_x002d_ModuleName", "eCTD-ModuleLabel", wdContentControlComboBox
    Case "ectd-sectionlabel"
        setSharepointProps Location, "SectionTitle", "eCTD-SectionLabel", wdContentControlComboBox
    Case "ectd-subsectionindex"
        setSharepointProps Location, "eCTD_x002d_SubSection_x0023_", "eCTD-SubSectionIndex", wdContentControlComboBox
    Case "ectd-subsectionlabel"
        setSharepointProps Location, "e_x002d_CTD_x002d_SubsectionLabel", "eCTD-SubsectionLabel", wdContentControlComboBox
    Case Else
        response = MsgBox("Unrecognized property name: " & PropertyName, _
                vbCritical, "Insert Document Properties")
    End Select

End Sub

Sub setCoverPageProps(Location, PropertyName, TitlePlaceHolder, ContentType)
    'Const missing = Nothing
    Const coverPageMappings = "xmlns:ns0='http://schemas.microsoft.com/office/2006/coverPageProps'"
    With Location.ContentControls.Add(ContentType)
      .Title = TitlePlaceHolder
      .XMLMapping.SetMapping "/ns0:CoverPageProperties[1]/ns0:" & PropertyName & "[1]", coverPageMappings, Nothing
      .SetPlaceholderText missing, missing, "[" & TitlePlaceHolder & "]"
      .range.Select
    End With
End Sub

Sub setSharepointProps(Location, PropertyName, TitlePlaceHolder, ContentType)
    'Const missing = Nothing
    'THis is the property corresponding to: w:prefixMappings
    Const sharePointPropsMappings = "xmlns:ns0='http://schemas.microsoft.com/office/2006/metadata/properties' xmlns:ns1='http://www.w3.org/2001/XMLSchema-instance' xmlns:ns2='http://schemas.microsoft.com/office/infopath/2007/PartnerControls' xmlns:ns3='856dd977-5561-4031-9d6b-b2809bca48df'"
    With Location.ContentControls.Add(ContentType)
      .Title = TitlePlaceHolder

      'This part is extracted from w:xpath=
      .XMLMapping.SetMapping "/ns0:properties[1]/documentManagement[1]/ns3:" & PropertyName & "[1]", sharePointPropsMappings, Nothing
      .SetPlaceholderText Nothing, Nothing, "[" & TitlePlaceHolder & "]"
      .range.Select
    End With
End Sub

Sub setDCoreProps(Location, PropertyName, TitlePlaceHolder, ContentType)
    'Const missing = Nothing
    Const DCoreMappings = "xmlns:ns0='http://purl.org/dc/elements/1.1/' xmlns:ns1='http://schemas.openxmlformats.org/package/2006/metadata/core-properties'"
    With Location.ContentControls.Add(ContentType)
      .Title = TitlePlaceHolder
      .XMLMapping.SetMapping "/ns1:coreProperties[1]/ns0:" & PropertyName & "[1]", DCoreMappings, Nothing
      .SetPlaceholderText Nothing, Nothing, "[" & TitlePlaceHolder & "]"
      .range.Select
    End With
End Sub

Sub setMSCoreProps(Location, PropertyName, TitlePlaceHolder, ContentType)
    'Const missing = Nothing
    Const MSCoreMappings = "xmlns:ns0='http://schemas.openxmlformats.org/package/2006/metadata/core-properties'"
    With Location.ContentControls.Add(ContentType)
      .Title = TitlePlaceHolder
      .XMLMapping.SetMapping "/ns0:coreProperties[1]/ns0:" & PropertyName & "[1]", MSCoreMappings, Nothing
      .SetPlaceholderText Nothing, Nothing, "[" & TitlePlaceHolder & "]"
      .range.Select
    End With
End Sub

Sub setExtendedProps(Location, PropertyName, TitlePlaceHolder, ContentType)
    'Const missing = Nothing
    Const extendedMappings = "xmlns:ns0='http://schemas.openxmlformats.org/officeDocument/2006/extended-properties'"
    With Location.ContentControls.Add(ContentType)
      .Title = TitlePlaceHolder
      .XMLMapping.SetMapping "/ns0:Properties[1]/ns0:" & PropertyName & "[1]", extendedMappings, Nothing
      .SetPlaceholderText Nothing, Nothing, "[" & TitlePlaceHolder & "]"
      .range.Select
    End With
End Sub

Sub test()
    insertAndMapProperty Selection, "eCTD-ModuleLabel"
End Sub