本例效果图:
program Project1;
uses
Windows,
Messages;
{供 WM_LBUTTONDOWN 消息调用的自定义过程}
procedure OnLButtonDown(h: HWND);
var
BrushHandle: HBRUSH;
Rect: TRect;
begin
GetClientRect(h, Rect); {获取客户区矩形}
BrushHandle := CreateSolidBrush(RGB(255,0,0)); {建立红色笔刷}
FillRect(GetDC(h), Rect, BrushHandle); {填充客户区}
DeleteObject(BrushHandle); {删除笔刷}
end;
{供 WM_LBUTTONUP 消息调用的自定义过程}
procedure OnLButtonUp(h: HWND);
var
Rect: TRect;
begin
GetClientRect(h, Rect); {获取客户区矩形}
InvalidateRect(h, @Rect, True); {使客户区无效, 从而强制重绘}
end;
{供 WM_MOUSEMOVE 消息调用的自定义过程}
procedure onm ouseMove(h: HWND; lParam: Integer);
var
pt: TPoint;
buf: array[0..255] of Char;
begin
pt.X := LoWord(lParam); {lParam 中的低两位是 x 坐标}
pt.Y := HiWord(lParam); {lParam 中的高两位是 y 坐标}
wvsprintf(buf, '%d, %d', @pt); {格式化到缓冲区}
SetWindowText(h, buf); {显示在标题}
end;
function WndProc(wnd: HWND; msg: UINT; wParam: Integer; lParam: Integer): Integer; stdcall;
begin
Result := 0;
case msg of
WM_LBUTTONDOWN: OnLButtonDown(wnd); {鼠标左键按下的消息}
WM_LBUTTONUP : OnLButtonUp(wnd); {鼠标左键抬起的消息}
WM_MOUSEMOVE : onm ouseMove(wnd, lParam); {鼠标移动的消息, 坐标位置在 lParam 中}
WM_DESTROY : PostQuitMessage(0);
else
Result := DefWindowProc(wnd, msg, wParam, lParam);
end;
end;
function RegMyWndClass: Boolean;
var
cls: TWndClass;
begin
cls.style := CS_HREDRAW or CS_VREDRAW;
cls.lpfnWndProc := @WndProc;
cls.cbClsExtra := 0;
cls.cbWndExtra := 0;
cls.hInstance := HInstance;
cls.hIcon := 0;
cls.hCursor := LoadCursor(0, IDC_ARROW);
cls.hbrBackground := HBRUSH(COLOR_WINDOW + 1);
cls.lpszMenuName := nil;
cls.lpszClassName := 'MyWnd';
Result := RegisterClass(cls) <> 0;
end;
{程序入口}
const
tit = 'New Form';
ws = WS_OVERLAPPEDWINDOW;
x = 100; y = 100; w = 300; h = 180;
var
hWnd: THandle;
Msg : TMsg;
begin
RegMyWndClass;
hWnd := CreateWindow('MyWnd', tit, ws, x, y, w, h, 0, 0, HInstance, nil);
ShowWindow(hWnd, SW_SHOWNORMAL);
UpdateWindow(hWnd);
while(GetMessage(Msg, 0, 0, 0)) do
begin
TranslateMessage(Msg);
DispatchMessage(Msg);
end;
end.
posted on
2008-04-19 11:34
万一
阅读(9088)
评论(1)
编辑
收藏