テキストボックス内のハイライト部分をそれぞれ配列に格納して、Collectionにする(Word)

WordVBA VBA自作クラス VBA自作メソッド

テキストボックス内のハイライト部分をそれぞれ配列に格納して、Collectionにする

意味の取りづらいタイトルですまない。

テキストボックス内のハイライト部分（Rangeオブジェクト）をテキストボックスごとに配列にして、それぞれの配列をCollectionにぶち込もう、ということ。

余計にわからなくなったとしたら申しわけない。

ハイライト部分を保持するクラス

なぜかクラスモジュールを使う。

クラス名は「HighLightedRange」にした。相変わらずクラスの命名のこつがわからない。

すでに作成済みのクラスモジュールのコードを全て載っけると異様に長くなるので、必要な部分のみ掲載する。

リスト１　クラスモジュール
'Variable'
Private ParentDoc_ As Document
Private HighLightedRangesInTextBox_ As Collection

'Properties'
Public Property Get ParentDoc() As Document
  Set ParentDoc = ParentDoc_
End Property
Public Property Get HighLightedRangesInTextBox() As Collection
  Set HighLightedRangesInTextBox = HighLightedRangesInTextBox_
End Property

'Constructor'
Private Sub Class_Initialize()
  Set ParentDoc_ = ActiveDocument
End Sub
Public Sub init(ByVal targetDocument As Document)
  Set ParentDoc_ = targetDocument
End Sub

'Methods'
Public Sub getHighLightedRangesInTextBox()
  Dim targetShape As Word.Shape
  'Collectionオブジェクトのインスタンスを準備'
  Set HighLightedRangesInTextBox_ = New Collection
  'Shapeオブジェクトを一つづつスキャン'
  For Each targetShape In ParentDoc_.Shapes
    Application.ScreenUpdating = False
    Dim ar() As Range
    Dim i As Long
    i = 0
    '捕まえたShapeオブジェクトがテキストボックスだったら処理'
    If targetShape.Type = msoTextBox Then
      'テキストボックスが文字列を持っていたら処理'
      If targetShape.TextFrame.HasText Then
        '一旦文字列全体を選択'
        targetShape.TextFrame.TextRange.Select
        '選択範囲を先頭方向に向って潰す'
        Call Selection.Collapse(Direction:=wdCollapseStart)
        'Findオブジェクトを初期化'
        Call resetFindObject(Selection.Find)
        '必要なプロパティを設定'
        Selection.Find.Highlight = True
        '検索実行'
        Call Selection.Find.Execute
        Do While Selection.Find.Found
          '配列の容量を拡張'
          ReDim Preserve ar(i)
          '現在の選択範囲を配列に格納'
          Set ar(i) = Selection.Range
          '変数をインクリメント'
          i = i + 1
          '現在の選択範囲を終端方向に潰す'
          Call Selection.Collapse(Direction:=wdCollapseEnd)
          '検索実行'
          '次のマッチ部分があれば、そこが選択状態になる'
          Call Selection.Find.Execute
        Loop
      End If
    End If
    '上のDoループで作成された配列をCollectionに追加'
    Call HighLightedRangesInTextBox_.Add(ar)
    Application.ScreenUpdating = True
  Next
End Sub
'Findオブジェクトのリセット用Privateメソッド'
Private Sub resetFindObject(ByRef targetFind As Find)
  With targetFind
    Call .ClearFormatting
    Call .Replacement.ClearFormatting
    .Text = ""
    .Replacement.Text = ""
    .Forward = True
    .Wrap = wdFindContinue
    .Format = False
    .Highlight = False
    .MatchCase = False
    .MatchWholeWord = False
    .MatchByte = False
    .MatchAllWordForms = False
    .MatchSoundsLike = False
    .MatchWildcards = False
    .MatchFuzzy = False
  End With
End Sub

コード中のresetFindObjectメソッドについては、

akashi-keirin.hatenablog.com

コチラをご覧ください。

getHighLightedRangesInTextBoxメソッドが、テキストボックスのハイライト部分を配列化→配列のコレクション化を行う。処理の内容については、コード中にかなり細かくコメントを入れたので、そちらをよく読んでくだされ。

簡単に説明すると、

akashi-keirin.hatenablog.com

