検索の速度を測ってみた

検索の所要時間を調べた

ちょっと興味があったので、調べてみた。

f:id:akashi_keirin:20190114223859j:plain

このように、10001000列目のセル、すなわちALL1000セルに「ち~んw」という値(笑)を入力したシートを準備する。

で、この「ち~んw」を検索するのにどのぐらい時間がかかるものなのか、測ってみたわけである。

検索方法

私は所詮素人なので、次の三つの方法を用いた。

  1. 1000×1000のセル範囲のセルのValueプロパティを一つ一つ調べる方式
  2. 1000×1000のセル範囲のRangeオブジェクトのValueプロパティの値を一旦二次元配列にぶち込んで、同じく一つ一つ調べる方式
  3. 1000×1000のセル範囲に対してExcelFindメソッドを使う方式

以上三つである。

実験用のコード

下記のコードを用いる。

時間計測用に、自作のWindowsAPIクラスを用いているが、これについては、

akashi-keirin.hatenablog.com

コチラをどうぞ。WindowsAPI.callGetTickCountメソッドというのは、WindowsAPIのGetTickCountを利用するメソッドです。

リスト1 標準モジュール
'エントリポイント。'
Public Sub testSearch()
  '自作WindowsAPIクラスのインスタンスを用意。'
  Dim winAPI As New WindowsAPI

  'セルを一つ一つ巡回する方式の時間を表示する。'
  Dim startTime As Long
  startTime = winAPI.callGetTickCount
  Dim ret As Boolean
  ret = testSearchByNormalForLoop
  Dim elapsedTime As Double
  elapsedTime = winAPI.callGetTickCount - startTime
  Call showResult(ret, "testSearchByNormalForLoop", elapsedTime)

  '二次元配列にぶち込んで一つ一つ巡回する方式の時間を表示する。'
  startTime = winAPI.callGetTickCount
  ret = testSearchBy2DimensionArray
  elapsedTime = winAPI.callGetTickCount - startTime
  Call showResult(ret, "testSearchBy2DimensionArray", elapsedTime)

  'ExcelのFindメソッドを使う方式の時間を表示する。'
  startTime = winAPI.callGetTickCount
  ret = testSearchByFindMethod
  elapsedTime = winAPI.callGetTickCount - startTime
  Call showResult(ret, "testSearchByFindMethod", elapsedTime)
End Sub

'計測結果を表示するためのメソッド。'
Private Sub showResult(ByVal isSuccessed As Boolean, _
                       ByVal methodName As String, _
                       ByVal elapsedTime As Double)
  Debug.Print methodName & " の結果:"
  If isSuccessed Then
    Debug.Print "「ち~んw」を みつけた!"
  Else
    Debug.Print "見つけられなかった……。"
  End If
  Debug.Print elapsedTime / 1000 & "秒かかった!"
  Debug.Print String(20, "=")
End Sub

'セルを一つ一つ巡回する方式。'
Public Function testSearchByNormalForLoop() As Boolean
  Dim ret As Boolean
  ret = False
  Dim sh As Worksheet
  Set sh = ActiveSheet
  Dim r As Long
  Dim c As Long
  For r = 1 To 1000
    For c = 1 To 1000
      If sh.Cells(r, c).Value = "ち~んw" Then _
        ret = True: Exit For
    Next
  Next
  If ret Then testSearchByNormalForLoop = True
End Function

'一旦二次元配列にぶち込んで一つ一つ巡回する方式。'
Public Function testSearchBy2DimensionArray() As Boolean
  Dim ret As Boolean
  ret = False
  Dim sh As Worksheet
  Set sh = ActiveSheet
  Dim rng As Range
  With sh
    Set rng = .Range(.Cells(1, 1), _
                     .Cells(1000, 1000))
  End With
  Dim ar As Variant
  ar = rng.Value
  Dim r As Long
  Dim c As Long
  For r = 1 To 1000
    For c = 1 To 1000
      If ar(r, c) = "ち~んw" Then _
        ret = True: Exit For
    Next
  Next
  If ret Then testSearchBy2DimensionArray = True
End Function

'ExcelのFindメソッドを使う方式。'
Public Function testSearchByFindMethod() As Boolean
  Dim ret As Boolean
  ret = False
  Dim sh As Worksheet
  Set sh = ActiveSheet
  Dim rng As Range
  With sh
  Set rng = .Range(.Cells(1, 1), _
                   .Cells(1000, 1000)).Find(what:="ち~んw")
  End With
  If Not rng Is Nothing Then ret = True
  testSearchByFindMethod = ret
End Function

処理内容はコード内のコメントの通り。行数の割に中身はないw

実行結果

f:id:akashi_keirin:20190114223921j:plain

ご覧の通り。

1000×1000のセル範囲のセルのValueプロパティを一つ一つ調べる方式

4.016秒。

1000×1000のセル範囲のRangeオブジェクトのValueプロパティの値を一旦二次元配列にぶち込んで、同じく一つ一つ調べる方式

0.235秒。

1000×1000のセル範囲に対してExcelFindメソッドを使う方式

0.015秒。

なんと、まさにケタ違い。

ちょっとビックリの結果。

まあ、一つ目、二つ目については、一番時間がかかるところに値(笑)を配置するという意地悪な実験なんですが。

