【第1回】Word VBA：Wordファイルを綺麗にHTML化

　2021/07/26の第1回の配信が完了しました。ご視聴いただきありがとうございました。

今回のポイントは、

・カーソル位置の制御：Selection.start / Selection.end

・置換／検索：Selection.find

の２つでした！ワイルドカード等も登場するので少しずつ慣れていきましょう。次回もよろしくおねがいします。

Sub 知財系DX派HTML化()
'まずは変数を定義する！
Dim path As String
Dim docName As String, docName2 As String
Dim cursorNum As Long
path = ActiveDocument.path '現在ファイルのpathを取得
docName = ActiveDocument.Name '現在ファイル名を取得
docName2 = Left(docName, InStrRev(docName, ".") - 1) '現在ファイル名の拡張子なしを取得
'現在のカーソル位置を記憶しておく
cursorNum = Selection.Start
'本文を全選択（ヘッダとフッタは無し！）
Selection.EndKey Unit:=wdStory, Extend:=wdMove 'カーソルをエンドに飛ばす
Selection.Start = 0
'全選択（ヘッダとフッタを含む）
'Selection.WholeStory
'コピー
Selection.Copy
'新規の白紙ページを開く
Documents.Add Template:="Normal", NewTemplate:=False, DocumentType:=0
'ペースト
Selection.Paste
'コメント全削除
Selection.Comments.Add Range:=Selection.Range, _
Text:="a"
ActiveDocument.DeleteAllComments
'変更履歴を反映
ActiveDocument.Revisions.AcceptAll
'各種置換処理
Selection.HomeKey Unit:=wdStory, Extend:=wdMove 'カーソルをホームに飛ばす
With Selection.Find
   
'改行タグを入れる。
   .MatchFuzzy = False
   .MatchWildcards = True
   .Text = "^13"
   .Replacement.Text = "<br>^13"
   .Execute Replace:=wdReplaceAll
   .ClearFormatting
   .Replacement.ClearFormatting
'空白以外で下線がある箇所に下線を引く
   .Text = "([!　])"
   .Font.Underline = wdUnderlineSingle
   .Replacement.Text = "<u>\1</u>"
   .Execute Replace:=wdReplaceAll
   .ClearFormatting
   .Replacement.ClearFormatting
'</u><u>を消す
   .MatchWildcards = False
   .Text = "</u><u>"
   .Replacement.Text = ""
   .Execute Replace:=wdReplaceAll
   .ClearFormatting
   .Replacement.ClearFormatting
'上付きの箇所を上付きにする
   .MatchWildcards = True
   .Text = "(?)"
   .Font.Superscript = True
   .Replacement.Text = "<sup>\1</sup>"
   .Execute Replace:=wdReplaceAll
   .ClearFormatting
   .Replacement.ClearFormatting
'</sup><sup>を消す
   .MatchWildcards = False
   .Text = "</sup><sup>"
   .Replacement.Text = ""
   .Execute Replace:=wdReplaceAll
   .ClearFormatting
   .Replacement.ClearFormatting
'下付きの箇所を下付きにする
   .MatchWildcards = True
   .Text = "(?)"
   .Font.Subscript = True
   .Replacement.Text = "<sub>\1</sub>"
   .Execute Replace:=wdReplaceAll
   .ClearFormatting
   .Replacement.ClearFormatting
   
'</sub><sub>を消す
   .MatchWildcards = False
   .Text = "</sub><sub>"
   .Replacement.Text = ""
   .Execute Replace:=wdReplaceAll
   .ClearFormatting
   .Replacement.ClearFormatting
End With
        
   strDocName = path & "\" & docName2 & ".htm"
   ActiveDocument.SaveAs2 FileName:=strDocName, _
   FileFormat:=wdFormatText
   ActiveDocument.Close DoNotSave '保存せずに表示中の画面を閉じる
   
   '元のカーソル位置に復帰
   Selection.Start = cursorNum
   Selection.End = cursorNum
   
   MsgBox ("HTMLファイルを作成しました！")
End Sub