基本完全Copy李维大师的《Inside VCL》书中的代码(P18-P20),手敲调试绝对好过简单的下载复制。
只有出错才能提高,我相信。
没有使用VCL Framework,纯粹Win API调用,带来的是仅有44KB的文件大小。
其实Windows窗体程序的流程也很简单:
- 定义窗体类——窗体类名为 AppName = 'ET_PureObjectPascalWindow'
- 注册窗体类——function WinRegister: Boolean;
- 创建窗体——function WinCreate: HWND;
- 窗体消息循环
while GetMessage(AMessage, 0, 0, 0) do begin TranslateMessage(AMessage); DispatchMessage(AMessage) end;
- 处理窗体消息——function WindowProc(Window: HWND; AMessage: UINT; WParam: WPARAM; LParam: LPARAM): LRESULT; stdcall; export;
- 直到程序结束
代码如下:
program TestWinAPI;
uses
Windows, Messages, SysUtils;
const
AppName = 'ET_PureObjectPascalWindow';
function WindowProc(Window: HWND; AMessage: UINT; WParam: WPARAM; LParam: LPARAM): LRESULT; stdcall; export;
var
dc: HDC;
ps: TPaintStruct;
r: TRect;
begin
Result := 0;
case AMessage of
WM_PAINT: begin
dc := BeginPaint(Window, ps);
GetClientRect(Window, r);
DrawText(dc, '纯粹使用Object Pascal写的Native Windows程序,有够拉风吧!', -1, r, DT_SINGLELINE or DT_CENTER or DT_VCENTER);
EndPaint(Window, ps);
end;
WM_DESTROY: begin
PostQuitMessage(0);
end;
else
Result := DefWindowProc(Window, AMessage, WParam, LParam);
end;
end;
function WinRegister: Boolean;
var
WindowClass: WNDCLASS;
begin
with WindowClass do begin
style := CS_HREDRAW or CS_VREDRAW;
lpfnWndProc := TFNWndProc(@WindowProc);
cbClsExtra := 0;
cbWndExtra := 0;
hInstance := MainInstance;
hIcon := LoadIcon(0, IDI_APPLICATION);
hCursor := LoadCursor(0, IDC_ARROW);
hbrBackground := GetStockObject(WHITE_BRUSH);
lpszMenuName := nil;
lpszClassName := AppName;
end;
Result := RegisterClass(WindowClass) <> 0;
end;
function WinCreate: HWND;
var
hWindow: HWND;
begin
hWindow := CreateWindow(AppName, '爱生活,爱拉风', WS_OVERLAPPEDWINDOW,
CW_USEDEFAULT, CW_USEDEFAULT, CW_USEDEFAULT, CW_USEDEFAULT,
0, 0, MainInstance, nil);
if hWindow <> 0 then begin
ShowWindow(hWindow, CmdShow);
ShowWindow(hWindow, SW_SHOW);
UpdateWindow(hWindow);
end;
Result := hWindow;
end;
var
AMessage: TMsg;
hWindow: HWND;
begin
if not WinRegister then begin
MessageBox(0, 'WinRegister failed', nil, MB_OK);
Exit;
end;
hWindow := WinCreate;
if LongInt(hWindow) = 0 then begin
MessageBox(0, 'WinCreate failed', nil, MB_OK);
Exit;
end;
while GetMessage(AMessage, 0, 0, 0) do begin
TranslateMessage(AMessage);
DispatchMessage(AMessage)
end;
Halt(AMessage.wParam);
end.