Word VBA 機密（絶密）情報の削除 99% Remove Word Document infomation and other

隠し文字削除機能をが使えるようになりました。
フィールドコード、ブックマーク、ページ罫線、ページの背景色も削除あるいはリセットできるようにしました。
20191/25PDFの作成機能を追加しました。実際の印刷に近いものになります。
Docに関する記述を変更しました。

機密情報といっても何を機密にするか

一度アウトラインモードにして、折りたたみを解除してすべて表示。
変更履歴を反映し、とりあえず隠し図形とかまで削除します
フィールドコードは文字化することも考えられますが、とりあえずLockにとどめました
同名チェックをかけて枝番を付して別名を作成。
Wordマクロを別名保存することにより削除します。ただし~~Docはできないので注意してください。~~Docの場合2013で作成したものはコードが消えました。しかし必ず確認してください。

'ページの透かし、ページの背景色、ページ罫線の削除
'Call DeleteWordPageWaterMark(wDoc): Call EraseWdPageBackGrowndFillColor(wDoc): Call DeleteWdPageBorderLine(wDoc)
'BookMarkの削除
'Call DeleteWdBookmarks(wDoc)

この部分をコメントアウト

'ページの透かし、色、罫線の削除
Call DeleteWordPageWaterMark(wDoc): Call EraseWdPageBackGrowndFillColor(wDoc): Call DeleteWdPageBorderLine(wDoc)
'BookMarkの削除
Call DeleteWdBookmarks(wDoc)

することにより、ページの透かし、背景色、ページ罫線、BookMarkが削除できますがここまでいるのかがわかりません。

コード

Main

Sub RemoveWordSecurityInfos()
'For Word VBA
Dim wDoc As Word.Document: Set wDoc = ThisDocument
'remove comments
Dim comM As Comment
Dim SHP As Word.Shape, i As Long
Dim strFullPath As String, strBase As String, strFile As String, strParent As String, StrNew As String, strExt As String
Dim ar As Variant, strPath As String
Dim wRiv As Word.Revision
Dim varViewType
'まず現在のファイルを上書き保存する
If MsgBox("現在開いている" & ThisDocument.FullName & "を上書き保存します。OKをクリックしてください。" & "キャンセルで終了します。", vbOKCancel + vbInformation, "【上書き保存確認】") = vbCancel Then Exit Sub
wDoc.Save
'保存したThisDocumentのファイル名を取得
strFullPath = wDoc.FullName
strPath = wDoc.Path & "\"
With CreateObject("Scripting.filesystemobject")
strBase = .getbasename(wDoc.FullName)
strExt = .getextensionname(wDoc.FullName)
End With
'Field CodeはEQが文字化するとうまくいかないため、Lockして今後自動更新できないようにする。
'http://office-qa.com/Word/wd598.htm
'https://www.relief.jp/docs/002553.html
  Selection.WholeStory
  Selection.Fields.Update
  Selection.Fields.Locked = True
  'Selection.Fields.Unlink ’EQがない場合は全部文字化もありえる。どちらがいいかは難しい
