Selection.Collapseメソッドの挙動に注意(Word)

WordVBA VBA覚書

Selection.Collapseメソッドの挙動に注意

前回

akashi-keirin.hatenablog.com

紹介した、次のハイライト箇所を取得するgetNextHighLightメソッド。

検索箇所を取得した後、Selection.Collapseメソッドを用いて、選択箇所を後方に向けて潰すようにしている。

こうしないと、同じところを取得し続けてしまうからだ。

しかし、カーソルの位置によっては、Selection.Collapseメソッドはちょっと困った動きをする。

カーソルが最後尾にあるとき

たとえば、

f:id:akashi_keirin:20191229154836j:plain

こんなふうに、テキストボックスに「ダボ」というテキストが入力されていて、全体がハイライトされているとする。

このとき、テキストボックスの先頭にカーソルを置いて、次のコードを実行してみる。

リスト１
Private Sub test02()
  Dim tmp As Range
  Set tmp = getNextHighLight(Selection.Range)
  Debug.Print tmp.Text
End Sub

当然、結果は、

f:id:akashi_keirin:20191229154839j:plain

こうなって、カーソル位置は

f:id:akashi_keirin:20191229154843j:plain

こうなる。

問題はこの次。

カーソルは、テキストボックスの末尾にある。

この状態で、

Call Selection.Find.Execute

を実行するとどうなるか。

f:id:akashi_keirin:20191229154845j:plain

なんと、こうなるのである。

で、この状態で、

Call Selection.Collapse(wdCollapseEnd)

を実行するとどうなるのか。

悲しいことに、

f:id:akashi_keirin:20191229154848j:plain

こうなってしまうのである。

最末尾であるがゆえに、引数にwdCollapseStartを指定したのと同じ結果になってしまうのである。

これは実にまずい。

なぜなら、この状態で再び

Call Selection.Find.Execute

を実行すると、

f:id:akashi_keirin:20191229154850j:plain

またしてもこうなってしまうからである。

つまり、たとえば

リスト２
Private Sub test03()
  Dim tmp As Range
  Do
    Set tmp = getNextHighLight(Selection.Range)
    If tmp Is Nothing Then Exit Do
    Call someCollection.Add(tmp)
  Loop
End Sub

このようなコードで、終了判定にgetNextHighLightがNothingを返すかどうかを用いてDo ～ Loopを使おうとすると、無限ループになってしまうのだ。

しかも、恐ろしいことに、この形で無限ループになってしまった場合、派手にWordがクラッシュしてしまう。（←経験者。）

どういう理屈でそうなるのかはわからないが、たとえば私が経験したパターンだと、

  • 無限ループに陥る
  • 「応答なし」になる
  • 画面をクリックすると画面が白っぽくなる
  • ウインドウの×をクリックするとWordが終了する
  • 再び同じドキュメントを開こうとすると、「セーフモード」で起動することを勧められる
  • 言われた通りにセーフモードで開くと、中身のないWordだけが開く
  • 仕方がないのでWordを終了する
  • もう一度ドキュメントを開こうと試みる
  • 別のユーザが開いているので開けない旨通知がある
  • タスク マネージャーを開くと、確かにMicrosoft Wordが実行中で、しかもすっげーメモリを食っている
  • タスクを終了させる
  • 再度ドキュメントを開こうと試みる
  • 「セーフモード」起動を促されるが、拒否して普通に開く
  • 開くには開くが、クラスモジュールとか標準モジュールが消え去っている

長くなってしまったが、ざっとこれぐらいのわけのわからないことが起こった。

おわりに

気をつけましょう。

文書中のハイライトされた箇所を取得するFunction(Word)

WordVBA VBA自作メソッド

文書中のハイライトされた箇所を取得するFunction

文書中のハイライトされた箇所を取得するFunctionについては、かつて

akashi-keirin.hatenablog.com

akashi-keirin.hatenablog.com

このような形で取り上げたことがあった。

しかし、ハイライト箇所を文書本体、テキストボックスごとにRange配列として取得するよりも、個々のRangeオブジェクトをCollectionに叩き込むやり方の方が、取り扱いが簡単だと考えた。

そこで、単純に現在のカーソル位置の直後にあるハイライト箇所をRangeオブジェクトとして取得するメソッドを作成した。

次のハイライト箇所を取得するメソッド

コードを紹介する。

リスト１
Private Function getNextHighLight( _
             ByVal currentRange As Range) As Range  '……(1)'
  Set getNextHighLight = Nothing  '……(2)'
  Dim ret As Range  '……(3)'
  '渡されたRangeオブジェクトにカーソルを置く'
  Call currentRange.Select    '……(4)'
  '念のため選択箇所を潰しておく'
  Call Selection.Collapse(wdCollapseStart)
  With Selection.Find    '……(5)'
    Call .ClearFormatting
    Call .Replacement.ClearFormatting
  End With
  'Findオブジェクトの諸設定'
  With Selection.Find    '……(6)'
    .Text = ""
    .Replacement.Text = ""
    'これをwdFindStopにしておかないと、検索が終わらない'
    '文書の最後にカーソルがあるときに、先頭から検索してしまう'
    .Wrap = wdFindStop
    .Format = False
    .Highlight = True
    .MatchCase = False
    .MatchWholeWord = False
    .MatchByte = False
    .MatchAllWordForms = False
    .MatchSoundsLike = False
    .MatchWildcards = False
    .MatchFuzzy = False
  End With
  '検索実行'
  Call Selection.Find.Execute    '……(7)'
  'ヒットしなければNothingを返す'
  If Not Selection.Find.Found Then Exit Function  '……(8)'
  '返り値用変数に検索ヒットしたRangeオブジェクトをセット'
  Set ret = Selection.Range    '……(9)'
  '次の検索用に選択範囲を後方に潰す'
  Call Selection.Collapse(Direction:=wdCollapseEnd)  '……(10)'
  '返り値をセット'
  Set getNextHighLight = ret  '……(11)'
  DoEvents
