「青空文庫」をWordVBAで攻略する(2)
ルビを振るべき親文字の箇所を取得する
前回
紹介したのは、「青空文庫」からダウンロードしたテキストファイルから、ルビ情報（「《 》」で括られた文字列）を削除する、という対応だった。
しかし、いくら読みやすさのためといえども、ルビ情報全削除はあんまりである。
当然、次に目指すべきは、
ちゃんとルビを振ろうぜ
ということになる。
目次
こんなことをします
ルビの親文字に相当する部分をRangeオブジェクトとして取得するために必要なFunctionを作る。
通常であれば、これは人間にしか（完全には）なし得ない作業だが、幸い「青空文庫」では明確なルールに基づいてテキストデータを作ってくれているので、なんとかなる。
詳細は後述。
とにかく、たとえば、
この画像の中でいえば、
左の手で小次郎の鼻息《びそく》をそっと触れてみた。の中から、
このように、親文字となるべき「鼻息」の部分をRangeオブジェクトとして取得するのである。
考え方
先述の通り、「青空文庫」では、次のようなルールでルビ情報をテキストデータ上で表現している。
- 親文字の直後に「
《 》」で括ってルビを示す
【例】：小次郎の鼻息《びそく》→「鼻息」が親文字 - ルビを振らない漢字と隣接しているときは、区切りの部分に「｜」（全角バーティカルバー）が入っている
【例】：柳生｜石舟斎《せきしゅうさい》→「石舟斎」が親文字
実に明解。
つまり、「《」の手前から遡り、非漢字にぶつかるか、「｜」にぶつかるかしたら、その直後の位置までが親文字ということだ。
処理の手順は次の通り。すなわち、
- 「
《 》」で括られた部分のRangeオブジェクトを取得 - 取得した
Rangeオブジェクトを一旦開始方向に向けて潰し、その位置（*1）を取得する - そこから1文字づつ遡って、漢字かどうか、または「｜」かどうかを調べる
- 非漢字または「｜」にぶつかったら、その直後の位置を取得する（*2）
- （*1）、（*2）で取得した位置を元に
Rangeオブジェクトを作成する
このような手順である。
ルビの親文字の箇所を取得する
指定した文字の位置を取得する
これは、前回も使用したgetNextPositionメソッドを使う。
コードを再掲する。
リスト１ 標準モジュールFormatStrings
Private Function getNextPosition( _
ByVal FindText As String) As Long
Dim ret As Long
ret = -1
With Selection.Find
.Text = FindText
.Replacement.Text = ""
.Wrap = wdFindStop
.Format = False
.Highlight = False
.MatchCase = False
.MatchFuzzy = False
.MatchWholeWord = False
.MatchByte = False
.MatchAllWordForms = False
.MatchSoundsLike = False
.MatchWildcards = False
End With
Call Selection.Find.Execute
If Not Selection.Find.Found Then GoTo ReturnValue
ret = Selection.Range.Start
Call Selection.Collapse(wdCollapseEnd)
ReturnValue:
getNextPosition = ret
End Function
漢字かどうかを判定するFunction
これまた、ずいぶん前に書いたコードを再利用する。
リスト２ 標準モジュールFormatStrings
Private Function isKanji( _
ByVal tgtChar As String) As Boolean
isKanji = False
Dim char As String * 1
char = tgtChar
If CInt(Asc(tgtChar)) > 0 Then Exit Function
If CInt(Asc(char)) < CInt(&H889F) Then Exit Function
isKanji = True
End Function
Privateメソッドで、1文字だけ渡して漢字かどうかを判定するだけの用途に使うので、ややこしい引数チェック等はなし。
親文字の箇所を取得するFunction
ここまでで準備はオッケー。後はコーディングあるのみ！
リスト３ 標準モジュールFormatStrings
Private Function getRubiedCharPosition( _
ByVal BasePos As Long, _
Optional ByVal Delimiter As String = "｜") As Long '……(1)'
Dim ret As Long '……(2)'
ret = 0
Dim tgtDoc As Document
Set tgtDoc = ActiveDocument
Call tgtDoc.Range(BasePos, BasePos).Select '……(3)'
Dim tmp As String '……(4)'
Do
tmp = tgtDoc.Range(BasePos - 1, BasePos).Text '……(5)'
If Not isKanji(tmp) Or tmp = Delimiter Then '……(6)'
ret = BasePos '……(7)'
Exit Do
Else
BasePos = BasePos - 1 '……(8)'
If BasePos < 0 Then Exit Do
End If
Loop
getRubiedCharPosition = ret
End Function
まず、(1)の
Private Function getRubiedCharPosition( _
ByVal BasePos As Long, _
Optional ByVal Delimiter As String = "｜") As Long
で引数と返り値の設定。
引数BasePosは探索の開始位置。「青空文庫」でいえば、「《」の直前の位置ということになる。
引数Delimiterは、親文字開始の目印となる文字。
「青空文庫」の場合、「｜」という非漢字文字が区切りの役割を果たしているので、デフォルト値を「｜」にする意味はない。
とにかく、「《」の直前の位置から遡り、非漢字文字にぶつかったらその直後の位置を整数値で返すので、返り値はLong型。
(2)の
Dim ret As Long ret = 0
で返り値用変数と初期値を設定。
文書の先頭から親文字が始まる可能性があるので、初期値は0。
先頭まで行っても非漢字文字にぶつからないということは、（「青空文庫」のボランティアスタッフがミスったのでない限り、）文書の先頭が親文字の開始位置だということだ。
探索を繰り返して、非漢字文字にぶつからないまま文書先頭に至ったときには「0」を返すようにするために、こうしておく。
(3)の
Call tgtDoc.Range(BasePos, BasePos).Select
で、探索開始位置にカーソルをセット。
(4)からの11行
Dim tmp As String
Do
tmp = tgtDoc.Range(BasePos - 1, BasePos).Text '……(5)'
If Not isKanji(tmp) Or tmp = Delimiter Then '……(6)'
ret = BasePos '……(7)'
Exit Do
Else
BasePos = BasePos - 1 '……(8)'
If BasePos < 0 Then Exit Do
End If
Loop
が探索過程。
まず、(5)の
tmp = tgtDoc.Range(BasePos - 1, BasePos).Text
で、先頭方向に1文字分の文字を取得。
(6)の
If Not isKanji(tmp) Or tmp = Delimiter Then
で、その文字が〝非漢字または区切り文字〟であるかどうかをを判定し、Trueならば、(7)の
ret = BasePos Exit Do
で位置を返す。
非漢字文字にぶつかった時点で、BasePosの値は非漢字文字の直後、すなわち親文字の開始位置を表すので、これでよい。
(6)の判定結果がFalseだったら、(8)の
BasePos = BasePos - 1 If BasePos < 0 Then Exit Do
でBasePosの値を1減らす。
また、1減らした段階でBasePosの値が負の数になっていたら、それ以上探索しても無駄なのでループを抜ける。（0が返ることになる。）
ルビの親文字の箇所を取得する
ここまでで準備はできた。
まさに、「時は来た、それだけだ！」状態である。
上掲getNextPositionで、「《」の位置を取得すれば、それが〝ルビの親文字の箇所〟の終端となり、getRubiedCharPositionで、文書前方の直近の非漢字文字の直後の位置を取得すれば、それが〝ルビの親文字の箇所〟の始端となるのである！
つまり、たとえば、
このようにカーソルを置いて、次のコードを実行すれば、親文字の部分が選択されることになる。
リスト４ 標準モジュール
Private Sub test00()
Dim rng As Range
Dim startPos As Long
Dim endPos As Long
endPos = getNextPosition("《")
startPos = getRubiedCharPosition(endPos)
Set rng = ActiveDocument.Range(startPos, endPos)
Call rng.Select
End Sub
ほれ、この通り。
この状態で実行したら、
当然こうなる。
おわりに
あとは、親文字にルビを振り、「《 》」で括られた部分を削除するだけ。
ここまで来たら、あとは楽勝でしょう。
指定した文字列に挟まれた箇所を取得する（Word）
補足 指定した文字列に挟まれた箇所を取得する
の補足。
ワイルドカードを用いたらもっと簡単にできるので、書いておきます。
目次
こんなことができます
たとえば、
「《》」で括られた箇所を取得したい！
というときに、引数に「《」と「》」を指定してやると、後方にある直近の当該箇所を指し示すRangeオブジェクトを取得することができます。
考え方
FindオブジェクトのTextプロパティに、ワイルドカードを用いて文字列を指定する。
それだけ。たったそれだけ。
たとえば、〝「《》」で括られた箇所〟が必要なら、Textプロパティを、
With Selection.Find
.Text = "《" & "*" & "》"
' 以下省略'
:
:
End With
とすればよい。
指定した文字列に挟まれた箇所を取得するFunction
さっさとコードを書いてしまおう。
リスト１ 標準モジュールFormatStrings
Public Function GetSandwichedRange( _
ByVal StartChar As String, _
ByVal EndChar As String) As Range
Dim ret As Range
Set ret = Nothing
With Selection.Find
.Text = StartChar & "*" & EndChar
.Replacement.Text = ""
.Wrap = wdFindStop
.Format = False
.Highlight = False
.MatchCase = False
.MatchWholeWord = False
.MatchByte = False
.MatchAllWordForms = False
.MatchPhrase = False
.MatchSoundsLike = False
.MatchFuzzy = False '……(*)'
.MatchWildcards = True
End With
Call Selection.Find.Execute
If Not Selection.Find.Found Then GoTo ReturnObject
Set ret = Selection.Range
ReturnObject:
Set GetSandwichedRange = ret
End Function
気をつけないといけないのは、(*)のところ。
今回は、ワイルドカードを有効にするためにMatchWildcardsプロパティをTrueに設定したいのだが、だからといって、たとえば
.MatchWildcards = True .MatchFuzzy = False
という順でコードを書くと、
という実行時エラーに見舞われるのである。
これは、先のエラーメッセージに挙げられている「MatchPhrase」、「MatchWildcards」、「MatchSoundsLike」、「MatchAllWordForms」、「MatchFuzzy」の各プロパティのうち、唯一「MatchFuzzy」プロパティのみが、初期値Trueであるという事情による。
つまり、MatchFuzzyをFalseにする前に、「MatchPhrase」、「MatchWildcards」、「MatchSoundsLike」、「MatchAllWordForms」のうちどれか一つでもTrueにすると、
「MatchPhrase、MatchWildcards、MatchSoundsLike、MatchAllWordForms、MatchFuzzyパラメータ」を「同時に True に設定」した呼ばわり
されることになるのである！
まさに、天に二日なし!!!!!!!!
たぶん、多くの人は、Findオブジェクトを利用するコードなんてコピッペして使い回しているはずなので（ですよね？）、初めから「.MatchFuzzy」はMatch一族の中で一番上に置いておくのが良いかもしれない。
おっと、話がそれた。
このGetSandwichedRangeメソッドを用いれば、
たとえば、
この状態で、次のコードをイミディエイトで実行すると、
?GetSandwichedRange("《", "》").Text
こうなる。意図どおりの結果。
指定した文字列に挟まれた箇所を置換するメソッドはこんなに短くなります
前回のリスト２のコードは、次のように劇的に（？）短くなる。
リスト２ 標準モジュールFormatStrings
Public Function ReplaceSpecifiedRange( _
ByVal StartChar As String, _
ByVal EndChar As String, _
Optional ByVal ReplaceText As String = "") As Boolean
ReplaceSpecifiedRange = False
Dim tgtRange As Range
Set tgtRange = GetSandwichedRange(StartChar, EndChar)
If tgtRange Is Nothing Then Exit Function
tgtRange.Text = ReplaceText
ReplaceSpecifiedRange = True
End Function
おわりに
ただ、なんとなく今回の方式の方が遅い気がする。
ちょいと測ってみたら、
やっぱり少しだけ遅い。（何度も実験したわけではないので、毎回こうなるかどうなのかは不明。）
うーん……。何なのだろう。
「青空文庫」をWordVBAで攻略する(1)
「青空文庫」のテキストからルビ用文字列を除去する
「青空文庫」からダウンロードしたテキストファイルを、WordVBAを用いて整形していきます。
今回は、手始めに〝ルビ用文字列〟の除去を行います。
目次
こんなことができます
「青空文庫」からテキストデータをダウンロードすると、
中身はこうなっている。
見ての通り、
櫂《かい》の木太刀本文中でルビが振られている文字の後ろに、「《》」で括ってルビの文字列を示してある。
これはこれで実に重要な情報なのだが、読む際にはただただ邪魔である。
このテキストデータをWordに貼り付けた後、読みやすいように「《》」で括られた部分を除去したい。
これを、
こういう状態にするのである。
ルビ用文字列の位置を取得する
考え方
除去するためには、まず場所を特定せねばならん。
これは簡単。ルビ文字列はことごとく「《》」で括られているのだから、「《」の位置と「》」の位置を取得して、その範囲を取得すればよい。
文字を検索し、その位置を返すFunction
Findオブジェクトを利用するFunctionを作る。
リスト１ 標準モジュールFormatStrings
Private Function getNextPosition( _
ByVal FindText As String) As Long '……(1)'
Dim ret As Long '……(2)'
ret = -1
With Selection.Find '……(3)'
.Text = FindText
.Replacement.Text = ""
.Wrap = wdFindStop
.Format = False
.Highlight = False
.MatchCase = False
.MatchWholeWord = False
.MatchByte = False
.MatchAllWordForms = False
.MatchSoundsLike = False
.MatchWildcards = False
.MatchFuzzy = False
End With
Call Selection.Find.Execute '……(4)'
If Not Selection.Find.Found Then GoTo ReturnValue '……(5)'
ret = Selection.Range.Start '……(6)'
Call Selection.Collapse(wdCollapseEnd) '……(7)'
ReturnValue: '……(8)'
getNextPosition = ret
End Function
まず、(1)の
Private Function getNextPosition( _
ByVal FindText As String) As Long
で引数と返り値を設定。
検索文字列を受け取って、ドキュメント内での位置を表す整数を返すようにした。
(2)からの2行
Dim ret As Long ret = -1
返り値用の変数retを用意して、初期値-1を設定。
文字列の位置が負の数になることはないので、検索がうまくいかなかったことがわかるようにこうしている。
(3)からの14行
With Selection.Find .Text = FindText .Replacement.Text = "" .Wrap = wdFindStop .Format = False .Highlight = False .MatchCase = False .MatchWholeWord = False .MatchByte = False .MatchAllWordForms = False .MatchSoundsLike = False .MatchWildcards = False .MatchFuzzy = False End With
は、おなじみ、Findオブジェクトの初期設定。
純粋に文字列を検索したいだけなので、ほとんどの項目がFalse。
WrapプロパティをwdFindStopにしているのは、後方検索オンリーにしたいがゆえ。
この辺りの挙動は、となりITさんのこちらの記事が詳しいのでどうぞ。
(4)の
Call Selection.Find.Execute
で検索実行。
(5)の
If Not Selection.Find.Found Then GoTo ReturnValue
でFoundプロパティを調べる。
FoundプロパティがFalseだということは、そもそも検索でヒットしなかったということなので、即座にReturnValueラベルに吹っ飛ばして、-1を返す。
(6)にたどり着いたということは、検索でヒットしたということ。
この時点で、Wordドキュメント上ではヒットした文字列が選択された状態になっている。
たとえば、「ち～んｗ」という文字列がヒットした場合、(5)の実行後は、
こんな状態になっている。
そこで、(6)の
ret = Selection.Range.Start
で選択箇所の始端位置を取得し、返り値用変数retにぶち込む。
このままだと、検索でヒットした箇所が選択状態なので、次に検索するときに検索対象がこの箇所オンリーになってしまって困る。
そこで、(7)の
Call Selection.Collapse(wdCollapseEnd)
で、選択箇所を後方に潰しておく。
あとは、(8)の
ReturnValue: getNextPosition = ret
で返り値をセットしておしまい。
ルビ文字列の箇所を表すRangeオブジェクト
これで、ルビ文字列の箇所、すなわち〝「《》」で括られた文字列の箇所〟を取得する準備がととのった。
ここからの手順は次の通り。すなわち、
- リスト１の
getNextPositionメソッドを用いて、「《」の位置を取得する - 同様に「
》」の位置を取得する [Document].Rangeメソッドに上記1.・2.で取得した開始位置・終了位置を渡してRangeオブジェクトを取得する
これでオッケーである。
コードとしては、
Dim startPos As Long
startPos = getNextPosition("《")
Dim endPos As Long
endPos = getNextPosition("》") + 1 '……(*)'
Dim tgtRange As Range
Set tgtRange = ActiveDocument.Range(startPos, endPos)
とすればオッケー。
(*)のところで「 + 1」しているのは、getNextPositionメソッドが検索でヒットした文字列の開始位置を取得するから。
ヒットした文字列（この場合は「》」）の文字数分だけプラスしてやれば終了位置になる。
ルビ用文字列を除去する
ここまでで、除去対象の箇所を表すRangeが取得できている。
あとは簡単。
[Range].Textプロパティに""をセットしてやればよい。上のコードで言えば、
tgtRange.Text = ""
とすればよい。楽勝。
ルビ用文字列を次々に除去する
「《》」で括られた箇所を除去するFunction
まず、先に記した手順をひとまとめにしたFunctionを作っておく。
リスト２ 標準モジュールFormatStrings
Public Function ReplaceSpecifiedRange( _
ByVal StartChar As String, _
ByVal EndChar As String, _
Optional ByVal ReplaceText As String = "") As Boolean
ReplaceSpecifiedRange = False
'getNextPositionは、文字列がみつからなかったら-1を返す'
Const NOT_FOUND As Long = -1
Dim startPos As Long
startPos = getNextPosition(StartChar)
If startPos = NOT_FOUND Then Exit Function
Dim endPos As Long
endPos = getNextPosition(EndChar)
If endPos = NOT_FOUND Then Exit Function
endPos = endPos + Len(EndChar)
If startPos > endPos Then Exit Function
Dim tgtDoc As Document
Set tgtDoc = ActiveDocument
Dim tgtRange As Range
Set tgtRange = tgtDoc.Range(startPos, endPos)
tgtRange.Text = ReplaceText
ReplaceSpecifiedRange = True
End Function
引数StartCharとEndCharで挟まれた文字列を、まるごと引数ReplaceTextの文字列に置き換える、というもの。
今回の例であれば、
Call FormatStrings.ReplaceSpecifiedRange("《", "》", "")
とすれば、たとえば「《ち～んｗ》」をごっそり除去できる、ということになる。
上ではCallを用いたが、置換に成功すればTrue、置換できなければFalseを返すようにしているので、たとえば、
Do
If Not FormatStrings.ReplaceSpecifiedRange("《", "》", "") Then
Exit Do
End If
Loop
とでもしておけば、文書の終端まで除去し続けることになる。
こんな感じに。（わかりやすいように、Sleepをかましています。）
おわりに
手作業で除去しようとすると恐ろしい手間がかかりますが、これだと楽勝。
こういう場面では、WordのVBAが大活躍します。
補足
ワイルドカードを用いて〝「《 》」で括られた箇所を取得する〟方法については、
コチラをどうぞ。
VBEのフォントを変えたらバグった話
VBEのフォントを変えたらバグった話
フォントを変えたらVBEがバグった
VBEのフォントを、Ricty Diminished Discordに変えたら、VBEがおかしくなった。
［ツール］→［オプション］→［エディターの設定］の順にクリックすると、「応答なし」になって、Excelが落ちるのである。
何べんやってもだめ。フォントの再変更すらさせてくれない。
治し方
ずーっと前にも、フォントを源ノ角ゴシックに変えたときに同様の症状を呈した。
そのときは、結局レジストリ・エディタでフォントを変えて治した。
レジストリのありかは、
HKEY_CURRENT_USER\SOFTWARE\Microsoft\VBA\7.1\Commonここの、FontFaceの値を変えたらオッケー。
今回は、Ricty Diminishedにしたら治った。
おわりに
原因は不明。わけわからん。
Documentの終端を取得する(Word)
Documentの終端を取得する(Word)
目次
こんなことができます
Wordドキュメントの終端のRangeオブジェクトを、簡単に取得することができる。
きっかけ
Wordドキュメントの末尾の部分のRangeオブジェクトを取得したいなあと思って、ちょろっとコードを書いてみたら、
Dim tgtDoc As Document Set tgtDoc = ThisDocument Dim tmpRange As Range Set tmpRange = tgtDoc.Range(tgtDoc.Range.End - 1, tgtDoc.Range.End - 1)
という、ぶさいくにもほどがあるコードになってしまったので、
これは外出ししなくては！
となったのがきっかけ。
それ以上でもそれ以下でもない。
Function化
コードは次の通り。
リスト１ 標準モジュール
Private Function getLastEdge( _
Optional ByVal TgtDocument As Document) As Range
If TgtDocument Is Nothing Then Set TgtDocument = ActiveDocument
Dim ret As Range
With TgtDocument
Set ret = .Range(.Range.End - 1, .Range.End - 1)
End With
Set getLastEdge = ret
End Function
もはや説明は必要ないだろう。ド直球。
使ってみる
たとえば、このようなWordドキュメントがあるとする。
画像ではややわかりにくいかも知れないが、現在カーソルが「しかしながら」で始まる段落の先頭にある。
この状態で、次のコードを実行してみる。
リスト２ 標準モジュール
Private Sub test00() Dim tgtDoc As Document Set tgtDoc = ThisDocument Dim tmpRange As Range Set tmpRange = getLastEdge(tgtDoc) '……(1)' Call tmpRange.Select '……(2)' End Sub
もはや言うまでもないことだが、(1)の
Set tmpRange = getLastEdge(tgtDoc)
で、変数tmpRangeに文書末尾のRangeオブジェクトをぶち込み、(2)の
Call tmpRange.Select
で、その部分をSelectしたわけである。
したがって、これまた非常に分かりづらい画像で恐縮至極だが、
このように、ちゃんと文書末尾にカーソルが移動している。
ばっちり。
おわりに
「車輪の再発明」みたいなことになっていたら教えろ教えてください。
Callbackメソッドを追加する
Callbackメソッドを追加する
前回
作成したDekosukeクラス。
そのイベントリスナ用ImmWndCallbackクラスに、新たなメソッドを追加してみる。
目次
- こんなことができます
- インターフェースIDekosukeCallbackの変更
- ImmWndCallbackクラスへのメソッド追加
- DekosukeクラスのNameプロパティ変更
- 使ってみる
- おわりに
- 追記
こんなことができます
今回は、
DekosukeクラスのNameプロパティを変更しようとしたとき、新しい名前が「デコスケ」だったら、変更を拒否して元の名前を維持し、イミディエイトにもその旨出力する
というものにしたい。
Private Sub testDekosuke01()
Dim ds As Dekosuke
Set ds = New Dekosuke
Set ds.Callback = New ImmWndCallback
Call ds.Say("ち～んｗ")
ds.Name = "諸葛亮"
Call ds.Say("他にすることはないのですか？")
ds.Name = "デコスケ" '……(*)'
Call ds.Say("それは良いお考えです。")
End Sub
上掲コードでは、(*)のところで、DekosukeオブジェクトのNameプロパティを「デコスケ」に変更しようと試みているが、実際に実行すると、
こうなる。
インターフェースIDekosukeCallbackの変更
まずは、メソッドの追加。
今回作成するメソッドは、名前を変更する前に発生するイベントのようなものなので、名前は「BeforeChangeName」にする。
リスト１ クラスモジュールIDekosukeCallback
Option Explicit
Public Sub AfterSaid(ByVal Message As String, _
Optional ByVal Speaker As String)
End Sub
Public Sub BeforeChangeName( _
ByVal OldName As String, _
ByRef NewName As String)
End Sub
二つ目が追加したもの。
変更前の名前OldNameと変更後の名前NewNameを受け取るようにした。
二つ目の引数NewNameをByRefにしたのは、メソッド側で値を変更できるようにするため。
今回の場合、NewNameの値が「デコスケ」だったら、
NewName = OldName
のように、元の名前をセットすることを想定している。
ImmWndCallbackクラスへのメソッド追加
インターフェースに定義したメソッドが増えたので、ImmWndCallbackクラスにもメソッドを追加せねばならない。
追加したメソッドの部分のコードは、次のリスト２の通り。
リスト２ クラスモジュールImmWndCallback
Private Sub IDekosukeCallback_BeforeChangeName( _
ByVal OldName As String, _
ByRef NewName As String)
If NewName = "デコスケ" Then
Debug.Print "名前「デコスケ」は使用できません。" & vbCrLf & _
"元の名前「" & OldName & "」に戻します。"
NewName = OldName
End If
End Function
見ての通り、NewNameが「デコスケ」だったら、イミディエイトにメッセージを表示し、NewNameにOldNameの値を代入する。
NewNameはByRef指定なので、呼び出し元のNewNameにも変更が反映される。
DekosukeクラスのNameプロパティ変更
あとは、DekosukeクラスのNameプロパティの内部を変更しないといけない。
現段階のDekosukeクラスモジュールのコードは、次に示すリスト２の通り。
リスト２ クラスモジュールDekosuke
Option Explicit
Private m_Name As String
Public Callback As IDekosukeCallback
Public Property Let Name(ByVal ArgString As String)
m_Name = ArgString '……(**)'
End Property
Public Property Get Name() As String
Name = m_Name
End Property
Public Sub Say(ByVal Message As String)
Dim tmp As String
tmp = m_Name & "曰く、「" & Message & "」"
Call MsgBox(tmp)
If Not Me.Callback Is Nothing Then
Call Me.Callback.AfterSaid(Message, m_Name)
End If
End Sub
Private Sub Class_Initialize()
m_Name = "名無しさん"
End Sub
(**)のところからも分かる通り、現状では、受けとった文字列をそのままm_Nameに代入しているだけ。
これを、次のように変更する。
Public Property Let Name(ByVal ArgString As String)
If Not Me.Callback Is Nothing Then
Call Me.Callback.BeforeChangeName(m_Name, ArgString)
End If
m_Name = ArgString
End Property
CallbackプロパティがNothingでなかったら、Callbackプロパティに代入されているオブジェクトのBeforeChangeNameメソッドを実行する。（本当にひつこいが、CallbackプロパティはIDekosueCallback型なので、必ずBeforeChangeNameメソッドを持っているのである。）
今回の場合、ImmWndCallbackクラスのBeforeChangeNameを実行することになる。
BeforeChangeNameメソッドの第2引数（この場合はArgStringがそのまま渡される。）が「デコスケ」でなければ、ImmWndCallback_BeforeChangeNameメソッドの仕様上、ArgStringの値は変更されず、それがm_Nameに代入される。すなわち、DekosukeオブジェクトのNameプロパティが変更される。
逆に、BeforeChangeNameメソッドの第2引数が「デコスケ」だったら、ImmWndCallback_BeforeChangeNameメソッドの仕様上、ArgStringの値がm_Nameの値（つまり、変更前の名前）に変更され、それがm_Nameに代入されることになる。すなわち、DekosukeオブジェクトのNameプロパティは（見かけ上）変更されないのである。
これで準備完了。
まさに、「時は来た！」状態である！
使ってみる
次のリスト３を実行する。
リスト３ 標準モジュール
Private Sub testDekosuke01()
Dim ds As Dekosuke
Set ds = New Dekosuke
Set ds.Callback = New ImmWndCallback
Call ds.Say("ち～んｗ")
ds.Name = "諸葛亮"
Call ds.Say("他にすることはないのですか？")
ds.Name = "デコスケ" '……(***)'
Call ds.Say("それは良いお考えです。")
End Sub
こんなふうに次々とメッセージボックスが表示されるが、
(***)のところでNameプロパティを「デコスケ」に変更しようとしたというのに、最後の「それは良いお考えです。」というセリフは「諸葛亮」が言ったことになっている。
イミディエイトはこの通り。
ちゃんとImmWndCallback_BeforeChangeNameメソッドが仕事をしているということだ。
おわりに
いやはや、面白いものだ。
追記
肝腎なことを書くのを忘れていた。
今回の内容について、
Propertyの設定値に制限加えるぐらい、Property Letプロシージャ内でやりゃいーだろうが。そのためのProperty Letプロシージャじゃねえのかよ！
と思っただろうか。
なるほど。一理ある。
しかし、私はこう思うのだ。
これぞまさに、「データとインターフェースの分離」というやつでねえのかい？
と。
たとえば、今回の場合、〝特定の名前の変更を拒否する〟という動作を、ImmWndCallbackクラスに持たせた。これによって、Dekosukeクラスに直接〝特定の名前の変更を拒否する〟という動作を書く必要がなくなった。
これにより、Nameプロパティ変更時にやらせたい動作を、実に柔軟に、自由自在に書くことができるようになるのである！
もちろん、アホみたいにたくさんクラスモジュールを使うことにはなるけど。
今のところ、このように理解しています。
もし、
おおお……、何という浅はか者よ……。おまえの考えは間違うておる……。
と思う人がいたら、教えろ教えてくだされ。
Custom EventをCallbackに変える
Custom EventをCallbackに変える
クラスモジュールを用いて作ったオブジェクトには、イベントを持たせることができる。
今回は、このCustom Eventと同様のことを、別のやり方でやってみる。
Custom Eventの場合は、Event、RaiseEvent、WithEventsという三つのキーワードを用いましたが、今度はインターフェース用のクラスモジュールとImplementsキーワードを用います。
『VBA Developer's Handbook Second Edition』で紹介されていたテクニックです。いつもありがとうございます。
目次
こんなことができます
たとえば、
Private Sub testDekosuke01()
Dim ds As Dekosuke
Set ds = New Dekosuke
Set ds.Callback = New ImmWndCallback
Call ds.Say("ち～んｗ")
ds.Name = "諸葛亮"
Call ds.Say("他にすることはないのですか？")
End Sub
こんなコードを実行するだけで、
こんな動作をさせる裏で、イミディエイトに
こんな風に出力させることができる。
上掲コード中、DekosukeクラスのインスタンスdsがSayメソッドを実行したときに、あたかもイベントが発生したかのように、イミディエイトに文字列が出力されたのである。
もちろん、Custom Eventを使わずに、である。
前述のように、代わりにIDekosukeCallbackというインターフェース用クラスモジュールと、Implementsキーワード、そして、イベントを受け取ってイミディエイトに出力するためのImmWndCallbackクラスモジュールを使う。
準備
Dekosukeクラスを作る
まずは、Dekosukeクラスを作る。
なるべく単純にするために、インスタンス個別の名前を表すNameプロパティ（read/write）と、引数で与えられた文字列をメッセージボックスで表示するSay(Message)だけを持つ簡単なクラスにする。
リスト１ クラスモジュールDekosuke
'### オブジェクト名はDekosuke ###' Option Explicit Private m_Name As String Public Property Let Name(ByVal ArgString As String) m_Name = ArgString End Property Public Property Get Name() As String Name = m_Name End Property Public Sub Say(ByVal Message As String) Dim tmp As String tmp = m_Name & "曰く、「" & Message & "」" Call MsgBox(tmp) End Sub Private Sub Class_Initialize() m_Name = "名無しさん" End Sub
見ての通り、シンプルきわまりない。
IDekosukeCallbackインターフェースを作る
次に、イベントリスナに持たせるためのインターフェースIDekosukeCallback。
リスト２ クラスモジュールIDekosukeCallback
Option Explicit
Public Sub AfterSaid(ByVal Message As String, _
Optional ByVal Speaker As String)
End Sub
これだけ。とりあえずメソッド一つだけにした。
DekosukeオブジェクトのSayメソッド実行後に実行することを想定している。
DekosukeクラスにCallbackプロパティを生やす
問題はここから。
上掲リスト１のDekosukeクラスのコードには、特にイベントを発火させるポイントはない。
そこで、このDekosukeクラスにCallbackというプロパティを生やす。
すると、リスト１は、次のようになる。
リスト1-2 クラスモジュールDekosuke
'### オブジェクト名はDekosuke ###' Option Explicit Private m_Name As String Public Callback As IDekosukeCallback '……(*)' Public Property Let Name(ByVal ArgString As String) m_Name = ArgString End Property Public Property Get Name() As String Name = m_Name End Property Public Sub Say(ByVal Message As String) Dim tmp As String tmp = m_Name & "曰く、「" & Message & "」" Call MsgBox(tmp) End Sub Private Sub Class_Initialize() m_Name = "名無しさん" End Sub
(*)の部分を追加。これでCallbackというプロパティを追加したことになる。
このCallbackプロパティ、IDekosukeCallback型にしたところがミソ。
こうすることで、IDekosukeCallbackインターフェースをImplementsしたクラスモジュールのインスタンスなら、何でもこのCallbackプロパティに突っ込めるようになったのである！
ImmWndCallbackクラスを作る
さあ、いよいよ、DekosukeクラスのCallbackプロパティに突っ込むためのクラスを作成する。
別の言い方をすれば、DekosukeオブジェクトのSayメソッド実行に反応してイミディエイトに文字列を書き出すためのクラスである。
リスト３ クラスモジュールImmWndCallback
Option Explicit
Implements IDekosukeCallback
Private Sub IDekosukeCallback_AfterSaid(Byval Speaker As String, _
ByVal Message As String)
If Speaker = "" Then Speaker = "名無しさん"
Dim tmp As String
tmp = "「" & Message & "」by " & Speaker
Debug.Print tmp
End Sub
IDekosukeCallbackインターフェースによって規定されたAfterSaidメソッドを実装。
引数MessageとSpeakerで受けとった文字列を組み合わせて、イミディエイトに出力するようにしている。
もちろん、これだけではだめ。
これに伴ってDekosukeクラスのSayメソッド側を変更せねばならない。
リスト1-3 クラスモジュールDekosuke
Public Sub Say(ByVal Message As String)
Dim tmp As String
tmp = m_Name & "曰く、「" & Message & "」"
Call MsgBox(tmp)
If Not Me.Callback Is Nothing Then '……(**)'
Call Me.Callback.AfterSaid(Message, m_Name)
End If
End Sub
Sayメソッドのメインの処理（メッセージボックスの表示）の後、AfterSaidメソッドを実行できるように、(**)からの3行
If Not Me.Callback Is Nothing Then Call Me.Callback.AfterSaid(Message, m_Name) End If
がそれ。
Callbackプロパティにイベントリスナ用のクラスのインスタンスが突っ込まれていなかったら、CallbackプロパティはNothingなので、何もしない。
Callbackプロパティにイベントリスナ用クラスのインスタンスが突っ込まれていたら、（それはIDekosukeCallback型である以上、必ずAfterSaidメソッドを持っているはずなので）ただAfterSaidメソッドを実行する、という仕掛け。
これで、まるでSayメソッドの実行を検知してAfterSaidメソッドが実行されたかのような結果が得られるのである！
使ってみる
最初に示したのと同じだが、次のコードでDekosukeクラスを使ってみる。
リスト４ 標準モジュール
Private Sub testDekosuke01()
Dim ds As Dekosuke
Set ds = New Dekosuke
Set ds.Callback = New ImmWndCallback '……(***)'
Call ds.Say("ち～んｗ")
ds.Name = "諸葛亮"
Call ds.Say("他にすることはないのですか？")
End Sub
ポイントは、(***)のところ。
Dekosukeクラスのインスタンスdsを得た後、即座にそのCallbackプロパティにImmWndCallbackクラスのインスタンスを突っ込んでいる。
少々ひつこいが、ImmWndCallbackクラスには、IDekosukeCallbackインターフェースがImplementsされているので、IDekosukeCallback型のプロパティCallbackに突っ込めるのである。
これで、以後ds.Sayメソッドが実行されるたびにAfterSaidメソッドが呼ばれることになる。
したがって、実行すると、
画面上はこうなって、
イミディエイトは
こうなる。
おわりに
VBAの特性上、やたら数多くのクラスモジュールを使うことになってしまうが、イベントを次々に連鎖させるような処理をするなら、これも一つの面白いやり方なのではないかと思いました。