しかし、こうなると、ExcelFindメソッドの実装がどうなっとるのか、非常に気になるのであります。

乱数を作るクラスを改良した

乱数を作るクラス

ランダムに並べ替える作業というのは滅多にないのだけれど、絶妙に忘れかけた頃に発生するので、

akashi-keirin.hatenablog.com

このときにクラスまで作っていた。

んで、改めて見直してみたら、イマイチやなあ、と(笑)。

そんなわけで、作り直してみた。

乱数を作るクラスの改良

前に作ったやつは、あくまでも「1~最大数」をランダムに並べ替えるというだけだった。

そこで、今回は、

  1. 最小値と最小値を指定できるようにする
  2. 素数を指定できるようにする

の2点を追加することにした。

あと、クラス名とか変数名、プロパティ名も大幅に見直した。

コード

さっそく、クラスモジュールのコードを示す。

クラス名は「RandomNumbers」に変えた。

リスト1 クラスモジュール
Option Explicit

'Variables'
Private Item_() As Long
'Properties'
Public Property Get Item(ByVal i As Long) As Long
  Item = Item_(i)
End Property
Public Property Get Count() As Long
  Count = UBound(Item_) + 1
End Property
'Constructor'
Private Sub Class_Initialize()
  ReDim Item_(0)
  Item_(0) = 1
End Sub
'Methods'
Public Sub setRandomNumbers(ByVal maxNum As Long, _
                            ByVal countOfElements As Long, _
                   Optional ByVal minNum As Long = 1, _
                   Optional ByVal hasDuplicate As Boolean = False)
'///minNum~maxNumまでの整数をランダムに並べて配列に格納する。'
'///引数maxNum:最大数'
'///引数countOfElements:出来上がりの要素数'
'///引数minNum:最小数'
'///引数hasDuplicate:重複を許可するならTrue'
'///ただし、要素数が数値の種類数(maxNum-minNum+1)より大きいときは、'
'///Falseが渡されてもTrueに変える。'
  If countOfElements > maxNum - minNum + 1 Then _
    hasDuplicate = True
  Dim isUsed() As Boolean
  ReDim isUsed(countOfElements - 1)
  Dim i As Long
  ReDim Item_(countOfElements - 1)
  Randomize
  Dim tmp As Long
  For i = 0 To countOfElements - 1
    Do
      tmp = Int((maxNum - minNum + 1) * Rnd + minNum)
    '///乱数:Int((最大値 - 最小値 + 1) * Rnd + 最小値)'
    Loop Until isUsed(tmp - minNum) = False
    Item_(i) = tmp
    If Not hasDuplicate Then isUsed(tmp - minNum) = True
  Next
End Sub

まあ、大枠では変えていないので、説明は省略w

使ってみる

次のコードで実験。

スト2 標準モジュール
Public Sub testRandomNumbers()
  Dim rndNums As New RandomNumbers
  With rndNums
    Call .setRandomNumbers(10, 10, 1, False)  '……(1)'
    Dim i As Long
    For i = 0 To .Count - 1
      Debug.Print .Item(i)
    Next
    Debug.Print String(5, "=")
    Call .setRandomNumbers(20, 20, 11, True)  '……(2)'
    For i = 0 To .Count - 1
      Debug.Print .Item(i)
    Next
  End With
End Sub

setRandomNumbersメソッドを2回呼び出して、それぞれ取得したランダムな数列をイミディエイトに書き出すだけのコード。

(1)の

Call .setRandomNumbers(10, 10, 1, False)

では、

最大値10(第1引数)、最小値1(第3引数)で、重複を許さず(第4引数)に、ランダムに並べた10個(第2引数)の数字を得ることになる。

同様に、(2)の

Call .setRandomNumbers(20, 20, 11, True)

では、

最大値20(第1引数)、最小値11(第3引数)で、重複を許して(第4引数)、ランダムに並べた20個(第2引数)の数字を得ることになる。

ちなみに、(2)で

Call .setRandomNumbers(20, 20, 11, False)

と、第4引数をFalseにしたとしても、setRandomNumbersメソッド内部でTrueに変えるようにしてある。(リスト1参照)

これは、たとえば「15を重複しないようにランダムに10個並べろ!」とか言われても、

そんなの、デキッコナイス

となるに決まっているからである。

実行結果

f:id:akashi_keirin:20190113221436j:plain

この通り。

うまくいっている。

おわりに

これに、あとひと工夫すれば、

f:id:akashi_keirin:20190113221507j:plain

こんなふうに、記号をランダムに散らす、といったことに使えます。

学校の先生なんかが、記号式のテスト問題の解答をテキトーに散らすのに使えるんじゃないですかね。

あとは、競輪の出目予想とかw

自作WindowsAPIクラスにユーザが選択したフォルダのパスを返すFunctionを追加した


ユーザが選択したフォルダのパスを取得するFunction

相変わらず、WindowsAPIにハマっている。

今回も、名著『大村あつしのExcel VBA Win64/32 API プログラミング』を参考に、おなじみ、自作WindowsAPIクラスにメソッドを追加する。

akashi-keirin.hatenablog.com

このときにも書いたが、クラスモジュールWindowsAPIの他に、標準モジュールWinAPIEnums参考)を使う。