End Function

検索に用いるFindオブジェクトには、設定項目（プロパティ）が大量にあるので、タテ長になるのは致し方なし。まあ、スニペットとかにしておくと便利なのでしょうねえ。

(1)の

Private Function getNextHighLight( _
             ByVal currentRange As Range) As Range

でメソッド名と引数を設定。

一応、Rangeオブジェクトを受け取って、そのRangeオブジェクトの直後にあるハイライト箇所をRangeオブジェクトとして返すようにした。

(2)の

Set getNextHighLight = Nothing

で初期値Nothingをセット。まあ、必要ないのだが、一応明示。

(3)の

Dim ret As Range

で返り値用変数を準備。

即Exitできるように(2)でgetNextHighLightにNothingをセットしてあるので、このretに初期値Nothingすることはしない。

(4)の

Call currentRange.Select
Call Selection.Collapse(wdCollapseStart)

で、引数として渡されたRangeオブジェクトを選択。そして、次の検索のために、選択範囲を潰しておく。

まあ、実用上はまずこの引数にはSelection.Rangeを渡すことになるので回りくどいといえば回りくどい。ただ、一応、現在カーソルがあるところ以外のRangeオブジェクトを渡す場面も想定しておかないといけないと思うので、こうした。

(5)の

With Selection.Find
  Call .ClearFormatting
  Call .Replacement.ClearFormatting
End With

でFindオブジェクトの諸設定をクリア。

f:id:akashi_keirin:20191229145422j:plain

f:id:akashi_keirin:20191229145425j:plain

この状態。

(6)の

With Selection.Find
  .Text = ""
  .Replacement.Text = ""
  .Wrap = wdFindStop
  .Format = False
  .Highlight = True
  .MatchCase = False
  .MatchWholeWord = False
  .MatchByte = False
  .MatchAllWordForms = False
  .MatchSoundsLike = False
  .MatchWildcards = False
  .MatchFuzzy = False
End With

今回は、ハイライト部分を検索するので、検索文字列を表すTextプロパティ、置換後の文字列を表すReplacement.Textプロパティの値をともに""にしておく。

ハイライト箇所を検索したいので、HighlightプロパティをTrueにする。

で、注意せねばならんのがWrapプロパティの設定値。

この値がwdFindContinueになっていると、文書等の最後の検索箇所以降にカーソルがある状態で検索を実行したときに、文書等の先頭に戻って検索してしまう。

ここまでで、検索の準備が完了。

いよいよ(7)の

 Call Selection.Find.Execute

で検索を実行。

検索対象（ハイライトされた箇所）があれば、その部分が選択された状態になる。

(8)の

If Not Selection.Find.Found Then Exit Function

ここで、FindオブジェクトのFoundプロパティを調べる。

検索対象が見つかっていなければ、FoundプロパティがFalseになるので、即Exit。これでNothingが返る。

ここを通過したときは、検索対象が見つかっているということなので、(9)の

Set ret = Selection.Range

選択されている箇所、すなわちハイライトされている箇所を返り値用変数retに突っ込む。

ここからは後始末。

検索終了時点で、ハイライトされている箇所が選択された状態になっているので、

(10)の

Call Selection.Collapse(Direction:=wdCollapseEnd)

で選択箇所を後方に向けて潰す。

最後に(11)の

Set getNextHighLight = ret

で返り値をセットしておしまい。

使ってみる

f:id:akashi_keirin:20191229145427j:plain

このようなドキュメントを用意して、カーソルを先頭に置いておく。

この状態で次のコードを実行。

リスト２
Private Sub test02()
  Dim tmp As Range
  Set tmp = getNextHighLight(Selection.Range)
  Debug.Print tmp.Text
End Sub

実行後、イミディエイトは

f:id:akashi_keirin:20191229145431j:plain

この状態。ちゃんとハイライト箇所が取得できている。

んで、

f:id:akashi_keirin:20191229145434j:plain

おわかりだろうか。ハイライト箇所の終端と次の文字のカンチャンにカーソルが移動している。

おわりに

これで、ハイライト箇所がどこにあろうと、Rangeオブジェクトを渡しさえすれば、同じRangeオブジェクトとして取得することができる。

ただし、ハイライト部分の検索にはちょっとヤバい挙動がある（たぶん）ので、このメソッドをそのままDo ～ Loopで使おうとすると、場合によってはかなりひどいことが起こります（たぶん）。気をつけましょう。

