|
VBでは使用不可能と思っていたんだけど、…できちゃった。自分でもびっくり。
検索ダイアログボックスを表示させるのは簡単なだけど、表示させるだけではイベント("次を検索"、"ｷｬﾝｾﾙ"等が押される)を受け取れない。イベントを拾えるようにするには RegisterWindowMessage 関数でメッセージを登録する必要がある。検索ダイアログボックスの場合は、"FINDMSGSTRING"を指定すればよろしい。"COMMDLG.H" ファイルを見ると、 #define FINDMSGSTRINGA "commdlg_FindReplace" とあるのでこれを使用する。変数名の一番右にある'A'の文字は取り去ってしまって大丈夫。さて、これを登録することで、ウインドウプロシージャよりメッセージを受け取れるようになる。また、lParam には FINDREPLACE構造体へのポインタが送られてくる。 FINDREPLACE 構造体はVBでは次の通り。
Private Type FINDREPLACE
lStructSize As Long
hwndOwner As Long
hInstance As Long
flags As Long
lpstrFindWhat As Long
lpstrReplaceWith As Long
wFindWhatLen As Integer
wReplaceWithLen As Integer
lCustData As Long
lpfnHook As Long
lpTemplateName As Long
End Type
flags から大文字・小文字を区別する、下へ検索 などの情報を取得できる。また lpstrFindWhat からは、検索する文字列を取得できる。このメンバは検索に指定された文字列へのポインタであり、それはLong型である。これから文字列を取得するには、それなりの処理をしなければならない。これはソースを確認されたい。 それでは、フォーム(オブジェクト名：frmMain)にテキストボックス(オブジェクト名：何でもよろしい)、コマンドボタン(オブジェクト名：Command1)を配置しませう。ここでの例は、大文字・小文字を区別するを指定できるようにしている。じゃ、いきまっせ。 ①まず、フォームモジュールに一気に次のコードを書きましょう。いきなり関数が出てくるけど、気にしない。 Private Sub Form_Load()
'ウインドウメッセージを登録する
Call RegWindowMessage
'サブクラス化を開始する
Call SubClass(frmMain.hwnd)
End Sub
Private Sub Form_QueryUnload(Cancel As Integer, UnloadMode As Integer)
'サブクラス化を解除する
Call UnSubClass(frmMain.hwnd)
End Sub
Private Sub Command1_Click()
Call FindMyWord(frmMain.hwnd)
End Sub
②標準モジュールを用意して、次のコード達を書いてね。
'頼もしいAPI関数達 Private Declare Function CallWindowProc Lib "user32" Alias "CallWindowProcA" (ByVal lpPrevWndFunc As Long, ByVal hwnd As Long, ByVal Msg As Long, ByVal wParam As Long, ByVal lParam As Long) As Long Private Declare Function RegisterWindowMessage Lib "user32" Alias "RegisterWindowMessageA" (ByVal lpString As String) As Long Private Declare Function FindText Lib "comdlg32.dll" Alias "FindTextA" (pFindreplace As FINDREPLACE) As Long Private Declare Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" (Destination As Any, Source As Any, ByVal Length As Long) Private Declare Function SendMessage Lib "user32" Alias "SendMessageA" (ByVal hwnd As Long, ByVal wMsg As Long, ByVal wParam As Long, lParam As Any) As Long Private Declare Function lstrlen Lib "kernel32" Alias "lstrlenA" (ByVal lpString As Long) As Long
Private Type FINDREPLACE
lStructSize As Long
hwndOwner As Long
hInstance As Long
flags As Long
lpstrFindWhat As Long
lpstrReplaceWith As Long
wFindWhatLen As Integer
wReplaceWithLen As Integer
lCustData As Long
lpfnHook As Long
lpTemplateName As Long
End Type
'定数
Private Const EM_GETSEL = &HB0
Private Const WM_GETTEXT = &HD
Private Const EM_SETSEL = &HB1
Private Const EM_SCROLLCARET = &HB7
Private Const FR_DIALOGTERM = &H40
Private Const FR_DOWN = &H1
Private Const FR_ENABLEHOOK = &H100
Private Const FR_ENABLETEMPLATE = &H200
Private Const FR_ENABLETEMPLATEHANDLE = &H2000
Private Const FR_FINDNEXT = &H8
Private Const FR_HIDEMATCHCASE = &H8000
Private Const FR_HIDEUPDOWN = &H4000
Private Const FR_HIDEWHOLEWORD = &H10000
Private Const FR_MATCHCASE = &H4
Private Const FR_NOMATCHCASE = &H800
Private Const FR_NOUPDOWN = &H400
Private Const FR_NOWHOLEWORD = &H1000
Private Const FR_REPLACE = &H10
Private Const FR_REPLACEALL = &H20
Private Const FR_SHOWHELP = &H80
Private Const FR_WHOLEWORD = &H2
Private Const GWL_WNDPROC = (-4) 'ウインドウプロシージャ
Private Const FINDMSGSTRING = "commdlg_FindReplace"
Private udtFINDREPLACE As FINDREPLACE
'新規メッセージ識別子
Private WM_FDDLGEVENT As Long
'検索文字
Private fndString As String
'デフォルトのウインドウプロシージャのハンドル
Private OldWindowhWnd As String
'---------------------------------------------------------------------------
' 関数名 ： RegWindowMessage
' 機能 ： ウインドウメッセージを登録する
' 引数 ： なし
' 返り値 ： イベントメッセージ定数
'---------------------------------------------------------------------------
Public Sub RegWindowMessage()
WM_FDDLGEVENT = RegisterWindowMessage(FINDMSGSTRING)
End Sub
'---------------------------------------------------------------------------
' 関数名 ： SubClass
' 機能 ： サブクラス化を開始する
' 引数 ： (in) hWnd … フォームのウインドウハンドル
' 返り値 ： なし
'---------------------------------------------------------------------------
Public Sub SubClass(ByVal hwnd As Long)
OldWindowhWnd = SetWindowLong(hwnd, GWL_WNDPROC, AddressOf WindowProc)
End Sub
'---------------------------------------------------------------------------
' 関数名 ： UnSubClass
' 機能 ： サブクラス化を解除する
' 引数 ： (in) hWnd … フォームのウインドウハンドル
' 返り値 ： なし
'---------------------------------------------------------------------------
Public Sub UnSubClass(ByVal hwnd As Long)
If OldWindowhWnd <> 0 Then
'元のプロシージャアドレスに設定する
Call SetWindowLong(hwnd, GWL_WNDPROC, OldWindowhWnd)
OldWindowhWnd = 0
End If
End Sub
'---------------------------------------------------------------------------
' 関数名 ： FindMyWord
' 機能 ： 文字列検索ダイアログボックスを表示する
' 引数 ： (in)hWnd … 対象ハンドル
' 返り値 ： なし
'---------------------------------------------------------------------------
Public Sub FindMyWord(ByVal hwnd As Long)
With udtFINDREPLACE
.lStructSize = Len(udtFINDREPLACE)
.hInstance = App.hInstance
.hwndOwner = hWnd
fndString = String$(256, Chr$(0)) '文字列初期化
.lpstrFindWhat = StrPtr(fndString) '文字列のアドレスを渡す
.wFindWhatLen = Len(fndString)
.flags = FR_FINDNEXT Or FR_MATCHCASE Or FR_HIDEWHOLEWORD Or FR_HIDEUPDOWN
End With udtFINDREPLACE
Call FindText(udtFINDREPLACE)
End Sub
'---------------------------------------------------------------------------
' 関数名 ： WindowProc
' 機能 ： ウインドウプロシージャ
' 引数 ： (in) hWnd … サブクラス化したウインドウハンドル
' (in) uMsg … ウインドウメッセージ
' (in) wParam … 追加情報１
' (in) lParam … 追加情報２
' 戻り値 ： ウインドウプロシージャのアドレス
'---------------------------------------------------------------------------
Public Function WindowProc(ByVal hwnd As Long, ByVal uMsg As Long, ByVal wParam As Long, ByVal lParam As Long) As Long
Select Case uMsg
Case WM_FDDLGEVENT
'検索処理
Call SearchGetString(hwnd, lParam)
WindowProc = 0&
Case Else
WindowProc = CallWindowProc(OldWindowhWnd, hwnd, uMsg, wParam, lParam)
End Select
End Function
'---------------------------------------------------------------------------
' 関数名 ： SearchGetString
' 機能 ： 文字列を検索する
' 引数 ： (in) hWnd … オーナーウインドウのハンドル
' (in) udtFRPtr … FINDREPLACE構造体へのポインタ
' 戻り値 ： なし
'---------------------------------------------------------------------------
Public Sub SearchGetString(ByVal hwnd As Long, ByVal udtFRPtr As Long)
Dim udtFR As FINDREPLACE
Dim gStrPtr As Long '検索文字列へのポインタ
Dim gText As String
Dim SearchText As String '検索する文字列
Dim gStrLength As Long '文字列の長さ
'FINDREPLACE構造体情報をコピー
Call CopyMemory(udtFR, ByVal udtFRPtr, Len(udtFR))
'次を検索が押された
If (udtFR.flags And FR_FINDNEXT) = FR_FINDNEXT Then
'文字列のアドレス
gStrPtr = udtFR.lpstrFindWhat
'文字列の長さを取得
gStrLength = lstrlen(gStrPtr)
'Nullで初期化
gText = String$(gStrLength, Chr$(0))
'文字列取得
Call CopyMemory(ByVal gText, ByVal gStrPtr&, gStrLength)
SearchText = gText
'この先に検索処理を書く
' ・
' ・
' ・
'大文字・小文字の区別をする
If udtFR.flags And FR_MATCHCASE Then
'検索処理
'大文字・小文字の区別をしない
Eｌse
'検索処理
End If
' ・
' ・
' ・
'検索処理終了
Else
'キャンセルが押された
End If
End Sub
気をつけることは、コマンドボタンを押す度にダイアログが表示されてしまうこと。フラグなど用意して、２つ目以降を表示させないようにするようにしないと駄目ですぜ。 |