unit APIControl;

interface

uses
  Windows,
  Messages,
  UtilFunc,
  UTilClass;

type

TAPICreateParams = record
  Caption: string;
  Style: Longint;
  ExStyle: Longint;
  X, Y: Integer;
  Width, Height: Integer;
  WinClassName: array[0..63] of Char;
end;

//----------- TSelfSubClass -----------------------------------------
TSelfSubClass = class(TSubClass)
private
  FHandle: HWND;
  FID: HMenu;
protected
  procedure APICreateParams(var Params: TAPICreateParams); virtual; abstract;
  procedure Initialize; virtual; abstract;
public
  constructor Create(hParent: HWND); override;
  destructor Destroy; override;
  procedure DestroyObject;
  property Handle: HWND read FHandle;
  property ID: HMenu read FID;
end;

//----------- TAPIContol -------------------------------------------
TAPIControl = class(TSelfSubClass)
private
  function GetCaption: string;
  procedure SetCaption(value: string);
  function GetDimension: TRect;
  procedure SetDimension(value: TRect);
  function GetXPos: integer;
  procedure SetXPos(value: integer);
  function GetYPos: integer;
  procedure SetYPos(value: integer);
  function GetWidth: integer;
  procedure SetWidth(value: integer);
  function GetHeight: integer;
  procedure SetHeight(value: integer);
  function GetEnable: Boolean;
  procedure SetEnable(value:Boolean);
  function GetVisible: Boolean;
  procedure SetVisible(value: Boolean);
protected
  procedure Initialize; override;
public
  destructor Destroy; override;
  property Caption: string read GetCaption write SetCaption;
  property Dimension : TRect read GetDimension write SetDimension;
  property XPos: integer read GetXPos write SetXPos;
  property YPos: integer read GetYPos write SetYPos;
  property Width: integer read GetWidth write SetWidth;
  property Height: integer read GetHeight write SetHeight;
  property Enable: Boolean read GetEnable write SetEnable;
  property Visible: Boolean read GetVisible write SetVisible;
end;

//---------- TAPIButton ----------------------------------------------
TAPIButton = class(TAPIControl)
private
  FOnClick: TNotifyMessage;
protected
  procedure APICreateParams(var Params: TAPICreateParams); override;
public
  procedure DefaultHandler(var Message); override;
  property OnClick: TNotifyMessage read FOnClick write FOnClick;
end;

//---------- TAPICheckBox ----------------------------------------------
TCBTextStyle = (cbtRight,cbtLeft);

TAPICheckBox = class(TAPIControl)
private
  FChecked: Boolean;
  FTextStyle: TCBTextStyle;
  FReadOnly: Boolean;
  FIndeterminate: Boolean;
  FOnClick: TNotifyMessage;
  procedure SetChecked(value:Boolean);
  procedure SetTextStyle(value:TCBTextStyle);
  procedure SetIndeterminate(value: Boolean);
protected
  procedure APICreateParams(var Params: TAPICreateParams); override;
  procedure Initialize; override;
public
  procedure DefaultHandler(var Message); override;
  property Checked: Boolean read FChecked write SetChecked;
  property TextStyle: TCBTextStyle read FTextStyle write SetTextStyle;
  property DoIndeterminate: Boolean read FIndeterminate write SetIndeterminate;
  property ReadOnly: Boolean read FReadOnly write FReadOnly;
  property OnClick: TNotifyMessage read FOnClick write FOnClick;
end;

//---------- TAPIRadioButton --------------------------------------------
TAPIRadioButton = class(TAPIControl)
private
  FTextStyle: TCBTextStyle;
  FGroupIndex: Integer;
  FOnClick: TNotifyMessage;
  function GetChecked:Boolean;
  procedure SetChecked(value:Boolean);
  procedure SetTextStyle(value:TCBTextStyle);
protected
  procedure APICreateParams(var Params: TAPICreateParams); override;
  procedure Initialize; override;
public
  procedure DefaultHandler(var Message); override;
  property Checked: Boolean read GetChecked write SetChecked;
  property TextStyle: TCBTextStyle read FTextStyle write SetTextStyle;
  property GroupIndex: integer read FGroupIndex write FGroupIndex;
  property OnClick: TNotifyMessage read FOnClick write FOnClick;