'Outline Modeに切り替えてすべて表示する
varViewType = ActiveWindow.ActivePane.View.Type
ActiveWindow.ActivePane.View.Type = wdOutlineView
ActiveWindow.ActivePane.View.ExpandAllHeadings 'ドキュメント内のすべての見出しを展開します。 すべて閉じるのは View.CollapseAllHeadings method (Word)'https://docs.microsoft.com/ja-jp/office/vba/api/word.view.expandallheadings
ActiveWindow.ActivePane.View.Type = varViewType
'変更履歴の反映
If wDoc.Revisions.Count > 0 Then
For Each wRiv In wDoc.Revisions
wRiv.Accept
wRiv.Reject
Next
End If
'remove comments
For Each comM In ActiveDocument.Comments
comM.Delete
Next
'非表示の図形の削除 https://www.relief.jp/docs/word-vba-remove-all-shapes.html
If wDoc.Shapes.Count > 0 Then
For i = wDoc.Shapes.Count - 1 To 1 Step -1
With wDoc.Shapes(i)
If .Visible = msoFalse Then
.Delete
End If
End With
Next
End If
'remove author and any other names
On Error Resume Next
wDoc.RemoveDocumentInformation wdRDIDocumentProperties '8 文書プロパティを削除します。
wDoc.RemoveDocumentInformation wdRDIRevisions '2 変更履歴マークを削除します。
wDoc.RemoveDocumentInformation wdRDIVersions '3 文書のバージョン情報を削除します。
wDoc.RemoveDocumentInformation wdRDIRemovePersonalInformation '4 個人情報を削除します。
wDoc.RemoveDocumentInformation wdRDIEmailHeader '5 メール ヘッダー情報を削除します。
wDoc.RemoveDocumentInformation wdRDIInkAnnotations '11 インク注釈を削除します。
wDoc.RemoveDocumentInformation wdRDISendForReview '7 校閲者に文書を送信するときに格納された情報を削除します。
wDoc.RemoveDocumentInformation wdRDIRoutingSlip '6 回覧先情報を削除します。
wDoc.RemoveDocumentInformation wdRDITemplate '9 テンプレート情報を削除します。
wDoc.RemoveDocumentInformation wdRDIContentType '15 Removes document management policy information.ドキュメント管理ポリシーの情報を削除します。
wDoc.RemoveDocumentInformation wdRDIDocumentManagementPolicy
wDoc.RemoveDocumentInformation wdRDITaskpaneWebExtensions '17 作業ウィンドウの web 拡張機能の情報を削除します。
wDoc.RemoveDocumentInformation wdRDITaskpaneWebExtensions 'Removes taskpane web extensions information.作業ウィンドウの web 拡張機能の情報を削除します。
'隠し文字を削除
Application.Options.PrintHiddenText = True '印刷して確認するためTrueに変えます。
Call ReplaceWdHiddenFont(wDoc)
'ページの透かし、ページの背景色、ページ罫線の削除
'Call DeleteWordPageWaterMark(wDoc): Call 'EraseWdPageBackGrowndFillColor(wDoc): Call DeleteWdPageBorderLine(wDoc)
'BookMarkの削除
'Call DeleteWdBookmarks(wDoc)

'最終版にする
wDoc.Final = True
'PDFの作成
Call wdDocSaveToPDF(wDoc)
If LCase(strExt) = "doc" Then
wDoc.SaveAs2 fnNewFileNameAddNumInBrac(strPath & strBase & "." & strExt), wdFormatDocument
ElseIf LCase(strExt) = "docx" Or LCase(strExt) = "docm" Then
wDoc.SaveAs2 fnNewFileNameAddNumInBrac(strPath & strBase & "." & "docx"), wdFormatDocumentDefault 'ここでdocxでマクロを削除する。このときwdFormatDocumentDefaultを指定しないとdocxができても開けない。
End If
End Sub

Sub wdDocSaveToPDF(wDoc As Word.Document)
wDoc.Activate
Dim strFullPath As String, strBase As String, strFile As String, strParent As String, StrNew As String, strExt As String
Dim ar As Variant, strPath As String

strFullPath = wDoc.FullName
strPath = wDoc.Path & "\"
With CreateObject("Scripting.filesystemobject")
strBase = .getbasename(wDoc.FullName)
strExt = .getextensionname(wDoc.FullName)
End With
strFullPath = strPath & strBase & "_" & strExt & ".pdf"
' Macro1 Macro
'https://docs.microsoft.com/ja-jp/dotnet/api/microsoft.office.tools.word.document.exportasfixedformat?view=vsto-2017
'Document.?Export?AsFixed?Format(String, WdExportFormat, Boolean, WdExportOptimizeFor, WdExportRange, Int32, Int32, WdExportItem, _
　 Boolean, Boolean, WdExportCreateBookmarks, Boolean, Boolean, Boolean, Object) Method
'PDFに出力
'KeepIRMBoolean ソース文書が IRM (Information Rights Management) によって保護されている場合に、IRM アクセス許可を XPS 文書にコピーする場合は true。それ以外の場合は false。 既定値は、true です。
'OpenAfterExport Boolean 新しいファイルを自動的に開く場合は true。それ以外の場合は false。
'OptimizeFor WdExportOptimizeFor 画面または印刷のどちら用に最適化するかを指定する WdExportOptimizeFor のいずれかの値。
' Range:=wdExportAllDocument, From:=1, to:=1 印刷範囲が文書全体のため From Toは有効ではない wdExportFromToの時有効
' DocStructureTagsBoolean スクリーン リーダーにとって有用な追加データ (コンテンツのフローや論理構成など) を含める場合は true。それ以外の場合は false。 既定値は、true です。
' これがアクセシビリティの構造を保存の意味
' BitmapMissingFonts:=True　フォントのライセンスで PDF ファイルへのフォントの埋め込みを許可しない場合は、このパラメーターを true に設定します。 このパラメーターを false に設定すると、指定されたフォントが表示先のコンピューターで使用できない場合は、適切なフォントに置き換えられます。 既定値は、true です。
' CreateBookmarks:=wdExportCreateNoBookmarks エクスポートされた文書でブックマークを作成しません。
'seISO19005_1Boolean PDF の使用を ISO 19005-1 として標準化されている PDF のサブセットに限定する場合は true。それ以外の場合は false。
' このパラメーターを true に設定すると、結果ファイルの独立性は高まりますが、形式の制限が原因で、サイズが大きくなったり、ビジュアル アイテムの表示が増加したりする場合があります。 既定値は、false です。

