TextFileクラスの改良

TextFileクラスの改良

「改良」なのかどうかはわからんが。

ちなみに、元祖TextFileクラスについては、

akashi-keirin.hatenablog.com

コチラをどうぞ。

改良後のTextFileクラス

リスト1 クラスモジュール
'オブジェクト名はTextFile'
Option Explicit

'Constants'
Private Enum ErrorTypes  '……(**)'
  etFileNotFound = 1
  etLineNotExists
  etNotInitialized
  etErrorOccurred
End Enum

'Module Level Variables'
Private isInitialized As Boolean
Private fileFullName As String
Private line_() As String
Private fsObj As FileSystemObject

'Properties'
Public Property Get Line(ByVal numberOf As Long) As String
  Const ERR_SOURCE As String = _
          "TextFile Class, Property Get Line"
  'initメソッド未実行ならエラー。'
  If Not isInitialized Then _
    Call raiseError(etNotInitialized, ERR_SOURCE)
  Dim ret As String
  '存在しない行番号を指定していたらエラー。'
  If UBound(line_) + 1 < numberOf Or _
     numberOf < 0 Then _
    Call raiseError(etLineNotExists, ERR_SOURCE)
  On Error GoTo ErrorHandler
  ret = line_(numberOf - 1)
  Line = ret
  Exit Property
ErrorHandler:
  '何かしらエラーが出たら、イミディエイトに情報を表示して中断。'
  Debug.Print "Number : " & Err.Number
  Debug.Print "Description : " & Err.Description
  Call raiseError(etErrorOccurred, ERR_SOURCE)
End Property

Public Property Get LineCount() As Long
  Const ERR_SOURCE As String = _
          "TextFile Class, Property Get LineCount"
  'initメソッド未実行ならエラー。'
  If Not isInitialized Then _
    Call raiseError(etNotInitialized, ERR_SOURCE)
  On Error GoTo ErrorHandler
  Dim ret As Long
  If IsEmpty(line_) Then ret = 0: GoTo Finalizer
  ret = UBound(line_) + 1
Finalizer:
  LineCount = ret
  Exit Property
ErrorHandler:
  Debug.Print "Number : " & Err.Number
  Debug.Print "Description : " & Err.Description
  Call raiseError(etErrorOccurred, ERR_SOURCE)
End Property

'Constructor'
Private Sub Class_Initialize()
  isInitialized = False
  Set fsObj = New FileSystemObject
End Sub

Public Sub init(ByVal targetFullName As String)
  Const ERR_SOURCE As String = _
          "TextFile class,init Method"
  '対象ファイルの存否確認。なければエラー。'
  If Not fsObj.FileExists(targetFullName) Then _
    Call raiseError(etFileNotFound, "TextFile Class, init Method")
  On Error GoTo ErrorHandler
  'モジュールレベル変数に対象ファイルのフルパスを保存'
  fileFullName = targetFullName
  'テキストファイルからデータを取得'
  line_ = getLines(targetFullName)
  isInitialized = True
  Exit Sub
ErrorHandler:
  Debug.Print "Number : " & Err.Number
  Debug.Print "Description : " & Err.Description
  Call raiseError(etErrorOccurred, ERR_SOURCE)
End Sub

'テキストファイル読み込み'
Private Function getLines( _
             ByVal targetFullName As String) As String()
  Const ERR_SOURCE As String = _
          "TextFile class, getLines Method"
  On Error GoTo ErrorHandler
  Dim ret() As String
  Dim n As Long
  n = 0
  ReDim ret(n)
  Dim txtStream As Scripting.TextStream
  Set txtStream = fsObj.OpenTextFile( _
                          FileName:=targetFullName, _
                          IOMode:=ForReading, _
                          Create:=False)
  Do
    ret(n) = txtStream.ReadLine
    '最終行まで読み込んだらExit'
    If txtStream.AtEndOfLine Then Exit Do
    n = n + 1
    ReDim Preserve ret(n)
  Loop
  Call txtStream.Close
  Set txtStream = Nothing
  line_ = ret
  getLines = line_
  Exit Function
ErrorHandler:
  Debug.Print "Number : " & Err.Number
  Debug.Print "Description : " & Err.Description
  Call raiseError(etErrorOccurred, ERR_SOURCE)
End Function

'Destructor'
Private Sub Class_Terminate()
  Set fsObj = Nothing
End Sub

'Methods'
Public Sub regetData(Optional ByVal targetFullName As String)
  Const ERR_SOURCE As String = _
          "TextFile Class, regetData Method"
  'initメソッド未実行ならエラー。'
  If Not isInitialized Then _
    Call raiseError(etNotInitialized, ERR_SOURCE)
  If targetFullName = "" Then GoTo MainProcess
  If Not fsObj.FileExists(targetFullName) Then _
    Call raiseError(etFileNotFound, ERR_SOURCE)
  '新たにファイルフルパスが渡されたら、それを新しいファイルフルパスにする'
  fileFullName = targetFullName
MainProcess:
  On Error GoTo ErrorHandler
  Erase line_
  Call Me.init(fileFullName)
  Exit Sub
ErrorHandler:
  Debug.Print "Number : " & Err.Number
  Debug.Print "Description : " & Err.Description
  Call raiseError(etErrorOccurred, ERR_SOURCE)
End Sub

'データ書き換え'  '……(*)'
Public Sub setData(ByVal targetLine As Long, _
                   ByVal targetData As String)
  Const ERR_SOURCE As String = _
          "TextFile Class, setData Method"
  'initメソッド未実行ならエラー。'
  If Not isInitialized Then _
    Call raiseError(etNotInitialized, ERR_SOURCE)
  Dim ret As String
  '存在しない行番号を指定していたらエラー。'
  If targetLine < 1 Or _
     UBound(line_) + 1 < targetLine Then _
    Call raiseError(etLineNotExists, ERR_SOURCE)
  On Error GoTo ErrorHandler
  'メインの処理'
  line_(targetLine - 1) = targetData
  Dim txtStream As Scripting.TextStream
  Set txtStream = fsObj.OpenTextFile( _
                          FileName:=fileFullName, _
                          IOMode:=ForWriting, _
                          Create:=False)
  Dim i As Long
  For i = 0 To UBound(line_)
    Call txtStream.WriteLine(line_(i))
  Next
  Call txtStream.Close
  Set txtStream = Nothing
  Exit Sub
ErrorHandler:
  Debug.Print "Number : " & Err.Number
  Debug.Print "Description : " & Err.Description
  Call raiseError(etErrorOccurred, ERR_SOURCE)
End Sub

'エラー発生用'
Private Sub raiseError(ByVal typeOfError As ErrorTypes, _
              Optional ByVal errorSource As String)
  Dim msg As String
  msg = getErrorMessage(typeOfError)
  Call Err.Raise(Number:=10000 + typeOfError, _
                 Source:=errorSource, _
                 Description:=msg)
End Sub