列挙体だけでなく、構造体や定数の宣言用に使うことにした。今さらながら、WinAPIConstantsとでもしておけば良かった……。これは今後変更するかも知れぬ。

では早速。

ちなみに、今回参考にしたのは、

f:id:akashi_keirin:20190105203721j:plain

我らが教科書『大村あつしのExcel VBA Win64/32 API プログラミング』の130~137ページです。

構造体と定数の宣言

今回使用するWindowsAPI関数は、

  1. FindWindow関数
  2. SHBrowseForFolder関数
  3. SHGetPathFromIDList関数
  4. CoTaskMemFree関数

の四つ。

このうち、FindWindow関数は、すでに

akashi-keirin.hatenablog.com

このときに使用済み。

これらの関数のうち、SHBrowseForFolder関数で引数に構造体を使うこと、また、その構造体に値をセットする際に定数を使用することから、標準モジュールWinAPIEnumsに構造体と定数を追加する。

リスト1 標準モジュール宣言セクション
'CustomTypes'
Public Type BrowseInfo
  biHwndOwner As Long
  biPidRoot As Long
  biPszDisplayName As String
  biLpszTitle As String
  biUlFlags As Long
  biLpfn As Long
  biLParam As Long
  biIImage As Long
End Type

'Constants'
'ルートフォルダを指定する定数'
Public Const CSIDL_DESKTOP As Long = &H0&
Public Const CSIDL_PROGRAMS As Long = &H2&
Public Const CSIDL_CONTROLS As Long = &H3
Public Const CSIDL_PRINTERS As Long = &H4
Public Const CSIDL_PERSONAL As Long = &H5
Public Const CSIDL_FAVORITE As Long = &H6
Public Const CSIDL_STARTUP As Long = &H7
Public Const CSIDL_RECENT As Long = &H8
Public Const CSIDL_SENDTO As Long = &H9
Public Const CSIDL_BITBUCKET As Long = &HA
Public Const CSIDL_STARTMENU As Long = &HB
Public Const CSIDL_DESKTOPDIRECTORY As Long = &H10
Public Const CSIDL_DRIVES As Long = &H11
Public Const CSIDL_NETWORK As Long = &H12
Public Const CSIDL_NETHOO As Long = &H13
Public Const CSIDL_FONTS As Long = &H14
Public Const CSIDL_TEMPLATES As Long = &H15
'動作方法を指定する定数'
Public Const BIF_RETURNONLYSDIRS As Long = &H1
Public Const BIF_DONTGOBELOWDOMAIN As Long = &H2
Public Const BIF_STATUSTEXT As Long = &H4
Public Const BIF_RETURNFSCANCESTORS As Long = &H8
Public Const BIF_EDITBOX As Long = &H10
Public Const BIF_VALIDATE As Long = &H20
Public Const BIF_BROWSEFORCOMPUTER As Long = &H1000
Public Const BIF_BROWSEFORPRINTER As Long = &H2000
Public Const BIF_BROWSEINCLUDEFILES As Long = &H4000

これらのうち、今回実際に使うのはごく一部だが、挙動を変えたり、機能を追加したりするときに必要になってくるので、ひととおり全て書いてある。

WindowsAPI関数の宣言

お次は、WindowsAPI関数の宣言。これは、クラスモジュールWindowsAPIの宣言セクションに追加する。

スト2 クラスモジュール宣言セクション
'ウインドウハンドル取得まわり'
Private Declare Function FindWindow Lib "user32" _
                  Alias "FindWindowA" (_
                           ByVal lpClassName As String, _
                           ByVal lpWindowName As String) As Long
Private Declare Function GetNextWindow Lib "user32" _
                  Alias "GetWindow" ( _
                           ByVal hwnd As Long, _
                           ByVal wFlag As Long) As Long
Private Declare Function IsWindowVisible Lib "user32" ( _
                           ByVal hwnd As Long) As Long
Private Declare Function GetWindowText Lib "user32" _
                  Alias "GetWindowTextA" ( _
                           ByVal hwnd As Long, _
                           ByVal lpString As String, _
                           ByVal cch As Long) As Long
Private Declare Function GetClassName Lib "user32" _
                  Alias "GetClassNameA" ( _
                           ByVal hwnd As Long, _
                           ByVal lpClassName As String, _
                           ByVal nMaxCount As Long) As Long
'フォルダパス取得まわり'
Private Declare Function SHBrowseForFolder Lib "shell32.dll" _
                  Alias "SHBrowseForFolderA" ( _
                           ByRef lpbi As BrowseInfo) As Long
Private Declare Function SHGetPathFromIDList Lib "shell32.dll" _
                  Alias "SHGetPathFromIDListA" ( _
                           ByVal pidlRoot As Long, _
                           ByVal pszDispName As String) As Long  '……(1)'
'メモリ解放まわり'
Private Declare Function CoTaskMemFree Lib "OLE32.dll" ( _
                           ByVal pv As Long) As Long

(1)の第2引数「pszDispName」については、

akashi-keirin.hatenablog.com

をご覧ください。

ユーザーが選択したフォルダパスを取得するメソッド

以上で準備は終わり。早速メソッドの本体のコードを載っけておこう。

