Word VBA V2 Update 配布用のdocxを作成するマクロ

どこまで削除すべきか

今回も前回の印刷と同様何を削るのか仕様を決める必要があります

さらにコードの方は削れるものはみな挙げておいて、それを使わない、という形で条件分岐させます。
これでも全部ではないと思います

pdf,xpsのzoomの率は個別に確認する必要があります

マクロの記録で一度保存させたり、印刷させることで率が変わっていないか確認し、それに合わせて書き換えてください。
サンプルは縮小がかかっていない状態ですが、実際は縮小がかかっていることはよくあります。その場合、サンプルそのままでは正しく表示されません。

変更履歴

1.1　Microsoft Scripting Runtimeの参照設定が必要なのを解除しました。また、文末脚注の削除オプションを追加し、若干コードを見直しました。
2.0 Fileを一度保存してから情報を削除することにより、元のファイルが保護されるようにしました。また削除するオプション、保存する形式のオプションを増やしました。
2.1 Printernameの取得がうまくいっていない原因がつかめたので修正しました

互換モードについて

今回はオリジナルファイルは2013以降のdocx形式を前提としています。
しかしSaveas2のオプションはdocx形式のため、一応2007以降のdocmは動くと思います。
Sub SaveAs2([FileName], [FileFormat], [LockComments], [Password], [AddToRecentFiles], [WritePassword], [ReadOnlyRecommended], [EmbedTrueTypeFonts], [SaveNativePictureFormat], [SaveFormsData], [SaveAsAOCELetter], [Encoding], [InsertLineBreaks], [AllowSubstitutions], [LineEnding], [AddBiDiMarks], [CompatibilityMode])
ここ [CompatibilityMode]をなにも決めないと、互換モードなら互換モードで保存されます。

https://docs.microsoft.com/ja-jp/office/vba/api/word.saveas2
既定では、このパラメーターに値が指定されていない場合、Word では 0 の値が入力され、現在の文書の互換性モードを保持する必要があると指定されます。
By default, if no value is specified for this parameter, Word enters a value of 0, which specifies that the current compatibility mode of the document should be retained.

原文が頭が悪すぎなんですよね。標準の場合も互換モードかよバカが。
既定では、このパラメータになにも指定しないことによって、Wordは0が入力されているものみなし、現在の文書のバージョンで保存を行います。
By default, if no value is specified for this parameter, Word enters a value of 0, which specifies that the current version of the document should be retained and saved.
こんな感じじゃないですかね。これは原文からしておかしいです。2013以降、つまり現在の最新バージョンは互換モードではない。なぜならレイアウトオプションが起動しないし、互換モードという表示が出てこないからです。もっともシステム的にはこのあとのバージョンを考えれば、最新だから表示されていないだけで、現在の最新バージョンも互換モードなのでしょう。だからと言ってこういう書き方は絶対に誤りなので、反省してほしいですね。内情がわかるのと、だからいいかというのは全く別で、これは全くダメです。システムの内情など知ったことか。金払ってるんだからまじめにやらんかボケが。

Excel, Word, PowerPointによるPDF出力
http://cup.sakura.ne.jp/exl/pdf_out.htm
書いているのはRubyでもパラメーターの効果は同じなので一読の価値あり。

今回の仕様

マクロを削除してdocx形式にする

基本的なことを書き忘れていました。
ここで重要なのがSaveAs2のファイルフォーマット定数です。wdFormatXMLDocumentを加えないといけません。これを入れないとできたファイルが壊れて開けません。このSampleに限らず、WordのSaveAs2の非常に重要な注意点ですが、解説されているサイトはないかもしれません。なぜこうなのかというとWordのファイルがもともとdoc形式で、2007からdocx形式になったことを引き継いでいるらしいです。docxとはxml形式のバイナリ（ぶっちゃけzip形式の圧縮ファイル)となっています。これを表しているらしいのです。Defaultとかそういう名前ではありません。
以前書いた、Word VBA 機密（絶密）情報の削除 99% Remove Word Document infomation and otherでは新しいファイルにコピーしています。この方式だと透かしや色は抜けてしまいます。このため、一度マクロなしのバージョンで保存してから情報を削除するように変更しました。

情報を削除する時の仕様は現在以下のとおりです

.RemoveDocumentInformation wdRDIComments: logbuf = logbuf & "wdRDIComments 1 校閲のコメント削除" & vbCrLf
.RemoveDocumentInformation wdRDIRevisions: logbuf = logbuf & "wdRDIRemoveRevisions 2 変更履歴を削除" & vbCrLf
.RemoveDocumentInformation wdRDIVersions: logbuf = logbuf & "RemoveRDIVersions 3 バージョン情報を削除" & vbCrLf 'ここが間違っていました。変更履歴ではなくバージョン情報です。
.RemoveDocumentInformation wdRDIRemovePersonalInformation: logbuf = logbuf & "RemovePersonalInformation 4 個人情報を削除" & vbCrLf
'.RemoveDocumentInformation wdRDIEmailHeader: logbuf = logbuf & "wdRDIEmailHeader 5 メール ヘッダー情報を削除" & vbCrLf
.RemoveDocumentInformation wdRDIRoutingSlip: logbuf = logbuf & "wdRDIRoutingSlip 6  回覧先情報を削除" & vbCrLf
.RemoveDocumentInformation wdRDISendForReview: logbuf = logbuf & "wdRDISendForReview 7 校閲者に文書を送信するときに格納された情報を削除" & vbCrLf
.RemoveDocumentInformation wdRDIDocumentProperties: logbuf = logbuf & "wdRDIDocumentProperties　Remove Documentproperty 8 文書プロパティを削除" & vbCrLf
'.RemoveDocumentInformation wdRDITemplate: logbuf = logbuf & "wdRDITemplate 9 テンプレート情報を削除" & vbCrLf
.RemoveDocumentInformation dRDIDocumentWorkspace: logbuf = logbuf & "wdRDIDocumentWorkspace 10 ワークスペース情報を削除" & vbCrLf
.RemoveDocumentInformation wdRDIInkAnnotTations: logbuf = logbuf & "wdRDIInkAnnotTations 11 インク注釈を削除" & vbCrLf
'.RemoveDocumentInformation wdRDIDocumentServerProperties: logbuf = logbuf & "wdRDIDocumentServerProperties 14 ドキュメント サーバーのプロパティを削除" & vbCrLf
'.RemoveDocumentInformation wdRDIDocumentManagementPolicy: logbuf = logbuf & "wdRDIDocumentManagementPolicy 15 ドキュメント管理ポリシーの情報を削除" & vbCrLf
'.RemoveDocumentInformation wdRDIContentType: logbuf = logbuf & "wdRDIContentType　16 コンテンツ情報を削除" & vbCrLf
.RemoveDocumentInformation wdRDITaskpaneWebExtensions: logbuf = logbuf & "wdRDITaskpaneWebExtensions 17 作業ウィンドウの web 拡張機能の情報を削除" & vbCrLf

