Excel VBA ファイル操作

Excel VBA のトップに戻る
Excel VBA 目次

索引

ファイルを検索する

下記サイトに分かりやすく書かれています。
Excel VBAでファイル検索する方法を4種類掲載しています。
https://excel-excel.com/tips/vba_68.html

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


ブックを開いて、オブジェクト型変数に格納して活用

 シートやセルのデータを活用するとき、ブックをオブジェクト型変数に格納しておくと、使いたい時にいちいち前面表示(Activate)しなくてもよいので、便利です。
 下記は、使いたいブックを開いて、変数に格納して、処理後に閉じる例です。


Option Explicit

Sub ブックを開いて、オブジェクト型変数に格納して活用()

   Dim コピー元ブックフルパス
   Dim コピー元ブック As Workbook
   
   'コピー元ブック名は、このVBAブックのセルA2に登録してある
   'コピー元ブックは、このVBAブックと同じフォルダに存在する
   コピー元ブックフルパス = ThisWorkbook.Path & "\" _
                     & ThisWorkbook.Worksheets("Sheet1").Range("A2").Value
   
   Set コピー元ブック = Workbooks.Open(コピー元ブックフルパス)
   
   'ここで処理をする
   Stop

   コピー元ブック.Close savechanges:=False           '保存せずにブックを閉じる
      
End Sub

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


フルパス→ファイル名、拡張子

ファイルに関連する文字列の取得方法です。