end;

//---------- APIPushRadio --------------------------------------------
TAPIPushRadio = class(TAPIRadioButton)
protected
  procedure APICreateParams(var Params: TAPICreateParams); override;
end;

//---------- APIGroupBox ---------------------------------------------
TGBTextAlign = (gbtLeft, gbtCenter, gbtRight);// TextAlign of APIGroupBox

TAPIGroupBox = class(TAPIControl)
private
  FTextAlign: TGBTextAlign;
  procedure SetTextAlign(value:TGBTextAlign);
protected
  procedure APICreateParams(var Params: TAPICreateParams); override;
  procedure Initialize; override;
public
  property TextAlign: TGBTextAlign read FTextAlign write SetTextAlign;
end;

//
//---------- Create Functions ---------------------------------------
//
function CreateButton(hParent: HWND; x,y,cx,cy: integer;sCaption: string;
                      sOnClick:TNotifyMessage): TAPIButton;
function CreateCheckBox(hParent: HWND; x,y,cx,cy: integer;sCaption: string;
                      sOnClick:TNotifyMessage): TAPICheckBox;
function CreateRadioButton(hParent: HWND; x,y,cx,cy: integer;sCaption: string;
            Group: integer; sOnClick:TNotifyMessage): TAPIRadioButton;

function CreatePushRadio(hParent: HWND; x,y,cx,cy: integer;sCaption: string;
            Group: integer; sOnClick:TNotifyMessage): TAPIPushRadio;
function CreateGroupBox(hParent: HWND; x,y,cx,cy: integer;
                       sCaption: string): TAPIGroupBox;


implementation


var
  ID_CONT: integer = 400;

//----------- TSelfSubClass -----------------------------------------
function SelfSubClassProc(hWnd: HWND; Msg: UINT;
                       wParam: WPARAM; lParam: LPARAM): LRESULT; stdcall;
var
  PascalObject: TSelfSubClass;
  OriginalProc: TFNWndProc;
  SBMsg: TMessage;
begin
  OriginalProc := TFNWndProc(GetProp(hWnd,'WNDPROC'));
  result := CallWindowProc(OriginalProc,hWnd,Msg,wParam,lParam);
  PascalObject := TSelfSubClass(GetProp(hWnd,'OBJECT'));

  case Msg of

    WM_DESTROY: if Assigned(PascalObject) then PascalObject.Free;

  else
    if Assigned(PascalObject) then begin
      SBMsg.Msg := Msg;
      SBMsg.WParam := wParam;
      SBMsg.LParam := lParam;
      SBMsg.Result := 0;
      PascalObject.Dispatch(SBMsg);
      if SBMsg.Result <> 0 then result := SBMsg.Result;
    end;
  end; // case

end;

constructor TSelfSubClass.Create(hParent: HWnd);
var
  Params: TAPICreateParams;
  DefWndProc: TFNWndProc;
begin
  inherited Create(hParent);
  APICreateParams(Params);
  with Params do begin
    FHandle := CreateWindowEx(ExStyle,WinClassName,PChar(Caption),
                Style,X, Y, Width, Height,
                hParent,
                ID_CONT,
                hInstance,
                nil);
  end;

  if IsWindow(FHandle) then begin
    SetProp(FHandle,'OBJECT',Integer(self));
    DefWndProc := TFNWndProc(SetWindowLong(FHandle,
                            GWL_WNDPROC,Integer(@SelfSubClassProc)));
    SetProp(FHandle,'WNDPROC',integer(DefWndProc));
  end;

  FID := ID_CONT; Inc(ID_CONT);

  Initialize;
end;

destructor TSelfSubClass.Destroy;
begin
  SetWindowLong(FHandle,GWL_WNDPROC,GetProp(FHandle,'WNDPROC'));
  RemoveProp(FHandle,'OBJECT');
  RemoveProp(FHandle,'WNDPROC');
  inherited Destroy;
end;

procedure TSelfSubClass.DestroyObject;
begin
  DestroyWindow(FHandle);
end;

//----------- TAPIControl -----------------------------------------
destructor TAPIControl.Destroy;
begin
                        
  inherited Destroy;
end;

procedure TAPIControl.Initialize;
begin
  Dispatcher.TrapMessage(WM_COMMAND,self);