コチラでご紹介したやり方でもって、テキストボックスの文字列の先頭にカーソルを置いて、あとは

akashi-keirin.hatenablog.com

コチラでご紹介したやり方でハイライト部分（Rangeオブジェクト）を配列にぶち込んでいっている。

このときと違うのは、さらにその配列をCollectionにぶち込んでいる、というだけ。

使ってみる

f:id:akashi_keirin:20190103203239j:plain

このように、テキストボックスを二つ設置したDocumentを用意して、次のコードを実行してみる。

リスト１　標準モジュール
Public Sub test()
  Dim highLightedRange_ As New HighLightedRange
  With highLightedRange_
    .getHighLightedRangesInTextBox
  End With
End Sub

もちろん、単にこのコードを実行しただけだと、表面上何も起こらない。

配列を作ってCollectionにぶち込んでいるだけだし、そのCollectionにしたところで、実行後は破棄されてしまうのだから。

従って、End Subのところにブレークポイントを設定してコードの実行を中断し、イミディエイト・ウインドウに次のように打ち込んで[Enter]し、変数の内容を調べてみる。

?highLightedRange_.HighLightedRangesInTextBox(1)(0).Text
?highLightedRange_.HighLightedRangesInTextBox(1)(1).Text
?highLightedRange_.HighLightedRangesInTextBox(1)(2).Text
?highLightedRange_.HighLightedRangesInTextBox(1)(3).Text
?highLightedRange_.HighLightedRangesInTextBox(2)(0).Text
?highLightedRange_.HighLightedRangesInTextBox(2)(1).Text

鋭い方なら三つ目と四つ目に「？」となるだろうが、実行結果を見てほしい。

実行結果

f:id:akashi_keirin:20190103203253j:plain

なぜか、このような結果になる。

一つ目のテキストボックスは、ハイライト箇所が２箇所しかないのに、その２箇所が二重に取得されてしまっている。

二つ目のテキストボックスはちゃんと取得されているのに。

なぜこうなるのか、全然わかりません。

おわりに

実は、今回のHighLightedRangeクラスに、次のメソッドを追加して、上記getHighLightedRangesInTextBoxメソッド実行後に実行すると、おかしなことが起こる。

toggleHighLightInTextBoxメソッド
Public Sub toggleHighLightInTextBox()
  Dim i As Long
  For i = 1 To HighLightedRangesInTextBox_.Count
    Dim j As Long
    For j = LBound(HighLightedRangesInTextBox_(i)) To _
            UBound(HighLightedRangesInTextBox_(i))
      With HighLightedRangesInTextBox_(i)(j)
        If .HighlightColorIndex = wdYellow Then
          .HighlightColorIndex = wdNone
        Else
          .HighlightColorIndex = wdYellow
        End If
      End With
    Next
  Next
End Sub

getHighLightedRangesInTextBoxメソッドで取得したRangeオブジェクト一つ一つのHighlightプロパティの値を調べて、必要に応じて設定し直すだけのしょうもないメソッドなのに、なぜかこれを実行すると、私の環境（Windows10 64Bit & Word2013 32Bit）ではWordが強制終了されてしまうのである。

しかも、Wordが自動的に再起動した後、標準モジュールやクラスモジュールの復元に失敗したらしく、間違えて上書き保存してしまってせっかく書いたコードが一度失われるという悲劇に……。

ホントにわけわかんないんですけど……。

転記用マクロをサクッと書いてみた(Excel)

ちょい書きマクロ

転記用マクロをサクッと書いてみた

Twitterで話題になっていたのでちょっと乗っかってみた。

転記処理は、基本的に各転記元のブックの方で、集計（積み上げ）対象のデータ（笑）だけを別シートに転記しておいて、集計（積み上げ）時には、そのシートのデータ（笑）をまるごと集計（積み上げ）用シートに積み上げていくことしかやったことがなかったので、ちょっと腕試しに……。

お題

  • 転記元のブックは複数ある（たぶん、ファイル名もでたらめ。）。
  • 転記元ブックのシートのデータ（笑）を全て転記するわけではなく、特定の条件に当てはまっている行のデータ（笑）のみ転記する。

だいたいこういう条件だと思った。

実験の準備