テキストボックスの先頭にカーソルを置く(Word)

WordVBA

テキストボックスの先頭にカーソルを置く

これ、みなさんどうやって実現しているのでしょう？

テキストボックス内の文字列を取得する

テキストボックスはShapeオブジェクトの一種。

んで、その配下にTextFrameオブジェクトがあり、そのTextRangeプロパティを参照すると、「指定されたレイアウト枠の中の文字列範囲を表すRangeオブジェクト」が取得できる、という次第。

従って、テキストボックス内の文字列は、

[Shape].TextFrame.TextRange.Text

で取得可能。

たとえば、Document上に

f:id:akashi_keirin:20191227075104j:plain

このようなテキストボックスがあるとき、イミディエイト・ウインドウに

?ActiveDocument.Shapes(1).TextFrame.TextRange.Text

と入力して[Enter]を押すと、

f:id:akashi_keirin:20191227075106j:plain

こんなふうに、テキストボックス内の文字列を取得することができる。

[Shape].TextFrame.TextRangeを選択する

では、テキストボックス内の文字列を選択するにはどうすればよいか。

[Shape].TextFrame.TextRangeプロパティの返り値はRangeオブジェクトなので、[Range].Selectメソッドを使えばよい。

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

ActiveDocument.Shapes(1).TextFrame.TextRange.Select

と入力して[Enter]を押す。

f:id:akashi_keirin:20191227075110j:plain

まっ　たく　簡　単　だ。

カーソルを先頭に置く

では、カーソルを先頭に持って行くにはどうすればよいのだろうか。

すでに、文字列部分が選択されている以上、私にはSelection.Collapseメソッドを用いる方法しか思い浮かばなかった。つまり、

Call Selction.Collapse(wdCollapseStart)

とするのである。

リスト１　標準モジュール
Private Sub test01()
  Call ActiveDocument.Shapes(1).TextFrame.TextRange.Select
  Call Selection.Collapse(wdCollapseStart)
End Sub

ActiveDocumentにはテキストボックスを一つ置いているだけなので、ActiveDocument.Shapes(1)とすれば、そのテキストボックスをShapeオブジェクトとして取得可能。

あとは、TextFrame.TextRangeプロパティを参照してRangeオブジェクトを取得し、そのSelectメソッドを用いてテキスト範囲を選択。

しかる後にSelection.Collapseメソッドの引数にwdCollapseStartを渡して選択範囲を先頭方向に向かって潰す。

リスト１を実行すると、

f:id:akashi_keirin:20191227075113j:plain

無事に先頭にカーソルを置くことができた。

おわりに

無事に目的は果たせたわけだが、なんかスマートじゃない気がする。

エレガントな方法があったら教えろ教えてください。

なお、なんでテキストボックスの先頭にカーソルを置きたかったのか。

それは、テキストボックスの文字列を狙って検索したかったからです。

本当に変化したときだけChangeイベントを起こす(Excel)

本当に値が変更されたときだけChangeイベントを起こす

標題はちょっと嘘。

結果的に値が変わったときだけ処理をする、というもの。

作戦

次のような作戦を考えた。

複数セルの値が変更された場合の処理は、現状力不足ゆえ諦めている。

複数セルの値が変更されたときは、変更前に戻すようにする。

  • ブックオープン時に、シートの特定の範囲の値を2次元配列にぶち込む。
  • Changeイベントが起こったときに、Target.Valueを2次元配列に格納されている値と比較する。
  • 同じ値だったらそのままExit。
  • 異なる値だったら必要な処理を行う。

まあ、こんな感じ。

準備

今回は単なる実験なので、シート上に

f:id:akashi_keirin:20191215141734j:plain

このように３×３の領域を用意して、それぞれに色々な値（笑）を入れておく。

んで、この範囲に「ListArea」と名前を付けておく。

f:id:akashi_keirin:20191215141739j:plain

後はコードを書くだけ。

コード

シートモジュール Sh01
Option Explicit

Private Const LIST_AREA As String = "ListArea"

Private listValues As Variant

Public Property Get ListArea() As Range
  Set ListArea = Me.Range(LIST_AREA)
End Property

Public Property Get ListLeftTop() As Range
  Dim rng As Range
  Set rng = Me.ListArea.Cells(1, 1)
  Set ListLeftTop = rng
End Property

Public Property Get ListRightBottom() As Range
  Dim rng As Range
  With Me.ListArea
    Set rng = .Cells(.Rows.Count, Columns.Count)
  End With
  Set ListRightBottom = rng
End Property

Private Sub Worksheet_Change(ByVal Target As Range)
  '複数セルが変更されたときは、値を元に戻してExit'
  Application.EnableEvents = False
  If Target.Count > 1 Then _
    Me.ListArea.Value = listValues: GoTo Finalizer
  'Targetがリスト外だったらExit'
  If Not isWithinList(Target) Then GoTo Finalizer
  '変更されたかどうかを判定'
  Dim r As Long, c As Long
  r = getRelativeRow(Target)
  c = getRelativeColumn(Target)
  '結果的に変更がなかったときはExit'
  If Target.Value = listValues(r, c) Then GoTo Finalizer
  '変更があった場合は何らかの処理をする'
  Call MsgBox("Value has been changed...")
  'リストの値を再配列化'
  Call setListValues
