【第3回】Word VBA：Wordファイルを綺麗にHTML化（その２）

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

今回のポイントは、

・文字のタイピング：Selection.Typetext("～")

・文字は""アリ、変数は""ナシ

・For～Nextによるループ

の３つでした！表の検索方法と、数式の検索方法が違うことも結構なノウハウかなと思います。

Sub 知財系DX派HTML化()
'まずは変数を定義する！
Dim path As String, docName As String, docName2 As String, cursorNum As Long
path = ActiveDocument.path '現在ファイルのpathを取得
docName = ActiveDocument.Name '現在ファイル名を取得
docName2 = Left(docName, InStrRev(docName, ".") - 1) '現在ファイル名の拡張子なしを取得
'現在のカーソル位置を記憶しておく
cursorNum = Selection.Start
'コピーの準備
Call 検索用ページの準備

''【第３回の追加分】ここから
'変数をさらに定義
Dim tbl As Object, img As Object, i As Long

With Selection.Find
'識別子を消しておく
   .MatchFuzzy = False
   .MatchWildcards = False
   .Text = "◆ﾘｸﾚｰﾑ1◆"
   .Replacement.Text = ""
   .Execute Replace:=wdReplaceAll
   .Text = "◆ﾘｸﾚｰﾑ2~◆"
   .Replacement.Text = ""
   .Execute Replace:=wdReplaceAll
   
   .Text = "◆ｺｺﾏﾃﾞ◆"
   .Replacement.Text = ""
   .Execute Replace:=wdReplaceAll
   .ClearFormatting
   .Replacement.ClearFormatting
End With

'表を画像に変換
Selection.HomeKey Unit:=wdStory, Extend:=wdMove
For Each tbl In ActiveDocument.Tables
   tbl.Select
   Selection.Cut
   Selection.PasteAndFormat Type:=wdChartPicture
Next tbl
'数式を画像に変換
Selection.HomeKey Unit:=wdStory, Extend:=wdMove
With Selection.Find
   .MatchFuzzy = False
   .MatchWildcards = False
   .Text = ""
   .Font.Name = "Cambria Math"
   Do While .Execute
     Selection.Cut
     Selection.PasteAndFormat Type:=wdChartPicture
   Loop
End With
Selection.Find.ClearFormatting
Selection.Find.Replacement.ClearFormatting

'まっさらなページを作成
Call 検索用ページの準備
'各画像に改ページを入れる
Selection.HomeKey Unit:=wdStory, Extend:=wdMove
tmp = 0
For Each img In ActiveDocument.InlineShapes
   img.Select
   Selection.Start = tmp
   Selection.End = Selection.End - 1
   Selection.Delete
   Selection.Start = Selection.Start + 2
'    Selection.End = Selection.End + 1
   Selection.TypeText (Chr(12))
   tmp = Selection.Start
Next img
Selection.EndKey Unit:=wdStory, Extend:=wdMove
Selection.Start = tmp - 1
Selection.Delete
'あとでキャプチャするために「キャプチャ用」としてPDF化しておく
ActiveDocument.ExportAsFixedFormat OutputFileName:=path & "\" & "画像キャプチャ用" & ".pdf", ExportFormat:=wdExportFormatPDF
ActiveDocument.ActiveWindow.Close DoNotSave
'画像を★画像★に変換
Selection.HomeKey Unit:=wdStory, Extend:=wdMove
For Each img In ActiveDocument.InlineShapes
   img.Select
   Selection.Delete
   Selection.TypeText ("★画像★")
Next img

'図面の欄があるかどうかチェック
Selection.HomeKey Unit:=wdStory, Extend:=wdMove
With Selection.Find
   .MatchFuzzy = False
   .MatchWildcards = True
   .Text = "【書類名】図面"
   If Not .Execute Then
       '図面の数を数えておく
       Selection.HomeKey Unit:=wdStory, Extend:=wdMove
           .MatchFuzzy = False
           .MatchWildcards = True
           .Text = "【図[０-９]"
           i = 0
           Do While .Execute
             Selection.Start = Selection.End
             i = i + 1
           Loop
       '図面の欄を追加
       If i > 0 Then
       Selection.EndKey Unit:=wdStory, Extend:=wdMove
       Selection.TypeText (Chr(13) & Chr(13) & Chr(13) & "【書類名】図面" & Chr(13))
       For J = 1 To i
       Selection.TypeText ("【図" & J & "】" & Chr(13) & "★図面★" & Chr(13))
       Next
       End If
   End If
End With
Selection.Find.ClearFormatting
Selection.Find.Replacement.ClearFormatting
'★画像★をイメージタグに変換
Selection.HomeKey Unit:=wdStory, Extend:=wdMove 'カーソルをホームに飛ばす
With Selection.Find
   .MatchFuzzy = False
   .MatchWildcards = False
   .Text = "★画像★"
   i = 0
   Do While .Execute
     i = i + 1
     Selection.TypeText ("<img src=image/" & i & ".jpg>")
   Loop
End With
Selection.Find.ClearFormatting
Selection.Find.Replacement.ClearFormatting
'★図面★をイメージタグに変換
Selection.HomeKey Unit:=wdStory, Extend:=wdMove
With Selection.Find
   .MatchFuzzy = False
   .MatchWildcards = False
   .Text = "★図面★"
   i = 0
   Do While .Execute
     i = i + 1
     Selection.TypeText ("<img src=fig/" & i & ".jpg>")
   Loop
End With
Selection.Find.ClearFormatting
Selection.Find.Replacement.ClearFormatting
''【第３回の追加分】ここまで
'各種置換処理
Selection.HomeKey Unit:=wdStory, Extend:=wdMove
With Selection.Find
'改行タグを入れる。
   .MatchFuzzy = False
   .MatchWildcards = True
   .Text = "◆付記：◆"
   .Replacement.Text = "<br>^13"
   .Execute Replace:=wdReplaceAll
   .ClearFormatting
   .Replacement.ClearFormatting
'改行タグを入れる。
   .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