Private Function getErrorMessage( _
          ByVal typeOfError As ErrorTypes) As String  '……(***)'
  Const ERR_SOURCE As String = _
          "TextFile class, getErrorMessage Method"
  On Error GoTo ErrorHandler
  Dim ret As String
  Select Case typeOfError
    Case etFileNotFound
      ret = "The file you specified isn't found."
    Case etLineNotExists
      ret = "This file doesn't have so many lines."
    Case etNotInitialized
      ret = "You must run ""init"" method!"
    Case etErrorOccurred
      ret = "Some Error has occurred"
  End Select
  getErrorMessage = ret
  Exit Function
ErrorHandler:
  Debug.Print "Number : " & Err.Number
  Debug.Print "Description : " & Err.Description
  Call raiseError(etErrorOccurred, ERR_SOURCE)
End Function

メソッドを一つ追加した(*)ことに伴い、列挙体の要素を増やし(**)、エラーメッセージのパターンも増やした(***)。

setDataメソッド
Public Sub setData(ByVal targetLine As Long, _
                   ByVal targetData As String)  '……(1)'
  Const ERR_SOURCE As String = _
          "TextFile Class, setData Method"
  'initメソッド未実行ならエラー。'  '……(2)'
  If Not isInitialized Then _
    Call raiseError(etNotInitialized, ERR_SOURCE)
  Dim ret As String
  '存在しない行番号を指定していたらエラー。'  '……(3)'
  If targetLine < 0 Or _
     UBound(line_) + 1 < targetLine Then _
    Call raiseError(etLineNotExists, ERR_SOURCE)
  On Error GoTo ErrorHandler
  'メインの処理'
  line_(targetLine - 1) = targetData  '……(4)'
  Dim txtStream As Scripting.TextStream  '……(5)'
  Set txtStream = fsObj.OpenTextFile( _
                          FileName:=fileFullName, _
                          IOMode:=ForWriting, _
                          Create:=False)
  Dim i As Long  '……(6)'
  For i = 0 To UBound(line_)
    Call txtStream.WriteLine(line_(i))
  Next
  Call txtStream.Close  '……(7)'
  Set txtStream = Nothing
  Exit Sub
ErrorHandler:
  Debug.Print "Number : " & Err.Number
  Debug.Print "Description : " & Err.Description
  Call raiseError(etErrorOccurred, ERR_SOURCE)
End Sub

まず(1)の

Public Sub setData(ByVal targetLine As Long, _
                   ByVal targetData As String) 

で引数の設定。

targetLineで何行目のデータを書き換えるのかを指定し、targetDataで書き換えるデータを指定する。

(2)の2行(実質1行)

If Not isInitialized Then _
    Call raiseError(etNotInitialized, ERR_SOURCE)

はガード節。

擬似コンストラクinitメソッドの末尾に

isInitialized = True

があり、Module LevelのisInitializedTrueにするようにしている。こうすることで擬似コンストラクinitメソッドの実行を強制している。

(3)の3行(実質1行)もガード節。

If targetLine < 1 Or _
   UBound(line_) + 1 < targetLine Then _
  Call raiseError(etLineNotExists, ERR_SOURCE)

このメソッドでは、既にある行のデータを書き換えることを想定しているので、元のテキストファイルの行数を超える行番号は指定できないようにしている。もちろん、0行目とか、負の数行目もあり得ないので、ここで弾く。

不正な引数とか、あり得ない操作については、このようにメソッド冒頭で弾いてしまう、という「ガード節」の考え方が気に入っている。good mannerだと思う。

テキストファイルにデータを追記するために、次はappendDataメソッドを作る必要があるかもしれない。

ここまで来たら、ほぼ安全なので、メインの処理に移る。

(4)の

line_(targetLine - 1) = targetData

で、元のテキストファイルの各行のデータを保持したModule Levelの配列line_()の書き換え対象データを書き換える。

行番号と配列の添字がずれるのはイマイチなので、今にして思えば配列を1はじまりにした方が良かったかもしれない。このTextFileクラスのLineプロパティはItemみたいなものなのだから……。

まあ、「1ずれる」という部分は、クラスモジュール内に隠蔽してしまっているので、利用する側は何も困らないのだけれど。これもオブジェクト指向の強みだね。

次に、(5)からの5行(実質2行)

Dim txtStream As Scripting.TextStream
  Set txtStream = fsObj.OpenTextFile( _
                          FileName:=fileFullName, _
                          IOMode:=ForWriting, _
                          Create:=False)

Scripting.TextStreamオブジェクトを準備する。

OpenTextFileメソッドの引数IOModeForWritingにしているので、書き込みモードだ。

Scripting.TextStreamオブジェクトについては、詳しくはコチラをどうぞ。とにかく、テキストファイルの読み書きを行うときには、TextStreamオブジェクトを通して行う、ぐらいの理解で良いと思う。

これで、TextStreamクラスのインスタンスtxtStreamが用意できたので、コイツを通じてテキストファイルを操作することができる。

あとは、(6)からの4行

Dim i As Long
For i = 0 To UBound(line_)
  Call txtStream.WriteLine(line_(i))
Next

で配列line_()の各要素を1行目から最終行まで書き込む。

変更していない行まで書き込みし直すのは無駄な気がするけれど、仕方ない。

指定した行だけを書き換える方法ってあるのかな??? あったら誰か教えてくだされ。

最後に(7)の

Call txtStream.Close

txtStream(テキストファイルとの接続?)を閉じておしまい。

実験

このプロジェクトと同じフォルダ内に、test.txtというテキストファイルを置き、内容を

f:id:akashi_keirin:20190717083008j:plain

にしておく。相変わらずアホな内容ですまん。

次のコードを標準モジュールに書く。

スト2 標準モジュール
Private Sub testTextFileClass()
  Dim targetPath As String
  targetPath = ThisDocument.Path & "\" & "test.txt"  '"
  Dim txtFile As TextFile
  Set txtFile = New TextFile
  Call txtFile.init(targetPath)
  Dim ar() As String
  Dim i As Long  '……(1)'
  For i = 1 To txtFile.LineCount
    Debug.Print txtFile.Line(i)
    Call WindowsAPI.waitFor(300)
  Next
  Debug.Print "3行目を書き換えるよ。"  '……(2)'
  Call txtFile.setData(3, "ち~んw")
  Call WindowsAPI.waitFor(500)
  For i = 1 To txtFile.LineCount  '……(3)'
    Debug.Print txtFile.Line(i)
    Call WindowsAPI.waitFor(300)
  Next
End Sub

(1)の

Dim i As Long  '……(1)'
For i = 1 To txtFile.LineCount
  Debug.Print txtFile.Line(i)
  Call WindowsAPI.waitFor(300)
Next

では、まずは普通にtxtFileインスタンスに蓄えられた元のテキストファイル(test.txt)の各行のデータ(笑)を吐き出している。