Finalizer:
  Application.EnableEvents = True
End Sub

Private Function isWithinList( _
             ByVal tgtcell As Range) As Boolean
  isWithinList = False
  'リストの外側だったらFalseを返す'
  With tgtcell
    If .Row < Me.ListLeftTop.Row Or _
       .Row > Me.ListRightBottom.Row Then Exit Function
    If .Column < Me.ListLeftTop.Column Or _
       .Column > Me.ListRightBottom.Column Then Exit Function
  End With
  'リスト内部だったらTrueを返す'
  isWithinList = True
End Function

'リスト内での相対位置を割り出す'
Private Function getRelativeRow( _
             ByVal tgtcell As Range) As Long
  Dim ret As Long
  ret = tgtcell.Row - Me.ListLeftTop.Row + 1
  getRelativeRow = ret
End Function
Private Function getRelativeColumn( _
             ByVal tgtcell As Range) As Long
  Dim ret As Long
  ret = tgtcell.Column - Me.ListLeftTop.Column + 1
  getRelativeColumn = ret
End Function

'セルの値を2次元配列に突っ込む'
Public Sub setListValues()
  listValues = Me.ListArea.Value
End Sub
ThisWorkbookモジュール
Option Explicit

Private Sub Workbook_Open()
  Call Sh01.setListValues
End Sub

細かい説明は省略ｗ　コード内のコメントを読んでくだされ。

ご質問はコメント欄とかノンプロ研SlackとかTwitterでどうぞ。

使ってみる

こんなふうに動くのだ。

f:id:akashi_keirin:20191215141753g:plain

おわりに

動作確認はテキトーなので、使い方によっては実行時エラーが出るかも知れません。

「こんなふうにしたらエラーになるがな！」みたいなのも教えてくださいましたら、気が向いたら対応いたしまする。

配列もCollectionも使わないデータ構造（Queue）

VBAクラス・モジュール VBA自作クラス

配列もCollectionも使わないデータ構造（Queue）

前回、前々回

akashi-keirin.hatenablog.com

akashi-keirin.hatenablog.com

のStackに続いて、Queueも作った。

コードを簡単にするために、今回もString型データ専門。

値なら何でもオッケーにしたければ、Variantにしてください。

StringQueueクラスとStringQueueItemクラス

用意するのは標題の二つのクラス。とりあえずコードを掲載。

クラスモジュール StringQueue
Option Explicit

'Field Variables'
Private frontItem As StringQueueItem
Private rearItem As StringQueueItem
Private count_ As Long

'Properties'
Public Property Get ItemExists() As Boolean
  ItemExists = Not ((frontItem Is Nothing) And (rearItem Is Nothing))
End Property

Public Property Get Count() As Long
  Count = count_
End Property

Public Property Get Item(ByVal Index As Long) As StringQueueItem
  Dim ret As StringQueueItem
  Set ret = Nothing
  'IndexがおかしかったらNothingを返す'
  If Index < 1 Then GoTo Finalizer
  If Index > Me.Count Then GoTo Finalizer
  'アイテムがあったら返す'
  If ItemExists Then
    Set ret = frontItem
    'アイテムが一つだけなら先頭のアイテムを返す'
    If Me.Count = 1 Then GoTo Finalizer
    Dim i As Long
    For i = 2 To Index
      Set ret = ret.NextItem
    Next
  End If
Finalizer:
  Set Item = ret
End Property

Public Property Get Front() As StringQueueItem
  Dim ret As StringQueueItem
  Set ret = Nothing
  If ItemExists Then Set ret = frontItem
  Set Front = ret
End Property

Public Property Get Rear() As StringQueueItem
  Dim ret As StringQueueItem
  Set ret = Nothing
  If Me.ItemExists Then Set ret = rearItem
  Set Rear = ret
End Property

'Constructor'
Private Sub Class_Initialize()
  count_ = 0
End Sub

'Methods'
Public Sub addItem(ByVal newValue As String)
  '新しいStringQueueItemオブジェクトを作る'
  Dim newStringQueueItem As New StringQueueItem
  'StringQueueItemオブジェクトのValueプロパティをセット'
  newStringQueueItem.Value = newValue
  If Me.ItemExists Then
    '追加前のStringQueueにアイテムがあったとき'
    Set rearItem.NextItem = newStringQueueItem
    Set rearItem = newStringQueueItem
  Else
    'アイテム追加前のStringQueueが空だったとき'
    Set frontItem = newStringQueueItem
    Set rearItem = newStringQueueItem
  End If
  count_ = count_ + 1
End Sub

Public Function removeItem() As StringQueueItem
  Dim ret As StringQueueItem
  Set ret = Nothing
  'アイテムがあったらアイテムをセット'
  If Me.ItemExists Then
    Set ret = frontItem
    'アイテム除去後の後始末'
    If frontItem Is rearItem Then
      'アイテムが一つだけだったら、StringQueueは空になる'
      Set frontItem = Nothing
      Set rearItem = Nothing
    Else
      '先頭のアイテムを入れ換える'
      Set frontItem = frontItem.NextItem
    End If
    count_ = count_ - 1
  End If
  Set removeItem = ret