end;

function TAPIControl.GetCaption: string;
var
  s: string;
begin
  SetLength(s,50);
  SetString(result,PChar(s),GetWindowText(FHandle,PChar(s),50));
end;

procedure TAPIControl.SetCaption(value: string);
begin
  SetWindowText(FHandle, PChar(Value));
end;

function TAPIControl.GetDimension: TRect;
begin
  result := SetDim(XPos,YPos,Width,Height);
end;

procedure TAPIControl.SetDimension(value: TRect);
begin
  MoveWindow(FHandle,value.left, value.top,
                   value.right, value.bottom, true);
end;

function TAPIControl.GetXPos: integer;
var
  r: TRect;
  p: TPoint;
begin
  GetWindowRect(FHandle,r);
  p.x := r.Left; p.y := r.Top;
  ScreenToClient(Parent,p);
  result := p.x;
end;

procedure TAPIControl.SetXPos(value: integer);
begin
  ChangeWindowPos(FHandle,value,YPos);
end;

function TAPIControl.GetYPos: integer;
var
  r: TRect;
  p: TPoint;
begin
  GetWindowRect(FHandle,r);
  p.x := r.Left; p.y := r.Top;
  ScreenToClient(Parent,p);
  result := p.y;
end;

procedure TAPIControl.SetYPos(value: integer);
begin
  ChangeWindowPos(FHandle,XPos,value);
end;

function TAPIControl.GetWidth: integer;
var
  r: TRect;
begin
  GetWindowRect(FHandle,r);
  result := r.Right-r.Left;
end;

procedure TAPIControl.SetWidth(value: integer);
begin
  ChangeWindowSize(FHandle,value,Height);
end;

function TAPIControl.GetHeight: integer;
var
  r: TRect;
begin
  GetWindowRect(FHandle,r);
  result := r.Bottom-r.Top;
end;

procedure TAPIControl.SetHeight(value: integer);
begin
  ChangeWindowSize(FHandle,Width,value);
end;

function TAPIControl.GetEnable: Boolean;
begin
  result := Boolean(IsWindowEnabled(FHandle));
end;

procedure TAPIControl.SetEnable(value: Boolean);
begin
  EnableWindow(FHandle,value);
end;

function TAPIControl.GetVisible: Boolean;
begin
  result := Boolean(IsWindowVisible(FHandle));
end;

procedure TAPIControl.SetVisible(value:Boolean);
begin
  if value then
    ShowWindow(FHandle,SW_SHOWNORMAL)
  else
    ShowWindow(FHandle,SW_HIDE);
end;

//--------------- TAPIButton ----------------------------------------------
procedure TAPIButton.APICreateParams(var Params: TAPICreateParams);
begin
  with Params do begin
    Caption := 'APIButton';
    Style := WS_CHILD or WS_VISIBLE or WS_TABSTOP or
             WS_CLIPSIBLINGS or BS_PUSHBUTTON;
    ExStyle := 0;
    X := 0;
    Y := 0;
    Width := 0;
    Height := 0;
    WinClassName := 'BUTTON';
  end;
end;

procedure TAPIButton.DefaultHandler(var Message);
var
  AMsg:TMessage;
begin
  AMsg := TMessage(message);
  case AMsg.Msg of
    WM_COMMAND:
      if (AMsg.LParam = LongInt(FHandle)) and (AMsg.WParamHi = BN_CLICKED) then
         if Assigned(FOnClick) then begin
           AMsg.Msg := UINT(self); // Sender
           OnClick(AMsg);
         end;
  end; // case
end;

//
//---------- Create Functions ---------------------------------------
//
function CreateButton(hParent: HWND; x,y,cx,cy: integer;sCaption: string;
                      sOnClick:TNotifyMessage): TAPIButton;
begin
  result := TAPIButton.Create(hParent);
  with result do begin
    Dimension := SetDim(x,y,cx,cy);
    Caption := sCaption;
    OnClick := sOnClick;
  end;
end;

//---------- TAPICheckBox ----------------------------------------------
procedure TAPICheckBox.Initialize;
begin
  inherited Initialize;

  FChecked := false;
  FTextStyle := cbtRight;
  FReadOnly := false;
  FIndeterminate := false;
