procedure TForm1.ApplicationEvents1Message(var Msg: tagMSG;
var Handled: Boolean);
var pd:TPoint;
WinCon : TWinControl;
WND : HWND;
cmpComponent:TComponent;
begin
if Msg.message=WM_MOUSEMOVE then
begin
GetCursorPos(pd);
WND := Handle;
repeat
WinCon := FindControl(WND);
WND := ChildWindowFromPoint(WinCon.Handle,WinCon.ScreenToClient(pd));
if (WND = 0) or (not WinCon.Showing) or (not WinCon.CanFocus) then //增加判斷 showing focus
exit;
until (WND = WinCon.Handle) or (WinCon.ControlCount <= 0);
cmpComponent := FindComponent(wincon.Name);
if Assigned(cmpComponent) then
begin
Label1.Caption := cmpComponent.Name;
end;
end;
end;
參考: http://delphi.ktop.com.tw/board.php?cid=168&fid=913&tid=101905
2017年9月7日 星期四
將應用程式建立在Form上
Ex:將小算盤移到Form上
procedure TForm1.Button1Click(Sender: TObject);
var hWndNewParent : THandle;
begin
hWndNewParent := Findwindow(nil, '小算盤');
Windows.SetParent(hWndNewParent, Form1.Handle);
end;
procedure TForm1.Button1Click(Sender: TObject);
var hWndNewParent : THandle;
begin
hWndNewParent := Findwindow(nil, '小算盤');
Windows.SetParent(hWndNewParent, Form1.Handle);
end;
tscap32 Delphi Video Capture Component
網路視訊 for Delphi 元件
http://tscap32.sourceforge.net/screenshots.html
http://tscap32.sourceforge.net/screenshots.html
判斷檔案是否被開啟
function TForm1.fn_FileInUse(sFileName:String):Boolean;
var HFileRes: HFILE;
begin
Result := False;
if not FileExists(sFileName) then
exit;
HFileRes := CreateFile(pchar(sFileName), GENERIC_READ or GENERIC_WRITE, 0, nil, OPEN_EXISTING, FILE_ATTRIBUTE_NORMAL, 0);
Result := (HFileRes = INVALID_HANDLE_VALUE);
if not Result then
CloseHandle(HFileRes);
end;
var HFileRes: HFILE;
begin
Result := False;
if not FileExists(sFileName) then
exit;
HFileRes := CreateFile(pchar(sFileName), GENERIC_READ or GENERIC_WRITE, 0, nil, OPEN_EXISTING, FILE_ATTRIBUTE_NORMAL, 0);
Result := (HFileRes = INVALID_HANDLE_VALUE);
if not Result then
CloseHandle(HFileRes);
end;
影像處理[灰階化]及[邊緣化]
unit kantendetektion;
interface
uses graphics;
type
PRGBTriple = ^TRGBTriple;
TRGBTriple = packed Record
rgbtBlue: Byte;
rgbtGreen: Byte;
rgbtRed: Byte;
End;
PRGBLine = ^TRGBLine;
TRGBLine = Array[0..0] of TRGBTriple;
procedure Sobel(var Picture: TBitmap; const EdgeWhite: Boolean = True);
implementation
procedure pValInRange( var Val: Integer; const cFrom, cTo: Integer );
begin
if Val > cTo then
Val := cTo
else
if Val < cFrom then
Val := cFrom;
end;
function fValInRange( Val: Integer; const cFrom, cTo: Integer ): Integer;
begin
if Val > cTo then
Result := cTo
else
if Val < cFrom then
Result := cFrom
else
Result := Val;
end;
//nebenfunktion
procedure Gray(var Picture: TBitmap);
var
sl: PRGBLine;
x: Integer;
procedure _Gray(var rgbt: TRGBTriple );
begin
with rgbt do
begin
{weiß}
rgbtBlue := (rgbtBlue+rgbtGreen+rgbtRed) div 3;
rgbtGreen := rgbtBlue;
rgbtRed := rgbtBlue;
end;
end;
begin
sl := PRGBLine( Picture.Scanline[Picture.Height-1] );
for x := 0 to Picture.Width*Picture.Height-1 do
_Gray( sl^[x] );
end;
//hautpfunktion
procedure Sobel(var Picture: TBitmap; const EdgeWhite: Boolean = True);
type
T4 = -2..2;
const
xMatrix: Array[0..2, 0..2] of T4 =
( (-1, 0, 1),
(-2, 0, 2),
(-1, 0, 1 ) );
yMatrix: Array[0..2, 0..2] of T4 =
( (1, 2, 1),
( 0, 0, 0),
(-1, -2,-1) );
var
sl: PRGBLine;
x, y: Integer;
i, j: Integer;
sumX, sumY: Integer;
Data: Array of Array of Byte;
begin
Gray(Picture);
sl := PRGBLine( Picture.Scanline[Picture.Height-1] );
SetLength(Data, Picture.Width, Picture.Height);
for y := 0 to Picture.Height-1 do
for x := 0 to Picture.Width-1 do
Data[x,y] := sl^[y*Picture.Width+x].rgbtBlue;
for y := 0 to Picture.Height-1 do
for x := 0 to Picture.Width-1 do
begin
sumX := 0;
sumY := 0;
for i := -1 to 1 do
for j := -1 to 1 do
begin
inc( sumX, Data[fValInRange(x+i, 0, Picture.Width-1),fValInRange(y+j, 0, Picture.Height-1)]*xMatrix[i+1,j+1] );
inc( sumY, Data[fValInRange(x+i, 0, Picture.Width-1),fValInRange(y+j, 0, Picture.Height-1)]*yMatrix[i+1,j+1] );
end;
sumX := Abs(sumX)+Abs(sumY);
pValInRange( sumX, 0, $FF );
with sl^[y*picture.Width+x] do
begin
if EdgeWhite then
rgbtBlue := sumX
else
rgbtBlue := $FF-sumX;
rgbtGreen := rgbtBlue;
rgbtRed := rgbtBlue;
end;
end;
end;
end.
轉貼至 http://www.delphipraxis.net/post995075.html
interface
uses graphics;
type
PRGBTriple = ^TRGBTriple;
TRGBTriple = packed Record
rgbtBlue: Byte;
rgbtGreen: Byte;
rgbtRed: Byte;
End;
PRGBLine = ^TRGBLine;
TRGBLine = Array[0..0] of TRGBTriple;
procedure Sobel(var Picture: TBitmap; const EdgeWhite: Boolean = True);
implementation
procedure pValInRange( var Val: Integer; const cFrom, cTo: Integer );
begin
if Val > cTo then
Val := cTo
else
if Val < cFrom then
Val := cFrom;
end;
function fValInRange( Val: Integer; const cFrom, cTo: Integer ): Integer;
begin
if Val > cTo then
Result := cTo
else
if Val < cFrom then
Result := cFrom
else
Result := Val;
end;
//nebenfunktion
procedure Gray(var Picture: TBitmap);
var
sl: PRGBLine;
x: Integer;
procedure _Gray(var rgbt: TRGBTriple );
begin
with rgbt do
begin
{weiß}
rgbtBlue := (rgbtBlue+rgbtGreen+rgbtRed) div 3;
rgbtGreen := rgbtBlue;
rgbtRed := rgbtBlue;
end;
end;
begin
sl := PRGBLine( Picture.Scanline[Picture.Height-1] );
for x := 0 to Picture.Width*Picture.Height-1 do
_Gray( sl^[x] );
end;
//hautpfunktion
procedure Sobel(var Picture: TBitmap; const EdgeWhite: Boolean = True);
type
T4 = -2..2;
const
xMatrix: Array[0..2, 0..2] of T4 =
( (-1, 0, 1),
(-2, 0, 2),
(-1, 0, 1 ) );
yMatrix: Array[0..2, 0..2] of T4 =
( (1, 2, 1),
( 0, 0, 0),
(-1, -2,-1) );
var
sl: PRGBLine;
x, y: Integer;
i, j: Integer;
sumX, sumY: Integer;
Data: Array of Array of Byte;
begin
Gray(Picture);
sl := PRGBLine( Picture.Scanline[Picture.Height-1] );
SetLength(Data, Picture.Width, Picture.Height);
for y := 0 to Picture.Height-1 do
for x := 0 to Picture.Width-1 do
Data[x,y] := sl^[y*Picture.Width+x].rgbtBlue;
for y := 0 to Picture.Height-1 do
for x := 0 to Picture.Width-1 do
begin
sumX := 0;
sumY := 0;
for i := -1 to 1 do
for j := -1 to 1 do
begin
inc( sumX, Data[fValInRange(x+i, 0, Picture.Width-1),fValInRange(y+j, 0, Picture.Height-1)]*xMatrix[i+1,j+1] );
inc( sumY, Data[fValInRange(x+i, 0, Picture.Width-1),fValInRange(y+j, 0, Picture.Height-1)]*yMatrix[i+1,j+1] );
end;
sumX := Abs(sumX)+Abs(sumY);
pValInRange( sumX, 0, $FF );
with sl^[y*picture.Width+x] do
begin
if EdgeWhite then
rgbtBlue := sumX
else
rgbtBlue := $FF-sumX;
rgbtGreen := rgbtBlue;
rgbtRed := rgbtBlue;
end;
end;
end;
end.
轉貼至 http://www.delphipraxis.net/post995075.html
如何自動註冊Midas.DLL
D7 版本, 只要 USES MIDASLIB 即可, 就不用註冊 MIDAS.DLL 了
轉貼:http://delphi.ktop.com.tw/board.php?cid=30&fid=68&tid=26133
轉貼:http://delphi.ktop.com.tw/board.php?cid=30&fid=68&tid=26133
如何以Code叫出AdoConnection.ConnectionString的編修畫面來
uses ADOConEd;
{$R *.DFM}
procedure TForm1.Button1Click(Sender: TObject);
begin
EditConnectionString(ADOConnection1);
end;
轉貼: http://delphi.ktop.com.tw/board.php?cid=30&fid=66&tid=58392
{$R *.DFM}
procedure TForm1.Button1Click(Sender: TObject);
begin
EditConnectionString(ADOConnection1);
end;
轉貼: http://delphi.ktop.com.tw/board.php?cid=30&fid=66&tid=58392
如何清空鍵盤的緩衝區(Buffer)
如何清空鍵盤的緩衝區(Buffer)?
可用於進入某個輸入的TFrom前清空Keyboard Buffer,以免誤輸入錯誤的資料!
procedure EmptyKeyQueue;
var msg: TMsg;
begin
while PeekMessage(msg, 0, WM_KEYFIRST, WM_KEYLAST, PM_REMOVE or PM_NOYIELD) do;
end;
轉貼至:http://delphi.ktop.com.tw/board.php?cid=16&fid=49&tid=18231
可用於進入某個輸入的TFrom前清空Keyboard Buffer,以免誤輸入錯誤的資料!
procedure EmptyKeyQueue;
var msg: TMsg;
begin
while PeekMessage(msg, 0, WM_KEYFIRST, WM_KEYLAST, PM_REMOVE or PM_NOYIELD) do;
end;
轉貼至:http://delphi.ktop.com.tw/board.php?cid=16&fid=49&tid=18231
搜尋目錄內的檔案名稱
var sSourcePath:String;
iSearchRec: TSearchRec;
iStatus: Integer;
begin
sSourcePath := 'C:';
iStatus := FindFirst(sSourcePath+'\*.*', faAnyFile, iSearchRec);
try
while iStatus = 0 do
begin
if ((iSearchRec.Attr and faDirectory) <> faDirectory) and //非目錄
((iSearchRec.Attr and faHidden)<>faHidden) and //非隱藏檔
((iSearchRec.Attr and faSysFile)<>faSysFile) and //非系統檔
(iSearchRec.Name <> '.') and
(iSearchRec.Name <> '..') then
begin
...
...
end;
iStatus := FindNext(iSearchRec);
end;
Finally
FindClose(iSearchRec);
end;
end
iSearchRec: TSearchRec;
iStatus: Integer;
begin
sSourcePath := 'C:';
iStatus := FindFirst(sSourcePath+'\*.*', faAnyFile, iSearchRec);
try
while iStatus = 0 do
begin
if ((iSearchRec.Attr and faDirectory) <> faDirectory) and //非目錄
((iSearchRec.Attr and faHidden)<>faHidden) and //非隱藏檔
((iSearchRec.Attr and faSysFile)<>faSysFile) and //非系統檔
(iSearchRec.Name <> '.') and
(iSearchRec.Name <> '..') then
begin
...
...
end;
iStatus := FindNext(iSearchRec);
end;
Finally
FindClose(iSearchRec);
end;
end
設定報表內的表格框(QRShape) 與 動態高度的Band 同高度
QRShape.Size.Height := ChildBand.Size.Height + ChildBand.Expanded;
ChildBand.Size.Height 與 ChildBand.Expanded取得的是圖像點數
圖像點數*0.37795(QuickRpt裡pixfactor記錄的系數)=屬性中的高度(Height)
ChildBand.Size.Height 與 ChildBand.Expanded取得的是圖像點數
圖像點數*0.37795(QuickRpt裡pixfactor記錄的系數)=屬性中的高度(Height)
取得、變更預設印表機
uses
Printers, Messages;
//取得預設印表機資訊
function GetDefaultPrinter: string;
var
ResStr: array[0..255] of Char;
begin
GetProfileString('Windows', 'device', '', ResStr, 255);
Result := StrPas(ResStr);
end;
//設定預設印表機, 使用GetDefaultPrinter取得的印表機完整資訊來變更
//參數字串已含有Port的資訊
procedure SetDefaultPrinter1(NewDefPrinter: string);
var
ResStr: array[0..255] of Char;
begin
StrPCopy(ResStr, NewdefPrinter);
WriteProfileString('windows', 'device', ResStr);
StrCopy(ResStr, 'windows');
SendMessage(HWND_BROADCAST, WM_WININICHANGE, 0, Longint(@ResStr));
end;
//設定預設印表機, 取Printer.Printers裡的印表機名稱來變更
//參數字串只有印表機名稱
procedure SetDefaultPrinter2(PrinterName: string);
var
I: Integer;
Device: PChar;
Driver: PChar;
Port: PChar;
HdeviceMode: THandle;
aPrinter: TPrinter;
begin
Printer.PrinterIndex := -1;
GetMem(Device, 255);
GetMem(Driver, 255);
GetMem(Port, 255);
aPrinter := TPrinter.Create;
try
for I := 0 to Printer.Printers.Count - 1 do
begin
if Printer.Printers[I] = PrinterName then
begin
aprinter.PrinterIndex := I;
aPrinter.getprinter(device, driver, port, HdeviceMode);
StrCat(Device, ',');
StrCat(Device, Driver);
StrCat(Device, Port);
WriteProfileString('windows', 'device', Device);
StrCopy(Device, 'windows');
SendMessage(HWND_BROADCAST, WM_WININICHANGE, 0, Longint(@Device));
end;
end;
finally
aPrinter.Free;
end;
FreeMem(Device, 255);
FreeMem(Driver, 255);
FreeMem(Port, 255);
end;
procedure TForm1.Button1Click(Sender: TObject);
begin
label1.Caption := GetDefaultPrinter;
end;
//Fill the combobox with all available printers
procedure TForm1.FormCreate(Sender: TObject);
begin
Combobox1.Items.Clear;
Combobox1.Items.AddStrings(Printer.Printers);
end;
//Set the selected printer in the combobox as default printer
procedure TForm1.Button2Click(Sender: TObject);
begin
SetDefaultPrinter2(Combobox1.Text);
end;
轉貼至http://www.swissdelphicenter.ch/en/showcode.php?id=660
Printers, Messages;
//取得預設印表機資訊
function GetDefaultPrinter: string;
var
ResStr: array[0..255] of Char;
begin
GetProfileString('Windows', 'device', '', ResStr, 255);
Result := StrPas(ResStr);
end;
//設定預設印表機, 使用GetDefaultPrinter取得的印表機完整資訊來變更
//參數字串已含有Port的資訊
procedure SetDefaultPrinter1(NewDefPrinter: string);
var
ResStr: array[0..255] of Char;
begin
StrPCopy(ResStr, NewdefPrinter);
WriteProfileString('windows', 'device', ResStr);
StrCopy(ResStr, 'windows');
SendMessage(HWND_BROADCAST, WM_WININICHANGE, 0, Longint(@ResStr));
end;
//設定預設印表機, 取Printer.Printers裡的印表機名稱來變更
//參數字串只有印表機名稱
procedure SetDefaultPrinter2(PrinterName: string);
var
I: Integer;
Device: PChar;
Driver: PChar;
Port: PChar;
HdeviceMode: THandle;
aPrinter: TPrinter;
begin
Printer.PrinterIndex := -1;
GetMem(Device, 255);
GetMem(Driver, 255);
GetMem(Port, 255);
aPrinter := TPrinter.Create;
try
for I := 0 to Printer.Printers.Count - 1 do
begin
if Printer.Printers[I] = PrinterName then
begin
aprinter.PrinterIndex := I;
aPrinter.getprinter(device, driver, port, HdeviceMode);
StrCat(Device, ',');
StrCat(Device, Driver);
StrCat(Device, Port);
WriteProfileString('windows', 'device', Device);
StrCopy(Device, 'windows');
SendMessage(HWND_BROADCAST, WM_WININICHANGE, 0, Longint(@Device));
end;
end;
finally
aPrinter.Free;
end;
FreeMem(Device, 255);
FreeMem(Driver, 255);
FreeMem(Port, 255);
end;
procedure TForm1.Button1Click(Sender: TObject);
begin
label1.Caption := GetDefaultPrinter;
end;
//Fill the combobox with all available printers
procedure TForm1.FormCreate(Sender: TObject);
begin
Combobox1.Items.Clear;
Combobox1.Items.AddStrings(Printer.Printers);
end;
//Set the selected printer in the combobox as default printer
procedure TForm1.Button2Click(Sender: TObject);
begin
SetDefaultPrinter2(Combobox1.Text);
end;
轉貼至http://www.swissdelphicenter.ch/en/showcode.php?id=660
設定Caps Lock ON或OFF
==================================================
procedure SetCapsLockKey( vcode: Integer; down: Boolean );
begin
if Odd(GetAsyncKeyState( vcode )) <> down then
begin
keybd_event( vcode, MapVirtualkey( vcode, 0 ),
KEYEVENTF_EXTENDEDKEY, 0);
keybd_event( vcode, MapVirtualkey( vcode, 0 ),
KEYEVENTF_EXTENDEDKEY or KEYEVENTF_KEYUP, 0);
end;
end;
===================================================
在BUTTOM1之Click事件中加入以下：
SetcapsLockKey( VK_CAPITAL, True );
如此按下按鈕就可設定CAPS LOCK啟動或是關閉
轉貼至 http://delphi.ktop.com.tw/board.php?cid=16&fid=43&tid=355
procedure SetCapsLockKey( vcode: Integer; down: Boolean );
begin
if Odd(GetAsyncKeyState( vcode )) <> down then
begin
keybd_event( vcode, MapVirtualkey( vcode, 0 ),
KEYEVENTF_EXTENDEDKEY, 0);
keybd_event( vcode, MapVirtualkey( vcode, 0 ),
KEYEVENTF_EXTENDEDKEY or KEYEVENTF_KEYUP, 0);
end;
end;
===================================================
在BUTTOM1之Click事件中加入以下：
SetcapsLockKey( VK_CAPITAL, True );
如此按下按鈕就可設定CAPS LOCK啟動或是關閉
轉貼至 http://delphi.ktop.com.tw/board.php?cid=16&fid=43&tid=355
Hook簡介
http://www.bravos.com.tw/big5/tutor/Profession/Hook/
Hook簡介
MSDN的定義:
A hook is a point in the system message-handling mechanism where an application can install a subroutine to monitor the message traffic in the system and process certain types of messages before they reach the target window procedure.
Hook應用簡介:
Hook是用來與作業系統掛勾進而攔截並處理某些訊息之用。
例如說，我們想讓系統不管在什麼地方只要按個Ctl-N便執行NotePad，或許您會使用Form的KeyPreview，設定為True，但在其他Process中按Ctl-N呢？那就沒有用，這是就得設一個KeyboardProc來攔截所有Key in的鍵；
再如：線上翻譯軟體(如：易點通) 應用Hook功能中WH_MOUSE的來欄截Mouse的訊息。進而解析滑鼠所在位置的string token以便由資料庫中萃取對應的翻譯字句。
再如：UltraEditor中錄製巨集功能即使用Hook功能中的WH_JOURNALRECORD，執行巨集功能，即使用Hook功能中的WH_JOURNALPLAYBACK；
再如：ICQ會在User不輸入滑鼠或鍵盤idle一陣子時將User由Online的狀態變成Away的狀態。其內部即應用Hook功能中的WH_MOUSE, WH_KEYBOARD 以攔截所有Mouse及Keyboard動作。
Hook可以是整個系統為範圍(Remote Hook)，即其他Process的動作您也可以攔截，也可以是LocalHook，它的攔截範圍只有Process本身。Remote Hook的Hook Function要在.Dll之中，Local Hook則可包含在專案模組中。
Remote Hook的應用實例，線上翻譯軟體(如：易點通)、鍵盤輸入法(如：自然輸入法)，熱鍵攔截(如：TurboLaunch)。
由上數列舉可知Hook的應用幾乎是無所不在的，您能禁得起這般強悍的功能而不去學習它嗎?
轉載網路上一篇關於hook有趣的描述:
hook鉤子也，windows是訊息導向的，當有事情發生時windows會發出通知告訴你，像"失火了","房子倒了"之類的，於是你對這些訊息做出 反應，windows程式大概就是這種架構。而hook的用處就是可以在windows送訊息給你的時候把訊息攔截下來。
你可以想像你的程式是皇帝，而windows是宰相，而hook是太監；如果話是從宰相口中親耳聽到的八成假不了，如果話是太監口中聽到的，說不定就變質 了，hook的功用就是在這裡，所以你可以寫一個文字編輯器，然後掛上一個hook，並且用這個hook把鍵盤訊息攔截下來，然後把它丟掉，於是你的文字 編輯器就沒有作用了，所以說宦官能搞亂朝政。
當然大部分人不會做這總傻事，大部分寫hook都是為了攔截整個系統的訊息或是假裝訊息給別人，這個時候你就必須把hook寫在dll裡了，然後用你的程 式啟動dll裡的hook，由於dll會載入到所有的人的行程裡，所以你就可以利用她偷竊別人的東西或是假傳聖旨，例如你可以抓別人的視窗handle然 後用你的程式對她丟訊息，比較值得注意的是，在dll裡你必須將要用來共享的資料設成shared，這樣才能去抓別的程式的資料，因為dll雖然存在於每 個人的行程裡，但是資料都是獨立的，也就是每個人都有一分，如果你把用來共享的資料設成shared，那這筆記憶體區塊就只有一份，於是就可以拿來偷東西 了
Hook程式必備的API
l
SetWindowsHookEx
The SetWindowsHookEx function installs an application-defined hook procedure into a hook chain. You would install a hook procedure to monitor the system for certain types of events. These events are associated either with a specific thread or with all threads in the system.
HHOOK SetWindowsHookEx(
int idHook,
hook型態,常用型態例如：WH_CALLWNDPROC
HOOKPROC lpfn,
自訂的hook procedure 之回呼函式,其prototype會依idHook(hook型態)而異
HINSTANCE hMod,
應用程式或DLL之instance
如果是Remote Hook，則可以使用GetModuleHandle(".dll名稱")來傳入。
如果是Local Hook，該值可以是NULL
DWORD dwThreadId);
指定要攔截訊息之thread ID,若為0則攔截系統中所有thread之訊息
回傳值:
如果SetWindowsHookEx()成功，它會傳回一個值，代表目前的Hook的Handle，這個值要記錄下來以提供UnHookWindowHookEx() (可用於 unhook時之參數)
l
UnhookWindowsHookEx
釋放移除先前經由SetWindowsHookEx()所註冊的hook handle resource.
BOOL UnhookWindowsHookEx(HHOOK hHook);
hHook,
便是SetWindowsHookEx()的傳回值
l
CallNextHookEx
The CallNextHookEx function passes the hook information to the next hook procedure in the current hook chain. A hook procedure can call this function either before or after processing the hook information.
LRESULT CallNextHookEx(
HHOOK hHook,
handle to current hook
int nCode,
hook code passed to hook procedure
WPARAM wParam,
value passed to hook procedure
LPARAM lParam);
value passed to hook procedure
CallNextHookEx 使用時機:
例如A程式可以有一個System Hook(Remote Hook)，如KeyBoard Hook，而B程式也來設一個Remote的KeyBoard Hook，那麼到底KeyBoard的訊息誰所攔截？答案是，最後的那一個所攔截，也就是說A先做keyboard Hook，而後B才做，那訊息被B攔截，那A呢？就看B的Hook Function如何做。如果B想讓A的Hook Function也得這個訊息，那B就得呼叫CallNextHookEx()將這訊息Pass給A，於是產生Hook的一個連線。如果B中不想Pass 這訊息給A，那就不要呼叫CallNextHookEx()。
Hook-C++範例
本範例利用Hook技巧以攔截Microsoft Visual C++ Dialog Box，因為此為Remote Hook故需以DLL包裝
// HookVc.DLL
// 本模組開放兩個介面函式供外部程式呼叫
// * HookVcWndProc() ==> 啟動攔截 VC 的視窗訊息
// * UnHookVcWndProc() ==> 終止攔截 VC 的視窗訊息
HINSTANCE g_hInst = NULL;
static HWND s_hWndVc = NULL; // VC 的 Window Handle
static HHOOK s_hHook = NULL; // Hook Handle ID
int WINAPI DllEntryPoint(HINSTANCE hinst, unsigned long reason, void*)
{
g_hInst = hinst;
return 1;
}
BOOL HookVcWndProc()
{
// 找出VC主視窗 Window Handle
EnumWindows((WNDENUMPROC)EnumWindowsProc, NULL);
DWORD dwVcThreadId;
if (s_hWndVc && g_hInst) {
// 找出產生VC主視窗的ThreadID
dwVcThreadId = GetWindowThreadProcessId(s_hWndVc, NULL);
if (dwVcThreadId)
// 於系統Send Message給VC處理後攔截
s_hHook=SetWindowsHookEx(WH_CALLWNDPROCRET,
(HOOKPROC)CallWndRetProcHook, // 自訂的hook procedure之回呼函式
g_hInst, // this Dll's instance
dwVcThreadId); // thread you want to hook, here it's VC
if (s_hHook) return TRUE; // 啟動攔截 VC 的視窗訊息成功
}
return FALSE; // 啟動攔截 VC 的視窗訊息失敗
} // HookVcWndProc
void UnHookVcWndProc()
{
if (s_hHook) {
UnhookWindowsHookEx(s_hHook); s_hHook = NULL ;
}
} // UnHookVcWndProc
// 自訂的hook procedure之回呼函式
// nCode: 若 nCode<0 ==>不處理
// lParam: Pointer to CWPRETSTRUCT, 訊息詳細資料
LRESULT CALLBACK CallWndRetProcHook(int nCode, WPARAM wParam, LPARAM lParam)
{
// Buffer for storing the window title.
TCHAR szBuff[ MAX_PATH ] ;
// 傳遞訊息給可能存在的下一個 Hook procedure
LRESULT lRet=CallNextHookEx(s_hHook, nCode, wParam, lParam);
// 若 nCode<0 ==>不繼續處理 (請參照 MSDN 'HOOKPROC', 'CallWndRetProc'文件說明)
if ( nCode < 0 ) return lRet;
// 取得訊息詳細資料 CWPRETSTRUCT *
PCWPRETSTRUCT pMsg = (PCWPRETSTRUCT)lParam;
// 以下利用 pMsg->hwnd, pMsg->message, pMsg->wParam, pMsg->lParam繼續處理
// ...
return lRet;
} // CallWndRetProcHook
Hook-Delphi範例
使用過ICQ嗎？ICQ會在User不輸入滑鼠或鍵盤idle一陣子時將User由Online的狀態變成Away的狀態。本範例利用Hook型態 WH_MOUSE, WH_KEYBOARD 以攔截所有Mouse及Keyboard動作。當使用者於預定時限當中不輸入滑鼠或鍵盤時，本元件會觸發一個OnIdle notify event
l
TBvIdleCheck元件功能描述:
A user idle chekcing Component, apply the mouse/keyboard hook callback to check user idle time on application level.
當使用者於預定時限當中不輸入滑鼠或鍵盤時，本元件會觸發一個OnIdle notify event
l
Properties
Active:
true èstart check, false èstop check
Interval:
Idle checking pooling time frequency (in second)
IdleTime:
Define the IdleTime criteria (in second)
l
Notify Event:
OnIdle:
notify event happened when user mouse and keyboard idle time out
程式碼片段:
// Mouse Hook 回呼函數內容
function MouseHookCallBack(Code: integer; Msg: WPARAM; MouseHook: LPARAM): LRESULT; stdcall;
begin
if Code >= 0 then s_tIoEvent := Now; // 紀錄 Mouse IO 時發生之時間
Result := CallNextHookEx(s_WhMouse, Code, Msg, MouseHook);
end;
// Keyboard Hook 回呼函數內容
function KeyboardHookCallBack(Code: integer; Msg: WPARAM; KeyboardHook: LPARAM): LRESULT; stdcall;
begin
if Code >= 0 then s_tIoEvent := Now; // 紀錄 Keyboard IO 時發生之時間
Result := CallNextHookEx(s_WhKeyboard, Code, Msg, KeyboardHook);
end;
// Construtor
constructor TBvIdleCheck.Create(AOwner: TComponent);
begin //[
inherited Create(AOwner);
....
Inc(s_nInstances);
if s_nInstances > 1 then exit;
// 註冊 Mouse Hook 回呼函數
s_WhMouse := SetWindowsHookEx(WH_MOUSE, MouseHookCallBack, GetModuleHandleFromInstance, GetCurrentThreadID);
// 註冊 Keyboard Hook 回呼函數
s_WhKeyboard := SetWindowsHookEx(WH_KEYBOARD, KeyboardHookCallBack, GetModuleHandleFromInstance, GetCurrentThreadID);
end; // ] TBvIdleCheck.Create
// Destructor
destructor TBvIdleCheck.Destroy;
begin // [
Dec(s_nInstances);
Stop;
if s_nInstances = 0 then begin
// 釋放 hook handle
UnhookWindowsHookEx(s_WhKeyboard); UnhookWindowsHookEx(s_WhMouse);
end;
inherited Destroy;
end; // ] TBvIdleCheck.Destroy
// 元件內部檢查 user 是否 idle,
// if yes ==> 觸發 Notify Event
procedure TBvIdleCheck._TimeHit(Sender: TObject);
var
tNow: TDateTime;
nSecElapsed: integer;
begin // [
tNow=Now;
nSecElapsed=TimeDiffSec(tNow, s_tIoEvent);
if nSecElapsed
if Assigned(FOnIdle) then FOnIdle(Sender);
s_tIoEvent:=tNow;
end; // ] TBvIdleCheck._TimeHit
Hook-VB範例
本範例展示在VB中利用Hook技巧以攔截應用程式中User按下Print Screen按鍵，因為此為Local Hook故可直接含於project中
' ======================================================================
' HookKb.BAS
' KeyBoard Hook 的範例
' ======================================================================
Declare Function SetWindowsHookEx Lib "user32" Alias "SetWindowsHookExA" _
(ByVal idHook As Long, _
ByVal lpfn As Long, _
ByVal hmod As Long, _
ByVal dwThreadId As Long) As Long
Declare Function UnhookWindowsHookEx Lib "user32" Alias "UnhookWindowsHookEx" _
(ByVal hHook As Long) As Long
Declare Function CallNextHookEx Lib "user32" Alias "CallNextHookEx" _
(ByVal hHook As Long, _
ByVal ncode As Long, _
ByVal wParam As Long, _
lParam As Any) As Long
Public g_hHook as Long
Public Function HookAppKb() As Boolean
HookAppKb = true
If g_hHook <> 0 Then
Exit Function
End If
' 攔截所有keystroke訊息
g_hHook = SetWindowsHookEx(WH_KEYBOARD, AddressOf MyKBHFunc, App.hInstance, App.ThreadId)
End Function
Public Sub UnHookAppKb()
If g_hHook <> 0 Then
UnhookWindowsHookEx g_hHook
g_hHook = 0
End If
End Sub
' MyKBHFunc: KeyStroke Hook Function的三個參數
' Public Function MyKBHFunc(ByVal iCode As Long, ByVal wParam As Long, ByVal lParam As Long) As Long
' iCode HC_ACTION或HC_NOREMOVE
' wParam 表按鍵Virtual Key
' lParam 與WM_KEYDOWN同
' 傳回值 若訊息要被處理傳0反之傳1
Public Function MyKBHFunc(ByVal iCode As Long, ByVal wParam As Long, ByVal lParam As Long) As Long
MyKBHfunc = 0 '表示要處理這個訊息
If wParam = vbKeySnapshot Then '偵測-->若按到PrintScreen鍵
MyKBHFunc = 1 '在這個Hook便吃掉這個訊息
' 處理 User 按到PrintScreen鍵之動作
' ....
Exit Function
End If
Call CallNextHookEx(g_hHook, iCode, wParam, lParam) '傳給下一個Hook
End Function
下載本範例: http:/dn/tutor/Delphi.Advance/HookKb.zip
轉貼至 Delphi.KTop http://delphi.ktop.com.tw/board.php?cid=31&fid=77&tid=47170
Hook簡介
MSDN的定義:
A hook is a point in the system message-handling mechanism where an application can install a subroutine to monitor the message traffic in the system and process certain types of messages before they reach the target window procedure.
Hook應用簡介:
Hook是用來與作業系統掛勾進而攔截並處理某些訊息之用。
例如說，我們想讓系統不管在什麼地方只要按個Ctl-N便執行NotePad，或許您會使用Form的KeyPreview，設定為True，但在其他Process中按Ctl-N呢？那就沒有用，這是就得設一個KeyboardProc來攔截所有Key in的鍵；
再如：線上翻譯軟體(如：易點通) 應用Hook功能中WH_MOUSE的來欄截Mouse的訊息。進而解析滑鼠所在位置的string token以便由資料庫中萃取對應的翻譯字句。
再如：UltraEditor中錄製巨集功能即使用Hook功能中的WH_JOURNALRECORD，執行巨集功能，即使用Hook功能中的WH_JOURNALPLAYBACK；
再如：ICQ會在User不輸入滑鼠或鍵盤idle一陣子時將User由Online的狀態變成Away的狀態。其內部即應用Hook功能中的WH_MOUSE, WH_KEYBOARD 以攔截所有Mouse及Keyboard動作。
Hook可以是整個系統為範圍(Remote Hook)，即其他Process的動作您也可以攔截，也可以是LocalHook，它的攔截範圍只有Process本身。Remote Hook的Hook Function要在.Dll之中，Local Hook則可包含在專案模組中。
Remote Hook的應用實例，線上翻譯軟體(如：易點通)、鍵盤輸入法(如：自然輸入法)，熱鍵攔截(如：TurboLaunch)。
由上數列舉可知Hook的應用幾乎是無所不在的，您能禁得起這般強悍的功能而不去學習它嗎?
轉載網路上一篇關於hook有趣的描述:
hook鉤子也，windows是訊息導向的，當有事情發生時windows會發出通知告訴你，像"失火了","房子倒了"之類的，於是你對這些訊息做出 反應，windows程式大概就是這種架構。而hook的用處就是可以在windows送訊息給你的時候把訊息攔截下來。
你可以想像你的程式是皇帝，而windows是宰相，而hook是太監；如果話是從宰相口中親耳聽到的八成假不了，如果話是太監口中聽到的，說不定就變質 了，hook的功用就是在這裡，所以你可以寫一個文字編輯器，然後掛上一個hook，並且用這個hook把鍵盤訊息攔截下來，然後把它丟掉，於是你的文字 編輯器就沒有作用了，所以說宦官能搞亂朝政。
當然大部分人不會做這總傻事，大部分寫hook都是為了攔截整個系統的訊息或是假裝訊息給別人，這個時候你就必須把hook寫在dll裡了，然後用你的程 式啟動dll裡的hook，由於dll會載入到所有的人的行程裡，所以你就可以利用她偷竊別人的東西或是假傳聖旨，例如你可以抓別人的視窗handle然 後用你的程式對她丟訊息，比較值得注意的是，在dll裡你必須將要用來共享的資料設成shared，這樣才能去抓別的程式的資料，因為dll雖然存在於每 個人的行程裡，但是資料都是獨立的，也就是每個人都有一分，如果你把用來共享的資料設成shared，那這筆記憶體區塊就只有一份，於是就可以拿來偷東西 了
Hook程式必備的API
l
SetWindowsHookEx
The SetWindowsHookEx function installs an application-defined hook procedure into a hook chain. You would install a hook procedure to monitor the system for certain types of events. These events are associated either with a specific thread or with all threads in the system.
HHOOK SetWindowsHookEx(
int idHook,
hook型態,常用型態例如：WH_CALLWNDPROC
HOOKPROC lpfn,
自訂的hook procedure 之回呼函式,其prototype會依idHook(hook型態)而異
HINSTANCE hMod,
應用程式或DLL之instance
如果是Remote Hook，則可以使用GetModuleHandle(".dll名稱")來傳入。
如果是Local Hook，該值可以是NULL
DWORD dwThreadId);
指定要攔截訊息之thread ID,若為0則攔截系統中所有thread之訊息
回傳值:
如果SetWindowsHookEx()成功，它會傳回一個值，代表目前的Hook的Handle，這個值要記錄下來以提供UnHookWindowHookEx() (可用於 unhook時之參數)
l
UnhookWindowsHookEx
釋放移除先前經由SetWindowsHookEx()所註冊的hook handle resource.
BOOL UnhookWindowsHookEx(HHOOK hHook);
hHook,
便是SetWindowsHookEx()的傳回值
l
CallNextHookEx
The CallNextHookEx function passes the hook information to the next hook procedure in the current hook chain. A hook procedure can call this function either before or after processing the hook information.
LRESULT CallNextHookEx(
HHOOK hHook,
handle to current hook
int nCode,
hook code passed to hook procedure
WPARAM wParam,
value passed to hook procedure
LPARAM lParam);
value passed to hook procedure
CallNextHookEx 使用時機:
例如A程式可以有一個System Hook(Remote Hook)，如KeyBoard Hook，而B程式也來設一個Remote的KeyBoard Hook，那麼到底KeyBoard的訊息誰所攔截？答案是，最後的那一個所攔截，也就是說A先做keyboard Hook，而後B才做，那訊息被B攔截，那A呢？就看B的Hook Function如何做。如果B想讓A的Hook Function也得這個訊息，那B就得呼叫CallNextHookEx()將這訊息Pass給A，於是產生Hook的一個連線。如果B中不想Pass 這訊息給A，那就不要呼叫CallNextHookEx()。
Hook-C++範例
本範例利用Hook技巧以攔截Microsoft Visual C++ Dialog Box，因為此為Remote Hook故需以DLL包裝
// HookVc.DLL
// 本模組開放兩個介面函式供外部程式呼叫
// * HookVcWndProc() ==> 啟動攔截 VC 的視窗訊息
// * UnHookVcWndProc() ==> 終止攔截 VC 的視窗訊息
HINSTANCE g_hInst = NULL;
static HWND s_hWndVc = NULL; // VC 的 Window Handle
static HHOOK s_hHook = NULL; // Hook Handle ID
int WINAPI DllEntryPoint(HINSTANCE hinst, unsigned long reason, void*)
{
g_hInst = hinst;
return 1;
}
BOOL HookVcWndProc()
{
// 找出VC主視窗 Window Handle
EnumWindows((WNDENUMPROC)EnumWindowsProc, NULL);
DWORD dwVcThreadId;
if (s_hWndVc && g_hInst) {
// 找出產生VC主視窗的ThreadID
dwVcThreadId = GetWindowThreadProcessId(s_hWndVc, NULL);
if (dwVcThreadId)
// 於系統Send Message給VC處理後攔截
s_hHook=SetWindowsHookEx(WH_CALLWNDPROCRET,
(HOOKPROC)CallWndRetProcHook, // 自訂的hook procedure之回呼函式
g_hInst, // this Dll's instance
dwVcThreadId); // thread you want to hook, here it's VC
if (s_hHook) return TRUE; // 啟動攔截 VC 的視窗訊息成功
}
return FALSE; // 啟動攔截 VC 的視窗訊息失敗
} // HookVcWndProc
void UnHookVcWndProc()
{
if (s_hHook) {
UnhookWindowsHookEx(s_hHook); s_hHook = NULL ;
}
} // UnHookVcWndProc
// 自訂的hook procedure之回呼函式
// nCode: 若 nCode<0 ==>不處理
// lParam: Pointer to CWPRETSTRUCT, 訊息詳細資料
LRESULT CALLBACK CallWndRetProcHook(int nCode, WPARAM wParam, LPARAM lParam)
{
// Buffer for storing the window title.
TCHAR szBuff[ MAX_PATH ] ;
// 傳遞訊息給可能存在的下一個 Hook procedure
LRESULT lRet=CallNextHookEx(s_hHook, nCode, wParam, lParam);
// 若 nCode<0 ==>不繼續處理 (請參照 MSDN 'HOOKPROC', 'CallWndRetProc'文件說明)
if ( nCode < 0 ) return lRet;
// 取得訊息詳細資料 CWPRETSTRUCT *
PCWPRETSTRUCT pMsg = (PCWPRETSTRUCT)lParam;
// 以下利用 pMsg->hwnd, pMsg->message, pMsg->wParam, pMsg->lParam繼續處理
// ...
return lRet;
} // CallWndRetProcHook
Hook-Delphi範例
使用過ICQ嗎？ICQ會在User不輸入滑鼠或鍵盤idle一陣子時將User由Online的狀態變成Away的狀態。本範例利用Hook型態 WH_MOUSE, WH_KEYBOARD 以攔截所有Mouse及Keyboard動作。當使用者於預定時限當中不輸入滑鼠或鍵盤時，本元件會觸發一個OnIdle notify event
l
TBvIdleCheck元件功能描述:
A user idle chekcing Component, apply the mouse/keyboard hook callback to check user idle time on application level.
當使用者於預定時限當中不輸入滑鼠或鍵盤時，本元件會觸發一個OnIdle notify event
l
Properties
Active:
true èstart check, false èstop check
Interval:
Idle checking pooling time frequency (in second)
IdleTime:
Define the IdleTime criteria (in second)
l
Notify Event:
OnIdle:
notify event happened when user mouse and keyboard idle time out
程式碼片段:
// Mouse Hook 回呼函數內容
function MouseHookCallBack(Code: integer; Msg: WPARAM; MouseHook: LPARAM): LRESULT; stdcall;
begin
if Code >= 0 then s_tIoEvent := Now; // 紀錄 Mouse IO 時發生之時間
Result := CallNextHookEx(s_WhMouse, Code, Msg, MouseHook);
end;
// Keyboard Hook 回呼函數內容
function KeyboardHookCallBack(Code: integer; Msg: WPARAM; KeyboardHook: LPARAM): LRESULT; stdcall;
begin
if Code >= 0 then s_tIoEvent := Now; // 紀錄 Keyboard IO 時發生之時間
Result := CallNextHookEx(s_WhKeyboard, Code, Msg, KeyboardHook);
end;
// Construtor
constructor TBvIdleCheck.Create(AOwner: TComponent);
begin //[
inherited Create(AOwner);
....
Inc(s_nInstances);
if s_nInstances > 1 then exit;
// 註冊 Mouse Hook 回呼函數
s_WhMouse := SetWindowsHookEx(WH_MOUSE, MouseHookCallBack, GetModuleHandleFromInstance, GetCurrentThreadID);
// 註冊 Keyboard Hook 回呼函數
s_WhKeyboard := SetWindowsHookEx(WH_KEYBOARD, KeyboardHookCallBack, GetModuleHandleFromInstance, GetCurrentThreadID);
end; // ] TBvIdleCheck.Create
// Destructor
destructor TBvIdleCheck.Destroy;
begin // [
Dec(s_nInstances);
Stop;
if s_nInstances = 0 then begin
// 釋放 hook handle
UnhookWindowsHookEx(s_WhKeyboard); UnhookWindowsHookEx(s_WhMouse);
end;
inherited Destroy;
end; // ] TBvIdleCheck.Destroy
// 元件內部檢查 user 是否 idle,
// if yes ==> 觸發 Notify Event
procedure TBvIdleCheck._TimeHit(Sender: TObject);
var
tNow: TDateTime;
nSecElapsed: integer;
begin // [
tNow=Now;
nSecElapsed=TimeDiffSec(tNow, s_tIoEvent);
if nSecElapsed
if Assigned(FOnIdle) then FOnIdle(Sender);
s_tIoEvent:=tNow;
end; // ] TBvIdleCheck._TimeHit
Hook-VB範例
本範例展示在VB中利用Hook技巧以攔截應用程式中User按下Print Screen按鍵，因為此為Local Hook故可直接含於project中
' ======================================================================
' HookKb.BAS
' KeyBoard Hook 的範例
' ======================================================================
Declare Function SetWindowsHookEx Lib "user32" Alias "SetWindowsHookExA" _
(ByVal idHook As Long, _
ByVal lpfn As Long, _
ByVal hmod As Long, _
ByVal dwThreadId As Long) As Long
Declare Function UnhookWindowsHookEx Lib "user32" Alias "UnhookWindowsHookEx" _
(ByVal hHook As Long) As Long
Declare Function CallNextHookEx Lib "user32" Alias "CallNextHookEx" _
(ByVal hHook As Long, _
ByVal ncode As Long, _
ByVal wParam As Long, _
lParam As Any) As Long
Public g_hHook as Long
Public Function HookAppKb() As Boolean
HookAppKb = true
If g_hHook <> 0 Then
Exit Function
End If
' 攔截所有keystroke訊息
g_hHook = SetWindowsHookEx(WH_KEYBOARD, AddressOf MyKBHFunc, App.hInstance, App.ThreadId)
End Function
Public Sub UnHookAppKb()
If g_hHook <> 0 Then
UnhookWindowsHookEx g_hHook
g_hHook = 0
End If
End Sub
' MyKBHFunc: KeyStroke Hook Function的三個參數
' Public Function MyKBHFunc(ByVal iCode As Long, ByVal wParam As Long, ByVal lParam As Long) As Long
' iCode HC_ACTION或HC_NOREMOVE
' wParam 表按鍵Virtual Key
' lParam 與WM_KEYDOWN同
' 傳回值 若訊息要被處理傳0反之傳1
Public Function MyKBHFunc(ByVal iCode As Long, ByVal wParam As Long, ByVal lParam As Long) As Long
MyKBHfunc = 0 '表示要處理這個訊息
If wParam = vbKeySnapshot Then '偵測-->若按到PrintScreen鍵
MyKBHFunc = 1 '在這個Hook便吃掉這個訊息
' 處理 User 按到PrintScreen鍵之動作
' ....
Exit Function
End If
Call CallNextHookEx(g_hHook, iCode, wParam, lParam) '傳給下一個Hook
End Function
下載本範例: http:/dn/tutor/Delphi.Advance/HookKb.zip
轉貼至 Delphi.KTop http://delphi.ktop.com.tw/board.php?cid=31&fid=77&tid=47170
TPopupMenu OnClose Event
Here's the source of the extended PopupList class you need to add to your projects in order to be able to respond when the popup menu is closed:
unit PopupListEx;
interface
uses Controls;
const
CM_MENU_CLOSED = CM_BASE + 1001;
CM_ENTER_MENU_LOOP = CM_BASE + 1002;
CM_EXIT_MENU_LOOP = CM_BASE + 1003;
implementation
uses Messages, Forms, Menus;
type TPopupListEx = class(TPopupList)
protected
procedure WndProc(var Message: TMessage) ; override;
private
procedure PerformMessage(cm_msg : integer; msg : TMessage) ;
end;
{ TPopupListEx }
procedure TPopupListEx.PerformMessage(cm_msg: integer; msg : TMessage) ;
begin
if Screen.Activeform <> nil then
Screen.ActiveForm.Perform(cm_msg, msg.WParam, msg.LParam) ;
end;
procedure TPopupListEx.WndProc(var Message: TMessage) ;
begin
case message.Msg of
WM_ENTERMENULOOP: PerformMessage(CM_ENTER_MENU_LOOP, Message) ;
WM_EXITMENULOOP : PerformMessage(CM_EXIT_MENU_LOOP, Message) ;
WM_MENUSELECT :
with TWMMenuSelect(Message) do
begin
if (Menu = 0) and (Menuflag = $FFFF) then
begin
PerformMessage(CM_MENU_CLOSED, Message) ;
end;
end;
end;
inherited;
end;
initialization;
Popuplist.Free; //free the "default", "old" list
PopupList:= TPopupListEx.Create; //create the new one
// The new PopupList will be freed by
// finalization section of Menus unit.
end.
Here's how to use the PopupListEx unit:
Drop a TPopupMenu on a Delphi form
Add several menu items to the PopupMenu
Include the "PopupListEx" in the uses clause
Write a procedure to handle PopupListEx's messages: CM_MENU_CLOSED, CM_ENTER_MENU_LOOP and CM_EXIT_MENU_LOOP
An example implementation (download):
uses PopupListEx, ...
TForm1 = class(TForm) ...
private
procedure CM_MenuClosed(var msg: TMessage) ; message CM_MENU_CLOSED;
procedure CM_EnterMenuLoop(var msg: TMessage) ; message CM_ENTER_MENU_LOOP;
procedure CM_ExitMenuLoop(var msg: TMessage) ; message CM_EXIT_MENU_LOOP; ...
implementation
procedure TForm1.CM_EnterMenuLoop(var msg: TMessage) ;
begin
Caption := 'PopMenu entered';
end;
procedure TForm1.CM_ExitMenuLoop(var msg: TMessage) ;
begin
Caption := 'PopMenu exited';
end;
procedure TForm1.CM_MenuClosed(var msg: TMessage) ;
begin
Caption := 'PopMenu closed';
end;
轉貼至 http://delphi.about.com/od/adptips2006/qt/popuplistex.htm
unit PopupListEx;
interface
uses Controls;
const
CM_MENU_CLOSED = CM_BASE + 1001;
CM_ENTER_MENU_LOOP = CM_BASE + 1002;
CM_EXIT_MENU_LOOP = CM_BASE + 1003;
implementation
uses Messages, Forms, Menus;
type TPopupListEx = class(TPopupList)
protected
procedure WndProc(var Message: TMessage) ; override;
private
procedure PerformMessage(cm_msg : integer; msg : TMessage) ;
end;
{ TPopupListEx }
procedure TPopupListEx.PerformMessage(cm_msg: integer; msg : TMessage) ;
begin
if Screen.Activeform <> nil then
Screen.ActiveForm.Perform(cm_msg, msg.WParam, msg.LParam) ;
end;
procedure TPopupListEx.WndProc(var Message: TMessage) ;
begin
case message.Msg of
WM_ENTERMENULOOP: PerformMessage(CM_ENTER_MENU_LOOP, Message) ;
WM_EXITMENULOOP : PerformMessage(CM_EXIT_MENU_LOOP, Message) ;
WM_MENUSELECT :
with TWMMenuSelect(Message) do
begin
if (Menu = 0) and (Menuflag = $FFFF) then
begin
PerformMessage(CM_MENU_CLOSED, Message) ;
end;
end;
end;
inherited;
end;
initialization;
Popuplist.Free; //free the "default", "old" list
PopupList:= TPopupListEx.Create; //create the new one
// The new PopupList will be freed by
// finalization section of Menus unit.
end.
Here's how to use the PopupListEx unit:
Drop a TPopupMenu on a Delphi form
Add several menu items to the PopupMenu
Include the "PopupListEx" in the uses clause
Write a procedure to handle PopupListEx's messages: CM_MENU_CLOSED, CM_ENTER_MENU_LOOP and CM_EXIT_MENU_LOOP
An example implementation (download):
uses PopupListEx, ...
TForm1 = class(TForm) ...
private
procedure CM_MenuClosed(var msg: TMessage) ; message CM_MENU_CLOSED;
procedure CM_EnterMenuLoop(var msg: TMessage) ; message CM_ENTER_MENU_LOOP;
procedure CM_ExitMenuLoop(var msg: TMessage) ; message CM_EXIT_MENU_LOOP; ...
implementation
procedure TForm1.CM_EnterMenuLoop(var msg: TMessage) ;
begin
Caption := 'PopMenu entered';
end;
procedure TForm1.CM_ExitMenuLoop(var msg: TMessage) ;
begin
Caption := 'PopMenu exited';
end;
procedure TForm1.CM_MenuClosed(var msg: TMessage) ;
begin
Caption := 'PopMenu closed';
end;
轉貼至 http://delphi.about.com/od/adptips2006/qt/popuplistex.htm
[轉貼]如何正確捕捉滑鼠及其原理(附範例)
在Win95, WinNT 的環境下, Microsoft為了避免行程間互相干擾,
對於使用者輸入的部份(如鍵盤, 滑鼠), 是採用一種叫"Local
Input State Processing"的方式, 這種技術簡單來說, 就是每個
行程, 執行緒, 認為自已是唯一取得使用者輸入的, 彼此之間並
不互相干擾(其實真正取得使用者輸入的只有 Active的行程或執行緒).
而我們最常用來抓取螢幕座標的 SetCapture , 是以System-Wide 的
型式來實作的, 所以就算滑鼠不在你的程式視窗範圍內, 也可以抓到
座標, 但是當你把滑鼠按鍵放開, 系統會改變滑鼠捕捉權, 使其為
Thread-Local-Wide, 此時就算你沒有使用 ReleaseCapture 來釋放
滑鼠捕捉權, 也無法在視窗範圍外捕捉滑鼠.這是因為 Local Input
State Processing 的關係. 若要解決這個問題, 最好的方法就是暫
時把 Local Input State Processing 的功能關閉, 而方式就是掛上
一個 Journal Record Hook, 在Win95, NT 下因為Local Input State
Processing 和 Journal Record Hook 會互相干擾, 而Microsoft為了
向下相容性所以當Journal Record Hook 被掛起來時, 就會把 Local
Input State Processin 給關閉.
範例貼在下一篇, 此測試程式會把攔截到的滑鼠座標以 Label1 秀出.
測試方法, 首先按下"SetCapture"按鈕, 在程式視窗範圍內, 按下滑鼠
左鍵不放, 將滑鼠移出程式視窗, 此時可以發現, 即使在程式視窗範圍
外還是可以捕捉到滑鼠. 之後把滑鼠左鍵放開, 在移動滑鼠, 可以發現,
在放開滑鼠左鍵後,即使我們沒有呼叫ReleaseCapture, 也無法捕捉到滑
鼠.
接下來我們按下"SetCapture with Journal Record Hook"按鈕, 按下後
首先程式會先呼叫SetCapture, 之後在掛上 Journal Record Hook, 而此
Hook 沒做什麼事, 只是把值傳給下一個Hook(CallNextHookEx), 在我們
按下這按鈕後, 無論怎麼移動滑鼠, 無論有沒有按下滑鼠左鍵, 都可以收
到滑鼠座標.
範例:
unit Unit1;
interface
uses
Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs,
StdCtrls;
type
TForm1 = class(TForm)
Label1: TLabel;
Button1: TButton;
Button2: TButton;
Button3: TButton;
Button4: TButton;
procedure Button1Click(Sender: TObject);
procedure Button2Click(Sender: TObject);
procedure Button3Click(Sender: TObject);
procedure Button4Click(Sender: TObject);
procedure FormCreate(Sender: TObject);
private
{ Private declarations }
Procedure HandleMouseMsg(var msg: TMessage); Message WM_MOUSEMOVE;
public
{ Public declarations }
end;
var
Form1: TForm1;
hJourHook: HHOOK;
implementation
{$R *.DFM}
Procedure TForm1.HandleMouseMsg(var msg: TMessage);
begin
Label1.Caption := Format( 'x=%d, y=%d',
[LOWORD(msg.Lparam), HIWORD(msg.Lparam)]);
Application.ProcessMessages;
end;
Function JournalRecordProc( code: Integer;
WParamInfo: WPARAM;
LParamInfo: LPARAM): Integer; stdcall;
begin
Result := CallNextHookEx(hJourHook, code, WParamInfo, LParamInfo);
end;
procedure TForm1.Button1Click(Sender: TObject);
begin
SetCapture(Handle);
SetWindowsHookEx(WH_JOURNALRECORD, @JournalRecordProc, HInstance, 0);
end;
procedure TForm1.Button2Click(Sender: TObject);
begin
ReleaseCapture();
UnhookWindowsHookEx(hJourHook);
end;
procedure TForm1.Button3Click(Sender: TObject);
begin
SetCapture(Handle);
end;
procedure TForm1.Button4Click(Sender: TObject);
begin
ReleaseCapture();
end;
procedure TForm1.FormCreate(Sender: TObject);
begin
Button1.Caption := 'SetCapture with Journal Record Hook';
Button2.Caption := 'ReleaseCapture with Journal Record Hook';
Button3.Caption := 'SetCapture';
Button4.Caption := 'ReleaseCapture';
end;
end.
轉貼至:http://delphi.ktop.com.tw/board.php?cid=30&fid=72&tid=58460
對於使用者輸入的部份(如鍵盤, 滑鼠), 是採用一種叫"Local
Input State Processing"的方式, 這種技術簡單來說, 就是每個
行程, 執行緒, 認為自已是唯一取得使用者輸入的, 彼此之間並
不互相干擾(其實真正取得使用者輸入的只有 Active的行程或執行緒).
而我們最常用來抓取螢幕座標的 SetCapture , 是以System-Wide 的
型式來實作的, 所以就算滑鼠不在你的程式視窗範圍內, 也可以抓到
座標, 但是當你把滑鼠按鍵放開, 系統會改變滑鼠捕捉權, 使其為
Thread-Local-Wide, 此時就算你沒有使用 ReleaseCapture 來釋放
滑鼠捕捉權, 也無法在視窗範圍外捕捉滑鼠.這是因為 Local Input
State Processing 的關係. 若要解決這個問題, 最好的方法就是暫
時把 Local Input State Processing 的功能關閉, 而方式就是掛上
一個 Journal Record Hook, 在Win95, NT 下因為Local Input State
Processing 和 Journal Record Hook 會互相干擾, 而Microsoft為了
向下相容性所以當Journal Record Hook 被掛起來時, 就會把 Local
Input State Processin 給關閉.
範例貼在下一篇, 此測試程式會把攔截到的滑鼠座標以 Label1 秀出.
測試方法, 首先按下"SetCapture"按鈕, 在程式視窗範圍內, 按下滑鼠
左鍵不放, 將滑鼠移出程式視窗, 此時可以發現, 即使在程式視窗範圍
外還是可以捕捉到滑鼠. 之後把滑鼠左鍵放開, 在移動滑鼠, 可以發現,
在放開滑鼠左鍵後,即使我們沒有呼叫ReleaseCapture, 也無法捕捉到滑
鼠.
接下來我們按下"SetCapture with Journal Record Hook"按鈕, 按下後
首先程式會先呼叫SetCapture, 之後在掛上 Journal Record Hook, 而此
Hook 沒做什麼事, 只是把值傳給下一個Hook(CallNextHookEx), 在我們
按下這按鈕後, 無論怎麼移動滑鼠, 無論有沒有按下滑鼠左鍵, 都可以收
到滑鼠座標.
範例:
unit Unit1;
interface
uses
Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs,
StdCtrls;
type
TForm1 = class(TForm)
Label1: TLabel;
Button1: TButton;
Button2: TButton;
Button3: TButton;
Button4: TButton;
procedure Button1Click(Sender: TObject);
procedure Button2Click(Sender: TObject);
procedure Button3Click(Sender: TObject);
procedure Button4Click(Sender: TObject);
procedure FormCreate(Sender: TObject);
private
{ Private declarations }
Procedure HandleMouseMsg(var msg: TMessage); Message WM_MOUSEMOVE;
public
{ Public declarations }
end;
var
Form1: TForm1;
hJourHook: HHOOK;
implementation
{$R *.DFM}
Procedure TForm1.HandleMouseMsg(var msg: TMessage);
begin
Label1.Caption := Format( 'x=%d, y=%d',
[LOWORD(msg.Lparam), HIWORD(msg.Lparam)]);
Application.ProcessMessages;
end;
Function JournalRecordProc( code: Integer;
WParamInfo: WPARAM;
LParamInfo: LPARAM): Integer; stdcall;
begin
Result := CallNextHookEx(hJourHook, code, WParamInfo, LParamInfo);
end;
procedure TForm1.Button1Click(Sender: TObject);
begin
SetCapture(Handle);
SetWindowsHookEx(WH_JOURNALRECORD, @JournalRecordProc, HInstance, 0);
end;
procedure TForm1.Button2Click(Sender: TObject);
begin
ReleaseCapture();
UnhookWindowsHookEx(hJourHook);
end;
procedure TForm1.Button3Click(Sender: TObject);
begin
SetCapture(Handle);
end;
procedure TForm1.Button4Click(Sender: TObject);
begin
ReleaseCapture();
end;
procedure TForm1.FormCreate(Sender: TObject);
begin
Button1.Caption := 'SetCapture with Journal Record Hook';
Button2.Caption := 'ReleaseCapture with Journal Record Hook';
Button3.Caption := 'SetCapture';
Button4.Caption := 'ReleaseCapture';
end;
end.
轉貼至:http://delphi.ktop.com.tw/board.php?cid=30&fid=72&tid=58460
等待外部執行檔結束作業後, 再繼續執行後續的程式碼
uses ShellAPI;
procedure TForm1.pr_WaitForProcess(sFile, sParameter:String);
var
ExitCode: cardinal;
ExecInfo: TShellExecuteInfo;
begin
ZeroMemory(@ExecInfo,SizeOf(ExecInfo));
with ExecInfo do
begin
cbSize := SizeOf(ExecInfo);
fMask := SEE_MASK_NOCLOSEPROCESS;
lpVerb := 'open';
lpFile := PChar(sFile); //執行檔檔名
lpParameters := PChar(sParameter); //參數
Wnd := 0;
nShow := SW_SHOWNORMAL;
end;
ShellExecuteEx(@ExecInfo);
GetExitCodeProcess(ExecInfo.hProcess,ExitCode);
while ExitCode=STILL_ACTIVE do
begin
GetExitCodeProcess(ExecInfo.hProcess, ExitCode);
sleep(10);
Application.ProcessMessages;
end;
end;
fatmoon1 對直接取用ShellExecute回傳值使用於WaiteforSingleObject的見解
引言:
引言:
procedure TForm1.Button1Click(Sender: TObject);
var
aHandle: Hwnd;
begin
//WinExec('D:\WinRAR\Rar.exe a -r E:\ShareFile.rar E:\ShareFile', SW_SHOWNORMAL);
aHandle := ShellExecute(Self.Handle, 'Open', 'rar.exe', ' a -r E:\ShareFile.rar E:\ShareFile', 'D:\WinRAR\', SW_SHOWNORMAL);
WaitForSingleObject(aHandle, INFINITE);
ShowMessage('成功!')
end;
雖然已經有正確解答了,但我針對上述方法會失敗的原因來回應
上述方法會失敗的原因是因為
aHandle:=ShellExecute(Self.Handle, 'Open', 'rar.exe', ' a -r E:\ShareFile.rar E:\ShareFile', 'D:\WinRAR\', SW_SHOWNORMAL);
如此的話aHandle只是存入ShellExecute的回傳值(成功的話回傳值會大於32)
所以WaitForSingleObject(aHandle, INFINITE);此行根本沒等到正確的Handle值
而WaitForSingleObject(hHandle: THandle; dwMilliseconds: DWORD);
這個函式的作用是 等候 hHandle(執行程式的Handle值) dwMilliseconds(ms)
所以經過dwMilliseconds(ms)後仍會執行下一行
所以要改寫成
var Result: Boolean;
ShellExInfo: TShellExecuteInfo;
begin
FillChar(ShellExInfo, SizeOf(ShellExInfo), 0);
with ShellExInfo do begin
cbSize := SizeOf(ShellExInfo);
fMask := see_Mask_NoCloseProcess;
Wnd := Application.Handle;
lpFile := 'D:\WinRAR\Rar.exe';
lpDirectory := 'D:\WinRAR\';
lpParameters := ' a -r E:\ShareFile.rar E:\ShareFile';
nShow := SW_SHOWNORMAL;
end;
//上述程式碼與william兄是一樣的,不一樣的在下方
Result := ShellExecuteEx(@ShellExInfo);
if Result then
while WaitForSingleObject(ShellExInfo.HProcess, 100) = WAIT_TIMEOUT do
begin
Application.ProcessMessages;
if Application.Terminated then Break;
end;
end;
=========================
fat eat moon,fat eat moon
轉貼至 http://delphi.ktop.com.tw/board.php?cid=30&fid=72&tid=38858
procedure TForm1.pr_WaitForProcess(sFile, sParameter:String);
var
ExitCode: cardinal;
ExecInfo: TShellExecuteInfo;
begin
ZeroMemory(@ExecInfo,SizeOf(ExecInfo));
with ExecInfo do
begin
cbSize := SizeOf(ExecInfo);
fMask := SEE_MASK_NOCLOSEPROCESS;
lpVerb := 'open';
lpFile := PChar(sFile); //執行檔檔名
lpParameters := PChar(sParameter); //參數
Wnd := 0;
nShow := SW_SHOWNORMAL;
end;
ShellExecuteEx(@ExecInfo);
GetExitCodeProcess(ExecInfo.hProcess,ExitCode);
while ExitCode=STILL_ACTIVE do
begin
GetExitCodeProcess(ExecInfo.hProcess, ExitCode);
sleep(10);
Application.ProcessMessages;
end;
end;
fatmoon1 對直接取用ShellExecute回傳值使用於WaiteforSingleObject的見解
引言:
引言:
procedure TForm1.Button1Click(Sender: TObject);
var
aHandle: Hwnd;
begin
//WinExec('D:\WinRAR\Rar.exe a -r E:\ShareFile.rar E:\ShareFile', SW_SHOWNORMAL);
aHandle := ShellExecute(Self.Handle, 'Open', 'rar.exe', ' a -r E:\ShareFile.rar E:\ShareFile', 'D:\WinRAR\', SW_SHOWNORMAL);
WaitForSingleObject(aHandle, INFINITE);
ShowMessage('成功!')
end;
雖然已經有正確解答了,但我針對上述方法會失敗的原因來回應
上述方法會失敗的原因是因為
aHandle:=ShellExecute(Self.Handle, 'Open', 'rar.exe', ' a -r E:\ShareFile.rar E:\ShareFile', 'D:\WinRAR\', SW_SHOWNORMAL);
如此的話aHandle只是存入ShellExecute的回傳值(成功的話回傳值會大於32)
所以WaitForSingleObject(aHandle, INFINITE);此行根本沒等到正確的Handle值
而WaitForSingleObject(hHandle: THandle; dwMilliseconds: DWORD);
這個函式的作用是 等候 hHandle(執行程式的Handle值) dwMilliseconds(ms)
所以經過dwMilliseconds(ms)後仍會執行下一行
所以要改寫成
var Result: Boolean;
ShellExInfo: TShellExecuteInfo;
begin
FillChar(ShellExInfo, SizeOf(ShellExInfo), 0);
with ShellExInfo do begin
cbSize := SizeOf(ShellExInfo);
fMask := see_Mask_NoCloseProcess;
Wnd := Application.Handle;
lpFile := 'D:\WinRAR\Rar.exe';
lpDirectory := 'D:\WinRAR\';
lpParameters := ' a -r E:\ShareFile.rar E:\ShareFile';
nShow := SW_SHOWNORMAL;
end;
//上述程式碼與william兄是一樣的,不一樣的在下方
Result := ShellExecuteEx(@ShellExInfo);
if Result then
while WaitForSingleObject(ShellExInfo.HProcess, 100) = WAIT_TIMEOUT do
begin
Application.ProcessMessages;
if Application.Terminated then Break;
end;
end;
=========================
fat eat moon,fat eat moon
轉貼至 http://delphi.ktop.com.tw/board.php?cid=30&fid=72&tid=38858
取得Service 檔案名稱
function TService1.fn_GetServiceFilenName:String;
var strBuf: array[1..512] of Char;
sFileName:String;
begin
ZeroMemory(@strBuf, 512);
GetModuleFileName(GetModuleHandle(nil), @strBuf, 512);
sFileName := Trim(strBuf);
Result := sFileName
Result := ExtractFileDir(sFileName); //回傳路徑
end;
var strBuf: array[1..512] of Char;
sFileName:String;
begin
ZeroMemory(@strBuf, 512);
GetModuleFileName(GetModuleHandle(nil), @strBuf, 512);
sFileName := Trim(strBuf);
Result := sFileName
Result := ExtractFileDir(sFileName); //回傳路徑
end;
[範例]DLL編寫與呼叫
DLL project
library Dll_procedure;
uses
SysUtils, Classes,
Windows, ExtCtrls;
{$R *.res}
function fn_StrToInt(sValue:String):Integer; stdcall;
begin
Result := StrToInt(sValue);
end;
exports fn_StrToInt;
begin
end.
----------------------------------------------------
Text Project - Call Dll
unit Unit1;
interface
uses
Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms,
Dialogs, StdCtrls, Buttons, ExtCtrls;
type
TForm1 = class(TForm)
BitBtn1: TBitBtn;
procedure BitBtn1Click(Sender: TObject);
private
{ Private declarations }
public
{ Public declarations }
end;
function fn_StrToInt(sValue:String):Integer; stdcall; External 'Dll_procedure.dll';
var
Form1: TForm1;
implementation
{$R *.dfm}
procedure TForm1.BitBtn1Click(Sender: TObject);
var sStr:String;
i:Integer;
begin
sStr := '123';
i := fn_StrToInt(sStr);
sStr := IntToStr(i);
showmessage(sStr);
end;
end.
library Dll_procedure;
uses
SysUtils, Classes,
Windows, ExtCtrls;
{$R *.res}
function fn_StrToInt(sValue:String):Integer; stdcall;
begin
Result := StrToInt(sValue);
end;
exports fn_StrToInt;
begin
end.
----------------------------------------------------
Text Project - Call Dll
unit Unit1;
interface
uses
Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms,
Dialogs, StdCtrls, Buttons, ExtCtrls;
type
TForm1 = class(TForm)
BitBtn1: TBitBtn;
procedure BitBtn1Click(Sender: TObject);
private
{ Private declarations }
public
{ Public declarations }
end;
function fn_StrToInt(sValue:String):Integer; stdcall; External 'Dll_procedure.dll';
var
Form1: TForm1;
implementation
{$R *.dfm}
procedure TForm1.BitBtn1Click(Sender: TObject);
var sStr:String;
i:Integer;
begin
sStr := '123';
i := fn_StrToInt(sStr);
sStr := IntToStr(i);
showmessage(sStr);
end;
end.
訂閱：
文章 (Atom)