指定した文字列に挟まれた箇所を取得する（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の特性上、やたら数多くのクラスモジュールを使うことになってしまうが、イベントを次々に連鎖させるような処理をするなら、これも一つの面白いやり方なのではないかと思いました。
Worksheetを継承したクラスを作る(8)
ラップしたオブジェクトのイベントを検知する
めっちゃ久しぶりに
の続き。
ちょっと何言ってるかわからないかも知れないので説明する。
たとえば、WorksheetオブジェクトをラップしたPoweredSheetという自作クラスがあるとする。
当然、Worksheetオブジェクトには数々のイベントがある。
PoweredSheetにも同様のイベントを生やしたいのだ。
要するに、PoweredSheetに包まれたWorksheetオブジェクトで発火したイベントをPoweredSheet側で検知したい、ということだ。
どうも、イベントについては頭がこんがらがって、うまく説明できる自信がない。（いつか、「Custom Event？ ははは。簡単じゃねーか、あんなの！」と笑える日が来るのだろうか。）
自身の覚書のつもりで書き残しておく。
目次
イベントのしくみ
Custom Eventの作成に必要なのは、「Event」、「RaiseEvent」、「WithEvents」の三つのキーワード。
手順としては、
- イベント名の宣言（
Eventキーワード） - イベント発火タイミングの設定（
RaiseEventキーワード） - イベントリスナ側にイベントプロシージャを作成（
WithEventsキーワード）
という順になる。
イベント名の宣言
イベントを生やしたいオブジェクトモジュールの宣言セクション（プロシージャよりも上の部分）に、「Event」キーワードを用いてイベント名を宣言する。
たとえば、Activateという名前のイベントを宣言するときは、
Option Explicit Public Event Activate()
と書くだけ。
これで、既にイベントの作成自体はおしまい。
オブジェクト ブラウザーで見ると、
ちゃんとイベントが設定されている。
もちろん、これだけではイベントは発火しない。発火するタイミングがないのだから。
イベント発火タイミングの設定
イベントを発火させるタイミングを設定するには、「RaiseEvent」キーワードを用いる。
イベントを発火させたい場所に、
RaiseEvent イベント名(引数リスト)
と書くだけ。
たとえば、次のようなshowMessageというメソッドがあるとする。
Pubilc Sub showMessage(ByVal Message As String) Call MsgBox(Message) Message = Message & vbCrLf & "ち～んｗ" Call MsgBox(Message) End Sub
で、このプロシージャ内の１回目のMsgBox実行直後に「Activate」というイベントを発火させたいとする。
その場合は、
Pubilc Sub showMessage(ByVal Message As String) Call MsgBox(Message) RaiseEvent Activate Message = Message & vbCrLf & "ち～んｗ" Call MsgBox(Message) End Sub
と書けば良い。
これで、めでたくshowMessageメソッド実行時の１回目のMsgBox実行直後にActivateイベントが発火する。
発火するだけだけど。
発火したイベントを拾う
イベントが発火しても、それを拾うプロシージャがなければ、無視されて終わり。
ちょうど、Worksheetではそれこそ四六時中イベントが発火しているにもかかわらず、Worksheetモジュールにイベントプロシージャを置いていなかったら何も起こらないのと同じ。
イベントを拾う、すなわち、イベントプロシージャを作成するには、「WithEvents」キーワードを使う。
ただし、
イベントを拾うことができるのは、オブジェクトモジュールに限られる
ということに注意が必要。
標準モジュールではイベントが拾えない。すなわち、「WithEvents」が使えない。
とりあえず、手近なオブジェクトモジュールであるシートモジュールに書くことにする。
たとえば、シートモジュールの宣言セクションに、
Private WithEvents m_PoweredSheet As PoweredSheet
と書いてみる。
すると、VBEのオブジェクトリストに、
このようにm_PoweredSheetが追加されているのがわかる。
こいつを選択してやると、
このように、今のところPoweredSheetクラス唯一のイベントであるActivateイベントのイベントプロシージャが挿入された。
このm_PoweredSheet_Activateプロシージャ内にコードを書けば、m_PoweredSheetにぶち込まれたPoweredSheetオブジェクト内で発火したイベントを拾って、何らかの動作をさせることができる。
この説明では、シートモジュールによって、PoweredSheetオブジェクトで発火したイベントを拾った。
このシートモジュールが、「イベントリスナ（Event listener）」である。
よそで起こったイベントを聞き取って反応するやつ、ぐらいの意味だろうか。
以上が、Custom Eventのしくみである。
PoweredSheetにイベント装着
イベントの宣言
これはアホみたいに簡単。
上の「イベント名の宣言」でも書いたように、PoweredSheetクラスモジュールの宣言セクションに、
Public Event Activate()
と書くだけ。余裕。
イベント発火のタイミング設定
PoweredSheetオブジェクトは、実在するWorksheetオブジェクトをラップしているだけなので、PoweredSheetオブジェクトのActivateイベントは、実在のWorksheetオブジェクトのActivateイベントが発火したときに発火しないといけない。
一見ややこしそうに見えるけど、めっちゃ簡単。
要は、PoweredSheetオブジェクトが、その中に隠し持っている実在のWorksheetオブジェクトのイベントリスナになれば良い。
したがって、上の「発火したイベントを拾う」に書いたように、実在のWorksheetオブジェクトをぶち込む変数「m_RealSh」の宣言にWithEventsを付けるだけ。
こうすることによって、
このように、m_RealSh_Activateというイベントプロシージャを作ることができる。
このm_RealSh_Activateは、m_RealShがActivateされたときに発動する。
よって、このプロシージャ内でRaiseEventキーワードを用いれば、m_RealShのActivateイベントを拾ってPoweredSheetのActivateイベントを発火させることができることになる。
つまり、
Private Sub m_RealSh_Activate() RaiseEvent Activate End Sub
こうするわけだ。
整理すると、
m_RealShにぶち込まれたWorksheetでActivateイベントが発火するPoweredSheetオブジェクトがm_RealShのActivateイベントを拾うm_RealSh_Activateプロシージャ内でRaiseEvent Activateが実行されるPoweredSheetオブジェクトのActivateイベントが発火する
このような次第。
イベントリスナをクラスモジュールで作成
クラスモジュールTestListenerを挿入し、次のコードを書く。
リスト１ クラスモジュールTestListener
Option Explicit Private WithEvents m_PoweredSheet As PoweredSheet 'Property' Public Property Get PoweredSheet() As PoweredSheet Set PoweredSheet = m_PoweredSheet End Property 'Constructor' Private Sub Class_Initialize() Set m_PoweredSheet = New PoweredSheet End Sub Public Sub init(ByVal WorksheetEntity As Worksheet) Call m_PoweredSheet.init(WorksheetEntity) End Sub
変数m_PoweredSheetをWithEventsキーワード付きで宣言しているので、このオブジェクトはPoweredSheetオブジェクトのイベントを拾うことができるようになった。
準備は以上。後は実験あるのみ。
実験
次のコードで実験してみる。
ただし、このままではPoweredSheetのActivateイベントが無事に発動されたかどうかがわからないので、PoweredSheet内でRaiseEventを実行した直後に、イミディエイトにメッセージを出力することとする。すなわち、PoweredSheetクラスモジュール内のm_RealSh_Activateプロシージャを次のようにする。
Private Sub m_RealSh_Activate() RaiseEvent Activate Debug.Print "Activate event has surely been raised..." End Sub
イミディエイトにメッセージが出力されていたら、RaiseEvent Activateが実行された証となるはずだ。
リスト２ 標準モジュール
Private Sub test01() Dim tl As TestListener Set tl = New TestListener Dim Sh As Worksheet Set Sh = PoweredSheetProject.Sh01 Call tl.init(Sh) Debug.Print "Sh02をActivateするよ。" Call PoweredSheetProject.Sh02.Activate Debug.Print "Sh02をActivateしたよ。" Debug.Print "Sh01をActivateするよ。" Call PoweredSheetProject.Sh01.Activate '……(*)' Debug.Print "Sh01をActivateしたよ。" End Sub
変数tlにぶち込んだTestListenerオブジェクトの内部には、PoweredSheetProject.Sh01が指し示すWorksheetオブジェクトがぶち込まれている。
一旦PoweredSheetProject.Sh02がActivateされ、その後PoweredSheetProject.Sh01がActivateされることになる。
(*)のところでイベントが発火するので、「Sh01をActivateするよ。」と「Sh01をActivateしたよ。」の間に、「Activate event has surely raised...」が出力されるはずだ。
上記リスト２を実行すると、
バッチリ。
おわりに
これで、PoweredSheetプロジェクトの完成にまた一歩近づいた。
過去記事
しかしまあ、Custom Eventの実装は、割と頭がこんがらがるなあ。
