Peter's Blog: 9月 2017

2017年9月7日星期四

由滑鼠位置取得Form上物件的名稱

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

將應用程式建立在Form上

Ex:將小算盤移到Form上

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

判斷檔案是否被開啟

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;

設定檔案屬性

SetFileAttributes(PChar(sTarget_FileName), FILE_ATTRIBUTE_ARCHIVE);

QuickReport報表-列表位置

QuickRep1.CurrentX;
QuickRep1.CurrentY;

影像處理[灰階化]及[邊緣化]

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

如何自動註冊Midas.DLL

D7 版本, 只要 USES MIDASLIB 即可, 就不用註冊 MIDAS.DLL 了

轉貼: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

如何清空鍵盤的緩衝區(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

搜尋目錄內的檔案名稱

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

設定報表內的表格框(QRShape) 與動態高度的Band 同高度

QRShape.Size.Height := ChildBand.Size.Height + ChildBand.Expanded;

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

設定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

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

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

[轉貼]如何正確捕捉滑鼠及其原理(附範例)

在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

等待外部執行檔結束作業後, 再繼續執行後續的程式碼

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

取得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;

[範例]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.

ShellExecute如何開啟徢徑(*.lnk)

ShellExecute(Handle, Operation, File, Parameters, Directory, ShowCmd);

一般使用方式
Ex:ShellExecute(Handle, 'Open', PChar('c:\test.exe'), '', '', SW_SHOW);

開啟徢徑(*.lnk)時, 將檔案的完整檔名 "\"字元改成 "/"字元即可
Ex:ShellExecute(Handle, 'Open', PChar('c:/test.exe'), '', '', SW_SHOW);

取得Service 所在的路徑

var
szPath: array [0..1024] of Char;

begin
// 取得程式所在根目錄
ZeroMemory(@szPath,sizeof(szPath));
GetModuleFileName(0,szPath,sizeof(szPath));
//result szPath='c:\path\test.exe'
---
end;

取視窗的圖示(ICON)

var hWnd:THandle;
icon:TIcon;
begin
hWnd := application.Handle;
icon := TIcon.Create;
icon.Handle := SendMessage(hWnd, WM_GETICON, ICON_BIG, 0);
Self.Canvas.Draw(0,0,icon);
end;

[轉貼]Delphi基本圖像處理代碼

Delphi基本图像处理代码

//浮雕
procedure Emboss(SrcBmp,DestBmp:TBitmap;AzimuthChange:integer);overload;
var
i, j, Gray, Azimuthvalue, R, G, B: integer;
SrcRGB, SrcRGB1, SrcRGB2, DestRGB: pRGBTriple;
begin
for i := 0 to SrcBmp.Height - 1 do
begin
SrcRGB := SrcBmp.ScanLine[i];
DestRGB := DestBmp.ScanLine[i];

if (AzimuthChange >= -180) and (AzimuthChange < -135) then
begin
if i > 0 then
SrcRGB1 := SrcBmp.ScanLine[i-1]
else
SrcRGB1 := SrcRGB;
Inc(SrcRGB1);
SrcRGB2 := SrcRGB;
Inc(SrcRGB2);
end
else if (AzimuthChange >= -135) and (AzimuthChange < -90) then
begin
if i > 0 then
SrcRGB1 := SrcBmp.ScanLine[i-1]
else
SrcRGB1 := SrcRGB;
SrcRGB2 := SrcRGB1;
Inc(SrcRGB2);
end
else if (AzimuthChange >= -90) and (AzimuthChange < -45) then
begin
if i > 0 then
SrcRGB1 := SrcBmp.ScanLine[i-1]
else
SrcRGB1 := SrcRGB;
SrcRGB2 := SrcRGB1;
end
else if (AzimuthChange >= -45) and (AzimuthChange < 0) then
begin
SrcRGB1 := SrcRGB;
if i > 0 then
SrcRGB2 := SrcBmp.ScanLine[i-1]
else
SrcRGB2 := SrcRGB;
end
else if (AzimuthChange >= 0) and (AzimuthChange < 45) then
begin
SrcRGB2 := SrcRGB;
if (i < SrcBmp.Height - 1) then
SrcRGB1 := SrcBmp.ScanLine[i+1]
else
SrcRGB1 := SrcRGB;
end
else if (AzimuthChange >= 45) and (AzimuthChange < 90) then
begin
if (i < SrcBmp.Height - 1) then
SrcRGB1 := SrcBmp.ScanLine[i+1]
else
SrcRGB1 := SrcRGB;
SrcRGB2 := SrcRGB1;
end
else if (AzimuthChange >= 90) and (AzimuthChange < 135) then
begin
if (i < SrcBmp.Height - 1) then
SrcRGB1 := SrcBmp.ScanLine[i+1]
else
SrcRGB1 := SrcRGB;
SrcRGB2 := SrcRGB1;
Inc(SrcRGB1);
end
else if (AzimuthChange >= 135) and (AzimuthChange <= 180) then
begin
if (i < SrcBmp.Height - 1) then
SrcRGB2 := SrcBmp.ScanLine[i+1]
else
SrcRGB2 := SrcRGB;
Inc(SrcRGB2);
SrcRGB1 := SrcRGB;
Inc(SrcRGB1);
end;

for j := 0 to SrcBmp.Width - 1 do
begin
if (AzimuthChange >= -180) and (AzimuthChange < -135) then
begin
Azimuthvalue := AzimuthChange + 180;
R:=SrcRGB.rgbtRed-((SrcRGB1.rgbtRed)*Azimuthvalue div 45)-((SrcRGB2.rgbtRed)*(45-Azimuthvalue) div 45)+78;
G:=SrcRGB.rgbtGreen-((SrcRGB1.rgbtGreen)*Azimuthvalue div 45)-((SrcRGB2.rgbtGreen)*(45-Azimuthvalue) div 45)+78;
B:=SrcRGB.rgbtBlue-((SrcRGB1.rgbtBlue)*Azimuthvalue div 45)-((SrcRGB2.rgbtBlue)*(45-Azimuthvalue) div 45)+78;
end
else if (AzimuthChange >= -135) and (AzimuthChange < -90) then
begin
Azimuthvalue := AzimuthChange + 135;
R:=SrcRGB.rgbtRed-((SrcRGB1.rgbtRed)*Azimuthvalue div 45)-((SrcRGB2.rgbtRed)*(45-Azimuthvalue) div 45)+78;
G:=SrcRGB.rgbtGreen-((SrcRGB1.rgbtGreen)*Azimuthvalue div 45)-((SrcRGB2.rgbtGreen)*(45-Azimuthvalue) div 45)+78;
B:=SrcRGB.rgbtBlue-((SrcRGB1.rgbtBlue)*Azimuthvalue div 45)-((SrcRGB2.rgbtBlue)*(45-Azimuthvalue) div 45)+78;
end
else if (AzimuthChange >= -90) and (AzimuthChange < -45) then
begin
if j=1 then Inc(SrcRGB1,-1);
Azimuthvalue := AzimuthChange + 90;
R:=SrcRGB.rgbtRed-((SrcRGB1.rgbtRed)*Azimuthvalue div 45)-((SrcRGB2.rgbtRed)*(45-Azimuthvalue) div 45)+78;
G:=SrcRGB.rgbtGreen-((SrcRGB1.rgbtGreen)*Azimuthvalue div 45)-((SrcRGB2.rgbtGreen)*(45-Azimuthvalue) div 45)+78;
B:=SrcRGB.rgbtBlue-((SrcRGB1.rgbtBlue)*Azimuthvalue div 45)-((SrcRGB2.rgbtBlue)*(45-Azimuthvalue) div 45)+78;
end
else if (AzimuthChange >= -45) and (AzimuthChange < 0) then
begin
if j=1 then
begin
Inc(SrcRGB1,-1);
Inc(SrcRGB2,-1);
end;
Azimuthvalue := AzimuthChange + 45;
R:=SrcRGB.rgbtRed-((SrcRGB1.rgbtRed)*Azimuthvalue div 45)-((SrcRGB2.rgbtRed)*(45-Azimuthvalue) div 45)+78;
G:=SrcRGB.rgbtGreen-((SrcRGB1.rgbtGreen)*Azimuthvalue div 45)-((SrcRGB2.rgbtGreen)*(45-Azimuthvalue) div 45)+78;
B:=SrcRGB.rgbtBlue-((SrcRGB1.rgbtBlue)*Azimuthvalue div 45)-((SrcRGB2.rgbtBlue)*(45-Azimuthvalue) div 45)+78;
end
else if (AzimuthChange >= 0) and (AzimuthChange < 45) then
begin
if j=1 then
begin
Inc(SrcRGB1,-1);
Inc(SrcRGB2,-1);
end;
Azimuthvalue := AzimuthChange;
R:=SrcRGB.rgbtRed-((SrcRGB1.rgbtRed)*Azimuthvalue div 45)-((SrcRGB2.rgbtRed)*(45-Azimuthvalue) div 45)+78;
G:=SrcRGB.rgbtGreen-((SrcRGB1.rgbtGreen)*Azimuthvalue div 45)-((SrcRGB2.rgbtGreen)*(45-Azimuthvalue) div 45)+78;
B:=SrcRGB.rgbtBlue-((SrcRGB1.rgbtBlue)*Azimuthvalue div 45)-((SrcRGB2.rgbtBlue)*(45-Azimuthvalue) div 45)+78;
end
else if (AzimuthChange >= 45) and (AzimuthChange < 90) then
begin
if j=1 then Inc(SrcRGB2,-1);
Azimuthvalue := AzimuthChange - 45;
R:=SrcRGB.rgbtRed-((SrcRGB1.rgbtRed)*Azimuthvalue div 45)-((SrcRGB2.rgbtRed)*(45-Azimuthvalue) div 45)+78;
G:=SrcRGB.rgbtGreen-((SrcRGB1.rgbtGreen)*Azimuthvalue div 45)-((SrcRGB2.rgbtGreen)*(45-Azimuthvalue) div 45)+78;
B:=SrcRGB.rgbtBlue-((SrcRGB1.rgbtBlue)*Azimuthvalue div 45)-((SrcRGB2.rgbtBlue)*(45-Azimuthvalue) div 45)+78;
end
else if (AzimuthChange >= 90) and (AzimuthChange < 135) then
begin
Azimuthvalue := AzimuthChange - 90;
R:=SrcRGB.rgbtRed-((SrcRGB1.rgbtRed)*Azimuthvalue div 45)-((SrcRGB2.rgbtRed)*(45-Azimuthvalue) div 45)+78;
G:=SrcRGB.rgbtGreen-((SrcRGB1.rgbtGreen)*Azimuthvalue div 45)-((SrcRGB2.rgbtGreen)*(45-Azimuthvalue) div 45)+78;
B:=SrcRGB.rgbtBlue-((SrcRGB1.rgbtBlue)*Azimuthvalue div 45)-((SrcRGB2.rgbtBlue)*(45-Azimuthvalue) div 45)+78;
end
else if (AzimuthChange >= 135) and (AzimuthChange <= 180) then
begin
Azimuthvalue := AzimuthChange - 135;
R:=SrcRGB.rgbtRed-((SrcRGB1.rgbtRed)*Azimuthvalue div 45)-((SrcRGB2.rgbtRed)*(45-Azimuthvalue) div 45)+78;
G:=SrcRGB.rgbtGreen-((SrcRGB1.rgbtGreen)*Azimuthvalue div 45)-((SrcRGB2.rgbtGreen)*(45-Azimuthvalue) div 45)+78;
B:=SrcRGB.rgbtBlue-((SrcRGB1.rgbtBlue)*Azimuthvalue div 45)-((SrcRGB2.rgbtBlue)*(45-Azimuthvalue) div 45)+78;
end;
R:=Min(R,255);
R:=Max(R,0);
G:=Min(G,255);
G:=Max(G,0);
B:=Min(B,255);
B:=Max(B,0);
Gray := (R shr 2) + (R shr 4) + (G shr 1) + (G shr 4) + (B shr 3);
DestRGB.rgbtRed:=Gray;
DestRGB.rgbtGreen:=Gray;
DestRGB.rgbtBlue:=Gray;
if (j=-180) and (AzimuthChange<-135)) or ((AzimuthChange>=90) and (AzimuthChange<=180))) then
begin
Inc(SrcRGB1);
end;
if (j=135) and (AzimuthChange<180)) or ((AzimuthChange>=-180) and (AzimuthChange<=-90))) then
begin
Inc(SrcRGB2);
end;
Inc(SrcRGB);
Inc(DestRGB);
end;
end;
end;