次のように、テスト用のデータ（笑）を準備した。

転記先ブックと転記元ブック

f:id:akashi_keirin:20190103175729j:plain

画像のように、フォルダ内に、転記先ブック一つと転記元ブック複数を用意した。

転記先ブック

f:id:akashi_keirin:20190103175737j:plain

転記先ブックには、このように項目のラベルだけを作った。

ファイル名が「★転記先ブック.xlsm」となっていることからお分かりのように、マクロはこのブックに書く。

転記元ブック

転記元ブックは、次のように複数準備した。

転記元01.xlsx

f:id:akashi_keirin:20190103175747j:plain

転記元02.xlsx

f:id:akashi_keirin:20190103175801j:plain

転記元03.xlsx

f:id:akashi_keirin:20190103175924j:plain

転記元04.xlsx

f:id:akashi_keirin:20190103180101j:plain

このように、実に詳細なデータ（笑）の入った四つのブックを用意した。あーしんど。

コーディング

とりあえず、再利用性や保守（保守は英語でメンテナンス）性は無視。心にうつりゆくよしなしコードを、そこはかとなく書きつけたものが次のコード。

リスト１　標準モジュール
Public Sub transferData()
  '転記先シートを変数にぶち込む'
  Dim mainSh As Worksheet
  Set mainSh = Sheet1
  '現在のフォルダパスを変数にぶち込む'
  Dim folderPath As String
  folderPath = ThisWorkbook.Path & "\"      '"
  '処理済みファイル用フォルダの準備'
  Dim saveFolder As String
  saveFolder = folderPath & "処理済み\"     '"
  '「処理済み」フォルダがなかったら作る'
  If Dir(saveFolder) = "" Then Call MkDir(saveFolder)
  '一つ目の転記元ブックのファイル名を取得'
  Dim targetFileName As String
  targetFileName = Dir(folderPath & "*.xlsx", vbNormal)
  '該当ファイルにヒットしなければ煽って終了ｗ'
  If targetFileName = "" Then _
    Call XlsCommon.makeUserSick("ファイルがないんじゃぼけー！"): _
    Exit Sub
  '転記先シートの転記対象行番号用変数の準備＆初期化'
  Dim n As Long 
  n = 2
  Do While targetFileName <> ""
    '転記元シートを取得して変数にぶち込む'
    Dim targetSh As Worksheet
    Set targetSh = Workbooks.Open(folderPath & targetFileName).Worksheets(1)
    '転記元シートのデータ（笑）最終行を取得'
    Dim maxRow As Long
    maxRow = targetSh.Cells(Rows.Count, 1).End(xlUp).Row
    '転記元シートをスキャン'
    Dim i As Long
    For i = 2 To maxRow
      With mainSh
        '条件に当てはまったら転記＆行番号用変数インクリメント'
        If targetSh.Cells(i, 7).Value = "先捲" Or _
           targetSh.Cells(i, 7).Value = "捲先" Then
          .Range(.Cells(n, 1), .Cells(n, 8)).Value = _
            targetSh.Range(targetSh.Cells(i, 1), targetSh.Cells(i, 8)).Value
          n = n + 1
        End If
      End With
    Next
    '転記元ブックを保存せずに閉じる'
    Call targetSh.Parent.Close(SaveChanges:=False)
    '「処理済み」フォルダへ移動'
    Name folderPath & targetFileName As _
         saveFolder & targetFileName
    '次の転記元ブックのファイル名を取得'
    targetFileName = Dir()
  Loop
  'データ（笑）の範囲に格子罫線を施す'
  mainSh.Range("A1").CurrentRegion.Borders.LineStyle = xlContinuous
End Sub

処理の手順は全てコード中にコメントで記した。転記元の表のデータ（笑）の中から、「戦法」が「先捲」か「捲先」の行のデータ（笑）だけを転記先ブックに積み上げていくマクロ。我ながらReadableなコードだとｑあｓうぇｄｒｆｔｇｙふじこｌｐ……あっ、物を投げないでくださいよ！

そうそう、コード中のXlsCommon.makeUserSickメソッドについては、

akashi-keirin.hatenablog.com

コチラをどうぞ。

実行してみる

「★転記先ブック.xlsm」だけを開いた状態で実行。