end;

procedure TAPICheckBox.APICreateParams(var Params: TAPICreateParams);
begin
  with Params do begin
    Caption := 'APICheckBox';
    Style := WS_CHILD or WS_VISIBLE or WS_TABSTOP or
             WS_CLIPSIBLINGS or BS_3STATE;
    ExStyle := 0;
    X := 50;
    Y := 50;
    Width := 150;
    Height := 32;
    WinClassName := 'BUTTON';
  end;
end;

procedure TAPICheckBox.DefaultHandler(var Message);
var
  AMsg: TMessage;
begin
  if FReadOnly then Exit;
  AMsg := TMessage(message);
  case AMsg.Msg of
    WM_COMMAND:
      if (AMsg.LParam = LPARAM(FHandle)) and (AMsg.WParamHi = BN_CLICKED) then begin
        Checked := not Checked;
        AMsg.Msg := UINT(self); // Sender
        if Assigned(FOnClick)then OnClick(AMsg);
      end;
  end; // case
end;

procedure TAPICheckBox.SetChecked(value:Boolean);
begin
  FChecked := value;
  if value then
    SendMessage(FHandle,BM_SETCHECK,BST_CHECKED,0)
  else
    SendMessage(FHandle,BM_SETCHECK,BST_UNCHECKED,0);
end;

procedure TAPICheckBox.SetTextStyle(value:TCBTextStyle);
var
  Style: LongInt;
begin
  if FTextStyle = value then exit;
  FTextStyle := value;
  Style := GetWindowLong(FHandle,GWL_STYLE);
  if value = cbtLeft then
    SetWindowLong(FHandle,GWL_STYLE,(Style or BS_LEFTTEXT))
  else
    SetWindowLong(FHandle,GWL_STYLE,(Style and (not BS_LEFTTEXT)));
  InvalidateRect(FHandle,nil,true);
end;

procedure TAPICheckBox.SetIndeterminate(value: Boolean);
begin
  if value then
    SendMessage(FHandle,BM_SETCHECK,BST_INDETERMINATE,0)
  else
    if FChecked then Checked := true else Checked := false;
  FIndeterminate := value;
end;

function CreateCheckBox(hParent: HWND; x,y,cx,cy: integer;sCaption: string;
                      sOnClick:TNotifyMessage): TAPICheckBox;
begin
  result := TAPICheckBox.Create(hParent);
  with result do begin
    Dimension := SetDim(x,y,cx,cy);
    Caption := sCaption;
    OnClick := sOnClick;
  end;
end;

//---------- TAPIRadioButton --------------------------------------------
procedure TAPIRadioButton.Initialize;
begin
  inherited Initialize;

  FTextStyle := cbtRight;
  FGroupIndex := 0;
end;

procedure TAPIRadioButton.APICreateParams(var Params: TAPICreateParams);
begin
  with Params do begin
    Caption := 'APIRadioButton';
    Style := WS_CHILD or WS_VISIBLE or WS_TABSTOP or
             WS_CLIPSIBLINGS or BS_RADIOBUTTON;
    ExStyle := 0;
    X := 50;
    Y := 50;
    Width := 150;
    Height := 32;
    WinClassName := 'BUTTON';
  end;
end;

function UnCheckSameRadioGroup(hWindow: HWND; Data:LParam): Boolean; stdcall;
var
  sobject: TObject;
begin
  result := true;
  if GetProp(hWindow,'OBJECT') <> 0 then begin
    sobject := TObject(GetProp(hWindow,'OBJECT'));
    if (sobject is TAPIRadioButton) and
          (TAPIRadioButton(sobject).GroupIndex = Data) then
       TAPIRadioButton(sobject).Checked := false;
  end;
end;

procedure UnCheckSameGroup(hParent: HWND; GroupIndex:Integer);
begin
  EnumChildWindows(hParent,@UnCheckSameRadioGroup,GroupIndex);
end;

procedure TAPIRadioButton.DefaultHandler(var Message);
var
  AMsg: TMessage;