現在の削除するオプション、保存するオプション

Const blRemoveThema = False 'テーマ削除
Const blRemoveHeader = True 'True ヘッダー削除
Const blRemoveHeaderWaterMark = True 'True 透かし、原稿用紙を削除
Const blRemoveFooter = True 'True フッダー削除
Const blRemoveNumber = False  '段落番号削除 Falseに変更(Ver2 20200410) ぶら下げインデントが一時的に無効になる場合があるため
Const blRemoveHiddenText = False 'True 隠し文字を削除(非表示ではなく削除) Falseの場合、隠し文字を削除するのではなく、属性を解除して、赤字にする
Const EmbedTrueTypeFontOption = False  'TrueTypeFontを埋め込む '海外用はFontを埋め込むためTrueがよい
Const blRemoveFootNote = True ' Footnote 脚注を削除する
Const blRemoveEndNote = True '  EndNote 文末脚注があれば削除する
Const blRemoveBookMark = True 'BookMarkを削除する
Const blRemoveAllDocumentInformation = False ' Trueの場合すべての情報が削除される Trueは非推奨
Const blRemoveReviewers = True '校閲者を削除する
Const blExportPDF = True 'WordのExportFixedFormat2でPDFに出力
Const blExportOXPS = False 'oxpsで出力
Const blExportXPS = False 'xpsで出力
Const blPrintAdobPDF = False 'Acrobatがある場合、AcrobatでPDFにする
Const blFinilize = False '最終版にする
Const blWord2010 = False 'Word2010形式で保存する

未保存の場合は問答無用で終了する。(Const blForceSave = MsoTriState.msoFalse)

マクロなしファイルとマクロがある原本で中身の違いがあるはずがありません。当然保存していなければ動かないのです。しかも黙って終了します。オプションの指定などで必ずVBEは使えるはずですし、使えるならイミディエイトは開いている。そういう前提です。必ず保存してからです。

テーマを削除はしない(Const blRemoveThema = False)

これを削るとイメージが変わりますのでFalseにします

Fontは埋め込まない

海外で日本語のフォントがないと文字化けします。しかしこれをTrueにするとファイルのサイズがいきなり増えます。サンプルはFalseに設定しています。

段落番号 True 削除 False推奨です

段落番号は補助的にしか使わないと思われたので、Trueで削除するようになっています。しない場合にはFalseに変えます。
ここはFalseがいいようです。

ヘッダー、フッターの削除

とりあえず全てのページのヘッダーフッターが対象です
これはMougのものですが、最大のポイントはSectionsのSectionのHeders/FootersのHeder/FooterのRange.Delete
となる点でしょう。そんなのありなの？

情報はヘッダーではなくフッターに入れるべし。

ヘッダーとフッターがありますが、フッターの削除は成功しますが、フッターの削除はなぜか失敗することがあります。
ページ、ファイル、日付等の削除したい情報はなるだけフッターに入れるようにした方がいいです。
そうしないとフッターは削除に失敗することが往々にしてあるからです。
なぜこういう差が生まれるのかわかりませんが、これはシステムが使うところに原因があるのでしょう。

Pageの色は、ExportAsFixedFormat2ではxps、pdfでは失敗するときがある

本来このようにページ全体に色を付けているのですが、これをxpsやExportAsFixedFormat2で指定したとき

なぜかこのように4分の１だけ着色するというわけのわからない現象が起きます。

ちなみに背景の色は

ActiveDocument.Background.Fill.ForeColor.ObjectThemeColor = _
        wdThemeColorAccent2
ActiveDocument.Background.Fill.ForeColor.TintAndShade = 0.4
ActiveDocument.Background.Fill.Visible = msoTrue
ActiveDocument.Background.Fill.Solid
’イミディエイト出力結果
?ActiveDocument.Background.fill.ForeColor
 12972968 

です。

しかし、ExportAsFixedFormat2の方が2のないExportAsFixedFormatより安定していると思われます。
現時点ではAcrobatの方が設定が面倒で、遅いのですが、確実に着色されます。

Acrobatの設定

アドレス欄にControl Printersと打ちます。Win+Rキーなんていりません。

このタブで結果のPDFを表示させず、また保存するファイル名をDocuments\*.pdfにしています。こうすると、ファイル名を指定しなくてもPDFで保存されます。

ここまでは基本設定です。次にプリンターのプロパティです

アクセス許可はWordからのアクセスを考え全ユーザーに特殊を除き許可します

上記のタブにはこの基本設定からでも入ることができます。

透かしは削除か文言削除で(Const blRemoveHeaderWaterMark = True)

さらにWordの透かし、原稿用紙の設定はヘッダーでされていることがわかりました。
https://www.relief.jp/docs/000117.html
さらに、実際の透かしははヘッダーと任意に設定されたものと２つ存在します。
そこで社外秘で一定の大きさ以上のものを対象として、文字だけ削除します。
Wordファイルの透かしを削除するマクロ

FootNote脚注

EndNote 文末脚注の削除(V1.1追加)

これも場合によっては削除する場合があります。

隠し文字を削除

