Turbo Pascal 7.0 / TP7 / OWLDEMOS / BITBTN

{************************************************}
{ }
{ Turbo Pascal for Windows }
{ Demo library (DLL) }
{ Copyright (c) 1991 by Borland International }
{ }
{************************************************}

library BitBtn;

uses WinTypes, WinProcs;

{$R BITBTN.RES}

const
ofState = 0;
ofDownBits = 2;
ofUpBits = 4;
ofFocUpBits = 6;
ofSize = 8; { Amount of window extra bytes to use }

const
bdBorderWidth = 1;

const
bsDisabled = $0001;
bsFocus = $0002;
bsKeyDown = $0004;
bsMouseDown = $0008;
bsMouseUpDown = $0010;
bsDefault = $0020;

function BitButtonWinFn(HWindow: HWnd; Message: Word; wParam: Word;
lParam: Longint): Longint; export;
var
DC: HDC;
BitsNumber: Integer;
Bitmap: TBitmap;
Rect: TRect;
Pt: TPoint;
PS: TPaintStruct;

function Get(Ofs: Integer): Word;
begin
Get := GetWindowWord(HWindow, Ofs);
end;

procedure SetWord(Ofs: Integer; Val: Word);
begin
SetWindowWord(HWindow, Ofs, Val);
end;

function State: Word;
begin
State := Get(ofState);
end;

function DownBits: Word;
begin
DownBits := Get(ofDownBits);
end;

function UpBits: Word;
begin
UpBits := Get(ofUpBits);
end;

function FocUpBits: Word;
begin
FocUpBits := Get(ofFocUpBits);
end;

function GetState(AState: Word): Boolean;
begin
GetState := (State and AState) = AState;
end;

procedure Paint(DC: HDC);
var
MemDC: HDC;
Bits, Oldbitmap: HBitmap;
BorderBrush, OldBrush: HBrush;
Frame: TRect;
Height, Width: Integer;
begin
if (State and (bsMouseDown + bsKeyDown) <> 0) and
not GetState(bsMouseUpDown) then
Bits := DownBits
else
if GetState(bsFocus) then Bits := FocUpBits
else Bits := UpBits;

{ Draw border }
GetClientRect(HWindow, Frame);
Height := Frame.bottom - Frame.top;
Width := Frame.right - Frame.left;

if GetState(bsDefault) then
BorderBrush := GetStockObject(Black_Brush)
else BorderBrush := GetStockObject(White_Brush);
OldBrush := SelectObject(DC, BorderBrush);
PatBlt(DC, Frame.left, Frame.top, Width, bdBorderWidth, PatCopy);
PatBlt(DC, Frame.left, Frame.top, bdBorderWidth, Height, PatCopy);
PatBlt(DC, Frame.left, Frame.bottom - bdBorderWidth, Width,
bdBorderWidth, PatCopy);
PatBlt(DC, Frame.right - bdBorderWidth, Frame.top, bdBorderWidth,
Height, PatCopy);
SelectObject(DC, OldBrush);

{ Draw bitmap }
MemDC := CreateCompatibleDC(DC);
OldBitmap := SelectObject(MemDC, Bits);
GetObject(Bits, Sizeof(Bitmap), @Bitmap);
BitBlt(DC, bdBorderWidth, bdBorderWidth, Bitmap.bmWidth, Bitmap.bmHeight,
MemDC, 0, 0, srcCopy);
SelectObject(MemDC, OldBitmap);
DeleteDC(MemDC);
end;

procedure Repaint;
var
DC: HDC;
begin
DC := GetDC(HWindow);
Paint(DC);
ReleaseDC(HWindow, DC);
end;

procedure SetState(AState: Word; Enable: Boolean);
var
OldState: Word;
begin
OldState := State;
if Enable then SetWord(ofState, State or AState)
else SetWord(ofState, State and not AState);
if State <> OldState then Repaint;
end;

function InMe(lPoint: Longint): Boolean;
var
R: TRect;
Point: TPoint absolute lPoint;
begin
GetClientRect(HWindow, R);
InflateRect(R, -bdBorderWidth, -bdBorderWidth);
InMe := PtInRect(R, Point);
end;