まず、

f:id:akashi_keirin:20190103180009j:plain

フォルダ内に「処理済み」フォルダが生成され、

f:id:akashi_keirin:20190103175942j:plain

画面がボカチカチカチカした後、転記が完了。

ちなみに、「処理済み」フォルダ内は、

f:id:akashi_keirin:20190103180134j:plain

こんな感じ。

おわりに

コードそのものをもっとReadableにする手はあるし、エラー対応もほとんど考えていないコードだけれど、即興だったらこんなもんかなあ。

ちなみに、フォルダ内に処理対象ブック（っていうか、.xlsxファイル）がない場合にこのマクロを実行すると、

f:id:akashi_keirin:20190103183903j:plain

こうなりますｗ

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

WordVBA

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

Documentオブジェクトの場合

Documentオブジェクトの先頭位置にカーソルを置くのは簡単。

Document.Range(0, 0).Select

とすれば、ドキュメントの先頭位置にカーソルを置くことができる。

テキストボックスの場合

ところが、テキストボックスの場合、Rangeメソッドを持つオブジェクトが見当たらない（ですよね？）ので、そもそも

Object.Range(0, 0)

で先頭位置のRangeオブジェクトを取得することができない。

テキストボックスはWord.Shapeオブジェクト。テキストボックスに書き込まれたテキストを取得するには、

Document.TextFrame.TextRange.Text

と、非常に多くの階層をたどる必要がある。

「TextRange」というのがRangeオブジェクトを返しそうな名前のプロパティなので調べてみると、確かにRangeオブジェクトを返すらしい。

で、イミディエイト・ウインドウに、次のように打ち込んで[Enter]してみる。

ActiveDocument.TextFrame.TextRange.Select

f:id:akashi_keirin:20190101193113j:plain

このように、テキストボックス内のすべてのテキストが選択された。

これにCollapseメソッドを組み合わせたら、カーソルを先頭に置くことは可能だろう。

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

リスト１　標準モジュール
Public Sub test()
  ActiveDocument.Shapes(1).TextFrame.TextRange.Select
  Call Selection.Collapse(Direction:=wdCollapseStart)
End Sub

選択範囲を、開始位置方向に向けて潰す、といったイメージのコード。

TextFrameオブジェクトの段階でRangeメソッド使わせてくれたらいいのに……。

こいつを実行すると、

f:id:akashi_keirin:20190101193123j:plain

わかりづらい画像ですまない。

カーソルが先頭に来ている。

これで、Findオブジェクトを使って検索することができる。

配列を配列の要素にする

VBA覚書

配列の配列を作ってみる

配列の要素を配列にすることはできるのか。

やってみた。

準備

Split関数をラップしたFunctionを作って、簡単にString型の配列を作れるようにした。

リスト１　標準モジュール
Private Function setArray( _
                   ByVal spaceSeparatedWords As String) _
                                                As String()
  Dim ar As Variant
  ar = Split(spaceSeparatedWords)
  setArray = ar
End Function

単語ごとに半角スペースで区切った文字列を渡したら、それらの単語を格納した配列を返すFunction。

配列を返り値として受け取るときのルールがイマイチよくわかっとらんので、たぶん変なことをしているのだと思う。

これで準備はおしまい。

配列を配列にぶちこんでみる

次のようなコードで実験してみた。

リスト２　標準モジュール
Public Sub test()
  Dim ar1() As String    '……(1)'
  ar1 = setArray("アホ ボケ カス")
  Dim ar2() As String
  ar2 = setArray("クズ ドロボー ロクデナシ")
  Dim ar3() As String
  ar3 = setArray("デコスケ ボーフラ ウジムシ")
  Dim ars(2) As Variant    '……(*)'
  ars(0) = ar1    '……(2)'
  ars(1) = ar2
  ars(2) = ar3
  Dim i As Long    '……(3)'
  Dim j As Long
  For i = 0 To 2
    For j = 0 To 2
      Debug.Print ars(i)(j)
    Next
    Debug.Print String(10, "=")
  Next
End Sub

(*)のところでは、

Dim ars(2) As String

とすると、「型が一致しません」エラーになる。

ぶち込みたいのはString型の値なのではなく、String型の配列なのだから当り前だ。