'印刷用 アクセシビリティ用の構造はキープ 情報は削除 変換できない文字はビットマップ 返還後に開かない
ActiveDocument.ExportAsFixedFormat OutputFileName:=fnNewFileNameAddNumInBrac(strFullPath), _
ExportFormat:=wdExportFormatPDF, OpenAfterExport:=False, OptimizeFor:= _
wdExportOptimizeForPrint, Range:=wdExportAllDocument, From:=1, to:=1, _
Item:=wdExportDocumentContent, IncludeDocProps:=False, KeepIRM:=False, _
CreateBookmarks:=wdExportCreateNoBookmarks, DocStructureTags:=True, _
BitmapMissingFonts:=True, UseISO19005_1:=False
End Sub

前回の同名チェック

VBA 同名のファイルがあるときにカッコつきで枝番を追加して重複を避けたファイル名を生成する関数 Same Filename add 2 digit number in BracketsFunction

Function fnNewFileNameAddNumInBrac(strFullPathFileName) As String
'For Office VBA
'Recommend Reference setting Microsoft Scripting Runtime and Vbscript Regular expression 5.5
' Usage fnNewFileNameAddNumInBrac("C/hoge/hoge.txt")
Const MaxDegit = 2 '99までに制限
Const Maxdegitstring = "9" ' この場合99+1で桁オーバーにする 3ケタの場合はMaxDigitを3にする。ただし9だと999までいくため5で555くらいがいいのでは。
Dim FSO: Set FSO = CreateObject("Scripting.FileSystemObject"): 'Dim FSO As New Scripting.FileSystemObject
Dim oFolder 'As Folder
Dim oFIle 'As File
Dim ar, iar, i As Long, i1 As Long
Dim strPath As String, strFile As String, strBase As String, strExt As String
Dim Reg: Set Reg = CreateObject("VBScript.RegExp")
Dim MC, M, iM, sMs, strLast5$
ar = Split(strFullPathFileName, "\")
For i = UBound(ar) - 1 To 0 Step -1
strPath = ar(i) & "\" & strPath
Next
i = -1
On Error GoTo ERR_Handle
If FSO.FolderExists(strPath) = False Then Debug.Print " fnNewFileNameAddNumInBrac occure error line 10 Folder " & strPath & " not exist": Set FSO = Nothing: fnNewFileNameAddNumInBrac = vbNullString: Exit Function ' フォルダがなければエラー
If FSO.FileExists(strFullPathFileName) = False Then
fnNewFileNameAddNumInBrac = strFullPathFileName
Exit Function
Else
Set oFIle = FSO.GetFile(strFullPathFileName)
strExt = FSO.getextensionname(oFIle.Path)
strBase = FSO.getbasename(oFIle.Path)
If Len(strBase) >= MaxDegit + 3 Then
  strLast5 = Right(strBase, MaxDegit + 3) 'ファイル名が長いときは途中の枝番に見えるところを変換しかねないのでカットして変換する
Else
  strLast5 = strBase
End If
Reg.Pattern = "\([0-9]{0," & MaxDegit & "}\)": Reg.Global = True: Reg.MultiLine = False
  If Reg.test(strLast5) = True Then
  If Len(strBase) >= MaxDegit + 3 Then
  Set MC = Reg.Execute(strLast5)
  strLast5 = Replace(strBase, MC(MC.Count - 1), "", 1, 1, vbTextCompare)
  strBase = Left(strBase, MC(0).FirstIndex + 1) & strLast5
  i = CLng(Replace(Replace(MC(MC.Count - 1).Value, "(", "", 1, 1, vbTextCompare), ")", "", 1, -1, vbTextCompare))
Else
  Set MC = Reg.Execute(strLast5)
  strBase = Replace(strBase, MC(MC.Count - 1), "", 1, 1, vbTextCompare)
  i = CLng(Replace(Replace(MC(MC.Count - 1).Value, "(", "", 1, 1, vbTextCompare), ")", "", 1, -1, vbTextCompare))
End If
End If
If i = -1 Then i = 0
  Do
  i = i + 1
  If i > CLng(String(MaxDegit, Maxdegitstring)) Then fnNewFileNameAddNumInBrac = vbNullString: Debug.Print "Branch count " & CLng(String(MaxDegit, "9")) + 1 & " over Too Many": Exit Function
  If FSO.FileExists(strPath & strBase & "(" & String(MaxDegit - Len(CStr(i)), "0") & i & ")." & strExt) = False Then
    Set FSO = Nothing
    fnNewFileNameAddNumInBrac = strPath & strBase & "(" & String(MaxDegit - Len(CStr(i)), "0") & i & ")." & strExt
    Exit Do
  End If
  Loop
Exit Function
End If
Exit Function
ERR_Handle:
Set FSO = Nothing
If Err.Number <> 0 Then Debug.Print "fnNewFileNameAddNumInBrac Error strfullpathfile:=" & strFullPathFileName & vbCrLf & Err.Number & vbCrLf, Err.Description: Err.Clear
Exit Function
End Function

隠し文字の処理

削除する（現在採用）

これがわかりやすいが、元はなにかわからないのが欠点です。ログを取ればよいのでしょうけど。

ハイライトする

ハイライトを使っていない場合は有効。

隠し文字属性を解除する

解除しただけでは何かわからない。

Sub SearchWdFontHiddenAndDelete(wDoc As Word.Document)
'For WORD VBA
'隠し文字自体検索して削除する
'Dim wDoc As Word.Document: Set wDoc = ThisDocument
wDoc.Activate
Selection.HomeKey Unit:=wdStory
Selection.Find.ClearFormatting
With Selection.Find.Font
.StrikeThrough = False
.DoubleStrikeThrough = False
.Hidden = True
.SmallCaps = False
.AllCaps = False
.Superscript = False
.Subscript = False
End With
With Selection.Find
.Text = ""
.Replacement.Text = ""
.Forward = True
.Wrap = wdFindContinue
.Format = True
.MatchCase = False
.MatchWholeWord = False
.MatchByte = False
.MatchAllWordForms = False
.MatchSoundsLike = False
.MatchWildcards = False
.MatchFuzzy = True
On Error Resume Next
Do While .Execute
Selection.Delete
Loop
End With

End Sub
'--------------------------
Sub SearchWdFontHiddenAndHilight(wDoc As Word.Document)
'For Word VBA
'隠し文字を検索してハイライトする
'Dim wDoc As Word.Document: Set wDoc = ThisDocument
Selection.Find.ClearFormatting
With Selection.Find.Font
.StrikeThrough = False
.DoubleStrikeThrough = False
.Hidden = True
.SmallCaps = False
.AllCaps = False
.Superscript = False
.Subscript = False
End With
With Selection.Find
.Text = ""
.Replacement.Text = ""
.Forward = True
.Wrap = wdFindContinue
.Format = True
.MatchCase = False
.MatchWholeWord = False
.MatchByte = False
.MatchAllWordForms = False
.MatchSoundsLike = False
.MatchWildcards = False
.MatchFuzzy = True
Do While .Execute
Selection.Range.HighlightColorIndex = wdYellow
Loop
End With
End Sub
'--------------------------
Sub ReplaceWdHiddenFont(wDoc As Word.Document)
'For Word VBA
'隠し文字を検索しFont.HiddenをFalseにして隠し文字属性を解除する
'Dim wDoc As Word.Document: Set wDoc = ThisDocument
wDoc.Activate
Selection.Find.Replacement.ClearFormatting
With Selection.Find.Replacement.Font
.StrikeThrough = False
.DoubleStrikeThrough = False
.Hidden = False
.SmallCaps = False
.AllCaps = False
.Superscript = False
.Subscript = False
End With
With Selection.Find
.Text = ""
.Replacement.Text = ""
.Forward = True
.Wrap = wdFindContinue
.Format = True
.MatchCase = False
.MatchWholeWord = False
.MatchByte = False
.MatchAllWordForms = False
.MatchSoundsLike = False
.MatchWildcards = False
.MatchFuzzy = False
End With
Selection.Find.Execute Replace:=wdReplaceAll
Selection.Find.ClearFormatting
With Selection.Find.Font
.StrikeThrough = False
.DoubleStrikeThrough = False
.Hidden = True
.SmallCaps = False
.AllCaps = False
.Superscript = False
.Subscript = False
End With
Selection.Find.Replacement.ClearFormatting
With Selection.Find.Replacement.Font
.StrikeThrough = False
.DoubleStrikeThrough = False
.Hidden = False
.SmallCaps = False
.AllCaps = False
.Superscript = False
.Subscript = False
End With
With Selection.Find
.Text = ""
.Replacement.Text = ""
.Forward = True
.Wrap = wdFindContinue
.Format = True
.MatchCase = False
.MatchWholeWord = False
.MatchByte = False
.MatchAllWordForms = False
.MatchSoundsLike = False
.MatchWildcards = False
.MatchFuzzy = False
End With
End Sub

透かしやページ背景色を消すか

この辺になると機密情報とはいいがたいが、部外秘とか書いてあるのはどうなの？機密ってばれてしまう。一方で削除すれば機密かどうかわからない。
どこまで削るのかということになるわけです。
上記で説明したとおり、コメントアウトして動きませんが、必要や仕様に応じて追加します。

Sub DeleteWordPageWaterMark(wDoc As Word.Document)
'For Word VBA
'ページの透かし（背景画像）を消す
'Dim wDoc As Word.Document: Set wDoc = ThisDocument
wDoc.Acivate
Dim wView As Word.View
Dim iSec As Long, iShp As Long
Dim wPane As Word.Pane
ActiveWindow.ActivePane.View.Type = wdPrintView
'https://word2013-help.blogspot.com/2016/08/blog-post_13.html
For iSec = wDoc.Sections.Count To 1 Step -1
wDoc.Sections(iSec).Range.Select
Set wView = ActiveWindow.View
ActiveWindow.ActivePane.View.SeekView = wdSeekCurrentPageHeader
If Selection.HeaderFooter.Shapes.Count > 0 Then
For iShp = Selection.HeaderFooter.Shapes.Count To 1 Step -1
Selection.HeaderFooter.Shapes(iShp).Select
Selection.Delete
ActiveWindow.ActivePane.View.SeekView = wdSeekMainDocument
Next iShp
End If
Next iSec
End Sub
'----
Sub EraseWdPageBackGrowndFillColor(wDoc As Word.Document)
'For Word VBA
'ページの色を消す
'Dim wDoc As Word.Document: Set wDoc = ThisDocument
wDoc.Activate
ActiveWindow.ActivePane.View.SeekView = wdSeekMainDocument
ActiveDocument.Background.Fill.Visible = msoFalse
ActiveWindow.ActivePane.View.SeekView = wdSeekMainDocument
End Sub

ページ罫線を消す

Sub DeleteWdPageBorderLine(wDoc As Word.Document)
'Dim wDoc As Word.Document: Set wDoc = ThisDocument
wDoc.Activate
'For Word VBA
'ページ罫線を削除するマクロ
'ページ罫線がなくて起動してもエラーにはならない
Dim iSec As Long
For iSec = Selection.Sections.Count To 1 Step -1
With Selection.Sections(iSec)
.Borders(wdBorderLeft).LineStyle = wdLineStyleNone
.Borders(wdBorderRight).LineStyle = wdLineStyleNone
.Borders(wdBorderTop).LineStyle = wdLineStyleNone
.Borders(wdBorderBottom).LineStyle = wdLineStyleNone
' With .Borders
' .DistanceFrom = wdBorderDistanceFromPageEdge
' .AlwaysInFront = True
' .SurroundHeader = False
' .SurroundFooter = False
' .JoinBorders = False
' .DistanceFromTop = 24
' .DistanceFromLeft = 24
' .DistanceFromBottom = 24
' .DistanceFromRight = 24
' .Shadow = False
' .EnableFirstPageInSection = True
' .EnableOtherPagesInSection = True
' .ApplyPageBordersToAllSections
' End With
End With
' With Options
' .DefaultBorderLineStyle = wdLineStyleSingle
' .DefaultBorderLineWidth = wdLineWidth050pt
' .DefaultBorderColor = wdColorAutomatic
' End With
Next
End Sub

BookMarkの削除

Sub DeleteWdBookmarks(wDoc As Word.Document)
'For Word VBA
'BookMarkを削除する
'Dim wDoc As Word.Document: Set wDoc = ThisDocument
Dim wBM As Word.Bookmark
Dim wBMs As Bookmarks
wDoc.Bookmarks.ShowHidden = True
Set wBMs = wDoc.Bookmarks
For Each wBM In wBMs
wBM.Delete
Next
End Sub

必要な知識

変更履歴の削除
https://www.relief.jp/docs/word-vba-accept-all-changes.html
図形の削除
https://www.relief.jp/docs/word-vba-remove-all-shapes.html
ブックマーク
https://www.relief.jp/docs/word-vba-defined-bookmarks-list.html