リスト3 クラスモジュール
'ユーザが選択したフォルダのパスを取得するメソッド'
Public Function getSelectedFolderPath( _
                  ByVal prompt As String, _
                  ByVal targetApp As Application) As String
  getSelectedFolderPath = ""
  Dim str As String
  str = Trim(Replace(targetApp.Name, "Microsoft", ""))  '……(2)'
  Dim className As String
  className = getWindowClassName(str)  '……(3)'
  Dim browseInfo_ As BrowseInfo  '……(4)'
  With browseInfo_
    .biHwndOwner = FindWindow(className, Application.Caption)
    .biPidRoot = CSIDL_DESKTOP
    .biLpszTitle = prompt
    .biUlFlags = BIF_RETURNONLYSDIRS
  End With
  Dim pIdl As Long
  pIdl = SHBrowseForFolder(browseInfo_)  '……(5)'
  If pIdl = 0 Then Exit Function  '……(6)'
  Dim ret As String * MAX_PATH_SIZE
  Dim tmp As Long
  tmp = SHGetPathFromIDList(pIdl, ret)  '……(7)'
  getSelectedFolderPath = Left(ret, InStr(ret, vbNullChar) - 1)
  Call CoTaskMemFree(pIdl)  '……(8)'
End Function
'ウインドウのクラス名を取得するメソッド'
Public Function getWindowClassName( _
                  ByVal targetAppNameKeyWord As String) As String
  Dim gotClassName As String * 100
  Dim gotCaption As String * 200
  Dim hwnd As Long
  hwnd = FindWindow(vbNullString, vbNullString)
  Do
    If IsWindowVisible(hwnd) Then
      Call GetWindowText(hwnd, gotCaption, Len(gotCaption))
      If InStr(1, gotCaption, targetAppNameKeyWord) > 0 Then
        Call GetClassName(hwnd, gotClassName, Len(gotClassName))
        Dim ret As String
        ret = Left(gotClassName, InStr(gotClassName, vbNullChar) - 1)
        Exit Do
      End If
    End If
    hwnd = GetNextWindow(hwnd, GW_HWNDNEXT)
  Loop Until hwnd = GetNextWindow(hwnd, GW_HWNDLAST)
  getWindowClassName = ret
End Function

後半のgetWindowClassNameは、前回のリスト3と同じ。今回追加したgetSelectedFolderPath内で使うので、再掲した次第。

(2)の

str = Trim(Replace(targetApp.Name, "Microsoft", ""))

では、(3)のgetWindowClassNameに渡す引数を作るためにReplace関数とTrim関数を用いてアプリケーション名(「Excel」とか「Word」とか)を取り出している。

(3)の

className = getWindowClassName(str)

では、自作のgetWindowClassNameを用いて、アプリケーションのクラス名(Excelだったら「XLMAIN」)を取得し、変数classNameにぶち込んでいる。

(4)からの7行

Dim browseInfo_ As BrowseInfo
With browseInfo_
  .biHwndOwner = FindWindow(className, Application.Caption)
  .biPidRoot = CSIDL_DESKTOP
  .biLpszTitle = prompt
  .biUlFlags = BIF_RETURNONLYSDIRS
End With

では、上のリスト1で宣言した構造体BrowseInfo型の変数browseInfo_を準備して、値をぶち込んでいる。

先ほど(2)、(3)で準備したアプリケーションのクラス名は、

.biHwndOwner = FindWindow(className, Application.Caption)

のところで、FindWindow関数の引数として使用している。

これで、BrowseInfo型の変数browseInfo_に値のセットが終わったので、(5)の

pIdl = SHBrowseForFolder(browseInfo_)

SHBrowseForFolderを呼ぶ。

ここで、フォルダ選択ダイアログが表示されることになる。

ユーザーがフォルダを選んで[OK]、または[キャンセル]をクリックするとコード実行再開。

ユーザーが[キャンセル]をクリックしていたら、SHBrowseForFolderが「0」を返すので、(6)の

If pIdl = 0 Then Exit Function

で処理を抜ける。このとき、getSelectedFolderPathは「""」を返す。

何らかのフォルダを選んで[OK]をクリックした場合は、(7)からの2行

tmp = SHGetPathFromIDList(pIdl, ret)
getSelectedFolderPath = Left(ret, InStr(ret, vbNullChar) - 1)

で、SHGetPathFromIDListSHBrowseForFolderの返り値pIdlを渡す。

SHGetPathFromIDListを実行する過程で「ret」には、ユーザが選択したフォルダパスが固定長の文字列がぶち込まれ、

Left(ret, InStr(ret, vbNullChar) - 1)

によって必要な文字列だけが切り出されてgetSelectedFolderPathの返り値としてreturnされることとなる。

あとは、(8)の

Call CoTaskMemFree(pIdl)

でメモリを解放して終わり。

使ってみる

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

?WindowsAPI.getSelectedFolderPath("フォルダを選択してください",Excel.Application)

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

すると、

f:id:akashi_keirin:20190112225654j:plain

まず、フォルダダイアログが表示される。

f:id:akashi_keirin:20190112225705j:plain

テキトーにフォルダを選択して[OK]をクリックする。

f:id:akashi_keirin:20190112225714j:plain

バッチリ。

おわりに

筆者の大村あつし氏もおっしゃるように、VBAだけでは、フォルダ選択ダイアログを表示させることはできないので、ツール作りをする人にとってはめっちゃ便利なのではないかと思いました。

