Referencia de propiedades de documentos de Word integradas y personalizadas + VBA para enumerar nombres y valores

'*************** Code Start *****************************************************
' module name: mod_List_Word_DocProperties_s4p
'-------------------------------------------------------------------------------
' Purpose  : VBA to list:
'              BuiltInDocumentProperties
'                 and/or
'              CustomDocumentProperties
'            at the end of the ActiveDocument.
'            Choose to sort alphabetically or not
' Author   : crystal (strive4peace)
' Code List: www.msaccessgurus.com/code.htm
' This code: 
' LICENSE  :
'   You may freely use and share this code, but not sell it.
'   Keep attribution. Use at your own risk.
'-------------------------------------------------------------------------------
' NOTE: if you put this code into Normal.dotm,
'       it will be available for any document
'~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
'           List_WordDocumentProperties_s4p
'~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
Sub List_WordDocumentProperties_s4p() 
'220614 s4p, 220710 ... 220831, 230612, 17
   ' CALLs
   '  DoTableBorders_s4p
   
   '-------------------------------------- CUSTOMIZE!
   Const bSORT As Boolean = True  'sort properties alphabetically
   Const sOPTIONS As String =  "BC" 'B=Built-in, C=Custom
'   Const sOPTIONS As String = "C" 'C=Custom
   '--------------------------------------
   
   '----- dimension object variables
   Dim oDoc As Word.Document 
   Dim oRange As Range 
   Dim oTable As Word.Table 
   
   Dim oDocProp As DocumentProperty _ 
      ,oContainer As DocumentProperties 
   
   '----- dimension scalar variables
   Dim iBC As Integer 
   
   Dim sContainerName As String _ 
      ,sTypeContainer As String _ 
      ,sBuiltinCustom As String _ 
      ,sProperty As String 
      
   Dim nRows As Long _ 
      ,nCols As Long _ 
      ,nRow As Long 
      
   Dim vMessage As Variant  '230612
   
   'important Built-in properties that can be displayed
   'in columns of Windows File Explorer will be bold
   Dim asBold(1 To 2) As String  '230612
   asBold(1) =  "~Title~Author~Company~Comments~Subject~"
   asBold(2) =  ""
         
   '----- set oDoc to ActiveDocument
   Set oDoc = Word.ActiveDocument 

   '----- write information
   'insert new line at end of current document
   'write Document Properties as Heading 2
   With oDoc.Content 
      'collapse to end of document
      .Collapse Direction:=0  'wdCollapseEnd

      'blank line
      .InsertParagraphAfter 
      
      .InsertAfter  "Document Properties " _ 
         & IIf(bSORT, "(sorted)", "") &  ": " _ 
         & Format(Now(), "yymmdd hh:nn ") _ 
         & oDoc.Name 
      'style as Heading 2
      oDoc.Paragraphs(oDoc.Paragraphs.Count).Style _ 
            = oDoc.Styles( "Heading 2") 
      .InsertParagraphAfter 
      
      .InsertAfter  "file: " & oDoc.FullName 

      .InsertParagraphAfter 
            
   End With  'oDoc.Content
   
   'skip errors in case a property doesn't have a value
   On Error Resume Next 
   
   'iterate DocumentProperties
   ' Built-in (1) and Custom (2)
   For iBC = 1 To 2 
      With oDoc 

         If iBC = 1 Then 
            If Not InStr(sOPTIONS, "B") > 0 Then 
               GoTo Next_Option 
            End If 
            sTypeContainer =  "B" 'built-in
            sBuiltinCustom =  "Built-in"
            Set oContainer = .BuiltInDocumentProperties 
            sContainerName =  "BuiltInDocumentProperties"
         Else  '2
            If Not InStr(sOPTIONS, "C") > 0 Then 
               Exit For 
            End If 
            sTypeContainer =  "C" 'custom
            sBuiltinCustom =  "Custom"
            Set oContainer = .CustomDocumentProperties 
            sContainerName =  "CustomDocumentProperties"
         End If 
      
         'count properties
         nRows = oContainer.Count 
         
         With .Content 
            'collapse to end of document
            .Collapse Direction:=0  'wdCollapseEnd
            
            'blank line
            .InsertParagraphAfter 
            
            'Specify Built-in or Custom
            .InsertAfter sContainerName 
            If bSORT Then 
               .InsertAfter  "      (sorted alphabetically)"
            End If 
            'style as Heading 3
            oDoc.Paragraphs(oDoc.Paragraphs.Count).Style _ 
                  = oDoc.Styles( "Heading 3") 
            .InsertParagraphAfter 
            
         End With  'oDoc.Content
                 
         'range for table, put at end
         Set oRange = .Content 
         oRange.Collapse Direction:=0  'wdCollapseEnd
         
         'insert table
         nCols = 3  'number of columns
         'NumRows: number of properties + 1 for header row
         Set oTable = .Tables.Add( _ 
            Range:=oRange _ 
            ,NumRows:=nRows + 1 _ 
            ,NumColumns:=nCols _ 
            ) 
      End With  'oDoc
  
      'customize and write table
      With oTable 
      
         'dont allow rows to break
         .Rows.AllowBreakAcrossPages = False 
         
         'Vertical Alignment for each cell is Top
         ' 0=wdCellAlignVerticalTop
         .Range.Cells.VerticalAlignment = 0 
         
         'heading row
         .Rows(1).HeadingFormat = True 
         .Cell(1,1).Range.Text = sBuiltinCustom &  " Document Property Name"
         .Cell(1,2).Range.Text =  "DataType"
         .Cell(1,3).Range.Text =  "Value"
         
         nRow = 1  'header row just written
         
         'loop through properties and write values
         For Each oDocProp In oContainer 
            sProperty = oDocProp.Name 
            nRow = nRow + 1  'go to next row
            .Cell(nRow,1).Range.Text = sProperty 
            
            '230612
            If InStr(asBold(iBC), "~" & sProperty &  "~") Then 
               'bold the text in the cell
               .Cell(nRow,1).Range.Font.Bold = True 
            End If 
            
            .Cell(nRow,2).Range.Text = TypeName(oDocProp.Value) 
            .Cell(nRow,3).Range.Text = oDocProp.Value 
         Next oDocProp 

         'best-fit columns
         .Columns.AutoFit 
         
         'format
         With .Range.ParagraphFormat 
            .SpaceAfter = 0 
            .SpaceBefore = 0 
            .LineSpacing = 0  ' wdLineSpaceSingle
         End With  'ParagraphFormat
   
         If bSORT Then 
            'sort table by property name for Custom
            ' leave Built-in properties sorted logically
