{ -----------------------------------------------------------------------
Tcl Scripting Language Components (Tslc)
Copyright (C) 1996-2002 William Byrne

This library is free software; you can redistribute it and/or
modify it under the terms of the GNU Lesser General Public
License as published by the Free Software Foundation; either
version 2.1 of the License, or (at your option) any later version.

This library is distributed in the hope that it will be useful,
but WITHOUT ANY WARRANTY; without even the implied warranty of
MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
Lesser General Public License for more details.

You should have received a copy of the GNU Lesser General Public
License along with this library; if not, write to the Free Software
Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA

WilliamB@ByrneLitho.com
------------------------------------------------------------------------}
unit TkPanel;

interface

uses
  Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs,
  ExtCtrls, TclTk;

type

  TTkKill = class(TComponent)
  public
  	procedure Kill; virtual; abstract;
  end;

  TTkScrollBox = class(TScrollingWinControl)
  private
    { Private declarations }
    FBorderStyle: TBorderStyle;
    FStyles: TStringList;
    FExStyles: TStringList;
    FTkChild: THandle;
    FCanvas: TCanvas;
    FTkKill: TTkKill;
    FSizingChild, FGeometryRequest, FTkWinReady, FTkWinSized: boolean;
    procedure SetBorderStyle(value: TBorderStyle);
    procedure SetTkKill(ATkKill: TTkKill);
    procedure CMCtl3DChanged(var Message: TMessage); message CM_CTL3DCHANGED;
    procedure TkAttachWindow(var Message: TMessage); message TK_ATTACHWINDOW;
    procedure TkClaimFocus(var Message: TMessage); message TK_CLAIMFOCUS;
    procedure TkGeometryReq(var Message: TMessage); message TK_GEOMETRYREQ;
    procedure WmClose(var Message: TMessage); message WM_CLOSE;
    procedure WmParentNotify(var Message: TMessage); message WM_PARENTNOTIFY;
    procedure WmDestroy(var Message: TMessage); message WM_DESTROY;
    procedure WMSize(var Message: TWMSize); message WM_SIZE;
  protected
    { Protected declarations }
    procedure Loaded; override;
	procedure CreateParams(var Params: TCreateParams); override;
    procedure Notification(AComponent: TComponent; Operation: TOperation); override;
	procedure Paint;
    property Canvas: TCanvas read FCanvas;
  public
    { Public declarations }
    constructor Create(AOwner: TComponent); override;
    destructor Destroy; override;
    procedure AddStyle(style: string);
    procedure AddExStyle(exstyle: string);
    property TkKill: TTkKill read FTkKill write SetTkKill;
  published
    { Published declarations }
    property Align;
    property BorderStyle: TBorderStyle read FBorderStyle write SetBorderStyle default bsSingle;
    property Ctl3D;
    property ParentCtl3D;
    property Visible;

  end;

  TTkWindow = class(TTkScrollBox)
  public
    { Public declarations }
    constructor Create(AOwner: TComponent); override;
  end;

  TTkPanel = class(TTkWindow);

implementation
uses Tslc, TslcUtil, TslcHash;

//{$R *.DFM}

function StrToWndStyle(str: string): DWORD; forward;

{~~~ TTkPanel ~~~}

constructor TTkScrollBox.Create(AOwner: TComponent);
begin
	inherited Create(AOwner);
	FCanvas := TControlCanvas.Create;
    TControlCanvas(FCanvas).Control := Self;
    FStyles := TStringList.Create;
    FStyles.Sorted := False;
    FExStyles := TStringList.Create;
    FExStyles.Sorted := False;
    Height := 50;
    Width := 50;
    FBorderStyle := bsSingle;
end;

destructor TTkScrollBox.Destroy;
begin
	inherited Destroy;
	FStyles.Free;
    FExStyles.Free;
    FCanvas.Free;
end;

procedure TTkScrollBox.Loaded;
begin
    inherited Loaded;
end;

procedure TTkScrollBox.SetTkKill(ATkKill: TTkKill);
begin
	FreeNotification(ATkKill);
    FTkKill := ATkKill;
end;

procedure TTkScrollBox.Notification(AComponent: TComponent; Operation: TOperation);
begin
	if (AComponent = FTkKill) and (Operation = opRemove) then
    	FTkKill := nil;

   	inherited Notification(AComponent, Operation);
end;

procedure TTkScrollBox.TkAttachWindow(var Message: TMessage);
var
	rect: TRect;
begin
//	inherited;
    FTkChild := Message.WParam;