ちなみに、画像ではまったく伝わりませんが(笑)、

f:id:akashi_keirin:20190112225818j:plain

Wordでもフツーに動きます。

たぶん、OutlookとかPowerpointでも大丈夫だと思いますが、保証はしまへん。

名著『大村あつしのExcel VBA Win64/32 API プログラミング』に誤植???

誤植?

f:id:akashi_keirin:20190105203721j:plain

おなじみ、『大村あつしのExcel VBA Win64/32 API プログラミング』に、誤植かも知れない箇所を発見したので、ご報告。

すでに出版元のWebページ等で訂正されているかも知れないが、そこは調べていない。(←調べろ。)

134~135ページ

当該書籍(以下「本書」という。)の134~135ページにSHGetPathFromIDList関数を宣言するコードが掲載されている。

'SHBrowseForFolderで取得した値からフォルダのフルパスを取得する関数'
'戻り値    成功 = NOERROR(0)'
'          失敗 = E_INVAILEDARG(=&H80070057)'
Declare PtrSafe Function SHGetPathFromIDList Lib "shell32.dll" _
    Alias "SHGetPathFromIDListA" _
    (ByVal pidl As Long, _
     ByVal PtrSafe As String) As LongPtr    '……(*)'

(「……(*)」は引用者による。)

(*)の

ByVal PtrSafe As String

は間違いだと思う。

PtrSafeのところに入る引数(変数)には、この関数を実行したときに固定長の文字列(取得したフォルダパス)が格納される模様なので、上掲コードの「PtrSafe」の部分を、それらしい識別子で置き換えなければならない。

とりあえず、私は、本書133ページに掲載されている構造体(SHBrowseForFolder関数に渡す引数)「BROWSEINFO」の要素名から取って「pszDispName」としている。

修正後のコード

修正後のコードを載っけておく。ただし、ご利用は自己責任で。

リスト1 標準モジュール
'For 64bit'
Declare PtrSafe Function SHGetPathFromIDList Lib "shell32.dll" _
    Alias "SHGetPathFromIDListA" _
    (ByVal pidl As Long, _
     ByVal pszDispName As String) As LongPtr
'For 32bit'
Declare Function SHGetPathFromIDList Lib "shell32.dll" _
    Alias "SHGetPathFromIDListA" _
    (ByVal pidl As Long, _
     ByVal pszDispName As String) As Long

上が64bit用、下が32bit用です。

おわりに

所詮、素人なので、間違えていたら教えろ教えてください。

出版元や筆者からお礼に記念品、とか言われたら、遠慮なくいただきますw

自作WindowsAPIクラスにウインドウのクラス名を返すFunctionを追加した

ウインドウのクラス名を返すFunction

WinAPIの勉強中。

f:id:akashi_keirin:20190105203721j:plain

コチラの本に、アプリケーション別のクラス名が掲載されていたのだが、Internet Explorerのクラス名が載っていなかったので、アプリケーションのクラス名を返すFunctionを作ってみた。

コードを書いてから実行する中で、何箇所か致命的なタイプミスがあって、何度かExcelが強制終了したのだが、大丈夫なのだろうか……。

もちろん、Win32API関数を使います。

家のPCは64bitなんだけれど、職場のPCが32bitなので……。

使用するWinAPI関数

次の関数を使った。

  1. FindWindow関数
  2. GetNextWindow関数
  3. IsWindowVisible関数
  4. GetWindowText関数
  5. GetClassName関数

以上五つ。

例によって、自作のWindowsAPIクラスに組み込んだ。

WindowsAPIクラスへの追加

追加するものが多いので、順に挙げていく。

リスト1 クラスモジュール宣言セクション
Private Declare Function FindWindow Lib "user32" _
                  Alias "FindWindowA" (ByVal lpClassName As String, _
                                       ByVal lpWindowName As String) As Long
Private Declare Function GetNextWindow Lib "user32" _
                  Alias "GetWindow" (ByVal hwnd As Long, _
                                     ByVal wFlag As Long) As Long
Private Declare Function IsWindowVisible Lib "user32" ( _
                                         ByVal hwnd As Long) As Long
Private Declare Function GetWindowText Lib "user32" _
                  Alias "GetWindowTextA" (ByVal hwnd As Long, _
                                          ByVal lpString As String, _
                                          ByVal cch As Long) As Long
Private Declare Function GetClassName Lib "user32" _
                  Alias "GetClassNameA" (ByVal hwnd As Long, _
                                         ByVal lpClassName As String, _
                                         ByVal nMaxCount As Long) As Long

まずは、Win32APIの関数群。

最初、あろうことかGetClassName関数の返り値の型をなぜか「String」と打ち間違えていたために、コード実行後にExcelが強制終了したのだが、大丈夫だったのだろうか……。コワーーー。

スト2 クラスモジュール宣言セクション
Private Const GW_HWNDLAST As Long = 1
Private Const GW_HWNDNEXT As Long = 2

これらは、GetNextWindow関数の引数(第2引数wFlag)にするための定数。

どうも、

hwnd = GetNextWindow(hwnd, GW_HWNDLAST)

とすれば、最後に取得するウインドウである場合にGetNextWindow関数がウインドウハンドル(hwndの値)と同じ値を返すっぽい。