'            If iBC = 2 Then
               .Sort ExcludeHeader:=True _ 
                  ,FieldNumber:=1 
'            End If
         End If 
         
      End With  'oTable
         
      'add table borders
      Call DoTableBorders_s4p(oTable) 
               
      With oDoc.Content 
         'go to end of document
         .MoveEnd unit:=wdStory 
      
'         'add blank line before count
'         .InsertParagraphAfter
         
         'write how many properties were found
         .InsertAfter  "** " _ 
            & Format(nRows, "0;;\n\o\n\e") _ 
               &  " " & sBuiltinCustom _ 
               &  " Document Properties listed"
            
      End With  'oDoc.Content
Next_Option: 
      
   Next iBC  'next Built-in or Custom list
   
   vMessage = Null 
   If InStr(sOPTIONS, "B") > 0 Then 
      vMessage =  "Built-in "
   End If 
   If InStr(sOPTIONS, "C") > 0 Then 
      vMessage = (vMessage +  "and ") &  "Custom "
   End If 
   vMessage =  "Done enumerating " & vMessage _ 
      &  "Document Properties"
   
   MsgBox vMessage,, "done"
   
Proc_exit: 
   'release object variables
   Set oDocProp = Nothing 
   Set oContainer = Nothing 
   Set oTable = Nothing 
   Set oRange = Nothing 
   Set oDoc = Nothing 
   
End Sub 
'~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
'           DoTableBorders_s4p_s4p
'~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
Public Sub DoTableBorders_s4p(oTable As Object)   'Word.Table
's4p 170811
   Dim i As Integer 
   With oTable 
      For i = 1 To 6 
         'wdBorderTop =-1
         'wdBorderLeft = -2
         'wdBorderBottom =-3
         'wdBorderRight= -4
         'wdBorderHorizontal = -5
         'wdBorderVertical = -6
         With .Borders(-i) 
            .LineStyle = 1   'wdLineStyleSingle=1
            .LineWidth = 8  'wdLineWidth100pt=8. wdLineWidth150pt=12
            .Color = RGB(200,200,200)  'medium-light gray
         End With 
      Next i 
   End With 
   'change borders to black for first row
   With oTable.Rows(1) 
      For i = 1 To 4 
         With .Borders(-i) 
            .Color = 0       'wdColorBlack = 0
         End With 
      Next i 
      'Shading for header row
      .Shading.BackgroundPatternColor = RGB(232,232,232) 
   End With  'first row
   'Not used:
'      'wdLineStyleNone = 0
'      .Borders(-7).LineStyle = 0 'wdBorderDiagonalDown =-7
'      .Borders(-8).LineStyle = 0 'wdBorderDiagonalUp =-8
End Sub 
'*************** Code End *******************************************************