ループ1回ごとに自作WindowsAPIクラスのwaitForメソッドでポーズを入れている((2)も(3)も同様。)。

WindowsAPIクラスについては、

akashi-keirin.hatenablog.com

コチラをどうぞ。

(2)の

Debug.Print "3行目を書き換えるよ。"
Call txtFile.setData(3, "ち~んw")

では、イミディエイトに書き換え宣言を表示させた後、

Call txtFile.setData(3, "ち~んw")

で新作のsetDataメソッドを実行。引数に「3」と「"ち~んw"」を渡しているので、test.txtの「3」行目を「ち~んw」というデータ(笑)に書き換えることになる。

あとは、(3)の

For i = 1 To txtFile.LineCount
  Debug.Print txtFile.Line(i)
  Call WindowsAPI.waitFor(300)
Next

で、新生test.txtのデータ(笑)を全てゆっくり吐き出す。

スト2を実行すると……

f:id:akashi_keirin:20190717083027g:plain

このとおり。

test.txt

f:id:akashi_keirin:20190717083010j:plain

こうなっている。

おわりに

異様に長い割に、読んでもあまりためにならない記事になってしまい、深く反省している……。

差し込み印刷のデータソース接続前にデータソースの存否確認をする(Word)

差し込み印刷のデータソース接続前にデータソースの存否確認をする

……などと、大それた標題をブチ上げたが、実質的な

敗北宣言

だと思っていただきたい。

いわば、爆負宣言である。

差し込み印刷のデータソースはExcel限定

実は、差し込み印刷の差し込みデータソースには、実に多様なものを指定することができる。

私は、Excel→Wordパターンしか知らなかった(だいたい、差し込み印刷というテクニックwを覚えたのが5年前ぐらいなのだ。)ので、驚いた。ヒマな人は自分で調べてみてください。

今回は、Excel限定にする。……というか、それしか思い浮かばなかったのだ。結局。だから、敗北宣言。

ファイルの存在確認

まず、Excelのワークシートなり、セル範囲なりをデータソースに指定しているときは、当該のExcelブックが存在しなくてはいけない。これはめっちゃ簡単。

FileSystemObjectクラスのFileExsistsメソッドでOK。

シート・セル範囲の存在確認

で、問題はこいつ。

最初は、簡単にできると思っていた。

データソースに接続するときに、Document.MailMergeオブジェクトのOpenDataSourceメソッドでSQLを投げているっぽいので、データソースに指定したシート名なりセル範囲名に誤りがあったら、そこでエラーが出るやろ、と。

しかし、Word様は一枚上手だった。

f:id:akashi_keirin:20190716080550j:plain

データソースが見当たらなかったら、こんな風に、データソースの指定を促してくるのである。やられた。(ちなみに、ここで[キャンセル]を選択すると、実行時エラーになる。自動で[キャンセル]を選択するようにすれば、ここでエラーキャッチできるが、あまり美しいやり方ではない……。)

紆余曲折の末、現在の私のスキルレベルでは無理、と判断し、一番アホみたいな解決策をとった。

リスト1 標準モジュール
Private Function isCorrectTable( _
             ByVal dataSourceFilePath As String, _
             ByVal dataSourceTableName As String) As Boolean
  'Microsoft Excel XX.X Object Libraryを参照設定する'
  Dim ret As Boolean
  ret = False
  Dim tgtXls As Excel.Application
  Set tgtXls = New Excel.Application
  Dim tgtBook As Workbook
  Set tgtBook = tgtXls.Workbooks.Add(dataSourceFilePath)
  On Error GoTo Finalizer
  'テーブル名の右端が「$」ならば、シートを指定している'
  If Right(dataSourceTableName, 1) = "$" Then
    Dim tgtSheetName As String
    tgtSheetName = Left(dataSourceTableName, Len(dataSourceTableName) - 1)
    'シートの存否を確認'
    If sheetExists(targetBook:=tgtBook, _
                   targetSheetName:=tgtSheetName) Then
      ret = True: GoTo Finalizer
    Else
      GoTo Finalizer
    End If
  End If
  'テーブル名の右端が「$」でないならば、名前付きセル範囲を指定している'
  'アテ馬変数を準備'
  Dim stalkingHorse As Variant
  Set stalkingHorse = tgtXls.Range(dataSourceTableName)
  If stalkingHorse Is Nothing Then GoTo Finalizer  '……(*)'
  Set stalkingHorse = Nothing
  'ここまでたどり着いたということは、名前付きセル範囲があったということ'
  ret = True
Finalizer:
  Call tgtBook.Close(SaveChanges:=False)
  Call tgtXls.Quit
  Set tgtXls = Nothing
  Set tgtBook = Nothing
  isCorrectTable = ret
  If Err.Number > 0 Then Call Err.Clear
End Function

Private Function sheetExists( _
             ByVal targetBook As Workbook, _
             ByVal targetSheetName As String) As Boolean
  Dim ret As Boolean
  ret = False
  Dim i As Long
  With targetBook
    For i = 1 To .Worksheets.Count
      If .Worksheets(i).Name = targetSheetName Then
        ret = True
        Exit For
      End If
    Next
  End With
  sheetExists = ret
End Function

単なる力業ですよ、はい。

Excel→Wordの差し込み印刷についても、ちゃんと理解しているわけではないので、〈シート名での指定〉、〈セル範囲の名前での指定〉以外に指定方法があったらアウトw

エラーキャッチもたぶんかなり杜撰w

(*)の

If stalkingHorse Is Nothing Then GoTo Finalizer

なんて、本当に必要なんかな、と思いますがw

実行

まず、このプロジェクト(SettingFile.docm)があるフォルダ内は

f:id:akashi_keirin:20190716080554j:plain

こんな状態。

差し込みデータソースInsertionData.xlsxは、この状態。

f:id:akashi_keirin:20190716080558j:plain

右側のセル範囲には、ご覧のようにSumoDataと名前を付けている。

この状態で実行してみる。

何せ、たかがデータソースの存否を確認するためだけに、わざわざExcelを起動するのだから、さぞかし時間がかかるに違いない、とお思いでしょう。

そこで、次のようなプロシージャで処理に要した時間を計測してみようと思う。

まず、リスト1を呼び出すプロシージャを作る。

スト2 標準モジュール
Public Sub callIsCorrectTable()
  Debug.Print isCorrectTable( _
                ThisDocument.Path & "\InsertionData.xlsx", _
                "InsertionData$")
End Sub

で、こいつを自作の処理時間計測用メソッドにわたす。

参考 標準モジュール
'Declare Section'
Private Declare Function GetTickCount Lib "kernel32" () As Long

Public Function getElapsedTime(ByVal procedureName As String) As Double
  Dim startTime As Long
  Dim endTime As Long
  startTime = GetTickCount
  Call Application.run(procedureName)
  endTime = GetTickCount
  getElapsedTime = (endTime - startTime) / 1000
End Function

イミディエイト・ウインドウに、

