Excel VBA ファイル操作

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

索引

UNICODE でテキスト保存

 海外から、Excelで、毎月、売り上げのトランザクション・ファイルが送られてきます。
 これを、期末に、自動で集計するためのマクロを作りました。
 テキスト保存する形式を、ShiftJIS、Unicode(UTF16)、UTF-8 から選択できるところが売りです。


ShiftJISUnicode(UTF16)UTF-8
Excelシートをテキスト保存SaveAs メソッドSaveAs メソッドUTF-8ファイル作成 for VBA
テキストを読み込みテキストストリームオブジェクトADODBストリームADODBストリーム
テキストに書き出しテキストストリームオブジェクトテキストストリームオブジェクトUTF-8ファイル作成 for VBA

 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 が入っていますので、これを参考に改変します。

このマクロをダウンロードできます→SaveAsUnicodeTextVBA2.xls
中国語のサンプルもダウンロードできます→Chinese.xls

1.マクロの機能
 (1).このExcelシートと同じフォルダの全てのExcelシートを、テキスト保存します。
 (2).保存するテキストの形式を、ShiftJIS、Unicode(UTF16)、Unicode(UTF8)から選択できます。
 (3).保存したテキストを一つのファイルに集約できます。
 (4).集約(合体)したファイルは、ソートして出力します。

2.マクロの使い方
 (1).作業用のフォルダを作ります。
 (2).テキスト保存したいExcelブック(1つでも複数でも可)を、作業用フォルダに登録します。
 (3).このマクロ Excelも、作業用のフォルダに保存します。
 (4).作業用のフォルダから、このマクロ Excelを開いて、テキスト形式のボタンを押します。
 (5).テキスト保存したファイルは、最後に1つのファイルに合体します。合体ファイルは、作業用フォルダ名をファイル名として、作成します。

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

Dim テキスト形式 As String
Dim 入力ファイル名 As String
Dim 出力ファイル名 As String
Dim 入力行 As String
Dim 出力行 As String
Dim ファイルシステムオブジェクト As Object          ' FileSystemObject
Dim 入力テキストストリームオブジェクト As Object    ' TextStream
Dim 出力テキストストリームオブジェクト As Object    ' TextStream
'参照設定:Microsoft ActiveX Data Objects x.x Library
Dim ADODBストリーム As ADODB.Stream                 ' ADODB.Stream
Dim テキスト As String
Dim 現在のパス As String
Dim フォルダ As Object
'Dim サブフォルダ As Object
Dim ファイル As Object
Dim フォルダパス As String
'Dim ファイル内容 As Variant
Dim 開始日時 As Variant
Dim 終了日時 As Variant
Dim 処理行カウンタ As Long
Dim ヘッダ行数 As Integer
Dim ファイル内カウンタ As Long
Dim データ配列() As Variant
Dim データ行数 As Long
Dim 処理行 As Long
Dim 処理内容 As String
Dim 列数 As Integer
Dim 列 As Integer
'UTF-8で出力用
Dim f1 As New TextFile


'メインフロー ★ここから★*************************************
Sub ShiftJISで保存()
   
    開始日時 = Now                ' 開始時刻を変数に格納します。
 
   テキスト形式 = "ShiftJIS"
   Call Excelを開く(テキスト形式)
   Call ShiftJISテキスト合体

   終了日時 = Now
   MsgBox "処理を終了しました。" & vbNewLine & "処理時間は、" _
   & Format(終了日時 - 開始日時, "hh時間nn分ss秒") & " でした。"

End Sub

Sub UTF16で保存()
    開始日時 = Now                ' 開始時刻を変数に格納します。
 
   テキスト形式 = "UTF16"
   Call Excelを開く(テキスト形式)
   Call UTF16テキスト合体
   
   終了日時 = Now
   MsgBox "処理を終了しました。" & vbNewLine & "処理時間は、" _
   & Format(終了日時 - 開始日時, "hh時間nn分ss秒") & " でした。"

End Sub

Sub UTF8で保存()
    
    開始日時 = Now                ' 開始時刻を変数に格納します。
 
   テキスト形式 = "UTF8"
   Call Excelを開く(テキスト形式)
   Call UTF8テキスト合体
   
   終了日時 = Now
   MsgBox "処理を終了しました。" & vbNewLine & "処理時間は、" _
   & Format(終了日時 - 開始日時, "hh時間nn分ss秒") & " でした。"

End Sub
'メインフロー ☆ここまで☆*************************************