procedure Emboss(Bmp:TBitmap;AzimuthChange:integer;ElevationChange:integer;WeightChange:integer);overload;
var
DestBmp:TBitmap;
begin
　　DestBmp:=TBitmap.Create;
　　DestBmp.Assign(Bmp);
　　Emboss(Bmp,DestBmp,AzimuthChange,ElevationChange,WeightChange);
　　Bmp.Assign(DestBmp);
end;

//反色
procedure Negative(Bmp:TBitmap);
var
i, j: Integer;
PRGB: pRGBTriple;
begin
Bmp.PixelFormat:=pf24Bit;
for i := 0 to Bmp.Height - 1 do
begin
PRGB := Bmp.ScanLine[i];
for j := 0 to Bmp.Width - 1 do
begin
PRGB^.rgbtRed :=not PRGB^.rgbtRed ;
PRGB^.rgbtGreen :=not PRGB^.rgbtGreen;
PRGB^.rgbtBlue :=not PRGB^.rgbtBlue;
Inc(PRGB);
end;
end;
end;

//曝光
procedure Exposure(Bmp:TBitmap);
var
i, j: integer;
PRGB: pRGBTriple;
begin
Bmp.PixelFormat:=pf24Bit;
for i := 0 to Bmp.Height - 1 do
begin
PRGB := Bmp.ScanLine[i];
for j := 0 to Bmp.Width - 1 do
begin
if PRGB^.rgbtRed<128 then
PRGB^.rgbtRed :=not PRGB^.rgbtRed ;
if PRGB^.rgbtGreen<128 then
PRGB^.rgbtGreen :=not PRGB^.rgbtGreen;
if PRGB^.rgbtBlue<128 then
PRGB^.rgbtBlue :=not PRGB^.rgbtBlue;
Inc(PRGB);
end;
end;
end;

//模糊
procedure Blur(SrcBmp:TBitmap);
var
i, j:Integer;
SrcRGB:pRGBTriple;
SrcNextRGB:pRGBTriple;
SrcPreRGB:pRGBTriple;
Value:Integer;

procedure IncRGB;
begin
Inc(SrcPreRGB);
Inc(SrcRGB);
Inc(SrcNextRGB);
end;

procedure DecRGB;
begin
Inc(SrcPreRGB,-1);
Inc(SrcRGB,-1);
Inc(SrcNextRGB,-1);
end;

begin
SrcBmp.PixelFormat:=pf24Bit;
for i := 0 to SrcBmp.Height - 1 do
begin
if i > 0 then
SrcPreRGB:=SrcBmp.ScanLine[i-1]
else
SrcPreRGB := SrcBmp.ScanLine[i];
SrcRGB := SrcBmp.ScanLine[i];
if i < SrcBmp.Height - 1 then
SrcNextRGB:=SrcBmp.ScanLine[i+1]
else
SrcNextRGB:=SrcBmp.ScanLine[i];
for j := 0 to SrcBmp.Width - 1 do
begin
if j > 0 then DecRGB;
Value:=SrcPreRGB.rgbtRed+SrcRGB.rgbtRed+SrcNextRGB.rgbtRed;
if j > 0 then IncRGB;
Value:=Value+SrcPreRGB.rgbtRed+SrcRGB.rgbtRed+SrcNextRGB.rgbtRed;
if j < SrcBmp.Width - 1 then IncRGB;
Value:=(Value+SrcPreRGB.rgbtRed+SrcRGB.rgbtRed+SrcNextRGB.rgbtRed) div 9;
DecRGB;
SrcRGB.rgbtRed:=value;
if j > 0 then DecRGB;
Value:=SrcPreRGB.rgbtGreen+SrcRGB.rgbtGreen+SrcNextRGB.rgbtGreen;
if j > 0 then IncRGB;
Value:=Value+SrcPreRGB.rgbtGreen+SrcRGB.rgbtGreen+SrcNextRGB.rgbtGreen;
if j < SrcBmp.Width - 1 then IncRGB;
Value:=(Value+SrcPreRGB.rgbtGreen+SrcRGB.rgbtGreen+SrcNextRGB.rgbtGreen) div 9;
DecRGB;
SrcRGB.rgbtGreen:=value;
if j > 0 then DecRGB;
Value:=SrcPreRGB.rgbtBlue+SrcRGB.rgbtBlue+SrcNextRGB.rgbtBlue;
if j > 0 then IncRGB;
Value:=Value+SrcPreRGB.rgbtBlue+SrcRGB.rgbtBlue+SrcNextRGB.rgbtBlue;
if j < SrcBmp.Width - 1 then IncRGB;
Value:=(Value+SrcPreRGB.rgbtBlue+SrcRGB.rgbtBlue+SrcNextRGB.rgbtBlue) div 9;
DecRGB;
SrcRGB.rgbtBlue:=value;
IncRGB;
end;
end;
end;