?getElapsedTime("callIsCorrectTable")

と入力して[Enter]。

f:id:akashi_keirin:20190716080601j:plain

何と、5秒近くもかかっている……。

おわりに

Document.MailMergeオブジェクトのOpenDataSourceメソッドでSQLを投げるときに、何かうまくやる方法があるように思えてならない。

FileSystemObjectを用いてテキストファイルを読み込む

FileSystemObjectを用いてテキストファイルを読み込む

〈FileSystemObject使い宣言〉をしていた(いつ?!)にもかかわらず、

akashi-keirin.hatenablog.com

このときは、テキストファイルの読み込みにFileSystemObjectを利用していなかった。

深く反省して、FileSystemObjectを用いる形に書き換えたい。

TextFileクラスのコード

めんどくさいので、改良(?)したTextFileクラスのコードを全掲載する。

リスト1 クラスモジュール
'オブジェクト名は"TextFile"。'
Option Explicit

'Constants'
Private Enum ErrorTypes
  etFileNotFound = 1
  etLineNotExists
  etNotInitialized
  etErrorOccurred
End Enum

'Module Level Variables'
Private isInitialized As Boolean
Private fileFullName As String
Private line_() As String
Private fsObj As FileSystemObject

'Properties'
Public Property Get Line(ByVal numberOf As Long) As String
  Const ERR_SOURCE As String = "TextFile Class, Property Get Line"
  'initメソッド未実行ならエラー。'
  If Not isInitialized Then _
    Call raiseError(etNotInitialized, ERR_SOURCE)
  Dim ret As String
  '存在しない行番号を指定していたらエラー。'
  If UBound(line_) + 1 < numberOf Or _
     numberOf < 0 Then _
    Call raiseError(etLineNotExists, ERR_SOURCE)
  On Error GoTo ErrorHandler
  ret = line_(numberOf - 1)
  Line = ret
  Exit Property
ErrorHandler:
  '何かしらエラーが出たら、イミディエイトに情報を表示して中断。'
  Debug.Print "Number : " & Err.Number
  Debug.Print "Description : " & Err.Description
  Call raiseError(etErrorOccurred, ERR_SOURCE)
End Property

Public Property Get LineCount() As Long
  Const ERR_SOURCE As String = "TextFile Class, Property Get LineCount"
  'initメソッド未実行ならエラー。'
  If Not isInitialized Then _
    Call raiseError(etNotInitialized, ERR_SOURCE)
  Dim ret As Long
  If IsEmpty(line_) Then ret = 0: GoTo Finalizer
  ret = UBound(line_) + 1
Finalizer:
  LineCount = ret
End Property

'Constructor'
Private Sub Class_Initialize()
  isInitialized = False
  Set fsObj = New FileSystemObject
End Sub

Public Sub init(ByVal targetFullName As String)
  '対象ファイルの存否確認。なければエラー。'
  If Not fsObj.FileExists(targetFullName) Then _
    Call raiseError(etFileNotFound, "TextFile Class, init Method")
  'モジュールレベル変数に対象ファイルのフルパスを保存'
  fileFullName = targetFullName
  'テキストファイルからデータを取得'
  line_ = getLines(targetFullName)
  isInitialized = True
End Sub
'テキストファイル読み込み'
Private Function getLines( _
             ByVal targetFullName As String) As String()
  Dim ret() As String
  Dim n As Long
  n = 0
  ReDim ret(n)
  Dim txtStream As Scripting.TextStream
  Set txtStream = fsObj.OpenTextFile( _
                          FileName:=targetFullName, _
                          IOMode:=ForReading, _
                          Create:=False)
  Do
    ret(n) = txtStream.ReadLine
    '最終行まで読み込んだらExit'
    If txtStream.AtEndOfLine Then Exit Do
    n = n + 1
    ReDim Preserve ret(n)
  Loop
  Call txtStream.Close
  Set txtStream = Nothing
  line_ = ret
  getLines = line_
End Function

'Destructor'
Private Sub Class_Terminate()
  Set fsObj = Nothing
End Sub

'Methods'
Public Sub regetData(Optional ByVal targetFullName As String)
  Const ERR_SOURCE As String = "TextFile Class, regetData Method"
  'initメソッド未実行ならエラー。'
  If Not isInitialized Then _
    Call raiseError(etNotInitialized, ERR_SOURCE)
  If targetFullName = "" Then GoTo MainProcess
  If Not fsObj.FileExists(targetFullName) Then _
    Call raiseError(etFileNotFound, ERR_SOURCE)
  '新たにファイルフルパスが渡されたら、それを新しいファイルフルパスにする'
  fileFullName = targetFullName
MainProcess:
  Erase line_
  Call Me.init(fileFullName)
End Sub

Private Sub raiseError(ByVal typeOfError As ErrorTypes, _
              Optional ByVal errorSource As String)
  Dim msg As String
  msg = getErrorMessage(typeOfError)
  Call Err.Raise(Number:=10000 + typeOfError, _
                 Source:=errorSource, _
                 Description:=msg)
End Sub

Private Function getErrorMessage( _
          ByVal typeOfError As ErrorTypes) As String
  Dim ret As String
  Select Case typeOfError
    Case etFileNotFound:  ret = "The file you specified isn't found."
    Case etLineNotExists: ret = "This file doesn't have so many lines."
    Case etNotInitialized: ret = "You must run ""init"" method!"
    Case etErrorOccurred: ret = "Some Error has occurred"
  End Select
  getErrorMessage = ret
End Function

すまん。すっげえタテ長になってしまった。

テキストファイル読み込み部分だけ取り上げる。

スト2 クラスモジュール
Private Function getLines( _
             ByVal targetFullName As String) As String()
  Dim ret() As String
  Dim n As Long
  n = 0
  ReDim ret(n)
  Dim txtStream As Scripting.TextStream    '……(1)'
  Set txtStream = fsObj.OpenTextFile( _
                          FileName:=targetFullName, _
                          IOMode:=ForReading, _
                          Create:=False)
  Do    '……(2)'
    ret(n) = txtStream.ReadLine
    '最終行まで読み込んだらExit'
    If txtStream.AtEndOfLine Then Exit Do
    n = n + 1
    ReDim Preserve ret(n)
  Loop
  Call txtStream.Close
  Set txtStream = Nothing
  line_ = ret
  getLines = line_
End Function

目玉は二つ。

まずは、(1)からの5行(実質2行)

Dim txtStream As Scripting.TextStream
Set txtStream = fsObj.OpenTextFile( _
                        FileName:=targetFullName, _
                        IOMode:=ForReading, _
                        Create:=False)

FileSystemObjectクラスのOpenTextFileメソッドは、TextStreamオブジェクトを返す。

最初、

Dim txtStream As 

と入力してもTextStreamが入力候補に出なかったので焦ったが、

Dim txtStream As Scripting.

まで入力したら、ちゃんとTextStreamが出た。

