word导入导出自定义属性列表

Sub ExportCustom()
‘
‘ ExportCustom 宏
‘ 导出自定义属性到custom.txt
‘
    Dim lFileNumber As Long
    Dim sFilePath As String
    Dim current As Object
    Set current = ActiveDocument
    sFilePath = current.Path + "\Custom.txt"
    lFileNumber = FreeFile()
    Open sFilePath For Output As #lFileNumber
    Dim i As Integer
    For Each objProp In current.CustomDocumentProperties
        Dim bRegular As Boolean
        bRegular = True
        If objProp.Name = "ProprietaryDeclaration" Then
            bRegular = False
        End If
        If objProp.Name = "slevel" Then
            bRegular = False
        End If
        If objProp.Name = "slevelui" Then
            bRegular = False
        End If
        If objProp.Name = "sflag" Then
            bRegular = False
        End If
        If bRegular Then
            Print #lFileNumber, objProp.Name & vbTab & objProp.Value
        End If
    Next

    Close #lFileNumber
    MsgBox "导出完毕！"
End Sub
Sub UpdateCustom()
‘
‘ UpdateCustom 宏
‘
‘
    Dim strUpdateContent As String
    Dim strNotFoundProperty  As String

    Dim current As Object
    Set current = ActiveDocument
    Dim lFileNumber As Long
    lFileNumber = FreeFile()
    Open current.Path + "\Custom.txt" For Input As #lFileNumber ‘ 打开文件。
    Dim TextLine As String
    Dim tmpObj As Object
    Dim iTabIndex As Integer
    Do While Not EOF(lFileNumber) ‘ 循环至文件尾。
        Line Input #lFileNumber, TextLine ‘ 读入一行数据并将其赋予某变量。

        If Not (TextLine = "") Then

            iTabIndex = InStr(TextLine, vbTab)
            If Not (iTabIndex = 0 Or iTabIndex = 1 Or iTabIndex = Len(TextLine)) Then

                Dim strName As String
                Dim strValue As String

                strName = Mid(TextLine, 1, iTabIndex - 1)
                Debug.Print strName ‘ 在调试窗口中显示数据。
                strValue = Mid(TextLine, iTabIndex + 1)
                Debug.Print strValue ‘ 在调试窗口中显示数据。

                On Error Resume Next
                Set tmpObj = Nothing
                Set tmpObj = current.CustomDocumentProperties(strName)
                On Error GoTo 0
                If Not (tmpObj Is Nothing) Then
                    If (tmpObj.Type = msoPropertyTypeString And (Not (tmpObj.Value = strValue))) Then
                        strUpdateContent = strUpdateContent & vbCrLf & tmpObj.Name & vbTab & tmpObj.Value & "==>>" & strValue
                        tmpObj.Value = strValue
                    End If
                Else
                    strNotFoundProperty = strNotFoundProperty & vbCrLf & strName
                End If
            End If

        End If

    Loop

    Dim strMsg As String
    If Not (strUpdateContent = "") Then
        strMsg = strMsg & "Update content:" & strUpdateContent
    End If

    If Not (strNotFoundProperty = "") Then
        strMsg = strMsg & "Not found property:" & strNotFoundProperty
    End If

    If (strMsg = "") Then
        strMsg = "No Update"
    End If

    MsgBox strMsg

End Sub

Sub SortCustom()
‘
‘ SortCustom 宏
‘
‘
    Dim current As Object
    Set current = ActiveDocument
    sFilePath = current.Path + "\Custom.txt"
    Dim propertys() As Object
    ‘Set propertys = current.CustomDocumentProperties
    Dim iPropLen As Integer
    iPropLen = current.CustomDocumentProperties.Count
    Dim i As Integer
    Dim iTmpPropLen As Integer
    iTmpPropLen = iPropLen
    Dim bFlag As Boolean
    bFlag = True
    Do While bFlag And iTmpPropLen > 1
        bFlag = False
        For i = 1 To (iTmpPropLen - 1)
            If current.CustomDocumentProperties(i).Name > current.CustomDocumentProperties(i + 1).Name Then
                bFlag = True

                Dim tmpProp1 As Object
                Set tmpProp1 = current.CustomDocumentProperties(i)
                Dim tmpProp2 As Object
                Set tmpProp2 = current.CustomDocumentProperties(i + 1)

                Dim tmpPropName As String
                Dim tmpPropType As Integer
                Dim tmpPropLinkToContent As Boolean
                Dim tmpPropValue As String
                tmpPropName = tmpProp1.Name
                tmpPropType = tmpProp1.Type
                tmpPropLinkToContent = tmpProp1.LinkToContent
                tmpPropValue = tmpProp1.Value
                tmpProp1.Name = "tmp"
                tmpProp1.Type = msoPropertyTypeString
                tmpProp1.LinkToContent = False
                tmpProp1.Value = "tmp"

                Dim tmpPropName2 As String
                Dim tmpPropType2 As Integer
                Dim tmpPropLinkToContent2 As Boolean
                Dim tmpPropValue2 As String
                tmpPropName2 = tmpProp2.Name
                tmpPropType2 = tmpProp2.Type
                tmpPropLinkToContent2 = tmpProp2.LinkToContent
                tmpPropValue2 = tmpProp2.Value
                tmpProp2.Name = tmpPropName
                tmpProp2.Type = tmpPropType
                tmpProp2.LinkToContent = tmpPropLinkToContent
                tmpProp2.Value = tmpPropValue

                tmpProp1.Name = tmpPropName2
                tmpProp1.Type = tmpPropType2
                tmpProp1.LinkToContent = tmpPropLinkToContent2
                tmpProp1.Value = tmpPropValue2
            End If
        Next
        iTmpPropLen = iTmpPropLen - 1
    Loop

    MsgBox "排序完毕！"
End Sub