//锐化
procedure Sharpen(SrcBmp:TBitmap);
var
i, j: integer;
SrcRGB: pRGBTriple;
SrcPreRGB: pRGBTriple;
Value: integer;
begin
SrcBmp.PixelFormat:=pf24Bit;
for i := 0 to SrcBmp.Height - 1 do
begin
SrcRGB := SrcBmp.ScanLine[i];
if i > 0 then
SrcPreRGB:=SrcBmp.ScanLine[i-1]
else
SrcPreRGB:=SrcBmp.ScanLine[i];
for j := 0 to SrcBmp.Width - 1 do
begin
if j = 1 then Dec(SrcPreRGB);
Value:=SrcRGB.rgbtRed+(SrcRGB.rgbtRed-SrcPreRGB.rgbtRed) div 2;
Value:=Max(0,Value);
Value:=Min(255,Value);
SrcRGB.rgbtRed:=value;
Value:=SrcRGB.rgbtGreen+(SrcRGB.rgbtGreen-SrcPreRGB.rgbtGreen) div 2;
Value:=Max(0,Value);
Value:=Min(255,Value);
SrcRGB.rgbtGreen:=value;
Value:=SrcRGB.rgbtBlue+(SrcRGB.rgbtBlue-SrcPreRGB.rgbtBlue) div 2;
Value:=Max(0,Value);
Value:=Min(255,Value);
SrcRGB.rgbtBlue:=value;
Inc(SrcRGB);
Inc(SrcPreRGB);
end;
end;
end;
[图像的旋转和翻转]

以下代码用ScanLine配合指针移动实现，用于24位色！

//旋转90度
procedure Rotate90(const Bitmap:TBitmap);
var
i,j:Integer;
rowIn,rowOut:pRGBTriple;
Bmp:TBitmap;
Width,Height:Integer;
begin
Bmp:=TBitmap.Create;
Bmp.Width := Bitmap.Height;
Bmp.Height := Bitmap.Width;
Bmp.PixelFormat := pf24bit;
Width:=Bitmap.Width-1;
Height:=Bitmap.Height-1;
for j := 0 to Height do
begin
rowIn := Bitmap.ScanLine[j];
for i := 0 to Width do
begin
rowOut := Bmp.ScanLine[i];
Inc(rowOut,Height - j);
rowOut^ := rowIn^;
Inc(rowIn);
end;
end;
Bitmap.Assign(Bmp);
end;

//旋转180度
procedure Rotate180(const Bitmap:TBitmap);
var
i,j:Integer;
rowIn,rowOut:pRGBTriple;
Bmp:TBitmap;
Width,Height:Integer;
begin
Bmp:=TBitmap.Create;
Bmp.Width := Bitmap.Width;
Bmp.Height := Bitmap.Height;
Bmp.PixelFormat := pf24bit;
Width:=Bitmap.Width-1;
Height:=Bitmap.Height-1;
for j := 0 to Height do
begin
rowIn := Bitmap.ScanLine[j];
for i := 0 to Width do
begin
rowOut := Bmp.ScanLine[Height - j];
Inc(rowOut,Width - i);
rowOut^ := rowIn^;
Inc(rowIn);
end;
end;
Bitmap.Assign(Bmp);
end;

//旋转270度
procedure Rotate270(const Bitmap:TBitmap);
var
i,j:Integer;
rowIn,rowOut:pRGBTriple;
Bmp:TBitmap;
Width,Height:Integer;
begin
Bmp:=TBitmap.Create;
Bmp.Width := Bitmap.Height;
Bmp.Height := Bitmap.Width;
Bmp.PixelFormat := pf24bit;
Width:=Bitmap.Width-1;
Height:=Bitmap.Height-1;
for j := 0 to Height do
begin
rowIn := Bitmap.ScanLine[j];
for i := 0 to Width do
begin
rowOut := Bmp.ScanLine[Width - i];
Inc(rowOut,j);
rowOut^ := rowIn^;
Inc(rowIn);
end;
end;
Bitmap.Assign(Bmp);
end;

//任意角度
function RotateBitmap(Bitmap:TBitmap;Angle:Integer;BackColor:TColor):TBitmap;
var
i,j,iOriginal,jOriginal,CosPoint,SinPoint : integer;
RowOriginal,RowRotated : pRGBTriple;
SinTheta,CosTheta : Extended;
AngleAdd : integer;
begin
Result:=TBitmap.Create;
Result.PixelFormat := pf24bit;
Result.Canvas.Brush.Color:=BackColor;
Angle:=Angle Mod 360;
if Angle<0 then Angle:=360-Abs(Angle);
if Angle=0 then
Result.Assign(Bitmap)
else if Angle=90 then
begin
Result.Assign(Bitmap);
Rotate90(Result);//如果是旋转90度，直接调用上面的代码
end
else if (Angle>90) and (Angle<180) then
begin
AngleAdd:=90;
Angle:=Angle-AngleAdd;
end
else if Angle=180 then
begin
Result.Assign(Bitmap);
Rotate180(Result);//如果是旋转180度，直接调用上面的过程
end
else if (Angle>180) and (Angle<270) then
begin
AngleAdd:=180;
Angle:=Angle-AngleAdd;
end
else if Angle=270 then
begin
Result.Assign(Bitmap);
Rotate270(Result);//如果是旋转270度，直接调用上面的过程
end
else if (Angle>270) and (Angle<360) then
begin
AngleAdd:=270;
Angle:=Angle-AngleAdd;
end
else
AngleAdd:=0;
if (Angle>0) and (Angle<90) then
begin
SinCos((Angle + AngleAdd) * Pi / 180, SinTheta, CosTheta);
if (SinTheta * CosTheta) < 0 then
begin
Result.Width := Round(Abs(Bitmap.Width * CosTheta - Bitmap.Height * SinTheta));
Result.Height := Round(Abs(Bitmap.Width * SinTheta - Bitmap.Height * CosTheta));
end
else
begin
Result.Width := Round(Abs(Bitmap.Width * CosTheta + Bitmap.Height * SinTheta));
Result.Height := Round(Abs(Bitmap.Width * SinTheta + Bitmap.Height * CosTheta));
end;
CosTheta:=Abs(CosTheta);
SinTheta:=Abs(SinTheta);
if (AngleAdd=0) or (AngleAdd=180) then
begin
CosPoint:=Round(Bitmap.Height*CosTheta);
SinPoint:=Round(Bitmap.Height*SinTheta);
end
else
begin
SinPoint:=Round(Bitmap.Width*CosTheta);
CosPoint:=Round(Bitmap.Width*SinTheta);
end;
for j := 0 to Result.Height-1 do
begin
RowRotated := Result.Scanline[j];
for i := 0 to Result.Width-1 do
begin
Case AngleAdd of
0:
begin
jOriginal := Round((j+1)*CosTheta-(i+1-SinPoint)*SinTheta)-1;
iOriginal := Round((i+1)*CosTheta-(CosPoint-j-1)*SinTheta)-1;
end;
90:
begin
iOriginal := Round((j+1)*SinTheta-(i+1-SinPoint)*CosTheta)-1;
jOriginal := Bitmap.Height-Round((i+1)*SinTheta-(CosPoint-j-1)*CosTheta);
end;
180:
begin
jOriginal := Bitmap.Height-Round((j+1)*CosTheta-(i+1-SinPoint)*SinTheta);
iOriginal := Bitmap.Width-Round((i+1)*CosTheta-(CosPoint-j-1)*SinTheta);
end;
270:
begin
iOriginal := Bitmap.Width-Round((j+1)*SinTheta-(i+1-SinPoint)*CosTheta);
jOriginal := Round((i+1)*SinTheta-(CosPoint-j-1)*CosTheta)-1;
end;
end;
if (iOriginal >= 0) and (iOriginal <= Bitmap.Width-1)and
(jOriginal >= 0) and (jOriginal <= Bitmap.Height-1)
then
begin
RowOriginal := Bitmap.Scanline[jOriginal];
Inc(RowOriginal,iOriginal);
RowRotated^ := RowOriginal^;
Inc(RowRotated);
end
else
begin
Inc(RowRotated);
end;
end;
end;
end;
end;

//水平翻转
procedure FlipHorz(const Bitmap:TBitmap);
var
i,j:Integer;
rowIn,rowOut:pRGBTriple;
Bmp:TBitmap;
Width,Height:Integer;
begin
Bmp:=TBitmap.Create;
Bmp.Width := Bitmap.Width;
Bmp.Height := Bitmap.Height;
Bmp.PixelFormat := pf24bit;
Width:=Bitmap.Width-1;
Height:=Bitmap.Height-1;
for j := 0 to Height do
begin
rowIn := Bitmap.ScanLine[j];
for i := 0 to Width do
begin
rowOut := Bmp.ScanLine[j];
Inc(rowOut,Width - i);
rowOut^ := rowIn^;
Inc(rowIn);
end;
end;
Bitmap.Assign(Bmp);
end;