End Function

StringStackクラスの場合は、一番上のアイテムへの参照であるTopプロパティだけで良かった（データの出し入れが一箇所だけなので。）が、StringQueueクラスの場合は、データの入口と出口が異なるので、データ集合の先頭アイテムへの参照であるFrontプロパティと、データ集合の最後尾のアイテムへの参照であるRearプロパティが必要となる。

新しくアイテムを追加する（つまり、最後尾にアイテムを追加する）ためのaddItemメソッドと、先頭のアイテムを取得するとともに削除するremoveItemメソッドの中身を見てもらえば、どのような処理をしているのかがおわかりかと思う（わかりにくければ、コメント欄とか、Twitter、ノンプロ研Slackなんかに質問プリーズ。）。

クラスモジュール StringQueueItem
Option Explicit

'Field Variables'
Private value_ As String
Private nextItem_ As StringQueueItem

'Properties'
Public Property Let Value(ByVal argValue As String)
  value_ = argValue
End Property
Public Property Get Value() As String
  Value = value_
End Property

Public Property Set NextItem(ByVal argItem As StringQueueItem)
  Set nextItem_ = argItem
End Property
Public Property Get NextItem() As StringQueueItem
  Set NextItem = nextItem_
End Property

こちらの方は至ってシンプル。というか、前回のStringStackItemクラスとほとんど同じ。まあ、Stackにしても、Queueにしても一列棒状にアイテムがつながっている、というデータ構造なので、次のアイテムへの参照（NextItemプロパティ。StringQueueItem型。）を持たせておけば、それだけで表現できるのであった。

使ってみる

次のコードで使ってみる。

リスト１　標準モジュール
Private Sub testStringQueue()
  Private strQueue As New StringQueue
  With strQueue
    Call .addItem("1番サード岩鬼")    '……(1)'
    Debug.Print .Front.Value & " ～ "; .Rear.Value
    Debug.Print "===================="
    Call .addItem("2番セカンド殿馬")
    Debug.Print .Front.Value & " ～ "; .Rear.Value
    Debug.Print "===================="
    Call .addItem("3番レフト微笑")
    Debug.Print .Front.Value & " ～ "; .Rear.Value
    Debug.Print "===================="
    Call .addItem("4番キャッチャー山田")
    Debug.Print .Front.Value & " ～ "; .Rear.Value
    Debug.Print "===================="
    Dim i As Long    '……(2)'
    For i = 1 To 4
      Debug.Print "前から" & CStr(StrConv(i, vbWide)) & _
                  "番目のアイテムは、" & _
                  .Item(i).Value & "です。"
    Next
    Debug.Print "===================="    '……(3)'
    Do While .ItemExists    '……(4)'
      Debug.Print .removeItem.Value & " を削除しました。"
      Debug.Print "現在の保有アイテム数は、" & _
                  .Count & " 個です。"
    Loop
  End With
End Sub

(1)の

With strQueue
  Call .addItem("1番サード岩鬼")
  Debug.Print .Front.Value & " ～ "; .Rear.Value
  Debug.Print "===================="
  Call .addItem("2番セカンド殿馬")
  Debug.Print .Front.Value & " ～ "; .Rear.Value
  Debug.Print "===================="
  Call .addItem("3番レフト微笑")
  Debug.Print .Front.Value & " ～ "; .Rear.Value
  Debug.Print "===================="
  Call .addItem("4番キャッチャー山田")
  Debug.Print .Front.Value & " ～ "; .Rear.Value
End With

では、addItemメソッドを用いてアイテムを追加しつつ、そのたびに先頭のアイテムの値と最後尾のアイテムの値を出力。あと、アイテムごとに区切り線も追加している。

四つのアイテムを追加し終えると、(2)の

With strQueue
  Dim i As Long
  For i = 1 To 4
    Debug.Print "前から" & CStr(StrConv(i, vbWide)) & _
                "番目のアイテムは、" & _
                .Item(i).Value & "です。"
  Next
End With

で、先頭のアイテムから順に値を出力。

(3)の

Debug.Print "===================="

で区切りを入れて、あとは(4)の

With strQueue
  Do While .ItemExists
    Debug.Print .removeItem.Value & " を削除しました。"
    Debug.Print "現在の保有アイテム数は、" & _
                .Count & " 個です。"
  Loop
End With

で、アイテムのある限り先頭アイテムの値を出力し、そのたびに残りのアイテム数を出力する。

実行結果

リスト１の実行結果は

f:id:akashi_keirin:20191117155150j:plain

このとおり。

おわりに

実に面白い。

この要領で、たとえば、OrderdLinkedListも作ることができる。

速度面でどうなのかはわからないが。

クラスモジュールを用いたStackの改良

VBAクラス・モジュール VBA自作メソッド

クラスモジュールを用いたStackの改良

前回

akashi-keirin.hatenablog.com

の続き。

ちょっと改良した。

クラス名の見直し

StringStackオブジェクトの各要素がStackStringというのは、余りにもわかりにくすぎるので、StringStackItemに改めた。少し長くなるけど、この方がいい。Javaとかだったらもっとえげつなく長いクラス名とか普通にあるし。わかりやすさ優先。