あとは、(2)からの7行(正味6行)

Do    '……(2)'
  ret(n) = txtStream.ReadLine
  '最終行まで読み込んだらExit'
  If txtStream.AtEndOfLine Then Exit Do
  n = n + 1
  ReDim Preserve ret(n)
Loop

最初、ReadLineメソッドに引数がないので、

おい小池、行数指定できねえのかよ!

と思ったのだが、Doループで回すだけで順番に取り出してくれているっぽい。

任意の行を指定したいときにはどうすれば良いのかわからないが、全ての行を取り出すには実に好都合だ。

終了判定は、

If txtStream.AtEndOfLine Then Exit Do

のように、AtEndOfLineプロパティで行うことが可能。

実にわかりやすい。

実行

次のコードで使用実験。

リスト3 標準モジュール
Private Sub testTextFileClass()
  Dim targetPath As String
  targetPath = ThisDocument.Path & "\" & "test.txt"  '"
  Dim txtFile As TextFile
  Set txtFile = New TextFile
  Call txtFile.init(targetPath)
  Dim ar() As String
  Dim i As Long
  For i = 1 To txtFile.LineCount
    Debug.Print txtFile.Line(i)
  Next
End Sub

このプロジェクトと同じフォルダ内に「test.txt」というテキストファイルを置いておく。

テキストファイルの内容は、

f:id:akashi_keirin:20190712084949j:plain

これw

実行すると、

f:id:akashi_keirin:20190712084951j:plain

意図どおり。

おわりに

同じ処理をさせるのでも、FileSystemObjectを利用すると、非常にreadableになる。

オブジェクト指向の強みだと思う。

『BLOG「芦田の毎日」』(シラバスとは何か ― コマシラバスはなぜ必要なのか)の本文を読みやすく加工するマクロ(Word)

『BLOG「芦田の毎日」』(シラバスとは何か ― コマシラバスはなぜ必要なのか)の本文を読みやすく加工するマクロ(Word)

我ながら超ニッチなマクロであるw

過去記事

このときにも紹介したが、標題の記事は、

※本文中、(●)などの表記が見られる場合は、その前に来る言葉の傍点ルビや読みがなルビを意味している。●が一個だと前の文字一つのルビ、●●と2個だと前の文字二つのルビなどを意味する。

という表記ルールで書かれているため、そのままだと異様に読みづらい。

そこで、本文中の必要な箇所に傍点を施し、邪魔なハナクソ(「「●」などの表記」のこと)を除去するマクロを作った。

誰のために?

自分のために決まっているじゃありませんか!

コード

とりあえず、コードを全て掲載する。

我ながら非常にreadableなので、何も説明は要らないと思う。

うそです。ほとんどコード中にコメントで書きましたw

リスト1 標準モジュール
Option Explicit

Private Sub main()
  Dim orgRange As Range
  Set orgRange = Selection.Range
  Call putEmphasisMarkToDocument
  Call orgRange.Select
End Sub

Private Sub putEmphasisMarkToDocument()
  Dim doc As Document
  Set doc = ThisDocument
  Call doc.Range(0, 0).Select	'……(1)'
  Do
    '「(●」を探す'
    With Selection.Find
      .MatchWildcards = False
      .MatchFuzzy = False
      .Text = "(●"
      Call .Execute    '……(2)'
      'ヒットしなければ終了'
      If Not .Found Then Exit Do
    End With
    '開始位置を変数にセットする'
    Dim baseRange As Range
    Call Selection.Collapse(wdCollapseStart) '……(3)'
    Set baseRange = Selection.Range
    '選択範囲を「)」まで延ばす'
    Dim refRange As Range
    Call Selection.Extend(")")    '……(4)'
    Set refRange = Selection.Range
    '文字数を取得する'
    Dim charCount As Long
    charCount = refRange.Characters.Count - 2 'カッコの分は引く'
    '変数にセットした開始位置から逆方向に文字数分選択範囲を延ばす'
    Call baseRange.Select
    Call Selection.MoveLeft(Unit:=wdCharacter, _
                            Count:=charCount, _
                            Extend:=wdExtend)    '……(5)'
    'Selection.CharactersのEmphasisMarkプロパティをセットする'
    Call putEmphasisMark(Selection, charCount)    '……(6a)'
    'ハナクソを削除する'
    Call refRange.Delete    '……(7)'
    '削除後、charCount字数分だけ選択された状態なので、終端に向けて潰す'
    '潰しておかないと、次に選択範囲内だけを検索することになる'
    Call Selection.Collapse(wdCollapseEnd)
  Loop
End Sub

Private Sub putEmphasisMark(ByVal targetSelection As Selection, _
                            ByVal charCount As Long)    '……(6b)'
'指定された文字に傍点を施す'
  Dim i As Long
  For i = 1 To charCount
    targetSelection.Characters(i).EmphasisMark = wdEmphasisMarkOverComma
  Next
End Sub

処理の手順は、コード中のコメントのとおり。

実行

f:id:akashi_keirin:20190711082255j:plain

とりあえず、13,169文字分のテキストをWordに貼り付けて実験してみる。

(1)の

Call doc.Range(0, 0).Select

で、

f:id:akashi_keirin:20190711082259j:plain

こうなる。

With Selection.Find
  .MatchWildcards = False
  .MatchFuzzy = False
  .Text = "(●"
  Call .Execute    '……(2)'
  'ヒットしなければ終了'
  If Not .Found Then Exit Do
End With

この(2)を実行したところで、

f:id:akashi_keirin:20190711082302j:plain

こうなる。

(3)の

Call Selection.Collapse(wdCollapseStart)

を実行すると、

f:id:akashi_keirin:20190711082306j:plain

こうなる。

(4)の

Call Selection.Extend(")")

を実行すると

f:id:akashi_keirin:20190711082310j:plain

こうなる。

(5)の

Call Selection.MoveLeft(Unit:=wdCharacter, _
                            Count:=charCount, _
                            Extend:=wdExtend)

を実行すると、

f:id:akashi_keirin:20190711082313j:plain

こうなる。

そして、(6a)の

Call putEmphasisMark(Selection, charCount)

で(6b)に飛び、

Private Sub putEmphasisMark(ByVal targetSelection As Selection, _
                            ByVal charCount As Long)    '……(6b)'
Dim i As Long
  For i = 1 To charCount
    targetSelection.Characters(i).EmphasisMark = _
                                  wdEmphasisMarkOverComma
  Next
End Sub

を実行すると、

f:id:akashi_keirin:20190711082318j:plain

こうなる。

f:id:akashi_keirin:20190711082814g:plain

(4)の後、ハナクソ(「(●●●)」)は、変数refRangeぶち込んであるので、(7)の

Call refRange.Delete

を実行して除去する。

ただし、除去した後は

f:id:akashi_keirin:20190711082734j:plain

このように除去したハナクソの数(画像の場合は三つ)分だけ選択された状態になるので、選択範囲を終端に向かって潰しておく必要がある。