procedure ButtonPressed;
begin
SetState(bsMouseDown + bsMouseUpDown + bsKeyDown, False);
SendMessage(GetParent(HWindow), wm_Command, GetDlgCtrlID(HWindow),
Longint(HWindow));
end;

begin
BitButtonWinFn := 0;
case Message of
wm_Create:
begin
DC := GetDC(0);
if (GetSystemMetrics(sm_CYScreen) < 480) or
(GetDeviceCaps(DC, numColors) < 16) then
BitsNumber := 2000 + Get(gww_ID)
else
BitsNumber := 1000 + Get(gww_ID);
ReleaseDC(0, DC);

SetWord(ofUpBits, LoadBitmap(hInstance, PChar(BitsNumber)));
SetWord(ofDownBits, LoadBitmap(hInstance, pChar(BitsNumber + 2000)));
SetWord(ofFocUpBits, LoadBitmap(hInstance, pChar(BitsNumber + 4000)));
GetObject(DownBits, SizeOf(Bitmap), @Bitmap);
GetWindowRect(HWindow, Rect);
Pt.X := Rect.Left;
Pt.Y := Rect.Top;
ScreenToClient(PCreateStruct (lParam)^.hwndParent, Pt);
MoveWindow(HWindow, Pt.X, Pt.Y,
Bitmap.bmWidth + bdBorderWidth * 2,
Bitmap.bmHeight + bdBorderWidth * 2, False);
if (PCreateStruct(lParam)^.style and $1F) = bs_DefPushButton then
SetState(bsDefault, True);
end;
wm_NCDestroy:
begin
BitButtonWinFn := DefWindowProc(HWindow, Message, wParam, lParam);
DeleteObject(UpBits);
DeleteObject(DownBits);
DeleteObject(FocUpBits);
end;
wm_Paint:
begin
BeginPaint(HWindow, PS);
Paint(PS.hDC);
EndPaint(HWindow, PS);
end;
wm_EraseBkGnd:
begin
end;
wm_Enable:
SetState(bsDisabled, wParam <> 0);
wm_SetFocus:
SetState(bsFocus, True);
wm_KillFocus:
SetState(bsFocus, False);
wm_KeyDown:
if (wParam = $20) and not GetState(bsKeyDown) and
not GetState(bsMouseDown) then
SetState(bsKeyDown, True);
wm_KeyUP:
if (wParam = $20) and GetState(bsKeyDown) then
ButtonPressed;
wm_LButtonDblClk, wm_LButtonDown:
if InMe(lParam) and not GetState(bsKeyDown) then
begin
if GetFocus <> HWindow then SetFocus(HWindow);
SetState(bsMouseDown, True);
SetCapture(HWindow);
end;
wm_MouseMove:
if GetState(bsMouseDown) then
SetState(bsMouseUpDown, not InMe(lParam));
wm_LButtonUp:
if GetState(bsMouseDown) then
begin
ReleaseCapture;
if not GetState(bsMouseUpDown) then ButtonPressed
else SetState(bsMouseDown + bsMouseUpDown, False);
end;
wm_GetDlgCode:
if GetState(bsDefault) then
BitButtonWinFn:= dlgc_DefPushButton
else
BitButtonWinFn := dlgc_UndefPushButton;
bm_SetStyle:
SetState(bsDefault, wParam = bs_DefPushButton);
else
BitButtonWinFn := DefWindowProc(HWindow, Message, wParam, lParam);
end;
end;

exports
BitButtonWinFn;

var
Class: TWndClass;

begin
with Class do
begin
lpszClassName := 'BitButton';
hCursor := LoadCursor(0, idc_Arrow);
lpszMenuName := nil;
style := cs_HRedraw or cs_VRedraw or cs_DblClks or cs_GlobalClass;
lpfnWndProc := TFarProc(@BitButtonWinFn);
hInstance := System.hInstance;
hIcon := 0;
cbWndExtra := ofSize;
cbClsExtra := 0;
hbrBackground := 0;
end;
RegisterClass(Class);
end.