//	rect := ClientRect;
//	MoveWindow(FTkChild, 0, 0, rect.right - rect.left, rect.bottom - rect.top, True);
//                MoveWindow(wParam, 0, 0, 640, 480, True);
end;

procedure TTkScrollBox.TkClaimFocus(var Message: TMessage);
begin
//	inherited;
   	Windows.SetFocus(FTkChild);
end;

procedure TTkScrollBox.TkGeometryReq(var Message: TMessage);
var
	rect: TRect;
    wParam: WORD;
    lParam: DWORD;
begin
	inherited;

	rect := ClientRect;

 	wParam := Message.WParam;
    lParam := Message.LParam;

	rect.Left := Left;
    rect.Top := Top;
    rect.Right := rect.Left + wParam;
    rect.Bottom := rect.Top + lParam;

    FGeometryRequest := True;
	try
    	if FTkWinSized then
			BoundsRect := rect;
    finally
    	FGeometryRequest := False;
    end;

//    MoveWindow(FTkChild, 0, 0, wParam, lParam, True);
	if FTkWinSized then
	    MoveWindow(FTkChild, 0, 0, Width, Height, True);

    if not FTkWinReady then
    	FTkWinReady := True;

	if not FTkWinSized then
    begin
    	if (Width = wParam) and (Height = lParam) then
	    	FTkWinSized := True
        else
			PostMessage(Handle, WM_SIZE, 0, MakeLParam(Width, Height));
    end;
end;

procedure TTkScrollBox.WmClose(var Message: TMessage);
begin
	if FTkChild = 0 then
		inherited
    else if FTkKill <> nil then
    	FTkKill.Kill;
end;

procedure TTkScrollBox.WmSize(var Message: TWMSize);
var
	pW: pTk_Window;
begin
    inherited;
//  TWMSize = record
//    Msg: Cardinal;
//    SizeType: Longint; { SIZE_MAXIMIZED, SIZE_MINIMIZED, SIZE_RESTORED,
//                         SIZE_MAXHIDE, SIZE_MAXSHOW }
//    Width: Word;
//    Height: Word;
//    Result: Longint;
//  end;

	if not FGeometryRequest and not FSizingChild and FTkWinReady then
    begin
    	FSizingChild := True;
        try
//        	PostMessage(FTkChild, TK_GEOMETRYREQ, width, height);
           	InitTk('');
            pW := Tk_HWNDToWindow(FTkChild);
    	    if pW <> nil then
	    		Tk_GeometryRequest(pW, width, height);
	    finally
        	FSizingChild := False;
        end;
    end;

end;

procedure TTkScrollBox.WmParentNotify(var Message: TMessage);
var
	w: WORD;
begin
	//inherited;
   	w := LOWORD(Message.WParam);

    if (w = WM_LBUTTONDOWN) or (w = WM_MBUTTONDOWN) or (w =WM_RBUTTONDOWN) then
    	Windows.SetFocus(FTkChild)
    else if (w = WM_DESTROY) then
    begin
    	FTkWinReady := False;
        FTkWinSized := False;
    	FTkChild := 0;
        if ((GetWindowLong(Handle, GWL_STYLE) and WS_CHILD) = 0) then
        	ShowWindow(Handle, SW_HIDE);
    end;
end;

procedure TTkScrollBox.WmDestroy(var Message: TMessage);
begin
	if FTkChild = 0 then
		inherited;
end;

procedure TTkScrollBox.AddStyle(style: string);
begin
	FStyles.Add(style);
end;


procedure TTkScrollBox.AddExStyle(exstyle: string);
begin
	FExStyles.Add(exstyle);
end;


{$IFDEF VER130}
    procedure ParseStyle(str: string; var style: DWORD);
{$ELSE}
{$IFDEF VER120}
    procedure ParseStyle(str: string; var style: DWORD);
{$ELSE}
    procedure ParseStyle(str: string; var style: longint);
{$ENDIF}
{$ENDIF}
    var
    	p: pChar;
    begin
    	if trim(str) = '' then
            exit;

    	p := pChar(str);
        if p^ = '|' then
        begin
        	inc(p);
            style := style or StrToWndStyle(p);
		end else if p^ = '~' then
        begin
            inc(p);
            style := style and not StrToWndStyle(p);
        end else
        	style := StrToWndStyle(p);

    end;


procedure TTkScrollBox.CreateParams(var Params: TCreateParams);
const
  BorderStyles: array[TBorderStyle] of Longint = (0, WS_BORDER);