ちなみに、一気にこのコードを完走させると、

f:id:akashi_keirin:20190711082321j:plain

f:id:akashi_keirin:20190711082325j:plain

f:id:akashi_keirin:20190711082827g:plain

こうなる。激速!

おわりに

非常にニッチなニーズ(そもそも存在するのか?)にお応えしました。

ドラッグで文字列を選択したかのような操作(Word)

文字列をドラッグして選択する操作(Word)

akashi-keirin.hatenablog.com

このとき、

選択範囲を文字数単位で拡張するメソッドとか、ないものか。(←調べろ。)

などと、テキトーなことをぶっこいていたが、

あった。

やはり、ものごとというものは、ちゃんと調べてみるものである。

Selection.MoveLeftメソッド

ちょこっと調べてみると、Selection.MoveLeftメソッドというものが見つかった。

コチラによると、

Moves the selection to the left and returns the number of units it has been moved.

Syntax

expression.

expression Required. A variable that represents a Selection object.

Parameters

Name Required/Optional Data type Description
Unit Optional WdUnits The unit by which the selection is to be moved.The default value is wdCharacter.
Count Optional Variant The number of units the selection is to be moved. The default value is 1.
Extend Optional Variant Can be either wdMove or wdExtend. If wdMove is used, the selection is collapsed to the endpoint and moved to the left. If wdExtend is used, the selection is extended to the left. The default value is wdMove.

とある。

つまり、たとえば、

Call Selection.MoveLeft(wdCharacter, 5, wdExtend)

と書けば、

現在のカーソル位置から〈文字単位で〉、〈5だけ〉、左方向へ〈選択範囲を延ばす〉という操作を行うことができるということだ。

実験

f:id:akashi_keirin:20190710075155j:plain

このように、「キーワード」と「(●●●●●)」の嵌張にカーソルを置いて、イミディエイト・ウインドウに

Call Selection.MoveLeft(wdCharacter, 5, wdExtend)

と打ち込んで[Enter]を押す。

f:id:akashi_keirin:20190710075159j:plain

この通り。

おわりに

これでかなり処理速度を上げることができるぞ!

うおおおおおおおおおおおお!

面白くなってきたぜええええ!

ちなみに、右方向に選択範囲を延ばすには、Selection.MoveRightメソッドをどうぞ。

テキストファイルの内容を保持するクラス

テキストファイルの内容を保持するクラス

処理に必要な値の中で、〈ほぼ静的なんだけどちょっと動的な値〉、つまり、滅多に変更することはないのだけれど、たまに変更が生ずるような値があると、実にめんどくさい。

これがExcelの場合だと、設定値書き込み用のシートを置いておけば、そのシートを設定ファイル代わりに使えて便利だ。

しかし、WordやPowerpointなどだとそうはいかない。

まあ、〈滅多に変更することがない値〉なので、モジュールに定数として書いてしまう、という対応をよくする。

実用上、これで困ることはほぼないのだが、それでもやはりたまに訪れる変更のときに、いちいちVBEを開いて書き換える、というのもイマイチな気がする。

ほかには、たとえば、CustomDocumentPropertiesを用いるという手もあるが、それとていちいちDocumentなりPresentationなりを開かねばならんので、やはりめんどくさい。

そこで、テキストファイルですよ!

テキストファイルを用いる

プロジェクトの外側に設定用のテキストファイルを置いておけば、設定変更したいときはそのテキストファイルを書き換えれば済むのだから、ユーザとしてはずいぶん楽になる。

しかし、コーディングという観点からすれば、VBAからテキストファイルを操るのは、(めったに使わないステートメントを使わねばならんこともあって)かなりめんどくさい。

それならば、クラスでラップしちまえば良いのですよ。

TextFileクラス

テキストファイルの各行の文字列をインスタンス内に保持して、必要に応じて対象行の文字列を返すシンプルなクラスにしてみた。

とりあえず、書いたコードをぶちまける。

クラスモジュール TextFile
Option Explicit

'Constants'
Private Enum ErrorTypes
  etFileNotFound = 1
  etLineNotExists
  etErrorOccurred
End Enum

'Module Level Variables'
Private fileFullName As String
Private line_() As String
Private fsObj As FileSystemObject

'Properties'
Public Property Get Line(ByVal numberOf As Long) As String
  Const ERR_SOURCE As String = "TextFile Class, Property Get Line"
  Dim ret As String
  '存在しない行番号を指定していたらエラー。'
  If UBound(line_) + 1 < numberOf Or _
     numberOf < 0 Then _
    Call raiseError(etLineNotExists, ERR_SOURCE)
  On Error GoTo ErrorHandler
  ret = line_(numberOf - 1)
  Line = ret
  Exit Property
ErrorHandler:
  '何かしらエラーが出たら、イミディエイトに情報を表示して中断。'
  Debug.Print "Number : " & Err.Number
  Debug.Print "Description : " & Err.Description
  Call raiseError(etErrorOccurred, "")
End Property

Public Property Get LineCount() As Long
  Dim ret As Long
  If IsEmpty(line_) Then ret = 0: GoTo Finalizer
  ret = UBound(line_) + 1
Finalizer:
  LineCount = ret
End Property

'Constructors'
Private Sub Class_Initialize()
  Set fsObj = New FileSystemObject
End Sub

Public Sub init(ByVal targetFullName As String)
  '対象ファイルの存否確認。なければエラー。'
  If Not fsObj.FileExists(targetFullName) Then _
    Call raiseError(etFileNotFound, "TextFile Class, init Method")
  'モジュールレベル変数に対象ファイルのフルパスを保存'
  fileFullName = targetFullName
  'テキストファイルを開いて、データを取得'
  Dim n As Long
  n = FreeFile(0)
  Open fileFullName For Input As n
  Dim LineCount As Long
  LineCount = 1
  Do
    ReDim Preserve line_(LineCount - 1)
    Line Input #n, line_(LineCount - 1)
    LineCount = LineCount + 1
  Loop Until EOF(n)
  Close n
End Sub

'Destructor'
Private Sub Class_Terminate()
  Set fsObj = Nothing
End Sub

'Methods'
Public Sub regetData(Optional ByVal targetFullName As String)
  If targetFullName = "" Then GoTo MainProcess
  If Not fsObj.FileExists(targetFullName) Then _
    Call raiseError(etFileNotFound, "TextFile Class, regetData Method")
  '新たにファイルフルパスが渡されたら、それを新しいファイルフルパスにする'
  fileFullName = targetFullName
MainProcess:
  Erase line_
  Call Me.init(fileFullName)
End Sub

Private Sub raiseError(ByVal typeOfError As ErrorTypes, _
              Optional ByVal errorSource As String)
  Dim msg As String
  msg = getErrorMessage(typeOfError)
  Call Err.Raise(Number:=10000 + typeOfError, _
                 Source:=errorSource, _
                 Description:=msg)