//垂直翻转
procedure FlipVert(const Bitmap:TBitmap);
var
i,j:Integer;
rowIn,rowOut:pRGBTriple;
Bmp:TBitmap;
Width,Height:Integer;
begin
Bmp:=TBitmap.Create;
Bmp.Width := Bitmap.Height;
Bmp.Height := Bitmap.Width;
Bmp.PixelFormat := pf24bit;
Width:=Bitmap.Width-1;
Height:=Bitmap.Height-1;
for j := 0 to Height do
begin
rowIn := Bitmap.ScanLine[j];
for i := 0 to Width do
begin
rowOut := Bmp.ScanLine[Height - j];
Inc(rowOut,i);
rowOut^ := rowIn^;
Inc(rowIn);
end;
end;
Bitmap.Assign(Bmp);
end;

[亮度、对比度、饱和度的调整]

以下代码用ScanLine配合指针移动实现！

function Min(a, b: integer): integer;
begin
if a < b then
result := a
else
result := b;
end;

function Max(a, b: integer): integer;
begin
if a > b then
result := a
else
result := b;
end;

//亮度调整
procedure BrightnessChange(const SrcBmp,DestBmp:TBitmap;ValueChange:integer);
var
i, j: integer;
SrcRGB, DestRGB: pRGBTriple;
begin
for i := 0 to SrcBmp.Height - 1 do
begin
SrcRGB := SrcBmp.ScanLine[i];
DestRGB := DestBmp.ScanLine[i];
for j := 0 to SrcBmp.Width - 1 do
begin
if ValueChange > 0 then
begin
DestRGB.rgbtRed := Min(255, SrcRGB.rgbtRed + ValueChange);
DestRGB.rgbtGreen := Min(255, SrcRGB.rgbtGreen + ValueChange);
DestRGB.rgbtBlue := Min(255, SrcRGB.rgbtBlue + ValueChange);
end else begin
DestRGB.rgbtRed := Max(0, SrcRGB.rgbtRed + ValueChange);
DestRGB.rgbtGreen := Max(0, SrcRGB.rgbtGreen + ValueChange);
DestRGB.rgbtBlue := Max(0, SrcRGB.rgbtBlue + ValueChange);
end;
Inc(SrcRGB);
Inc(DestRGB);
end;
end;
end;

//对比度调整
procedure ContrastChange(const SrcBmp,DestBmp:TBitmap;ValueChange:integer);
var
i, j: integer;
SrcRGB, DestRGB: pRGBTriple;
begin
for i := 0 to SrcBmp.Height - 1 do
begin
SrcRGB := SrcBmp.ScanLine[i];
DestRGB := DestBmp.ScanLine[i];
for j := 0 to SrcBmp.Width - 1 do
begin
if ValueChange>=0 then
begin
if SrcRGB.rgbtRed >= 128 then
DestRGB.rgbtRed := Min(255, SrcRGB.rgbtRed + ValueChange)
else
DestRGB.rgbtRed := Max(0, SrcRGB.rgbtRed - ValueChange);
if SrcRGB.rgbtGreen >= 128 then
DestRGB.rgbtGreen := Min(255, SrcRGB.rgbtGreen + ValueChange)
else
DestRGB.rgbtGreen := Max(0, SrcRGB.rgbtGreen - ValueChange);
if SrcRGB.rgbtBlue >= 128 then
DestRGB.rgbtBlue := Min(255, SrcRGB.rgbtBlue + ValueChange)
else
DestRGB.rgbtBlue := Max(0, SrcRGB.rgbtBlue - ValueChange);
end
else
begin
if SrcRGB.rgbtRed >= 128 then
DestRGB.rgbtRed := Max(128, SrcRGB.rgbtRed + ValueChange)
else
DestRGB.rgbtRed := Min(128, SrcRGB.rgbtRed - ValueChange);
if SrcRGB.rgbtGreen >= 128 then
DestRGB.rgbtGreen := Max(128, SrcRGB.rgbtGreen + ValueChange)
else
DestRGB.rgbtGreen := Min(128, SrcRGB.rgbtGreen - ValueChange);
if SrcRGB.rgbtBlue >= 128 then
DestRGB.rgbtBlue := Max(128, SrcRGB.rgbtBlue + ValueChange)
else
DestRGB.rgbtBlue := Min(128, SrcRGB.rgbtBlue - ValueChange);
end;
Inc(SrcRGB);
Inc(DestRGB);
end;
end;
end;

//饱和度调整
procedure SaturationChange(const SrcBmp,DestBmp:TBitmap;ValueChange:integer);
var
Grays: array[0..767] of Integer;
Alpha: array[0..255] of Word;
Gray, x, y: Integer;
SrcRGB,DestRGB: pRGBTriple;
i: Byte;
begin
ValueChange:=ValueChange+255;
for i := 0 to 255 do
Alpha[i] := (i * ValueChange) Shr 8;
x := 0;
for i := 0 to 255 do
begin
Gray := i - Alpha[i];
Grays[x] := Gray;
Inc(x);
Grays[x] := Gray;
Inc(x);
Grays[x] := Gray;
Inc(x);
end;
for y := 0 to SrcBmp.Height - 1 do
begin
SrcRGB := SrcBmp.ScanLine[Y];
DestRGB := DestBmp.ScanLine[Y];
for x := 0 to SrcBmp.Width - 1 do
begin
Gray := Grays[SrcRGB.rgbtRed + SrcRGB.rgbtGreen + SrcRGB.rgbtBlue];
if Gray + Alpha[SrcRGB.rgbtRed]>0 then
DestRGB.rgbtRed := Min(255,Gray + Alpha[SrcRGB.rgbtRed])
else
DestRGB.rgbtRed := 0;
if Gray + Alpha[SrcRGB.rgbtGreen]>0 then
DestRGB.rgbtGreen := Min(255,Gray + Alpha[SrcRGB.rgbtGreen])
else
DestRGB.rgbtGreen := 0;
if Gray + Alpha[SrcRGB.rgbtBlue]>0 then
DestRGB.rgbtBlue := Min(255,Gray + Alpha[SrcRGB.rgbtBlue])
else
DestRGB.rgbtBlue := 0;
Inc(SrcRGB);
Inc(DestRGB);
end;
end;
end;

//RGB调整
procedure RGBChange(SrcBmp,DestBmp:TBitmap;RedChange,GreenChange,BlueChange:integer);
var
SrcRGB, DestRGB: pRGBTriple;
i,j:integer;
begin
for i := 0 to SrcBmp.Height- 1 do
begin
SrcRGB := SrcBmp.ScanLine[i];
DestRGB :=DestBmp.ScanLine[i];
for j := 0 to SrcBmp.Width - 1 do
begin
if RedChange> 0 then
DestRGB.rgbtRed := Min(255, SrcRGB.rgbtRed + RedChange)
else
DestRGB.rgbtRed := Max(0, SrcRGB.rgbtRed + RedChange);

if GreenChange> 0 then
DestRGB.rgbtGreen := Min(255, SrcRGB.rgbtGreen + GreenChange)
else
DestRGB.rgbtGreen := Max(0, SrcRGB.rgbtGreen + GreenChange);

if BlueChange> 0 then
DestRGB.rgbtBlue := Min(255, SrcRGB.rgbtBlue + BlueChange)
else
DestRGB.rgbtBlue := Max(0, SrcRGB.rgbtBlue + BlueChange);
Inc(SrcRGB);
Inc(DestRGB);
end;
end;
end;

[颜色调整]

//RGB<=>BGR
procedure RGB2BGR(const Bitmap:TBitmap);
var
X: Integer;
Y: Integer;
PRGB: pRGBTriple;
Color: Byte;
begin
for Y := 0 to (Bitmap.Height - 1) do
begin
for X := 0 to (Bitmap.Width - 1) do
begin
Color := PRGB^.rgbtRed;
PRGB^.rgbtRed := PRGB^.rgbtBlue;
PRGB^.rgbtBlue := Color;
Inc(PRGB);
end;
end
end;
end;

//灰度化(加权)
procedure Grayscale(const Bitmap:TBitmap);
var
X: Integer;
Y: Integer;
PRGB: pRGBTriple;
Gray: Byte;
begin
for Y := 0 to (Bitmap.Height - 1) do
begin
PRGB := Bitmap.ScanLine[Y];
for X := 0 to (Bitmap.Width - 1) do
begin
Gray := (77 * Red + 151 * Green + 28 * Blue) shr 8;
PRGB^.rgbtRed:=Gray;
PRGB^.rgbtGreen:=Gray;
PRGB^.rgbtBlue:=Gray;
Inc(PRGB);
end;
end;
end;