隠し文字は削除が通常だと思われたのでTrueです。
(V2.0)Falseの場合、属性を解除して赤字になるようにしています。
これはSelection.Findを使います。

  Set wholeRng = wDocC.Range
  Set wFind = wholeRng.Find
  wholeRng.Find.ClearFormatting
  With wholeRng.Find
  .Text = "?"
  .MatchWildcards = True
  .Forward = True
  .Font.Hidden = True
  Do While .Execute = True
   Call wholeRng.SetRange(wholeRng.Start, wholeRng.Start) '隠し文字が1字見つかったらその直前に検索位置を戻す
    wholeRng.Find.MatchWildcards = False 'ワイルドカード検索をオフ
    wholeRng.Find.Text = "" 'テキスト指定をしない
    wholeRng.Find.Execute '隠し文字を再検索。連続する1文字以上の隠し文字を検索する
    wholeRng.Font.Hidden = False
    wholeRng.Font.Color = wdColorRed
    Call wholeRng.SetRange(wholeRng.End, wholeRng.End)
    wholeRng.Find.MatchWildcards = True 'ワイルドカード検索に戻す
    wholeRng.Find.Text = "?" '1文字検索
    Loop
    End With

これは単純にやると無限Loopする恐れがあるという指摘があり、これを採用しました。
https://elleneast.com/?p=657
これが分かったことによって、Falseの場合は隠し文字属性を解除して赤字にしています。
単純に削除(true）でもよいのですが、そもそもなにを削除したのかわからないというのは問題だと考えます。

校閲、注釈の削除

RDIを使います。これはExcelと似ています。

非表示の図形

これはDefaultで選択の余地なく削除にしています

文字を持たないハイパーリンク

これも怪しいので削除します。

Word2o1oの互換モードでの保存

これも意外と難しいのですが、まずSetCompatibilityModeで指定して、それからSaveAsです。
この時のSaveAs2のフォーマット定数はwdformatxmldocument 12です。
これをやるためにも、作業の初めにいったん別名で保存しないと、オリジナルが互換モードになります。

フィールドコードのテキスト化

これは定番のものですが、すべてのフィールドコードは削除できません。
https://www.wordvbalab.com/code/2728/

保存するファイルの削除設定の書き出し(Ver1.1追加)

ややこしいので、一度書きだすようにしています。

# If VBA7 Then
Private Declare PtrSafe Sub Sleep Lib "kernel32" (ByVal ms As LongPtr)
# Else
Private Declare Sub Sleep Lib "kernel32" (ByVal ms As Long)
# End If
# If VBA7 Then
Private Declare PtrSafe Function GetTickCount Lib "kernel32" () As Long
Private Declare PtrSafe Function MsgWaitForMultipleObjects Lib "user32" _
   (ByVal Count As Long, ByVal HandlesPointer As Long, _
    ByVal WaitAll As Long, ByVal MilliSeconds As Long, _
    ByVal WakeMask As Long) As Long
# Else
Private Declare Function GetTickCount Lib "kernel32" () As Long
Private Declare Function MsgWaitForMultipleObjects Lib "user32" _
   (ByVal Count As Long, ByVal HandlesPointer As Long, _
    ByVal WaitAll As Long, ByVal MilliSeconds As Long, _
    ByVal WakeMask As Long) As Long
# End If

Sub MakeCleanDocument()

Const blForceSave = MsoTriState.msoTrue 'True 未保存の場合、保存してから実行する False(推奨) 未保存ならそのまま終了する。メッセージすら出さない。

Const blRemoveThema = False 'テーマ削除
Const blRemoveHeader = True 'True ヘッダー削除
Const blRemoveHeaderWaterMark = True 'True 透かし、原稿用紙を削除
Const blRemoveFooter = True 'True フッダー削除
Const blRemoveNumber = False  '段落番号削除 Falseに変更(Ver2 20200410) ぶら下げインデントが一時的に無効になる場合があるため
Const blRemoveHiddenText = False 'True 隠し文字を削除(非表示ではなく削除) Falseの場合、隠し文字を削除するのではなく、属性を解除して、赤字にする
Const EmbedTrueTypeFontOption = False  'TrueTypeFontを埋め込む '海外用はFontを埋め込むためTrueがよい
Const blRemoveFootNote = True ' Footnote 脚注を削除する
Const blRemoveEndNote = True '  EndNote 文末脚注があれば削除する
Const blRemoveBookMark = True 'BookMarkを削除する
Const blRemoveAllDocumentInformation = False ' Trueの場合すべての情報が削除される Trueは非推奨
Const blRemoveReviewers = True '校閲者を削除する
Const blExportPDF = True 'WordのExportFixedFormat2でPDFに出力
Const blExportOXPS = False 'oxpsで出力
Const blExportXPS = False 'xpsで出力
Const blPrintAdobPDF = False 'Acrobatがある場合、AcrobatでPDFにする
Const blFinilize = False '最終版にする
Const blWord2010 = False 'Word2010形式で保存する

' FileSystemObject Late Binding用定数
Const ForWriting = 2, ForAppending = 8
Const TristateUseDefault = -2

Dim wDoc As Word.Document, wDocC As Word.Document: Set wDoc = ThisDocument
Dim wRng As Word.Range, wholeRng As Word.Range
Dim wBM As Word.Bookmark, wBMS As Word.Bookmarks, blHiddentext As Boolean
Dim wParas As Word.Paragraphs, wPara As Word.Paragraph
Dim wFld As Word.Field, wFlds As Word.Fields, wFind As Word.Find, wReviewer As Word.Reviewer, WReviewers As Word.Reviewers
Dim sPath As String, sFileName As String
Dim FSO: Set FSO = CreateObject("Scripting.FilesystemObject")
Dim HDFTs As HeadersFooters, HDFT As Word.HeaderFooter
Dim wSecs As Word.Sections, wSec As Word.Section
Dim wFCs As Word.Fields, wFc As Word.Field
Dim i As Long, cnt As Long, wSty As Word.Style
Dim logbuf As String
Dim wFootNote As Word.Footnote
Dim wShp As Word.Shape, varViewType, strPrinterName As String: strPrinterName = Application.ActivePrinter
Dim wHL As Word.Hyperlink
Dim TS 'As TextStream
If blForceSave = MsoTriState.msoTrue Then
wDoc.Save
ElseIf blForceSave = MsoTriState.msoFalse Then
    If ThisDocument.Saved = False Then
    Debug.Print "未保存の変更があります。終了します"
    Exit Sub
    End If
End If
' 複写先ファイルを作成
'Set wDocC = Application.Documents.Add(, False, wdNewBlankDocument, True)
sPath = FSO.getparentfoldername(wDoc.FullName): logbuf = logbuf & "sPath " & sPath & vbCrLf
' 複写先ファイル名の決定
ChDir wDoc.Path
sFileName = sPath & "\" & FSO.getbasename(wDoc.FullName) & ".docx"
' 同名チェック
If FSO.fileexists(sFileName) Then
    For i = 1 To 10
        If FSO.fileexists(sPath & "\" & FSO.getbasename(wDocC.FullName) & "(" & i & ")" & ".docx") = False Then
        sFileName = ""
        sFileName = sPath & "\" & FSO.getbasename(wDocC.FullName) & "(" & i & ")" & ".docx"
        Exit For
            If i > 9 Then
            MsgBox "ファイルが9程重複しているようです。本番ファイルがこんなに作られることはないので、一度削除したり整理してください", vbCritical + vbOKOnly, " 9 same files already exists."
            Set TS = FSO.OpenTextFile(wDocC.Path & "\WordPublishDocx" & Format(Now, "hhmmss") & ".txt", ForWriting, True, TristateUseDefault)
            TS.WriteLine "[ErrorEnd]" & vbCrLf & _
            wDocC.FullName & " was not saved. Without Macro, to " & sFileName & "."
            TS.Close
            Set FSO = Nothing
            wDocC.Close False
            End If
        End If
    Next i
End If
wDoc.SaveAs2 sFileName, wdFormatXMLDocument, , , False, , , , False, False, False: DoEvents: WaitAPI6432 (1000): Sleep 5000
wDoc.Activate
Set wDocC = ActiveDocument 'いったん保存して、現在のファイルをwDocCに変更する。これによって元のファイルは変更されなくなる。

'現在のファイルから複写
wDocC.Activate

With ActiveWindow.ActivePane.View
varViewType = .Type
.Type = wdOutlineView
.ExpandAllHeadings 'ドキュメント内のすべての見出しを展開します。 すべて閉じるのは View.CollapseAllHeadings method (Word)'https://docs.microsoft.com/ja-jp/office/vba/api/word.view.expandallheadings
.Type = varViewType
End With
If EmbedTrueTypeFontOption = True Then
wDocC.EmbedTrueTypeFonts = True
logbuf = logbuf & "フォントを埋め込む（互換性や海外のWordで読めますが、ファイルが重くなります " & vbCrLf
Else
wDocC.EmbedTrueTypeFonts = False
End If
' 現在の隠し文字ファイルの印刷設定を保存
blHiddentext = _
Application.Options.PrintHiddenText
If blHiddentext Then
logbuf = logbuf & "隠し文字を印刷する　設定は" & blHiddentext & "のためFalseに変更します。終了後に元の設定に一応戻す予定です。" & vbCrLf
Application.Options.PrintHiddenText = False

End If

'なぜか情報の削除を先にしないと、フィールドコードをテキスト化して保存すると消える。
With wDocC
On Error Resume Next
If blRemoveAllDocumentInformation = True Then
.RemoveDocumentInformation wdRDIAll: logbuf = logbuf & "wdRDIAll 99 全ての情報を削除" & vbCrLf
Else
.RemoveDocumentInformation wdRDIComments: logbuf = logbuf & "wdRDIComments 1 校閲のコメント削除" & vbCrLf
.RemoveDocumentInformation wdRDIRevisions: logbuf = logbuf & "wdRDIRemoveRevisions 2 変更履歴を削除" & vbCrLf
.RemoveDocumentInformation wdRDIVersions: logbuf = logbuf & "RemoveRDIVersions 3 バージョン情報を削除" & vbCrLf 'ここが間違っていました。変更履歴ではなくバージョン情報です。
.RemoveDocumentInformation wdRDIRemovePersonalInformation: logbuf = logbuf & "RemovePersonalInformation 4 個人情報を削除" & vbCrLf
'.RemoveDocumentInformation wdRDIEmailHeader: logbuf = logbuf & "wdRDIEmailHeader 5 メール ヘッダー情報を削除" & vbCrLf
.RemoveDocumentInformation wdRDIRoutingSlip: logbuf = logbuf & "wdRDIRoutingSlip 6  回覧先情報を削除" & vbCrLf
.RemoveDocumentInformation wdRDISendForReview: logbuf = logbuf & "wdRDISendForReview 7 校閲者に文書を送信するときに格納された情報を削除" & vbCrLf
.RemoveDocumentInformation wdRDIDocumentProperties: logbuf = logbuf & "wdRDIDocumentProperties　Remove Documentproperty 8 文書プロパティを削除" & vbCrLf
'.RemoveDocumentInformation wdRDITemplate: logbuf = logbuf & "wdRDITemplate 9 テンプレート情報を削除" & vbCrLf
.RemoveDocumentInformation dRDIDocumentWorkspace: logbuf = logbuf & "wdRDIDocumentWorkspace 10 ワークスペース情報を削除" & vbCrLf
.RemoveDocumentInformation wdRDIInkAnnotTations: logbuf = logbuf & "wdRDIInkAnnotTations 11 インク注釈を削除" & vbCrLf
'.RemoveDocumentInformation wdRDIDocumentServerProperties: logbuf = logbuf & "wdRDIDocumentServerProperties 14 ドキュメント サーバーのプロパティを削除" & vbCrLf
'.RemoveDocumentInformation wdRDIDocumentManagementPolicy: logbuf = logbuf & "wdRDIDocumentManagementPolicy 15 ドキュメント管理ポリシーの情報を削除" & vbCrLf
'.RemoveDocumentInformation wdRDIContentType: logbuf = logbuf & "wdRDIContentType　16 コンテンツ情報を削除" & vbCrLf
.RemoveDocumentInformation wdRDITaskpaneWebExtensions: logbuf = logbuf & "wdRDITaskpaneWebExtensions 17 作業ウィンドウの web 拡張機能の情報を削除" & vbCrLf
End If
End With

' 隠し文字の削除
If blRemoveHiddenText Then
logbuf = logbuf & "https://social.msdn.microsoft.com/Forums/office/en-US/5e638689-b1cb-4a04-8ffa-3bdbc4564342/how-to-deleteremove-the-hidden-text-in-word-document?forum=worddev" & vbCrLf
wDocC.Activate: DoEvents
    Selection.Find.Replacement.ClearFormatting
    Selection.Find.Font.Hidden = True
        With Selection.Find
        .Text = ""
        .Replacement.Text = ""
        .Forward = True
        .Wrap = wdFindContinue
        .Format = True
        .MatchCase = False
        .MatchWholeWord = False
        .MatchByte = False
        .CorrectHangulEndings = False
        .HanjaPhoneticHangul = False
        .MatchAllWordForms = False
        .MatchSoundsLike = False
        .MatchWildcards = False
        .MatchFuzzy = True
         .Execute Replace:=wdReplaceAll
        End With

  If Err.Number <> 0 Then
  logbuf = logbuf & "HiddenText　隠し文字削除エラー" & Err.Number & " " & Err.Description & vbCrLf
  Else
  logbuf = logbuf & "HiddenText　隠し文字削除" & vbCrLf
  End If
  Else
  Set wholeRng = wDocC.Range
  Set wFind = wholeRng.Find
  wholeRng.Find.ClearFormatting
  With wholeRng.Find
  .Text = "?"
  .MatchWildcards = True
  .Forward = True
  .Font.Hidden = True
  Do While .Execute = True
   Call wholeRng.SetRange(wholeRng.Start, wholeRng.Start) '隠し文字が1字見つかったらその直前に検索位置を戻す
    wholeRng.Find.MatchWildcards = False 'ワイルドカード検索をオフ
   wholeRng.Find.Text = "" 'テキスト指定をしない
    wholeRng.Find.Execute '隠し文字を再検索。連続する1文字以上の隠し文字を検索する
    wholeRng.Font.Hidden = False
    wholeRng.Font.Color = wdColorRed
    Call wholeRng.SetRange(wholeRng.End, wholeRng.End)
    wholeRng.Find.MatchWildcards = True 'ワイルドカード検索に戻す
    wholeRng.Find.Text = "?" '1文字検索
    Loop
    End With
   If Err.Number <> 0 Then
  logbuf = logbuf & "HiddenText　隠し文字属性解除エラー：https://elleneast.com/?p=657" & Err.Number & " " & Err.Description & vbCrLf
  Else
  logbuf = logbuf & "HiddenText　隠し文字属性解除：https://elleneast.com/?p=657" & vbCrLf
  End If
 End If
' Header Fotterヘッダー、フッターの削除
Set wSecs = wDocC.Sections
For Each wSec In wSecs
  wSec.Range.Select
  If blRemoveHeader = True Then
    Set HDFTs = wSec.Headers
    For Each HDFT In HDFTs
    HDFT.Range.Delete
    Next HDFT
    logbuf = logbuf & "ヘッダー削除" & vbCrLf
  End If
  If blRemoveHeaderWaterMark Then
   ActiveWindow.ActivePane.View.SeekView = wdSeekCurrentPageHeader
   For cnt = 1 To Selection.HeaderFooter.Shapes.Count
        Set wShp = Selection.HeaderFooter.Shapes(cnt)
        If InStr(1, wShp.Name, "WaterMark") > 0 Then
            Selection.HeaderFooter.Shapes(wShp.Name).Delete
        End If
    Next cnt
    logbuf = logbuf & "(透かしがあれば削除。透かしはヘッダーに含まれた画像。原稿用紙と同じ。" & vbCrLf & "https://stabucky.com/wp/archives/3001" & vbTab & "https://www.relief.jp/docs/000117.html )"
    ActiveWindow.ActivePane.View.SeekView = wdSeekMainDocument
  End If
  If blRemoveFooter = True Then
    Set HDFTs = wSec.Footers
    For Each HDFT In HDFTs
    HDFT.Range.Delete
    Next HDFT
    logbuf = logbuf & "フッター削除" & vbCrLfif
  End If
Next
If blRemoveFootNote Then
    If wDocC.Footnotes.Count > 0 Then
    logbuf = logbuf & "FootNote脚注削除" & vbCrLf
      For Each wFootNote In wDocC.Footnotes
      logbuf = logbuf & wFootNote.Range.Text & vbCrLf
      wFootNote.Delete
      Next wFootNote
    End If
End If
If blRemoveEndNote Then
Call RemoveEndNote(wDocC)
logbuf = logbuf & "EndonoteNote文末脚注削除" & vbCrLf
End If
If wDocC.Shapes.Count > 1 And blRemoveHeaderWaterMark Then
For Each wsh In wDocC.Shapes
If (wShp.Width / (wDocC.PageSetup.PageWidth - wDocC.PageSetup.LeftMargin - wDocC.PageSetup.RightMargin)) > 1 Then
If InStr(1, wShp.TextFrame.TextRange.Text, "社外秘", vbTextCompare) > 0.9 Then
wShp.TextFrame.TextRange.Text = ""
 logbuf = logbuf & "透かし削除オプション TrueのためShapeのうち、手動でDocument内に設定されたタイプの透かしを検索。条件はページサイズとほぼ同じ。" & _
 "つまり図形の幅がページの幅から左右のマージンを引いた数より大体大きい(>0.9)。かつ社外秘を対象。これ以外の文言や幅が小さい場合は非対象。文言だけ削除する" & vbCrLf
End If
End If
Next
End If
If wDocC.Shapes.Count > 0 Then
  For Each wShp In wDocC.Shapes
    If wShp.Visible = msoFalse Then
    logbuf = logbuf & "隠し図形削除" & wShp.Name & vbTab & wShp.Type & vbCrLf
    wShp.Delete
    End If
  Next wShp
End If

If wDocC.Hyperlinks.Count > 0 Then
For Each wHL In wDocC.Hyperlinks
  If wHL.TextToDisplay = "" Then
  logbuf = logbuf & "No text Hyperling deleted" & vbCrLf
  wHL.Delete
  End If
Next
End If
On Error GoTo 0

If Err.Number <> 0 Then Debug.Print Err.Number, Err.Description: Err.Clear
If wDocC.Fields.Count > 0 Then
wDocC.Fields.Unlink
End If

With wDocC
On Error Resume Next
    If blRemoveThema = True Then
    .RemoveTheme
    logbuf = logbuf & "RemoveThema" & vbCrLf
    End If
    If blRemoveNumber = True Then '段落番号の削除
    .RemoveNumbers
    logbuf = logbuf & "Remove Numbers 段落番号の削除 " & vbCrLf
    End If
    If blRemoveBookMark = True Then 'BookMarkの削除
        Call wdRemoveBookMarks(wDocC)
    End If

    
    
        
On Error Resume Next
  For Each wSty In .Styles
   If wSty.InUse = True Then
   wSty.Locked = True
   Else
   wSty.Delete
   End If
   If Err.Number <> 0 Then Err.Clear
  Next
End With
wDocC.Activate
With ActiveWindow
With .View
.Zoom = 100
.DisplayBackgrounds = True
.Draft = False
.ShowBookmarks = True
End With
End With
ChDir wDocC.Path
If blFinilize Then wDocC.Final = True: lobbuf = logbuf & "blFinilize :=" & blFinilize
wDocC.SaveAs2 sFileName, wdFormatXMLDocument, , , False, , , , False, False, False: DoEvents: WaitAPI6432 (1000): Sleep 5000
On Error GoTo 0
If Err.Number <> 0 Then logbuf = logbuf & "ExportAsPDf Err" & Err.Number & vbTab & Err.Description & vbCrLf: Err.Clear
If blExportOXPS Then
sFileName = wDocC.Path & "\" & FSO.getbasename(wDocC.FullName) & ".oxps"
wDocC.Activate
    ActiveDocument.ExportAsFixedFormat2 outputfileName:=sFileName, ExportFormat:=wdExportFormatXPS, _
         OpenAfterExport:=False, OptimizeFor:=wdExportOptimizeForPrint, Range:= _
        wdExportAllDocument, From:=1, to:=1, Item:=wdExportDocumentContent, _
        IncludeDocProps:=True, KeepIRM:=True, CreateBookmarks:= _
        wdExportCreateNoBookmarks, DocStructureTags:=True, BitmapMissingFonts:= _
        True, UseISO19005_1:=False, OptimizeForImageQuality:=True
        Debug.Print sFileName
If Err.Number <> 0 Then logbuf = logbuf & "ExportAsOXPS Err" & Err.Number & vbTab & Err.Description & vbCrLf: Debug.Print Err.Number, Err.Description, "xops": Err.Clear
End If

If blExportXPS Then
sFileName = ""
sFileName = wDocC.Path & "\" & FSO.getbasename(wDocC.FullName) & ".xps"
'wDocC.ExportAsFixedFormat2 sfilename, wdExportFormatXPS _
, False, wdExportOptimizeForPrint, wdExportAllDocument, , , wdExportDocumentContent, False, False, _
wdExportCreateHeadingBookmarks, True, True, False, False: DoEvents: Sleep 300: WaitAPI6432 1000
Debug.Print sFileName
wDocC.Activate
    ActiveDocument.ExportAsFixedFormat outputfileName:=sFileName, ExportFormat:=wdExportFormatXPS, _
         OpenAfterExport:=False, OptimizeFor:=wdExportOptimizeForPrint, Range:= _
        wdExportAllDocument, From:="1", to:="1", Item:=wdExportDocumentContent, _
        IncludeDocProps:=True, KeepIRM:=True, CreateBookmarks:= _
        wdExportCreateNoBookmarks, DocStructureTags:=True, BitmapMissingFonts:= _
        True, UseISO19005_1:=False: DoEvents: Sleep 500: WaitAPI6432 1000
        Debug.Print sFileName
If Err.Number <> 0 Then logbuf = logbuf & "ExportAsOXP Err" & Err.Number & vbTab & Err.Description & vbCrLf:: Debug.Print Err.Number, Err.Description, "ops": Err.Clear
End If
If blExportPDF = True Then
wDocC.Activate
sFileName = ""
    sFileName = wDocC.FullName & ".pdf"
    ActiveDocument.ExportAsFixedFormat2 outputfileName:= _
         sFileName, ExportFormat:=wdExportFormatPDF, _
         OpenAfterExport:=False, OptimizeFor:=wdExportOptimizeForPrint, Range:= _
        wdExportAllDocument, From:="1", to:="1", Item:=wdExportDocumentContent, _
        IncludeDocProps:=True, KeepIRM:=True, CreateBookmarks:= _
        wdExportCreateNoBookmarks, DocStructureTags:=True, BitmapMissingFonts:= _
        True, UseISO19005_1:=False, OptimizeForImageQuality:=True
    Sleep 1000
    WaitAPI6432 500
    If Err.Number <> 0 Then
    logbuf = logbuf & "ExportFormatPDF Err" & Err.Number & vbTab & Err.Description & vbCrLf: Debug.Print Err.Number, Err.Description, "pdf": Err.Clear
    Else
    logbuf = logbuf & "blExportPDF = True & Success Filename:=" & sFileName & vbCrLf & " ActiveDocument.ExportAsFixedFormat2 outputfileName:=" _
         & "sFileName, ExportFormat:=wdExportFormatPDF," _
         & "OpenAfterExport:=False, OptimizeFor:=wdExportOptimizeForPrint, Range:=" _
        & "wdExportAllDocument, From:=""1"", To:=""1"", Item:=wdExportDocumentContent," _
        & "IncludeDocProps:=True, KeepIRM:=True, CreateBookmarks:=" _
       & "wdExportCreateNoBookmarks, DocStructureTags:=True, BitmapMissingFonts:= " _
       & "True, UseISO19005_1:=False, OptimizeForImageQuality:=True" & vbCrLf
    End If
End If
If blPrintAdobPDF Then
'strPrinterName = Application.ActivePrinter 'ここで取得するとオプションを設定していないときは空文字になるため修正しました
sFileName = wDocC.Path & FSO.getbasename(wDocC.FullName) & "_Adobe.pdf"
    ActivePrinter = "Adobe PDF"
    '今回は本番用のため、DocumentContentを使用しDocumentContentWithMarkUPを使用せず
    Application.PrintOut Background:=True, append:=False, Range:=wdPrintAllDocument, outputfileName:="", Item:= _
        wdPrintDocumentContent, Pages:="", PageType:= _
        wdPrintAllPages, Copies:=1, Collate:=True, PrintToFile:=False, _
        PrintZoomColumn:=0, PrintZoomRow:=0, PrintZoomPaperWidth:=0, _
        PrintZoomPaperHeight:=0: DoEvents
Sleep 3000
If Err.Number <> 0 Then
logbuf = logbuf & "Print ADOBEPDF Err" & Err.Number & vbTab & Err.Description & vbCrLf: Debug.Print "Print ADOBEPDF Err", Err.Number, Err.Description: Err.Clear: Err.Clear
Else
    logbuf = logbuf & "blPrintAdobPDF = True & Success Filename:=" & sFileName & vbCrLf & "   Application.PrintOut Background:=True, append:=False, Range:=wdPrintAllDocument, outputfileName:="", Item:=" _
        & "wdPrintDocumentContent, Pages:="", PageType:= " _
        & "wdPrintAllPages, Copies:=1, Collate:=True, PrintToFile:=False," _
        & "PrintZoomColumn:=0, PrintZoomRow:=0, PrintZoomPaperWidth:=0," _
      & "PrintZoomPaperHeight:=0: DoEvents" & vbCrLf
End If
End If
If blWord2010 Then
wDocC.SetCompatibilityMode wdWord2010
wDocC.SaveAs2 wDocC.FullName & "_2010.docx"
End If
On Error GoTo 0

Set TS = FSO.OpenTextFile(wDocC.Path & "\WordPublishDocx" & Format(Now, "hhmmss") & ".txt", ForWriting, True, TristateUseDefault)
TS.WriteLine wDocC.FullName & " was saved. Without Macro, to " & sFileName & "." & vbCrLf & vbCrLf & logbuf & _
"wDocC.SaveAs2 sFileName, wdFormatXMLDocument, , , False, , , , False, False, False" & vbCrLf & _
"blRemoveThema: " & blRemoveThema & vbCrLf & "blRemoveHeader: " & blRemoveHeader & vbCrLf & "blRemoveFooter; " & blRemoveFooter & vbCrLf & _
"blRemoveNumber: " & blRemoveNumber & vbCrLf & "blRemoveHiddenText: " & blRemoveHiddenText & vbCrLf & "EmbedTrueTypeFontOption: " & EmbedTrueTypeFontOption & vbCrLf & _
"blRemoveFootNote: " & blRemoveFootNote & vbCrLf & "blRemoveEndNote: " & blRemoveEndNote
GoTo Terminator
Exit Sub
Terminator:
wDocC.Activate
wDocC.ActiveWindow.View.Type = varViewType
Application.ActivePrinter = strPrinterName
Application.Options.PrintHiddenText = blHiddentext
TS.Close
MsgBox "保存しました", vbInformation, "Saved"
Set FSO = Nothing
wDoc.Close False
Application.Quit
End Sub
Function fnExportFileName(wDoc As Word.Document, strExt As String, Optional blAdobePdf As Boolean = False)
Dim FSO: Set FSO = CreateObject("Scripting.FilesystemObject")
Dim sPath As String
Dim sFileName As String
sPath = FSO.getparentfoldername(wDoc.FullName)
If Left(strExt, 1) = "." Then strExt = Replace(strExt, ".", "", 1, 1, vbTextCompare)
If blAdobePdf = True Then
sFileName = sPath & "\" & FSO.getbasename(wDoc.FullName) & "_adobePDF" & "." & strExt
End If
If FSO.fileexists(sFileName) Then
    For i = 1 To 100
        If FSO.fileexists(sPath & "\" & FSO.getbasename(wDoc.FullName) & "(" & i & ")" & "." & strExt) = False Then
        sFileName = ""
        If blAdobePdf = True Then
        sFileName = sPath & "\" & FSO.getbasename(wDoc.FullName) & "_adobePDF" & "(" & i & ")" & "." & strExt
        Else
        sFileName = sPath & "\" & FSO.getbasename(wDoc.FullName) & "(" & i & ")" & "." & strExt
        End If

        Exit For
            If i > 9 Then
            MsgBox "ファイルが9程重複しているようです。本番ファイルがこんなに作られることはないので、一度削除したり整理してください", vbCritical + vbOKOnly, " 9 same files already exists."
            End If
        End If
    Next i
End If
fnExportFileName = sFileName
Set FSO = Nothing
End Function
Private Sub RemoveEndNote(Optional ByRef wDocu As Word.Document)
Dim wDoc As Word.Document
If wDocu Is Nothing Then Set wDoc = ThisDocument Else Set wDoc = wDocu
Dim wEndNotes As Word.Endnotes, wEndNote As Word.Endnote
Set wEndNotes = wDoc.Endnotes
If wEndNotes.Count > 0 Then
For Each wEndNote In wEndNotes
'wEndNote.Range.Delete '文末脚注の中身が削除されるが文末脚注自体は削除されない
wEndNote.Delete
Next
End If
End Sub

Public Sub WaitAPI6432(ByVal msec As Long)
' msec ミリセカント(千分の一秒)単位
If msec <= 0 Then
msec = 1
End If
Dim Interval As Long
Dim tickBegin As Long
Interval = msec
tickBegin = GetTickCount()
Do
  If MsgWaitForMultipleObjects(0, 0, 0, Interval, &HFF&) = 0 Then
     DoEvents
  End If
  Interval = msec + tickBegin - GetTickCount()
Loop Until Interval < 0
End Sub

Private Sub wdRemoveBookMarks(wDocu As Word.Document)
Dim wBM As Word.Bookmark, wBMS As Word.Bookmarks
wDocu.Activate
Set wBMS = wDocu.Bookmarks
If wDocu.Bookmarks.Count >= 1 Then
wBMS.ShowHidden = True
For Each wBM In wBMS
Debug.Print wBM.Name: DoEvents
On Error Resume Next
wBM.Delete
On Error GoTo 0
If Err.Number <> 0 Then Debug.Print Err.Number, Err.Description: Err.Clear: DoEvents
Next wBM
End If
End Sub

問題なのはこれでもまだ隠し文字等ができる点です

一番厄介なのは普通に書いてある場合です。これはついうっかりとあり得ます。なのでこういう技術で削るのは基本的に無理です。
　紙に印刷するのが一番安全でコストが安い。
多分これはこれからもうごかないです。このようにいくらでも削ることができるということは相手方に渡すときに改ざんが容易であり、それはまた漏洩も容易だということを意味します。なぜこんなことになるのか、確かにデジタルデータに保護をかければ改ざんは困難になります。しかし、それは相手方に全ての情報を出していい、という前提があります。いったんその前提が崩れると、なにをどこまで出していいのかがわからなくなり、それが通用しなくなるわけです。今回の場合も相手に一度渡して終わりであればうまくいきますが、相手とやり取りをしだすとこのような技術でも難しいです。
今はテレワークがやむを得ない面がありますが、デジタルによる文書の交換は極めてリスクが高いので、必ずトラブルが起きるでしょう。バラ色の技術ではなく、労働者を苦しめる以外のことはできません。

Wordはやはりどこかおかしい

なお、今回の文字が書いてあるのはMicrosofotのWordのVBAの解説です。表をWordにコピペしたところです。
赤字の部分は隠し文字だったところが赤くなっているのです。消えている部分は隠し文字を削除するモードの時消えたものです。
赤字を使っておらず、隠し文字があまりないという前提だと、隠し文字が削られると想定外のところで文字が消えてしまう可能性があります。
ここも迷うところです。
また、今回もいろいろ公式が全く書いていない不可思議なバグにぶち当たりました。隠し文字の検索や、保存形式の指定、別の形式の保存で存在しています。

Selection.Wholestoryはすべてコピーできない

セレクションでコピーしたときは背景の色がコピーされず、透かしもコピーされませんでした。
これをあえてコピーする場合はいったんdocx形式で保存する必要があります。
またこれはSelectionによるコピーが必ずしもすべてコピーしていないことを意味します。
もっとも今まで別名で保存するとき、docx形式の定数が必ずしも明らかではなかったため、多くのサイトはここを回避するためSelectionの複写しか手段がなかったのが確かです。

複数の保存形式で一括保存が可能

このような欠陥や挙動の差異がだいぶ明らかになりまた、複数の形式で一括して保存することで比較が可能になった点が大きいと思います。
今回の比較でもこんな単純な文書ですらWordのPDF形式とAcrobatの形式は大きく異なることがわかりました。

全員100%出力はA4サイズと大きさが違う

Wordとxpsは小さすぎ、Acrobatは大きすぎ

xpsとoxpsは容量は同じでPdfに敗北

この段階で負け。

xpsを見るには追加が必要な時がある

Windows 10 バージョン 1803 で XPS ビューアーを利用する方法
https://answers.microsoft.com/ja-jp/windows/forum/apps_windows_10-winapps-appscat_productivity/windows-10/76d80c1a-63a3-42f8-ae55-a9db6ae9c72f
Microsoft XPS Document Writer はどのような目的で使用するのでしょうか ・ 削除しても差し支えはないのでしょうか
https://answers.microsoft.com/ja-jp/windows/forum/all/microsoft-xps-document-writer/feba5643-90b4-4cc4-93a7-c3b6c253b939
モデレーター自身が使っていないことを正直に告白。

WordのPDF出力がAcrobatと違う

さらに、Wordの方が早いけど圧縮は効いていないことがわかりました。アクロバットなど1.6で勝っています。もっとも出力するの10秒は時間がかかる点が問題ですが。

しかし人に渡すのはやはり相手方持っているとああこの人ケチってPDFに変換したんだなってわかるので、渡す分はAcrobatで出した方がいいです。
　また、重要なのはそういう形式面もさることながら非常におかしいということが言えます。
　一般的にpdfはバージョンが上がる方が圧縮され、サイズが小さくなる反面、表示も遅くなり、保存にも時間がかかるという性質があります。ところが、AcrobatよりWordはバージョンが上で、さらにAcrobatより先に出力できています。これはMSが技術が上だからではなく、どこか間違っているか普通のPDFと違うことをしている可能性が大きいです。この差は印刷を介するとか、フォントの埋め込みかもしれませんが、今度はフォントを埋め込めばファイルサイズが一挙に大きくなります。
　このように考えていくとWordのPDF保存はバグがある可能性が否定できず、Acrobatで出力して配布したほうがトラブルになる可能性が少ないといえます。技術的に優れていてもPDFのNativeな様式に従っていないのではトラブルの可能性が否定できません。上記で述べたように背景の色ですら安定していないのがマイクロソフトの品質です。信頼性に欠けているわけです。

Word2010出力で句読点ぶら下げを正しく出力

　また今回互換モードでWord2010を出せるようにしたのは、レイアウトの句読点ぶら下げがWord2013以降ではできないため、欠陥があることがわかっているためです。Microsoftはなんども指摘されながらいまだにこれを訂正していません。このため、レイアウトが崩れます。もちろん日付コンテンツコントロールなど互換性がない機能はありますが、上下がそろう句読点が余白に追い出されたレイアウトを正確に出力するにはWord2010で出力しなければなりません。今回のVBAはそれを可能にしました。

透かし自体がセキュリティに問題がある

Wordの透かし機能の正体はヘッダーからぶら下がっているテキストボックスです。
これをマクロで記録すると、こんな感じです。

Sub Macro1()
'実際は環境変数ではなく、 `C:\User\name\AppData\Roming`のようになります
    Application.Templates( _
        "%APPDATA%\Microsoft\Document Building Blocks\1041\16\Built-In Building Blocks.dotx" _
        ).BuildingBlockEntries("社外秘 1").Insert Where:=Selection.Range, RichText:= _
        True
End Sub

今回社外秘をマクロで記録してびっくりしたのは、これ社外秘っていう名前で日本語版のWord Version 16だって指定してる点です。
ListImageと同じでローカルから呼び出している点で問題があり、配布に向いていないです。
どうしてもこういう透かしが使いたい場合には、PDFやXPSで出力したほうがいいです。そうではない場合は文中にテキストボックスで示す、ヘッダーやフッターでテキストで表示する方がいいです。また、コピーを妨害したいのなら、印刷するときにPrinterで設定する方がいいです。ヘッダーを使ったことすらこのコードではわからない。また、ヘッダーからぶら下がるという極めて特殊な構造で、バグの予感しかしません。
また、マクロの記録からは透かしの削除は記録されません。
こうした点で透かしには問題があります。
また見た目も見づらくなり、間違いが生じる原因で効率が非常に悪いです。
なので、出力するときに設定するか、PDFにするか、プリンターで印刷するとき出力するかの手段で直接Wordに書き込むことは避けましょう。
ヘッダーの画像は本来、会社のマークを入れるといったデザインのために存在しているので、透かしためにあるものではありません。どうも無理やり透かし機能をいれた感じですし、見たことがない構造です。