Power-Programmierung/CD1.mdf/pascal/tpw/owldemos/bitbtn.pas

Pascal/Delphi Source File | 1991-05-20 | 7KB | 263 lines

{************************************************}
{                                                }
{   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.