理论篇：
关键词：
绘图区－即窗口显示图像的区域，亦可为全屏幕（在全屏幕下绘图的效果比一般窗口下好）
中心点－即要绘图区显示的中心点在原始图像的坐标（声明：这个概念特别重要）
　　先说说图像的放大，要放大一张图片，我们一般的做法是直接放大图像，但本文介绍的方法仅放大我们能够看到的部分，放大分两种情况，一种是放大后比绘图区还要小，这种情况没什么好说，当然是显示全部的图像；第二种是放大后的图像比绘图区大，这才是我们今天要讨论的重点话题，这种情况下我们先要确定图像放大后的大小，然后根据“中心点”计算在原始图像的位置和大小，最后把截取的图像放大到绘图区。
　　再说说图像的漫游，当显示的图像超过绘图区时，我们需要对图像进行漫游，以便看到全部的图像。原理是：当鼠标在绘图区进行单击时，这时开始漫游，先记录鼠标的单击位置，然后检测鼠标的移动，根据鼠标和上次的位移计算出“中心点”（需要将屏幕坐标转换为原始图像坐标），根据在上面放大的原理到原始图像中取出要显示的部分，放大显示到绘图区。
算法实现篇：
1.图像放大
变量定义：
PZoom:放大率(整数:100时为100%，根据需要可以将 100 该为 10000 或者更大些，但不推荐使用浮点数)
a,b:中心点
w,h:要截取原始图像的宽和高
x,y:要截取的位置(左上角)
sw,sh:原始图像的宽和高
p1,p2:放大比例
aw,ah:放大后图像的大小
pw,ph:绘图区大小
vx,vy:在绘图区显示的位置（左上角）
vw,vh:在绘图区显示的大小
ptx,pty:临时变量
已知的变量：PZoom,(a,b),(sw,sh),(p1,p2),(aw,ah),(pw,ph)
要计算的变量：(x,y),(w,h),(vx,vy),(vw,vh)
开始计算：
aw=Round(PZoom*sw/100);
ah=Round(PZoom*sh/100);
p1=aw/pw
p2=ah/ph
// 注：Round 用于取整，如其他语言的Int(),Fix()等
if p1>1 then w=Round(sw/p1) else w=sw
if p2>1 then h=Round(sh/p2) else h=sh
// 注：shr 为右移运算符，可以使用“>>1”、“div 2”、“/2”或“Round(w/2)”代替
x=a-w shr 1
y=b-h shr 1
// 注：div 为整除运算符
ptx=(w*PZoom) div 100
pty=(h*PZoom) div 100
// 以下计算在绘图区显示的图像大小和位置
变量
Pencent:double; // 缩放比
wx:double; // 宽缩放比
hx:double; // 高缩放比
// 获得缩放比
wx:=pw/ptx
hx:=ph/pty
if wx>hx then Pencent:=hx
else Pencent:=wx;
// 获得图片最后的大小
vw:=Round(Pencent*ptx);
vh:=Round(Pencent*pty);
// 计算出图片的位置
vx:=(pw-vw) div 2;
vy:=(ph-vh) div 2;
// ------------------------------------
好了，两个重要的任务完成(x,y),(w,h),(vx,vy),(vw,vh)已经全部计算得出，下面的工作就是显示了，我们选择 Windows API 进行操作
// 以下显示图像 -----------------------
变量
sDC 为原始图片的设备句柄(DC)
tDC 为临时设备句柄
dDC 最终设备句柄
BitBlt(tDC,0,0,w,h,sDC,0,0,SRCCOPY);
SetStretchBltMode(dDC,STRETCH_DELETESCANS);
StretchBlt(dDC,0,0,vw,vh,tDC,0,0,w,h,SRCCOPY);
最后绘制到显示的区域即可：
例如：BitBlt(GetDC(0),vx,vy,vx+vw,xy+vh,dDC,0,0,SRCCOPY);
// ------------------------------------
2.图像漫游
先定义三个全局变量：
FBeginDragPoint :TPoint; // 记录鼠标开始拖动的位置
FBeginDragSBPoint :TPoint; // 记录“中心点”位置
FBeginDrag :boolean; // 是否已经开始“拖动”
a,b :integer; // “中心点”位置
在鼠标左键点击时，记录鼠标的位置和“中心点”的位置，同时设置 FBeginDrag 为真
当鼠标右键弹起时，设置 FBeginDrag 为假
鼠标移动时，判断 FBeginDrag ，如果为假不进行处理，如果为真进行下面处理：
假设 X,Y 为鼠标当前的位置
a=FBeginDragPoint.X-((X-FBeginDragPoint.X)*100) div PZoom
b=FBeginDragPoint.Y-((Y-FBeginDragPoint.Y)*100) div PZoom
最后使用上面介绍的图像放大显示出图像
技巧篇：
1.如果图像较大，使用 delphi 的位图对象会出现内存溢出错误，这时可以进行如下设置：
bitImage:=TBitmap.Create;
bitImage.PixelFormat:=pf24bit;
bitImage.ReleaseHandle;
2.如果要让图像自动适应窗口的大小，参考以下代码：
var
p1,p2 :double;
begin
p1:=pw/sw;
p2:=ph/sw;
if p1>p2 then PZoom:=Round(p2*100)
else PZoom:=Round(p1*100);
if PZoom=0 then PZoom:=100;
end;