それによって終了判定に使うことができるらしい。ふーん。

リスト3 クラスモジュール
Public Function getWindowClassName(ByVal targetAppNameKeyWord As String) As String
  Dim gotClassName As String * 100    '……(1)'
  Dim gotCaption As String * 200
  Dim hwnd As Long
  hwnd = FindWindow(vbNullString, vbNullString)    '……(2)'
  Do
    If IsWindowVisible(hwnd) Then    '……(3)'
      Call GetWindowText(hwnd, gotCaption, Len(gotCaption))
      If InStr(1, gotCaption, targetAppNameKeyWord) > 0 Then    '……(4)'
        Call GetClassName(hwnd, gotClassName, Len(gotClassName))
        Dim ret As String
        ret = Left(gotClassName, InStr(gotClassName, vbNullChar) - 1)    '……(5)'
        Exit Do
      End If
    End If
    hwnd = GetNextWindow(hwnd, GW_HWNDNEXT)    '……(6)'
  Loop Until hwnd = GetNextWindow(hwnd, GW_HWNDLAST)    '……(7)'
  getWindowClassName = ret
End Function

これがメインのコード。

たぶん、気をつけないといけないのは、(1)の

Dim gotClassName As String * 100
Dim gotCaption As String * 200

String型変数を宣言する際に固定長にしておくこと。

固定長にして、使用するメモリのサイズを厳密に確保しておかないと、えらいことになるような気がする。このあたり、C言語に詳しい人がいたら、教えろ教えてください。

(2)の

hwnd = FindWindow(vbNullString, vbNullString)

は、FindWindow関数を用いて、ウインドウハンドルを取得。引数に二つともvbNullStringを渡しているので、とりあえずテキトーにどれか一つを取得しているのだと思う。違っていたら教えろ教えてください。

ここからDoループに突入。

(3)からの

If IsWindowVisible(hwnd) Then    '……(3)'
  Call GetWindowText(hwnd, gotCaption, Len(gotCaption))
  If InStr(1, gotCaption, targetAppNameKeyWord) > 0 Then    '……(4)'
    Call GetClassName(hwnd, gotClassName, Len(gotClassName))
    Dim ret As String
    ret = Left(gotClassName, InStr(gotClassName, vbNullChar) - 1)    '……(5)'
    Exit Do
  End If
End If
hwnd = GetNextWindow(hwnd, GW_HWNDNEXT)    '……(6)'

If文がネストしているので、読みづらいかも知れない。

まず、(3)でIsWindowVisible関数を用いて、可視状態のウインドウかどうかを調べる。

この関門をクリアすると、今度はGetWindowTextでウインドウのキャプションを取得する。

Functionのくせに返り値を受け取る形にしないのがキモチワルイけれど、ステップ実行してみると、

Call GetWindowText(hwnd, gotCaption, Len(gotCaption))

の実行直後に「gotCaption」にウィンドウのキャプションと残りの文字数をNull文字で埋めた固定長の文字列が格納されていることがわかる。ここの返り値が結構長い文字列になることがあるので、とりあえず固定長を200と大きめに取っておいたが、これが適切なのかどうかもよくわからない。これまた詳しい人がいたら教えろ教えてください。

次に、(4)の

If InStr(1, gotCaption, targetAppNameKeyWord) > 0 Then

の条件判定。

変数gotCaptionには、ウインドウのキャプションとNull文字が入っているので、引数の「targetAppNameKeyWord」を含んでいるなら、お目当てのウインドウだということで、Ifブロック内に進むようにした。

たいていアプリケーション名が入っていると思うので。

ただ、アプリケーション名が全角文字のときにどうなるのかはわからない。一太郎とか。

このあたりも、詳しい人がいたら、教えろ教えてください。

Ifブロック内に突入したら、まず

Call GetClassName(hwnd, gotClassName, Len(gotClassName))

GetClassNameを呼び出す。

これで、gotClassNameに残りの文字数をNull文字で埋めた固定長の文字列が格納される。

あとは、(5)の

ret = Left(gotClassName, InStr(gotClassName, vbNullChar) - 1)

で正味の文字の部分だけを切り出してretに格納し、ループを抜ける。

ループを抜けたら、

getWindowClassName = ret

retの内容をreturnして終わり。

ループから抜けられなかったら、(6)の

hwnd = GetNextWindow(hwnd, GW_HWNDNEXT)

で次のウインドウハンドルを取得してループの先頭へ。

お目当てのウインドウにぶち当たらずに最後まで行ってしまったら、(7)の

Loop Until hwnd = GetNextWindow(hwnd, GW_HWNDLAST)

によってループを抜ける。この場合は""が返ることになる。

使ってみる

目的は、Internet Explorerのクラス名を知ることなので、次のコードで実行する。

リスト4 標準モジュール
Public Sub test()
  Debug.Print WindowsAPI.getWindowClassName("Internet")
End Sub

アホみたいに簡単。

テキトーにIEを起動してから実行すると、イミディエイト・ウインドウに

f:id:akashi_keirin:20190106182051j:plain

IEFrame」と表示された。

これがInternet Explorerのクラス名ということだ。

おわりに

何かに使えるかも知れないので、「WinAPIEnums」という標準モジュールを挿入し、次のような列挙体を作った。

