html から ePub を作成

平野啓一郎さんに、新聞連載小説「本心」という作品があります。
近未来を舞台にして、「バーチャル・フィギュア」や「リアル・アバターという職業」が登場する、興味深い心理小説です。
この小説は、バックナンバーを含めて、４日遅れで、「東京新聞」のニュースサイトで読むことができます。

ここで、この小説を、個人使用の範囲で、オフラインで読めるように ePub に変換する方法を紹介します。
このサイトで紹介しているツールの使い方の、具体的な事例になっています。

注：6月に「東京新聞」の形式が変更になったので、これに合わせて変更しました。

Excel VBA 目次

索引

ePub 作成手順

１．Website Explorer を使って、記事一覧からページ内容を一括ダウンロードする。
　スタートアドレス：
https://www.tokyo-np.co.jp/f/series/honshin
　サイトに含めるアドレスのキーワード：
=honshin
　フィルタ
フォルダ階層を 3 (4 以上にしても画像は直接取得できない (^^ゞ)

ダウンロードする対象
　本文：article フォルダに
www.tokyo-np.co.jp/article/

２．article フォルダで「honshin_imageURLvba02.xls」を使って jpg のURLを取得

３．「ルビUTF8」フォルダを作成し、その下に「image」フォルダを作成する。

４．「Free Download Manager」に、２で取得した jpg のURLをクリップボード貼付けして、 jpg ファイルを取得して「image」フォルダに登録する。
　例：
https://static.tokyo-np.co.jp/image/article/size1/1/f/2/1/1f2183416cbc2b0871947a07ee03c97e_1.jpg

５．「作業」フォルダを作成し、article フォルダの html をコピーする。

６．「作業」フォルダで、「DelScriptHeaderFooterUTF8vba01.xls」を使って、
HTML から、本文以外(ヘッダーとフッターなど)を削除する。

７．html のファイル名を昇順にならべられるように、ChangeFileNameByTitleVBA**.xls を使って、html の Titleタグから番号を取得して、ファイル名の頭に付加する。

８．RubyTagFromParenthesesUTF8vba**.xls を使って、ルビUTF8 フォルダの HTML を、ルビ・タグに変換する。 *_Ruby.html が作成される。
　たとえば、言い果（おお）せるを、果(おお) に変換

９．「ルビUTF8」フォルダに、作成した *_Ruby.html を移動する。

10．Sigil を使って、ルビUTF8 フォルダのファイルを ePub にする。

この種類の目次に戻る↑　索引へ↓　トップページに戻る

UTF8 html から jpg のパスを取得

このマクロをダウンロードできます。honshin_imageURLvba02.xls

Option Explicit

   Dim ファイル名 As String
   Dim キーの文字列 As String
   Dim ファイル数 As Long
   Dim 出力行数 As Integer
   
Sub 現在のフォルダの直下の全てのファイルを対象に処理()

   Dim 対象ファイルの拡張子 As String
   Dim ファイルシステムオブジェクト As Object          ' FileSystemObject
   Dim このExcelブックのフォルダパス As String
   Dim フォルダ As Object
   Dim ファイル As Object

   Dim 開始時刻 As Variant
   Dim 終了時刻 As Variant

    開始時刻 = Now                ' 開始時刻を変数に格納します。
    Application.DisplayStatusBar = True
   
   '★指定した html の存在するフォルダの全ての html ファイルを対象
   ファイル数 = 0
   出力行数 = 0
   
   ThisWorkbook.Worksheets("Sheet1").Activate
   対象ファイルの拡張子 = Range("D1").Value
   キーの文字列 = Range("E1").Value
   
   このExcelブックのフォルダパス = ThisWorkbook.Path
   Set ファイルシステムオブジェクト = CreateObject("Scripting.FileSystemObject")
   Set フォルダ = ファイルシステムオブジェクト.GetFolder(このExcelブックのフォルダパス)
   
   For Each ファイル In フォルダ.Files
   
      ファイル名 = ファイル.Name

      'ファイルの拡張子を調べて、html ファイルのみを、取得対象とする
      If ファイルシステムオブジェクト.GetExtensionName(ファイル名) = 対象ファイルの拡張子 Then
'         If InStr(ファイル名, "8449") > 0 Then Stop
      
         'ファイルが、対象ファイルだったら
         ファイル数 = ファイル数 + 1
         
         If ファイル数 Mod 1000 = 0 Then
            Application.StatusBar = "★☆★" & ファイル数 & " を処理しました。"
         End If
         
         Call 指定したキー文字列を含む行を書き出す

      End If '指定拡張子のファイルのみ
      
   Next '★ファイル

    '**************終了処理*********************
    
   'オブジェクトを解放する
   Set フォルダ = Nothing
   Set ファイルシステムオブジェクト = Nothing

    終了時刻 = Now()
    MsgBox "処理が終了しました。" & Chr(13) & _
    "対象ファイル数：　" & ファイル数 & Chr(13) & _
    "処理時間は、" & Format(終了時刻 - 開始時刻, "nn分ss秒") & " でした。", vbOKOnly
    
End Sub


Private Sub 指定したキー文字列を含む行を書き出す()

   Dim 入力ファイル名 As String
   Dim 入力行 As String
   Dim 入力ADODBストリーム As Object                 ' ADODB.Stream
   Dim 行 As Integer

   '変換対象のファイル名とパス取得(出力ファイル名は決め打ち)
   入力ファイル名 = ThisWorkbook.Path & "\" & ファイル名

   '********************************
   ' 指定ファイルをOPEN(入力モード)
   'ADODB.Stream生成
   Set 入力ADODBストリーム = CreateObject("ADODB.Stream")
       
   With 入力ADODBストリーム
      .Type = 2             'adTypeText Textモード
      .Charset = "UTF-8"    '文字コード（Shift_JIS, Unicodeなど）
      .Open                 'Streamのオープン
      .LoadFromFile (入力ファイル名)
   End With
         
    '*************データの読み込み***********
    Do Until 入力ADODBストリーム.EOS

      ' レコードの読み込み
      入力行 = 入力ADODBストリーム.ReadText(-2) 'adReadLine：ストリームから次の行を読み込み。
      '-1 (adReadAll)だと現在の位置からEOSマーカー方向に、すべてのバイトをストリームから読み込みます。
'      Stop

      'Replace 呼び出しを 3 回行うことで、
      'Cr / CrLf / Lf が混在しているテキストを CrLf 改行に揃える
      入力行 = Replace(入力行, vbCrLf, vbLf, , , vbBinaryCompare)
      入力行 = Replace(入力行, vbCr, vbLf, , , vbBinaryCompare)
      入力行 = Replace(入力行, vbLf, vbCrLf, , , vbBinaryCompare)
      
      'CrLf で区切って、一次元配列に変換
      Dim 行配列() As String
      行配列 = Split(入力行, vbCrLf, , vbBinaryCompare)
      
      For 行 = 0 To UBound(行配列)
         If InStr(行配列(行), キーの文字列) > 0 Then
            出力行数 = 出力行数 + 1
            Range("A1").Cells(出力行数, 1).Value = _
            Mid(行配列(行), InStr(行配列(行), "<img src=") + 10, InStrRev(行配列(行), "jpg") - InStr(行配列(行), "<img src=") - 7)
'            Stop
         End If
      Next 行
      ' 最終行まで繰り返す
   Loop

   ' 指定ファイルをCLOSE
   入力ADODBストリーム.Close
   Set 入力ADODBストリーム = Nothing
   
End Sub

この種類の目次に戻る↑　索引へ↓　トップページに戻る

UTF8 html から、本文以外(ヘッダーとフッターなど)を削除

このマクロをダウンロードできます。DelScriptHeaderFooterUTF8vba01.xls

'======================================================================
' 渡辺　真
' 00：2020/08/28：平野啓一郎 さんの新聞連載小説「本心」の本文抽出用に作成。
' 01：2021/10/07：画像 jpg のパス変更に対応。
'=======================================================================

Option Explicit

Dim 入力ファイル名 As String
Dim 対象入力ファイル名 As String
Dim 対象ファイル数 As Integer
Dim 出力ファイル名 As String
Dim 入力行 As String
Dim Script部分 As Boolean
Dim Header部分 As Boolean
Dim Footer部分 As Boolean
Dim 開始時刻 As Variant
Dim 終了時刻 As Variant


Sub 本文以外削除()

Dim ファイルシステムオブジェクト As Object    ' FileSystemObject
Dim フォルダ As Object
Dim ファイル As Object
Dim 入力ADODBストリーム As Object             ' ADODB.Stream
Dim 出力ADODBストリーム As Object             ' ADODB.Stream

   '変換対象のファイル名とパス取得
   ChDrive ThisWorkbook.Path
   ChDir ThisWorkbook.Path
   
   '変換対象のファイル名とパス取得
   対象ファイル数 = 0

   入力ファイル名 = Application.GetOpenFilename("HTMLファイル,*.html")
   If 入力ファイル名 = "False" Then End
   
   開始時刻 = Now()
   Set ファイルシステムオブジェクト = CreateObject("Scripting.FileSystemObject")
   Set フォルダ = ファイルシステムオブジェクト.GetFolder(Left(入力ファイル名, InStrRev(入力ファイル名, "\") - 1))
   
   '★上で指定したフォルダ内の、全てのファイルを対象に検索
   For Each ファイル In フォルダ.Files
   
      入力ファイル名 = ファイル.Path
      Application.StatusBar = False 'ステータスバーの表示をクリア
      
      If Right(入力ファイル名, 4) = "html" And Right(入力ファイル名, 14) <> "_Testatum.html" Then
         対象入力ファイル名 = 入力ファイル名
         対象ファイル数 = 対象ファイル数 + 1
      
          'ファイルのオープン。
    
         ' 指定ファイルをOPEN(入力モード)
         'ADODB.Stream生成
         Set 入力ADODBストリーム = CreateObject("ADODB.Stream")
         
         With 入力ADODBストリーム
            .Type = 2            'adTypeText Textモード
            .Charset = "UTF-8"   '文字コード（Shift_JIS, Unicodeなど）
            .LineSeparator = 10  '改行コードをLFとするため10を指定 adLF：LF (Unix)
            .Open              'Streamのオープン
            .LoadFromFile (入力ファイル名)
         End With
         
         出力ファイル名 = Left(入力ファイル名, Len(入力ファイル名) - 5) & "_Testatum" & ".html"
    
         ' 出力用の UTF-8 の"ADODB.Stream"オブジェクトを得る
         Set 出力ADODBストリーム = CreateObject("ADODB.Stream")
         
         'UTF-8形式で保存する
         With 出力ADODBストリーム
            .Type = 2            'adTypeText
            .Charset = "UTF-8"
            .Open
            .LineSeparator = -1   ' adCRLF -1 改行復帰行送り
         End With
      
         '*************データの読み込み***********
         
         Script部分 = False
         Header部分 = False
         Footer部分 = False
         
         Do Until 入力ADODBストリーム.EOS
                     
            ' レコードの読み込み
            入力行 = 入力ADODBストリーム.ReadText(-2) '-2 adReadLine
'            Stop
            
            If InStr(入力行, "<!DOCTYPE html>") > 0 Then
               入力行 = "<!DOCTYPE html PUBLIC ""-//W3C//DTD XHTML 1.0 Transitional//EN"">"
            ElseIf InStr(入力行, "<body class=""tokyo"">") > 0 Then
               入力行 = "<body class=""tokyo""><div><div><div><div>"
            ElseIf InStr(入力行, "<div class=""content-area"">") > 0 Then
               入力行 = ""
            ElseIf InStr(入力行, "<div class=""l-wrapper"">") > 0 Then
               入力行 = ""
            ElseIf InStr(入力行, "<div class=""l-container""") > 0 Then
               入力行 = ""
            ElseIf InStr(入力行, "<a href=") > 0 Then
               入力行 = ""
            ElseIf InStr(入力行, "</a>") > 0 Then
               入力行 = ""
            ElseIf InStr(入力行, "<iframe") > 0 Then
               入力行 = ""
            ElseIf InStr(入力行, "</body>") > 0 Then
               入力行 = "</div></body>"
            ElseIf InStr(入力行, "<script") > 0 And InStr(入力行, "</script>") > 0 Then
               入力行 = ""
            ElseIf InStr(入力行, "<link ") > 0 Then
               入力行 = ""
            ElseIf InStr(入力行, "<meta property") > 0 Then
               入力行 = ""
            ElseIf InStr(入力行, "<meta name") > 0 Then
               入力行 = ""
            End If
            
            If InStr(入力行, "<!-- Google Tag Manager (noscript)-->") > 0 Then
               Header部分 = True
            ElseIf InStr(入力行, "cmp-hdg001") > 0 And Header部分 = True Then
               Header部分 = False
            ElseIf InStr(入力行, "<div class=""clear"">") > 0 Then
               Footer部分 = True
            ElseIf InStr(入力行, "<!-- service worker:end -->") > 0 And Footer部分 = True Then
               Footer部分 = False
               入力行 = ""
            ElseIf InStr(入力行, "<script") > 0 Then
               Script部分 = True
            ElseIf InStr(入力行, "</script>") > 0 And Script部分 = True Then
               Script部分 = False
               入力行 = ""
            End If
            
            If Script部分 = True Or Header部分 = True Or Footer部分 = True Then
               入力行 = ""
            End If
            
            If InStr(入力行, "<img src=") > 0 = True Then
            入力行 = 正規表現で置換("<img src=""https://static.tokyo-np.co.jp/image/article/.*?/([_0-9a-z]*.jpg)"" alt=""(.*)""", 入力行, "<img src=""image/$1"" alt=""$2"" width=""610"" height=""416"" ")
            End If
            
            If InStr(入力行, "本心<") > 0 = True Then
               入力行 = 正規表現で置換("本心<([0-9]+)>", 入力行, "本心＜$1＞")
            End If

            If Trim(入力行) <> "" Then
               出力ADODBストリーム.WriteText 入力行, 1    '//0:改行無し 1:改行有り
            End If

              ' 最終行まで繰り返す
          Loop
          
         出力ADODBストリーム.SaveTofile (出力ファイル名), 2 'adSaveCreateOverWrite 上書きを許す
   
         ' 指定ファイルをCLOSE
         入力ADODBストリーム.Close
         Set 入力ADODBストリーム = Nothing
         
         出力ADODBストリーム.Close
         Set 出力ADODBストリーム = Nothing
   
      End If
      Application.StatusBar = 対象入力ファイル名 & " 処理完了"

   Next '★ファイル
   
   '★上で指定したフォルダ内の、全てのファイルを対象に検索
   For Each ファイル In フォルダ.Files
      入力ファイル名 = ファイル.Path
      If Right(入力ファイル名, 4) = "html" And InStr(入力ファイル名, "_") = 0 Then '変更後ファイルを削除しないように
         Kill 入力ファイル名
      End If
   Next '★ファイル
   
'   Stop
   For Each ファイル In フォルダ.Files
      入力ファイル名 = ファイル.Path
      If Right(入力ファイル名, 4) = "html" And Right(入力ファイル名, 14) = "_Testatum.html" Then
'         Stop
         Name 入力ファイル名 As Left(入力ファイル名, Len(入力ファイル名) - 14) & ".html"
      End If
   Next '★ファイル
   
   'クローズ
   Set ファイルシステムオブジェクト = Nothing

    '**************終了処理*********************
    Application.StatusBar = 対象入力ファイル名 & " ファイル処理完了"
    
    終了時刻 = Now()
    MsgBox "処理が終了しました。" & Chr(13) & _
    "処理時間は、" & Format(終了時刻 - 開始時刻, "nn分ss秒") & " でした。", vbOKOnly
    
End Sub



'正規表現で置換
'http://codezine.jp/article/detail/1655?p=3
'[引数]
'正規表現パターン
'検索文字列
'置換文字列
'[返り値]
'検索文字列内に正規表現パターンが見つかった場合：置換文字列に置き換えた結果を返す
'検索文字列内に正規表現パターンが見つからなかった場合
'：検索文字列に変更を加えずそのまま返す
Function 正規表現で置換(正規表現パターン As String, 検索文字列 As String, 置換文字列 As String) As String
    Dim 正規表現 As RegExp               ' 変数を作成します。
    Set 正規表現 = New RegExp            ' 正規表現を作成します。
    正規表現.Pattern = 正規表現パターン  ' パターンを設定します。
    正規表現.Global = True               ' 一致するもの全てを対象とするように設定します。
    正規表現で置換 = 正規表現.Replace(検索文字列, 置換文字列)   ' 置換します。
End Function

この種類の目次に戻る↑　索引へ↓　トップページに戻る

HTMLの Titleタグの内容をファイル名に付加する(UTF8)

ファイル名置換対象の html ファイルと同じフォルダに登録します。

このマクロをダウンロードできます。→ChangeFileNameByTitleVBA00.xls

Option Explicit

'00：2020/06/13：html のファイル名を Title タグから設定するために作成

Dim 旧ファイル名 As String
Dim 新ファイル名 As String

Sub タイトル抽出()

   Dim 入力ファイル名 As String
   Dim 対象ファイル数 As Integer
   Dim 入力行 As String
   Dim 番号 As String

   Dim ファイルシステムオブジェクト As Object    ' FileSystemObject
   Dim 入力ADODBストリーム As Object             ' ADODB.Stream
   Dim フォルダ As Object
   Dim ファイル As Object
   Dim 開始時刻 As Variant
   Dim 終了時刻 As Variant
   Dim 桁 As Integer
   
   '変換対象のファイル名とパス取得
   ChDrive ThisWorkbook.Path
   ChDir ThisWorkbook.Path
   
   '変換対象のファイル名とパス取得
   対象ファイル数 = 0

   入力ファイル名 = Application.GetOpenFilename("HTMLファイル,*.html")
   If 入力ファイル名 = "False" Then End
   
   開始時刻 = Now()
   Set ファイルシステムオブジェクト = CreateObject("Scripting.FileSystemObject")
   Set フォルダ = ファイルシステムオブジェクト.GetFolder(Left(入力ファイル名, InStrRev(入力ファイル名, "\") - 1))
   
   '★上で指定したフォルダ内の、全てのファイルを対象に検索
   For Each ファイル In フォルダ.Files
   
      入力ファイル名 = ファイル.Path
      Application.StatusBar = False 'ステータスバーの表示をクリア
      
      If Right(入力ファイル名, 4) = "html" And InStr(入力ファイル名, "_") = 0 Then '変更後ファイルを再読みしないように
         旧ファイル名 = 入力ファイル名
'         D:\epub\本心old\作業\31449Prct=honshin.html

         対象ファイル数 = 対象ファイル数 + 1
         番号 = ""

         'ファイルのオープン。
         '指定ファイルをOPEN(入力モード)
         'ADODB.Stream生成
         Set 入力ADODBストリーム = CreateObject("ADODB.Stream")
         
         With 入力ADODBストリーム
            .Type = 2          'adTypeText Textモード
            .Charset = "UTF-8" '文字コード（Shift_JIS, Unicodeなど）
            .Open              'Streamのオープン
            .LoadFromFile (入力ファイル名)
         End With
         
         '*************データの読み込み***********
         Do Until 入力ADODBストリーム.EOS
            
            ' レコードの読み込み
            入力行 = 入力ADODBストリーム.ReadText(-2) '-2 adReadLine
              
'            <title>本心<256></title>
'            <title>平野啓一郎さんに聞く（動画あり）　ＡＩ時代の人間を問う</title>

            If InStr(入力行, "<title>") > 0 Then
               If InStr(入力行, "本心") > 0 Then
                  If Mid(入力行, 12, 1) = ">" Or Mid(入力行, 12, 1) = "＞" Then
                     番号 = "00" & Mid(入力行, 11, 1)
                  ElseIf Mid(入力行, 13, 1) = ">" Or Mid(入力行, 13, 1) = "＞" Then
                     番号 = "0" & Mid(入力行, 11, 2)
                  ElseIf Mid(入力行, 14, 1) = ">" Or Mid(入力行, 14, 1) = "＞" Then
                     番号 = Mid(入力行, 11, 3)
                  End If
               Else
                  番号 = "000"
               End If
               
               桁 = InStrRev(旧ファイル名, "\")
               新ファイル名 = Left(旧ファイル名, 桁) & 番号 & "_" & Right(旧ファイル名, Len(旧ファイル名) - 桁)
         
'         Stop
         
               Call ファイル名変更
               
               Exit Do
            End If
              ' 最終行まで繰り返す
          Loop
          
         ' 指定ファイルをCLOSE
         入力ADODBストリーム.Close
         Set 入力ADODBストリーム = Nothing
         
      End If

   Next '★ファイル
   'クローズ

   Set ファイルシステムオブジェクト = Nothing
   

    '**************終了処理*********************
    Application.StatusBar = "全 " & 対象ファイル数 & " ファイル処理完了"
    
    終了時刻 = Now()
    MsgBox "処理が終了しました。" & Chr(13) & _
    "処理時間は、" & Format(終了時刻 - 開始時刻, "nn分ss秒") & " でした。", vbOKOnly

End Sub

Private Sub ファイル名変更()
         
      On Error Resume Next
      
      If Dir(新ファイル名) = "" _
      And Dir(旧ファイル名) <> "" Then '新ファイル名が存在せず、旧をファイル名が存在する場合
'         Debug.Print 旧ファイル名 & vbNewLine & 新ファイル名
         Name 旧ファイル名 As 新ファイル名
      End If
   
End Sub

この種類の目次に戻る↑　索引へ↓　トップページに戻る

文中の（）を、HTMLのルビ・タグに変更する(UTF8)

「青空文庫」のルビを、HTMLのルビ・タグに変更する(UTF8版) を微修正したものです。
置換対象の html ファイルと同じフォルダに登録します。

このマクロをダウンロードできます。→RubyTagFromParenthesesUTF8vba00.xls

Option Explicit

Dim 入力ファイル名 As String
Dim 対象入力ファイル名 As String
Dim 対象ファイル数 As Integer
Dim 出力ファイル名 As String
Dim 入力行 As String
Dim 出力行 As String
Dim 入力行文字数 As Integer
Dim bodyフラグ As Integer
Dim 処理行カウンタ As Integer
Dim 検索文字目 As Integer
Dim 漢字字数 As Integer
Dim ルビ字数 As Integer
Dim 地文字数 As Integer
Dim 地文字フラグ As Integer
Dim ルビ文字フラグ As Integer
Dim 漢字文字フラグ As Integer
Dim 開始時刻 As Variant
Dim 終了時刻 As Variant


Sub ルビタグ変換()

Dim ファイルシステムオブジェクト As Object    ' FileSystemObject
Dim 入力ADODBストリーム As Object             ' ADODB.Stream
Dim 出力ADODBストリーム As Object             ' ADODB.Stream
Dim フォルダ As Object
Dim ファイル As Object

   '変換対象のファイル名とパス取得
   ChDrive ThisWorkbook.Path
   ChDir ThisWorkbook.Path
   
   '変換対象のファイル名とパス取得
   対象ファイル数 = 0

    
   入力ファイル名 = Application.GetOpenFilename("HTMLファイル,*.html")
   If 入力ファイル名 = "False" Then End
   
   開始時刻 = Now()
   Set ファイルシステムオブジェクト = CreateObject("Scripting.FileSystemObject")
   Set フォルダ = ファイルシステムオブジェクト.GetFolder(Left(入力ファイル名, InStrRev(入力ファイル名, "\") - 1))
   
   '★上で指定したフォルダ内の、全てのファイルを対象に検索
   For Each ファイル In フォルダ.Files
   
      入力ファイル名 = ファイル.Path
      Application.StatusBar = False 'ステータスバーの表示をクリア
      
      If Right(入力ファイル名, 4) = "html" And Right(入力ファイル名, 10) <> "_Ruby.html" Then
         対象入力ファイル名 = 入力ファイル名
         対象ファイル数 = 対象ファイル数 + 1
      
          'ファイルのオープン。
         bodyフラグ = 0
         処理行カウンタ = 0
    
         ' 指定ファイルをOPEN(入力モード)
         'ADODB.Stream生成
         Set 入力ADODBストリーム = CreateObject("ADODB.Stream")
         
         With 入力ADODBストリーム
            .Type = 2          'adTypeText Textモード
            .Charset = "UTF-8" '文字コード（Shift_JIS, Unicodeなど）
            .Open              'Streamのオープン
            .LoadFromFile (入力ファイル名)
         End With
         
         出力ファイル名 = Left(入力ファイル名, Len(入力ファイル名) - 5) & "_Ruby" & ".html"
    
         ' 出力用の UTF-8 の"ADODB.Stream"オブジェクトを得る
         Set 出力ADODBストリーム = CreateObject("ADODB.Stream")
         
         'UTF-8形式で保存する
         With 出力ADODBストリーム
            .Type = 2            'adTypeText
            .Charset = "UTF-8"
            .Open
            .LineSeparator = 10  'adLF：LF (Unix)
         End With
      
         '*************データの読み込み***********
         Do Until 入力ADODBストリーム.EOS
         
            処理行カウンタ = 処理行カウンタ + 1
            
            ' レコードの読み込み
            入力行 = 入力ADODBストリーム.ReadText(-2) '-2 adReadLine
              
            出力行 = 入力行
            
            If Trim(入力行) = "</body>" Then
                bodyフラグ = 0
            End If
            
            If bodyフラグ = 1 Then
                Call 本文処理  '★★★★★★★★★
            End If
              
            If Left(Trim(入力行), 5) = "<body" Then
                bodyフラグ = 1
            End If
            
            If Trim(入力行) <> "" Then
               出力ADODBストリーム.WriteText 出力行, 1    '//0:改行無し 1:改行有り
            End If

              ' 最終行まで繰り返す
          Loop
          
         出力ADODBストリーム.SaveTofile (出力ファイル名), 2 'adSaveCreateOverWrite 上書きを許す
   
         ' 指定ファイルをCLOSE
         入力ADODBストリーム.Close
         Set 入力ADODBストリーム = Nothing
         
         出力ADODBストリーム.Close
         Set 出力ADODBストリーム = Nothing
   
      End If
      Application.StatusBar = 対象入力ファイル名 & " 最終 " & 処理行カウンタ & " 最終行まで読込み完了"

   Next '★ファイル
   'クローズ

   Set ファイルシステムオブジェクト = Nothing
   

    '**************終了処理*********************
    Application.StatusBar = 対象入力ファイル名 & " " & 処理行カウンタ & " 行。全 " & 対象ファイル数 & " ファイル処理完了"
    
    終了時刻 = Now()
    MsgBox "処理が終了しました。" & Chr(13) & _
    "処理時間は、" & Format(終了時刻 - 開始時刻, "nn分ss秒") & " でした。", vbOKOnly

End Sub


Private Sub 本文処理()
    出力行 = ""
    地文字数 = 0
    漢字字数 = 0
    ルビ字数 = 0
    漢字文字フラグ = 0
    ルビ文字フラグ = 0
    地文字フラグ = 1 '地文字とは、ルビでない部分
    
    入力行文字数 = Len(入力行)
    
    For 検索文字目 = 入力行文字数 To 1 Step -1 '一行ずつ、行末から処理していく
    
        If Mid(入力行, 検索文字目, 1) = ">" Then
            地文字フラグ = 1
        End If
    
        If ルビ文字フラグ = 1 Then
            ルビ字数 = ルビ字数 + 1
        ElseIf 漢字文字フラグ = 1 Then
            漢字字数 = 漢字字数 + 1
        ElseIf 地文字フラグ = 1 Then
            地文字数 = 地文字数 + 1
        End If
        
        
        If 漢字文字フラグ = 1 And Mid(入力行, 検索文字目, 1) = "）" Then   '★★6月5日追加
         '★右括弧）の左が「かな」でなければルビでないと判定
         '該当１：（平野啓一郎・作、菅実花・画）
         '該当２：「Ｏｎ　ｔｈｅ　ｉｎｔｅｒｎｅｔ，　ｍｏｒｅ　ｔｈａｎ　９０００　ｐｅｏｐｌｅ　ｐｒａｉｓｅｄ
         'ｔｈｉｓ　ｂｒａｖｅ　ｍａｎ　ｆｏｒ　ｈｉｓ　ｎｏｎ－ｖｉｏｌｅｎｔ　ｒｅｓｉｓｔａｎｃｅ　ｔｏ　ａ　ｒａｃｉｓｔ．
         '（差別主義者に対する、この勇敢な男性の非暴力的な抗議に、ネットでは九〇〇〇人以上が賞賛（しょうさん）を送っている。）」という一文が表示された。
            If Mid(入力行, 検索文字目 - 1, 1) Like "[あ-ん]" Then
               出力行 = "</rt><rp>)</rp></ruby><ruby><rb>" _
               & Mid(入力行, 検索文字目 + 1, 漢字字数 - 1) & 出力行
               
               漢字字数 = 0
               漢字文字フラグ = 0
               
               地文字数 = 0
               ルビ字数 = 0     '前回のルビ字数をリセット
               地文字フラグ = 0
               ルビ文字フラグ = 1
            End If
        
        ElseIf Mid(入力行, 検索文字目, 1) = "）" Then
        '★右括弧）の左が「かな」でなければルビでないと判定
            If Mid(入力行, 検索文字目 - 1, 1) Like "[あ-ん]" Then
               出力行 = "</rt><rp>)</rp></ruby>" & Mid(入力行, 検索文字目 + 1, 地文字数 - 1) & 出力行
               地文字数 = 0
               ルビ字数 = 0     '前回のルビ字数をリセット
               地文字フラグ = 0
               ルビ文字フラグ = 1
            End If
        ElseIf Mid(入力行, 検索文字目, 1) = "（" And ルビ文字フラグ = 1 Then
        '★ルビでない左括弧（を排除するため・・・・・・・↑
            出力行 = "</rb><rp>(</rp><rt>" & Mid(入力行, 検索文字目 + 1, ルビ字数 - 1) & 出力行
            漢字字数 = 0     '前回の漢字字数をリセット
            ルビ文字フラグ = 0
            漢字文字フラグ = 1
            
        ElseIf 漢字文字フラグ = 1 And (Mid(入力行, 検索文字目, 1) = "｜" _
        Or Mid(入力行, 検索文字目, 1) = "│") Then      '"｜"JIS 8162は記号の縦線。"│"JIS 84A0は罫線の縦線
            '★ガリバー対応★★★★6月5日追加
            出力行 = "<ruby><rb>" & Mid(入力行, 検索文字目 + 1, 漢字字数 - 1) & 出力行
            漢字字数 = 0
            漢字文字フラグ = 0
            地文字フラグ = 1
            
        ElseIf 漢字文字フラグ = 1 And (Mid(入力行, 検索文字目, 1) = "（" _
        Or Mid(入力行, 検索文字目, 1) = "）") Then       '（例）１円山応挙《まるやまおうきょ》
            '★夜明け前対応★★★★6月6日追加
            出力行 = "<ruby><rb>" & Mid(入力行, 検索文字目 + 1, 漢字字数 - 1) & 出力行
            漢字字数 = 0
            漢字文字フラグ = 0
            地文字フラグ = 1
            地文字数 = 1    '地のところまで侵食したため戻す
            
            
        ElseIf ルビ字数 > 0 And 漢字字数 = ルビ字数 Then
            出力行 = "<ruby><rb>" & Mid(入力行, 検索文字目 + 1, 漢字字数 - 1) & 出力行
            漢字字数 = 0
            漢字文字フラグ = 0
            地文字フラグ = 1
            地文字数 = 1    '地のところまで侵食したため戻す

            
'        ElseIf Mid(入力行, 検索文字目 + 1, 1) >= "亜" And 漢字字数 > 1 _
'        And Mid(入力行, 検索文字目, 1) < "亜" Then  '★つぐみ対応★★★★6月5日追加

        ElseIf Mid(入力行, 検索文字目 + 1, 1) > "ヶ" And 漢字字数 > 1 _
           And Mid(入力行, 検索文字目, 1) <= "ヶ" _
           And Mid(入力行, 検索文字目, 1) <> "々" Then               '★大丈夫対応★★★★6月5日追加
              出力行 = "<ruby><rb>" & Mid(入力行, 検索文字目 + 1, 漢字字数 - 1) & 出力行
              漢字字数 = 0
              漢字文字フラグ = 0
              地文字フラグ = 1
              地文字数 = 1    '地のところまで侵食したため戻す
              
        ElseIf 漢字文字フラグ = 1 And 検索文字目 = 1 Then    '行頭の漢字
            '★夜明け前対応★★★★6月8日追加
            出力行 = "<ruby><rb>" & Mid(入力行, 検索文字目, 漢字字数) & 出力行
            漢字字数 = 0
            漢字文字フラグ = 0

        End If
    
'       If 処理行カウンタ = 71 Then Stop  '●●▲●●
    
    Next 検索文字目
    
    If 地文字フラグ = 1 And 地文字数 > 0 Then
        出力行 = Mid(入力行, 検索文字目 + 1, 地文字数) & 出力行
    End If

End Sub

この種類の目次に戻る↑　索引へ↓　トップページに戻る

文中の（）を、HTMLのルビ・タグに変更する(Shift JIS)

「青空文庫」のルビを、HTMLのルビ・タグに変更するを微修正したものです。
置換対象の html ファイルと同じフォルダに登録します。

このマクロをダウンロードできます。→RubyTagFromParenthesesVBS01.xls

Option Explicit

Dim 入力ファイル名 As String
Dim 出力ファイル名 As String
Dim 入力行 As String
Dim 出力行 As String
Dim 入力行文字数 As Integer
Dim bodyフラグ As Integer
Dim 処理行カウンタ As Integer
Dim 検索文字目 As Integer
Dim 漢字字数 As Integer
Dim ルビ字数 As Integer
Dim 地文字数 As Integer
Dim 地文字フラグ As Integer
Dim ルビ文字フラグ As Integer
Dim 漢字文字フラグ As Integer
Dim ファイルシステムオブジェクト As Object          ' FileSystemObject


Sub 対象ファイルを取得()

   Dim カウンタ As Integer
   Dim フォルダ As Object
   Dim ファイル As Object
   Dim 開始日時 As Variant
   Dim 終了日時 As Variant

   開始日時 = Now                ' 開始時刻を変数に格納します。

   Application.DisplayStatusBar = True

   Set ファイルシステムオブジェクト = CreateObject("Scripting.FileSystemObject")

   Set フォルダ = ファイルシステムオブジェクト.GetFolder(ThisWorkbook.Path)

   '★自身のExcelの存在するフォルダの全てのファイルを対象
   For Each ファイル In フォルダ.Files

      入力ファイル名 = ファイル.Path

      If LCase(Right(入力ファイル名, Len(入力ファイル名) - InStrRev(入力ファイル名, "."))) = "html" Then

         カウンタ = カウンタ + 1
         Application.StatusBar = カウンタ & "　" & Dir(入力ファイル名)
         
         Call ルビタグ変換

     End If

   Next '★ファイル

   Set フォルダ = Nothing
   Set ファイルシステムオブジェクト = Nothing

   終了日時 = Now
   MsgBox "処理を終了しました。" & vbNewLine _
   & "処理ファイル数：　" & カウンタ & vbNewLine _
   & "処理時間は、" _
   & Format(終了日時 - 開始日時, "hh時間nn分ss秒") & " でした。"
End Sub


Private Sub ルビタグ変換()

Dim 入力テキストストリームオブジェクト As Object    ' TextStream
Dim 出力テキストストリームオブジェクト As Object    ' TextStream

    出力ファイル名 = Left(入力ファイル名, Len(入力ファイル名) - 5) & "_Ruby" & ".html"
        
    '********************************
    'ファイルのオープン。
    bodyフラグ = 0
    処理行カウンタ = 0
    
    ' 指定ファイルをOPEN(入力モード)
    Set 入力テキストストリームオブジェクト = _
    ファイルシステムオブジェクト.OpenTextFile(入力ファイル名, 1)

    ' 指定ファイルをOPEN(出力モード)
    Set 出力テキストストリームオブジェクト = _
    ファイルシステムオブジェクト.CreateTextFile(出力ファイル名)

    '*************データの読み込み***********
     Do Until 入力テキストストリームオブジェクト.AtEndOfStream
        処理行カウンタ = 処理行カウンタ + 1
        
        ' レコードの読み込み
        入力行 = 入力テキストストリームオブジェクト.ReadLine

        出力行 = 入力行
        
        If Trim(入力行) = "</body>" Then
            bodyフラグ = 0
        End If
        
        If bodyフラグ = 1 Then
            Call 本文処理  '★★★★★★★★★
        End If
          
        If Left(Trim(入力行), 5) = "<body" Then
            bodyフラグ = 1
        End If
        
        出力テキストストリームオブジェクト.WriteLine 出力行         ' 改行(CrLf)付き

        ' 最終行まで繰り返す
    Loop
    
    '**************終了処理*********************
    
    ' 指定ファイルをCLOSE
    入力テキストストリームオブジェクト.Close
    Set 入力テキストストリームオブジェクト = Nothing
    出力テキストストリームオブジェクト.Close
    Set 出力テキストストリームオブジェクト = Nothing
    
End Sub


Private Sub 本文処理()
    出力行 = ""
    地文字数 = 0 '地文字とは、ルビでない部分
    漢字字数 = 0
    ルビ字数 = 0
    漢字文字フラグ = 0
    ルビ文字フラグ = 0
    地文字フラグ = 1 '地文字とは、ルビでない部分
    
    入力行文字数 = Len(入力行)
    
    For 検索文字目 = 入力行文字数 To 1 Step -1
    
        If Mid(入力行, 検索文字目, 1) = ">" Then
            地文字フラグ = 1
        End If
    
        If ルビ文字フラグ = 1 Then
            ルビ字数 = ルビ字数 + 1
        ElseIf 漢字文字フラグ = 1 Then
            漢字字数 = 漢字字数 + 1
        ElseIf 地文字フラグ = 1 Then
            地文字数 = 地文字数 + 1
        End If
        
        If 漢字文字フラグ = 1 And Mid(入力行, 検索文字目, 1) = "）" Then   '★★6月5日追加
        '（平野啓一郎・作、菅実花・画）←括弧の左が「かな」でなければルビでないと判定
            If Mid(入力行, 検索文字目 - 1, 1) Like "[あ-ん]" Then
               出力行 = "</rt><rp>)</rp></ruby><ruby><rb>" _
               & Mid(入力行, 検索文字目 + 1, 漢字字数 - 1) & 出力行
               
               漢字字数 = 0
               漢字文字フラグ = 0
               
               地文字数 = 0
               ルビ字数 = 0     '前回のルビ字数をリセット
               地文字フラグ = 0
               ルビ文字フラグ = 1
            End If
        
        ElseIf Mid(入力行, 検索文字目, 1) = "）" Then
        '（平野啓一郎・作、菅実花・画）←括弧の左が「かな」でなければルビでないと判定
            If Mid(入力行, 検索文字目 - 1, 1) Like "[あ-ん]" Then
               出力行 = "</rt><rp>)</rp></ruby>" & Mid(入力行, 検索文字目 + 1, 地文字数 - 1) & 出力行
               地文字数 = 0
               ルビ字数 = 0     '前回のルビ字数をリセット
               地文字フラグ = 0
               ルビ文字フラグ = 1
            End If
            
        ElseIf Mid(入力行, 検索文字目, 1) = "（" And ルビ文字フラグ = 1 Then
            出力行 = "</rb><rp>(</rp><rt>" & Mid(入力行, 検索文字目 + 1, ルビ字数 - 1) & 出力行
            漢字字数 = 0     '前回の漢字字数をリセット
            ルビ文字フラグ = 0
            漢字文字フラグ = 1
            
        ElseIf 漢字文字フラグ = 1 And (Mid(入力行, 検索文字目, 1) = "｜" _
        Or Mid(入力行, 検索文字目, 1) = "│") Then      '"｜"JIS 8162は記号の縦線。"│"JIS 84A0は罫線の縦線
            '★ガリバー対応★★★★6月5日追加
            出力行 = "<ruby><rb>" & Mid(入力行, 検索文字目 + 1, 漢字字数 - 1) & 出力行
            漢字字数 = 0
            漢字文字フラグ = 0
            地文字フラグ = 1
            
        ElseIf 漢字文字フラグ = 1 And (Mid(入力行, 検索文字目, 1) = "（" _
        Or Mid(入力行, 検索文字目, 1) = "）") Then       '（例）１円山応挙《まるやまおうきょ》
            '★夜明け前対応★★★★6月6日追加
            出力行 = "<ruby><rb>" & Mid(入力行, 検索文字目 + 1, 漢字字数 - 1) & 出力行
            漢字字数 = 0
            漢字文字フラグ = 0
            地文字フラグ = 1
            地文字数 = 1    '地のところまで侵食したため戻す
            
        ElseIf ルビ字数 > 0 And 漢字字数 = ルビ字数 Then
            出力行 = "<ruby><rb>" & Mid(入力行, 検索文字目 + 1, 漢字字数 - 1) & 出力行
            漢字字数 = 0
            漢字文字フラグ = 0
            地文字フラグ = 1
            地文字数 = 1    '地のところまで侵食したため戻す
        
        ElseIf Mid(入力行, 検索文字目 + 1, 1) > "ヶ" And 漢字字数 > 1 _
           And Mid(入力行, 検索文字目, 1) <> "々" _
           And Mid(入力行, 検索文字目, 1) <= "ヶ" Then  '★大丈夫対応★★★★6月5日追加
            出力行 = "<ruby><rb>" & Mid(入力行, 検索文字目 + 1, 漢字字数 - 1) & 出力行
            漢字字数 = 0
            漢字文字フラグ = 0
            地文字フラグ = 1
            地文字数 = 1    '地のところまで侵食したため戻す
            
        ElseIf 漢字文字フラグ = 1 And 検索文字目 = 1 Then    '行頭の漢字
            '★夜明け前対応★★★★6月8日追加
            出力行 = "<ruby><rb>" & Mid(入力行, 検索文字目, 漢字字数) & 出力行
            漢字字数 = 0
            漢字文字フラグ = 0

        End If
        
    Next 検索文字目
    
    If 地文字フラグ = 1 And 地文字数 > 0 Then
        出力行 = Mid(入力行, 検索文字目 + 1, 地文字数) & 出力行
    End If

End Sub

この種類の目次に戻る↑　索引へ↓　トップページに戻る