あと、オレオレコーディング規約で、「プロパティはパスカル、メソッド名はキャメル」という謎ルールを課しているので、Pushメソッド、PopメソッドをそれぞれpushItem、popItemに改めた。

プロパティの追加

せっかくデータの集合なのに、データの総数がわからなかったり、○○個目のデータが参照できたりしないのでは不便（Popすると、値は得られるが消えてしまう。）。

そこで、アイテム総数を返すCountプロパティ、上から○○個目のアイテムを返すItemプロパティを追加した。

改良後のコード

クラスモジュール StringStack
Option Explicit

Private topItem As StringStackItem
Private count_ As Long    '……(1)'

Public Property Get Count() As Long  '……(2)'
  Count = count_
End Property

Public Property Get Top() As String
  If ItemExists Then
    Top = topItem.Value
  Else
    Top = ""
  End If
End Property

Public Property Get Item( _
            ByVal Index As Long) As String    '……(3)'
  Dim ret As StringStackItem
  If ItemExists Then    '……(4)'
    Set ret = topItem    '……(5)'
    If Index = 1 Then GoTo Finalizer
    Dim i As Long    '……(6)'
    For i = 2 To Index
      Set ret = ret.NextItem
    Next
  Else
    Set ret = Nothing
  End If
Finalizer:
  If ret Is Nothing Then Item = "": Exit Property
  Item = ret.Value
End Property

Public Property Get ItemExists() As Boolean
  ItemExists = Not (topItem Is Nothing)
End Property

Public Sub pushItem(ByVal argValue As String)
  Dim newTopItem As New StringStackItem
  newTopItem.Value = argValue
  Set newTopItem.NextItem = topItem
  Set topItem = newTopItem
  count_ = count_ + 1    '……(7)'
End Sub

Public Function popItem() As String
  Dim ret As Variant
  If Me.ItemExists Then
    ret = topItem.Value
    Set topItem = topItem.NextItem
    count_ = count_ - 1    '……(8)'
  End If
  popItem = ret
End Function

追加したのは、まず(1)の

Private count_ As Long

というモジュールレベル変数。こいつで、アイテム数を保持する。

(2)の

Public Property Get Count() As Long
  Count = count_
End Property

でCountプロパティを生やす。ReadOnly。

(3)の

Public Property Get Item( _
            ByVal Index As Long) As String
  Dim ret As StringStackItem
  If ItemExists Then    '……(4)'
    Set ret = topItem    '……(5)'
    If Index = 1 Then GoTo Finalizer
    Dim i As Long    '……(6)'
    For i = 2 To Index
      Set ret = ret.NextItem
    Next
  Else
    Set ret = Nothing
  End If
Finalizer:
  If ret Is Nothing Then Item = "": Exit Property
  Item = ret.Value
End Property

でItemプロパティを生やす。

引数Indexを受け取って、上からIndex番目のアイテムの値（String）を返す。

(4)の

If ItemExists Then

で条件分岐。アイテムがなかったら、Else節へ飛んで、retにNothingをセット。別に無くても良いけど、明示する。

アイテムがある場合は、(5)の

Set ret = topItem
If Index = 1 Then GoTo Finalizer

で、retに一番上に積まれているアイテムをセット。引数Indexが1だったら即Finalizerラベルへ飛び、値を返す。

Indexが2以上のときは、(6)の

Dim i As Long
For i = 2 To Index
  Set ret = ret.NextItem
Next

で、必要な回数だけNextItemを順に手繰っていって、目的のStringStackItemを取得する。

ちなみに、Indexに1未満の数やCountの値を超える数値が渡されたときの対応は未実装。

あと、(7)と(8)は、pushItem、popItemメソッド実行時にそれぞれcount_の値を増減しているだけ。

クラスモジュール StringStackItem
Option Explicit

Private value_ As String
Private nextItem_ As StringStackItem

Public Property Let Value(ByVal argValue As String)
  value_ = argValue
End Property
Public Property Get Value() As String
  Value = value_
End Property

Public Property Set NextItem(ByVal argItem As StringStackItem)
  Set nextItem_ = argItem
End Property
Public Property Get NextItem() As StringStackItem
  Set NextItem = nextItem_
End Property

こちらの方は変更なし。クラス名を変えただけ。

使ってみる

次のコードで実験。

リスト１　標準モジュール
Private Sub testStringStack()
  Dim strStack As New StringStack
  With strStack
    Debug.Print "現在の保有アイテム数は、" & .Count & " 個です。"
    Call .pushItem("1番サード岩鬼")
    Debug.Print .Top & " をPushしました。"
    Debug.Print "現在の保有アイテム数は、" & .Count & " 個です。"
    Call .pushItem("2番セカンド殿馬")
    Debug.Print .Top & " をPushしました。"
    Debug.Print "現在の保有アイテム数は、" & .Count & " 個です。"
    Call .pushItem("3番レフト微笑")
    Debug.Print .Top & " をPushしました。"
    Debug.Print "現在の保有アイテム数は、" & .Count & " 個です。"
    Call .pushItem("4番キャッチャー山田")
    Debug.Print .Top & " をPushしました。"
    Debug.Print "現在の保有アイテム数は、" & .Count & " 個です。"
    Debug.Print "===================="
    Dim i As Long
    For i = 1 To .Count
    Debug.Print "上から" & StrConv(CStr(i), vbWide) & "番目は、" & _
                .Item(i) & " です。"
    Next
    Debug.Print "===================="
    Do While .ItemExists
      Debug.Print .popItem & " をPopしました。"
      Debug.Print "現在の保有アイテム数は、" & .Count & " 個です。"
    Loop
  End With