Delphi灰度图像像素颜色亮度处理
　　在图像处理中，速度是很重要的。因此，我们得重新处理一下TBitmap,得到TVczhBitmap。这只是因为GetPixels和SetPixels的速度太慢，换一个方法而已。
　　unit untBitmapProc;
　　interface
　　uses Graphics, SysUtils;
　　type
　　TVczhBitmap=class(TBitmap)
　　private
　　Data:PByteArray;
　　Line:Integer;
　　procedure SetFormat;
　　function GetBytePointer(X,Y:Integer):PByte;
　　procedure SetBytes(X,Y:Integer;Value:Byte);
　　function GetBytes(X,Y:Integer):Byte;
　　protected
　　published
　　constructor Create;
　　public
　　property Bytes[X,Y:Integer]:Byte read GetBytes write SetBytes;
　　procedure LoadFromFile(FileName:String);
　　procedure ToGray;
　　end;
　　implementation
　　procedure TVczhBitmap.SetFormat;
　　begin
　　HandleType:=bmDIB;
　　PixelFormat:=pf24bit;
　　end;
　　function TVczhBitmap.GetBytePointer(X,Y:Integer):PByte;
　　begin
　　if Line<>Y then
　　begin
　　Line:=Y;
　　Data:=ScanLine[Y];
　　end;
　　Longint(result):=Longint(Data)+X;
　　end;
　　procedure TVczhBitmap.SetBytes(X,Y:Integer;Value:Byte);
　　begin
　　GetBytePointer(X,Y)^:=Value;
　　end;
　　function TVczhBitmap.GetBytes(X,Y:Integer):Byte;
　　begin
　　result:=GetBytePointer(X,Y)^;
　　end;
　　constructor TVczhBitmap.Create;
　　begin
　　inherited Create;
　　SetFormat;
　　Line:=-1;
　　end;
　　procedure TVczhBitmap.LoadFromFile(FileName:String);
　　begin
　　inherited LoadFromFile(FileName);
　　SetFormat;
　　Line:=-1;
　　end;
　　procedure TVczhBitmap.ToGray;
　　var X,Y,R:Integer;
　　B:Byte;
　　begin
　　for Y:=0 to Height-1 do
　　for X:=0 to Width-1 do
　　begin
　　R:=0;
　　for B:=0 to 2 do
　　R:=R+GetBytes(X*3+B,Y);
　　for B:=0 to 2 do
　　SetBytes(X*3+B,Y,R div 3);
　　end;
　　end;
　　end.
　　此后，我们需要建立几个窗体。第一个用来显示图片，第二个用来处理图片，其他的窗体都继承自第二个窗体，包含实际的处理方法。
　　先看第二个窗口：
　　unit untProc;
　　interface
　　uses
　　Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms,
　　Dialogs, ExtCtrls, untBitmapProc, StdCtrls, ComCtrls;
　　type
　　TfrmProcessor = class(TForm)
　　pbBar: TPaintBox;
　　gpProc: TGroupBox;
　　Button1: TButton;
　　procedure FormCreate(Sender: TObject);
　　procedure FormDestroy(Sender: TObject);
　　procedure FormShow(Sender: TObject);
　　procedure pbBarPaint(Sender: TObject);
　　procedure Button1Click(Sender: TObject);
　　private
　　{ Private declarations }
　　public
　　{ Public declarations }
　　BarData:array[0..255]of Byte;
　　Bar:TVczhBitmap;
　　procedure DrawBar;
　　end;
　　var
　　frmProcessor: TfrmProcessor;
　　implementation
　　{$R *.dfm}
　　uses untViewer;
　　procedure TfrmProcessor.DrawBar;
　　var I:Integer;
　　begin
　　Bar.Canvas.FillRect(Bar.Canvas.ClipRect);
　　Bar.Canvas.MoveTo(0,255-BarData[0]);
　　for I:=1 to 255 do
　　Bar.Canvas.LineTo(I,255-BarData[I]);
　　end;
　　procedure TfrmProcessor.FormCreate(Sender: TObject);
　　begin
　　Bar:=TVczhBitmap.Create;
　　Bar.Width:=256;
　　Bar.Height:=256;
　　Bar.Canvas.Brush.Color:=clWhite;
　　Bar.Canvas.Brush.Style:=bsSolid;
　　end;
　　procedure TfrmProcessor.FormDestroy(Sender: TObject);
　　begin
　　Bar.Free;
　　end;
　　procedure TfrmProcessor.FormShow(Sender: TObject);
　　var I:Integer;
　　begin
　　for I:=0 to 255 do
　　BarData[I]:=I;
　　DrawBar;
　　end;
　　procedure TfrmProcessor.pbBarPaint(Sender: TObject);
　　begin
　　pbBar.Canvas.Draw(0,0,Bar);
　　end;
　　procedure TfrmProcessor.Button1Click(Sender: TObject);
　　var X,Y:Integer;
　　begin
　　for Y:=0 to Buffer.Height-1 do
　　for X:=0 to Buffer.Width*3-1 do
　　Played.Bytes[X,Y]:=BarData[Buffer.Bytes[X,Y]];
　　frmViewer.FormPaint(frmViewer);
　　end;
　　end.
　　之后，做一个窗口继承自它，则调整BarData[]后，按Apply即可看到结果。
　　现在开始将图像处理。具体效果见示例程序。
　　
　　一、颜色反转。
　　灰度图像的颜色都是从0~255，所以，为了使颜色反转，我们可以用255减去该颜色值以得到反转后的颜色。
　　var I:Integer;
　　begin
　　inherited;
　　for I:=0 to 255 do
　　BarData[I]:=255-I;//用255减去该颜色值
　　DrawBar;
　　pbBarPaint(pbBar);
　　end;
　　
　　二、缩小颜色范围以增强或减弱亮度
　　颜色本来是从0~255的。如果调节它的范围，例如从0~16，则会是图像明显变暗。我们可以把起始值设为a，把终止值设为b，则新的颜色值New=a+(b-1)*Old/255。这样做的话可以改变亮度，并且不会破坏原先颜色的顺序。代码如下
　　var I:Integer;
　　begin
　　for I:=0 to 255 do
　　BarData[I]:=(255-sbMin.Position)+Round((sbMin.Position-sbMax.Position)/255*I);
　　DrawBar;
　　pbBarPaint(pbBar);
　　Button1Click(Button1);
　　end;
　　这里的sbMin.Position和sbMaxPosition都是反转过的。所以使用时要用255去减
　　
　　三、增加某个范围内的颜色范围
　　如果图像本身的颜色范围很小的画，你可以通过这种方法来加大图像的对比度，有利于对图像的分析。具体做法：
　　选取一个值a做为起始值，选取一个值b做为终止值，然后按以下公式变形：
　　|　0 (X<=a)
　　f(X)= |　255/(b-a)*(X-a)
　　|　255(X>=b)
　　var I:Integer;
　　begin
　　for I:=0 to 255 do
　　begin
　　if I<=sbMin.Position then
　　BarData[I]:=0
　　else if I>=sbMax.Position then
　　BarData[I]:=255
　　else
　　BarData[I]:=Round(255/(sbMax.Position-sbMin.Position)*(I-sbMin.Position));
　　end;
　　DrawBar;
　　pbBarPaint(pbBar);
　　Button1Click(Button1);
　　end;
　　
　　四、变为黑白图片
　　在使用第三个功能的时候，你会发现当b<=a时，图像上的颜色除了黑色就是白色。这样操作的好处是不能直接显示出来的。这只要到了比较高级的图像处理如边缘检测等，才有作用。本例可以拿第三种方法的公式再变形，因此不作详细阐述。
　　
　　五、指数级亮度调整
　　

