{******************************************************************************}
{ }
{ Demo Bitmap-Menü }
{ }
{ Copyright (c) 2001 Michael Puff }
{ www.luckie-online.de }
{ mpuff@luckie-online.de }
{ }
{******************************************************************************}
program bitmapmenu;
{$R resource.res}
uses
Windows,
Messages;
const
ClassName = '
WndClass';
AppName = '
Bitmap-Menü-Demo';
WindowWidth = 500;
WindowHeight = 350;
IDM_KUCKUCK = 1;
IDM_LERCHE = 2;
IDM_SPATZ = 3;
var
hMenu, hPopupMenu: Cardinal;
{ GetLastError }
function DisplayErrorMsg(hWnd: THandle): DWORD;
var
szBuffer:
array[0..255]
of Char;
begin
FormatMessage(FORMAT_MESSAGE_FROM_SYSTEM,
nil, GetLastError, 0, szBuffer,
sizeof(szBuffer),
nil);
MessageBox(hWnd, szBuffer, '
Fehler', MB_ICONSTOP);
result := GetLastError;
end;
procedure MenuBmp(idBmpStart: DWORD;
dc: HDC; cntItems, ItemHeight: Byte; hWnd: Cardinal);
var
i: Integer;
hBmp: HBITMAP;
bmp: Windows.BITMAP;
hdcBmp: HDC;
begin
for i := 0
to cntItems-1
do
begin
hBmp := LoadBitmap(hInstance, MAKEINTRESOURCE(idBmpStart+i));
GetObject(hBmp, sizeof(BITMAP), @bmp);
hdcBmp := CreateCompatibleDC(
dc);
SelectObject(hdcBmp, hBmp);
StretchBlt(
dc, 2, ItemHeight*i+2, 15, 15, hdcBmp, 0, 0, bmp.bmWidth, bmp.bmHeight, SRCCOPY);
end;
ReleaseDC(hWnd, hdcBmp);
DeleteObject(hBmp);
end;
function WndProc(hWnd: HWND; uMsg: UINT; wParam: wParam; lParam: LParam):
lresult;
stdcall;
var
mi : PMEASUREITEMSTRUCT;
di : PDRAWITEMSTRUCT;
begin
Result := 0;
case uMsg
of
WM_CREATE:
begin
hMenu := CreateMenu;
hPopupMenu := CreateMenu;
AppendMenu(hPopupMenu, MF_OWNERDRAW, IDM_KUCKUCK, '
&Kuckuck');
AppendMenu(hPopupMenu, MF_OWNERDRAW, IDM_LERCHE, '
&Lerche');
AppendMenu(hPopupMenu, MF_OWNERDRAW, IDM_SPATZ, '
&Spatz');
AppendMenu(hMenu, MF_POPUP, hPopupMenu, '
&Datei');
SetMenu(hWnd, hMenu);
end;
WM_MEASUREITEM:
begin
mi := PMEASUREITEMSTRUCT(lParam);
case mi.CtlType
of
ODT_MENU:
begin
mi.itemWidth := 100;
mi.itemHeight := 19;
end
end;
end;
WM_DRAWITEM:
begin
di := PDRAWITEMSTRUCT(lParam);
case di.CtlType
of
ODT_MENU:
begin
if (di.itemState
and ODS_SELECTED = ODS_SELECTED)
then
begin
FillRect(di.hDC, di.rcItem, GetSysColorBrush(COLOR_HIGHLIGHT));
SetTextColor(di.hDC, GetSysColor(COLOR_HIGHLIGHTTEXT));
end
else
begin
FillRect(di.hDC, di.rcItem, GetSysColorBrush(COLOR_BTNFACE));
SetTextColor(di.hDC, GetSysColor(COLOR_WINDOWTEXT));
end;
SetBkMode(di.hDC, TRANSPARENT);
di.rcItem.Left := di.rcItem.left + 30;
DrawText(di.hDC, PChar(di.itemData), lstrlen(PChar(di.itemData)), di.rcItem,
DT_SINGLELINE
or DT_VCENTER);
MenuBmp(101, di.hDC, 3, 19, hWnd);
end;
end;
end;
WM_COMMAND:
begin
if HiWord(wParam) = 0
then
case LoWord(wParam)
of
IDM_KUCKUCK: SendMessage(hWnd, WM_CLOSE, 0,0 );
end;
end;
WM_DESTROY: PostQuitMessage(0);
else
Result := DefWindowProc(hWnd, uMsg, wParam, lParam);
end;
end;
var
wc: TWndClassEx = (
cbSize : SizeOf(TWndClassEx);
Style : CS_HREDRAW
or CS_VREDRAW;
lpfnWndProc : @WndProc;
cbClsExtra : 0;
cbWndExtra : 0;
hbrBackground : COLOR_APPWORKSPACE;
lpszMenuName :
nil;
lpszClassName : ClassName;
hIconSm : 0;
);
msg: TMsg;
begin
wc.hInstance := hInstance;
wc.hIcon := LoadIcon(0, IDI_APPLICATION);
wc.hCursor := LoadCursor(0, IDC_ARROW);
RegisterClassEx(wc);
CreateWindowEx(0, ClassName, AppName, WS_CAPTION
or WS_VISIBLE
or
WS_SYSMENU, Integer(CW_USEDEFAULT),Integer(CW_USEDEFAULT), WindowWidth,
WindowHeight, 0, 0, hInstance,
nil);
while true
do
begin
if not GetMessage(msg, 0, 0, 0)
then
break;
begin
TranslateMessage(msg);
DispatchMessage(msg);
end;
end;
ExitCode := msg.wParam;
end.