かといって、

Dim ars(2) As String()

としたのではもっとダメ。そもそもコンパイルが通らない。

そんなわけで、今のところVariantにしている。

見てもらったらわかると思うけれど、(1)からの６行

Dim ar1() As String    '……(1)'
ar1 = setArray("アホ ボケ カス")
Dim ar2() As String
ar2 = setArray("クズ ドロボー ロクデナシ")
Dim ar3() As String
ar3 = setArray("デコスケ ボーフラ ウジムシ")

では、「ar1」、「ar2」、「ar3」というString型の配列を作っている。

それを(2)からの３行

ars(0) = ar1
ars(1) = ar2
ars(2) = ar3

でVariant型の配列にぶち込んでいる。

あとは、(3)からの８行

Dim i As Long
Dim j As Long
For i = 0 To 2
  For j = 0 To 2
    Debug.Print ars(i)(j)
  Next
  Debug.Print String(10, "=")
Next

の二重Forループで、それぞれの配列の値をイミディエイト・ウインドウに出力する。

実行結果

f:id:akashi_keirin:20190101174222j:plain

ご覧の通り。

配列に配列をぶち込むことも可能。

さて、どんな用途があるのかのう……。

Findオブジェクトの設定をリセットするメソッド

f:id:akashi_keirin:20190101084110j:plain

Findオブジェクトの設定をリセットするメソッド

このとき

akashi-keirin.hatenablog.com

のリスト１で、Document内の黄色蛍光マーカ位置をRange配列として返すメソッドを作った。

その中で、Findオブジェクトを初期設定する部分、すなわち、

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

この部分が異様にタテ長で気に入らなかった。

Findオブジェクトを利用するたびに、こんなタテ長のブロックをいちいち書く（コピペする）となると非常にめんどくさい。

そこで、

  • 一旦Findオブジェクトを初期化する
  • 必要なプロパティのみ再設定する

というやり方を考えた。

Findオブジェクトを初期化するメソッド

上掲のリスト１では、「蛍光マーカ」の有無を表すプロパティ（Highlight）のみTrueにしていた。蛍光マーカの有無だけを調べたかったのでそうしている。つまり、それ以外は初期設定だとみなせるということ。したがって、HighlightプロパティをFalseにしておけば、まさに初期化状態、ということだ。

リスト２　標準モジュール
Public Sub resetFindObject(ByRef targetFind As Find)
  With targetFind
    .ClearFormatting
    .Replacement.ClearFormatting
    .Text = ""
    .Replacement.Text = ""
    .Forward = True
    .Wrap = wdFindContinue
    .Format = False
    .Highlight = False
    .MatchCase = False
    .MatchWholeWord = False
    .MatchByte = False
    .MatchAllWordForms = False
    .MatchSoundsLike = False
    .MatchWildcards = False
    .MatchFuzzy = False
  End With
End Sub

Findオブジェクトを返すFunctionにすることも考えたが、返り値のFindオブジェクトをSelection.Findにセットするというのがよくわからなかったので、ByRef指定で直接Findオブジェクトを書き換える形にした。

このメソッドに一旦Selection.Findオブジェクトを渡してFindオブジェクトを書き換えておき、その後で、設定したいプロパティだけ設定すればよい。

前回のコードの修正

というわけで、前回のコードを修正してみる。

修正前
Public Function getHighLightedRange( _
         ByVal targetDocument As Document) As Range()
  Application.ScreenUpdating = False
  Dim targetRange As Range
  Set targetRange = Selection.Range
  Call targetDocument.Range(0, 0).Select
  Call Selection.Find.ClearFormatting
  Call Selection.Find.Replacement.ClearFormatting
  With Selection.Find
    .Text = ""
    .Replacement.Text = ""
    .Forward = True
    .Wrap = wdFindContinue
    .Format = False
    .Highlight = True
    .MatchCase = False
    .MatchWholeWord = False
    .MatchByte = False
    .MatchAllWordForms = False
    .MatchSoundsLike = False
    .MatchWildcards = False
    .MatchFuzzy = False
  End With
  Call Selection.Find.Execute
  Dim ar() As Range
  Dim i As Long
  i = 0
  Do While Selection.Find.Found
    ReDim Preserve ar(i)
    Set ar(i) = Selection.Range
    i = i + 1
    Call Selection.Collapse(Direction:=wdCollapseEnd)
    Call Selection.Find.Execute
  Loop
  Call targetRange.Select
  getHighLightedRange = ar
  Application.ScreenUpdating = True