End Sub

Private Function getErrorMessage( _
          ByVal typeOfError As ErrorTypes) As String
  Dim ret As String
  Select Case typeOfError
    Case etFileNotFound:  ret = "The file you specified isn't found."
    Case etLineNotExists: ret = "This file doesn't have so many lines."
    Case etErrorOccurred: ret = "Some Error has occurred"
  End Select
  getErrorMessage = ret
End Function

パーツごとに見ておこう。

Constants
Private Enum ErrorTypes
  etFileNotFound = 1
  etLineNotExists
  etErrorOccurred
End Enum

クラス内でエラーが起こった場合の対応を分岐するために、列挙体を作った。

この値に応じてgetErrorMessageメソッドでエラーメッセージを取得して、raiseErrorメソッドでエラーを起こすのに使う。

Module Level Variables
Private fileFullName As String
Private line_() As String
Private fsObj As FileSystemObject

クラスモジュール内で通用するモジュールレベル変数。

fileFullNameには、テキストファイルのフルパスを保存する。

line_()には、テキストファイルから読み込んだ文字列を、配列にしてぶちこんでおく。

fsObjは、FileSystemObjectのインスタンス用。ファイルやフォルダの存否確認に必ず用いるので、クラス内にPrivateで置いておく。

Properties
Public Property Get Line(ByVal numberOf As Long) As String
  Const ERR_SOURCE As String = "TextFile Class, Property Get Line"
  Dim ret As String
  '存在しない行番号を指定していたらエラー。'
  If UBound(line_) + 1 < numberOf Or _
     numberOf < 0 Then _
    Call raiseError(etLineNotExists, ERR_SOURCE)
  On Error GoTo ErrorHandler
  ret = line_(numberOf - 1)
  Line = ret
  Exit Property
ErrorHandler:
  '何かしらエラーが出たら、イミディエイトに情報を表示して中断。'
  Debug.Print "Number : " & Err.Number
  Debug.Print "Description : " & Err.Description
  Call raiseError(etErrorOccurred, "")
End Property

Public Property Get LineCount() As Long
  Dim ret As Long
  If IsEmpty(line_) Then ret = 0: GoTo Finalizer
  ret = UBound(line_) + 1
Finalizer:
  LineCount = ret
End Property

プロパティはとりあえず二つだけ。

Lineプロパティは、対象のテキストファイルの文字列の内、引数で指定した行の文字列を返す。

変な引数が与えられたときにはエラーを起こすようにしている。

LineCountプロパティは、テキストファイルの行数を返す。

とりあえずはこれだけ。

Constructors
Private Sub Class_Initialize()
  Set fsObj = New FileSystemObject
End Sub

Public Sub init(ByVal targetFullName As String)
  '対象ファイルの存否確認。なければエラー。'
  If Not fsObj.FileExists(targetFullName) Then _
    Call raiseError(etFileNotFound, "TextFile Class, init Method")
  'モジュールレベル変数に対象ファイルのフルパスを保存'
  fileFullName = targetFullName
  'テキストファイルを開いて、データを取得'
  Dim n As Long
  n = FreeFile(0)
  Open fileFullName For Input As n
  Dim LineCount As Long
  LineCount = 1
  Do
    ReDim Preserve line_(LineCount - 1)
    Line Input #n, line_(LineCount - 1)
    LineCount = LineCount + 1
  Loop Until EOF(n)
  Close n
End Sub

コンストラクタに引数を渡すことができないVBAの悲しい性により、コンストラクタが二つもある。

一つ目はFileSystemObjectのインスタンスfsObjにぶち込むだけ。必ず使用するのだから、ここでセットしておくのが良いと思った。

もう一つのinitメソッドがこのクラスの中枢部分。

テキストファイルから各行の文字列を取り出して配列に格納。

データの抜き出しが終わったら、テキストファイルは用無しなので、閉じてしまう。必要ならまた開けば良い。

Destructor
Private Sub Class_Terminate()
  Set fsObj = Nothing
End Sub

これはまあ、FileSystemObjectのインスタンスを破棄しているだけ。別にいらんといえばいらんけど。

Methods
Public Sub regetData(Optional ByVal targetFullName As String)
  If targetFullName = "" Then GoTo MainProcess
  If Not fsObj.FileExists(targetFullName) Then _
    Call raiseError(etFileNotFound, "TextFile Class, regetData Method")
  '新たにファイルフルパスが渡されたら、それを新しいファイルフルパスにする'
  fileFullName = targetFullName
MainProcess:
  Erase line_
  Call Me.init(fileFullName)
End Sub

Private Sub raiseError(ByVal typeOfError As ErrorTypes, _
              Optional ByVal errorSource As String)
  Dim msg As String
  msg = getErrorMessage(typeOfError)
  Call Err.Raise(Number:=10000 + typeOfError, _
                 Source:=errorSource, _
                 Description:=msg)
End Sub

Private Function getErrorMessage( _
          ByVal typeOfError As ErrorTypes) As String
  Dim ret As String
  Select Case typeOfError
    Case etFileNotFound:  ret = "The file you specified isn't found."
    Case etLineNotExists: ret = "This file doesn't have so many lines."
    Case etErrorOccurred: ret = "Some Error has occurred"
  End Select
  getErrorMessage = ret
End Function

メソッドは今のところ三つ。

とはいえ、最後のgetErrorMessageメソッドはraiseErrorメソッドの下請けみたいなもんなので、実質二つ。

しかも、raiseErrorメソッドは、エラーが出たときの内部メソッドに過ぎないので、実質は一つみたいなもん。

で、その唯一のregetDataメソッドは、テキストファイルからのデータ再取得メソッド。

将来的に、このTextFileクラスを介してテキストファイルを書き換えるようなメソッドを置いたような場合に、設定の再取得ができるように作っただけ。今のところ使い道はない。

実験

次のようなテキストファイルを用意する。

f:id:akashi_keirin:20190709174716j:plain

マクロを実行するプロジェクト(今回はWord VBAを使うので、Wordドキュメント。)と同じフォルダ内に、「Test.txt」という名前にして置いておく。

そうして、次のコードで実験。

スト2 標準モジュール
Private Sub testTextFileClass()
  Dim targetPath As String
  targetPath = ThisDocument.Path & "\" & "test.txt"  '"
  Dim txtFile As TextFile
  Set txtFile = New TextFile
  Call txtFile.init(targetPath)
  Dim i As Long
  For i = 1 To txtFile.LineCount
    Debug.Print txtFile.Line(i)
  Next
  Call txtFile.regetData(targetPath)
  For i = 1 To txtFile.LineCount
    Debug.Print txtFile.Line(i)
  Next
End Sub

TextFileクラスのインスタンスを生成し、「Test.txt」のフルパスを渡して初期化。

Lineプロパティの中身を全てイミディエイト・ウインドウに吐き出させる。

