<コールバック関数の使用法>
ウインドウプロシージャについて
ウィンドウプロシージャについては、SfcMini.MachineCodeオブジェクトを利用して対応可能です。サンプルコードとして、この機能を用いてCreateWindowEx, ShowWindow, UpdateWindow, DispatchMessage関数を作成し、これらを使ってWindowsプログラムを構築する例を挙げてあります。
また、ウインドウプロシージャを簡単に使用するためのクラス『WindowProcedure』がライブラリにあります。
サンプルコード
ウインドウプロシージャを、マシン語で記述する例です。フォームの『閉じる』ボタンを押した時にアプリケーションを終了する機能だけをサポートした簡単な物です。ライブラリのWindowProcedureクラスを利用した例としては、こちらを参照してください。
実行結果
また、ウインドウプロシージャを簡単に使用するためのクラス『WindowProcedure』がライブラリにあります。
サンプルコード
ウインドウプロシージャを、マシン語で記述する例です。フォームの『閉じる』ボタンを押した時にアプリケーションを終了する機能だけをサポートした簡単な物です。ライブラリのWindowProcedureクラスを利用した例としては、こちらを参照してください。
option explicit
Dim i
Sub Declare(obj,dll,proc)
set obj=CreateObject("SfcMini.DynaCall")
obj.Declare dll,proc
End Sub
Dim PostQuitMessage, RegisterClassEx, UnregisterClass, LoadCursor
Dim GetMessage, TranslateMessage, GetStockObject,DefWindowProc
Dim MessageBox
Declare PostQuitMessage,"user32" ,"PostQuitMessage"
Declare RegisterClassEx,"user32" ,"RegisterClassExA"
Declare UnregisterClass,"user32" ,"UnregisterClassA"
Declare GetMessage,"user32" ,"GetMessageA"
Declare TranslateMessage,"user32" ,"TranslateMessage"
Declare LoadCursor,"user32" ,"LoadCursorA"
Declare GetStockObject,"gdi32" ,"GetStockObject"
Declare DefWindowProc,"User32.dll" ,"DefWindowProcA"
Declare MessageBox,"user32","MessageBoxA"
Dim API
set API=CreateObject("SfcMini.DynaCall")
API.LoadLibrariesA "user32"
Dim WP,WPbuff,CheckWP,label1,label2
set WP=CreateObject("SfcMini.MachineCode")
set WPbuff=CreateObject("SfcMini.MachineCode")
set CheckWP=CreateObject("SfcMini.MachineCode")
WPbuff.Reset(1028)
WPbuff.AddInt32(0) 'First 4 bytes contain number of que.
with WP
for i=1 to 2
.Reset
.AddCode "8b442408" 'mov eax,[esp+08]
.AddCode "3d":.AddInt32 WM_DESTROY 'cmp eax,WM_DESTROY
.AddCode "0f84":.AddInt32 label1,true 'je label1
.AddCode "8b442404" 'mov eax,[esp+04]//hwnd
.AddCode "8b5c2408" 'mov ebx,[esp+08]//message
.AddCode "8b4c240c" 'mov ecx,[esp+0c]//wparam
.AddCode "8b542410" 'mov edx,[esp+10]//lparam
.AddCode "52" 'push edx
.AddCode "51" 'push ecx
.AddCode "53" 'push ebx
.AddCode "50" 'push eax
.AddCode "b8"
.AddInt32 DefWindowProc.Address 'mov eax,DefWindowProc.Address
.AddCode "ffd0" 'call eax
.AddCode "c21000" 'ret 0010
'//store four parameters
label1= _
.AddCode("bb")
.AddInt32 WPbuff.BufferAddress 'mov ebx,WPbuff.BufferAddress
.AddCode "ff03" 'inc dword ptr [ebx]
.AddCode "8b03" 'mov eax,[ebx]
.AddCode "c1e004" 'shl eax,04
.AddCode "03d8" 'add ebx,eax
.AddCode "8b442404" 'mov eax,[esp+04]
.AddCode "894304" 'mov [ebx+04],eax
.AddCode "8b442408" 'mov eax,[esp+08]
.AddCode "894308" 'mov [ebx+08],eax
.AddCode "8b44240c" 'mov eax,[esp+0c]
.AddCode "89430c" 'mov [ebx+0c],eax
.AddCode "8b442410" 'mov eax,[esp+10]
.AddCode "894310" 'mov [ebx+10],eax
.AddCode "33c0" 'xor eax,eax //return 0;
.AddCode "c21000" 'ret 0010
next
end with
with CheckWP
for i=1 to 2
.Reset
.AddCode "bb":.AddInt32 WPbuff.BufferAddress'mov ebx,WPbuff.BufferAddress
.AddCode "8b442404" 'mov eax,[esp+04]
.AddCode "3d":.AddInt32 0 'cmp eax,0
.AddCode "0f85":.AddInt32 label2,true 'jne label2
'//Check-if mode (Que shifts)
.AddCode "8b0b" 'mov ecx,[ebx]
.AddCode "c1e104" 'shl ecx,04 //ecx=ecx*16;
.AddCode "83f900" 'cmp ecx,00000000
.AddCode "0f85":.AddInt32 label1,true 'jne label1
.AddCode "33c0" 'xor eax,eax //If nothing remains (ecx=0),
.AddCode "c20400" 'ret 0004 //return 0;//(do nothing)
label1= _
.AddCode("8b4314") 'mov eax,[ebx+14]
.AddCode "894304" 'mov [ebx+04],eax
.AddCode "83c304" 'add ebx,00000004
.AddCode "e2":.AddByte label1,true 'loop label1
.AddCode "bb":.AddInt32 WPbuff.BufferAddress'mov ebx,WPbuff.BufferAddress
.AddCode "8b03" 'mov eax,[ebx]
.AddCode "ff0b" 'dec dword ptr [ebx]
.AddCode "c20400" 'ret 0004
'//Get-data mode
label2= _
.AddCode("c1e002") 'shl eax,02 //eax=eax*4;
.AddCode "03d8" 'add ebx,eax
.AddCode "8b03" 'mov eax,[ebx]
.AddCode "c20400" 'ret 0004
next
end with
Function CreateWindowEx(dwExStyle,lpClassName,lpWindowName, _
dwStyle,X,Y,nWidth,nHeight,hwndParent,hMenu, _
hInstance,lpParam)
CreateWindowEx=API.CreateWindowExA(dwExStyle,lpClassName,lpWindowName, _
dwStyle,X,Y,nWidth,nHeight,hwndParent,hMenu, _
hInstance,lpParam)
do until CheckWP(0)=0
call WndProc(CheckWP(1),CheckWP(2),CheckWP(3),CheckWP(4))
loop
End Function
Function DispatchMessage(lpMsg)
DispatchMessage=API.DispatchMessageA(lpMsg)
do until CheckWP(0)=0
call WndProc(CheckWP(1),CheckWP(2),CheckWP(3),CheckWP(4))
loop
End Function
Function ShowWindow(hWnd,nCmdShow)
ShowWindow=API.ShowWindow(hWnd,nCmdShow)
do until CheckWP(0)=0
call WndProc(CheckWP(1),CheckWP(2),CheckWP(3),CheckWP(4))
loop
End Function
Function UpdateWindow(hWnd)
UpdateWindow=API.UpdateWindow(hWnd)
do until CheckWP(0)=0
call WndProc(CheckWP(1),CheckWP(2),CheckWP(3),CheckWP(4))
loop
End Function
'Window Class
Dim WNDCLASSEX:set WNDCLASSEX=CreateObject("SfcMini.Structure")
WNDCLASSEX _
"cbSize","Long", _
"style","Long", _
"lpfnWndProc","Long", _
"cbClsExtra","Long", _
"cbWndExtra","Long", _
"hInstance","Long", _
"hIcon","Long", _
"hCursor","Long", _
"hbrBackground","Long", _
"lpszMenuName","String", _
"lpszClassName","String", _
"hIconSm","Long"
'MSG structure
Dim MSG:set MSG=CreateObject("SfcMini.Structure")
MSG _
"message", "Long", _
"wParam", "Long", _
"lParam", "Long", _
"time", "Long", _
"pt_x", "Long", _
"pt_y", "Long"
Const WM_DESTROY = &H2
Const SW_SHOW = 5
Const LTGRAY_BRUSH = 1
Const WS_OVERLAPPEDWINDOW = &HCF0000
Const CW_USEDEFAULT = &H80000000
Const IDC_ARROW = 32512
'Just call WinMain()
Const g_chAppName = "TestApplication" 'Application name
Const g_chClassName = "TestWndClass" 'Window class name
Wscript.quit(WinMain(0,0,"",SW_SHOW))
Function WinMain(p_hInstance, p_hPreInst, p_pchCmdLine, p_iCmdShow)
'Register Window Class
If InitApplication(p_hInstance,WP.Address) = True Then
'Show Window
If InitInstance(p_hInstance, p_iCmdShow) = True Then
'Message Loop
Do While (GetMessage(MSG, 0, 0, 0))
Call TranslateMessage(MSG)
Call DispatchMessage(MSG)
Loop
End If
Call UnregisterClass(g_chClassName, p_hInstance)
End If
WinMain=0
End Function
'Register Window Class
Function InitApplication(p_hInstance, AddressOfWndProc )
Call UnregisterClass(g_chClassName, p_hInstance)
with WNDCLASSEX
.cbSize = 48
.style = 0
.lpfnWndProc = AddressOfWndProc
.cbClsExtra = 0
.cbWndExtra = 0
.hInstance = p_hInstance
.hIcon = 0
.hCursor = LoadCursor(0,IDC_ARROW)
.hbrBackground = GetStockObject(LTGRAY_BRUSH)
.lpszMenuName = 0
.lpszClassName = g_chClassName
.hIconSm = 0
end with
If RegisterClassEx(WNDCLASSEX) Then
InitApplication=True
Else
InitApplication=False
End If
End Function
'Show Window
Function InitInstance(p_hInstance, p_nCmdShow)
Dim hWnd
'Create Window
hWnd = CreateWindowEx(0, g_chClassName, g_chAppName, _
WS_OVERLAPPEDWINDOW, CW_USEDEFAULT, CW_USEDEFAULT, CW_USEDEFAULT, CW_USEDEFAULT, _
0, 0, p_hInstance, 0)
If hWnd = 0 Then
InitInstance = False
Exit Function
End If
'Show Window
Call ShowWindow(hWnd, p_nCmdShow)
Call UpdateWindow(hWnd)
InitInstance = True
End Function
'Window Procedure
Function WndProc(hwnd,message,wparam,lparam)
select case message
case WM_DESTROY
Call PostQuitMessage(0)
WndProc=0
case else
WndProc=DefWindowProc(hwnd,message,wparam,lparam)
end select
End Function
Dim i
Sub Declare(obj,dll,proc)
set obj=CreateObject("SfcMini.DynaCall")
obj.Declare dll,proc
End Sub
Dim PostQuitMessage, RegisterClassEx, UnregisterClass, LoadCursor
Dim GetMessage, TranslateMessage, GetStockObject,DefWindowProc
Dim MessageBox
Declare PostQuitMessage,"user32" ,"PostQuitMessage"
Declare RegisterClassEx,"user32" ,"RegisterClassExA"
Declare UnregisterClass,"user32" ,"UnregisterClassA"
Declare GetMessage,"user32" ,"GetMessageA"
Declare TranslateMessage,"user32" ,"TranslateMessage"
Declare LoadCursor,"user32" ,"LoadCursorA"
Declare GetStockObject,"gdi32" ,"GetStockObject"
Declare DefWindowProc,"User32.dll" ,"DefWindowProcA"
Declare MessageBox,"user32","MessageBoxA"
Dim API
set API=CreateObject("SfcMini.DynaCall")
API.LoadLibrariesA "user32"
Dim WP,WPbuff,CheckWP,label1,label2
set WP=CreateObject("SfcMini.MachineCode")
set WPbuff=CreateObject("SfcMini.MachineCode")
set CheckWP=CreateObject("SfcMini.MachineCode")
WPbuff.Reset(1028)
WPbuff.AddInt32(0) 'First 4 bytes contain number of que.
with WP
for i=1 to 2
.Reset
.AddCode "8b442408" 'mov eax,[esp+08]
.AddCode "3d":.AddInt32 WM_DESTROY 'cmp eax,WM_DESTROY
.AddCode "0f84":.AddInt32 label1,true 'je label1
.AddCode "8b442404" 'mov eax,[esp+04]//hwnd
.AddCode "8b5c2408" 'mov ebx,[esp+08]//message
.AddCode "8b4c240c" 'mov ecx,[esp+0c]//wparam
.AddCode "8b542410" 'mov edx,[esp+10]//lparam
.AddCode "52" 'push edx
.AddCode "51" 'push ecx
.AddCode "53" 'push ebx
.AddCode "50" 'push eax
.AddCode "b8"
.AddInt32 DefWindowProc.Address 'mov eax,DefWindowProc.Address
.AddCode "ffd0" 'call eax
.AddCode "c21000" 'ret 0010
'//store four parameters
label1= _
.AddCode("bb")
.AddInt32 WPbuff.BufferAddress 'mov ebx,WPbuff.BufferAddress
.AddCode "ff03" 'inc dword ptr [ebx]
.AddCode "8b03" 'mov eax,[ebx]
.AddCode "c1e004" 'shl eax,04
.AddCode "03d8" 'add ebx,eax
.AddCode "8b442404" 'mov eax,[esp+04]
.AddCode "894304" 'mov [ebx+04],eax
.AddCode "8b442408" 'mov eax,[esp+08]
.AddCode "894308" 'mov [ebx+08],eax
.AddCode "8b44240c" 'mov eax,[esp+0c]
.AddCode "89430c" 'mov [ebx+0c],eax
.AddCode "8b442410" 'mov eax,[esp+10]
.AddCode "894310" 'mov [ebx+10],eax
.AddCode "33c0" 'xor eax,eax //return 0;
.AddCode "c21000" 'ret 0010
next
end with
with CheckWP
for i=1 to 2
.Reset
.AddCode "bb":.AddInt32 WPbuff.BufferAddress'mov ebx,WPbuff.BufferAddress
.AddCode "8b442404" 'mov eax,[esp+04]
.AddCode "3d":.AddInt32 0 'cmp eax,0
.AddCode "0f85":.AddInt32 label2,true 'jne label2
'//Check-if mode (Que shifts)
.AddCode "8b0b" 'mov ecx,[ebx]
.AddCode "c1e104" 'shl ecx,04 //ecx=ecx*16;
.AddCode "83f900" 'cmp ecx,00000000
.AddCode "0f85":.AddInt32 label1,true 'jne label1
.AddCode "33c0" 'xor eax,eax //If nothing remains (ecx=0),
.AddCode "c20400" 'ret 0004 //return 0;//(do nothing)
label1= _
.AddCode("8b4314") 'mov eax,[ebx+14]
.AddCode "894304" 'mov [ebx+04],eax
.AddCode "83c304" 'add ebx,00000004
.AddCode "e2":.AddByte label1,true 'loop label1
.AddCode "bb":.AddInt32 WPbuff.BufferAddress'mov ebx,WPbuff.BufferAddress
.AddCode "8b03" 'mov eax,[ebx]
.AddCode "ff0b" 'dec dword ptr [ebx]
.AddCode "c20400" 'ret 0004
'//Get-data mode
label2= _
.AddCode("c1e002") 'shl eax,02 //eax=eax*4;
.AddCode "03d8" 'add ebx,eax
.AddCode "8b03" 'mov eax,[ebx]
.AddCode "c20400" 'ret 0004
next
end with
Function CreateWindowEx(dwExStyle,lpClassName,lpWindowName, _
dwStyle,X,Y,nWidth,nHeight,hwndParent,hMenu, _
hInstance,lpParam)
CreateWindowEx=API.CreateWindowExA(dwExStyle,lpClassName,lpWindowName, _
dwStyle,X,Y,nWidth,nHeight,hwndParent,hMenu, _
hInstance,lpParam)
do until CheckWP(0)=0
call WndProc(CheckWP(1),CheckWP(2),CheckWP(3),CheckWP(4))
loop
End Function
Function DispatchMessage(lpMsg)
DispatchMessage=API.DispatchMessageA(lpMsg)
do until CheckWP(0)=0
call WndProc(CheckWP(1),CheckWP(2),CheckWP(3),CheckWP(4))
loop
End Function
Function ShowWindow(hWnd,nCmdShow)
ShowWindow=API.ShowWindow(hWnd,nCmdShow)
do until CheckWP(0)=0
call WndProc(CheckWP(1),CheckWP(2),CheckWP(3),CheckWP(4))
loop
End Function
Function UpdateWindow(hWnd)
UpdateWindow=API.UpdateWindow(hWnd)
do until CheckWP(0)=0
call WndProc(CheckWP(1),CheckWP(2),CheckWP(3),CheckWP(4))
loop
End Function
'Window Class
Dim WNDCLASSEX:set WNDCLASSEX=CreateObject("SfcMini.Structure")
WNDCLASSEX _
"cbSize","Long", _
"style","Long", _
"lpfnWndProc","Long", _
"cbClsExtra","Long", _
"cbWndExtra","Long", _
"hInstance","Long", _
"hIcon","Long", _
"hCursor","Long", _
"hbrBackground","Long", _
"lpszMenuName","String", _
"lpszClassName","String", _
"hIconSm","Long"
'MSG structure
Dim MSG:set MSG=CreateObject("SfcMini.Structure")
MSG _
"message", "Long", _
"wParam", "Long", _
"lParam", "Long", _
"time", "Long", _
"pt_x", "Long", _
"pt_y", "Long"
Const WM_DESTROY = &H2
Const SW_SHOW = 5
Const LTGRAY_BRUSH = 1
Const WS_OVERLAPPEDWINDOW = &HCF0000
Const CW_USEDEFAULT = &H80000000
Const IDC_ARROW = 32512
'Just call WinMain()
Const g_chAppName = "TestApplication" 'Application name
Const g_chClassName = "TestWndClass" 'Window class name
Wscript.quit(WinMain(0,0,"",SW_SHOW))
Function WinMain(p_hInstance, p_hPreInst, p_pchCmdLine, p_iCmdShow)
'Register Window Class
If InitApplication(p_hInstance,WP.Address) = True Then
'Show Window
If InitInstance(p_hInstance, p_iCmdShow) = True Then
'Message Loop
Do While (GetMessage(MSG, 0, 0, 0))
Call TranslateMessage(MSG)
Call DispatchMessage(MSG)
Loop
End If
Call UnregisterClass(g_chClassName, p_hInstance)
End If
WinMain=0
End Function
'Register Window Class
Function InitApplication(p_hInstance, AddressOfWndProc )
Call UnregisterClass(g_chClassName, p_hInstance)
with WNDCLASSEX
.cbSize = 48
.style = 0
.lpfnWndProc = AddressOfWndProc
.cbClsExtra = 0
.cbWndExtra = 0
.hInstance = p_hInstance
.hIcon = 0
.hCursor = LoadCursor(0,IDC_ARROW)
.hbrBackground = GetStockObject(LTGRAY_BRUSH)
.lpszMenuName = 0
.lpszClassName = g_chClassName
.hIconSm = 0
end with
If RegisterClassEx(WNDCLASSEX) Then
InitApplication=True
Else
InitApplication=False
End If
End Function
'Show Window
Function InitInstance(p_hInstance, p_nCmdShow)
Dim hWnd
'Create Window
hWnd = CreateWindowEx(0, g_chClassName, g_chAppName, _
WS_OVERLAPPEDWINDOW, CW_USEDEFAULT, CW_USEDEFAULT, CW_USEDEFAULT, CW_USEDEFAULT, _
0, 0, p_hInstance, 0)
If hWnd = 0 Then
InitInstance = False
Exit Function
End If
'Show Window
Call ShowWindow(hWnd, p_nCmdShow)
Call UpdateWindow(hWnd)
InitInstance = True
End Function
'Window Procedure
Function WndProc(hwnd,message,wparam,lparam)
select case message
case WM_DESTROY
Call PostQuitMessage(0)
WndProc=0
case else
WndProc=DefWindowProc(hwnd,message,wparam,lparam)
end select
End Function
実行結果