End Function

で、お次が修正後。

修正前
Public Function getHighLightedRange( _
         ByVal targetDocument As Document) As Range()
  Application.ScreenUpdating = False
  Dim targetRange As Range
  Set targetRange = Selection.Range
  Call targetDocument.Range(0, 0).Select
  Call resetFindObject(Selection.Find)    '……(1)'
  Selection.Find.Highlight = True    '……(2)'
  Call Selection.Find.Execute
  Dim ar() As Range
  Dim i As Long
  i = 0
  Do While Selection.Find.Found
    ReDim Preserve ar(i)
    Set ar(i) = Selection.Range
    i = i + 1
    Call Selection.Collapse(Direction:=wdCollapseEnd)
    Call Selection.Find.Execute
  Loop
  Call targetRange.Select
  getHighLightedRange = ar
  Application.ScreenUpdating = True
End Function

(1)の

Call resetFindObject(Selection.Find)

でFindオブジェクトを初期化し、

(2)の

Selection.Find.Highlight = True

でHighlightプロパティのみ設定。

あのくっそ長かったFindオブジェクト準備用コードがすっげー短くなった。

おわりに

これでより一層Findオブジェクトが使いやすくなったなあ。

Document.ShapeオブジェクトのNameプロパティとは何なのか(Word)

WordVBA

Document.ShapeオブジェクトのNameプロパティとは何なのか

ちょっと意味がわからない現象に気づいたので、記しておく。

二つのテキストボックス

WordのDocumentに二つテキストボックスを設置してみる。

f:id:akashi_keirin:20181231205022j:plain

こんな感じ。

んで、次のようなコードを実行してみる。

リスト１　標準モジュール
Public Sub test()
  Dim shp As Word.Shape
  For Each shp In ActiveDocument.Shapes
    Debug.Print shp.Name
  Next
End Sub

ActiveDocumentにあるShapesコレクション（今回の場合だとテキストボックス二つのこと。）の要素であるShapeオブジェクト（つまりは、二つのテキストボックスそれぞれ）のNameプロパティの値をイミディエイト・ウインドウに出力するだけの簡単なコード。

さて、このコードの実行結果はどうなるか。

f:id:akashi_keirin:20181231205044j:plain

こうなるんである。

なぜか、どちらも「テキスト ボックス 2」。なんでやねん。

インデックスで指定してみる

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

ActiveDocument.Shapes(1).Select

と打ち込んで[Enter]してみる。すると、

f:id:akashi_keirin:20181231205112j:plain

こうなる。納得の結果。

次に、同じようにイミディエイト・ウインドウに

ActiveDocument.Shapes(2).Select

と打ち込んで[Enter]してみる。

f:id:akashi_keirin:20181231205132j:plain

こうなる。これまた至極当然の結果。

では、

ActiveDocument.Shapes("テキスト ボックス 2").Select

とイミディエイト・ウインドウに打ち込んで[Enter]するとどうなるか。

f:id:akashi_keirin:20181231205158j:plain

こうなるのである。

？？？

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

ActiveDocument.Shapes("テキスト ボックス 1").Select

と入力して[Enter]。

これはさすがに実行時エラーになると思った。しかし、

f:id:akashi_keirin:20181231205234j:plain

なぜかエラーが出ずに、さっきと全く同じ結果になった。

おわりに

二つ目のテキストボックスは、一つ目のテキストボックスをコピーしたものなので、同じ名前になってしまったのだろうか？　つまり、

  1. 一つ目のテキストボックスを挿入する。名前は「テキスト ボックス 1」。
  2. 一つ目のテキストボックスをコピーして二つ目のテキストボックスが生まれる。
  3. 二つ目のテキストボックスに名前「テキスト ボックス 2」が付与される。
  4. しかし、両者は同じものなので、一つ目のテキストボックスの名前も見かけ上「テキスト ボックス 2」になってしまう。
  5. ただし、元の名前「テキスト ボックス 1」は完全に消滅したわけではない。

