Word Security Risk? Find Hidden Fields!

When you Share or modify Word files - you can get OTHER PEOPLE's  names, IDs and personal information!  WORSE yet, you can GIVE others your own personal or proprietary info! How to Find these fields?  How to replace or purge them?

The macro at bottom of this page performs a checkup of common fields.

The top of the page shows you screenshots of how to find these fields in WinWord (Word for Windows®) via (a) shortcut "Alt-I-F" (b) Menu Tab "Insert" and (c) Macro Message box

(a) shortcut Alt-I-F
(a) shortcut Alt-I-F
(b) Menu Tab ''Insert''
(b) Menu Tab ''Insert''
c) Macro WordDocProperties Message box
c) Macro WordDocProperties Message box

Sub WordDocProperties()
Dim strTemp, strProp, strNameList As String
Dim thisRange   'strNameList used to bypass error thrown by at least one of the named properties
strNameList = "title,subject,author,last author,company,manager,Last Save time,Creation Date,Comments,Total Editing Time" 
'short list for demo. See menu [screenshot (b) above] in Word® for full list
xyz = Split(strNameList, ",")
Set thisRange = ActiveDocument.Content
 thisRange.Collapse Direction:=wdCollapseEnd ' wdCollapseStart is default per https://msdn.microsoft.com/en-us/library/office/ff840825(v=office.15).aspx
For Each Prop In ActiveDocument.BuiltInDocumentProperties '.CustomDocumentProperties BuiltInDocumentProperties
  With thisRange
    On Error Resume Next
    strProp = Prop.Name 'here, at least one property throws an error not trapped by 'on error'
    If Err.Number Then strProp = " n/a " ' this never happens: see above
' strTemp = strTemp & vbCrLf & Prop.Name 'for deriving full namelist
    If IsNumeric(findElementinArray(Prop.Name, xyz)) Then strTemp = strTemp & vbCrLf & Prop.Name & " = " & Prop.Value
    On Error GoTo 0
 End With
 MsgBox strTemp, , "Sub WordDocProperties"
End Sub
Function findElementinArray(someString, someArray) 'returns index of found item, else "" if not found
Dim kounter, i, j, k As Integer
findElementinArray = ""
    For k = LBound(someArray) To UBound(someArray)
        If UCase(someString) = UCase(someArray(k)) Then
            findElementinArray = k
            Exit For
        End If
    Next k
End Function

A macro to Purge or SetWordDocProperties will be available 2017-April-02 in the "Office Macro Package"

Print Unique Footer Header with Tabs

Problem:  You've been given  20 minutes to update 3 tabs of a 25 Tab *MONSTER* Spreadsheet, and REPORT your updates ....  Some are Landscape and some are Portrait.  Most are 5+ pages long.

How to make page number, sheet name and file name show in header and footer for your meeting in 20 minutes?

Sub Write_Header_Footer_from_Many_Tabbed_Workbook()
 Dim qystring, howmany, menudefault, sht
 'THIS IS FOR A XLS OF MANY TABS - sets the header, footer, and margins of each tab
 If Not ActiveWorkbook.Saved Then
 qystring = "nonemptystring"
 howmany = Sheets.Count
 menudefault = "OK to wait " & howmany * 10 & " seconds " ' Set default.
 qystring = InputBox("Wait 10 seconds each while header/footers written for " & howmany & " tabs?" _
 & vbCrLf & vbCrLf & "Enter Yes / No (or press 'Escape Key' to Skip)", "Enter Yes / No (or press 'Escape Key' to Skip)", menudefault)
 If qystring > "" Then qystring = UCase(Left(qystring, 1))
 'qystring = MsgBox(menudefault & " for " & howmany & " tabs?", vbYesNoCancel, "Write Tab Names to Header and Footer")
 Loop Until ((qystring = "N") Or (qystring = "Y") Or (qystring = "O") Or (qystring = ""))
 End If 'if not saved
 If UCase(Left(qystring, 1)) = "N" Then
 Exit Sub
' If qystring <> vbYes Then Exit Sub 'this line is if using msgbox alternative to inputbox above
 For Each sht In Sheets
 With sht.PageSetup
 .CenterHeader = "&A"
 .RightFooter = "Page &P of &N"
 .CenterFooter = "&08" & "&F" 'to show full (network) path use ' Me.Path & "/" & vbCrLf & "&F"
 .LeftFooter = "&D &T"
 .FitToPagesWide = 1
 .FitToPagesTall = 999
 .PrintTitleRows = "$1:$1"
 If (.Orientation = xlLandscape) Then
 .LeftMargin = Application.InchesToPoints(0.25)
 .RightMargin = Application.InchesToPoints(0.25)
 .TopMargin = Application.InchesToPoints(0.65)
 .BottomMargin = Application.InchesToPoints(0.65)
 .HeaderMargin = Application.InchesToPoints(0.2)
 .FooterMargin = Application.InchesToPoints(0.2)
 .LeftMargin = Application.InchesToPoints(0.5)
 .RightMargin = Application.InchesToPoints(0.5)
 .TopMargin = Application.InchesToPoints(0.5)
 .BottomMargin = Application.InchesToPoints(0.5)
 .HeaderMargin = Application.InchesToPoints(0.2)
 .FooterMargin = Application.InchesToPoints(0.2)
 End If
 End With
 Next sht
 End If ' vbyes
 End Sub