その後、regetDataメソッドで再度「Test.txt」のデータを読み込んで、Lineプロパティの中身を全てイミディエイト・ウインドウに吐き出させる。

もちろん、「Test.txt」の中身は変わらないので、同じ出力が二度あるだけだが。

実行結果

f:id:akashi_keirin:20190709174719g:plain

意図どおり。

おわりに

クラスにしたので、設定ファイルが複数種類あっても、それぞれインスタンスを作ればよい。

また、たとえば、

テキストファイルの1行目が保存用フォルダ名、2行目が差込印刷データソースのファイル名、3行目が差込データテーブルの名前

だったら、呼び出し側のモジュールに

Private Enum SettingData
  sdSaveFolderName = 1
  sdDataSourceFileName
  sdDataSourceTableName
End Enum

のような列挙体を作成しておき、

txtFile.Line(sdSaveFolderName)

のような形で呼び出すようにすれば、非常にreadableになると思う。

追記

TextFileクラスは新しくなりました。(2019/07/17)

akashi-keirin.hatenablog.com

指定した文字列に傍点を施すWordマクロ

指定した文字列に傍点を施すWordマクロ

芦田宏直氏が、ブログ『芦田の毎日』上で、「シラバスとは何か ― コマシラバスはなぜ必要なのか」という超大作の論考を発表しておられる。

氏のツイート(@jai_an)によると、2019/07/06時点で11万字overとのこと。

読むにあたっての困難

読まねば、とは思ったものの、何せ11万字overの論考である。

素人ゆえ大した読解力もない私が、PCやタブレットの画面上で読むのはつらい。

とりあえず、Wordとか一太郎にコピペしてプリントアウトし、紙で読もうと思った。

しかし、そこでちょっと困ったことに気づいた。

f:id:akashi_keirin:20190706223217j:plain

これである。

文中のところどころに(●●●●)のような、カッコでくくったハナクソが大量にあるのである。

最初は何かのミスだと思ったのだが、よくよく読んでみると、

直前の文字列に傍点があるというサイン

らしい。

つまり、

f:id:akashi_keirin:20190706223220j:plain

こういうことだ。

しかし、文中のあちこちにハナクソみたいな記号群があると、読みにくくて仕方がない。

何とかマクロで整形できないものか、考えてみた。

先に断っておくが、今のところまったく実用性のないソリューションになっているので、期待しないように。

コード

とりあえず、作成したコードをぶちまけておく。

リスト1 標準モジュール
Option Explicit

Private Sub main()
  Call putEmphasisMarkToDocument
  Call removeMarks
End Sub

Private Sub putEmphasisMarkToDocument()
  Dim doc As Document
  Set doc = ThisDocument
  Dim i As Long
  Dim targetCount As Long
  Dim hasStarted As Boolean
  Dim startPos As Long
  Dim endPos As Long
  For i = 2 To doc.Characters.Count
    'カウントモード中に「●」に出会ったら、targetCountをインクリメントする'
    If hasStarted Then _
      If doc.Characters(i) = "●" Then targetCount = targetCount + 1
    'カウントモード中に「)」に出会ったら、startPosを確定させて傍点を施す'
    If hasStarted Then
      If doc.Characters(i) = ")" Then
        startPos = endPos - targetCount + 1
        Call putEmphasisMark(doc, startPos, endPos)
        'カウントモード解除'
        hasStarted = False
      End If
    End If
    'カウントモード中は「(●」を探す必要なし'
    If hasStarted Then GoTo Continue
    Dim tmp As String
    tmp = doc.Characters(i - 1).Text & doc.Characters(i).Text
    '「(●」を見つけたら、targetCountを初期化し、カウントモードにした上で、'
    'endPosの値を決める'
    If tmp = "(●" Then _
      targetCount = 1: hasStarted = True: endPos = i - 2
Continue:
  Next
End Sub
'指定された文字に傍点を施す'
Private Sub putEmphasisMark(ByVal targetDoc As Document, _
                             ByVal startPos As Long, _
                             ByVal endPos As Long)
  Dim i As Long
  For i = startPos To endPos
    targetDoc.Characters(i).EmphasisMark = wdEmphasisMarkOverComma
  Next
End Sub

'元の印(「(●●●)」)を削除する'
Private Sub removeMarks()
  Dim orgRange As Range
  Set orgRange = Selection.Range
  Dim doc As Document
  Set doc = ThisDocument
  Call doc.Range(0, 0).Select
  Do
    With Selection.Find
      .MatchWildcards = False
      .MatchFuzzy = False
      .Text = "(●"
      Call .Execute
      If Not .Found Then Exit Do
    End With
    Call Selection.Collapse(Direction:=wdCollapseStart)
    With Selection
      Call .Extend(Character:=")")
      Call .Delete
    End With
  Loop
  Call orgRange.Select
End Sub

もう、恥ずかしくなるぐらいの力業。強引にもほどがある。

[Document].Charactersコレクションを総当たりにしているので、11万字overのドキュメントにこのマクロを実行したら、当分終わらないだろうと思う。

一応説明しておくと、次のような手順で傍点を施している。

  • 文書の先頭から1文字づつ当たっていき、「(●」になっているところを探す。
  • 見つかったら、カウントモードをオンにする。(hasStartedTrueにする。)
  • 同時に、傍点を施す最後の文字の位置が分かるので、endPosにセットする。
  • 引き続き1文字づつ当たっていく。「●」である限り、targetCountをインクリメントする。
  • 「)」に当たったら、その時点でのtargetCountの値が傍点を施すべき文字数。これで、傍点を施す開始位置が判明するので、startPosにセットする。
  • 傍点を施すべきCharactersコレクションの開始インデックス(startPos)と終了インデックス(endPos)が分かっているので、それぞれの要素のEmphasisMarkプロパティを設定する。

今改めて書き起こしても、実に強引なやり方だ……。

一通り傍点を施し終わったら、あとはハナクソ軍団を削除するのみ。

WordVBAについてはまだまだよくわかっていないので、こちらも強引な手法となった。簡単に手順を記しておくと、

  • Findオブジェクトを用いて、先頭から順に「(●」を探す。
  • 見つかったら、一旦始点側に選択範囲を潰す。
  • Selection.Extendメソッドを用いて選択範囲を広げる。引数Characterに「)」を渡すことにより、終端のカッコまで選択範囲を広げてくれる。
  • 先頭のカッコ~終端のカッコが選択された状態になるので、Deleteメソッドを用いて削除する。
  • 繰り返し。

まあ、こんな感じ。

実行

f:id:akashi_keirin:20190706223257j:plain

とりあえず、このような文書を用意して実験してみる。

f:id:akashi_keirin:20190706223413g:plain

とりあえず、意図した結果は得られている。

おわりに

しかし、相手は11万字overである……。

もっとスマートな方法があるはずだよな……。

とりあえず、選択範囲を文字数単位で拡張するメソッドとか、ないものか。(←調べろ。)