PC World Komputer 1998 January/Pcwk0198.iso/Dcomplib/BWCCDEL.LZH/BWCCDEL.PAS

Pascal/Delphi Source File | 1997-03-22 | 20KB | 782 lines

unit Bwccdel; {BWCC Delphi Controls
               Author: Xiao Luo  }



{You can use this program in any application you want without
 notice the author of this program.  You may freely distrubute
 this program as long as it's author is presented clearly as
 the original author.  You may also change this program and reproduce
 newer verison for this program as long as it's free.}

 {Supported by DragonsoftMedia Inc. Xiao Luo (C) 1996,1997}



interface

uses
  SysUtils,
  WinTypes,
  WinProcs,
  Messages,
  Classes,
  Graphics,
  Controls,
  Forms,
  Dialogs,
  Menus,
  StdCtrls;

const
 idhelp=998;

 BBS_BITMAP=$8000;
 BBS_PARENTNOTIFY=$2000;
 BBS_OWNERDRAW=$1000;
 BBM_SETBITS=BM_SETSTYLE+10;
 BBN_SETFOCUS=BN_DOUBLECLICKED + 10;
 BBN_SETFOCUSMOUSE=BN_DOUBLECLICKED + 11;
 BBN_GOTATAB=BN_DOUBLECLICKED + 12;
 BBN_GOTABTAB=BN_DOUBLECLICKED + 13;
 BBN_MOUSEENTER=BN_DOUBLECLICKED + 14;
 BBN_MOUSELEAVE=BN_DOUBLECLICKED + 14;

 BSS_GROUP=1;
 BSS_HDIP=2;
 BSS_VDIP=3;
 BSS_HBUMP=4;
 BSS_VBUMP=5;
 BSS_RGROUP=6;

 BSS_CAPTION=$8000;
 BSS_CTLCOLOR=$4000;
 BSS_NOPREFIX=$2000;
 BSS_LEFT=0;
 BSS_CENTER=$0100;
 BSS_RIGHT=$0200;
 BSS_ALIGNMASK=$030;

var
  loaderror:integer;


type
  Eloadlibraryerror=class(Exception);
  TDefStyle=(DefualtButton, PushButton);
  TSTATE=(Highlighted,Normal);
  TBWCCButtonKind=(WordOnly,
OK,Cancel,About,Retry,Ignore,Yes,No,
Help);


  TBorBtn=class(TButtonControl)
    private
      CurrentKind:TDefStyle;
      CurrentState:TSTATE;
      CurrentBWCCKind:TBWCCButtonKind;
      FDefault: Boolean;
      FCancel: Boolean;
      FActive: Boolean;
      FReserved: Byte;
      FModalResult: TModalResult;
      function GetKind:TBWCCButtonKind;
      procedure SetKind(Value:TBWCCButtonKind);
      procedure SetDefault(Value: Boolean);
      procedure CMDialogKey(var Message: TCMDialogKey); message CM_DIALOGKEY;
      procedure CMDialogChar(var Message: TCMDialogChar); message CM_DIALOGCHAR;
      procedure CMFocusChanged(var Message: TCMFocusChanged); message CM_FOCUSCHANGED;
      procedure CNCommand(var Message: TWMCommand); message CN_COMMAND;
    protected
      procedure CreateParams(var Params: TCreateParams); override;
      procedure CreateWnd; override;
      procedure SetButtonStyle(ADefault: Boolean); virtual;
    public
      procedure SetBits(Bit1,Bit2,Bit3:HBitmap);
      constructor Create(AOwner: TComponent); override;
      procedure Click; override;
   published
{      property kind read getkind; write setkind;}
      property Kind:TBWCCButtonKind read GetKind write SetKind;
    property Cancel: Boolean read FCancel write FCancel default False;
    property Caption;
    property Default: Boolean read FDefault write SetDefault default False;
    property DragCursor;
    property DragMode;
    property Enabled;
    property Font;
    property ModalResult: TModalResult read FModalResult write FModalResult default 0;
    property ParentFont;
    property ParentShowHint;
    property PopupMenu;
    property ShowHint;
    property TabOrder;
    property TabStop default True;
    property Visible;
    property OnClick;
    property OnDragDrop;
    property OnDragOver;
    property OnEndDrag;
    property OnEnter;
    property OnExit;
    property OnKeyDown;
    property OnKeyPress;
    property OnKeyUp;
    property OnMouseDown;
    property OnMouseMove;
    property OnMouseUp;
    property OnDBlClick;
  end;

  TBorRadio = class(TButtonControl)
  private
    FAlignment: TLeftRight;
    FChecked: Boolean;
    procedure SetAlignment(Value: TLeftRight);
    procedure WMSetFocus(var Message: TWMSetFocus); message WM_SETFOCUS;
    procedure CMCtl3DChanged(var Message: TMessage); message CM_CTL3DCHANGED;
    procedure CMDialogChar(var Message: TCMDialogChar); message CM_DIALOGCHAR;
    procedure CNCommand(var Message: TWMCommand); message CN_COMMAND;
  protected
    procedure SetChecked(Value: Boolean);
    procedure CreateParams(var Params: TCreateParams); override;
    procedure CreateWnd; override;
  public
    constructor Create(AOwner: TComponent); override;
  published
    property Alignment: TLeftRight read FAlignment write SetAlignment default taRightJustify;
    property Caption;
    property Checked: Boolean read FChecked write SetChecked default False;
    property Color;
    property DragCursor;
    property DragMode;
    property Enabled;
    property Font;
    property ParentColor;
    property ParentCtl3D;
    property ParentFont;
    property ParentShowHint;
    property PopupMenu;
    property ShowHint;
    property TabOrder;
    property TabStop;
    property Visible;
    property OnClick;
    property OnDblClick;
    property OnDragDrop;
    property OnDragOver;
    property OnEndDrag;
    property OnEnter;
    property OnExit;
    property OnKeyDown;
    property OnKeyPress;
    property OnKeyUp;
    property OnMouseDown;
    property OnMouseMove;
    property OnMouseUp;
  end;


  TBorCheck = class(TButtonControl)
  private
    FAlignment: TLeftRight;
    FAllowGrayed: Boolean;
    FState: TCheckBoxState;
    FReserved: Byte;
    function GetChecked: Boolean;
    procedure SetAlignment(Value: TLeftRight);
    procedure SetChecked(Value: Boolean);
    procedure SetState(Value: TCheckBoxState);
    procedure WMSetFocus(var Message: TWMSetFocus); message WM_SETFOCUS;
    procedure CMCtl3DChanged(var Message: TMessage); message CM_CTL3DCHANGED;
    procedure CMDialogChar(var Message: TCMDialogChar); message CM_DIALOGCHAR;
    procedure CNCommand(var Message: TWMCommand); message CN_COMMAND;
  protected
    procedure Toggle; virtual;
    procedure CreateParams(var Params: TCreateParams); override;
    procedure CreateWnd; override;
  public
    constructor Create(AOwner: TComponent); override;
  published
    property State: TCheckBoxState read FState write SetState default cbUnchecked;
    property Alignment: TLeftRight read FAlignment write SetAlignment default taRightJustify;
    property AllowGrayed: Boolean read FAllowGrayed write FAllowGrayed default False;
    property Caption;
    property Checked: Boolean read GetChecked write SetChecked stored False;
    property Color;
    property Ctl3D;
    property DragCursor;
    property DragMode;
    property Enabled;
    property Font;
    property ParentColor;
    property ParentCtl3D;
    property ParentFont;
    property ParentShowHint;
    property PopupMenu;
    property ShowHint;
    property TabOrder;
    property TabStop default true;
    property Visible;
    property OnClick;
    property OnDragDrop;
    property OnDragOver;
    property OnEndDrag;
    property OnEnter;
    property OnExit;
    property OnKeyDown;
    property OnKeyPress;
    property OnKeyUp;
    property OnMouseDown;
    property OnMouseMove;
    property OnMouseUp;
  end;

 TShadeStyle=(Group,Raisedgroup,Hdip,Vdip,HBump,VBump);
 TBorShade=Class(TCustomControl)
  protected
    FStyle:TShadeStyle;
    function GetStyle:TShadeStyle;
    procedure SetStyle(value:TShadeStyle);
    procedure CreateParams(var Params: TCreateParams); override;
  public
    constructor Create(AOwner: TComponent); override;
  published
    property Style:TShadeStyle read GetStyle write SetStyle;
    property Ctl3D;
    property Align;
    property Caption;
    property Color;
    property DragCursor;
    property DragMode;
    property Enabled;
    property Font;
    property ParentColor;
    property ParentCtl3D;
    property ParentFont;
    property ParentShowHint;
    property PopupMenu;
    property ShowHint;
    property TabOrder;
    property TabStop;
    property Visible;
    property OnClick;
    property OnDblClick;
    property OnDragDrop;
    property OnDragOver;
    property OnEndDrag;
    property OnEnter;
    property OnExit;
    property OnMouseDown;
    property OnMouseMove;
    property OnMouseUp;
  end;

function LoadDIBbitmap(Instance:word;Name:PChar):TBitmap;
function  BWCCVersion:single;
procedure BWCCRegister(hinst:word);
function  BWCCIntlInit(language:word):boolean;
function  BWCCIntlTerm: boolean;
function  BWCCGetVersion:integer;
function  BWCCGetPattern:word;
function  BWCCmessagebox(WndParent: HWND; Txt,Caption: PChar; TextType: Word): Integer;
procedure GetBWCCBitmap(Name:string;Assignto:Tbitmap);

procedure register;

var
  OldExitProc:Pointer;
implementation

function LoadDIBbitmap(Instance:word;Name:PChar):Tbitmap;
const
  BM = $4D42;  {Bitmap type identifier}
var
  Bmp: TBitmap;
  BMF: TBitmapFileHeader;
  HResInfo: THandle;
  MemHandle: THandle;
  Stream: TMemoryStream;
  ResPtr: PByte;
  ResSize: Longint;
begin
  BMF.bfType := BM;
  {Find, Load, and Lock the Resource containing BITMAP_1}
  HResInfo := FindResource(Instance, Name, RT_Bitmap);
  MemHandle := LoadResource(HInstance, HResInfo);
  ResPtr := LockResource(MemHandle);

  {Create a Memory stream, set its size, write out the bitmap
   header, and finally write out the Bitmap                  }
  Stream := TMemoryStream.Create;
  ResSize := SizeofResource(HInstance, HResInfo);
  Stream.SetSize(ResSize + SizeOf(BMF));
  Stream.Write(BMF, SizeOf(BMF));
  Stream.Write(ResPtr^, ResSize);

  {Free the resource and reset the stream to offset 0}
  FreeResource(MemHandle);
  Stream.Seek(0, 0);

  {Create the TBitmap and load the image from the MemoryStream}
  Bmp := TBitmap.Create;
  Bmp.LoadFromStream(Stream);
  result.assign(BMP);
  Bmp.Free;
  Stream.Free;
end;

  {$f+}
  procedure BWCCRegister(hinst:word);
  external 'BWCC';
  {$f-}

  {$f+}
  function  BWCCIntlInit(language:word):boolean;
  external 'BWCC';
  {$f-}

  {$f+}
  function  BWCCIntlTerm: boolean;
  external 'BWCC';
  {$f-}

  {$f+}
  function  BWCCGetVersion:integer;
  external 'BWCC';
  {$f-}

  function BWCCversion:single;
   var a:word;
       b:single;
  begin
    a:=BWCCgetversion;
    b:=a div 256;
    b:=b+ a mod 256;
    BWCCVersion:=b;
  end;

  {$f+}
  function  BWCCGetPattern:word;
  external 'BWCC';
  {$f-}

  {$f+}
  function  BWCCmessagebox(WndParent: HWND; Txt,Caption: PChar; TextType: Word): Integer;
  external 'BWCC';
  {$f-}

  {$f+}
  Procedure GetBWCCbitmap(Name:string;Assignto:Tbitmap);
  Var
   a:HBitmap;
   b:Pchar;
  begin
    getmem(b,sizeof(name));
    strpcopy(b,name);
    a:=loadbitmap(loaderror,b);
    assignto.handle:=a;
    deleteobject(a);
    freemem(b,sizeof(name));
  end;

constructor TBorBtn.Create(AOwner: TComponent);
begin
  inherited Create(AOwner);
  ControlStyle := [csSetCaption, csOpaque, csDoubleClicks];
  Width := 89;
  Height := 33;
  TabStop := True;
  CurrentBWCCKind:=Kind;
  SetKind(CurrentBWCCKind);
end;

procedure TBorBtn.Click;
var
  Form: TForm;
begin
  Form := GetParentForm(Self);
  if Form <> nil then Form.ModalResult := ModalResult;
  inherited Click;
end;

procedure TBorBtn.SetButtonStyle(ADefault: Boolean);
const
  BS_MASK = $000F;
var
  Style: Word;
begin
  if HandleAllocated then
  begin
    if ADefault then Style := BS_DEFPUSHBUTTON else Style := BS_PUSHBUTTON;
    if GetWindowLong(Handle, GWL_STYLE) and BS_MASK <> Style then
      SendMessage(Handle, BM_SETSTYLE, Style, 1);
  end;
end;

procedure TBorBtn.SetDefault(Value: Boolean);
begin
  FDefault := Value;
  if HandleAllocated then
    with GetParentForm(Self) do
      Perform(CM_FOCUSCHANGED, 0, Longint(ActiveControl));
end;

procedure TBorBtn.CreateParams(var Params: TCreateParams);
const
  ButtonStyles: array[Boolean] of LongInt = (BS_PUSHBUTTON, BS_DEFPUSHBUTTON);
begin
  inherited CreateParams(Params);
  CreateSubClass(Params, 'borbtn');
  with Params do Style := Style or ButtonStyles[FDefault];
end;

procedure TBorBtn.CreateWnd;
begin
  inherited CreateWnd;
  FActive := FDefault;
end;

procedure TBorBtn.CNCommand(var Message: TWMCommand);
begin
  if Message.NotifyCode = BN_CLICKED then Click;
end;

procedure TBorBtn.CMDialogKey(var Message: TCMDialogKey);
begin
  with Message do
    if  (((CharCode = VK_RETURN) and FActive) or
      ((CharCode = VK_ESCAPE) and FCancel)) and
      (KeyDataToShiftState(Message.KeyData) = []) and CanFocus then
    begin
      Click;
      Result := 1;
    end else
      inherited;
end;

procedure TBorBtn.CMDialogChar(var Message: TCMDialogChar);
begin
  with Message do
    if IsAccel(CharCode, Caption) and CanFocus then
    begin
      Click;
      Result := 1;
    end else
      inherited;
end;

procedure TBorBtn.CMFocusChanged(var Message: TCMFocusChanged);
begin
  with Message do
    if Sender is TBorBtn then
      FActive := Sender = Self
    else
      FActive := FDefault;
  SetButtonStyle(FActive);
  inherited;
end;


  procedure TBorBtn.SetBits(bit1,bit2,bit3:HBitmap);
    type a=array[0..2] of Hbitmap;
    var
       bits:a;
       Bitsp:^a;
    begin
       new(bitsp);
       Bits[0] := bit1;
       Bits[1] := bit2;
       Bits[2] := bit3;
       bitsp:=addr(bits);
       Perform(BBM_SETBITS, 0, longint(bitsp));
   end;

   function TBorBtn.GetKind:TBWCCbuttonKind;
   begin
     Result:=CurrentBWCCKind;
   end;

   procedure TBorBtn.SetKind(Value:TBWCCbuttonKind);
   var bit1,bit2,bit3:HBitmap;
       i:integer;
   begin
      CurrentBWCCKind:=Value;
      bit1:=0;
      bit2:=0;
      bit3:=0;
      if CurrentBWCCKind=WordOnly then begin
      i:=1999;
      bit1:=loadbitmap(loaderror,makeintresource(i));
      i:=3000+999;
      bit2:=loadbitmap(loaderror,makeintresource(i));
      i:=5000+999;
      bit3:=loadbitmap(loaderror,makeintresource(i));
      SetBits(bit1,bit2,bit3);
      end
      else
      begin
      if value<>Help then begin
      i:=1000+ord(Value);
      bit1:=loadbitmap(loaderror,makeintresource(i));
      i:=3000+ord(Value);
      bit2:=loadbitmap(loaderror,makeintresource(i));
      i:=5000+ord(Value);
      bit3:=loadbitmap(loaderror,makeintresource(i));
      SetBits(bit1,bit2,bit3);
      caption:='';
      end
      else
      begin
      i:=1000+idhelp;
      bit1:=loadbitmap(loaderror,makeintresource(i));
      i:=3000+idhelp;
      bit2:=loadbitmap(loaderror,makeintresource(i));
      i:=5000+idhelp;
      bit3:=loadbitmap(loaderror,makeintresource(i));
      SetBits(bit1,bit2,bit3);
      caption:='';
      end;
      end;
     Refresh;
   end;

constructor TBorRadio.Create(AOwner: TComponent);
begin
  inherited Create(AOwner);
  Width := 113;
  Height := 17;
  ControlStyle := [csSetCaption, csDoubleClicks];
  FAlignment := taRightJustify;
end;

procedure TBorRadio.SetAlignment(Value: TLeftRight);
begin
  if FAlignment <> Value then
  begin
    FAlignment := Value;
    RecreateWnd;
  end;
end;

procedure TBorRadio.SetChecked(Value: Boolean);

procedure TurnSiblingsOff;
  var
    I: Integer;
    Sibling: TControl;
  begin
    if Parent <> nil then
      with Parent do
        for I := 0 to ControlCount - 1 do
        begin
          Sibling := Controls[I];
          if (Sibling <> Self) and (Sibling is TBorRadio) then
            TBorRadio(Sibling).SetChecked(False);
        end;
  end;

begin
  if FChecked <> Value then
  begin
    FChecked := Value;
    TabStop := Value;
    if HandleAllocated then
      SendMessage(Handle, BM_SETCHECK, Cardinal(Checked), 0);
    if Value then
    begin
      TurnSiblingsOff;
      Click;
    end;
  end;
end;

procedure TBorRadio.CreateParams(var Params: TCreateParams);
const
  Alignments: array[TLeftRight] of LongInt = (BS_LEFTTEXT, 0);
begin
  inherited CreateParams(Params);
  CreateSubClass(Params, 'borradio');
  with Params do
    Style := Style or BS_RADIOBUTTON or BBS_PARENTNOTIFY or Alignments[FAlignment];
end;

procedure TBorRadio.CreateWnd;
begin
  inherited CreateWnd;
  SendMessage(Handle, BM_SETCHECK, Cardinal(FChecked), 0);
end;

procedure TBorRadio.WMSetFocus(var Message: TWMSetFocus);
begin
    inherited;
end;

procedure TBorRadio.CMCtl3DChanged(var Message: TMessage);
begin
  RecreateWnd;
end;

procedure TBorRadio.CMDialogChar(var Message: TCMDialogChar);
begin
  with Message do
    if IsAccel(Message.CharCode, Caption) and CanFocus then
    begin
      SetFocus;
      Result := 1;
    end else
      inherited;
end;

procedure TBorRadio.CNCommand(var Message: TWMCommand);
begin
  case Message.NotifyCode of
    BN_CLICKED: SetChecked(True);
    BN_DOUBLECLICKED: DblClick;
  end;
end;

constructor TBorCheck.Create(AOwner: TComponent);
begin
  inherited Create(AOwner);
  Width := 97;
  Height := 17;
  TabStop := True;
  ControlStyle := [csSetCaption, csDoubleClicks];
  FAlignment := taRightJustify;
  FState := cbUnchecked;
end;

procedure TBorCheck.Toggle;
begin
  case State of
    cbUnchecked:
      if AllowGrayed then State := cbGrayed else State := cbChecked;
    cbChecked: State := cbUnchecked;
    cbGrayed: State := cbChecked;
  end;
end;

function TBorCheck.GetChecked: Boolean;
begin
  Result := State = cbChecked;
end;

procedure TBorCheck.SetAlignment(Value: TLeftRight);
begin
  if FAlignment <> Value then
  begin
    FAlignment := Value;
    RecreateWnd;
  end;
end;

procedure TBorCheck.SetChecked(Value: Boolean);
begin
  if Value then State := cbChecked else State := cbUnchecked;
end;

procedure TBorCheck.SetState(Value: TCheckBoxState);
begin
  if FState <> Value then
  begin
    FState := Value;
    if HandleAllocated then
      SendMessage(Handle, BM_SETCHECK, Cardinal(FState), 0);
    Click;
  end;
end;

procedure TBorCheck.CreateParams(var Params: TCreateParams);
const
  Alignments: array[TLeftRight] of LongInt = (BS_LEFTTEXT, 0);
begin
  inherited CreateParams(Params);
  CreateSubClass(Params, 'borcheck');
  with Params do
    Style := Style or BS_3STATE or BBS_PARENTNOTIFY or Alignments[FAlignment];
end;

procedure TBorCheck.CreateWnd;
begin
  inherited CreateWnd;
  SendMessage(Handle, BM_SETCHECK, Cardinal(FState), 0);
end;

procedure TBorCheck.WMSetFocus(var Message: TWMSetFocus);
begin
  if Ctl3D and (Ctl3DBtnWndProc <> nil) then UpdateWindow(Handle);
  inherited;
end;

procedure TBorCheck.CMCtl3DChanged(var Message: TMessage);
begin
  RecreateWnd;
end;

procedure TBorCheck.CMDialogChar(var Message: TCMDialogChar);
begin
  with Message do
    if IsAccel(CharCode, Caption) and CanFocus then
    begin
      SetFocus;
      if Focused then Toggle;
      Result := 1;
    end else
      inherited;
end;

procedure TBorCheck.CNCommand(var Message: TWMCommand);
begin
  if Message.NotifyCode = BN_CLICKED then Toggle;
end;

constructor TBorshade.Create(Aowner:TComponent);
begin
  inherited create(AOWNER);
  Width:=50;
  Height:=50;
  FStyle:=Group;
end;

procedure Tborshade.CreateParams(var Params:
TCreateParams);
begin
  inherited CreateParams(Params);
  CreateSubClass(Params, 'borshade');
  with Params do
    Style := Style or Ord(FStyle)+1 or BSS_Caption;
end;

function Tborshade.GetStyle:TShadeStyle;
begin
 result:=Fstyle;
end;

procedure Tborshade.SetStyle(Value:TShadeStyle);
begin
 FStyle:=Value;
 Recreatewnd;
end;

procedure register;
  begin
    registercomponents('BWCC',[TBorBtn]);
    registercomponents('BWCC',[TBorRadio]);
    registercomponents('BWCC',[TBorCheck]);
    registercomponents('BWCC',[TBorShade]);
  end;

  procedure BWCCExitProc;far;
  begin
    ExitProc:=OldExitProc;
    If LoadError>=32 then FreeLibrary(Loaderror);
  end;
initialization
  loaderror:=loadlibrary('BWCC.DLL');
  if loaderror<HINSTANCE_ERROR then
    raise Eloadlibraryerror.create('Cannot Load Library!');
   OldExitProc:=ExitProc;
   ExitProc:=@BWCCExitProc;
end.