End Sub

計四つのアイテムをPush。そのたびにアイテム数を出力。その後、アイテムを上から順に表示し、すべてのアイテムをPop。そのたびに残りアイテム数を表示する、というもの。

実行すると、

f:id:akashi_keirin:20191115080757j:plain

このとおり。

おわりに

実に面白い。

2019.11.16追記

改めて見直してみたら、ItemプロパティやpopItemメソッドがString型の値を返すというのはわかりにくい。素直にStringStackItemオブジェクトを返す方が、名前に合っているような気がする。

また、Topプロパティが値を返すのも変だ。StackオブジェクトのTopにあるのはStringStackItemオブジェクトなのだから、素直にStringStackItemオブジェクトを返す方が自然だ。

よって、次のように修正することにした。

クラスモジュール StringStack
Option Explicit

Private topItem As StringStackItem
Private count_ As Long

Public Property Get Count() As Long
  Count = count_
End Property

Public Property Get Top() As StringStackItem
  Dim ret As StringStackItem
  Set ret = Nothing
  If ItemExists Then Set ret = topItem
  Set Top = ret
End Property

Public Property Get Item( _
              ByVal Index As Long) As StringStackItem
  Dim ret As StringStackItem
  Set ret = Nothing
  'IndexがおかしかったらNothingを返す'
  If Index < 1 Then GoTo Finalizer
  If Index > Me.Count Then GoTo Finalizer
  'アイテムがあったら返す。なかったらNothing'
  If ItemExists Then
    Set ret = topItem
    If Index = 1 Then GoTo Finalizer
    Dim i As Long
    For i = 2 To Index
      Set ret = ret.NextItem
    Next
  Else
    Set ret = Nothing
  End If
Finalizer:
  Set Item = ret
End Property

Public Property Get ItemExists() As Boolean
  ItemExists = Not (topItem Is Nothing)
End Property

Public Sub pushItem(ByVal argValue As String)
  Dim newTopItem As New StringStackItem
  newTopItem.Value = argValue
  Set newTopItem.NextItem = topItem
  Set topItem = newTopItem
  count_ = count_ + 1
End Sub

Public Function popItem() As StringStackItem
  Dim ret As Variant
  If Me.ItemExists Then
    Set ret = topItem
    Set topItem = topItem.NextItem
    count_ = count_ - 1
  End If
  Set popItem = ret
End Function

ついでに、Indexプロパティに不正な値が渡されたときの対応も追加した。

本来エラーを投げるべきなんだろうけど、めんどくさいからNothingを返す仕様にした。

この変更により、Topプロパティ、Itemプロパティ、popItemメソッドの全てがStringStackItemオブジェクトを返すようになった。

それに伴い、テスト用コード（リスト１）も修正が必要。

リスト２　標準モジュール
Private Sub testStringStack()
  Dim strStack As New StringStack
  With strStack
    Debug.Print "現在の保有アイテム数は、" & .Count & " 個です。"
    Call .pushItem("1番サード岩鬼")
    Debug.Print .Top.Value & " をPushしました。"
    Debug.Print "現在の保有アイテム数は、" & .Count & " 個です。"
    Call .pushItem("2番セカンド殿馬")
    Debug.Print .Top.Value & " をPushしました。"
    Debug.Print "現在の保有アイテム数は、" & .Count & " 個です。"
    Call .pushItem("3番レフト微笑")
    Debug.Print .Top.Value & " をPushしました。"
    Debug.Print "現在の保有アイテム数は、" & .Count & " 個です。"
    Call .pushItem("4番キャッチャー山田")
    Debug.Print .Top.Value & " をPushしました。"
    Debug.Print "現在の保有アイテム数は、" & .Count & " 個です。"
    Debug.Print "===================="
    Dim i As Long
    For i = 1 To .Count
    Debug.Print "上から" & StrConv(CStr(i), vbWide) & "番目は、" & _
                .Item(i).Value & " です。"
    Next
    Debug.Print "===================="
    Do While .ItemExists
      Debug.Print .popItem.Value & " をPopしました。"
      Debug.Print "現在の保有アイテム数は、" & .Count & " 個です。"
    Loop
  End With
End Sub

ひつこいけれど、Topプロパティ、Itemプロパティ、popItemメソッドの全てがStringStackItemオブジェクトを返すので、その値が欲しいときはValueプロパティを参照する必要がある。

その分、少しコードの量は増えた。（Top.Valueなどという実に安っぽい記述が頻出することにもなったｗ）

もちろん、実行結果は上と同じ。

配列もCollectionも使わないデータ構造（Stack）

VBAクラス・モジュール VBA自作クラス VBA覚書

配列もCollectionも使わないデータ構造

久しぶりに