　　我们假设这个图的定义域是[0,1]，值域也是[0,1]。那么，定义函数f(x)=x^c，则f(x)的图像有一段如上图。我们再用鼠标操作时，可以在上面取一点P(a,b)，然后使f(x)通过点P，则c=ln(b)/ln(a)。有了c之后，我们就可以对颜色进行操作了：
　　New=(Old/255)^c*255=exp(ln(old/255)*c)*255
　　var ea,eb,ec:Extended;
　　I:Integer;
　　begin
　　ea:=A/255;
　　eb:=B/255;
　　ec:=Ln(eb)/Ln(ea);
　　for I:=1 to 255 do
　　BarData[I]:=Round(Exp(Ln((I/255))*ec)*255);
　　DrawBar;
　　pbBarPaint(pbBar);
　　Button1Click(Button1);
　　end;
　　这样做可以调节图像的亮度。
Delphi图形显示特效的技巧
　概述
　　----目前在许多学习软件、游戏光盘中，经常会看到各种
　　图形显示技巧，凭着图形的移动、交错、雨滴状、百页窗、积木堆叠等显现方式，使画面变得更为生动活泼，更能吸引观众。本文将探讨如何在delphi中实现各种图形显示技巧。
　　基本原理
　　----在delphi中，实现一副图象的显示是非常简单的，只要在form中定义一个timage组件，设置其picture属性，然后选择任何有效的.ico、.bmp、.emf或.wmf文件，进行load，所选文件就显示在timage组件中了。但这只是直接将图形显示在窗体中，毫无技巧可言。为了使图形显示具有别具一格的效果，可以按下列步骤实现：
　　----定义一个timage组件，把要显示的图形先装入到timage组件中，也就是说，把图形内容从磁盘载入内存中，做为图形缓存。
　　----创建一新的位图对象，其尺寸跟timage组件中的图形一样。
　　----利用画布(canvas)的copyrect功能(将一个画布的矩形区域拷贝到另一个画布的矩形区域)，使用技巧，动态形
　　成位图文件内容，然后在窗体中显示位图。
　　----实现方法
　　下面介绍各种图形显示技巧：
1.推拉效果
　　将要显示的图形由上、下、左、右方向拉进屏幕内显示，同时将屏幕上原来的旧图盖掉，此种效果可分为四
　　种，上拉、下拉、左拉、右拉，但原理都差不多，以上拉效果为例。
原理：首先将放在暂存图形的第一条水平线，搬移至要显示的位图的最后一条，接着再将暂存图形的前两条水平线，依序搬移至要显示位图的最后两条水平线，然后搬移前三条、前四条叄?直到全部图形数据搬完为止。在搬移的过程中即可看到显示的位图由下而上浮起，而达到上拉的效果。
程序算法：
procedure tform1.button1click(sender: tobject);
var
newbmp: tbitmap;
i,bmpheight,bmpwidth:integer;
begin
newbmp:= tbitmap.create;
newbmp.width:=image1.width;
newbmp.height:=image1.height;
bmpheight:=image1.height;
bmpwidth:=image1.width;
for i:=0 to bmpheight do
begin
newbmp.canvas.copyrect(rect
(0,bmpheight-i,bmpwidth,bmpheight),
image1.canvas,
rect(0,0,bmpwidth,i));
form1.canvas.draw(120,100,newbmp);
end;
newbmp.free;
end;
2.垂直交错效果
原理：将要显示的图形拆成两部分，奇数条扫描线由上往下搬移，偶数条扫描线的部分则由下往上搬移，而且两者同时进行。从屏幕上便可看到分别由上下两端出现的较淡图形向屏幕中央移动，直到完全清楚为止。
程序算法：
procedure tform1.button4click(sender: tobject);
var
newbmp:tbitmap;
i,j,bmpheight,bmpwidth:integer;
begin
newbmp:= tbitmap.create;
newbmp.width:=image1.width;
newbmp.height:=image1.height;
bmpheight:=image1.height;
bmpwidth:=image1.width;
i:=0;
while i< =bmpheight do
begin
j:=i;
while j >0 do
begin
newbmp.canvas.copyrect(rect(0,j-1,bmpwidth,j),
image1.canvas,
rect(0,bmpheight-i+j-1,bmpwidth,bmpheight-i+j));
newbmp.canvas.copyrect(rect
(0,bmpheight-j,bmpwidth,bmpheight-j+1),
image1.canvas,
rect(0,i-j,bmpwidth,i-j+1));
j:=j-2;
end;
form1.canvas.draw(120,100,newbmp);
i:=i+2;
end;
newbmp.free;
end;
3.水平交错效果
原理：同垂直交错效果原理一样，只是将分成两组后的图形分别由左右两端移进屏幕。
程序算法：
procedure tform1.button5click(sender: tobject);
var
newbmp:tbitmap;
i,j,bmpheight,bmpwidth:integer;
begin
newbmp:= tbitmap.create;
newbmp.width:=image1.width;
newbmp.height:=image1.height;
bmpheight:=image1.height;
bmpwidth:=image1.width;
i:=0;
while i< =bmpwidth do
begin
j:=i;
while j >0 do
begin
newbmp.canvas.copyrect(rect(j-1,0,j,bmpheight),
image1.canvas,
rect(bmpwidth-i+j-1,0,bmpwidth-i+j,bmpheight));
newbmp.canvas.copyrect(rect
(bmpwidth-j,0,bmpwidth-j+1,bmpheight),
image1.canvas,
rect(i-j,0,i-j+1,bmpheight));
j:=j-2;
end;
form1.canvas.draw(120,100,newbmp);
i:=i+2;
end;
newbmp.free;
end;
4.雨滴效果
原理：将暂存图形的最后一条扫描线，依序搬移到可视位图的第一条到最后一条扫描线，让此条扫描线在屏幕上留下它的轨迹。接着再把暂存图形的倒数第二条扫描线，依序搬移到可视位图的第一条到倒数第二条扫描线。其余的扫描线依此类推。
程序算法：
procedure tform1.button3click(sender: tobject);
var
newbmp:tbitmap;
i,j,bmpheight,bmpwidth:integer;
begin
newbmp:= tbitmap.create;
newbmp.width:=image1.width;
newbmp.height:=image1.height;
bmpheight:=image1.height;
bmpwidth:=image1.width;
for i:=bmpheight downto 1 do
for j:=1 to i do
begin
newbmp.canvas.copyrect(rect(0,j-1,bmpwidth,j),
image1.canvas,
rect(0,i-1,bmpwidth,i));
form1.canvas.draw(120,100,newbmp);
end;
newbmp.free;
end;
5.百叶窗效果
原理：将放在暂存图形的数据分成若干组，然后依次从第一组到最后一组搬移，第一次每组各搬移第一条扫描线到可视位图的相应位置，第二次搬移第二条扫描线，接着搬移第三条、第四条扫描线.
程序算法：
procedure tform1.button6click(sender: tobject);
var
newbmp:tbitmap;
i,j,bmpheight,bmpwidth:integer;
xgroup,xcount:integer;
begin
newbmp:= tbitmap.create;
newbmp.width:=image1.width;
newbmp.height:=image1.height;
bmpheight:=image1.height;
bmpwidth:=image1.width;
xgroup:=16;
xcount:=bmpheight div xgroup;
for i:=0 to xcount do
for j:=0 to xgroup do
begin
newbmp.canvas.copyrect(rect
(0,xcount*j+i-1,bmpwidth,xcount*j+i),
image1.canvas,
rect(0,xcount*j+i-1,bmpwidth,xcount*j+i));
form1.canvas.draw(120,100,newbmp);
end;
newbmp.free;
end;
6.积木效果
原理：是雨滴效果的一种变化，不同之处在于，积木效果每次搬移的是一块图形，而不只是一根扫描线。
程序算法：
procedure tform1.button7click(sender: tobject);
var
newbmp:tbitmap;
i,j,bmpheight,bmpwidth:integer;
begin
newbmp:= tbitmap.create;
newbmp.width:=image1.width;
newbmp.height:=image1.height;
bmpheight:=image1.height;
bmpwidth:=image1.width;
i:=bmpheight;
while i>0 do
begin
for j:=10 to i do
begin
newbmp.canvas.copyrect(rect(0,j-10,bmpwidth,j),
image1.canvas,
rect(0,i-10,bmpwidth,i));
form1.canvas.draw(120,100,newbmp);
end;
i:=i-10;
end;
newbmp.free;
end;
结束语
上述图形显示效果均已上机通过。使用效果很好。
用Delphi实现图像放大镜
　　向窗体上添加两个TImage组件，其中一个TImage组件的Name属性设置为Image1，它充当原图片显示的载体。另一个TImage组件的Name属性设置为Image2，它可以显示放大后的图像。添加组件后的窗体如图1所示。

图1 添加组件后的窗体

　　本例的核心是StretchBlt函数，利用StretchBlt函数实现局部图像放大，响应代码如下：
procedure TForm1.Image1MouseMove(Sender: TObject; Shift: TShiftState; X, Y: Integer);
begin
　StretchBlt(Image2.Canvas.Handle,0,0,Image2.Width,Image2.Height,
　Image1.Canvas.Handle, X-20,Y-20,40,40,SRCCOPY);
　Image2.Refresh;
　Screen.Cursors[1]:=LoadCursorFromFile(’MAGNIFY.CUR’);
　Self.Cursor:=1;
end;

　　程序首先会调用StretchBlt函数，以鼠标当前位置作为中心点，以边长为40选中Image1组件上的局部图像，并放大此局部图像到Image2 组件上。然后通过调用Image2组件的Refresh方法以刷新Image2组件的显示。最后设置鼠标指针为新的形状。

　　程序代码如下：
unit Unit1;
interface
uses

Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms,
Dialogs, ExtCtrls, StdCtrls;

type
　TForm1 = class(TForm)
　Image1: TImage;
　Image2: TImage;
　procedure Image1MouseMove(Sender: TObject; Shift: TShiftState; X,Y: Integer);
　procedure FormMouseMove(Sender: TObject; Shift: TShiftState; X,Y: Integer);
private
　{ Private declarations }
public
　{ Public declarations }
end;

var
　Form1: TForm1;
　implementation
　{$R *.dfm}
　procedure TForm1.Image1MouseMove(Sender:TObject;Shift:TShiftState;X,Y: Integer);
　begin
　　StretchBlt(Image2.Canvas.Handle,0,0,Image2.Width,Image2.Height,Image1.Canvas.Handle, X-20,Y-20,40,40,SRCCOPY);
　　Image2.Refresh;
　　Screen.Cursors[1]:=LoadCursorFromFile(’MAGNIFY.CUR’);
　　Self.Cursor:=1;
end;

procedure TForm1.FormMouseMove(Sender: TObject; Shift: TShiftState; X,Y: Integer);
begin
　Screen.Cursors[1]:=crDefault;
　Self.Cursor:=1;
end;
end.

　　保存文件，然后按F9键运行程序，程序运行结果如图2所示。

图2 程序运行结果

　　放大图像是一个优秀的看图软件必备的功能，本实例提供了一种非常简便易行的方法，不但代码数量少，而且执行效率高。

轉貼自 http://blog.csdn.net/xujh/article/details/1858254

ListView排序

procedure TForm1.ListView1Compare(Sender: TObject; Item1,
Item2: TListItem; Data: Integer; var Compare: Integer);
begin
Compare := CompareText(Item1.caption, Item2.caption);
end;

procedure TForm1.BitBtn1Click(Sender: TObject);
begin
listview1.AlphaSort;
end;

將subitems納入排序 (Listview Column2)

procedure TForm1.ListView1Compare(Sender: TObject; Item1,
Item2: TListItem; Data: Integer; var Compare: Integer);
begin
Compare := CompareText(Item1.subitems[0], Item2.subitems[0]);
end;

procedure TForm1.BitBtn1Click(Sender: TObject);
begin
listview1.AlphaSort;
end;

[轉貼]Thread 多執行續 Sample

type
// 宣告執行序
TTestThread = class(TThread)
private
FStrings: TStrings;
procedure AddToStrings;
protected
procedure Execute; override;
public
constructor Create(CreateSuspended: Boolean; Strings: TStrings);
end;

// 列出執行序的 ThreadID
procedure TTestThread.AddToStrings;
begin
FStrings.Add('ThreadID: ' + IntToStr(ThreadID));
end;

{
CreateSuspended 建立時先不執行
Strings 要列出訊息的 Strings
}
constructor TTestThread.Create(CreateSuspended: Boolean; Strings: TStrings);
begin
inherited Create(CreateSuspended);
FStrings := Strings;
end;