ファイル名拡張子付 = Dir(ファイルフルパス)
ファイル名拡張子無 = Left(ファイル名拡張子付, InStrRev(ファイル名拡張子付, ".")-1)
フォルダパス = Replace(ファイルフルパス, "\" & ファイル名拡張子付, "")
拡張子 = Right(ファイルフルパス, Len(ファイルフルパス) - InStrRev(ファイルフルパス, "."))
このExcelブックのフォルダパス = ThisWorkbook.Path

ファイル・システム・オブジェクトを使う方法

'ディレクトリ
ファイルシステムオブジェクト.GetParentFolderName(フルパス)

'ファイル名
ファイルシステムオブジェクト.GetFileName(フルパス)
指定したパスのうち、ファイル名とみなされる最終要素を返します。
つまり「パス」+「ファイル名」の「ファイル名」部分です。

'ファイルベース名(拡張子を除く)
ファイルシステムオブジェクト.GetBaseName(フルパス)
ファイル名のうち拡張子(ピリオドを含む)を除くベース名です。

'拡張子
ファイルシステムオブジェクト.GetExtensionName(フルパス or ファイル名)
ファイルの拡張子を返します。ピリオドは含みません。

'ファイルオブジェクトを取得
Set ファイルオブジェクト = ファイルシステムオブジェクト.GetFile(フルパス)

'ドライブのパス
ファイルオブジェクト.Drive.Path

'フォルダのパス
ファイルオブジェクト.ParentFolder.Path
ファイルオブジェクト.GetParentFolderName(Path)
 https://excelwork.info/excel/fsogetfoldernamefilename/
  VBAで親フォルダのパスを取得する方法
 https://atmarkit.itmedia.co.jp/ait/articles/1705/01/news019.html

'ファイルのパス
ファイルオブジェクト.Path

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


テキストファイルの読み書き


 参考:Excel/VBAクリニック
 テキスト・ファイルの扱い方
http://itpro.nikkeibp.co.jp/article/COLUMN/20080526/304084/?ST=develop&P=4


1.Line Input # / Print # を使う

 以下は、PrepTutor英和・和英辞書の項でダウンロードできる、EPWING 版 PrepTutorEJDIC の、「和→英」索引データを作るときに使った、Excelマクロです。

 PDICテキスト形式は、
・見出し 1行(この場合は英単語)、
・説明文 1行(この場合は日本語訳)
の繰り返しで、構成されています。
 PrepTutorEJDIC テキスト・データは、下のような内容です。

baby
『赤ん坊,赤ちゃん』 / (家族・グループの中で)いちばん年少の人,最年少者 / 赤ん坊みたいな人 / (また『babe』)《米俗》《特に若い女の子への呼びかけた用いて》かわいこちゃん / 赤ん坊の[ような],赤ちゃん用の / 《話》…'を'赤ちゃんのように扱う,甘やかす
bowl
『どんぶり,はち;わん』,茶わん,ボール / どんぶり(はち)1杯の量 / (…の)丸くくぼんだ部分《+『of』+『名』》 / 《米》(はち形の)円形競技場(stadium)
rule
〈C〉『規則』,規定;法則 / 〈C〉『慣例』,慣習;通例,通則 / 〈U〉『支配』,統治;統治期間;統治権 / 〈C〉ものさし,定規(ruler) / 〈国・人など〉‘を'『支配する』,統治する,統御する / 《しばしば受動態で》〈感情などが〉〈人,人の行動など〉‘を'左右する,動かす / 〈裁判所・裁判官などが〉…‘と'裁決する,決定する / 〈紙〉‘に'線を引く / (…を)『支配する』,統治する《+『over』+『名』》 / (…について)裁決する,判定する《+『on』+『名』》;(…に反対の)裁決をする《+『against』+『名』(do『ing』)》・〈米俗〉抜群である、最高である

 上のサンプルで分るとおり、代表的な「日本語訳」は、『』で囲まれています。これを抽出して、表題の英語と関係付ければ、日本語→英語 索引ができることが分かります。日本語訳には、「,」や「;」で区切って2語入っているものが有りますし、重複する場合も有ります。
 注意点としては、上の例で、同じ『』で囲まれている項目には、構文の説明もあります。この構文解説は、《》で囲まれているので、「日本語索引」の対象外にします。
 また、()で囲んだ、補足についても、対象外にすべきでしょう。このとき、括弧《》や()の、「入れ子」を考慮する必要があります。

 正規表現を使って、《》や()の部分を、前もって入力データから削除しておけば、VBAのコードを簡単にすることができます。正規表現で入れ子検索する場合は、前後の括弧の数が不整合だと、ループ・エラーになります。

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


Option Explicit

Dim 入力ファイル名 As String
Dim 英単語 As String
Dim 和単語 As String
Dim 和単語数 As Integer
Dim 和単語群(100) As String
Dim 登録数 As Integer
Dim 重複 As Integer
Dim 入力行 As String
Dim 入力行文字数 As Integer
Dim 検索文字目 As Integer
Dim 日本語フラグ As Integer
Dim 補足フラグ As Integer
Dim 解説フラグ As Integer
Dim 日本語字数 As Integer
Dim 処理行カウンタ As Long
Dim 出力カウンタ As Integer
Dim 開始時刻 As Variant
Dim 終了時刻 As Variant
Dim 現在のパス As String


Sub 二重カギカッコ抽出()

    Application.Calculation = xlCalculationManual
    Application.ScreenUpdating = False

    現在のパス = ActiveWorkbook.Path
    ChDrive 現在のパス
    ChDir 現在のパス

    '変換対象のファイル名とパス取得
    入力ファイル名 = Application.GetOpenFilename("テキストファイル,*.txt")

    If 入力ファイル名 = "False" Then End
        
    開始時刻 = Now()
    処理行カウンタ = 0
    
    '********************************
    'ファイルのオープン。
    Open 入力ファイル名 For Input As #1
    
    '*************データの読み込み***********
    Do While (EOF(1) = 0)
        処理行カウンタ = 処理行カウンタ + 1
        Line Input #1, 英単語
        Line Input #1, 入力行
        
        Call 本文処理   '★★★★★

    Loop
    
    '**************終了処理*********************
    ThisWorkbook.Worksheets("Sheet1").Activate
    Range("A4").Value = 処理行カウンタ & " 最終行まで読込み完了"
    Close #1
    
    終了時刻 = Now()
    MsgBox "処理が終了しました。" & Chr(13) & _
    "処理時間は、" & Format(終了時刻 - 開始時刻, "nn分ss秒") & " でした。", vbOKOnly
    
    Range("A4").Activate
    
    Application.ScreenUpdating = True
    Application.Calculation = xlCalculationAutomatic

End Sub

'★★★★★ 本文処理 ★★★★★
Private Sub 本文処理()
    日本語フラグ = 0
    解説フラグ = 0
    補足フラグ = 0
    日本語字数 = 0
    和単語数 = 0
    Erase 和単語群
    重複 = 0

    入力行文字数 = Len(入力行)
    
    For 検索文字目 = 1 To 入力行文字数
    
        If Mid(入力行, 検索文字目, 1) = "(" Then
            補足フラグ = 補足フラグ + 1
        End If
        If 補足フラグ > 0 And Mid(入力行, 検索文字目, 1) = ")" Then
            補足フラグ = 補足フラグ - 1
        End If
        
        If Mid(入力行, 検索文字目, 1) = "《" Then
            解説フラグ = 解説フラグ + 1
        End If
        If 解説フラグ > 0 And Mid(入力行, 検索文字目, 1) = "》" Then
            解説フラグ = 解説フラグ - 1
        End If
       
        '構文説明以外の部分の『』内を特定する。
        If 補足フラグ = 0 And 解説フラグ = 0 And Mid(入力行, 検索文字目, 1) = "『" Then
            日本語フラグ = 1
        End If
    
        '構文説明以外の部分の『』の中の
        ',まで、あるいは、;まで、あるいは、『』の中を、「和単語」という名前の変数に格納する。
      
        If 日本語フラグ = 1 _
            And (Mid(入力行, 検索文字目, 1) = "," _
            Or Mid(入力行, 検索文字目, 1) = ";" _
            Or Mid(入力行, 検索文字目, 1) = "』") Then
        
            和単語 = Mid(入力行, 検索文字目 - 日本語字数 + 1, 日本語字数 - 1)
            
            If Left(和単語, 1) = "…" Then
                和単語 = Right(和単語, Len(和単語) - 1)
            End If
            If Left(和単語, 3) = "‘を'" Then
                和単語 = Right(和単語, Len(和単語) - 3)
            End If
            
            '『』の中で、全角文字数をカウントして、0のもの(=英字だけ)を排除する。
            '和単語の最後が ,で終わっているものを排除する。
            If LenB(StrConv(和単語, vbFromUnicode)) - Len(和単語) > 0 _
            And 日本語字数 > 1 Then
            
                '既存和単語との重複チェック
                For 登録数 = 1 To 和単語数
                    If 和単語群(登録数) = 和単語 Then
                        重複 = 1
                        Exit For
                    End If
                Next 登録数 '同一英単語に対する、抽出和単語数の最後まで、重複チェック
                
                If 重複 = 0 Then
                    '新しい日本語の場合に、英語、日本語の対応を、Excelのセルに取り込む。
                    和単語数 = 和単語数 + 1
                    Call 英和Excel取込み  '★★★★★
                    和単語群(和単語数) = 和単語
                End If
            End If
            
            日本語字数 = 0
        
            If Mid(入力行, 検索文字目, 1) = "』" Then
                日本語フラグ = 0
                重複 = 0
            End If
        End If

        If 日本語フラグ = 1 Then
            日本語字数 = 日本語字数 + 1
        End If
    
    Next 検索文字目 '入力行の最後まで、1文字ずつ文字を送って調べる

End Sub

'★★★★★ 英和 Excel 取込み ★★★★★
Private Sub 英和Excel取込み()
    出力カウンタ = 出力カウンタ + 1

    ThisWorkbook.Worksheets("英和").Activate
    Range("A1").Cells(出力カウンタ, 1).Value = 英単語
    Range("B1").Cells(出力カウンタ, 1).Value = 和単語
    
End Sub

 以下は、PrepTutorEJDIC テキストを、「和英辞典」として活用するために、上記のマクロを使って、Excelのセルに抽出した「日本語、英語の対応データ」を、日本語の方をキーにして、テキスト・ファイルに、PDIC テキスト形式で出力するものです。
 日本語、英語対応データを、「日本語」でソートする部分は、マクロで処理しないで、Excelの「データ」→「並べ替え」を使いました。抽出したデータを、Excel上で目視チェックして、修正したり、格助詞「を」を削除したりの作業が、必要だからです。


Option Explicit

Dim 出力ファイル名 As String
Dim 英語行 As String
Dim 英単語 As String
Dim 英単語数 As Integer
Dim 英単語群(100) As String
Dim 和単語 As String
Dim 前行和単語 As String
Dim 処理行カウンタ As Long
Dim 検索文字目 As Integer
Dim 英単語字数 As Integer
Dim 登録数 As Integer
Dim 重複 As Integer
Dim 異常件数 As Integer
Dim 開始時刻 As Variant
Dim 終了時刻 As Variant


Sub PDICテキスト出力()

    出力ファイル名 = "C:\test\PDICテキスト形式PrepTutorEJDIC和英.txt"
    前行和単語 = ""
    英単語 = ""
    英単語数 = 0
    異常件数 = 0

    開始時刻 = Now()
    
    '********************************
    'ファイルのオープン。
    Open 出力ファイル名 For Output As #1
    
    '*************データの読み込み***********
    
    ThisWorkbook.Worksheets("和英").Activate
    
    For 処理行カウンタ = 1 To Cells(ActiveSheet.Rows.Count, 1).End(xlUp).Row + 1
        
        和単語 = Range("A1").Cells(処理行カウンタ, 1).Value
        
        '同じ日本語が続く場合は、英語を、配列「英単語群」に重複チェックしながら追加。
        If 前行和単語 = 和単語 Then
        
            Call 英単語群に追加 '★★★★★
            
        Else
            If 処理行カウンタ > 1 Then
                '日本語が変わったら、前行までの部分を、テキストに書き出す。
                英語行 = 英単語群(1)
                If 登録数 > 1 Then
                    For 登録数 = 2 To 英単語数
                        英語行 = 英語行 & "," & 英単語群(登録数)
                    Next 登録数
                End If
                
                Call テキストファイル出力処理  '★★★★★
                
                '変数の初期化
                英単語数 = 0
                Erase 英単語群

            End If
            
            Call 英単語群に追加 '★★★★★

        End If
        
        前行和単語 = 和単語
        
    Next 処理行カウンタ 'Excelの最後の行まで繰返し
    
    '**************終了処理*********************
    ThisWorkbook.Worksheets("Sheet1").Activate
    Range("A4").Value = 処理行カウンタ & " 最終行まで読込み完了"
    Close #1
    
    終了時刻 = Now()
    MsgBox "処理が終了しました。" & Chr(13) & _
    "処理時間は、" & Format(終了時刻 - 開始時刻, "nn分ss秒") & " でした。", vbOKOnly
    
    Range("A4").Activate

End Sub


'★★★★★英単語を、配列「英単語群」に重複チェックしながら追加★★★★★
Private Sub 英単語群に追加()
            英語行 = Range("B1").Cells(処理行カウンタ, 1).Value
            英単語字数 = 0
            
            '英語行の途中に,が有って、複数登録されている場合の、最後以外の単語。
            For 検索文字目 = 1 To Len(英語行)
                英単語字数 = 英単語字数 + 1
                If Mid(英語行, 検索文字目, 1) = "," Then
                    英単語 = Mid(英語行, 検索文字目 - 英単語字数 + 1, 英単語字数 - 1)
                    '+1は、1文字目に当てるため。-1は,を除外するため。
                    
                    Call 新出単語登録 '★★★★★
                    
                    英単語字数 = 0
                End If
            Next 検索文字目
                    
            '英語行に、英語1単語だけの場合、もしくは、複数単語の最後の英単語。
            英単語 = Mid(英語行, 検索文字目 - 英単語字数, 英単語字数)
            '上の Next 検索文字目 で、カウントが1増えているので、ここでは+1しない。
            '最後は、,が無いので-1しない。
            
            Call 新出単語登録 '★★★★★
            
End Sub


'★★★★★新出単語登録★★★★★
Private Sub 新出単語登録()

    重複 = 0
    For 登録数 = 1 To 英単語数
        If 英単語群(登録数) = 英単語 Then '既存単語の場合
            重複 = 1
            Exit For
        End If
    Next 登録数
    
    If 重複 = 0 Then '新出単語の場合に、配列に追加。
        英単語数 = 英単語数 + 1
        英単語群(英単語数) = 英単語
    End If

    If 英単語数 = 25 Then '日本語に対して、英単語数が多すぎるものをチェックする。
        異常件数 = 異常件数 + 1
        Worksheets("異常候補").Activate
        Range("A1").Cells(異常件数, 1).Value = 和単語
        Worksheets("和英").Activate
    End If

End Sub


'★★★★★テキストファイル出力処理★★★★★
Private Sub テキストファイル出力処理()
        Print #1, 前行和単語
        Print #1, 英単語
End Sub

 解説:
 Open ステートメントは、ファイルを開いて、ファイルへ入出力できるようにします。
 Open ステートメント の項目も参照下さい。

 Workbooks.Open メソッドは、ブックを開きます。
この場合は、引数に、ブック名のフルパスを、文字列として指定します。

 Close ステートメントは、Open ステートメントで開いたファイルへの入出力を終了して、ファイルを閉じるファイル入出力ステートメントです。
 Workbooks.Close メソッドは、オブジェクトを閉じます。
閉じるブックを指定する場合は、Workbooks(ブック名).Close とします。
引数に、SaveChanges オプションを加えることができます。ブックに変更があり、開いている他のどのウィンドウにも表示されていない場合、この引数で、変更を保存するかどうかを指定します。True を指定すると、変更がブックに保存されます。False だと、変更を保存しません。

 Line Input # ステートメントは、シーケンシャル入力モード (Input) で開いたファイルから行全体を読み込み、文字列型 (String) の変数に代入するファイル入出力ステートメントです。

 注:Line Input # ステートメントは、ファイルからキャリッジ リターンCR (Chr(13)) または改行コードCR+LF (Chr(13)) + Chr(10)) の直前までの、すべての文字を読み込みます。

 このため、改行が、LF だけのテキストファイル(UNIX用のテキストファイル)は、テキストエディタを使うなどして、事前に改行コードを CR+LF に変更しておく必要があります。
 インターネットで、テキストファイルを公開するために、WebサーバにUPすると、多くの Webサーバは UNIXマシンのため、改行が LF に変わってしまいます。このため、テキストファイルを WEB にアップロードするときは、FTPクライアント転送モードを、アスキーではなくバイナリにします。そうすると、Windowsの改行コードが保持されます。(改行コードが CR+LF でも、ブラウザの表示は、何も問題有りません。)

 EOF 関数は、ランダム アクセス モード (Random) またはシーケンシャル入力モード (Input) で開いたファイルの現在位置がファイルの末尾に達している場合、ブール型 (Boolean) の値の真 (True) を含む整数型 (Integer) の値を返します。

 Print # ステートメントは、シーケンシャル出力モード (Output または Append) で開いたファイルにデータを書き込むファイル入出力ステートメントです。

 上の事例では、配列変数を使っています。配列変数に登録したデータをクリアするときには、 Erase ステートメント を使います。プログラムのループで変数を使い回すときは、ループの度に変数の値をクリアすることを忘れないようにしましょう。さもないと、先に変数に登録したデータが、再登場して悪さをします。
 Erase ステートメントは、固定サイズの配列の場合は要素を再初期化し、動的配列の場合は割り当てたメモリを解放します。
 構文は、Erase arraylist で、必須の引数 arraylist には、消去する配列変数を指定します。複数指定する場合は、カンマ (,) で区切ります。




 「BASICプログラムの例」の項目でも、固定長ファイルを読み込むプログラム(bom4.xls)を掲載しています。

 読み込む、部品表データの「パスとファイル名」は、当該ブック内に、シート「ファイル名」を作って、保存します。
 このシート「ファイル名」がない場合のみ、[ファイルを開く]ように、 On Error ステートメントを使って制御しています。


Private Sub BomImport(Div)
    Dim ダミー As String
    '***********ファイルの読み込み***************
    'Iは部品表標準リストの行数。
    N = 1
    InLines = 0
    
    On Error Resume Next  'エラースキップ
    ダミー = Worksheets("ファイル名").Name 'シートの有無の確認。無かったらエラーになる
    On Error GoTo 初回  '[ファイルを開く]処理に進む
    GoTo 二回目以降
初回:
        BomText = Application.GetOpenFilename("部品表構成ファイル,*.txt")
        If BomText = "False" Then End
        Worksheets.Add
        ActiveSheet.Name = "ファイル名"
        Worksheets("ファイル名").Range("A1").Value = BomText
        
二回目以降:
        BomText = Worksheets("ファイル名").Range("A1").Value
        
    If Dir(BomText) <> "" Then
・・・・・・・・プログラムは続く・・・・・

 解説:
 Private Sub を呼び出すときに、Sub プロシージャに渡す引数を使って、部品表の正展開と逆展開を切り替えています。

 読み込み対象ファイルを指定することろで、GetOpenFilename を使っています。

 GetOpenFilename メソッドは、ファイル名を指定するために、[ファイルを開く] ダイアログ ボックスを表示します。
 このメソッドを実行することによって、カレント ドライブやカレント フォルダが変更される可能性があります。
 ユーザーが選択、または入力したファイルの名前とパス名を返します。引数 MultiSelect が True の場合は、選択されたファイルの名前の配列が返されます。選択されたファイルが 1 つでも、配列として返されます。
 入力が取り消された場合には False が返されます。

 上の例では、String変数の BomText に、文字データとして False を受け取ったとき、プログラムを終了させています。

expression.GetOpenFilename(FileFilter, FilterIndex, Title, ButtonText, MultiSelect)

expression  必ず指定します。Application オブジェクトを返すオブジェクト式を指定します。

FileFilter ファイルの候補を指定する文字列 (ファイル フィルタ文字列) を指定します。

 ファイル フィルタ文字列とワイルドカードのペアを、必要な数だけ指定します。ファイル フィルタ文字列とワイルドカードはカンマ (,) で区切り、各ペアもカンマで区切って指定します。各ペアは、[ファイルの種類] ボックスのリストに表示されます。
 例えば、テキストとアドインの 2 つのファイル フィルタの指定は次のようになります。"テキスト ファイル (*.txt),*.txt,アドイン ファイル (*.xla),*.xla"
2 つのファイル フィルタの指定

 1 つのファイル フィルタ文字列に複数のワイルドカードを対応させるには、次のように各ワイルドカードをセミコロン (;) で区切ります。"Visual Basic ファイル (*.bas;*.txt),*.bas;*.txt" ←渡辺の推奨
 この引数を省略すると、"すべてのファイル (*.*),*.*" を指定したことになります。

 上の例では、[ファイルを開く] ダイアログ ボックスで、ファイルの種類をテキスト ファイルに限定しています。

 FilterIndex 引数 FileFilter で指定したファイル フィルタ文字列の中で、1 から何番目の値を既定値とするかを指定します。この引数を省略するか、引数 FileFilter に含まれるファイル フィルタ文字列の数より大きい数値を指定すると、最初のファイル フィルタ文字列が既定値となります。

 Title ダイアログ ボックスのタイトルを指定します。この引数を省略すると "ファイルを開く" になります。

 MultiSelect True を指定すると、複数のファイルを選択できます。False を指定すると、1 つのファイルしか選択できません。既定値は False です。

次のサンプル モジュールでは、開きたいファイル名を入力し、入力されたファイル名を MsgBox 関数を使用して表示後、目的のファイルを開きます。
  Sub FileOpen()
      Dim openfile As String
      openfile = Application.GetOpenFilename
      MsgBox openfile & "をオープンします"
      Workbooks.Open fileName:=openfile
  End Sub

次のサンプルモジュールでは、保存したいファイル名を入力し、入力されたファイル名を MsgBox 関数を使用して表示後、ファイルを保存しています。
  Sub Filesave()
      Dim savefile As String
      savefile = Application.GetSaveAsFilename
      MsgBox savefile & "を保存します"
      ActiveWorkbook.SaveAs fileName:=savefile
  End Sub

次のサンプルモジュールでは、[ファイル] - [開く] ダイアログ ボックスを表示し、<OK> ボタンがクリックされたら指定した任意のファイルを開きます。
  Sub DialogShow()
      Application.Dialogs(xlDialogOpen).Show
  End Sub

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


比較:ファイルを開くダイアログ

参考
http://officetanaka.net/excel/vba/tips/tips154.htm
http://www.geocities.jp/cbc_vbnet/tips/dialog.html
http://www.accessclub.jp/urawaza/87.html

区分メソッド特長初期フォルダの指定方法タイトル設定複数選択フィルタ設定
ExcelGetOpenFilenameファイル名を取得するだけ
キャンセルはFalse
★拡張子を選択させるために使える
ChDrive ThisWorkbook.Path
ChDir ThisWorkbook.Path
Title:=""MultiSelect:=FileFilter:="" 各ワイルドカードをセミコロン (;) で区切ります。
"Visual Basic ファイル (*.bas;*.txt),*.bas;*.txt"
FileDialog(msoFileDialogFilePicker)[参照] ダイアログ ボックス(ファイル参照).InitialFileNameTitle.AllowMultiSelect.Filters
Dialogs(xlDialogOpen).Show[OK]ボタンをクリックするとただちに開かれる



FindFile[開く]ボタンをクリックすると、ただちに選択したファイルを開く
[キャンセル]ボタンがクリックされたときは何もしない
ダイアログボックスに表示するファイルの種類を拡張子で指定できない



対象はExcelブックとhtmのみ
FileSearchExcel 2007 から使えない



WordFileDialog(msoFileDialogOpen)[ファイルを開く] ダイアログ ボックス.InitialFileName = "C:\"Title.AllowMultiSelect.Filters.Add "イメージ", "*.gif; *.jpg; *.jpeg", 1
Dialogs(wdDialogFileOpen).Show
ChangeFileOpenDirectory "C:\Documents"

.Name = "*.doc"
AccessFileDialog(msoFileDialogOpen)Microsoft Office ** Object Library への参照設定




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


別解:Microsoft Word から [ファイルを開く] ダイアログ ボックスを呼び出す

下記にあったものです。
http://technet.microsoft.com/ja-jp/library/ee692906.aspx

Sub ファイルを開くダイアログ()

   Dim Wordオブジェクト As Object
   Dim Fileオブジェクト As Object
   Const msoFileDialogOpen = 1 'Word に [ファイルを開く] ダイアログ ボックスを使用することを通知

   Set Wordオブジェクト = CreateObject("Word.Application")
   
   Wordオブジェクト.ChangeFileOpenDirectory ("C:\temp") '最初に開くフォルダを指定
   
   Wordオブジェクト.FileDialog(msoFileDialogOpen).Title = "削除するファイルを選択して下さい" 'ダイアログ ボックスの名前 (タイトル) を指定
   Wordオブジェクト.FileDialog(msoFileDialogOpen).AllowMultiSelect = True 'ダイアログ ボックスで複数のファイルを選択できるようにする
   
   If Wordオブジェクト.FileDialog(msoFileDialogOpen).Show = -1 Then '[ファイルを開く] ダイアログ ボックスを表示し、ユーザーが [開く] または [キャンセル] をクリックするのを待機
       Wordオブジェクト.WindowState = 2 'Word を最小化し、邪魔にならないように
       For Each Fileオブジェクト In Wordオブジェクト.FileDialog(msoFileDialogOpen).SelectedItems
           MsgBox Fileオブジェクト
       Next
       
   End If
   
   Wordオブジェクト.Quit 'Microsoft Word のインスタンスを終了

End Sub


 次のサンプルマクロは、「英辞郎」を買うと付いてくる「例辞郎」の、リンクテキストと本文ファイルを合体するプログラムの例です。
REIJI82VBA.xls
 5万行、14MBのテキスト・ファイルを、高速に処理してくれます。Excel VBA は、処理スピードの面でも満足できるプログラム言語です。

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


2.FileSystemObjectを使う


参照設定  FileSystemObjectを使って、一行ずつテキスト・ファイルを読み込むコードは、「Excelでお仕事!」の下記のページを、参考にさせていただきました。
http://www.asahi-net.or.jp/~ef2o-inue/vba_o/sub05_110_035.html
http://www.asahi-net.or.jp/~ef2o-inue/vba_o/sub05_110_055.html
出展を明記するとともに、 © 井上 治さんの、貴重なノウハウの公開に、感謝をいたします。

******************************
 ExcelVBA で、FileSystemObject を使うとき、以下の 2 つの方法が有ります。

1.参照設定で Microsoft Scripting Runtime にチェックを入れる
 プロジェクト>参照設定で、Microsoft Scripting Runtime の参照にチェックを入れます。
 下記で、インスタンスを作成します。
Dim FSO As New FileSystemObject
 メリット:コードを記述しているときに、自動メンバ表示や、自動データヒントの、コード補完機能が使えます。
 デメリット:マクロを、他の環境で動かそうとすると、他の環境でも、参照設定しないと動かない。

2.CreateObject関数を実行して、FileSystemObjectのインスタンスを作成する(私の推奨)
 下記で、インスタンスを作成します。
Dim ファイルシステムオブジェクト As Object
Set ファイルシステムオブジェクト = CreateObject("Scripting.FileSystemObject")


英文単語間の空白を抜いて単語頭文字を大文字に
 英文の単語間の空白を除いて、単語の頭文字を大文字に変換するマクロの例です。
 私のマクロは、可読性をよくするために、変数名に日本語漢字を使っています。
 このマクロ・コードを英語にする必要が出たときに、変数名を英文化するために作ったものです。
 私の和文コードから、変数名を抽出して、Google翻訳 したものを、下記のように英語変数名に変換しました。

File full path → FileFullPath
Summary book name → SummaryBookName

この Excel をダウンロードできます。→SkipSpacesAndUppercaseInitialLettersVBA01.xls

 コードの英文化は、コードを Word に貼り付けて ワード文書の語群をExcelの辞書を使って置換 で変換しました。

Option Explicit

Dim 入力ファイル名 As String
Dim 出力ファイル名 As String
Dim 入力行 As String

Dim 処理行カウンタ As Long
Dim 開始時刻 As Variant
Dim 終了時刻 As Variant
Dim 文字列 As String

Sub 途中の小文字を大文字に()
   
   Dim ファイルシステムオブジェクト As Object          ' FileSystemObject
   Dim 入力テキストストリームオブジェクト As Object    ' TextStream
   Dim 出力テキストストリームオブジェクト As Object    ' TextStream

   'ファイルを開くダイアログを使って、変換対象のファイル名とパスを取得
   ChDrive ThisWorkbook.Path
   ChDir ThisWorkbook.Path
   入力ファイル名 = Application.GetOpenFilename("TEXTファイル,*.txt")
   If 入力ファイル名 = "False" Then End
   
   出力ファイル名 = Left(入力ファイル名, InStrRev(入力ファイル名, ".") - 1) & "大文字.txt"
       
   開始時刻 = Now()
   
   '********************************
   'ファイルのオープン
   処理行カウンタ = 0
   
   Set ファイルシステムオブジェクト = CreateObject("Scripting.FileSystemObject")
   
   ' 指定ファイルをOPEN(入力モード)
'   https://msdn.microsoft.com/ja-jp/library/cc428044.aspx
   Set 入力テキストストリームオブジェクト = _
   ファイルシステムオブジェクト.OpenTextFile(入力ファイル名, 1, , False)

   ' 指定ファイルをOPEN(出力モード)
    Set 出力テキストストリームオブジェクト = _
    ファイルシステムオブジェクト.CreateTextFile(出力ファイル名)
   
   '******* 英文の単語間の空白を抜いて単語の頭文字を大文字に変換して出力 ********
   Do Until 入力テキストストリームオブジェクト.AtEndOfStream
   
      ' レコードの読み込み
      入力行 = 入力テキストストリームオブジェクト.ReadLine
      
      If Trim(入力行) <> "" Then
      'データが有る行のみを対象とする
      
         処理行カウンタ = 処理行カウンタ + 1
         
         If (処理行カウンタ Mod 100) = 0 Then
            Application.StatusBar = 処理行カウンタ & " 行目を読込み"
         End If
         
         Debug.Print 入力行
         
         文字列 = 入力行

         Do While InStr(文字列, " ") > 0
         '途中に空白が有る行のみ
            文字列 = Left(文字列, InStr(文字列, " ") - 1) _
            & UCase(Mid(文字列, InStr(文字列, " ") + 1, 1)) _
            & Right(文字列, Len(文字列) - InStr(文字列, " ") - 1)

         Loop
         
         出力テキストストリームオブジェクト.WriteLine 文字列         ' 改行(CrLf)付き

      End If

      ' 最終行まで繰り返す
   Loop
   
   '**************終了処理*********************
   Application.StatusBar = 処理行カウンタ & " 最終行まで読込み完了"
   
   ' 指定ファイルをCLOSE
   入力テキストストリームオブジェクト.Close
   Set 入力テキストストリームオブジェクト = Nothing
   出力テキストストリームオブジェクト.Close
   Set 出力テキストストリームオブジェクト = Nothing
   Set ファイルシステムオブジェクト = Nothing

   終了時刻 = Now()
   MsgBox "処理が終了しました。" & Chr(13) & _
   "処理時間は、" & Format(終了時刻 - 開始時刻, "nn分ss秒") & " でした。", vbOKOnly
   
   Range("A1").Activate

End Sub

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


階層付きテキストからタイトルのみ抽出
 階層付テキスト(WzMemo) からタイトル行のみレベルを付けて抽出するマクロの例です。

この Excel をダウンロードできます。→ExtractTitlesFromWzMemoVBA01.xls

Option Explicit

Dim 入力ファイル名 As String
Dim 出力ファイル名 As String
Dim 入力行 As String
Dim 出力行 As String
Dim 処理行カウンタ As Long
Dim 開始時刻 As Variant
Dim 終了時刻 As Variant
Dim 文字列 As String
Dim レベル As Integer
Dim 入力文字コード As Integer

Sub 階層付きテキストから階層とタイトルのみを抽出()
   
   Dim ファイルシステムオブジェクト As Object          ' FileSystemObject
   Dim 入力テキストストリームオブジェクト As Object    ' TextStream
   Dim 出力テキストストリームオブジェクト As Object    ' TextStream

   'ファイルを開くダイアログを使って、変換対象のファイル名とパスを取得
   ChDrive ThisWorkbook.path
   ChDir ThisWorkbook.path
   入力ファイル名 = Application.GetOpenFilename("TEXTファイル,*.txt")
   If 入力ファイル名 = "False" Then End
   
   出力ファイル名 = Left(入力ファイル名, InStrRev(入力ファイル名, ".") - 1) & "タイトル.txt"
       
   開始時刻 = Now()
   
   入力文字コード = Range("A11").Value
   
   '********************************
   'ファイルのオープン
   処理行カウンタ = 0
   
   Set ファイルシステムオブジェクト = CreateObject("Scripting.FileSystemObject")
   
   ' 指定ファイルをOPEN(入力モード)
'   https://msdn.microsoft.com/ja-jp/library/cc428044.aspx
   If 入力文字コード = 1 Then 'ShiftJIS
      Set 入力テキストストリームオブジェクト = _
      ファイルシステムオブジェクト.OpenTextFile(入力ファイル名, 1, , False)
   ElseIf 入力文字コード = 2 Then  'UNICODE(UTF-16)
      Set 入力テキストストリームオブジェクト = _
      ファイルシステムオブジェクト.OpenTextFile(入力ファイル名, 1, , True)
   Else
      MsgBox "入力ファイルの文字コードに対応していません。"
      GoTo 終了処理
   End If

   ' 指定ファイルをOPEN(出力モード)
    Set 出力テキストストリームオブジェクト = _
    ファイルシステムオブジェクト.CreateTextFile(出力ファイル名)
   
   '*************データを読込み、タイトルのみを出力***********
   Do Until 入力テキストストリームオブジェクト.AtEndOfStream
   
      ' レコードの読み込み
      入力行 = 入力テキストストリームオブジェクト.ReadLine
      
      If Trim(入力行) <> "" Then
      'データが有る行のみを対象とする
      
         処理行カウンタ = 処理行カウンタ + 1
         
         If (処理行カウンタ Mod 100) = 0 Then
            Application.StatusBar = 処理行カウンタ & " 行目を読込み"
         End If
         
         Debug.Print 入力行
         
         'ファイルの最初の特別処理
         If 処理行カウンタ = 1 Then
            If Left(入力行, 1) <> "." Then
            'データが存在する最初の行に . が無い場合は、.を付加する
               入力行 = "." & 入力行
            End If
         End If
         
         If Left(入力行, 1) = "." Then
         '左端にピリオドが有る行のみ

            文字列 = 入力行
            レベル = 0
            '左端の . を除く
            Do While Left(文字列, 1) = "."
               レベル = レベル + 1
               文字列 = Right(文字列, Len(文字列) - 1)
            Loop
            
            出力行 = CStr(レベル) & ":" & 文字列
            出力テキストストリームオブジェクト.WriteLine 出力行         ' 改行(CrLf)付き
            
         End If
      End If

      ' 最終行まで繰り返す
   Loop
   
   
   '**************終了処理*********************
   Application.StatusBar = 処理行カウンタ & " 最終行まで読込み完了"
   
   ' 指定ファイルをCLOSE
   入力テキストストリームオブジェクト.Close
   Set 入力テキストストリームオブジェクト = Nothing
   出力テキストストリームオブジェクト.Close
   Set 出力テキストストリームオブジェクト = Nothing
   
終了処理:

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

   終了時刻 = Now()
   MsgBox "処理が終了しました。" & Chr(13) & _
   "処理時間は、" & Format(終了時刻 - 開始時刻, "nn分ss秒") & " でした。", vbOKOnly
   
   Range("A1").Activate

End Sub

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


「青空文庫」の「字下げ」を空白字下げに変換
 「青空文庫」から、宮沢賢治の「注文の多い料理店」をダウンロードして、VerticalEditor で表示したところ、
[#ここから3字下げ]
[#ここで字下げ終わり]

という記述がうっとおしかったので、該当部分を、実際に空白字下げに変換するマクロを作りました。

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

Option Explicit

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


Sub 字下げ変換()

   Dim ファイルシステムオブジェクト As Object          ' FileSystemObject
   Dim 入力テキストストリームオブジェクト As Object    ' TextStream
   Dim 出力テキストストリームオブジェクト As Object    ' TextStream


   '変換対象のファイル名とパス取得
   ChDrive ThisWorkbook.Path
   ChDir ThisWorkbook.Path
   入力ファイル名 = Application.GetOpenFilename("TEXTファイル,*.txt")
   If 入力ファイル名 = "False" Then End
   出力ファイル名 = Left(入力ファイル名, Len(入力ファイル名) - 4) & "_Indent" & ".txt"
       
   開始時刻 = Now()
   
   '********************************
   'ファイルのオープン。
   処理行カウンタ = 0
   
   Set ファイルシステムオブジェクト = CreateObject("Scripting.FileSystemObject")
   
   ' 指定ファイルをOPEN(入力モード)
   Set 入力テキストストリームオブジェクト = _
    ファイルシステムオブジェクト.OpenTextFile(入力ファイル名, 1)

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

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

       出力行 = 入力行
       
       Call 本文処理  '★★★★★★★★★
       
       出力テキストストリームオブジェクト.WriteLine 出力行         ' 改行(CrLf)付き

       If (処理行カウンタ Mod 10) = 0 Then
       Range("A4").Value = 処理行カウンタ & " 行目を読込み"
       End If
       
       ' 最終行まで繰り返す
   Loop
    
   '**************終了処理*********************
   Range("A4").Value = 処理行カウンタ & " 最終行まで読込み完了"
   
   ' 指定ファイルをCLOSE
    入力テキストストリームオブジェクト.Close
    Set 入力テキストストリームオブジェクト = Nothing
    出力テキストストリームオブジェクト.Close
    Set 出力テキストストリームオブジェクト = Nothing
    
    Set ファイルシステムオブジェクト = Nothing

   
   終了時刻 = Now()
   MsgBox "処理が終了しました。" & Chr(13) & _
   "処理時間は、" & Format(終了時刻 - 開始時刻, "nn分ss秒") & " でした。", vbOKOnly
   
   Range("A4").Activate

End Sub


Private Sub 本文処理()

   If InStr(入力行, "(例)") = 0 _
      And InStr(入力行, "字下げ") > 0 And InStr(入力行, "]") > 0 Then
      字下げ対象行 = True
      字下げ文字数 = Val(半角(Mid(入力行, 7)))
      If 字下げ文字数 > 2 Then
         字下げ文字数 = 2
      End If
      出力行 = ""
'      Stop
      Exit Sub
   ElseIf 入力行 = "[#ここで字下げ終わり]" Then
      字下げ対象行 = False
      出力行 = ""
      Exit Sub
   End If
   
   If 字下げ対象行 = True Then
'      Stop
      出力行 = String(字下げ文字数, " ") & 入力行
   End If

End Sub

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


「青空文庫」の入力者注「傍点」をルビに変換
 「青空文庫」から、林 不忘の「丹下左膳」をダウンロードして読んでいたところ、傍点(・・)が、

傍点[#「傍点」に傍点]

と表記されていて、読みにくいので、ルビ表現(・・・・)傍点(・・)に修正するマクロを作りました。
下のルビ・タグに変更のマクロを修正しただけです。こちらのほうが簡単なので、先に掲示します。

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

Option Explicit

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


Sub 傍点変換()

Dim ファイルシステムオブジェクト As Object          ' FileSystemObject
Dim 入力テキストストリームオブジェクト As Object    ' TextStream
Dim 出力テキストストリームオブジェクト As Object    ' TextStream


    '変換対象のファイル名とパス取得
    入力ファイル名 = Application.GetOpenFilename("TEXTファイル,*.txt")
    If 入力ファイル名 = "False" Then End
    出力ファイル名 = Left(入力ファイル名, Len(入力ファイル名) - 4) & "_Dots" & ".txt"
        
    開始時刻 = Now()
    
    '********************************
    'ファイルのオープン。
    処理行カウンタ = 0
    
    Set ファイルシステムオブジェクト = CreateObject("Scripting.FileSystemObject")
    
    ' 指定ファイルをOPEN(入力モード)
    Set 入力テキストストリームオブジェクト = _
    ファイルシステムオブジェクト.OpenTextFile(入力ファイル名, 1)

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

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

        出力行 = 入力行
        
        Call 本文処理  '★★★★★★★★★
        
        出力テキストストリームオブジェクト.WriteLine 出力行         ' 改行(CrLf)付き

        If (処理行カウンタ Mod 10) = 0 Then
        Range("A4").Value = 処理行カウンタ & " 行目を読込み"
        End If
        
        ' 最終行まで繰り返す
    Loop
    
    '**************終了処理*********************
    Range("A4").Value = 処理行カウンタ & " 最終行まで読込み完了"
    
    ' 指定ファイルをCLOSE
    入力テキストストリームオブジェクト.Close
    Set 入力テキストストリームオブジェクト = Nothing
    出力テキストストリームオブジェクト.Close
    Set 出力テキストストリームオブジェクト = Nothing
    
    Set ファイルシステムオブジェクト = Nothing

    
    終了時刻 = Now()
    MsgBox "処理が終了しました。" & Chr(13) & _
    "処理時間は、" & Format(終了時刻 - 開始時刻, "nn分ss秒") & " でした。", vbOKOnly
    
    Range("A4").Activate

End Sub

'★★★★★★★★★
Private Sub 本文処理()
'★★★★★★★★★

Dim 閉カギ文字目 As Integer
Dim 開カギ文字目 As Integer
Dim 傍点対象文字列 As String
Dim 入力者注終了位置 As Integer
Dim 入力者注開始位置 As Integer
Dim 傍点文字数 As Integer

    出力行 = ""
    地文字数 = 0
    傍点文字数 = 0
    
    入力行文字数 = Len(入力行)
    
    For 検索文字目 = 入力行文字数 To 1 Step -1
    
        地文字数 = 地文字数 + 1

        If Mid(入力行, 検索文字目, 1) = "]" Then
        '傍点処理のチェック

            入力者注終了位置 = 検索文字目
            閉カギ文字目 = InStrRev(入力行, "」に傍点]", 入力者注終了位置)
            
            If 閉カギ文字目 + 4 = 入力者注終了位置 Then
            '傍点処理ルーチン
            
                開カギ文字目 = InStrRev(入力行, "「", 閉カギ文字目)
                傍点対象文字列 = Mid(入力行, 開カギ文字目 + 1, 閉カギ文字目 - 開カギ文字目 - 1)
                傍点文字数 = Len(傍点対象文字列)
                
                入力者注開始位置 = InStrRev(入力行, "[#", 閉カギ文字目)
                
                If 入力者注開始位置 > 0 Then
                    出力行 = Mid(入力行, 検索文字目 + 1, 地文字数 - 1) & 出力行
                    出力行 = "《" & String(傍点文字数, "・") & "》" & 出力行
                    出力行 = "|" & 傍点対象文字列 & 出力行
                    検索文字目 = 検索文字目 - 傍点文字数 - (入力者注終了位置 - 入力者注開始位置)
                    地文字数 = 0
                Else
                    MsgBox 処理行カウンタ
                    End
                End If
            End If
        End If
    Next 検索文字目
    
    出力行 = Mid(入力行, 検索文字目 + 1, 地文字数) & 出力行

End Sub

 解説:
 String 関数は、バリアント型 (内部処理形式 String の Variant) の値を返します。指定した文字コード (ASCII またはシフト JIS コード) の示す文字、または文字列の先頭文字を、指定した文字数だけ並べた文字列を返す文字列処理関数です。

構文:String(number, character)

number 必ず指定します。長整数型 (Long) の値を指定します。文字をいくつ並べるのかを指定します。名前付き引数 number に Null 値が含まれる場合は、Null 値を返します。
character 必ず指定します。バリアント型 (Variant) の値を指定します。文字の文字コード、または文字列式を指定します。この文字列の先頭文字を number 回繰り返したものを返します。名前付き引数 character に Null 値が含まれる場合は、Null 値を返します。

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

「青空文庫」にルビ設定
 「青空文庫」には、アンデルセン新見南吉など、子供でも楽しめる話があります。
また「Open Shelf」にも子供向けの本がいくつかあります。
 ただ、ふり仮名(ルビ)が少ないと、とりつきにくいものです。
このため、ルビ追加を支援するマクロを作りました。
 漢字には複数の読み方があり、これを単純に文字列置換できるものではありません。
例えば、空(から、そら)、明かり、明るい、金(かね、きん)、決める、決して、光る、光、細かく、細く、主(しゅ、ぬし)、勝つ、勝る、着る、着く、などです。
 このマクロは、テキスト・ファイルから漢字を抽出して、機械的に読み仮名を付ける部分と、この漢字・ルビ辞書の整備を支援する部分に分けています。
 漢字・ルビ辞書を、手作業で現実的に使える状態まで修正した上で、テキスト・ファイルに反映させます。
 電子書籍(ePub)にした事例をダウンロードできます。
王さまと靴屋(新美南吉)
オズの魔法使い(ライマン・フランク・ボーム作、武田正代、山形浩生訳)

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

 元の原稿がブラウザで表示できるものなら ひらひらのひらがなめがね を使った方が簡単です。

参考にさせて頂いたサイト:
***********************
vba 漢字 かな 判定
https://dobon.net/vb/dotnet/string/ishiragana.html
https://extan.jp/?p=4437#VBA%E3%81%A7%E6%96%87%E5%AD%97%E5%88%97%E3%81%8B%E3%82%89%E6%BC%A2%E5%AD%97%E3%81%AE%E3%81%BF%E3%82%92%E6%8A%BD%E5%87%BA%E3%83%BB%E5%89%8A%E9%99%A4%E3%81%99%E3%82%8B
https://www.asahi-net.or.jp/~ef2o-inue/vba_o/sub05_120_010.html
http://officetanaka.net/excel/vba/tips/tips145.htm

'======================================================================
' 渡辺 真
' 2021/12/28
'   E-mail:  makoto_watanabe@hi-ho.ne.jp
'=======================================================================

Option Explicit

Dim 入力ファイル名 As String
Dim 入力行 As String
Dim 処理行カウンタ As Integer
Dim 漢字索引 As Object        'Scripting.Dictionary オブジェクト
Dim 出力行 As Integer
Dim 漢字 As String
Dim ルビ As String
Dim 漢字数 As Integer
Public 開始時刻 As Variant
Public 終了時刻 As Variant
Public 最終行  As Integer
   
'★★★★★★★★★★★★★★★★★★★★★
Sub 漢字抽出()
'★★★★★★★★★★★★★★★★★★★★★

   Dim ファイルシステムオブジェクト As Object          ' FileSystemObject
   Dim 入力テキストストリームオブジェクト As Object    ' TextStream

   '★漢字索引を作成★
   Set 漢字索引 = CreateObject("Scripting.Dictionary")  '★連想配列の定義

   '変換対象のファイル名とパス取得
   ChDrive ThisWorkbook.Path
   ChDir ThisWorkbook.Path
   入力ファイル名 = Application.GetOpenFilename("TEXTファイル,*.txt")
   If 入力ファイル名 = "False" Then End
       
'   開始時刻 = Now()
   出力行 = 1
   
   ThisWorkbook.Worksheets("辞書").Activate
   '既存データの2行目以降を行削除する
   'A 列(10列目)を基準に、最終行を求める
   最終行 = Cells(ActiveSheet.Rows.Count, 1).End(xlUp).Row
   If 最終行 > 1 Then
      Rows(2 & ":" & 最終行).Delete Shift:=xlUp
   End If
   ThisWorkbook.Worksheets("Sheet1").Activate
   
   '********************************
   'ファイルのオープン。
   処理行カウンタ = 0
   
   Set ファイルシステムオブジェクト = CreateObject("Scripting.FileSystemObject")
   
   ' 指定ファイルをOPEN(入力モード)
   Set 入力テキストストリームオブジェクト = _
   ファイルシステムオブジェクト.OpenTextFile(入力ファイル名, 1)

   '*************データの読み込み***********
    Do Until 入力テキストストリームオブジェクト.AtEndOfStream
       処理行カウンタ = 処理行カウンタ + 1
       
       ' レコードの読み込み
       入力行 = Trim(入力テキストストリームオブジェクト.ReadLine)
       If 入力行 <> "" Then
'         Debug.Print 入力行
'         Stop
         Call 本文処理  '★★★★★★★★★
       End If

       If (処理行カウンタ Mod 10) = 0 Then
         ThisWorkbook.Worksheets("Sheet1").Range("J5").Value = 処理行カウンタ & " 行目を読込み"
       End If
       
       ' 最終行まで繰り返す
   Loop
    
   '**************終了処理*********************
   ThisWorkbook.Worksheets("Sheet1").Range("J5").Value = 処理行カウンタ & " 最終行まで読込み完了"
   
   ' 指定ファイルをCLOSE
   入力テキストストリームオブジェクト.Close
   Set 入力テキストストリームオブジェクト = Nothing
   
   Set ファイルシステムオブジェクト = Nothing
   Set 漢字索引 = Nothing  '★連想配列を削除
   
'   終了時刻 = Now()
'   MsgBox "処理が終了しました。" & Chr(13) & _
'   "処理時間は、" & Format(終了時刻 - 開始時刻, "nn分ss秒") & " でした。", vbOKOnly
   
   ThisWorkbook.Worksheets("Sheet1").Range("J5").Activate

End Sub

'★★★★★★★★★★★★★★★★★★★★★
Private Sub 本文処理()
'★★★★★★★★★★★★★★★★★★★★★
Dim 入力行文字数 As Integer

   Dim 漢字字数 As Integer
   Dim 検索文字目 As Long
   
'   Debug.Print 入力行
'   Stop
   入力行文字数 = Len(入力行)
   
   For 検索文字目 = 1 To 入力行文字数
      'If 処理行カウンタ = 143 And 検索文字目 = 220 Then Stop
   
      '既存ルビ部分の処理
      If Mid(入力行, 検索文字目, 1) = "|" Then       '|:ルビの付く文字列の始まりを示す記号
'      Stop
         漢字 = ""
         ルビ = ""
         If InStr(入力行, "》") > 0 And InStr(入力行, "《") > 0 Then
            Do While Mid(入力行, 検索文字目, 1) <> "》"  'ルビの終り
               If 検索文字目 < 入力行文字数 Then
                  検索文字目 = 検索文字目 + 1
                  Do While Mid(入力行, 検索文字目, 1) <> "《"  'ルビの初め
                     漢字 = 漢字 & Mid(入力行, 検索文字目, 1)
                     検索文字目 = 検索文字目 + 1
                  Loop
               End If
               If Mid(入力行, 検索文字目, 1) = "《" Then  'ルビの初め
                  If 検索文字目 < 入力行文字数 Then
                     検索文字目 = 検索文字目 + 1
                     Do While Mid(入力行, 検索文字目, 1) <> "》"   'ルビの終り
                        ルビ = ルビ & Mid(入力行, 検索文字目, 1)
                        検索文字目 = 検索文字目 + 1
                     Loop
                  End If
               End If
            Loop
            漢字数 = Len(漢字)
            Call 辞書シート追記
         End If
         
      ElseIf 漢字判定(Mid(入力行, 検索文字目, 1)) = True Then
         '漢字の場合
         漢字 = Mid(入力行, 検索文字目, 1)
         
         Do While 検索文字目 < 入力行文字数
            検索文字目 = 検索文字目 + 1
            
            If Mid(入力行, 検索文字目, 1) = "|" Then       '|:ルビの付く文字列の始まりを示す記号
               検索文字目 = 検索文字目 - 1
               If 漢字 <> "" Then
                  漢字数 = Len(漢字)
                  Call 辞書シート追記
                  Exit Do
               End If
            ElseIf Mid(入力行, 検索文字目, 1) = "《" Or Mid(入力行, 検索文字目, 1) = ")" _
               Or Mid(入力行, 検索文字目, 1) = "】" Then      '《:ルビの始まりかかっこの終わり
               If 漢字 <> "" Then
                  漢字数 = Len(漢字)
                  漢字 = 漢字 & Mid(入力行, 検索文字目, 1)
                  Call 辞書シート追記
                  Exit Do
               End If
            ElseIf 漢字判定(Mid(入力行, 検索文字目, 1)) = False Then
               '漢字以外の場合でかなの場合
               If Mid(入力行, 検索文字目, 1) Like "[あ-ん]" Then
                  If Len(漢字) = 1 Then '漢字1文字の場合は、送り仮名を含める
                     漢字 = 漢字 & Mid(入力行, 検索文字目, 1)
                     漢字数 = 1
                  Else
                     漢字数 = Len(漢字)
                  End If

                  Call 辞書シート追記
                  Exit Do
               Else 'それ以外
                  If 漢字 <> "" Then
                     漢字数 = Len(漢字)
                     Call 辞書シート追記
                     Exit Do
                  End If
               End If
            Else '漢字の場合
               漢字 = 漢字 & Mid(入力行, 検索文字目, 1)
            End If
         Loop
      Else 'かなの場合
         If Len(漢字) = 1 Then '漢字1文字の場合は、送り仮名を含める
         Stop
         '半角文字を除外、ルビ表示を除外、句読点を除外
            If Mid(入力行, 検索文字目, 1) <> StrConv(Mid(入力行, 検索文字目, 1), vbNarrow) _
            And Mid(入力行, 検索文字目, 1) <> "《" _
            And Mid(入力行, 検索文字目, 1) <> ")" _
            And Mid(入力行, 検索文字目, 1) <> "、" _
            And Mid(入力行, 検索文字目, 1) <> "。" Then
               漢字 = 漢字 & Mid(入力行, 検索文字目, 1)
            End If
         End If
         If 漢字 <> "" Then
         Stop
            漢字数 = Len(漢字)
            Call 辞書シート追記
         End If
      End If
      If 漢字 <> "" Then
         '行末の漢字
         漢字数 = Len(漢字)
         Call 辞書シート追記
      End If

   Next 検索文字目
   
   If 漢字 <> "" Then
      漢字数 = Len(漢字)
      Call 辞書シート追記
   End If

End Sub

'★★★★★★★★★★★★★★★★★★★★★
Sub 辞書シート追記()
'★★★★★★★★★★★★★★★★★★★★★
   If 漢字索引.Exists(漢字) = False Then
      '★漢字 が新規の場合
      出力行 = 出力行 + 1
      Worksheets("辞書").Range("A1").Cells(出力行, 1).Value = 漢字数
      Worksheets("辞書").Range("B1").Cells(出力行, 1).Value = Len(漢字)
      Worksheets("辞書").Range("C1").Cells(出力行, 1).Value = 漢字
      Worksheets("辞書").Range("D1").Cells(出力行, 1).Value = ルビ
      漢字索引(漢字) = 出力行
   End If
   漢字 = ""
   ルビ = ""
End Sub


'★★★★★★★★★★★★★★★★★★★★★
'文字が漢字の場合は true。それ以外の場合は false。
Public Function 漢字判定(ByVal 文字 As String) As Boolean
'★★★★★★★★★★★★★★★★★★★★★
   If 文字 Like "[亜-熙一-龠々]" Then
      漢字判定 = True
   Else
      漢字判定 = False
   End If
End Function
'★★★★★★★★★★★★★★★★★★★★★

参考にさせて頂いたサイト:
***********************
EXCELで漢字をひらがなに変換するツール
https://bitwave.showcase-tv.com/excel%E3%81%AE%E3%82%B3%E3%83%94%E3%83%9A%E6%BC%A2%E5%AD%97%E3%82%92%E3%81%B2%E3%82%89%E3%81%8C%E3%81%AA%E3%81%AB%E8%87%AA%E5%8B%95%E5%A4%89%E6%8F%9B%E3%81%99%E3%82%8B/

Application.GetPhonetic
https://excel-ubara.com/excelvba1/EXCELVBA404.html
https://www.moug.net/tech/exvba/0050134.html
https://so-zou.jp/software/tech/programming/vba/sample/kana.htm
https://vbabeginner.net/get-the-phonetic-guide-of-a-string/
https://docs.microsoft.com/ja-jp/office/vba/api/excel.application.getphonetic
https://excel-ubara.com/excelvba5/EXCEL101.html
http://officetanaka.net/excel/vba/tips/tips49.htm

 PHONETIC関数
https://excel-ubara.com/excel1/EXCEL596.html

Option Explicit

Public 処理行 As Integer
   
'★★★★★★★★★★★★★★★★★★★★★
Sub 漢字→かな()
'★★★★★★★★★★★★★★★★★★★★★
   Dim 最終行 As Integer
   Dim 漢字 As String
   Dim かな As String
   
'   開始時刻 = Now()
      
   ThisWorkbook.Worksheets("辞書").Activate
   'A 列(10列目)を基準に、最終行を求める
   最終行 = Cells(ActiveSheet.Rows.Count, 1).End(xlUp).Row
   
   For 処理行 = 2 To 最終行
      Range("D1").Cells(処理行, 1).Value _
      = StrConv(Application.GetPhonetic(Left((Range("C1").Cells(処理行, 1).Value), Range("B1").Cells(処理行, 1).Value)), vbHiragana)
      
      If Range("D1").Cells(処理行, 1).Value <> "" Then
      
         Range("E1").Cells(処理行, 1).Value _
         = Left(Range("C1").Cells(処理行, 1).Value, Len(Range("C1").Cells(処理行, 1).Value) _
         - Range("B1").Cells(処理行, 1).Value + Range("A1").Cells(処理行, 1).Value)

         Range("F1").Cells(処理行, 1).Value _
         = Left(Range("D1").Cells(処理行, 1).Value, Len(Range("D1").Cells(処理行, 1).Value) _
         - Range("B1").Cells(処理行, 1).Value + Range("A1").Cells(処理行, 1).Value)
      End If

   Next 処理行
   
'   終了時刻 = Now()
'   MsgBox "処理が終了しました。" & Chr(13) & _
'   "処理時間は、" & Format(終了時刻 - 開始時刻, "nn分ss秒") & " でした。", vbOKOnly
   
End Sub

Option Explicit

Public 包含行数 As Integer

'★★★★★★★★★★★★★★★★★★★★★
Sub 辞書準備()
'★★★★★★★★★★★★★★★★★★★★★
   Dim 配列()
   Dim 辞書カウンタ As Integer
   Dim 参照数配列(5000) As Integer

   '********************************
   '漢字・ルビ辞書を配列に格納
   '
   ThisWorkbook.Worksheets("辞書").Activate
   包含行数 = 0
   
   '漢字数逆順に並べて、同じ漢字・ルビが並ぶようにソート
   Range("A1").CurrentRegion.Sort _
   Key1:=Range("A2"), Order1:=xlDescending, _
   Key2:=Range("E2"), Order2:=xlDescending, _
   Key3:=Range("F2"), Order2:=xlDescending, _
   Header:=xlYes
   
   最終行 = Cells(ActiveSheet.Rows.Count, 1).End(xlUp).Row

   処理行 = 1
   Do While 処理行 <= 最終行  '漢字・ルビが同じものは除外
      処理行 = 処理行 + 1
      If Range("E1").Cells(処理行, 1).Value = Range("E1").Cells(処理行 + 1, 1).Value _
      And Range("F1").Cells(処理行, 1).Value = Range("F1").Cells(処理行 + 1, 1).Value Then
         Rows(処理行 + 1).Delete
         処理行 = 処理行 - 1
         最終行 = 最終行 - 1
      End If
   Loop
   
   最終行 = Cells(ActiveSheet.Rows.Count, 5).End(xlUp).Row '漢字空白以外

   配列 = ThisWorkbook.Worksheets("辞書").Range("E2").Resize(最終行 - 1, 2).Value
   
   Worksheets("辞書").Range("G2").Resize(最終行 - 1, 4).Clear        '前回の包含チェック結果を削除
   
   '漢字の包含チェック
   For 処理行 = 2 To 最終行
      For 辞書カウンタ = 処理行 To 最終行 - 1
         If InStr(Range("E1").Cells(処理行, 1).Value, 配列(辞書カウンタ, 1)) Then
         参照数配列(辞書カウンタ) = 参照数配列(辞書カウンタ) + 1
            Range("G1").Cells(処理行, 1).Value = 配列(辞書カウンタ, 1)
            Range("H1").Cells(処理行, 1).Value = 辞書カウンタ + 1
            Range("I1").Cells(辞書カウンタ + 1, 1).Value = 処理行
            Exit For
         End If
      Next 辞書カウンタ
      Range("J1").Cells(処理行, 1).Value = 参照数配列(処理行 - 1)
      If 参照数配列(処理行 - 1) >= 10 Then
         Range("J1").Cells(処理行, 1).Interior.ColorIndex = 3
         包含行数 = 包含行数 + 1
      ElseIf 参照数配列(処理行 - 1) >= 5 Then
         Range("J1").Cells(処理行, 1).Interior.ColorIndex = 7
         包含行数 = 包含行数 + 1
      ElseIf 参照数配列(処理行 - 1) >= 1 Then
         Range("J1").Cells(処理行, 1).Interior.ColorIndex = 6
         包含行数 = 包含行数 + 1
      End If
      
   Next 処理行
   
End Sub

正規表現を使用してグループ化する
https://ja.javascript.info/regexp-groups
https://www.javadrive.jp/regex-basic/meta/index9.html
$numberを使う事で、キャプチャグループに一致する部分文字列を置換文字列に含めることが出来ます。

https://xvideos.hatenablog.com/entry/vba_regex_expression
https://excel-ubara.com/excelvba4/EXCEL232.html
https://detail.chiebukuro.yahoo.co.jp/qa/question_detail/q13208748653
http://web-accountbook.com/index.aspx?page=2017060400

Option Explicit

Dim 入力ファイル名 As String
Dim 出力ファイル名 As String
Dim 入力行 As String
Dim 出力行 As String
Dim 入力行文字数 As Integer
Dim 処理行カウンタ As Integer

Dim 開始時刻 As Variant
Dim 終了時刻 As Variant
Dim 配列()
Dim 辞書カウンタ As Integer

'★★★★★★★★★★★★★★★★★★★★★
Sub 青空文庫Txtにルビ挿入()
'★★★★★★★★★★★★★★★★★★★★★

   Dim ファイルシステムオブジェクト As Object          ' FileSystemObject
   Dim 入力テキストストリームオブジェクト As Object    ' TextStream
   Dim 出力テキストストリームオブジェクト As Object    ' TextStream

   Application.DisplayStatusBar = True

   '変換対象のファイル名とパス取得
   ChDrive ThisWorkbook.Path
   ChDir ThisWorkbook.Path
   入力ファイル名 = Application.GetOpenFilename("TEXTファイル,*.txt")
   If 入力ファイル名 = "False" Then End
   出力ファイル名 = Left(入力ファイル名, Len(入力ファイル名) - 4) & "_ルビ" & ".txt"
       
   開始時刻 = Now()
   
   '********************************
   '漢字・ルビ辞書を配列に格納
   '
   ThisWorkbook.Worksheets("辞書").Activate

   最終行 = Cells(ActiveSheet.Rows.Count, 1).End(xlUp).Row

   配列 = ThisWorkbook.Worksheets("辞書").Range("E2").Resize(最終行 - 1, 2).Value

   '********************************
   'ファイルのオープン。
   処理行カウンタ = 0
   
   Set ファイルシステムオブジェクト = CreateObject("Scripting.FileSystemObject")
   
   ' 指定ファイルをOPEN(入力モード)
   Set 入力テキストストリームオブジェクト = _
    ファイルシステムオブジェクト.OpenTextFile(入力ファイル名, 1)

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

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

       出力行 = 入力行
       
       Call 本文処理  '★★★★★★★★★
       
       出力テキストストリームオブジェクト.WriteLine 出力行         ' 改行(CrLf)付き

       If (処理行カウンタ Mod 10) = 0 Then
         Application.StatusBar = 処理行カウンタ & " 行目を読込み"
       End If
       
       ' 最終行まで繰り返す
   Loop
    
   '**************終了処理*********************
   Application.StatusBar = "★" & 処理行カウンタ & " 最終行まで読込み完了 ★"
   
   ' 指定ファイルをCLOSE
    入力テキストストリームオブジェクト.Close
    Set 入力テキストストリームオブジェクト = Nothing
    出力テキストストリームオブジェクト.Close
    Set 出力テキストストリームオブジェクト = Nothing
    
    Set ファイルシステムオブジェクト = Nothing
   
   終了時刻 = Now()
   MsgBox "処理が終了しました。" & Chr(13) & _
   "処理時間は、" & Format(終了時刻 - 開始時刻, "nn分ss秒") & " でした。", vbOKOnly
   
End Sub


'★★★★★★★★★★★★★★★★★★★★★
Private Sub 本文処理()
'★★★★★★★★★★★★★★★★★★★★★

   For 辞書カウンタ = 1 To 最終行 - 1
      入力行 = Replace(入力行, 配列(辞書カウンタ, 1) _
      , "|" & 配列(辞書カウンタ, 1) & "《" & 配列(辞書カウンタ, 2) & "》")
      'ルビ記号の重複除去
      入力行 = Replace(入力行, "||", "|")
   Next 辞書カウンタ
   
   出力行 = 入力行
   
   '既存ルビの重複を除去 例:《どうか》《どうか》《きんぞく》《きんぞく》《つう》《いた》
'   正規表現のキャプチャグループの繰返しが何故か使えない
'   Dim 正規表現
'   Set 正規表現 = CreateObject("VBScript.RegExp")
'
'   ' 正規表現パターンをセット
'   正規表現.Pattern = "(《.+》)+"
'
'   ' 第一引数が置換対象の文字列、第二引数が置換後の文字列
'   出力行 = 正規表現.Replace(入力行, "$1")

   'このため文字列検索して対応する
   
   If InStr(出力行, "》《") > 0 Then
      Debug.Print 入力行
'      Stop
      
      Dim 検索文字目 As Integer
      Dim 重複候補 As String
      Dim カウンタ As Integer
      Dim 検索位置 As Integer
      Dim 検索位置配列(10) As Integer
      Dim 候補配列(10) As String
      
      検索位置配列(0) = 1
      For カウンタ = 1 To 重複候補数(出力行)
         検索位置配列(カウンタ) = InStr(検索位置配列(カウンタ - 1) + 1, 出力行, "》《")
         Debug.Print 検索位置配列(カウンタ)
         Debug.Print カウンタ
      Next カウンタ
         Debug.Print
      For カウンタ = 1 To 重複候補数(出力行)
      
         Debug.Print InStr(検索位置配列(カウンタ), 出力行, "》《")
         Debug.Print InStrRev(出力行, "《", InStr(検索位置配列(カウンタ), 出力行, "》《"))

         '前方を抽出
         重複候補 = Mid(出力行, InStrRev(出力行, "《", InStr(検索位置配列(カウンタ), 出力行, "》《")), _
         InStr(検索位置配列(カウンタ), 出力行, "》《") + 1 _
         - InStrRev(出力行, "《", InStr(検索位置配列(カウンタ), 出力行, "》《")))
         Debug.Print 重複候補
         候補配列(カウンタ) = 重複候補
      Next カウンタ

      '重複を除去
      For カウンタ = 1 To 重複候補数(出力行)
         出力行 = Replace(出力行, 候補配列(カウンタ) & 候補配列(カウンタ), 候補配列(カウンタ))
      Next カウンタ
      Debug.Print 出力行
'      Stop
   End If

End Sub


'★★★★★★★★★★★★★★★★★★★★★
Function 重複候補数(文字列 As String) As Integer
'★★★★★★★★★★★★★★★★★★★★★
   '"》《"の数を数える
   Dim 作業文字列 As String
   作業文字列 = 文字列
   重複候補数 = (Len(作業文字列) - Len(Replace(文字列, "》《", ""))) / 2
End Function

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 Variant
Dim 終了時刻 As Variant
Dim 配列()
Dim 辞書カウンタ As Integer

'★★★★★★★★★★★★★★★★★★★★★
Sub UTF8htmlに青空文庫形式でルビ挿入()
'★★★★★★★★★★★★★★★★★★★★★

   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()
   
   '********************************
   '漢字・ルビ辞書を配列に格納
   '
   ThisWorkbook.Worksheets("辞書").Activate

   最終行 = Cells(ActiveSheet.Rows.Count, 1).End(xlUp).Row
   配列 = ThisWorkbook.Worksheets("辞書").Range("E2").Resize(最終行 - 1, 2).Value

   '********************************

   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のオープン
            .LineSeparator = 10 'adLF  10 行送りを示します。
            .LoadFromFile (入力ファイル名)
         End With
         
         'adCR  13 改行復帰を示します。
         'adCRLF   -1 既定値です。改行復帰行送りを示します。
         'adLF  10 行送りを示します。
         
         出力ファイル名 = 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
         End With
         
         '*************データの読み込み***********
         Do Until 入力ADODBストリーム.EOS
         
            処理行カウンタ = 処理行カウンタ + 1
            
            ' レコードの読み込み
            入力行 = 入力ADODBストリーム.ReadText(-2) '-2 adReadLine
'            Debug.Print 入力行
'            Stop

            出力行 = 入力行
                        
            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 本文処理()
'★★★★★★★★★★★★★★★★★★★★★

   For 辞書カウンタ = 1 To 最終行 - 1
      入力行 = Replace(入力行, 配列(辞書カウンタ, 1) _
      , "|" & 配列(辞書カウンタ, 1) & "《" & 配列(辞書カウンタ, 2) & "》")
      'ルビ記号の重複除去
      入力行 = Replace(入力行, "||", "|")

   Next 辞書カウンタ
   
   出力行 = 入力行
   
   '既存ルビの重複を除去 例:《どうか》《どうか》《きんぞく》《きんぞく》《つう》《いた》
'   正規表現のキャプチャグループの繰返しが何故か使えない
'   Dim 正規表現
'   Set 正規表現 = CreateObject("VBScript.RegExp")
'
'   ' 正規表現パターンをセット
'   正規表現.Pattern = "(《.+》)+"
'
'   ' 第一引数が置換対象の文字列、第二引数が置換後の文字列
'   出力行 = 正規表現.Replace(入力行, "$1")

   'このため文字列検索して対応する
   If InStr(出力行, "》《") > 0 Then
      Debug.Print 入力行
'      Stop
      
      Dim 検索文字目 As Integer
      Dim 重複候補 As String
      Dim カウンタ As Integer
      Dim 検索位置 As Integer
      Dim 検索位置配列(10) As Integer
      Dim 候補配列(10) As String
      
      検索位置配列(0) = 1
      For カウンタ = 1 To 重複候補数(出力行)
         検索位置配列(カウンタ) = InStr(検索位置配列(カウンタ - 1) + 1, 出力行, "》《")
         Debug.Print 検索位置配列(カウンタ)
         Debug.Print カウンタ
      Next カウンタ
         Debug.Print
      For カウンタ = 1 To 重複候補数(出力行)
      
         Debug.Print InStr(検索位置配列(カウンタ), 出力行, "》《")
         Debug.Print InStrRev(出力行, "《", InStr(検索位置配列(カウンタ), 出力行, "》《"))

         '前方を抽出
         重複候補 = Mid(出力行, InStrRev(出力行, "《", InStr(検索位置配列(カウンタ), 出力行, "》《")), _
         InStr(検索位置配列(カウンタ), 出力行, "》《") + 1 _
         - InStrRev(出力行, "《", InStr(検索位置配列(カウンタ), 出力行, "》《")))
         Debug.Print 重複候補
         候補配列(カウンタ) = 重複候補
      Next カウンタ
      
      '重複を除去
      For カウンタ = 1 To 重複候補数(出力行)
         出力行 = Replace(出力行, 候補配列(カウンタ) & 候補配列(カウンタ), 候補配列(カウンタ))
      Next カウンタ
      Debug.Print 出力行
'      Stop
   End If

End Sub

'★★★★★★★★★★★★★★★★★★★★★
Function 重複候補数(文字列 As String) As Integer
'★★★★★★★★★★★★★★★★★★★★★
   '"》《"の数を数える
   Dim 作業文字列 As String
   作業文字列 = 文字列
   重複候補数 = (Len(作業文字列) - Len(Replace(文字列, "》《", ""))) / 2
End Function

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


「青空文庫」のルビを、HTMLのルビ・タグに変更する
 以下は、Vertical Editor の項で紹介した、「青空文庫」のルビを、HTMLのルビ・タグに変更するVBAの、メイン・ルーチンの部分です。

    【青空文庫のルビ記号】
    《》:ルビ
    (例)生憎《あいにく》
       ↓
      HTML表記→生憎(あいにく)
このマクロをダウンロードできます。RubyTagHtmlOrTextFSOvba03.xls

UTF-8 版 もあります。

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 Variant
Dim 終了時刻 As Variant
Dim 拡張子 As String


Sub ルビタグ変換()

   Dim ファイルシステムオブジェクト As Object          ' FileSystemObject
   Dim ファイルオブジェクト As Object
   Dim 入力テキストストリームオブジェクト As Object    ' TextStream
   Dim 出力テキストストリームオブジェクト As Object    ' TextStream

   '変換対象のファイル名とパス取得
   ChDrive ThisWorkbook.Path
   ChDir ThisWorkbook.Path
   
   Set ファイルシステムオブジェクト = CreateObject("Scripting.FileSystemObject")

   '変換対象のファイル名とパス取得
   入力ファイル名 = Application.GetOpenFilename("html か txt ファイル,*.htm?;*.txt")
   If 入力ファイル名 = "False" Then End
   'ファイルオブジェクトを取得
   Set ファイルオブジェクト = ファイルシステムオブジェクト.GetFile(入力ファイル名)
   拡張子 = ファイルシステムオブジェクト.GetExtensionName(入力ファイル名)
   出力ファイル名 = ファイルオブジェクト.ParentFolder.Path & "\" _
      & ファイルシステムオブジェクト.GetBaseName(入力ファイル名) & "_Ruby." & 拡張子
   
'   Stop
        
   開始時刻 = Now()
   
   '********************************
   'ファイルのオープン。
   bodyフラグ = 0
   処理行カウンタ = 0
   
   
   ' 指定ファイルをOPEN(入力モード)
   Set 入力テキストストリームオブジェクト = _
   ファイルシステムオブジェクト.OpenTextFile(入力ファイル名, 1)

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

   '*************データの読み込み***********
   Do Until 入力テキストストリームオブジェクト.AtEndOfStream
   
      処理行カウンタ = 処理行カウンタ + 1
       
      ' レコードの読み込み
      入力行 = 入力テキストストリームオブジェクト.ReadLine
      
      出力行 = 入力行
      
      If Trim(入力行) = "</body>" Then
          bodyフラグ = 0
      End If
      
      If (拡張子 = "txt" Or bodyフラグ = 1) And Len(Trim(入力行)) > 0 Then
          Call 本文処理  '★★★★★★★★★
      End If
      
      If Left(Trim(入力行), 5) = "<body" Then
          bodyフラグ = 1
      End If
      
      出力テキストストリームオブジェクト.WriteLine 出力行         ' 改行(CrLf)付き
      
      If (処理行カウンタ Mod 10) = 0 Then
      Range("A4").Value = 処理行カウンタ & " 行目を読込み"
      End If
      
      ' 最終行まで繰り返す
   Loop
   
   '**************終了処理*********************
   Range("A4").Value = 処理行カウンタ & " 最終行まで読込み完了"
   
   ' 指定ファイルをCLOSE
   入力テキストストリームオブジェクト.Close
   Set 入力テキストストリームオブジェクト = Nothing
   出力テキストストリームオブジェクト.Close
   Set 出力テキストストリームオブジェクト = Nothing
   
   Set ファイルシステムオブジェクト = Nothing

   
   終了時刻 = Now()
   MsgBox "処理が終了しました。" & Chr(13) & _
   "処理時間は、" & Format(終了時刻 - 開始時刻, "nn分ss秒") & " でした。", vbOKOnly
   
   Range("A4").Activate

End Sub

Private Sub 本文処理()
   Dim 先読み数 As Integer
   出力行 = ""
   地文字数 = 0 '地文字とは、ルビでない部分
   漢字字数 = 0
   ルビ字数 = 0
   漢字文字フラグ = 0
   ルビ文字フラグ = 0
   地文字フラグ = 1 '地文字とは、ルビでない部分
   
   入力行文字数 = Len(入力行)

   For 検索文字目 = 入力行文字数 To 1 Step -1
      Debug.Print Mid(入力行, 検索文字目, 1)
'      Stop
      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日追加
          出力行 = "</rt><rp>)</rp></ruby><ruby><rb>" _
          & Mid(入力行, 検索文字目 + 1, 漢字字数 - 1) & 出力行
          
          漢字字数 = 0
          漢字文字フラグ = 0
          
          地文字数 = 0
          ルビ字数 = 0     '前回のルビ字数をリセット
          地文字フラグ = 0
          ルビ文字フラグ = 1
      
      ElseIf Mid(入力行, 検索文字目, 1) = "》" Then
         If Mid(入力行, 検索文字目 - 1, 1) <> "《" Then
            出力行 = "</rt><rp>)</rp></ruby>" & Mid(入力行, 検索文字目 + 1, 地文字数 - 1) & 出力行
            地文字数 = 0
            ルビ字数 = 0     '前回のルビ字数をリセット
            地文字フラグ = 0
            ルビ文字フラグ = 1
         End If
          
      ElseIf Mid(入力行, 検索文字目, 1) = "《" Then
         If ルビ文字フラグ = 1 Then
             出力行 = "</rb><rp>(</rp><rt>" & Mid(入力行, 検索文字目 + 1, ルビ字数 - 1) & 出力行
             
             If 検索文字目 > ルビ字数 + 1 Then
   
               For 先読み数 = 1 To ルビ字数 + 1 '|ガラス戸《がらすど》
                 If Mid(入力行, 検索文字目 - 先読み数, 1) = "|" _
                    Or Mid(入力行, 検索文字目 - 先読み数, 1) = "│" Then      '"|"JIS 8162は記号の縦線。"│"JIS 84A0は罫線の縦線
                    検索文字目 = 検索文字目 - 先読み数
                    出力行 = "<ruby><rb>" & Mid(入力行, 検索文字目 + 1, 先読み数 - 1) & 出力行
                    漢字字数 = 0
                    漢字文字フラグ = 0
                    地文字フラグ = 1
                    Exit For
                 Else
                    漢字字数 = 0     '前回の漢字字数をリセット
                    ルビ文字フラグ = 0
                    漢字文字フラグ = 1
                 End If
               Next
             Else
               漢字字数 = 0     '前回の漢字字数をリセット
               ルビ文字フラグ = 0
               漢字文字フラグ = 1
             End If
         End If
      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       '(例)1円山応挙《まるやまおうきょ》
          '★夜明け前対応★★★★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


 解説:
 CreateObject 関数は、ActiveX オブジェクトへの参照を作成して、返します。

 CreateObject(class,[servername])

 class 必ず指定します。内部処理形式が文字型 (String) のバリアント型 (Variant) の値を指定します。作成するオブジェクトのクラスとアプリケーションの名前を指定します。

 servername 省略可能です。内部処理形式が文字型 (String) のバリアント型 (Variant) の値を指定します。作成するオブジェクトを保存するネットワーク サーバの名前を指定します。ローカル マシンで使用する場合は、空の文字列 ("") を指定します。

引数 class は、appname.objecttype の形式で指定します。

 appname 必ず指定します。内部処理形式が文字型 (String) のバリアント型 (Variant) の値を指定します。オブジェクトを提供しているアプリケーションの名前を指定します。
 objecttype 必ず指定します。内部処理形式が文字型 (String) のバリアント型 (Variant) の値を指定します。作成するオブジェクトの種類またはクラスを指定します。

 ActiveX オートメーションに対応しているアプリケーションでは、少なくとも 1 種類のオブジェクトが提供されています。
 たとえば、ワード プロセッサの場合、アプリケーション (Application) オブジェクト、文書 (Document) オブジェクト、ツールバー (Toolbar) オブジェクトなどが提供されます。

 ActiveX オブジェクトを作成するには、CreateObject 関数の戻り値をオブジェクト変数に代入します。


' オブジェクトへの参照を格納するためにオブジェクト変数を宣言します。
' Dim as Object で宣言すると、実行時バインディングが行われます。
Dim ExcelSheet As Object
Set ExcelSheet = CreateObject("Excel.Sheet")

 このコードを実行すると、オブジェクトを作成するアプリケーションが起動します。この場合は、Microsoft Excel のワークシートが作成されます。一度オブジェクトが作成されると、定義したオブジェクト変数を使って、コード中のオブジェクトを参照できます。

 次の例では、オブジェクト変数 ExcelSheet を使用して、新しく作成したオブジェクトのプロパティおよびメソッドを操作します。
また、Application オブジェクト、Cells コレクションなどのほかの Microsoft Excel のオブジェクトも使用しています。


' Application オブジェクトから Excel のワークシートを表示します。
ExcelSheet.Application.Visible = True
' シートの最初のセルに文字列を入力します。
ExcelSheet. Application.Cells(1, 1).Value = "これは列 A、行 1 です。"
' ワークシートをファイル C:\test.xls に保存します。
ExcelSheet.SaveAs "C:\ TEST.XLS"
' Application オブジェクトの Quit メソッドで Excel を終了します。
ExcelSheet.Application.Quit
' オブジェクト変数を解放します。
Set ExcelSheet = Nothing

 As Object 節を使用してオブジェクト変数を宣言すると、任意の種類のオブジェクトへの参照を格納できる変数を作成できます。ただし、このような変数を使用してオブジェクトを操作する場合は、実行時バインディングが行われます。つまり、プログラムの実行時にバインディングが行われます。

 これに対し、事前バインディングは、プログラムのコンパイル時にバインディングが行われます。事前バインディングを行うオブジェクト変数を作成するには、特定のクラス ID を指定してオブジェクト変数を宣言します。
 たとえば、次のような Microsoft Excel への参照を宣言して作成できます

Dim xlApp As Excel.Application
Dim xlBook As Excel.Workbook
Dim xlSheet As Excel.WorkSheet

Set xlApp = CreateObject("Excel.Application")
Set xlBook = xlApp.Workbooks.Add
Set xlSheet = xlBook.Worksheets(1)

 事前バインディングを行う変数を使用して参照した方が、パフォーマンスが良くなります。ただし、これらの変数に格納できるのは、宣言のときに指定したクラスへの参照のみです。

 また、CreateObject 関数から返ったオブジェクトを、引数としてオブジェクトが必要な関数に渡せます。
たとえば、次のコードは、Excel.Application オブジェクトへの参照を作成して引き渡します。

Call MySub (CreateObject("Excel.Application"))

 CreateObject 関数の引数 servername にコンピュータの名前を指定すると、リモート ネットワーク コンピュータにオブジェクトを作成できます。その名前は、共有名のマシン名の部分と同じになります。たとえば、共有名が "\\MyServer\Public," の場合、servername は "MyServer" になります。

 メモ:リモート ネットワーク コンピュータに作成できるアプリケーションについては、Microsoft Developer Network の COM のドキュメント参照してください。アプリケーションのレジストリ キーに追加することをお勧めします。

 次の例では、MyServer という名前のリモート コンピュータで実行されている Excel インスタンスのバージョン番号を返します。

Dim xlApp As Object
Set xlApp = CreateObject("Excel.Application", "MyServer")
Debug.Print xlApp.Version

 リモート サーバーが存在しないか、無効の場合は、実行時エラーが発生します。

 メモ:オブジェクトの現在のインスタンスがないときは、CreateObject 関数を使います。オブジェクトのインスタンスが既に実行されているときは、新しいインスタンスが起動されて、指定した型のオブジェクトが作成されます。現在のインスタンスを使用する場合、またはアプリケーションを起動してファイルを読み込む場合には、GetObject 関数を使います。

 複数のインスタンスを作成できないオブジェクトとして登録されているオブジェクトの場合には、CreateObject 関数を何回実行しても、そのオブジェクトのインスタンスは 1 つしか作成されません。

 参考:ActiveX オートメーションとは
参照設定(事前バインディング)と実行時バインディング★
http://www.moug.net/shop/sample/VBA_Expert_Pro_Sample.pdf
 実行時バインディングを使うと、環境に左右されにくい、汎用的なコーディングにすることができます。極端な例では、VBScript に、そのまま移植できます。

 実行時バインディングと事前バインディングの、コードの違い
http://www.moug.net/tech/exvba/0060061.htm


 FileSystemObject オブジェクトは、コンピュータのファイル システムへのアクセスを提供します。

 FileSystemObjectの使い方まとめ
https://d.hatena.ne.jp/nacookan/20080221/1203607060
 ↑使い方が、うまく整理されています。

 GEN MUTO'S HOMEPAGE > エクセル大事典 > エクセルからファイルを操作してみよう!
http://home.att.ne.jp/zeta/gen/excel/c04p24.htm
http://home.att.ne.jp/zeta/gen/excel/c04p25.htm
http://home.att.ne.jp/zeta/gen/excel/c04p26.htm

 構文:Scripting.FileSystemObject

 次のコードは、FileSystemObject オブジェクトを使用して、読み書きできる TextStream オブジェクトを返す例です。

Sub CreateAfile
    Set fs = CreateObject("Scripting.FileSystemObject")
    Set a = fs.CreateTextFile("c:\testfile.txt", True)
    a.WriteLine("This is a test.")
    a.Close
End Sub

 上記のコード例では、CreateObject 関数で FileSystemObject オブジェクト (fs) を返します。
次に、CreateTextFile メソッドでファイルを TextStream オブジェクト (a) として作成し、
WriteLine メソッドで 1 行の文字列を作成されたテキスト ファイルに書き込んでいます。
Close メソッドでバッファをフラッシュし、ファイルを閉じます。

 オブジェクト変数 a は FileSystemObject の CreateTextFile メソッドで返された TextStream オブジェクトです。
 WriteLine と Close は、TextStream オブジェクトのメソッドです。


 FileSystemObject のメソッド
http://msdn.microsoft.com/ja-jp/library/cc428078.aspx

 サンプルコード(Bellbig co.,Ltd パソコン講座 > VBA講座 )
http://officetanaka.net/excel/vba/filesystemobject/filesystemobject.htm

メソッド内容
Add メソッド (Dictionary) キーと項目のペアを Dictionary オブジェクトに追加します。
Add メソッド (Folders) 新しいフォルダを Folders コレクションに追加します。
BuildPath メソッド 名前を既存のパスの末尾に付加します。
Close メソッド 開いている TextStream ファイルを閉じます。
Copy メソッド 指定したファイルまたはフォルダを、ある場所から別の場所にコピーします。
CopyFile メソッド 1 つまたは複数のファイルを、ある場所から別の場所にコピーします。
CopyFolder メソッド フォルダを、ある場所から別の場所に再帰的にコピーします。
CreateFolder メソッド フォルダを作成します。
CreateTextFile メソッド 指定した名前のファイルを作成し、そのファイルの読み取り、書き込みに使用できる TextStream オブジェクトを返します。
Delete メソッド 指定したファイルまたはフォルダを削除します。
DeleteFile メソッド 指定したファイルを削除します。
DeleteFolder メソッド 指定したフォルダとその中身を削除します。
DrivesExists メソッド 指定したドライブが存在すれば true を返し、存在しなければ false を返します。
Exists メソッド 指定したキーが Dictionary オブジェクト内に存在すれば true を返し、存在しなければ false を返します。
FileExists メソッド 指定したファイルが存在すれば true を返し、存在しなければ false を返します。
FolderExists メソッド 指定したフォルダが存在すれば true を返し、存在しなければ false を返します。
GetAbsolutePathName メソッド 指定したパスから、省略されていない完全なパスを返します。
GetBaseName メソッド パスの最後の構成要素のベース名 (ファイル拡張子を除いたもの) を表す文字列を返します。
GetDrive メソッド 指定したパスのドライブに対応する Drive オブジェクトを返します。
GetDriveName メソッド 指定したパスのドライブ名を表す文字列を返します。
GetExtensionName メソッド パスの最後の構成要素の拡張子名を表す文字列を返します。
GetFile メソッド 指定したパスにあるファイルに対応する File オブジェクトを返します。
GetFileName メソッド 指定したパスの最後の構成要素のうちドライブ指定以外の部分を返します。
GetFileVersion メソッド 指定したファイルのバージョン番号を返します。
GetFolder メソッド 指定したパスにあるフォルダに対応する Folder オブジェクトを返します。
GetParentFolderName メソッド 指定したパスの最後の構成要素の親フォルダ名を表す文字列を返します。
GetSpecialFolder メソッド 指定した特殊フォルダのオブジェクトを返します。
GetTempName メソッド ランダムに生成される一時ファイルまたは一時フォルダの名前を返します。これらは一時ファイルや一時フォルダを必要とする処理を実行する際に便利です。
Items メソッド Dictionary オブジェクト内のすべての項目を格納した配列を返します。
Keys メソッド Dictionary オブジェクト内のすべての既存のキーを格納した配列を返します。
Move メソッド 指定したファイルまたはフォルダを、ある場所から別の場所に移動します。
MoveFile メソッド 1 つまたは複数のファイルを、ある場所から別の場所に移動します。
MoveFolder メソッド 1 つまたは複数のフォルダを、ある場所から別の場所に移動します。
OpenAsTextStream メソッド 指定したファイルを開き、ファイルの読み書きや追加書き込みに使用できる TextStream オブジェクトを返します。
OpenTextFile メソッド 指定したファイルを開き、ファイルの読み書きや追加書き込みに使用できる TextStream オブジェクトを返します。
Read メソッド 指定した数の文字を TextStream ファイルから読み取り、その結果の文字列を返します。
ReadAll メソッド TextStream ファイル全体を読み取り、その結果の文字列を返します。
ReadLine メソッド TextStream ファイルから 1 行 (改行文字を含まない) を読み取り、その結果の文字列を返します。
Remove メソッド キーと項目の 1 組のペアを Dictionary オブジェクトから削除します。
RemoveAll メソッド すべてのキーと項目のペアを Dictionary オブジェクトから削除します。
Skip メソッド TextStream ファイルを読み取るときに、指定した文字数をスキップします。
SkipLine TextStream ファイルを読み取るときに、次の行をスキップします。
Write メソッド 指定した文字列を TextStream ファイルに書き込みます。
WriteBlankLines メソッド 指定した数の改行文字を TextStream ファイルに書き込みます。
WriteLine メソッド 指定した文字列と改行文字を TextStream ファイルに書き込みます。

 FileSystemObject のコレクション
http://msdn.microsoft.com/ja-jp/library/cc428076.aspx

コレクション内容
Drives コレクション 利用可能なすべてのドライバの読み取り専用コレクションです。
Files コレクション フォルダ内にあるすべての File オブジェクトのコレクションです。
Folders コレクション Folder オブジェクト内に含まれているすべての Folder オブジェクトのコレクションです。

 FileSystemObject のプロパティ
http://msdn.microsoft.com/ja-jp/library/cc428082.aspx

プロパティ内容
AtEndOfLine プロパティ ファイル ポインタが TextStream ファイル内で行末マーカーの直前にあれば true を返し、直前になければ false を返します。
AtEndOfStream プロパティ ファイル ポインタが TextStream ファイルの末尾にあれば true を返し、末尾になければ false を返します。
Attributes プロパティ ファイルまたはフォルダの属性を設定または参照します。
AvailableSpace プロパティ 指定したドライブ上またはネットワーク共有上でユーザーが利用可能な領域の量を返します。
Column プロパティ TextStream ファイル内での現在の文字位置の列番号を返します。
CompareMode プロパティ Dictionary オブジェクト内の文字列キーを比較する際の比較モードを設定または参照します。
Count プロパティ コレクション内または Dictionary オブジェクト内にある項目の数を返します。
DateCreated プロパティ 指定したファイルまたはフォルダが作成された日付と時刻を返します。読み取り専用です。
DateLastAccessed プロパティ 指定したファイルまたはフォルダが最後にアクセスされた日付と時刻を返します。
DateLastModified プロパティ 指定したファイルまたはフォルダが最後に変更された日付と時刻を返します。
Drive プロパティ 指定したファイルまたはフォルダのあるドライブのドライブ名を返します。
DriveLetter プロパティ 物理ローカル ドライブまたはネットワーク共有のドライブ名を返します。
Drives プロパティ ローカル コンピュータ上で利用可能なすべての Drive オブジェクトからなる Drives コレクションを返します。
DriveType プロパティ 指定したドライブの種類を示す値を返します。
Files プロパティ 指定したフォルダ内にあるすべての File オブジェクトからなる Files コレクションを返します。隠しファイル属性やシステム ファイル属性が設定されたものも含まれます。
FileSystemProperty 指定したドライブで使用されているファイル システムの種類を返します。
FreeSpace プロパティ 指定したドライブ上またはネットワーク共有上でユーザーが利用可能な空き領域の量を返します。
IsReady プロパティ 指定したドライブがレディ状態であれば true を返し、レディ状態でなければ false を返します。
IsRootFolder プロパティ 指定したフォルダがルート フォルダであれば true を返し、ルート フォルダでなければ false を返します。
Item プロパティ Dictionary オブジェクト内において指定したキーに対応する項目を設定または参照します。コレクションの場合は、指定したに基づくを返します。
Key プロパティ Dictionary オブジェクト内でキーを設定します。
Line プロパティ TextStream ファイルにおける現在の行番号を返します。
Name プロパティ 指定したファイルまたはフォルダの名前を設定または参照します。
ParentFolder プロパティ 指定したファイルまたはフォルダの親にあたるフォルダ オブジェクトを返します。
Path プロパティ 指定したファイル、フォルダ、またはドライブのパスを返します。
RootFolder プロパティ 指定したドライブのルート フォルダを表す Folder オブジェクトを返します。
SerialNumber プロパティ ディスク ボリュームを一意に識別するために使用する 10 進シリアル番号を返します。
ShareName プロパティ 指定したドライブのネットワーク共有名を返します。
ShortName プロパティ 8.3 命名規則を必要とするプログラムで使用する短い名前を返します。
ShortPath プロパティ 8.3 命名規則を必要とするプログラムで使用する短いパスを返します。
Size プロパティ ファイルの場合は、指定したファイルのサイズをバイト単位で返します。フォルダの場合は、フォルダに含まれているすべてのファイルおよびサブフォルダの合計サイズをバイト単位で返します。
SubFolders プロパティ 指定したフォルダ内にあるすべてのフォルダからなる Folders コレクションを返します。隠しファイル属性やシステム ファイル属性が設定されたものも含まれます。
TotalSize プロパティ ドライブまたはネットワーク共有の総容量をバイト単位で返します。
Type プロパティ ファイルまたはフォルダの種類に関する情報を返します。
VolumeName プロパティ 指定したドライブのボリューム名を設定または参照します。


 FileExists メソッドは、指定されたファイルが存在する場合は、真 (True) を返します。存在しない場合は、偽 (False) を返します。

object.FileExists(filespec)

object 必ず指定します。FileSystemObject オブジェクトの名前を指定します。
filespec 必ず指定します。存在するかどうかを調べるファイルの名前を指定します。カレント フォルダ内にないファイルの場合は、フル パスを指定する必要があります。絶対パス、または相対パスのどちらでも指定できます。

 Delete メソッドは、指定されたファイルまたはフォルダを削除します。

object.Delete force

object 必ず指定します。File オブジェクトまたは Folder オブジェクトの名前を指定します。
force 省略可能です。真 (True) を指定すると読み取り専用のファイルやフォルダも削除されます。既定値の偽 (False) を指定すると読み取り専用のファイルやフォルダを削除しません。

 指定したファイルまたはフォルダが存在しなかった場合は、エラーが発生します。
 File オブジェクトまたは Folder オブジェクトに対して実行した Delete メソッドの結果は、FileSystemObject.DeleteFile または FileSystemObject.DeleteFolder を使って行った処理とまったく同じです。
 Delete メソッドでは、ほかのフォルダやファイルを含むフォルダと何も含まないフォルダとは区別されません。指定したフォルダは、ほかのファイルやフォルダが格納されているかどうかに関係なく削除されます。

 DeleteFile メソッドは、指定されたファイルを削除します。

object.DeleteFile filespec[, force]

object 必ず指定します。FileSystemObject オブジェクトの名前を指定します。
filespec 必ず指定します。削除するファイルの名前を指定します。パスの最後の構成要素内ではワイルドカード文字を使用できます。
force 省略可能です。真 (True) を指定すると、読み取り専用のファイルも削除されます。既定値の偽 (False) を指定すると、読み取り専用のファイルは削除されません。

 名前の一致するファイルが見つからない場合は、エラーが発生します。DeleteFile メソッドは、最初のエラーが発生した時点で処理を中止します。エラーが発生するまでに行った処理を取り消したり元に戻したりする処理は一切行われません。

 DeleteFolder メソッド は、指定されたフォルダおよびそのフォルダ内のフォルダとファイルを削除します。
object.DeleteFolder ( folderspec[, force] ); 
引数
object
必ず指定します。FileSystemObject オブジェクトの名前を指定します。
folderspec
必ず指定します。削除するフォルダの名前を指定します。パスの最後の構成要素内ではワイルドカード文字を使用できます。
force
省略可能です。真 (true) を指定すると、読み取り専用の属性を持つフォルダも削除されます。
偽 (false) を指定すると、読み取り専用フォルダは削除されません (既定値)。
読み取り専用フォルダをデフォルトで削除しようとすると、下記のエラーになります。
 実行時エラー '70': 書き込みできません。
解説
 DeleteFolder メソッドでは、ほかのフォルダやファイルを含むフォルダと何も含まないフォルダとは区別されません。
指定したフォルダは、ほかのファイルやフォルダが格納されているかどうかに関係なく削除されます。
 名前の一致するフォルダが見つからない場合は、エラーが発生します。
DeleteFolder メソッドは、最初のエラーが発生した時点で処理を中止します。
エラーが発生するまでに行った処理を、取り消したり元に戻したりする処理は一切行われません。


 参考:FileSystemObjectの解説
http://officetanaka.net/excel/vba/filesystemobject/
Microsoft Scripting Runtime を参照
 FileSystemObject を使うときには、Microsoft Scripting Runtime を参照するように設定すると便利です。
 コンパイルによる型チェックができるようになります。
 コード補完が機能するので、オブジェクト用の変数名のあとにピリオドを入力したとき、メソッドやプロパティの候補が表示されるようになります。

 VBE(Visual Basic Editor)で、
ツール(T)→参照設定(R)を選択して、表示される画面で、
「Microsoft Scripting Runtime」にチェックを付けて、
OK ボタンをクリック します。(右図参照)

 参照可能なライブラリ ファイル の一覧に、「Microsoft Scripting Runtime」が表示されない場合は、右側の参照ボタンを押して、
C:\WINDOWS\system32\scrrun.dll
を、直接、選択して下さい。


 Scrrun.dll が存在するのに、Scripting.FileSystemObject で、
 エラー番号 -2147319779 VBAProject でエラーが発生しました。
オートメーション エラーです。
ライブラリは登録されていません。


 と表示される場合は、レジストリが壊れている可能性が有ります。
 パソコンを立ち上げて、Excelなどのプログラムを起動させていない時点で、コマンド・プロンプトで、下記を実行して、レジストリを一旦、削除します。
regsvr32 /u Scrrun.dll
「成功しました。」という、メッセージが表示されたら、下記で、最インストールします。
regsvr32 Scrrun.dll


 Windows Script の 最新版のダウンロード
http://www.microsoft.com/japan/msdn/scripting/



 TextStream オブジェクトは、ファイルへのシーケンシャル アクセスを行うオブジェクトです。

 構文:TextStream.{property | method}

 引数 property と引数 method には、TextStream オブジェクトに関連付けられている任意のプロパティとメソッドを指定します。
 実際の TextStream オブジェクトの使用は、FileSystemObject で返される TextStream オブジェクトを表す変数プレースホルダに置き換えられます。


 OpenTextFile メソッドは、指定されたファイルを開き、ファイルを読み込んだり、文字列を追加するときに使用する TextStream オブジェクトを返します。

 構文:object.OpenTextFile(filename[, iomode[, create[, format]]])

 object 必ず指定します。FileSystemObject オブジェクトの名前を指定します。
 filename 必ず指定します。開くファイルを示す文字列式を指定します。
 iomode 省略可能です。読み込み、または書き込みのいずれのためにファイルを開くのかを示す、ForReading または ForAppending のいずれかの定数を指定します。
 create 引数 filename で指定されたファイルが存在しない場合に新しいファイルを作成するかどうかを示すブール値を指定します。
新しいファイルを作成する場合は、真 (True) を指定し、作成しない場合は、偽 (False) を指定します。
既定値は False なので、省略すると、新しいファイルは作成されません。

 format 省略可能です。開くファイルの形式を示す値を指定します。省略すると、ASCII ファイルとして開かれます。

 設定値:
引数定数説明
iomodeForReading1読み取り専用でファイルを開きます。このファイルに書き込むことはできません。
ForWriting2ファイルを書き込み専用として開きます。 既存のファイルを新しいデータで置き換える場合はこのモードを使用します。 このファイルからの読み取りはできません。
ForAppending8ファイルを開き、ファイルの末尾から書き込みます。
formatTristateUseDefault-2システムの既定値を使ってファイルを開きます。
TristateTrue-1Unicode としてファイルを開きます。
TristateFalse0ASCII ファイルとしてファイルを開きます。

 注:TristateTrue などのパラメータを使うためには、VBE で[Microsoft Scripting Runtime]を参照設定する必要があります。
 http://www.relief.jp/itnote/archives/fso-vba-references.php

 次の例は、OpenTextFile メソッドを使用して、ファイルを開いたり、文字列を追加するコードです。
Sub OpenTextFileTest
    Const ForReading = 1, ForWriting = 2, ForAppending = 3
    Dim fs, f
    Set fs = CreateObject("Scripting.FileSystemObject")
    Set f = fs.OpenTextFile("c:\testfile.txt", ForAppending,TristateFalse)
    f.Write "Hello world!"
    f.Close
End Sub


 CreateTextFile メソッドは、指定されたファイル名のファイルを作成し、ファイルを読み込んだり、書き込むときに使用する TextStream オブジェクトを返します。

 構文:object.CreateTextFile(filename[, overwrite[, unicode]])

 object 必ず指定します。FileSystemObject オブジェクト、または Folder オブジェクトの名前を指定します。
 filename 必ず指定します。作成するファイルを示す文字列式を指定します。
 overwrite 省略可能です。既にあるファイルを上書きするかどうかを示すブール値を指定します。
  ファイルを上書きする場合は、真 (True) を指定し、上書きしない場合は、偽 (False) を指定します。
  省略すると、ファイルは上書きされません。

 引数 overwrite の指定を偽 (False) または省略した場合に、引数 filename で既存のファイルを指定するとエラーとなります。

 unicode 省略可能です。Unicode または ASCII ファイルのいずれかで作成されたファイルかを示すブール値を指定します。Unicode で作成されたファイルでは、真 (True) を指定します。ASCII ファイルで作成されたファイルでは、偽 (False) を指定します。省略した場合、ASCII ファイルで作成されたファイルとします。

 次の例は、CreateTextFile メソッドを使用して、テキスト ファイルを作成し、開くコードです。

Sub CreateAfile
    Set fs = CreateObject("Scripting.FileSystemObject")
    Set a = fs.CreateTextFile("c:\testfile.txt", True)
    a.WriteLine("This is a test.")
    a.Close
End Sub

 引数 overwrite の指定を偽 (False) または省略した場合に、引数 filename で既存のファイルを指定するとエラーとなります。


 ReadLine メソッドは、TextStream ファイルから 1 行 (改行文字を除く) を読み込み、その結果の文字列を返します。

 構文:object.ReadLine

object には、TextStream オブジェクトの名前を指定します。


 AtEndOfStream プロパティは、ファイルのポインタが TextStream ファイルの末尾の位置にある場合は、真 (True) を返します。それ以外の場合は、偽 (False) を返します。値の取得のみ可能です。

 構文:object.AtEndOfStream

 object には、TextStream オブジェクトの名前を指定します。

 AtEndOfStream プロパティは、読み取り専用で開かれた TextStream ファイルのみに適用されます。他のファイルの場合は、エラーとなります。

 次のコードは、AtEndOfStream プロパティの使用例です。

Dim fs, a, retstring
Set fs = CreateObject("Scripting.FileSystemObject")
Set a = fs.OpenTextFile("c:\testfile.txt", ForReading, False)
Do While a.AtEndOfStream <> True
    retstring = a.ReadLine
    ...
Loop
a.Close


 WriteLine メソッドは、TextStream ファイルに指定された文字列と改行文字を書き込みます。

 構文:object.WriteLine([string])

 Object 必ず指定します。TextStream オブジェクトの名前を指定します。
 string 省略可能です。ファイルに書き込む文字列を指定します。省略すると、改行文字がファイルに書き込まれます。


 Write メソッドは、指定した文字列を TextStream ファイルに書き込みます。
 構文:object.Write(string)

 object 必ず指定します。TextStream オブジェクトの名前を指定します。
 string 必ず指定します。ファイルに書き込むテキストを指定します。

 連続して文字列を書き込んだ場合、文字列間にスペースや区切り文字は挿入されず、続けて書き込まれます。
文字列の最後で改行する必要がある場合は、WriteLine メソッドを使用するかまたは文字列の最後に改行文字を入れてください。
 次のコードは、Write メソッドの使用例です。
[VBScript]

Function WriteToFile
   Const ForReading = 1, ForWriting = 2
   Dim fso, f
   Set fso = CreateObject("Scripting.FileSystemObject")
   Set f = fso.OpenTextFile("c:\testfile.txt", ForWriting, True)
   f.Write "Hello world!" 
   Set f = fso.OpenTextFile("c:\testfile.txt", ForReading)
   WriteToFile =   f.ReadLine
End Function


 Close メソッドは、開いているTextStream ファイルを閉じます。

 構文:object.Close

object には、TextStream オブジェクトの名前を指定する必要があります。


 Nothing キーワード は、オブジェクト変数とその変数が参照しているオブジェクトとの関連付けを解除するために使います。
 Set ステートメントを使って、次のようにキーワード Nothing をオブジェクト変数に代入します。

Set MyObject = Nothing

 複数のオブジェクト変数が同じオブジェクトを参照することがあります。キーワード Nothing をオブジェクト変数に代入すると、その変数は実際のオブジェクトを参照しなくなります。
 複数のオブジェクト変数が同じオブジェクトを参照すると、各変数が参照するオブジェクトに関連付けられたメモリとシステム リソースは、Set ステートメントを使ってすべての変数を明示的にキーワード Nothing に設定するか、またはキーワード Nothing に設定した最後のオブジェクト変数が、暗黙のうちに適用範囲 (スコープ) 外になった後でなければ解放されません。



GetFolder メソッド は、指定されたパスに置かれているフォルダに対応する Folder オブジェクトを返します。
 構文
 object.GetFolder(folderspec)
 GetFolder メソッドの構文は、次の指定項目から構成されます。
指定項目 説明
object 必ず指定します。FileSystemObject オブジェクトの名前を指定します。
folderspec 必ず指定します。目的のフォルダのパスを指定します。絶対パス、または相対パスのどちらかを指定できます。

指定したフォルダが存在しない場合は、エラーが発生します。

次のコードは、GetFolder メソッドの使用例です。

[VBScript]
Sub AddNewFolder(path, folderName)
   Dim fso, f, fc, nf
   Set fso = CreateObject("Scripting.FileSystemObject")
   Set f = fso.GetFolder(path)
   Set fc = f.SubFolders
   If folderName <> "" Then
      Set nf = fc.Add(folderName)
   Else
      Set nf = fc.Add("新しいフォルダ")
   End If
End Sub

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


「青空文庫」のルビを、HTMLのルビ・タグに変更する(UTF8版)
 以下は、「青空文庫」のルビを、HTMLのルビ・タグに変更するVBAの、UTF-8 版です。

このExcelをダウンロードできます。RubyTagFSO_UTF8vba03.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

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


UNICODE(UTF-8)ファイルを読む

 一般に、ブラウザ表示用の画面は、多数の html ファイル群を、一つのフォルダに登録して、構成しています。
 各 html ファイルの「タイトル」に、画面bニ画面名が書かれているものを、ファイル名とともに抽出するために、下のマクロを作りました。
 html ファイルのファイル形式が、UNICODE の UTL-8 になっていたため、「TextStream」の代わりに「ADODB.Stream」を使っています。

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

EPWING 辞書複数行テキストを StarDict 1行テキストに変換 (UTF-8 ファイルの読み書き)も参照下さい。
こちら↑は、[参照設定]Microsoft ActiveX Data Objects Library が不要です。

 参考にさせていただいたサイト:
Microsoft ActiveX Data Objects (Multidimensional) (ADO MD)
http://msdn.microsoft.com/ja-jp/library/cc407851.aspx
ADO Stream オブジェクト
http://msdn.microsoft.com/ja-jp/library/cc364272.aspx
ADO レコードセット、レコード、およびストリーム オブジェクトを使用してドキュメントを開く方法
http://support.microsoft.com/kb/248255/ja

 Excel マクロ・VBA のお勉強
ADODB.Streamでファイル読み込み
http://www.cocoaliz.com/excelVBA/index/41/

 VBAでUTF-8文字を読込、Excelに出力する方法
KenKen_SP さんの回答
http://oshiete1.goo.ne.jp/qa1963113.html


 目的の html のファイルには、下記の形式で、データが格納されています。
<title>[画面]画面名</title>
または、
<title>[画面]画面名
</title>

'参照設定:Microsoft ActiveX Data Objects x.x Library

'EPWING 辞書複数行テキストを StarDict 1行テキストに変換 (UTF-8 ファイルの読み書き)も参照下さい。
'こちら↑は、[参照設定]Microsoft ActiveX Data Objects Library が不要です。

Option Explicit

Dim 画面 As String
Dim 画面名 As String
Dim 入力ファイル名 As String
Dim 入力行 As String
Dim 出力行 As Integer
Dim ファイルシステムオブジェクト As Object          ' FileSystemObject
Dim ADODBストリーム As ADODB.Stream                 ' ADODB.Stream
Dim 現在のパス As String
Dim フォルダ As Object
Dim ファイル As Object
Dim フォルダパス As String
Dim 開始日時 As Variant
Dim 終了日時 As Variant
Dim 画面名終了桁 As Integer


Sub 属性データ抽出()

   開始日時 = Now                ' 開始時刻を変数に格納します。
   出力行 = 0
   ThisWorkbook.Worksheets("Sheet1").Activate
   
   現在のパス = ActiveWorkbook.Path
   Set ファイルシステムオブジェクト = CreateObject("Scripting.FileSystemObject")
      
   Set フォルダ = ファイルシステムオブジェクト.GetFolder(現在のパス)
   
   
   '★上で指定したフォルダ内の、全てのファイルを対象に検索
   For Each ファイル In フォルダ.Files
   
      入力ファイル名 = ファイル.Path
      
      If Right(入力ファイル名, 4) = "html" Then
      
         ' 指定ファイルをOPEN(入力モード)
         'ADODB.Stream生成
         Set ADODBストリーム = New ADODB.Stream
         
         With ADODBストリーム
            .Type = adTypeText 'Textモード
            .Charset = "UTF-8" '文字コード(Shift_JIS, Unicodeなど)
            .Open              'Streamのオープン
            .LoadFromFile (入力ファイル名)
         End With
      
         '*************データの読み込み***********
         Do Until ADODBストリーム.EOS
              
              ' レコードの読み込み
              入力行 = ADODBストリーム.ReadText(adReadLine)

              If InStr(入力行, "<title>") > 0 Then
               If InStr(入力行, "[") > 0 Then
               
                   画面 = Mid(入力行 _
                   , InStr(入力行, "[") + 1, InStr(入力行, "]") - InStr(入力行, "[") - 1)
                   
                   画面名終了桁 = InStrRev(入力行, "<")
                   If 画面名終了桁 < InStr(入力行, "]") Then
                     画面名終了桁 = Len(入力行) + 1
                   End If
                   画面名 = Mid(入力行 _
                   , InStr(入力行, "]") + 1, 画面名終了桁 - InStr(入力行, "]") - 1)
                   出力行 = 出力行 + 1
                   Range("A2").Cells(出力行, 1).Value _
                   = Right(入力ファイル名, Len(入力ファイル名) - InStrRev(入力ファイル名, "\"))
                   Range("B2").Cells(出力行, 1).Value = 画面
                   Range("C2").Cells(出力行, 1).Value = 画面名
                   Exit Do
                 End If
              End If
              ' 最終行まで繰り返す
          Loop
      
         ' 指定ファイルをCLOSE
         ADODBストリーム.Close
         Set ADODBストリーム = Nothing
         
      End If

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

   Set ファイルシステムオブジェクト = Nothing
   
   終了日時 = Now
   MsgBox "処理を終了しました。" & vbNewLine & "処理時間は、" _
   & Format(終了日時 - 開始日時, "hh時間nn分ss秒") & " でした。"

End Sub

 解説:
 Path プロパティ は、指定されたアプリケーションの絶対パスを表す文字列を返します。
 パス末尾の円記号 (\) とアプリケーション名は含みません。値の取得のみ可能です。文字列型 (String) の値を使用します。

 Workbook.FullName プロパティ は、絶対パスだけでなくブック名を含めた文字列を返します。
値の取得のみ可能です。文字列型 (String) の値を使用します。

次の例の上段は、マクロのブックのパスを表示します。
下段は、作業中のブックのパスとファイル名を表示します。
作業中のブックは、一度は保存されたことがあるものとします。
Sub パス表示()

 ThisWorkbook.Worksheets("Sheet1").Range("A1").Value = ThisWorkbook.Path
 ThisWorkbook.Worksheets("Sheet1").Range("A2").Value = ThisWorkbook.FullName

End Sub

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


ファイル→名前を付けて保存

 「名前を付けて保存」ダイアログを表示してファイルを保存する場合は、GetSaveAsFilenameSaveAs を組合せて使います。

 次の例は、[名前を付けて保存] ダイアログ ボックスを、ファイルの種類を、Excel Book ファイルに限定して表示します。ファイル名を指定すると、そのファイル名で保存します。
 MsgBox は、冗長ですが、確認用に追加しています。この部分は無くてもかまいません。


Option Explicit
    
Sub 名前を付けて保存()

    Dim ファイル保存名 As Variant
    Dim メッセージ As String
    Dim タイトル As String
    Dim 返答 As Integer
    Dim カウント As Integer: カウント = 0

    ChDir "c:\temp"

    Do
      ファイル保存名 = Application.GetSaveAsFilename( _
          InitialFileName:="test.xls", _
          fileFilter:="Excel Book (*.xls), *.xls")

        カウント = カウント + 1
        If カウント > 2 Then End 'キャンセルで抜けられるように

    Loop Until ファイル保存名 <> False

    '*****念のための確認。ここから。
    タイトル = "保存ファイルのフォルダとファイル名の確認"
    メッセージ = "パス: " & ファイル保存名
    返答 = MsgBox(メッセージ, vbInformation + vbYesNo, タイトル)
        'vbInformation は、情報メッセージ アイコン。
        'vbYesNo は、[はい] と [いいえ] のボタンを表示。
    If 返答 = 7 Then Call 名前を付けて保存 ' 6*Yes, 7:No 。recursive コール(再帰呼出し)
    '****念のための確認。ここまで。

    On Error GoTo エラー時対応
    ActiveWorkbook.SaveAs Filename:=ファイル保存名

    Exit Sub
エラー時対応:
    Call 名前を付けて保存

End Sub

 解説:
 GetSaveAsFilename メソッドは、ユーザーからファイル名を取得するために、[名前を付けて保存] ダイアログ ボックスを表示します。ダイアログ ボックスで指定したファイルは、実際には保存されません。
 このメソッドは、ユーザーによって選択または入力されたファイルの名前とパス名を返します。入力が取り消された場合には False が返されます。
 このメソッドを実行することによって、カレント ドライブやカレント フォルダが変更される可能性があります。

 expression.GetSaveAsFilename(InitialFilename, FileFilter, FilterIndex, Title)

 expression 必ず指定します。Application オブジェクトを返すオブジェクト式を指定します。

 InitialFilename 省略可能です。バリアント型 (Variant) の値を使用します。既定値として表示するファイル名を指定します。この引数を省略すると、作業中のブックの名前が使われます。

 FileFilter 省略可能です。バリアント型 (Variant) の値を使用します。ファイルの候補を指定する文字列 (ファイル フィルタ文字列) を指定します。

 FilterIndex 省略可能です。バリアント型 (Variant) の値を使用します。引数 FileFilter で指定したファイル フィルタ文字列の中で、1 から何番目の値を既定値とするかを指定します。この引数を省略するか、引数 FileFilter に含まれるファイル フィルタ文字列の数より大きい数値を指定すると、最初のファイル フィルタ文字列が既定値となります。

 Title 省略可能です。バリアント型 (Variant) の値を使用します。ダイアログ ボックスのタイトルを指定します。この引数を省略すると、"名前を付けて保存" になります。


 Workbook を名前を付けて保存するときには、SaveAs メソッドを使います。
 指定されたブックの変更を保存する場合は、Save メソッドを使います。

 expression.Save

 expression.SaveAs(FileName, FileFormat, Password, WriteResPassword, ReadOnlyRecommended, CreateBackup, AccessMode, ConflictResolution, AddToMru, TextCodepage, TextVisualLayout, Local)

 expression 必ず指定します。上のいずれかのオブジェクトを返すオブジェクト式を指定します。

 Filename 省略可能です。バリアント型 (Variant) の値を使用します。
保存するファイルの名前を表す文字列を指定します。絶対パスを含めることもできます。
絶対パスを含めない場合は、ファイルはカレント フォルダに保存されます。

 FileFormat 省略可能です。バリアント型 (Variant) の値を使用します。
ファイルを保存するときのファイル形式を指定します。指定できる形式については、FileFormat プロパティを参照してください。
既存のファイルでは、指定された最後のファイル形式が既定のファイル形式です。
新しいファイルでは、現在使用されている Excel のバージョンでのファイル形式が既定のファイル形式です。
 Excel 2007 以降で、拡張子 .xls で保存したい場合は、XlFileFormat 列挙型 を使って、明示する必要があります。
 FileFormat:=xlExcel8
 FileFormat:=xlWorkbookNormal
'Excel ブック形式
 この方法は、Q&Aラウンジ ExcelVBAの わいわい さんの書き込みで教えていただきました。
http://park7.wakwak.com/~efc21/cgi-bin/exqalounge.cgi?print+201001/10010042.txt

 513号室(保管庫)の、Excel 2003×2010:SaveAsの挙動の違い に、調査結果のレポートが有ります。
http://blogs.yahoo.co.jp/bardiel_of_may/64539792.html

 参考:OSのバージョンとExcelのバージョンを取得

 Password 省略可能です。バリアント型 (Variant) の値を使用します。保存するファイルに設定する読み取りパスワードを表す文字列を指定します。パスワードは 15 文字以内の文字列で指定し、大文字と小文字が区別されます。  WriteResPassword 省略可能です。バリアント型 (Variant) の値を使用します。保存するファイルに設定する書き込みパスワードを表す文字列を指定します。パスワードを設定して保存したファイルを、パスワードを指定しないで開くと、ファイルは読み取り専用で開かれます。

 ReadOnlyRecommended 省略可能です。バリアント型 (Variant) の値を使用します。ファイルを開くときに、読み取り専用で開くことを推奨するメッセージを表示するには、True を指定します。

 CreateBackup 省略可能です。バリアント型 (Variant) の値を使用します。バックアップ ファイルを作成するには、True を指定します。

 AccessMode 省略可能です。XlSaveAsAccessMode クラスの定数を使用します。
 使用できる定数は、次のいずれかです。
xlExclusive 排他モード
xlNoChange (既定値) アクセス モードを変更しない
xlShared 共有モード
 この引数を省略すると、アクセス モードは変更されません。共有ファイルをファイル名を変えずに保存した場合は、この引数は無視されます。アクセス モードを変更するには、ExclusiveAccess メソッドを使います。

 ConflictResolution 省略可能です。XlSaveConflictResolution クラスの定数を使用します。
 使用できる定数は、次のいずれかです。
xlUserResolution [変更箇所のコンフリクト] ダイアログ ボックスを表示
xlLocalSessionChanges 自動的にローカル ユーザーの変更を反映
xlOtherSessionChanges 他のユーザーの変更を反映
 この引数を省略すると、[変更箇所のコンフリクト] ダイアログ ボックスが表示されます。

 AddToMru 省略可能です。バリアント型 (Variant) の値を使用します。最近使用したファイルの一覧にブックを追加するには True を指定します。既定値は False です。

 TextCodePage 省略可能です。バリアント型 (Variant) の値を使用します。英語の Excel では使用できません。

 TextVisualLayout 省略可能です。バリアント型 (Variant) の値を使用します。英語の Excel では使用できません。

 Local省略可能です。バリアント型 (Variant) の値を使用します。Excel の言語設定 (コントロール パネルの設定を含む) に合わせてファイルを保存するには、True を指定します。Visual Basic for Applications (VBA) の言語設定に合わせてファイルを保存するには、False (既定値) を指定します。通常この設定は、Workbooks.Open を実行する VBA プロジェクトが Excel バージョン 5 または 95 の各国語版で作成されたプロジェクトでない限り、英語 (U.S.) になります。


ChDrive ステートメント は、現在のドライブを変更します。

構文
ChDrive drive

引数 drive は必ず指定します。
引数 drive には、ドライブを示す文字列式を指定します。
引数 drive に長さ 0 の文字列 (" ") を指定したときは、現在のドライブは変更されません。
引数 drive に 2 文字以上の文字列を指定した場合、最初の 1 文字だけが使用されます。


 ChDir ステートメントは、現在のフォルダを変更します。

 ChDir path

 引数 path は必ず指定します。引数 path には、新しく設定するフォルダを表す文字列式を指定します。引数 path には、既定のドライブ名が含まれています。ドライブ名を省略してフォルダを指定すると、ChDir ステートメントは現在のフォルダを現在のドライブの該当するフォルダに変更します。
 path に指定したフォルダが無いと、エラーになります。

 ChDir ステートメントを使用すると、フォルダを変更できます。ただし、ドライブは変更されません。たとえば、現在のドライブが C のとき、次に示すステートメントは、D ドライブのフォルダを変更しますが、現在のドライブは C のまま変更されません。
 ChDir "D:\TMP"

 下記の相対位置を表す記号を使って、ディレクトリを変更することができます。
 ChDir ".." ' Microsoft Windows で一階層上のディレクトリに移動する場合

      'このファイルのパスを規定にする
      ChDir ThisWorkbook.Path


 Call ステートメントは、Sub プロシージャ、Function プロシージャ、ダイナミック リンク ライブラリ (DLL) プロシージャに制御を渡すフロー制御ステートメントです。

 プロシージャを呼び出すとき、キーワード Call は省略できますが、プログラムの判読を容易にするため、省略せずに書くことを、強く推奨します。
 キーワード Call を使って、引数が必要なプロシージャを呼び出す場合は、引数リスト (引数 argumentlist) をかっこで囲む必要があります。
 逆にキーワード Call を省略するときは、引数リストを囲むかっこも省略しなければなりません。
 配列全体を引数として渡す場合は、配列名の後ろに空のかっこを付けてください。
 Call 構文で組み込み関数またはユーザー定義型関数を呼び出す場合、その関数の戻り値を取得することはできません。

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


UNICODEでテキストを出力する

 Excelのマクロでテキスト出力すると、デフォルト・ロケール(通常は1041で Shift_JIS)になります。
 籠谷裕人さん作成の、クラスモジュールを使うと、UTF-8、UTF-16で出力できるようになります。

クラスモジュール「UTF-8ファイル作成 for VBA (utf8vba.zip)」
https://www.vector.co.jp/soft/winnt/prog/se320375.html
 ダウンロードすると、Sample.bas が入っていますので、これを参考に改変します。

 下の例は、ShiftJIS か Unicode(UTF-16) の 階層付テキスト(WzMemo) を読み込んで、Unicode(UTF-8) の xml(CherryTreeファイル)に変換するマクロです。

この Excel をダウンロードできます。→WzMemo2XMLvba01.xls

 追記:RSSフィード RssFeedVBA.xls も、このクラスモジュールを使って、UTF-8(BOM無し)テキストを出力する「サンプル」です。

Option Explicit

Dim 入力ファイル名 As String
Dim 出力ファイル名 As String
Dim 入力行 As String
Dim 出力行 As String
Dim 処理行カウンタ As Long
Dim 開始時刻 As Variant
Dim 終了時刻 As Variant
Dim 直前nodeレベル As Integer
Dim unique_id As Long
Dim 入力文字コード As Integer


Sub 階層付きテキストをXMLに変換()
   
   Dim ファイルシステムオブジェクト As Object          ' FileSystemObject
   Dim 入力テキストストリームオブジェクト As Object    ' TextStream
   
   Dim f1 As New TextFile

   'ファイルを開くダイアログを使って、変換対象のファイル名とパスを取得
   ChDrive ActiveWorkbook.path
   ChDir ActiveWorkbook.path
   入力ファイル名 = Application.GetOpenFilename("TEXTファイル,*.txt")
   If 入力ファイル名 = "False" Then End
   
   出力ファイル名 = Left(入力ファイル名, InStrRev(入力ファイル名, ".") - 1) & ".ctd"
       
   開始時刻 = Now()
   
   入力文字コード = Range("A11").Value
   
   '********************************
   'ファイルのオープン。
   処理行カウンタ = 0
   
   Set ファイルシステムオブジェクト = CreateObject("Scripting.FileSystemObject")
   
   ' 指定ファイルをOPEN(入力モード)
'   https://msdn.microsoft.com/ja-jp/library/cc428044.aspx
   If 入力文字コード = 1 Then      'ShiftJIS
      Set 入力テキストストリームオブジェクト = _
      ファイルシステムオブジェクト.OpenTextFile(入力ファイル名, 1, , False)
   ElseIf 入力文字コード = 2 Then  'UNICODE(UTF-16)
      Set 入力テキストストリームオブジェクト = _
      ファイルシステムオブジェクト.OpenTextFile(入力ファイル名, 1, , True)
   Else
      MsgBox "入力ファイルの文字コードに対応していません。"
      GoTo 終了処理
   End If

   ' 指定ファイルをOPEN(出力モード)
   f1.FileCreate 出力ファイル名, "UTF-8"
       
   'ヘッダー出力
   出力行 = "<?xml version=""1.0"" ?><cherrytree>"

   f1.TextWrite 出力行  'このテキストは UTF-8 でエンコードされています。
   f1.TextWrite vbCrLf  '改行(CrLf)付き
   
   直前nodeレベル = 0
   unique_id = 0
   
   '*************データの読み込み***********
   Do Until 入力テキストストリームオブジェクト.AtEndOfStream
   
      処理行カウンタ = 処理行カウンタ + 1
      
      ' レコードの読み込み
      入力行 = 入力テキストストリームオブジェクト.ReadLine
      Debug.Print 入力行
      
      'ファイルの最初の特別処理
      If 処理行カウンタ = 1 Then
         入力行 = Trim(入力行)
         If 入力行 = "" Then
         '1.空白行は無視する
            処理行カウンタ = 処理行カウンタ - 1
            GoTo 次の行へ
         ElseIf Left(入力行, 1) <> "." Then
         '2.最初に . が無い場合は、.を付加する
            入力行 = "." & 入力行
         End If
      End If

      Call 本文処理  '★★★★★★★★★
      
      f1.TextWrite 出力行  'このテキストは UTF-8 でエンコードされています。
      f1.TextWrite vbCrLf  '改行(CrLf)付き

      If (処理行カウンタ Mod 100) = 0 Then
         Range("A15").Value = 処理行カウンタ & " 行目を読込み"
      End If
      
次の行へ:
      ' 最終行まで繰り返す
   Loop
   
   'フッター出力
   出力行 = "</cherrytree>"
   
   Do While 直前nodeレベル > 0
      出力行 = "</node>" & 出力行
      直前nodeレベル = 直前nodeレベル - 1
   Loop

   出力行 = "</rich_text>" & 出力行
   
   f1.TextWrite 出力行  'このテキストは UTF-8 でエンコードされています。
   f1.TextWrite vbCrLf  '改行(CrLf)付き
   
   '**************終了処理*********************
   Range("A15").Value = 処理行カウンタ & " 最終行まで読込み完了"
   
   ' 指定ファイルをCLOSE
   入力テキストストリームオブジェクト.Close
   Set 入力テキストストリームオブジェクト = Nothing

   f1.FileClose
   
終了処理:

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

   終了時刻 = Now()
   MsgBox "処理が終了しました。" & Chr(13) & _
   "処理時間は、" & Format(終了時刻 - 開始時刻, "nn分ss秒") & " でした。", vbOKOnly
   
   Range("A15").Activate

End Sub


'★★★★★★★★★
Private Sub 本文処理()
'★★★★★★★★★

   Dim nodeレベル As Integer
   Dim レベル As Integer
   Dim nodeName As String
   Dim 直前レベル差 As Integer

   If Left(入力行, 1) = "." Then '行頭が.のみを対象
      'nodeレベルをカウント
      レベル = 1
      unique_id = unique_id + 1

      Do While Mid(入力行, レベル, 1) = "."
         nodeレベル = レベル
         nodeName = Right(入力行, Len(入力行) - レベル)
         レベル = レベル + 1
      Loop

      nodeName = 文字エスケープ(nodeName)
      出力行 = "<node name=""" & nodeName & """ prog_lang=""plain-text"" readonly=""False"" tags="""" unique_id=""" & unique_id & """><rich_text>"
      
      直前レベル差 = 直前nodeレベル - nodeレベル
      
      Do While 直前レベル差 >= 0
         出力行 = "</node>" & 出力行
         直前レベル差 = 直前レベル差 - 1
      Loop

      If unique_id > 1 Then
         出力行 = "</rich_text>" & 出力行
      End If
      
      直前nodeレベル = nodeレベル
      
   Else 'テキスト
   
      出力行 = 文字エスケープ(入力行)
            
   End If

End Sub


Function 文字エスケープ(文字列 As String) As String
   文字エスケープ = Replace(文字列, "&", "&amp;")
   文字エスケープ = Replace(文字エスケープ, "<", "&lt;")
   文字エスケープ = Replace(文字エスケープ, ">", "&gt;")
   文字エスケープ = Replace(文字エスケープ, """", "&quot;")
End Function

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


階層付きテキスト(WzMemo)を、OPML に変換する

 クラウド・アウトライナー Dynalist というアプリ(サービス)があります。
https://dynalist.io/download

 このアプリは、OPML(Outline Processor Markup Language)という形式のテキスト・ファイルを使って、データをインポート、エクスポートできます。

 一般的なアウトライン・エディタでサポートされている、階層付きテキスト(WzMemo)を OPML(Outline Processor Markup Language)に変換するマクロを作ってみました。

この Excel をダウンロードできます。→WzMemoToOPMLvba03.xls

Option Explicit

'03:2023/09/02:テキスト・ファイルの不正な文字を置換。Dynalist にインバリッドとなってインポートできないように

Dim 入力ファイル名 As String
Dim 出力ファイル名 As String
Dim 入力行 As String
Dim 文字列 As String
Dim 出力行 As String
Dim 処理行カウンタ As Long
Dim 開始時刻 As Variant
Dim 終了時刻 As Variant
Dim 直前nodeレベル As Integer
Dim 入力文字コード As Integer
Dim レベル As Integer
'         If Left(入力行, 1) = "." Then
'         '左端にピリオドが有る行のみ
'            文字列 = 入力行
'            レベル = 0
'            '左端の . を除く
'            Do While Left(文字列, 1) = "."
'               レベル = レベル + 1   '.の数でレベルを数えている
'               文字列 = Right(文字列, Len(文字列) - 1)
'            Loop

Dim ファイルシステムオブジェクト As Object          ' FileSystemObject
Dim 入力テキストストリームオブジェクト As Object    ' TextStream
Dim f1 As New TextFile
Dim セル出力行 As Integer
Dim ファイルの最初 As String

Sub 階層付きテキストをOPMLに変換()
   
   Dim 風味 As String
   Dim ソース As String
   Dim 所有者名 As String
   Dim メイルアドレス As String
   Dim 最終行 As Integer
   
   '既存データの2行目以降を行削除する
   Worksheets("階層とタイトル").Activate
   'B 列(2列目)を基準に、最終行を求める
   最終行 = Cells(ActiveSheet.Rows.Count, 2).End(xlUp).Row
   If 最終行 > 1 Then
      Rows(2 & ":" & 最終行).Delete Shift:=xlUp '単純な Cells.Clear だとムダな空白行が残ってしまう
   End If
   セル出力行 = 1
   Worksheets("Sheet1").Activate
   
   'ファイルを開くダイアログを使って、変換対象のファイル名とパスを取得
   ChDrive ActiveWorkbook.path
   ChDir ActiveWorkbook.path
   
   入力ファイル名 = Application.GetOpenFilename("TEXTファイル,*.txt")
   If 入力ファイル名 = "False" Then End
   
   出力ファイル名 = Left(入力ファイル名, InStrRev(入力ファイル名, ".") - 1) & ".opml"
       
   開始時刻 = Now()
   
   入力文字コード = Range("A11").Value
   風味 = Range("K10").Value
   ソース = Range("K11").Value
   所有者名 = Range("K12").Value
   メイルアドレス = Range("K13").Value
   
   '********************************
   'ファイルのオープン。
   処理行カウンタ = 0
   
   Set ファイルシステムオブジェクト = CreateObject("Scripting.FileSystemObject")

   ' 指定ファイルをOPEN(入力モード)
'   https://msdn.microsoft.com/ja-jp/library/cc428044.aspx
   If 入力文字コード = 1 Then 'ShiftJIS
      Set 入力テキストストリームオブジェクト = _
      ファイルシステムオブジェクト.OpenTextFile(入力ファイル名, 1, , False)
   ElseIf 入力文字コード = 2 Then  'UNICODE(UTF-16)
      Set 入力テキストストリームオブジェクト = _
      ファイルシステムオブジェクト.OpenTextFile(入力ファイル名, 1, , True)
   Else
      MsgBox "入力ファイルの文字コードに対応していません。"
      GoTo 終了処理
   End If

   ' 指定ファイルをOPEN(出力モード)
   f1.FileCreate 出力ファイル名, "UTF-8"
       
   'ヘッダー出力
   出力行 = "<?xml version=""1.0"" encoding=""utf-8""?>" & vbCrLf & _
            "<opml version=""2.0"">" & vbCrLf & _
            "<head>" & vbCrLf & _
            "<title></title>" & vbCrLf & _
            "<flavor>" & 風味 & "</flavor>" & vbCrLf & _
            "<source>" & ソース & "</source>" & vbCrLf & _
            "<ownerName>" & 所有者名 & "</ownerName>" & vbCrLf & _
            "<ownerEmail>" & メイルアドレス & "</ownerEmail>" & vbCrLf & _
            "</head>" & vbCrLf & _
            "<body>"
   

   f1.TextWrite 出力行  'このテキストは UTF-8 でエンコードされています。
   f1.TextWrite vbCrLf  '改行(CrLf)付き
   
   直前nodeレベル = 0
   
   '*************データの読み込み***********
   Do Until 入力テキストストリームオブジェクト.AtEndOfStream
   
      処理行カウンタ = 処理行カウンタ + 1
      
      ' レコードの読み込み
      入力行 = 入力テキストストリームオブジェクト.ReadLine
'      If InStr(入力行, ChrW(28)) Then Stop
'      If InStr(入力行, "火-土 10:00") Then Stop
      入力行 = Replace(入力行, ChrW(28), "-")
      入力行 = RTrim(入力行)  '行左の空白は残す。「 .」は階層ではないため!!
      Debug.Print 入力行
      
      'ファイルの最初の特別処理
      'ファイル最初の文字列をファイル名とする
      If 処理行カウンタ = 1 Then
         If 入力行 = "" Or 入力行 = "." Then
         '1.空白行と . のみの行は無視する
            処理行カウンタ = 処理行カウンタ - 1
            GoTo 次の行へ
         ElseIf Left(入力行, 1) = "." Then
         '2.最初に . が有れば、.を除外する
            文字列 = Trim(Right(入力行, Len(入力行) - 1))
            出力行 = 文字エスケープ(文字列)
            出力行 = "<outline text=""" & 出力行 & """>" & vbCrLf
            f1.TextWrite 出力行  'このテキストは UTF-8 でエンコードされています。
            ファイルの最初 = "ファイルの最初"
'            GoTo 次の行へ ファイル名であるとともに本文になるから、次の行に行かない
            
         ElseIf Left(入力行, 1) <> "." Then
         '3.最初に . がなければ、そのまま使う
            文字列 = 文字エスケープ(入力行)
            出力行 = "<outline text=""" & 文字列 & """>" & vbCrLf
            f1.TextWrite 出力行  'このテキストは UTF-8 でエンコードされています。
            入力行 = "." & 入力行
            ファイルの最初 = "ファイルの最初"
'            GoTo 次の行へ
         End If
      End If
      
'      'ファイルの2行目の特別処理
'      If 処理行カウンタ = 2 Then
'         If 入力行 = "" Then
'         '1.空白行は無視する
'            処理行カウンタ = 処理行カウンタ - 1
'            GoTo 次の行へ
'         ElseIf Left(入力行, 1) <> "." Then
'         '2.最初に . が無い場合は、.を付加する
'            入力行 = "." & 入力行
'         End If
'      End If
      
      If 入力行 <> "" Then '空白行以外のみを出力対象とする
         Call 本文処理  '★★★★★★★★★
'Stop
         f1.TextWrite 出力行  'このテキストは UTF-8 でエンコードされています。
   
         If (処理行カウンタ Mod 100) = 0 Then
            Range("A15").Value = 処理行カウンタ & " 行目を読込み"
         End If
      End If
      
次の行へ:
      ' 最終行まで繰り返す
   Loop
   
   'フッター出力
   出力行 = "</outline>" & vbCrLf & _
            "</body>" & vbCrLf & _
            "</opml>"
   
   Do While 直前nodeレベル > 0
      出力行 = "</outline>" & vbCrLf & 出力行
      直前nodeレベル = 直前nodeレベル - 1
   Loop
   出力行 = """>" & 出力行
            
   f1.TextWrite 出力行  'このテキストは UTF-8 でエンコードされています。
   
   '**************終了処理*********************
   Range("A15").Value = 処理行カウンタ & " 最終行まで読込み完了"
   
   ' 指定ファイルをCLOSE
   入力テキストストリームオブジェクト.Close
   Set 入力テキストストリームオブジェクト = Nothing

    f1.FileClose
   
終了処理:

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

   終了時刻 = Now()
   MsgBox "処理が終了しました。" & Chr(13) & _
   "処理時間は、" & Format(終了時刻 - 開始時刻, "nn分ss秒") & " でした。", vbOKOnly
   
   Range("A15").Activate

End Sub


'★★★★★★★★★
Private Sub 本文処理()
'★★★★★★★★★

   Dim nodeレベル As Integer
   Dim レベルカウンタ As Integer
   Dim ノードタイトル部分 As String
   Dim 直前とのレベル差 As Integer
   

   If Left(入力行, 1) = "." Then '行頭が . の行の場合
      'nodeレベルをカウント。ここから
      レベルカウンタ = 1  'トップレベルは 1
      Do While Mid(入力行, レベルカウンタ, 1) = "."
         nodeレベル = レベルカウンタ
         ノードタイトル部分 = Right(入力行, Len(入力行) - レベルカウンタ)
         レベルカウンタ = レベルカウンタ + 1
      Loop
      'nodeレベルをカウント。ここまで。
      
      '階層付きテキスト(WzMemo)のタイトル部分をシートに書き出す。
      セル出力行 = セル出力行 + 1
      Worksheets("階層とタイトル").Range("A1").Cells(セル出力行, 1).Value = 処理行カウンタ
      Worksheets("階層とタイトル").Range("B1").Cells(セル出力行, 1).Value = nodeレベル
      If Left(ノードタイトル部分, 1) = "=" Then ノードタイトル部分 = "=" & ノードタイトル部分
      Worksheets("階層とタイトル").Range("C1").Cells(セル出力行, 1).Value = ノードタイトル部分

      ノードタイトル部分 = 文字エスケープ(ノードタイトル部分)
      出力行 = "<outline text=""" & ノードタイトル部分 & "
"   '最後に改行文字を付ける。
      直前とのレベル差 = 直前nodeレベル - nodeレベル
         
      If 直前とのレベル差 = 0 Then
         出力行 = """></outline>" & vbCrLf & 出力行

      ElseIf 直前とのレベル差 = -1 And nodeレベル = 1 Then '1レベル(レベルが下がる)
         If ファイルの最初 = "ファイルの最初" Then
            ファイルの最初 = ""
            出力行 = vbCrLf & 出力行
         Else
            出力行 = """>" & vbCrLf & 出力行
         End If
         
      ElseIf 直前とのレベル差 = -1 Then   '2レベル以下で、レベルが下がる
'         MsgBox "nodeレベル= " & nodeレベル & " ノードタイトル部分= " & ノードタイトル部分
         出力行 = """ collapsed=""true"">" & vbCrLf & 出力行
         
      ElseIf 直前とのレベル差 < -1 Then   'レベルが1以上下がる
         MsgBox 入力行 & vbCrLf & "レベル異常"
         ' 指定ファイルをCLOSE
         入力テキストストリームオブジェクト.Close
         Set 入力テキストストリームオブジェクト = Nothing
          f1.FileClose
         Set ファイルシステムオブジェクト = Nothing
         End
         
      ElseIf 直前とのレベル差 > 0 Then    'レベルが上がる
         
         Do While 直前とのレベル差 >= 0
            出力行 = "</outline>" & vbCrLf & 出力行
            直前とのレベル差 = 直前とのレベル差 - 1
         Loop
         
         出力行 = """>" & 出力行

      End If
      
      直前nodeレベル = nodeレベル
      
   Else                '行頭が . 以外の文字列の場合
   
      出力行 = 文字エスケープ(入力行) & "
"   '最後に改行文字を付ける。
            
   End If

End Sub


Function 文字エスケープ(文字列 As String) As String
   文字エスケープ = Replace(文字列, "&", "&amp;")
   文字エスケープ = Replace(文字エスケープ, "<", "<")
   文字エスケープ = Replace(文字エスケープ, ">", ">")
   文字エスケープ = Replace(文字エスケープ, """", """)
End Function

Dynalist が使う OPML の構造例
<?xml version="1.0" encoding="utf-8"?>
<opml version="2.0">
  <head>
    <title></title>
    <flavor>dynalist</flavor>
    <source>https://dynalist.io</source>
    <ownerName>MakotoWATANABE</ownerName>
    <ownerEmail>MakotoWATANABE@mail.ne.jp</ownerEmail>
  </head>
  <body>
    <outline text="タイトル文字列">
      <outline text="1レベル文字列"/>
      <outline text="1レベル文字列" _note="下段小文字注記" checklist="true">
        <outline text="2レベル文字列">
          <outline text="3レベル文字列"/>
          <outline text="3レベル文字列"/>
        </outline>
        <outline text="2レベル文字列" collapsed="true">
          <outline text="3レベル文字列"/>
          <outline text="3レベル文字列"/>
        </outline>
        <outline text="2レベル文字列"/>
        <outline text="2レベル文字列&#10;改行して文字列は続く&#10;さらに改行"/>
        <outline text="2レベル文字列"/>
        <outline text="2レベル文字列" _note="下段小文字注記"/>
        <outline text="2レベル文字列"/>
      </outline>
      <outline text="1レベル文字列" _note="下段小文字注記" checklist="true">
        <outline text="2レベル文字列"/>
        <outline text="2レベル文字列" _note="下段小文字注記"/>
      </outline>
      <outline text="1レベル文字列">
        <outline text="2レベル文字列 [リンク文字列](https://help.dynalist.io/)"/>
        <outline text="2レベル文字列"/>
      </outline>
    </outline>
  </body>
</opml>

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


HTML で出力

 HTML の 基本タグを、接頭部分(HTML基本1)と接尾部分(HTML基本2)に分けて、Excelのシートに、それぞれ登録しておきます。
 VBAで、それらをシートから読み込むとともに、本文部分を、指定したシートのセルから、HTMLの表タグに登録して、HTML(実体はテキスト・ファイル)として出力します。
 複数のシートの出力を、一つのコードで兼用できるように、アクティブになっているシート名を、ActiveSheet.Nameで取得しています。

この Excel をダウンロードできます。→color.xls


 HTMLにテキスト出力する部分のコードは、籠谷 裕人さんが、下記で公開されているコードを使わせていただきました。
https://www.vector.co.jp/soft/winnt/prog/se320375.html

 HTMLに出力した結果を、インターネット・エクスプローラで表示する部分は、
ひしだま's 技術メモページ
http://www.ne.jp/asahi/hishidama/home/
の下記のコードを、そのまま使わせていただきました。
http://www.ne.jp/asahi/hishidama/home/tech/excel/browser.html

貴重なノウハウの公開に、感謝いたします。

Option Explicit

'Excelの表をHTMLに出力して、ブラウザで開く

Dim ファイル保存名 As String
Dim 行 As Integer
Dim 列 As Integer
Dim 文字列 As String
Dim 起動シート名 As String
Dim ファイル As New テキストファイル出力 'インスタンスの生成

Sub HTMLとして出力()

    起動シート名 = ActiveSheet.Name

    Call 名前を付けて保存
    
    Call ファイル.出力ファイル作成(ファイル保存名)
    
    Call HTML基本の出力("HTML基本1")
    Call Excel表の出力(起動シート名)
    Call HTML基本の出力("HTML基本2")
    
    Call ファイル.ファイル閉じる
    Worksheets(起動シート名).Activate
        
    Call ブラウザで開く(ファイル保存名)

End Sub

'****************★★★★★************************
Private Sub HTML基本の出力(シート名 As String)
    
    Worksheets(シート名).Activate
    
    For 行 = 1 To Cells(ActiveSheet.Rows.Count, 1).End(xlUp).Row
    
        文字列 = Range("A1").Cells(行, 1).Value
        Call ファイル.改行追加(文字列)
    Next 行
End Sub

'****************★★★★★************************
Private Sub Excel表の出力(シート名 As String)
    
    Worksheets(シート名).Activate
    
    For 行 = 1 To Cells(ActiveSheet.Rows.Count, 2).End(xlUp).Row - 5
        文字列 = "<tr>"
        
        For 列 = 1 To Cells(12, ActiveSheet.Columns.Count).End(xlToLeft).Column
        
            Select Case 列
            Case 5, 13             ' 5列目の場合。
                If Left(Range("M6").Cells(行, 1).Value, 1) = "#" Then
                    If Trim(Range("A6").Cells(行, 列).Value) <> "" Then
                        文字列 = _
                        文字列 & "<td bgcolor=" & Chr(34) & Range("M6").Cells(行, 1).Value & Chr(34) & ">" _
                        & Range("A6").Cells(行, 列).Value & "</td>"
                    Else
                        文字列 = _
                        文字列 & "<td bgcolor=" & Chr(34) & Range("M6").Cells(行, 1).Value & Chr(34) & ">" _
                        & "<br></td>"
                    End If
                Else
                    If Trim(Range("A6").Cells(行, 列).Value) <> "" Then
                        文字列 = 文字列 & "<td>" & Range("A6").Cells(行, 列).Value & "</td>"
                    Else
                        文字列 = 文字列 & "<td><br></td>"
                    End If
                End If
                
            Case Else           ' 5列目以外の場合。
                If Trim(Range("A6").Cells(行, 列).Value) <> "" Then
                    文字列 = 文字列 & "<td>" & Range("A6").Cells(行, 列).Value & "</td>"
                Else
                    文字列 = 文字列 & "<td><br></td>"
                End If
            End Select
        
        Next 列  'Excelシートの右端まで
        
        文字列 = 文字列 & "</tr>"
        Call ファイル.改行追加(文字列)
        
    Next 行  'Excelシートの最後の行まで
    
End Sub

 解説:
 ActiveSheet プロパティは、オブジェクトを返すプロパティです。
 作業中のブック、および指定されたウィンドウまたはブックのアクティブ シート (一番手前のシート) を表すオブジェクトを返します。
 値の取得のみ可能です。アクティブ シートが存在しないときは Nothing を返します。
 対象となるオブジェクトを指定しない場合は、作業中のブックのアクティブ シートが返されます。
 ブックを複数のウィンドウで表示している場合、対象となるウィンドウによって ActiveSheet プロパティの値が異なることがあります。

 インスタンスの生成:クラスモジュールを呼び出すための宣言です。

クラスモジュールを使った究極のVBAプログラミング
http://www.moug.net/skillup/opm/opm08-01.htm
私は、この記事を読んで、オブジェクト指向プログラミング(OOP=Object Oriented Programming)が、少し分るようになりました。



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


ホームページのトップに戻る