'**************************************************************
Private Sub Excelを開く(保存形式 As String)

   ThisWorkbook.Activate
    If Range("B20").Value = True Then
      ヘッダ行数 = Range("C21").Value
    Else
      ヘッダ行数 = 0
    End If
    
   現在のパス = ActiveWorkbook.path

   Set ファイルシステムオブジェクト = CreateObject("Scripting.FileSystemObject")
   Set フォルダ = ファイルシステムオブジェクト.GetFolder(現在のパス)
   
   データ行数 = 0
   
   '★Excelの存在するフォルダの、全てのファイルを対象に検索
    For Each ファイル In フォルダ.Files

      入力ファイル名 = ファイル.path
      
      '拡張子 xls で、マクロ自分自身以外のみを対象
      If Right(入力ファイル名, 3) = "xls" _
      And Mid(入力ファイル名, InStrRev(入力ファイル名, "\") + 1, 20) _
      <> "SaveAsUnicodeTextVBA" Then
         
          ' 指定ファイルをOPEN
          Workbooks.Open Filename:=入力ファイル名
          
          データ行数 = データ行数 + Cells(ActiveSheet.Rows.Count, 1).End(xlUp).Row

          Select Case 保存形式
            Case "ShiftJIS"
               出力ファイル名 = Left(入力ファイル名, Len(入力ファイル名) - 4) & "ShiftJIS.txt"
               Call ShiftJISで出力
            Case "UTF16"
               出力ファイル名 = Left(入力ファイル名, Len(入力ファイル名) - 4) & "UTF16.txt"
               Call UTF16で出力
            Case "UTF8"
               出力ファイル名 = Left(入力ファイル名, Len(入力ファイル名) - 4) & "UTF8.txt"
               Call UTF8で出力
            Case Else
               Stop
               MsgBox "保存形式を判断できません。"
               Exit Sub
          End Select
          
         ' 開いたExcelをCLOSE
         ActiveWorkbook.Close savechanges:=False
      End If
      
    Next '★ファイル
    
   Set フォルダ = Nothing
   Set ファイルシステムオブジェクト = Nothing

End Sub
'**************************************************************


'Excel からテキスト出力 ★ここから★******************************

Private Sub ShiftJISで出力()
    ActiveWorkbook.SaveAs _
      Filename:=出力ファイル名, _
      FileFormat:=xlText, CreateBackup:=False
End Sub

Private Sub UTF16で出力()
    ActiveWorkbook.SaveAs _
      Filename:=出力ファイル名, _
      FileFormat:=xlUnicodeText, CreateBackup:=False
End Sub

Private Sub UTF8で出力()
   f1.FileCreate 出力ファイル名, "UTF-8"
   For 処理行 = 1 To Cells(ActiveSheet.Rows.Count, 1).End(xlUp).Row
      列数 = Cells(処理行, ActiveSheet.Columns.Count).End(xlToLeft).Column
      If 列数 > 1 Then
         For 列 = 1 To 列数 - 1
            f1.TextWrite Range("A1").Cells(処理行, 列).Value & vbTab
         Next 列
      End If
      f1.TextWrite Range("A1").Cells(処理行, 列).Value
      f1.TextWrite vbCrLf
   Next 処理行
    f1.FileClose
End Sub
'Excel からテキスト出力 ☆ここまで☆******************************


'複数のテキスト・ファイルを、一つに合体 ★ここから★**************

Private Sub ShiftJISテキスト合体()

   ReDim データ配列(データ行数)

   現在のパス = ActiveWorkbook.path
   Set ファイルシステムオブジェクト = CreateObject("Scripting.FileSystemObject")
   Set フォルダ = ファイルシステムオブジェクト.GetFolder(現在のパス)
   
   ' 出力ファイル名を作成
   出力ファイル名 = 現在のパス & "\" & Right(現在のパス, Len(現在のパス) - InStrRev(現在のパス, "\")) & "ShiftJIS.txt"

   処理行カウンタ = 0
   処理内容 = "☆テキストファイル読み込み☆ "
   '★Excelの存在するフォルダの、全てのファイルを対象に検索
    For Each ファイル In フォルダ.Files
      
      入力ファイル名 = ファイル.path

      'ファイル名ShiftJIS、拡張子 txt のみを対象。合体ファイル、自分自身以外のみを対象
      If Right(入力ファイル名, 12) = "ShiftJIS.txt" _
         And 入力ファイル名 <> 出力ファイル名 Then

          ' 指定ファイルをOPEN(入力モード)
          Set 入力テキストストリームオブジェクト = _
          ファイルシステムオブジェクト.OpenTextFile(入力ファイル名, 1)
      
         ファイル内カウンタ = 0
         '*************データを一行ずつ読んで、書き込む***********
         Do Until 入力テキストストリームオブジェクト.AtEndOfStream
  
            ファイル内カウンタ = ファイル内カウンタ + 1
           
           ' レコードの読み込み
           入力行 = 入力テキストストリームオブジェクト.ReadLine

            テキスト = Replace(入力行, vbTab, "")

            If Trim(テキスト) <> "" And ファイル内カウンタ > ヘッダ行数 Then
               処理行カウンタ = 処理行カウンタ + 1
               データ配列(処理行カウンタ) = 入力行
            End If
   
           If (処理行カウンタ Mod 1000) = 0 Then
               Application.StatusBar = 処理内容 & 処理行カウンタ & " 行目を読込み"
           End If
           
           ' 最終行まで繰り返す
         Loop
      
         ' 指定ファイルをCLOSE
         入力テキストストリームオブジェクト.Close
         Set 入力テキストストリームオブジェクト = Nothing

      End If

    Next '★ファイル
   
   処理内容 = "★ 出力データを並び替え ★"
   Application.StatusBar = 処理内容
   Call クイックソート(データ配列, 1, 処理行カウンタ)
    
    
   処理内容 = "☆ 合体ファイルとして書き出し ☆ "
   Application.StatusBar = 処理内容

   '出力ファイルをオープン(出力モード)
   Set 出力テキストストリームオブジェクト = _
   ファイルシステムオブジェクト.CreateTextFile(出力ファイル名)
   
   For 処理行 = 1 To 処理行カウンタ
      出力テキストストリームオブジェクト.WriteLine データ配列(処理行)         ' 改行(CrLf)付き
   Next 処理行
    
   出力テキストストリームオブジェクト.Close
   Set 出力テキストストリームオブジェクト = Nothing
    
   Set ファイルシステムオブジェクト = Nothing
   
End Sub


Private Sub UTF16テキスト合体()

   ReDim データ配列(データ行数)

   現在のパス = ActiveWorkbook.path
   Set ファイルシステムオブジェクト = CreateObject("Scripting.FileSystemObject")
   Set フォルダ = ファイルシステムオブジェクト.GetFolder(現在のパス)
   
   ' 出力ファイル名を作成
   出力ファイル名 = 現在のパス & "\" & Right(現在のパス, Len(現在のパス) - InStrRev(現在のパス, "\")) & "UTF16.txt"

   処理行カウンタ = 0
   処理内容 = "☆テキストファイル読み込み☆ "
   '★Excelの存在するフォルダの、全てのファイルを対象に検索
    For Each ファイル In フォルダ.Files

      入力ファイル名 = ファイル.path
      
      'ファイル名UTF16、拡張子 txt のみを対象。合体ファイル、自分自身以外のみを対象
      If Right(入力ファイル名, 9) = "UTF16.txt" _
         And 入力ファイル名 <> 出力ファイル名 Then

         ' 指定ファイルをOPEN(入力モード)
         'ADODB.Stream生成
         Set ADODBストリーム = New ADODB.Stream
         
         With ADODBストリーム
            .Type = adTypeText 'Textモード
            .Charset = "Unicode" '文字コード(Shift_JIS, UTF-8など)
            .Open              'Streamのオープン
            .LoadFromFile (入力ファイル名)
         End With
         
         ファイル内カウンタ = 0
         '*************データを一行ずつ読んで、書き込む***********
         Do Until ADODBストリーム.EOS
  
            ファイル内カウンタ = ファイル内カウンタ + 1
           
           ' レコードの読み込み
           入力行 = ADODBストリーム.ReadText(adReadLine)

            テキスト = Replace(入力行, vbTab, "")
            
            If Trim(テキスト) <> "" And ファイル内カウンタ > ヘッダ行数 Then
               処理行カウンタ = 処理行カウンタ + 1
               データ配列(処理行カウンタ) = 入力行
            End If
   
           If (処理行カウンタ Mod 1000) = 0 Then
            Application.StatusBar = 処理内容 & 処理行カウンタ & " 行目を読込み"
           End If
           
           ' 最終行まで繰り返す
         Loop
      
         ' 指定ファイルをCLOSE
         ADODBストリーム.Close
         Set ADODBストリーム = Nothing
      End If

    Next '★ファイル
   
   処理内容 = "★ 出力データを並び替え ★"
   Application.StatusBar = 処理内容
   Call クイックソート(データ配列, 1, 処理行カウンタ)
    
    
   処理内容 = "☆ 合体ファイルとして書き出し ☆ "
   Application.StatusBar = 処理内容
   '出力ファイルをオープン(出力モード)
   Set 出力テキストストリームオブジェクト = _
   ファイルシステムオブジェクト.CreateTextFile(出力ファイル名, False, True)
   
   For 処理行 = 1 To 処理行カウンタ
      出力テキストストリームオブジェクト.WriteLine データ配列(処理行)         ' 改行(CrLf)付き
   Next 処理行
    
   出力テキストストリームオブジェクト.Close
   Set 出力テキストストリームオブジェクト = Nothing
    
   Set ファイルシステムオブジェクト = Nothing
   
End Sub


Private Sub UTF8テキスト合体()

   ReDim データ配列(データ行数)

   現在のパス = ActiveWorkbook.path
   Set ファイルシステムオブジェクト = CreateObject("Scripting.FileSystemObject")
   Set フォルダ = ファイルシステムオブジェクト.GetFolder(現在のパス)
   
   ' 出力ファイル名を作成
   出力ファイル名 = 現在のパス & "\" & Right(現在のパス, Len(現在のパス) - InStrRev(現在のパス, "\")) & "UTF8.txt"

   処理行カウンタ = 0
   処理内容 = "☆テキストファイル読み込み☆ "
   '★Excelの存在するフォルダの、全てのファイルを対象に検索
    For Each ファイル In フォルダ.Files

      入力ファイル名 = ファイル.path
      
      'ファイル名UTF8、拡張子 txt のみを対象。合体ファイル、自分自身以外のみを対象
      If Right(入力ファイル名, 8) = "UTF8.txt" _
         And 入力ファイル名 <> 出力ファイル名 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
         
         ファイル内カウンタ = 0
         '*************データを一行ずつ読んで、書き込む***********
         Do Until ADODBストリーム.EOS
  
            ファイル内カウンタ = ファイル内カウンタ + 1
           
           ' レコードの読み込み
           入力行 = ADODBストリーム.ReadText(adReadLine)
            テキスト = Replace(入力行, vbTab, "")
            
            If Trim(テキスト) <> "" And ファイル内カウンタ > ヘッダ行数 Then
               処理行カウンタ = 処理行カウンタ + 1
               データ配列(処理行カウンタ) = 入力行
            End If
   
           If (処理行カウンタ Mod 1000) = 0 Then
            Application.StatusBar = 処理内容 & 処理行カウンタ & " 行目を読込み"
           End If
           
           ' 最終行まで繰り返す
         Loop
      
         ' 指定ファイルをCLOSE
         ADODBストリーム.Close
         Set ADODBストリーム = Nothing
      End If

    Next '★ファイル
   
   処理内容 = "★ 出力データを並び替え ★"
   Application.StatusBar = 処理内容
   Call クイックソート(データ配列, 1, 処理行カウンタ)
    
    
   処理内容 = "☆ 合体ファイルとして書き出し ☆ "
   Application.StatusBar = 処理内容
   '出力ファイルをオープン(出力モード)
   f1.FileCreate 出力ファイル名, "UTF-8"
   
   For 処理行 = 1 To 処理行カウンタ
      f1.TextWrite データ配列(処理行)
      f1.TextWrite vbCrLf
   Next 処理行
    
    f1.FileClose
    
   Set ファイルシステムオブジェクト = Nothing
   
End Sub
'複数のテキスト・ファイルを、一つに合体 ☆ここまで☆**************

 解説:

 SaveAs メソッドを、Workbook オブジェクトに指定した場合、ブックの内容を、別のファイルに保存します。

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

 expression   必ず指定します。この場合は、Workbook オブジェクトを返すオブジェクト式を指定します。

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

 FileFormat   省略可能です。バリアント型 (Variant) の値を使用します。ファイルを保存するときのファイル形式を指定します。
指定できる形式は、FileFormat プロパティのいずれかを指定します。既存のファイルでは、指定された最後のファイル形式が既定のファイル形式です。新しいファイルでは、現在使用されている Excel のバージョンでのファイル形式が既定のファイル形式です。

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

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

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

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

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

 ConflictResolution   省略可能です。XlSaveConflictResolution クラスの定数を使用します。
使用できる定数は、次に示す 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.) になります。

 次の例は、新しいブックを作成し、ユーザーにファイル名を入力させるダイアログ ボックスを表示して、そのファイル名でブックを保存します。

Set NewBook = Workbooks.Add
Do
    fName = Application.GetSaveAsFilename
Loop Until fName <> False
NewBook.SaveAs Filename:=fName

 ADODB.Stream オブジェクトのコレクションおよびプロパティを使うと、次の操作を行うことができます。
 ADODB.Stream を使うためには Microsoft ActiveX Data Objectを参照設定します。

ADO レコードセット、レコード、およびストリーム オブジェクトを使用してドキュメントを開く方法
https://support.microsoft.com/kb/248255/ja

https://msdn.microsoft.com/ja-jp/library/cc364272.aspx


WriteText メソッド
指定したテキスト文字列を文字列型の Stream オブジェクトに書き込みます。

構文
Stream.WriteText Data, Options
パラメータ
Data
書き込む文字テキストを含む文字列型 (String) の値を指定します。
Options
省略可能です。指定した文字列の終わりに行区切り文字を書き込むかどうかを StreamWriteEnum 値で指定します。
StreamWriteEnum 定数 StreamWriteEnum 値 説明
adWriteChar 0 既定値で、行区切り文字は無しです。
Stream オブジェクトに対して、Data パラメータで指定したテキスト文字列を書き込みます。
adWriteLine 1 Stream オブジェクトに、テキスト文字列と行区切り文字を書き込みます。
LineSeparator プロパティが定義されていない場合は、実行時エラーを返します。
解説
指定した文字列が Stream オブジェクトに書き込まれます。このとき、各文字列間にスペースや文字は挿入されません。
現在の Position は、書き込まれたデータの次の文字に設定されます。WriteText メソッドでは、ストリーム内の残りの文字データは削除されません。これらの文字を削除する場合は、SetEOS メソッドを呼び出してください。
現在の EOS の位置を越える書き込みを行うと、StreamSize は、新しく書き込まれた文字がすべて格納されるように拡張され、EOS は、Stream に新しく書き込まれた最後の文字に移動します。

注意 WriteText メソッドは、文字列型ストリーム (TypeadTypeText) で使用します。バイナリ型のストリーム (TypeadTypeBinary) には、Write を使用してください。
バイナリ データを書き込む場合: Write メソッド



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


(UTF-8 ファイルの読み書き) EPWING 辞書複数行テキストを StarDict 1行テキストに変換

 Windows パソコンの DDwin で使っていた「福武国語辞典 電子ブック版」の内容を、Android 電子書籍ブラウザの ColorDict で表示させるために、辞書データを変換するために作ったマクロです。

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

Option Explicit


Sub StarDict用UTF8変換()

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

   Dim 開始時刻 As Variant
   Dim 終了時刻 As Variant
   Dim 入力ADODBストリーム As Object                 ' ADODB.Stream
   Dim 出力ADODBストリーム As Object                 ' ADODB.Stream
   Dim 単語内行数 As Integer

   '変換対象のファイル名とパス取得(ファイル名は決め打ち)
   入力ファイル名 = ThisWorkbook.Path & "\ddwin福武Export.txt"
   出力ファイル名 = ThisWorkbook.Path & "\FUKUTAKEforStarDict.txt"
      
   開始時刻 = Now()
   
   '********************************
   ' 指定ファイルを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
         
   ' 出力用の 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

   出力行 = ""
   単語内行数 = 0

    '*************データの読み込み***********
    Do Until 入力ADODBストリーム.EOS

      ' レコードの読み込み
      入力行 = 入力ADODBストリーム.ReadText(-2)
        
      If Trim(入力行) = "" Then
         出力ADODBストリーム.WriteText 出力行, 1    '//0:改行無し 1:改行有り
         単語内行数 = 0
         出力行 = ""
      Else
         単語内行数 = 単語内行数 + 1

         If 単語内行数 = 1 Then '単語キー
            出力行 = 入力行
         ElseIf 単語内行数 = 2 Then  '意味初行
            出力行 = 出力行 & vbTab & 入力行  'キーと意味の間はタブで区切る
         Else  '意味2行目以降
            出力行 = 出力行 & "\n" & 入力行  '改行を挟む
         End If
      End If
        ' 最終行まで繰り返す
   Loop
        
   出力ADODBストリーム.SaveTofile (出力ファイル名), 2 'adSaveCreateOverWrite 上書きを許す
        
   ' 指定ファイルをCLOSE
   入力ADODBストリーム.Close
   Set 入力ADODBストリーム = Nothing
   
   出力ADODBストリーム.Close
   Set 出力ADODBストリーム = Nothing

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

End Sub


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


(UTF-8 ファイルの読み書き) 電子ブック辞書テキストから漢字キーを生成する

 電子ブックのキーは、「かな」しかありません。キーボードから検索語を入力するならそれでよいのですが、電子書籍からコピペするには、漢字キーも必要です。
 このため、このマクロを作って、よみ・漢字をひっくり返して、漢字キーを生成しました。
 生成したテキストは、上のテキストと合体して、StarDict Editor に渡して、辞書データに変換します。

Option Explicit


Sub 漢字キーの行を生成()

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

   Dim 開始時刻 As Variant
   Dim 終了時刻 As Variant
   Dim 入力ADODBストリーム As Object                 ' ADODB.Stream
   Dim 出力ADODBストリーム As Object                 ' ADODB.Stream
   Dim 入力キー文字列 As String
   Dim キーかな As String
   Dim キー漢字 As String
   Dim 出力キー文字列 As String
   Dim 漢字部分開始文字目 As Integer
   Dim 意味部分文字列 As String
   Dim 漢字部分文字列 As String
   Dim カウンタ As Integer
   Dim 作業文字列 As String

   '変換対象のファイル名とパス取得(ファイル名は決め打ち)
   入力ファイル名 = ThisWorkbook.Path & "\FUKUTAKEforStarDict.txt"
   出力ファイル名 = ThisWorkbook.Path & "\FUKUTAKE漢字forStarDict.txt"
      
   開始時刻 = Now()
   
   '********************************
   ' 指定ファイルを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:LF (Unix)★行読み込みをするとき、Windows 標準でないときは明示指定しないと改行を認識しない★
      .LoadFromFile (入力ファイル名)
   End With
         
   ' 出力用の 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

      ' レコードの読み込み
      入力行 = 入力ADODBストリーム.ReadText(-2)
      入力キー文字列 = Left(入力行, InStr(入力行, vbTab) - 1)
      
      If InStr(入力キー文字列, "【") = 0 Then '漢字部分が無い
         '読み飛ばす
      Else
         意味部分文字列 = Right(入力行, Len(入力行) - InStr(入力行, vbTab))
         キーかな = Replace(Left(入力キー文字列, InStr(入力キー文字列, "【") - 1), "・", "") '中点・を除去
         
         漢字部分開始文字目 = InStr(入力キー文字列, "【") + 1
         漢字部分文字列 = Mid(入力キー文字列, 漢字部分開始文字目, Len(入力キー文字列) - 漢字部分開始文字目)
         
         '全角のアルファベット(英字)を半角に変換する
         'http://www.eurus.dti.ne.jp/~yoneyama/Excel/vba/vba_zenkakueisuji.html
         作業文字列 = ""
         For カウンタ = 1 To Len(漢字部分文字列)
            If Mid(漢字部分文字列, カウンタ, 1) Like "[A-z]" Then
               作業文字列 = 作業文字列 & StrConv(Mid(漢字部分文字列, カウンタ, 1), vbNarrow)
            Else
               作業文字列 = 作業文字列 & Mid(漢字部分文字列, カウンタ, 1)
            End If
         Next カウンタ
         漢字部分文字列 = 作業文字列
         
         漢字部分文字列 = Replace(漢字部分文字列, "▼", "") '中点・以外を除去
         漢字部分文字列 = Replace(漢字部分文字列, "∇", "")
         漢字部分文字列 = Replace(漢字部分文字列, "〈", "")
         漢字部分文字列 = Replace(漢字部分文字列, "〉", "")
         漢字部分文字列 = Replace(漢字部分文字列, "《", "")
         漢字部分文字列 = Replace(漢字部分文字列, "》", "")
         
         Do While InStr(漢字部分文字列, "・") > 0
            '漢字単語が複数
            キー漢字 = Left(漢字部分文字列, InStr(漢字部分文字列, "・") - 1)
            出力行 = キー漢字 & "【" & キーかな & "】" & vbTab & 意味部分文字列
            出力ADODBストリーム.WriteText 出力行, 1    '//0:改行無し 1:改行有り
            
            漢字部分文字列 = Right(漢字部分文字列, Len(漢字部分文字列) - InStr(漢字部分文字列, "・"))
         Loop
         
         '漢字単語が唯一
         キー漢字 = 漢字部分文字列
         出力行 = キー漢字 & "【" & キーかな & "】" & vbTab & 意味部分文字列
         出力ADODBストリーム.WriteText 出力行, 1    '//0:改行無し 1:改行有り

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

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

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


(UTF-8 ファイルに追記) UTF-8ファイルを読んで、指定文字列を含む行を抽出して出力

教えていただいたサイト
 UTF-8形式のテキストファイルに書き込む
http://officetanaka.net/excel/vba/file/file11.htm

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

Option Explicit

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

   Dim 対象ファイルの拡張子 As String
   Dim ファイルシステムオブジェクト As Object          ' FileSystemObject
   Dim このExcelブックのフォルダパス As String
   Dim フォルダ As Object
   Dim ファイル As Object
   Dim ファイル数 As Long
   Dim 開始時刻 As Variant
   Dim 終了時刻 As Variant

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

      'ファイルの拡張子を調べて、html ファイルのみを、取得対象とする
      If Right(ファイル名, Len(ファイル名) - InStrRev(ファイル名, ".")) = 対象ファイルの拡張子 Then
      
         'ファイルが、対象ファイルだったら
         ファイル数 = ファイル数 + 1
         
         If ファイル数 Mod 1000 = 0 Then
            Application.StatusBar = "★☆★" & ファイル数 & " を処理しました。"
         End If
         
         Call 指定したキー文字列を含む行を書き出す

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

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

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

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

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

   '変換対象のファイル名とパス取得(出力ファイル名は決め打ち)
   入力ファイル名 = ThisWorkbook.Path & "\" & ファイル名
   出力ファイル名 = ThisWorkbook.Path & "\出力テキスト.txt"
      
   '********************************
   ' 指定ファイルを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
         
   ' 出力用の 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
   
   If Dir(出力ファイル名) <> "" Then '出力ファイルが既存
      With 出力ADODBストリーム
         .LoadFromFile 出力ファイル名 'まず既存データを全部読み込む
         .Position = .Size            '書き込み位置をデータの末尾に移動させる
      End With
   End If

    '*************データの読み込み***********
    Do Until 入力ADODBストリーム.EOS

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

      If InStr(入力行, キーの文字列) > 0 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 Sub

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

(UTF-8 ファイルに追記) 英文 HTML に、Google で作成した英和対訳ファイルの日本語部分を挿入して出力

プロジェクト・グーテンベルクでは、無償の電子書籍を公開しています。
著作権が切れた作品を中心に、世界の偉大な文学を、ここで見つけることができます。

ここに、「みつばちマーヤの冒険」の英文訳 The Adventures of Maya the Bee がありました。
(『みつばちマーヤの冒険』は、ハンブルク生まれの作家、児童文学者のワルデマル・ボンゼルスが1912年に発表した(原題:Die Biene Maja und ihre Abenteuer、『みつばちマーヤとその冒険』)
https://www.gutenberg.org/ebooks/22354

この中の「Read this book online: HTML (as submitted)」を使って、GAS(Google Apps Script) に渡すと、英和対訳ファイルを作成できます。

このマクロは、最初に英和対訳ファイルを読んで、英文の最後の単語と和文の配列(辞書)を作成します。
次に英文HTMLを読んで英文の最後の単語をキーに、先に作成済の配列から和文を挿入していきます。
注意点としては、HTML には文字強調などのタブが入っているので、HTML 解析時にはこの不要なタブを除去して処理しています。

このマクロを含む関連ファイルをダウンロードできます→TheAdventuresOfMayaTheBeeE&J.zip

追記Sigil を使うと、簡単に HTML を ePub に変換できます。

Option Explicit

' 00:2023/08/06:作成

Sub 英文HTMLに対訳和文を挿入()

   Dim 入力対訳ファイル名 As String
   Dim 入力英文ファイル名 As String
   Dim 出力ファイル名 As String
   Dim 入力対訳行 As String
   Dim 入力英文行 As String
   Dim 作業文字列 As String
   Dim 出力行 As String
   Dim 対訳(2000, 2) As String
   Dim 対訳数 As Integer
   Dim 本文 As String

   Dim 開始時刻 As Variant
   Dim 終了時刻 As Variant
   Dim 入力対訳ADODBストリーム As Object                 ' ADODB.Stream
   Dim 入力英文ADODBストリーム As Object                 ' ADODB.Stream
   Dim 出力ADODBストリーム As Object                 ' ADODB.Stream
   Dim 英文行末語 As String
   Dim 検索数 As Integer

   '変換対象のファイル名とパス取得(ファイル名は決め打ち)
   入力対訳ファイル名 = ThisWorkbook.Path & "\The Adventures of Maya the Bee対訳.txt"
   入力英文ファイル名 = ThisWorkbook.Path & "\The Adventures of Maya the Bee, by Waldemar Bonsels.html"
   出力ファイル名 = ThisWorkbook.Path & "\The Adventures of Maya the Bee, by Waldemar Bonsels=E2J.html"
      
   開始時刻 = Now()
   
   '********************************
   ' 指定ファイルをOPEN(入力モード)
   'ADODB.Stream生成
   Set 入力対訳ADODBストリーム = CreateObject("ADODB.Stream")
   Set 入力英文ADODBストリーム = CreateObject("ADODB.Stream")
   With 入力対訳ADODBストリーム
      .Type = 2             'adTypeText Textモード
      .Charset = "UTF-8"    '文字コード(Shift_JIS, Unicodeなど)
      .Open                 'Streamのオープン
      .LoadFromFile (入力対訳ファイル名)
   End With
   With 入力英文ADODBストリーム
      .Type = 2             'adTypeText Textモード
      .Charset = "UTF-8"    '文字コード(Shift_JIS, Unicodeなど)
      .Open                 'Streamのオープン
      .LineSeparator = 10   'adLF:LF (Unix)
      .LoadFromFile (入力英文ファイル名)
   End With
   ' 出力用の 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


    '*************対訳データの読み込み***********
   対訳数 = 0
   Do Until 入力対訳ADODBストリーム.EOS

      ' レコードの読み込み
      入力対訳行 = 入力対訳ADODBストリーム.ReadText(-2)
'      Stop
      If Trim(入力対訳行) <> "" Then
      入力対訳行 = Trim(入力対訳行)
      
         If InStrRev(入力対訳行, " ") > 0 Then
            英文行末語 = Right(入力対訳行, Len(入力対訳行) - InStrRev(入力対訳行, " "))
         Else
            英文行末語 = 入力対訳行
         End If
         
         対訳数 = 対訳数 + 1
         対訳(対訳数, 1) = 英文行末語
         対訳(対訳数, 2) = Trim(入力対訳ADODBストリーム.ReadText(-2))

      End If
        ' 最終行まで繰り返す
   Loop
   
'   Stop
    '*************HTML データの読み込み***********
   本文 = ""
   検索数 = 0
   Do Until 入力英文ADODBストリーム.EOS
      出力行 = ""
      ' レコードの読み込み
      入力英文行 = 入力英文ADODBストリーム.ReadText(-2)
      
      '入力HTMLから不要なタグを除去
      作業文字列 = Replace(入力英文行, "<i>", "")
      作業文字列 = Replace(作業文字列, "</i>", "")
      作業文字列 = Replace(作業文字列, "<p>", "")
      作業文字列 = Replace(作業文字列, "<ins class=""correction"" title=""text has unneeded close quote"">", "")
      作業文字列 = Replace(作業文字列, " </ins>", "")
      
      If InStr(入力英文行, "CHAPTER I") > 0 Then
         本文 = "本文"
      End If
      
'      Stop
      If 本文 = "本文" And Right(入力英文行, 4) = "</p>" Then
'      Stop
         If InStrRev(入力英文行, " ") > 0 Then
            英文行末語 = Mid(作業文字列, InStrRev(作業文字列, " ") + 1, Len(作業文字列) - InStrRev(作業文字列, " ") - 4)
         Else
            英文行末語 = Left(作業文字列, Len(作業文字列) - 4)
         End If
         
         If Len(英文行末語) > 0 Then
            Do
               検索数 = 検索数 + 1
               If 検索数 > 1900 Then
                  GoTo 検索終了
               End If
            Loop Until 英文行末語 = 対訳(検索数, 1)
            出力行 = Left(入力英文行, Len(入力英文行) - 4) & "<br>" & 対訳(検索数, 2) & "</p>"
             
         End If
'         Stop
      Else
検索終了:
      
         出力行 = 入力英文行

      End If
      出力ADODBストリーム.WriteText 出力行, 1    '//0:改行無し 1:改行有り

      出力行 = ""
        ' 最終行まで繰り返す
   Loop
        
   出力ADODBストリーム.SaveTofile (出力ファイル名), 2 'adSaveCreateOverWrite 上書きを許す
        
   ' 指定ファイルをCLOSE
   入力対訳ADODBストリーム.Close
   Set 入力対訳ADODBストリーム = Nothing
   入力英文ADODBストリーム.Close
   Set 入力英文ADODBストリーム = Nothing
   
   出力ADODBストリーム.Close
   Set 出力ADODBストリーム = Nothing

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

End Sub

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

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