f:id:akashi_keirin:20191109220848j:plain

『VBA Developer's Handbook』を読んだ。

「Chapter 6」の「Creating Dynamic Data Structures Using Class Modules」のところに、実に面白いことが書いてあったので、やってみた。

Stackを二つのクラスモジュールで実現する

データの集合を取り扱う、となると、素人考えでは、配列を使う方法か、Collectionを使う方法しか思いつかない。

しかし、全然違うアプローチが説明されていたので、つい夢中で読んでしまった。英語苦手なくせに。

とりあえず、String型のデータを出し入れするStackを二つのクラスモジュールで実現する。

まず、クラスモジュールを二つ用意し、一方にはStringStack、もう一方にStackStringと名前をつける。

StringStackがStack全体、StackStringがStackに積まれている一つ一つの要素を表す。

クラスモジュール StringStack
Option Explicit

Private topItem As StackString

Public Property Get Top() As String
  If ItemExists Then
    Top = topItem.Value
  Else
    Top = ""
  End If
End Property

Public Property Get ItemExists() As Boolean
  ItemExists = Not (topItem Is Nothing)
End Property

Public Sub Push(ByVal argValue As String)
  Dim newTopItem As New StackString
  newTopItem.Value = argValue
  Set newTopItem.NextItem = topItem
  Set topItem = newTopItem
End Sub

Public Function Pop() As String
  Dim ret As Variant
  If Me.ItemExists Then
    ret = topItem.Value
    Set topItem = topItem.NextItem
  End If
  Pop = ret
End Function

まず、こちらはStack全体を表すStringStackクラス。

プロパティが二つ。

Topプロパティは、Stackのてっぺんに積んであるアイテムの値。今回はString型に限定している。

ItemExistsプロパティは、Stackにアイテムがあるかどうかを表す。

で、メソッドが二つ。

Pushメソッドは、新しいアイテムをStackのてっぺんに積む。

Popメソッドは、てっぺんにあるアイテムを除去するとともに、その値を取得する。

クラスモジュール StackString
Option Explicit

Private value_ As String
Private nextItem_ As StackString

Public Property Let Value(ByVal argValue As String)
  value_ = argValue
End Property
Public Property Get Value() As String
  Value = value_
End Property

Public Property Set NextItem(ByVal argItem As StackString)
  Set nextItem_ = argItem
End Property
Public Property Get NextItem() As StackString
  Set NextItem = nextItem_
End Property

こちらは、Stackに積まれているそれぞれのアイテムを表現するクラス。

Read/Writeのプロパティが二つ。

Valueプロパティは、アイテムの値。今回はString型に限定している。

NextItemプロパティは、自分自身の一つ下に積まれているアイテムを表す。

使ってみる

標準モジュールに次のようなコードを書いて、StringStackクラスを使ってみる。

リスト１　標準モジュール
Private Sub testStringStack()
  Dim strStack As New StringStack '……(1)'
  With strStack
    Call .Push("1番サード岩鬼")    '……(2)'
    Debug.Print .Top              '……(3)'
    Call .Push("2番セカンド殿馬")
    Debug.Print .Top
    Call .Push("3番レフト微笑")
    Debug.Print .Top
    Call .Push("4番キャッチャー山田")
    Debug.Print .Top
   Debug.Print "===================="  '……(4)'
    Do While .ItemExists          '……(5)'
      Debug.Print .Pop
    Loop
  End With
End Sub

まず、(1)の

Dim strStack As New StringStack

で、StringStackクラスのインスタンスを用意する。

その後、(2)の

With strStack
  Call .Push("1番サード岩鬼")
End With

で、Pushメソッドを用いて、「1番サード岩鬼」というデータ（笑）を持ったアイテム（StackStringオブジェクト）がStackに積まれる。

そうしておいて、(3)の

With strStack
  Debug.Print .Top
End With

で、Topプロパティの値を出力する。この時点でStackのてっぺんにあるアイテムの値は先ほどの「1番サード岩鬼」のはず。

同様に、二つ目、三つ目、四つ目のアイテムを追加していく。

ここで、一旦(4)の

Debug.Print "===================="

で、イミディエイト ウインドウに区切り線を入れる。

後は、(5)の

With strStack
  Do While .ItemExists
    Debug.Print .Pop
  Loop
End With

で、ItemExistsプロパティがFalseになるまで、すなわちStackに積まれたアイテムが無くなるまで、〈てっぺんのアイテムの値を出力＝てっぺんのアイテムを除去〉を繰り返す。

リスト１を実行すると、

f:id:akashi_keirin:20191109220856j:plain

Stackの場合、上へ上へと積み重ねたものを、上から順番に取り出すことになるので、こうなる。

おわりに

詳しい仕組みの説明は今のところ省略しますが、配列もCollectionも使わずに、データの集合を表現するって、何かスゴくないですか？

私はちょっと感動しています。

StackStringオブジェクトの内部にStackStringオブジェクトを持たせることによって、マトリョーシカ人形のような要領で複数のデータを数珠つなぎのように持たせる、ということなんですが、非常に面白いアイディアだと思います。

この調子で、Queueとか、OrderedLinkedListなんかも作っていくと、クラスモジュールの練習に良さそうです。