procedure TTestThread.Execute;
begin
// 當未停止時列出執行序的 ThreadID
while not Terminated do
begin
Synchronize(AddToStrings);
Sleep(1000);
end;
end;
-------------------------------------------------------------------------------------------
var
TestThread: TTestThread;

procedure TForm1.FormCreate(Sender: TObject);
begin
// 印出主執行序 MainThreadID
Memo1.Lines.Add('MainThreadID: ' + IntToStr(MainThreadID));
// 建立執行序，並在建立時就執行運作
TestThread := TTestThread.Create(False, Memo1.Lines);
end;

procedure TForm1.FormClose(Sender: TObject; var Action: TCloseAction);
begin
// 停止執行序
TestThread.Terminate;
TestThread.Free;
end

轉貼:http://solnone.blogspot.tw/2009/05/delphi-thread.html

[轉貼]Delphi TThread中文注释

TThread是一个抽象类，可以创建几个独立的线程。
类关系 TObject
在一个多线程的应用程序中创建一个TThread的后子类代表一个线程。每一新子类的TThread对象的实例是一个新的线程。从TThread派生的多线程实例可以构成Delphi的多线程应用程序。
　　当一个应用程序运行时，应用程序就被载入内存准备执行。此时，它成为包含一个或多个线程的进程，每个线程含有数据、代码和系统资源。线程执行应用程序的部分内容，并由系统分配CPU时间。同一进程的所有线程共享同一地址空间，可以访问进程的全局变量。线程通过以下工作改善应用的性能：管理多通信设备的输入。
　　区分任务的优先级。优先级高的处理紧急的任务。优先级低的处理其他任务。
　　以下是使用线程的一些建议：
　　同时跟踪太多的线程消耗CPU时间。对单处理器系统，一个进程最多有16个线程。
　　当多个线程更新相同的资源时，应使线程同步以避免冲突。
　　大多数访问VCL对象和更新窗体的方法必须从主VCL线程内部调用。
　　以下为创建和使用一个新线程的过程：
　　（1）单击File|New|Thread菜单项，创建一个包含对象的新单元，该对象源于TThread类。
　　（2）定义新线程对象和Create方法。
　　（3）通过插入线程执行时需要的代码定义线程对象和Execute方法。
　　（4）将使用VCL组件的任何调用传递给Synchronize方法，以避免多线程冲突。

属性列表
FreeOnTerminate 线程终止时该对象是否自动删除
Handle 包含线程句柄
Priority 确定该线程相对于进程中其他线程的优先级
ReturnValue 返回线程值
Suspended 指示一线程是否被挂起
Terminated 表明线程被要求终止
ThreadID 标识贯穿系统的线程

方法列表
~TThread 删除线程对象并释放其战用的内存空间
DoTerminate 产生一个OnTerminate事件
Execute 提供包含线程执行时所需代码的抽象方法
Resume 重新执行一个挂起的线程
Suspend 挂起一个运行中的线程
Synchronize 在主VCL线程中执行Method
Terminate 将Ternimated属性设置为True通知线程终止
TThread 创建一个线程对象的实例
WaitFor 等待线程终止并返回ReturnValue属性值

事件列表
OnTerminateExecute 方法已返回且该线程被删除前发生

属性

TThread::FreeOnTerminate
__property bool FreeOnTerminate = {read=FFreeOnTerminate,write=FFreeOnTerminate,nodefault};
确定当线程终止时，该线程对象是否自动删除。
FreeOnTerminate默认值为False，线程对象必须在代码中显示删除。
包含线程句柄。
当调用Win32API函数处理线程时，使用Handle.

TThread::Priority
__property TThreadPriority Priority = {read=GetPriority,write=SetPriority,nodefault};
确定该线程相对于进程中其他线程的优先级。
Priority属性为一枚举类型，其默认为tpNormal.
TThreadPriority类型定义了TThread组件的Priority属性的可能值，如下表所述。Windows根据优先级确定每一个线程的CPU周期。
_____________________________________________________________________
　　　值　　　　　　　　　　　含义
_____________________________________________________________________
tpIdle 只有当系统空闲时该线程执行
tpLowest 线程优先级比正常低2点
tpLower 线程优先级比正常低1点
tpNormal 线程优先级为正常值
tpHigher 线程优先级比正常高1点
tpHighest 线程优先级比正常高2点
tpTimeCritical 线程优先级最高

TThread::ReturnValue
__property int ReturnValue = {read=FReturnValue,write=FReturnValue,nodefault};
返回线程值。
使用ReturnValue应用为其他线程指示其成功/失败或数字结果/输出。WaitFor方法返回存储在ReturnValue中的值。

TThread::Suspended
__property bool Suspended = {read=FSuspended,write=SetSuspended,nodefault};
指示一线程是否被挂起。
除非重新执行，否则被挂起的线程不会继续执行。若将Suspended设置为True将挂起一个线程；若设置为False,则继续执行该线程。

TThread::Terminated
__property bool Terminated = {read=FTerminated,nodefault};
表明线程被要求终止。Terminate方法将Terminated属性设置为True。
线程的Execute方法和任何Execute调用的方法将周期性地检查Terminated，当其为True时，将终止执行。

TThread::ThreadID
__property int ThreadID = {read=FhreadID,nodefault};
标识贯穿系统的线程。
当调用Win32API函数处理线程时，ThreadID将十分有用。
注意：ThreadID与Handle属性不同。

方法

TThread::~TThread
__fastcall virvual ~TThread(void);
删除线程对象并释放其战胜的内存空间。
在应用中不要调用~TThread。用delete替代。
~TThread通知线程终止，并在调用Destroy方法前等待该线程返回。

TThread::DoTerminate
virtual void __fastcall DoTerminate(void);
产生一个OnTerminate事件。
DoTerminate调用OnTerminate时间句柄，但并不终止该线程。

TThread::Execute
virtual void __fastcall Execute(void) =0;
提供包含线程执行时所需代码的抽象方法。
Execute查看Terminated属性值以决定该线程是否需要终止。
当CreateSuspended被设置为False，当调用Create时，一线程执行；在线程创建后先调用了Resume且CreateSuspended为True，一线程执行。
注意：不要在线程的Execute方法中直接调用

其他对象的属性和方法。应该将对其他对象的使用分成几个不同的过程，将其作为一个传递到Synchronize方法的参数分别调用。

TThread::Resume
void __fastcall Resume(void);
重新执行一个挂起的线程。
调用Suspend可以嵌套。因此调用Resume必须注意次序。

TThread::Suspend
void __fastcall Suspend(void);
挂起一个运行中的线程。
调用Resume可以继续运行。调用Suspend可以嵌套。因此调用Resume必须次序。

TThread::Synchronize
typedef void __fastcall(__closure* TThreadMethod)(void);
void __fastcall Synchronize (TThreadMethod&Method);
在主VCL线程中执行Method。
Synchronize方法由Method指定的调用被主VCL线程执行。
注意：当在主VCL线程中执行Method时，当前的线程被挂起。

TThread::Terminate
void __fastcall Terminate(void);
通过将Terminated属性设置为True通知线程终止。
线程的Execute方法以及Execute调用的任何方法应周期性的检查Terminated，当其为True时终止运行。

TThread::TThread
__fastcall TThread(bool CreateSuspended);
创建一个线程对象的实例。
在应用中不要直接使用TThread来创建线程。用new替代，传递CreateSuspended参数argument。若 CreateSuspended为False,Execute被立即调用。若CreateSuspended为True,Execute直到Resume 被调用后才被调用。

TThread::WaitFor
int __fastcall WaitFor(void);
等待线程终止并返回ReturnValue属性值。
直到线程终止时WaitFor才返回，因此线程一定是因为结束了Execute方法或因Terminated属性为了True而终止。如果该线程使用Synchronize,则不要在主VCL线程中调用WaitFor，否则或者引起系统死机，或者产生一个EThread异常。
Synchronize在允许该方法生效前等待主VCL线程进入信息回路。若主VCL 线程已经调用了WaitFor,它将不会进入信息回路，Synchronize也永远不会返回。此时，TThread将产生一个EThread意外并使该线程终止；而且如果该意外没有被Execute方法截获，该应用也将终止。如果调用WaitFor时，Synchronize已经在VCL线程中等待，TThread将不会干预，应用程序将死机。

事件

TThread::OnTerminate
__property TNotifyEvent OnTerminate = {read=FOnTerminate,write=FOnTerminate};
当线程的Execute方法已经返回且在该线程被删除之前发生。
OnTerminate事件句柄在主VCL线程被调用。该线程对象也可在该事件中被释放。

轉貼:http://eelab.gxu.edu.cn/list.asp?Unid=543

訂閱：文章 (Atom)

2017年9月7日 星期四

2017年9月7日星期四