リスト5 標準モジュール宣言セクション
Public Enum AppClassName
  acNotepad
  acPaint
  acWordPad
  acExcel
  acWord
  acOutlook
  acPowerpoint
  acInternetExplorer
End Enum

その上で、我がWindowsAPIクラスのモジュールに次のPrivateメソッドを追加。

リスト6 クラスモジュール
Private Function getApplicationClassName(ByVal targetApp As AppClassName) As String
  Dim ret As String
  Select Case targetApp
    Case acNotepad:          ret = "Notepad"
    Case acPaint:            ret = "MSPaintApp"
    Case acWordPad:          ret = "WordPadClass"
    Case acExcel:            ret = "XLMAIN"
    Case acWord:             ret = "OpusApp"
    Case acOutlook:          ret = "rctrl_renwnd32"
    Case acPowerpoint:       ret = "PPTFrameClass"
    Case anInternetExplorer: ret = "IEFrame"
    Case Else:               ret = ""
  End Select
  getApplicationClassName = ret
End Function

標準モジュール「WinAPIEnums」と必ずセットでインポートしなければならなくなるけれど、このようにすることで、今後WindowsAPIオブジェクトを利用する際にクラス名を指定しやすくなった。

……とはいえ、列挙されているアプリ以外については、今後追加していかねばなりませんが……。

自作WindowsAPIクラスを修正した

WindowsAPIクラスの修正

『大村あつしのExcel VBA Win64/32 API プログラミング』

二年半程前に購入したものの、「だめだ、今の私では歯が立たない……」と諦めていた

f:id:akashi_keirin:20190105203721j:plain

コチラの本、『大村あつしのExcel VBA Win64/32 API プログラミング』。

「今ならそこそこ理解できるのではないか」と思い、現在再挑戦中。

で、次のような記述に出くわした。

77ページ

それでは、実際にAPI関数が「2,147,483,648」というLong型がサポートする値を超える数値を返した場合、Long型で宣言された引数は、この数値をどう受け入れるのでしょうか。VBAの環境内では、「2,147,483,648」をLong型変数に代入すればオーバーフローエラーが発生しますが、このケースではエラーは起きません。答えは、Long型引数は「2,147,483,648」という数値を「-2,147,483,647」という数値で受け入れる、です。

79ページ

それでは、実際にAPI関数が「2,147,483,647」を超える数値を返してしまったらどう対処すべきでしょう。この場合、最上位ビットに7は必ず「1」が立っていますから、VBAはその戻り値を「負」と判断してしまいます。つまり、「正」の数値の戻り値を受け取ったLong型変数が「負」の値を示したら、その「負」の値に「4,294,967,296(2の32乗)」を加算して、自ら「正」の数値に反転させてあげれば良いのです。

このロジックをプロシージャに組み込めば、VBAでも「符号なし32ビット長整数」を処理できるようになります。

なんというか、私は今、モーレツに感動している!

情報科学のいろはの「い」すら学んでいない素人ゆえ、そんなこと考えたこともなかったよ!

C言語の長整数は符号なし、VBAの長整数は符号あり……。

だから、VBALong型というのは、32ビットとは言いながら、符号あり、ということは最上位ビットが正負の符号を表すために使われるから、実際には正の数の最大値は

0111 1111 1111 1111 1111 1111 1111 1111

つまり、10進数で

2,147,483,647

であり、こいつに「1」を足すと、

1000 0000 0000 0000 0000 0000 0000 0000

になってしまうので、10進数にすると、

2,147,483,648ではなく、

-2,147,483,647になってしまう。(符号つき長整数の場合、
1000 0000 0000 0000 0000 0000 0000 0000
が最小値なので、10進数にすると-0ではなく、-2,147,483,647になる。)

うおおおお! 面白れえ!

しかし待てよ。「反転」させたとして、その数は「2,147,483,647」を超えているわけだから、もはやLong型では扱えないよな……。

サンプルコードを見てみる

というわけで、上掲書のサンプルコードを見てみる。

Windowsが起動してからの時間を計測するプロシージャが掲載されていた。

265-266ページ

Windowsを起動してから経過した時間を計測する

前述のGetTickCount関数は、実はWindowsを起動してから経過した時間をミリ秒単位で返すものです。つまり、次のように使えば、Windowsを起動してから経過した時間を計測することが可能です。

リスト3 Module1 Windowsを起動してから経過した時間を計測する(プロシージャ)
Sub GetTickCount_Sample2()
  Dim lngTimer As LongPtr
  Dim vntTimer As Variant
  Dim rc As Long
  Dim rc2 As Double

  'Windowsを起動してから経過した時間を取得'
  lngTimer = GetTickCount()

  vntTimer = CDec(lngTimer)
  If vntTimer < 0 Then
    vntTimer = vntTimer + 2 ^ 32
  End If

  vntTimer = vntTimer / 1000 / 60
  vntTimer = Int(vntTimer)
  MsgBox "Windowsを起動してから経過した時間: " & _
    Format(vntTimer, "#,###分")
End Sub

なぜかハンガリアンだし、変数rcとかrc2が何のために存在するのかわからないけれど、なるほど、Variantで受ければ良いらしい。

というわけで、

akashi-keirin.hatenablog.com

このときのWindowsAPIクラスのコードを修正しよう。