var
	z: integer;
begin
  inherited CreateParams(Params);
  with Params do
  begin
    Style := Style or BorderStyles[FBorderStyle];
    if NewStyleControls and Ctl3D and (FBorderStyle = bsSingle) then
    begin
      Style := Style and not WS_BORDER;
      ExStyle := ExStyle or WS_EX_CLIENTEDGE;
    end;

    for z:= 0 to FStyles.Count - 1 do
    	ParseStyle(FStyles[z], Style);

    for z:= 0 to FExStyles.Count - 1 do
    	ParseStyle(FExStyles[z], ExStyle);

  end;
end;

procedure TTkScrollBox.CMCtl3DChanged(var Message: TMessage);
begin
  if NewStyleControls and (FBorderStyle = bsSingle) then RecreateWnd;
  inherited;
end;

procedure TTkScrollBox.Paint;
var
  Rect, Rect2: TRect;
  TopColor, BottomColor: TColor;
  FontHeight: Integer;
begin
//    inherited Paint;
//    exit;
	if not (csDesigning in ComponentState) then exit;
  Rect := GetClientRect;
  with Canvas do
  begin
	if Parent <> nil then
	    Brush.Color := Parent.Brush.Color
    else
    	Brush.Color := clBtnFace;
    FillRect(Rect);
    Brush.Style := bsClear;
    Font := Self.Font;
    FontHeight := TextHeight('W');
    with Rect do
    begin
    	Top := ((Bottom + Top) - FontHeight) div 2;
        Bottom := Top + FontHeight;
    end;
    DrawText(Handle, pChar(name), -1, Rect, (DT_EXPANDTABS or DT_VCENTER) or DT_CENTER);
  end;
end;


procedure TTkScrollBox.SetBorderStyle(Value: TBorderStyle);
begin
  if FBorderStyle <> Value then
  begin
    FBorderStyle := Value;
    RecreateWnd;
  end;
end;

{~~~ TTkWindow ~~~}
constructor TTkWindow.Create(AOwner: TComponent);
begin
	inherited Create(AOwner);
    AutoScroll := False;
end;


const
	hash_					: integer = 0;
	hashWS_OVERLAPPED		: integer = 0;
	hashWS_POPUP			: integer = 0;
	hashWS_CHILD			: integer = 0;
	hashWS_MINIMIZE			: integer = 0;
	hashWS_VISIBLE			: integer = 0;
	hashWS_DISABLED			: integer = 0;
	hashWS_CLIPSIBLINGS		: integer = 0;
	hashWS_CLIPCHILDREN		: integer = 0;
	hashWS_MAXIMIZE			: integer = 0;
	hashWS_CAPTION			: integer = 0;
	hashWS_BORDER			: integer = 0;
	hashWS_DLGFRAME			: integer = 0;
	hashWS_VSCROLL			: integer = 0;
	hashWS_HSCROLL			: integer = 0;
	hashWS_SYSMENU			: integer = 0;
	hashWS_THICKFRAME		: integer = 0;
	hashWS_GROUP			: integer = 0;
	hashWS_TABSTOP			: integer = 0;
	hashWS_MINIMIZEBOX		: integer = 0;
	hashWS_MAXIMIZEBOX		: integer = 0;
	hashWS_TILED			: integer = 0;
	hashWS_ICONIC			: integer = 0;
	hashWS_SIZEBOX			: integer = 0;
	hashWS_OVERLAPPEDWINDOW	: integer = 0;
	hashWS_TILEDWINDOW		: integer = 0;
	hashWS_POPUPWINDOW		: integer = 0;
	hashWS_CHILDWINDOW		: integer = 0;
	hashWS_EX_DLGMODALFRAME	: integer = 0;
	hashWS_EX_NOPARENTNOTIFY: integer = 0;
	hashWS_EX_TOPMOST		: integer = 0;
	hashWS_EX_ACCEPTFILES	: integer = 0;
	hashWS_EX_TRANSPARENT	: integer = 0;
	hashWS_EX_MDICHILD		: integer = 0;
	hashWS_EX_TOOLWINDOW	: integer = 0;
	hashWS_EX_WINDOWEDGE	: integer = 0;
	hashWS_EX_CLIENTEDGE	: integer = 0;
	hashWS_EX_CONTEXTHELP	: integer = 0;
	hashWS_EX_RIGHT			: integer = 0;
	hashWS_EX_LEFT			: integer = 0;
	hashWS_EX_RTLREADING	: integer = 0;
	hashWS_EX_LTRREADING	: integer = 0;
	hashWS_EX_LEFTSCROLLBAR	: integer = 0;
	hashWS_EX_RIGHTSCROLLBAR: integer = 0;
	hashWS_EX_CONTROLPARENT	: integer = 0;
	hashWS_EX_STATICEDGE	: integer = 0;
	hashWS_EX_APPWINDOW		: integer = 0;
	hashWS_EX_OVERLAPPEDWINDOW	: integer = 0;
	hashWS_EX_PALETTEWINDOW	: integer = 0;


