【第1回】Word VBA:Wordファイルを綺麗にHTML化
2021/07/26の第1回の配信が完了しました。ご視聴いただきありがとうございました。
今回のポイントは、
・カーソル位置の制御:Selection.start / Selection.end
・置換/検索:Selection.find
の2つでした!ワイルドカード等も登場するので少しずつ慣れていきましょう。次回もよろしくおねがいします。
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
この記事が気に入ったらサポートをしてみませんか?