コードの修正

修正前のコードはコチラ

修正後のコードを載せておく。

リスト1 クラスモジュール
Private Declare Function GetTickCount Lib "kernel32" () As Long
Private Declare Sub Sleep Lib "kernel32" (ByVal dwMilliseconds As Long)

Public Function callGetTickCount() As Long
  Dim ret As Variant
  ret = GetTickCount()
  ret = CDec(ret)
  If ret < 0 Then ret = ret + 2 ^ 32
  callGetTickCount = ret
End Function

Public Sub callSleep(ByVal milliSeconds As Long)
  Call Sleep(milliSeconds)
End Sub

Public Sub waitFor(ByVal milliSeconds As Long)
  Dim startTime As Long
  startTime = callGetTickCount()
  Dim endTime As Long
  Do
    Sleep (1)
    DoEvents
    endTime = callGetTickCount()
  Loop Until endTime - startTime > milliSeconds
End Sub

これで、callGetTickCountメソッドが最大「49.7日間」(上掲書より)もの長時間に対応できるようになった。

おわりに

まあ、元の「約24.9日」でさえ使い切ることはまれだろうけれど。

でも、コンピュータに関する基本的なことをもっと勉強した方がいいのかも知れないなあ。

今さらながら基本情報でもちょっと勉強してみようかしら。

指定フォルダからファイル名を取り出すクラス

指定したフォルダからファイル名を取得するクラス

Twitterはけたさんがおっしゃっていたものを私も作ってみた。

あまりうまくないかも知れないけれど……。

指定フォルダからファイル名を取得するクラス

オブジェクト名は「TargetFiles」とした。

リスト1 クラスモジュール
Option Explicit

'Variables'
Private FoundFiles() As String
Private Count_ As Long
Private currentFolder As String
Private currentIndex As Long
Private HasNext_ As Boolean
'Properties'
Public Property Get Count() As Long
  Count = Count_
End Property
Public Property Get Item(ByVal i As Long) As String
  If i > Count Then Item = "": Exit Property
    If i < 1 Then
      currentIndex = 0
    Else
      currentIndex = i - 1
    End If
  Item = FoundFiles(currentIndex)
End Property
Public Property Get CurrentFile() As String
  If Count_ = 0 Then CurrentFile = "": Exit Property
  CurrentFile = FoundFiles(currentIndex)
  If currentIndex = Count_ - 1 Then
    HasNext_ = False
  Else
    HasNext_ = True
  End If
End Property
Public Property Get HasNext() As Boolean
  HasNext = HasNext_
End Property
Public Property Get NextFile() As String
  If HasNext_ Then
    NextFile = FoundFiles(currentIndex + 1)
    currentIndex = currentIndex + 1
  Else
    NextFile = ""
  End If
  If currentIndex = Count_ - 1 Then HasNext_ = False
End Property
Public Property Get PrevFile() As String
  If currentIndex > 0 Then
    PrevFile = FoundFiles(currentIndex - 1)
    currentIndex = currentIndex - 1
  Else
    PrevFile = ""
  End If
End Property
'Constructor'
Public Sub init(ByVal targetFolderName As String, _
                ByVal searchCondition As String)
  If Right(targetFolderName, 1) = "\" Then _
    targetFolderName = Left(targetFolderName, _
                            Len(targetFolderName) - 1)    '"
  currentFolder = targetFolderName & "\"              '"
  If Dir(currentFolder) = "" Then
    currentFolder = ThisWorkbook.Path & "\"     '"
    Exit Sub
  End If
  Call getFileNamesArray(currentFolder, searchCondition)
  currentIndex = 0
End Sub
'Methods'
Public Sub getFileNamesArray(ByVal targetFolder As String, _
                             ByVal searchCondition As String)
  Dim n As Long
  n = 0
  Dim foundFile As String
  foundFile = Dir(targetFolder & searchCondition, vbNormal)
  Do While foundFile <> ""
    ReDim Preserve FoundFiles(n)
    FoundFiles(n) = foundFile
    n = n + 1
    foundFile = Dir()
  Loop
  Count_ = n
End Sub

説明は、また時間があるときにゆっくり書く。

使ってみる

f:id:akashi_keirin:20190104172034j:plain

このようなフォルダを準備して、次のコードで実行。

スト2 標準モジュール
Public Sub testTargetFilesClass()
  Dim TargetFiles As New TargetFiles
  With TargetFiles
    Call .init(ThisWorkbook.Path, "*.xls*")
    Debug.Print .CurrentFile
    Do
      Debug.Print .NextFile
    Loop Until Not .HasNext
  End With
End Sub

こいつを実行すると、

f:id:akashi_keirin:20190104172043j:plain

こうなる。

もう一つ、次のパターンも。

リスト3 標準モジュール
Public Sub testTargetFilesClass02()
  Dim TargetFiles As New TargetFiles
  With TargetFiles
    Call .init(ThisWorkbook.Path, "*.xls*")
    Dim i As Long
    For i = 1 To .Count
      Debug.Print .Item(i)
    Next
  End With
End Sub

こいつを実行すると、

f:id:akashi_keirin:20190104172051j:plain

こうなる。

要するに、DoループにもForループにも対応可ということ。

おわりに

とりあえず書いてみただけなので、改良の余地はたくさんあると思います。