procedure Register;
begin
  RegisterComponents('Tslc', [TTkPanel, TTkScrollBox]);
end;


type
	TStyleRecord = record
    	pHash: ^Integer;
        pValue: pChar;
        value: DWORD;
    end;

    pStyleArray = ^TStyleArray;
    TStyleArray = array[0..1027] of TStyleRecord;

const
 	StyleArray: pStyleArray = nil;

	cCountStyleValues = 49;
	_HashCount_: integer = cCountStyleValues;
	cStyleValues: array[0..cCountStyleValues,0..2] of pChar = (
    	(@_HashCount_,		'', nil),  // not counted. Used to store array size. See TslcHash.HashCount()
    	(@hash_,			'', nil),
		(@hashWS_OVERLAPPED,		'WS_OVERLAPPED',				pChar(WS_OVERLAPPED)),
		(@hashWS_POPUP,				'WS_POPUP',					pChar(WS_POPUP)),
		(@hashWS_CHILD,				'WS_CHILD',					pChar(WS_CHILD)),
		(@hashWS_MINIMIZE,			'WS_MINIMIZE',				pChar(WS_MINIMIZE)),
		(@hashWS_VISIBLE,			'WS_VISIBLE',				pChar(WS_VISIBLE)),
		(@hashWS_DISABLED,			'WS_DISABLED',				pChar(WS_DISABLED)),
		(@hashWS_CLIPSIBLINGS,		'WS_CLIPSIBLINGS',			pChar(WS_CLIPSIBLINGS)),
		(@hashWS_CLIPCHILDREN,		'WS_CLIPCHILDREN',			pChar(WS_CLIPCHILDREN)),
		(@hashWS_MAXIMIZE,			'WS_MAXIMIZE',				pChar(WS_MAXIMIZE)),
		(@hashWS_CAPTION,			'WS_CAPTION',				pChar(WS_CAPTION)),
		(@hashWS_BORDER,			'WS_BORDER',				pChar(WS_BORDER)),
		(@hashWS_DLGFRAME,			'WS_DLGFRAME',				pChar(WS_DLGFRAME)),
		(@hashWS_VSCROLL,			'WS_VSCROLL',				pChar(WS_VSCROLL)),
		(@hashWS_HSCROLL,			'WS_HSCROLL',				pChar(WS_HSCROLL)),
		(@hashWS_SYSMENU,			'WS_SYSMENU',				pChar(WS_SYSMENU)),
		(@hashWS_THICKFRAME,		'WS_THICKFRAME',			pChar(WS_THICKFRAME)),
		(@hashWS_GROUP,				'WS_GROUP',					pChar(WS_GROUP)),
		(@hashWS_TABSTOP,			'WS_TABSTOP',				pChar(WS_TABSTOP)),
		(@hashWS_MINIMIZEBOX,		'WS_MINIMIZEBOX',			pChar(WS_MINIMIZEBOX)),
		(@hashWS_MAXIMIZEBOX,		'WS_MAXIMIZEBOX',			pChar(WS_MAXIMIZEBOX)),
		(@hashWS_TILED,				'WS_TILED',					pChar(WS_TILED)),
		(@hashWS_ICONIC,			'WS_ICONIC',				pChar(WS_ICONIC)),
		(@hashWS_SIZEBOX,			'WS_SIZEBOX',				pChar(WS_SIZEBOX)),
		(@hashWS_OVERLAPPEDWINDOW,	'WS_OVERLAPPEDWINDOW',		pChar(WS_OVERLAPPEDWINDOW)),
		(@hashWS_TILEDWINDOW,		'WS_TILEDWINDOW',			pChar(WS_TILEDWINDOW)),
		(@hashWS_POPUPWINDOW,		'WS_POPUPWINDOW',			pChar(WS_POPUPWINDOW)),
		(@hashWS_CHILDWINDOW,		'WS_CHILDWINDOW',			pChar(WS_CHILDWINDOW)),
		(@hashWS_EX_DLGMODALFRAME,	'WS_EX_DLGMODALFRAME',		pChar(WS_EX_DLGMODALFRAME)),
		(@hashWS_EX_NOPARENTNOTIFY,	'WS_EX_NOPARENTNOTIFY',		pChar(WS_EX_NOPARENTNOTIFY)),
		(@hashWS_EX_TOPMOST,		'WS_EX_TOPMOST',			pChar(WS_EX_TOPMOST)),
		(@hashWS_EX_ACCEPTFILES,	'WS_EX_ACCEPTFILES',		pChar(WS_EX_ACCEPTFILES)),
		(@hashWS_EX_TRANSPARENT,	'WS_EX_TRANSPARENT',		pChar(WS_EX_TRANSPARENT)),
		(@hashWS_EX_MDICHILD,		'WS_EX_MDICHILD',			pChar(WS_EX_MDICHILD)),
		(@hashWS_EX_TOOLWINDOW,		'WS_EX_TOOLWINDOW',			pChar(WS_EX_TOOLWINDOW)),
		(@hashWS_EX_WINDOWEDGE,		'WS_EX_WINDOWEDGE',			pChar(WS_EX_WINDOWEDGE)),
		(@hashWS_EX_CLIENTEDGE,		'WS_EX_CLIENTEDGE',			pChar(WS_EX_CLIENTEDGE)),
		(@hashWS_EX_CONTEXTHELP,	'WS_EX_CONTEXTHELP',		pChar(WS_EX_CONTEXTHELP)),
		(@hashWS_EX_RIGHT,			'WS_EX_RIGHT',				pChar(WS_EX_RIGHT)),
		(@hashWS_EX_LEFT,			'WS_EX_LEFT',				pChar(WS_EX_LEFT)),
		(@hashWS_EX_RTLREADING,		'WS_EX_RTLREADING',			pChar(WS_EX_RTLREADING)),
		(@hashWS_EX_LTRREADING,		'WS_EX_LTRREADING',			pChar(WS_EX_LTRREADING)),
		(@hashWS_EX_LEFTSCROLLBAR,	'WS_EX_LEFTSCROLLBAR',		pChar(WS_EX_LEFTSCROLLBAR)),
		(@hashWS_EX_RIGHTSCROLLBAR,	'WS_EX_RIGHTSCROLLBAR',		pChar(WS_EX_RIGHTSCROLLBAR)),
		(@hashWS_EX_CONTROLPARENT,	'WS_EX_CONTROLPARENT',		pChar(WS_EX_CONTROLPARENT)),
		(@hashWS_EX_STATICEDGE,		'WS_EX_STATICEDGE',			pChar(WS_EX_STATICEDGE)),
		(@hashWS_EX_APPWINDOW,		'WS_EX_APPWINDOW',			pChar(WS_EX_APPWINDOW)),
		(@hashWS_EX_OVERLAPPEDWINDOW,	'WS_EX_OVERLAPPEDWINDOW',			pChar(WS_EX_OVERLAPPEDWINDOW)),
		(@hashWS_EX_PALETTEWINDOW,	'WS_EX_PALETTEWINDOW',		pChar(WS_EX_PALETTEWINDOW)));


function StyleCount(StyleArray: pStyleArray): integer;
begin
	dec(pChar(StyleArray), sizeof(TStyleRecord));
    result := StyleArray^[0].pHash^;
end;

// modified from TslcHash
procedure InitializeStyleValues(var StyleArray: pStyleArray; const values: pStyleArray);
var
	x, c: integer;
begin
    StyleArray := @values^[1];
    c := StyleCount(StyleArray);
	for x:= 0 to c - 1 do
    with StyleArray^[x] do
		pHash^ := Hash(pValue);

end;
{$O-}
function StyleFindValue(p: pChar; StyleArray: pStyleArray): DWORD;
var
	x, c: integer;
    h: integer;
begin

	h := Hash(p);
    c := StyleCount(StyleArray);
	for x:= 0 to c - 1 do
    with StyleArray^[x] do
    	if pHash^ = h then
        begin
        	result := value;
            exit;
        end;

    TclError('Invalid Window Style');
end;
{$O+}

function StrToWndStyle(str: string): DWORD;
begin
	result := StyleFindValue(pChar(str), StyleArray);
end;


initialization

    InitializeStyleValues(StyleArray, pStyleArray(@cStyleValues));

end.