こんなわけのわからないことになっているのだろうか？？？

わからんなあ。

IE操作のためのクラスを作った

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

クラスにしてしまったのでぶちまけておく

f:id:akashi_keirin:20181229210153p:plain

職場のクソWebアプリの攻略の過程で色んなメソッドを作ったので、無駄にクラス化しておいた。

思いつきを行き当たりばったりで形にしただけなので、ツッコミどころはたくさんあると思う。

複数インスタンスを作るシチュエーションも思い浮かばないので、もしかしたらAttribute VB_PredeclaredIdをTrueにしてもいいかもしれない。

いちいち手入れするのもめんどくさいので、ソースコードをそのままぶちまけておく。

どうせ一般ウケは狙ってないし。（←負け惜しみｗ）

WebAppクラス

リスト１　クラスモジュール

オブジェクト名を「WebApp」としています。

Option Explicit

Private Declare Function GetTickCount Lib "kernel32" () As Long
Private Declare Sub Sleep Lib "kernel32" (ByVal dwMilliseconds As Long)

Private GotIE_ As InternetExplorer
Private CurrentDocument_ As HTMLDocument

Public Property Get GotIE() As InternetExplorer
  Set GotIE = GotIE_
End Property

Public Property Get CurrentDocument() As HTMLDocument
  On Error Resume Next
    Set CurrentDocument = GotIE_.Document
    If Err.Number > 0 Then Set CurrentDocument = Nothing
  On Error GoTo 0
End Property

Public Property Get PageHTMLSource() As String
  Dim ret As String
  On Error Resume Next
    ret = Me.getHTMLSource
  On Error GoTo 0
  PageHTMLSource = ret
End Property

Private Sub Class_Initialize()
  Set GotIE_ = New InternetExplorer
End Sub

Private Sub Class_Terminate()
  Set GotIE_ = Nothing
  Set CurrentDocument_ = Nothing
End Sub

Public Sub init(ByVal targetURL As String)
  '擬似コンストラクタ'
  With GotIE_
    .Visible = True
    Call .Navigate(targetURL)
    Do While .Busy Or .ReadyState <> READYSTATE_COMPLETE
      DoEvents
    Loop
    Call waitFor(2000)
  Set CurrentDocument_ = .Document
  End With
End Sub

Public Function getIEByTitle( _
                  ByVal titleKeyWord As String) As InternetExplorer
'タイトルにキーワードを含むページを表示中のIEを取得するメソッド'
  Dim shellApp As New Shell
  Dim shellWin As Object
  For Each shellWin In shellApp.Windows
    If shellWin.Name = "Internet Explorer" Then
      On Error Resume Next
      If InStr(1, shellWin.Document.Title, titleKeyWord) > 0 Then
        Set GotIE_ = Nothing
        Set GotIE_ = shellWin
        Exit For
      End If
      On Error GoTo 0
    End If
  Next
  If GotIE_ Is Nothing Then Exit Function
  Set getIEByTitle = GotIE_
  Set shellApp = Nothing
  Set shellWin = Nothing
End Function

Public Function getIEByURL( _
                  ByVal targetURLKey As String) As InternetExplorer
'URLのキーワードが一致するページを表示中のIEを取得するメソッド'
  Dim shellApp As New Shell
  Dim shellWin As Object
  For Each shellWin In shellApp.Windows
    If shellWin.Name = "Internet Explorer" Then
      On Error Resume Next
      If InStr(1, shellWin.Document.URL, targetURLKey) > 0 Then
        Set GotIE_ = shellWin
        Exit For
      End If
      On Error GoTo 0
    End If
  Next
  If GotIE_ Is Nothing Then Exit Function
  Set getIEByURL = GotIE_
  Set shellApp = Nothing
  Set shellWin = Nothing
End Function

Public Function isTargetPage( _
                  ByVal pageTitleKeyWord As String) As Boolean
'ページタイトルにキーワードを含んでいるか判定するメソッド'
  isTargetPage = True
  On Error Resume Next
  If InStr(1, Me.CurrentDocument.Title, pageTitleKeyWord) > 0 Then _
    Exit Function
  On Error GoTo 0
  isTargetPage = False