begin
  AMsg := TMessage(message);
  case AMsg.Msg of
    WM_COMMAND:
      if (AMsg.LParam = LPARAM(FHandle)) and (AMsg.WParamHi = BN_CLICKED) then begin
        if FGroupIndex = 0 then begin
          Checked := not Checked;
        end else begin // グループ化されている
          UnCheckSameGroup(Parent,FGroupIndex);
          Checked := true;
        end;
        AMsg.Msg := UINT(self);
        if Assigned(FOnClick)then OnClick(AMsg);
      end;
  end; // case
end;

function TAPIRadioButton.GetChecked:Boolean;
begin
  result := Boolean(SendMessage(FHandle,BM_GETCHECK,0,0));
end;

procedure TAPIRadioButton.SetChecked(value:Boolean);
begin
  if value then
    SendMessage(FHandle,BM_SETCHECK,1,0)
  else
    SendMessage(FHandle,BM_SETCHECK,0,0);
end;

procedure TAPIRadioButton.SetTextStyle(value:TCBTextStyle);
var
  Style: LongInt;
begin
  if FTextStyle = value then exit;
  FTextStyle := value;
  Style := GetWindowLong(FHandle,GWL_STYLE);
  if value = cbtLeft then
    SetWindowLong(FHandle,GWL_STYLE,(Style or BS_LEFTTEXT))
  else
    SetWindowLong(FHandle,GWL_STYLE,(Style and (not BS_LEFTTEXT)));
  InvalidateRect(FHandle,nil,true);
end;

//---------- TAPIPushRadio --------------------------------------------
procedure TAPIPushRadio.APICreateParams(var Params: TAPICreateParams);
begin
  inherited APICreateParams(Params);
  with Params do begin
    Caption := 'APIPushRadio';
    Style := Style or BS_PUSHLIKE;
  end;
end;

function CreateRadioButton(hParent: HWND; x,y,cx,cy: integer;sCaption: string;
            Group: integer; sOnClick:TNotifyMessage): TAPIRadioButton;
begin
  result := TAPIRadioButton.Create(hParent);
  with result do begin
    Dimension := SetDim(x,y,cx,cy);
    Caption := sCaption;
    GroupIndex := Group;
    OnClick := sOnClick;
  end;
end;

function CreatePushRadio(hParent: HWND; x,y,cx,cy: integer;sCaption: string;
            Group: integer; sOnClick:TNotifyMessage): TAPIPushRadio;
begin
  result := TAPIPushRadio.Create(hParent);
  with result do begin
    Dimension := SetDim(x,y,cx,cy);
    Caption := sCaption;
    GroupIndex := Group;
    OnClick := sOnClick;
  end;
end;

//---------- APIGroupBox ---------------------------------------------
procedure TAPIGroupBox.Initialize;
begin
  inherited Initialize;
  FTextAlign := gbtLeft;
end;

procedure TAPIGroupBox.APICreateParams(var Params: TAPICreateParams);
begin
  with Params do begin
    Caption := 'APIGroupBox';
    Style := WS_CHILD or WS_VISIBLE or  WS_CLIPSIBLINGS or
             BS_GROUPBOX or BS_LEFT;
    ExStyle := 0;
    X := 50;
    Y := 50;
    Width := 150;
    Height := 32;
    WinClassName := 'BUTTON';
  end;
end;

procedure TAPIGroupBox.SetTextAlign(value:TGBTextAlign);
var
  Style,SetStyle: LongInt;
  r: TRect;
begin
  if FTextAlign = value then Exit;
  FTextAlign := value;
  Style := GetWindowLong(FHandle,GWL_STYLE);
  SetStyle := Style and (not BS_CENTER);
  case value of
    gbtLeft: SetStyle := SetStyle or BS_LEFT;
    gbtCenter: SetStyle := SetStyle or BS_CENTER;
    gbtRight: SetStyle := SetStyle or BS_RIGHT;
  end;
  SetWindowLong(FHandle,GWL_STYLE,SetStyle);
  r := SetDim(XPos,YPos,XPos+Width,YPos+Height);
  InvalidateRect(Parent,@r,true);
end;

function CreateGroupBox(hParent: HWND; x,y,cx,cy: integer;
                       sCaption: string): TAPIGroupBox;
begin
  result := TAPIGroupBox.Create(hParent);
  with result do begin
    Dimension := SetDim(x,y,cx,cy);
    Caption := sCaption;
  end;
end;

end.