End Function

Public Function getElementByTagAndKeyWord( _
                  ByVal targetTagName As String, _
                  ByVal targetKeyWord As String) As Object
'タグ名とキーワードを要素内の文字列に持つ要素を取得するメソッド'
  Dim ret As Object
  Set ret = Nothing
  With Me.CurrentDocument
    Dim targetElement As Object
    For Each targetElement In .getElementsByTagName(targetTagName)
      If InStr(1, targetElement.outerHTML, targetKeyWord) > 0 Then
        Set ret = targetElement
        Exit For
      End If
    Next
  End With
  Set getElementByTagAndKeyWord = ret
End Function

Public Function getHTMLSource() As String
'表示中のHTMLドキュメントのソースを取得するメソッド'
  Dim ret As String
  ret = ""
  On Error Resume Next
  ret = GotIE_.Document.all(0).outerHTML
  On Error GoTo 0
  getHTMLSource = ret
End Function

Public Sub createSourceHTMLFile(ByVal fileFullName As String)
'表示中のページのHTMLソースをファイルとして出力するメソッド'
  Dim n As Long
  n = FreeFile(0)
  Open fileFullName For Output As n
    Print #n, Me.PageHTMLSource & vbCrLf
  Close #n
End Sub

Public Sub Quit()
'IEを終了するメソッド'
  GotIE_.Quit
End Sub

Private Sub waitFor(ByVal milliSeconds As Long)
'待ち時間設定用メソッド'
'内部処理専用'
  Dim startTime As Long
  startTime = GetTickCount
  Do While (GetTickCount - startTime) < milliSeconds
    DoEvents
    Call Sleep(1)
  Loop
End Sub

各メソッドの機能は、コード中のコメントをどうぞ。（なげやり）

使ってみる

WebAppクラスを、次のコードで利用してみる。

リスト２　標準モジュール
Public Sub disposable03()
  Dim webApp_ As New WebApp
  With webApp_
    '最初のページに移動する'
    Call .init("http://akashi-keirin.hatenablog.com/entry/2018/12/16/001606")
    '最初のページのHTMLソースを出力する'
    Call .createSourceHTMLFile(ThisWorkbook.Path & "\「マーカ部分を……」_src.html")
    '「検索」ボックスに「ち～んｗ」を入力する'
    Dim targetTextBox As HTMLInputElement
    On Error Resume Next
    Do
      Err.Clear
      Set targetTextBox = .getElementByTagAndKeyWord("input", "name=""q""")
      targetTextBox.Value = "ち～んｗ"
    Loop Until Err.Number = 0
    '検索実行ボタンをクリックする'
    Dim targetButton As HTMLInputButtonElement
    Set targetButton = .getElementByTagAndKeyWord("input", "value=""検索""")
    targetButton.Click
    Call WindowsAPI.waitFor(5000)
    'ページが取得できているかどうか試行錯誤する'
    Dim n As Long
    n = 1
    Do
      DoEvents
      Call WindowsAPI.waitFor(1000)
      If n > 2 Then _
        Call .getIEByTitle("ち～んｗ")
      Debug.Print "Wait " & n & " 回目：" & .CurrentDocument.Title
      n = n + 1
      If n > 5 Then .Quit: Exit Do
    Loop Until .isTargetPage("ち～んｗ")
  End With
  '移動後のページのHTMLソースを出力する'
  Call webApp_.createSourceHTMLFile( _
         ThisWorkbook.Path & "\「ち～んｗ」の検索結果_src.html")
  'メッセージを表示してすべてを終わらせる'
  Debug.Print "終了"
  webApp_.Quit
  Set webApp_ = Nothing
  Set targetTextBox = Nothing
  Set targetButton = Nothing
End Sub

それぞれのセクションで何をやっているのかは、コード中のコメントをどうぞ。（なげやり）

おわりに

ひとまず、これだけの機能があれば、うちの職場のクソWebアプリには圧勝できる。

参考

akashi-keirin.hatenablog.com

akashi-keirin.hatenablog.com

akashi-keirin.hatenablog.com

akashi-keirin.hatenablog.com

akashi-keirin.hatenablog.com

akashi-keirin.hatenablog.com

akashi-keirin.hatenablog.com