Prima Shareware 3/DuCom_Prima-Shareware-3_cd1.bin/PROGRAMO/PASCAL/CUSTOM/CUSTOM.PAS

Pascal/Delphi Source File | 1991-07-23 | 23.5 KB | 847 lines

{************************************************************************
*
*    Custom Controls Unit
*
*    WRITTEN BY:        Shawn Aubrey Baker (aka sab)
*
*    COMPUSERVE ID:    76450,22
*
*    CREDITS:            This code started out being based on the work of
*                        Robert Norton, who uploaded a bitmap button unit to
*                        Compuserve. Thanks Robert, it helped a lot. Also, the
*                        code from the example unit (BITBTN.PAS) that came with
*                        Turbo Pascal for Windows was a big help. Thanks Borland.
*
*    USE:                As you wish. Please send any comments and/or bug fixes
*                        via mail to the above ID. IF IT DIES IT'S YOUR PROBLEM.
*
*    NOTES:            This file uses tabs = 3
*
*    THE PROBLEM:    The first time I tried this the custom bitmap buttons
*                        worked fine in a TWindow but died a horrible death in
*                        a TDlgWindow. This is because Windows creates the
*                        actual controls instead of OWL. OWL provides little
*                        (read NO) support for custom controls and assumes that
*                        any control from a resource is fully created by the time
*                        that OWL gets to its child window creation code. This
*                        means that OWL doesn't try to create the window (good!)
*                        but that it has installed set the window procedure to
*                        its standard initialization proc (bad!). This procedure
*                        (InitWndProc for those with the OWL source) depends on
*                        having a global variable (CreationWindow) set that points
*                        to the object being created. Since this variable hasn't
*                        been set the routine goes off into la-la land. Also, the
*                        InitResource method sets the DefaultProc pointer to nil,
*                        which again causes OWL to go astray.
*
*    THE SOLUTION:    The method I've used to get around this is to override
*                        the window procedure pointer in the TWndClass structure
*                        to point my own procedure (InitCustom). Unfortunately,
*                        the InitCustom procedure needs to get a pointer to the
*                        object being initialized in order to get the real window
*                        procedure out of the Instance variable. Therefore, I've
*                        had to create a collection of custom controls and get
*                        the pointers out of there. Again, this only applies to
*                        controls from resources, so the object is added to the
*                        collection in InitResource and removed from it in
*                        InitCustom. It is possible to get into problems with this
*                        if you Init 2 dialogs with custom controls before you
*                        ExecDialog either of them. If there is a TCustom control
*                        with the same ID in the two resources then there is no
*                        telling which one will get picked out of the collection.
*                        It's simple, DON'T DO THIS!!!
*
*                        As far as the TWindow.InitResource problem goes, I simply
*                        call TWindow.Init as it does and then set everything
*                        except the DefaultProc pointer in the same way as
*                        TWindow.InitResource does.
*
*    THE END.
*
************************************************************************}

unit    Custom;

interface

uses    WinTypes,WinProcs,WObjects,Strings;

type

        PCustom=^TCustom;
        TCustom=object(TWindow)
            constructor    Init(AParent:PWindowsObject; AnId:integer;
                                    ATitle:PChar; X,Y,W,H:integer);
            constructor    InitResource(AParent:PWindowsObject; AnID:word);
            procedure    SetupWindow; virtual;
            function        GetClassName:PChar; virtual;
            procedure    GetWindowClass(var AWndClass:TWndClass); virtual;
            end;

        PCustomButton=^TCustomButton;
        TCustomButton=object(TCustom)
            OwnMouse        :    boolean;        { Is the mouse held captive?            }
            Pressed        :    boolean;        { Is the button currently pressed?    }
            Default        :    boolean;        { Is this the default button?            }

            constructor    Init(AParent:PWindowsObject; AnID:integer;
                                    AText:PChar; X,Y,W,H:integer; IsDefault:boolean);
            constructor    InitResource(AParent:PWindowsObject; AnID:integer);
            procedure    SetupWindow; virtual;

            procedure    WMMouseMove(var Msg:TMessage);
                                                    virtual wm_First + wm_MouseMove;

            procedure    WMLButtonDown(var Msg:TMessage);
                                                    virtual wm_First + wm_LButtonDown;
            procedure    WMLButtonUp(var Msg:TMessage);
                                                    virtual wm_First + wm_LButtonUp;

            procedure    WMSetFocus(var Msg:TMessage);
                                                    virtual wm_First + wm_SetFocus;
            procedure    WMKillFocus(var Msg:TMessage);
                                                    virtual wm_First + wm_KillFocus;

            procedure    WMKeyDown(var Msg:Tmessage);
                                                    virtual wm_First + wm_KeyDown;
            procedure    WMKeyUp(var Msg:Tmessage);
                                                    virtual wm_First + wm_KeyUp;

            procedure    WMGetDlgCode(var Msg:Tmessage);
                                                    virtual wm_First + wm_GetDlgCode;
            procedure    BMSetStyle(var Msg:Tmessage);
                                                    virtual wm_First + bm_SetStyle;
            end;

        PBitButton=^TBitButton;
        TBitButton=object(TCustomButton)
            UpBits        :    HBitMap;
            FocUpBits    :    HBitMap;
            DownBits        :    HBitMap;
            UpName        :    PChar;
            FocUpName    :    PChar;
            DownName        :    PChar;
            bmWidth        :    integer;
            bmHeight        :    integer;

            constructor    Init(AParent:PWindowsObject; AnID,X,Y:integer;
                                    AUpName,AFocUpName,ADownName:PChar;
                                    IsDefault:boolean);
            constructor    InitResource(AParent:PWindowsObject; AnID:integer;
                                                AUpName,AFocUpName,ADownName:PChar);
            destructor    Done; virtual;
            procedure    SetupWindow; virtual;
            function        GetClassName:PChar; virtual;
            procedure    Paint(DC:HDC; var PaintInfo:TPaintStruct); virtual;
            end;

implementation

{------------------------------------------------------------------------
-------------------------------------------------------------------------
----                                    TCustom Object                                    ----
-------------------------------------------------------------------------
------------------------------------------------------------------------}

{************************************************************************
*
*    Name:            InitCustom
*
*    Purpose:        Called with the first message for a custom control. This
*                    routine sets the window procedure to the one pointed to
*                    by Instance in the Custom object. The object is stored in
*                    the Customs collection by the Init/InitResource routine
*                    and it is removed here. This list is only needed in order
*                    to find the actual object.
*
*    Parameters:    Message    - the first message (should be wm_NCCreate)
*                    WParam    - more message info
*                    LParam    - even more message info
*
*    Return:        window procedure return value (depends on the message command)
*
************************************************************************}

var    Customs:PCollection;        { collection of custom controls }
        ACustom:PWindowsObject;    { current custom control }

function InitCustom(HWindow:HWND; Message,WParam:word; LParam:longint):
                            longint; export;

var    ID:longint;

        { finds the Custom object in the Customs collection }

        function FindID(Custom:PCustom):boolean; far;
        begin
        FindID:=Custom^.GetID = ID;
        end;

begin

{ find the Custom object, delete it from the collection }

ID:=GetWindowWord(HWindow,gww_ID);
ACustom:=Customs^.FirstThat(@FindID);
Customs^.Delete(ACustom);

{ set the window proc to the instance proc }

SetWindowLong(HWindow,gwl_WndProc,longint(ACustom^.Instance));

{ call the instance proc to handle the message }

asm
    PUSH    HWindow
    PUSH    Message
    PUSH    WParam
    PUSH    LParam.Word[2]
    PUSH    LParam.Word[0]
    MOV    AX,DS
    LES    DI,ACustom
    CALL    ES:[DI].TWindowsObject.Instance
end;

end;

{************************************************************************
*
*    Name:            TCustom.Init
*
*    Purpose:        Initializes a custom control.
*
*    Parameters:    AParent        - parent window
*                    AnID            - button ID
*                    ATitle        - control title
*                    X,Y,W,H        - position and size
*
*    Return:        None
*
************************************************************************}

constructor TCustom.Init(AParent:PWindowsObject; AnId:integer;
                                    ATitle:PChar; X,Y,W,H:integer);
begin
TWindow.Init(AParent,ATitle);
Attr.Id:=AnId;
Attr.X:=X;
Attr.Y:=Y;
Attr.W:=W;
Attr.H:=H;
Attr.Style:=ws_Child or ws_Visible or ws_Group or ws_TabStop;
end;

{************************************************************************
*
*    Name:            TCustom.InitResource
*
*    Purpose:        Initializes a custom control from a resource and enables
*                    data transfer.
*
*    Parameters:    AParent        - parent window
*                    AnID            - button ID
*
*    Return:        None
*
************************************************************************}

constructor TCustom.InitResource(AParent:PWindowsObject; AnID:word);
begin

{ replacement code for TWindow.InitResource, needed        }
{ because the TWindow routine sets DefaultProc to nil,    }
{ wherease TWindow.Init sets it to the routine we want    }

TWindow.Init(AParent,nil);
SetFlags(wb_FromResource,true);
FillChar(Attr,SizeOf(Attr),0);
Attr.ID:=AnID;

{ must pre-register because Windows creates controls from resources }

if not Register then Fail;
EnableTransfer;

{ add it to the Customs collection so that the InitCustom proc can find it }

Customs^.Insert(@self);
end;

{************************************************************************
*
*    Name:            TCustom.SetupWindow
*
*    Purpose:        Sets up the window and gets the attributes if the window
*                    is from a resource.
*
*    Parameters:    None
*
*    Return:        None
*
************************************************************************}

procedure TCustom.SetupWindow;
var    Rect:TRect;
        Pt:TPoint;
begin
TWindow.SetupWindow;

{ if it's from a resource then set the attributes }

if IsFlagSet(wb_FromResource) then
    begin

    { get the client rect in screen co-ordinates }

    GetWindowRect(HWindow,Rect);
    Pt.X:=Rect.Left;
    Pt.Y:=Rect.Top;

    { make the position relative to the parent window }

    ScreenToClient(GetWindowWord(HWindow,gww_HWndParent),Pt);
    Attr.X:=Pt.X;
    Attr.Y:=Pt.Y;

    { get the client rect and set the window size }

    GetClientRect(HWindow,Rect);
    Attr.W:=Rect.Right-Rect.Left;
    Attr.H:=Rect.Bottom-Rect.Top;

    { get the style info }

    Attr.Style:=GetWindowWord(HWindow,gwl_Style);
    Attr.ExStyle:=GetWindowWord(HWindow,gwl_ExStyle);
    end;
end;

{************************************************************************
*
*    Name:            TCustom.GetClassName
*
*    Purpose:        Abstract virtual method that gets the class name for a
*                    custom control. Generates a run-time error to ensure
*                    that the descendants override the method with their
*                    own class name.
*
*    Parameters:    None
*
*    Return:        None
*
************************************************************************}

function TCustom.GetClassName:PChar;
begin
Abstract;
end;

{************************************************************************
*
*    Name:            TCustom.GetWindowClass
*
*    Purpose:        Sets the class info for a custom control. Overrides the
*                    TPW startup procedure to use code that will find the
*                    object in our "Customs" collection.
*
*    Parameters:    AWndClass - class information
*
*    Return:        None
*
************************************************************************}

procedure TCustom.GetWindowClass(var AWndClass:TWndClass);
begin
TWindow.GetWindowClass(AWndClass);

if IsFlagSet(wb_FromResource) then
    AWndClass.lpfnWndProc:=@InitCustom;
end;

{------------------------------------------------------------------------
-------------------------------------------------------------------------
----                                TCustomButton Object                                ----
-------------------------------------------------------------------------
------------------------------------------------------------------------}

{************************************************************************
*
*    Name:            TCustomButton.Init
*
*    Purpose:        Initializes a custom button.
*
*    Parameters:    AParent        - parent window
*                    AnID            - button ID
*                    AText            - button text (or nil)
*                    X,Y,W,H        - position and size
*                    IsDefault    - default button ?
*
*    Return:        None
*
************************************************************************}

constructor    TCustomButton.Init(AParent:PWindowsObject; AnID:integer;
                                            AText:PChar; X,Y,W,H:integer;
                                            IsDefault:boolean);
begin
TCustom.Init(AParent,AnID,nil,X,Y,10,10);
if IsDefault then
    Attr.Style:=Attr.Style or bs_DefPushButton
else
    Attr.Style:=Attr.Style or bs_PushButton;
end;

{************************************************************************
*
*    Name:            TCustomButton.InitResource
*
*    Purpose:        Initializes a custom button from a resource.
*
*    Parameters:    AParent    - parent window
*                    AnID        - button ID
*
*    Return:        None
*
************************************************************************}

constructor    TCustomButton.InitResource(AParent:PWindowsObject; AnID:integer);
begin
TCustom.InitResource(AParent,AnID);
DisableTransfer;
end;

{************************************************************************
*
*    Name:            TCustomButton.SetupWindow
*
*    Purpose:        Sets up the window and initializes the state variables.
*
*    Parameters:    None
*
*    Return:        None
*
************************************************************************}

procedure TCustomButton.SetupWindow;
begin
TCustom.SetupWindow;

Pressed:=false;
OwnMouse:=false;
Default:=Attr.Style and bs_DefPushButton = bs_DefPushButton;
end;

{************************************************************************
*
*    Name:            TCustomButton.WMLButtonDown
*
*    Purpose:        repaint the button in the down position when the left
*                    mouse button is pressed.
*
*    Parameters:    Msg - a message
*
*    Return:        None
*
************************************************************************}

procedure TCustomButton.WMLButtonDown(var Msg:TMessage);
begin

{ if not already pressed then set state to pressed }

if not Pressed then
    begin
    if GetFocus <> hWindow then
        SetFocus(hWindow);
    Pressed:=true;
    OwnMouse:=true;
    SetCapture(hWindow);
    end;

{ trigger repaint }

InvalidateRect(hWindow,nil,false);
end;

{************************************************************************
*
*    Name:            TCustomButton.WMLButtonUp
*
*    Purpose:        If the left mouse button is pressed and then released
*                    over the button then repaint it as unpressed and notify
*                    the parent window.
*
*    Parameters:    Msg - a message
*
*    Return:        None
*
************************************************************************}

procedure TCustomButton.WMLButtonUp(var Msg:TMessage);
begin
if OwnMouse then
    begin
    ReleaseCapture;
    OwnMouse:=false;
    if Pressed then        { trigger repaint and notify parent }
        begin
        Pressed:=false;
        InvalidateRect(hWindow,nil,false);
        PostMessage(Parent^.hWindow,wm_Command,Attr.Id,longint(hWindow));
        end;
    end;
end;

{************************************************************************
*
*    Name:            TCustomButton.WMMouseMove
*
*    Purpose:        Repaints the button when the mouse is pressed and moves
*                    into and outof the button window.
*
*    Parameters:    Msg - a message
*
*    Return:        None
*
************************************************************************}

procedure TCustomButton.WMMouseMove(var Msg:TMessage);
var    BtnRect:TRect;
        MousePt:TPoint;
begin

{ get window rectangle and mouse point }

GetClientRect(hWindow,BtnRect);
MousePt.X:=integer(Msg.lParamLo);
MousePt.Y:=integer(Msg.lParamHi);

{ if the mouse is over the button }

if PtInRect(BtnRect,MousePt) then
    begin

    { if the mouse is moved into the button area }

    if OwnMouse and (not Pressed) then
        begin
        Pressed:=true;
        InvalidateRect(hWindow,nil,false);
        end;
    end

{ if the mouse is moved out of the button area }

else if Pressed then
    begin
    Pressed:=false;
    InvalidateRect(hWindow,nil,false);
    end;
end;

{************************************************************************
*
*    Name:            TCustomButton.WMSetFocus
*
*    Purpose:        Forces repaint if the focus is set to the button.
*
*    Parameters:    Msg - a message
*
*    Return:        None
*
************************************************************************}

procedure TCustomButton.WMSetFocus(var Msg:TMessage);
begin
InvalidateRect(hWindow,nil,false);
end;

{************************************************************************
*
*    Name:            TCustomButton.WMKillFocus
*
*    Purpose:        Forces repaint if the focus is taken away from the button.
*
*    Parameters:    Msg - a message
*
*    Return:        None
*
************************************************************************}

procedure TCustomButton.WMKillFocus(var Msg:TMessage);
begin
InvalidateRect(hWindow,nil,false);
end;

{************************************************************************
*
*    Name:            TCustomButton.WMKeyDown
*
*    Purpose:        Repaints the button in the down position if the space
*                    bar is pressed on the button.
*
*    Parameters:    Msg - a message
*
*    Return:        None
*
************************************************************************}

procedure TCustomButton.WMKeyDown(var Msg:Tmessage);
begin
if (Msg.wParam = $20) and not Pressed and not OwnMouse then
    begin
    Pressed:=true;
    InvalidateRect(hWindow,nil,false);
    end;
end;

{************************************************************************
*
*    Name:            TCustomButton.WMKeyUp
*
*    Purpose:        Repaints the button in the up position and notifies the
*                    parent window if the space bar is pressed on the button.
*
*    Parameters:    Msg - a message
*
*    Return:        None
*
************************************************************************}

procedure TCustomButton.WMKeyUP(var Msg:Tmessage);
begin
if (Msg.wParam = $20) and Pressed and not OwnMouse then
    begin
    Pressed:=false;
    InvalidateRect(hWindow,nil,false);
    PostMessage(Parent^.hWindow,wm_Command,Attr.Id,longint(hWindow));
    end;
end;

{************************************************************************
*
*    Name:            TCustomButton.WMGetDlgCode
*
*    Purpose:        Gets whether or not the button is the default.
*
*    Parameters:    Msg - a message
*
*    Return:        None
*
************************************************************************}

procedure TCustomButton.WMGetDlgCode(var Msg:Tmessage);
begin
if Default then
    Msg.Result:=dlgc_DefPushButton
else
    Msg.Result:=dlgc_UndefPushButton;
end;

{************************************************************************
*
*    Name:            TCustomButton.BMSetStyle
*
*    Purpose:        Sets the button style to either default or not.
*
*    Parameters:    Msg - a message
*
*    Return:        None
*
************************************************************************}

procedure TCustomButton.BMSetStyle(var Msg:Tmessage);
var    OldDefault:boolean;
begin
OldDefault:=Default;
Default:=Msg.WParam = bs_DefPushButton;
if Default <> OldDefault then
    InvalidateRect(hWindow,nil,false);
end;

{------------------------------------------------------------------------
-------------------------------------------------------------------------
----                                    TBitButton Object                                ----
-------------------------------------------------------------------------
------------------------------------------------------------------------}

{************************************************************************
*
*    Name:            TBitButton.Init
*
*    Purpose:        Initializes a button.
*
*    Parameters:    AParent        - parent window
*                    AnID            - button ID
*                    X,Y            - position
*                    IsDefault    - default button ?
*                    AUpName        - name of resource for up bitmap
*                    AFocUpName    - name of resource for up bitmap when focused
*                    ADownName    - name of resource for down bitmap
*
*    Return:        None
*
************************************************************************}

constructor TBitButton.Init(AParent:PWindowsObject; AnID,X,Y:integer;
                                        AUpName,AFocUpName,ADownName:PChar;
                                        IsDefault:boolean);
begin
TCustomButton.Init(AParent,AnID,nil,X,Y,10,10,IsDefault);

UpName:=AUpName;
FocUpName:=AFocUpName;
DownName:=ADownName;
end;

{************************************************************************
*
*    Name:            TBitButton.InitResource
*
*    Purpose:        Initializes a button from a resource.
*
*    Parameters:    AParent        - parent window
*                    AnID            - button ID
*                    AUpName        - name of resource for up bitmap
*                    AFocUpName    - name of resource for up bitmap when focused
*                    ADownName    - name of resource for down bitmap
*
*    Return:        None
*
************************************************************************}

constructor TBitButton.InitResource(AParent:PWindowsObject; AnID:integer;
                                        AUpName,AFocUpName,ADownName:PChar);
begin
TCustomButton.InitResource(AParent,AnID);

UpName:=AUpName;
FocUpName:=AFocUpName;
DownName:=ADownName;
end;

{************************************************************************
*
*    Name:            TBitButton.Done
*
*    Purpose:        Destroys the button.
*
*    Parameters:    None
*
*    Return:        None
*
************************************************************************}

destructor TBitButton.Done;
begin
DeleteObject(UpBits);
DeleteObject(FocUpBits);
DeleteObject(DownBits);
TCustomButton.Done;
end;

{************************************************************************
*
*    Name:            TBitButton.SetupWindow
*
*    Purpose:        Loads the bitmaps for a button, resizes the window
*                    accordingly, and initializes the state variables.
*
*    Parameters:    None
*
*    Return:        None
*
************************************************************************}

procedure TBitButton.SetupWindow;
var    bm:TBitMap;
begin
TCustomButton.SetupWindow;

{ load the bitmaps }

UpBits:=LoadBitmap(hInstance,UpName);
FocUpBits:=LoadBitmap(hInstance,FocUpName);
DownBits:=LoadBitmap(hInstance,DownName);

{ resize the window to fit the bitmaps }

GetObject(DownBits,SizeOf(bm),@bm);
MoveWindow(HWindow,Attr.X,Attr.Y,bm.bmWidth+2,bm.bmHeight+2,false);
bmWidth:=bm.bmWidth;
bmHeight:=bm.bmHeight;
end;

{************************************************************************
*
*    Name:            TBitButton.GetClassName
*
*    Purpose:        Gets the class name for a bitmap button.
*
*    Parameters:    None
*
*    Return:        pointer to the class name
*
************************************************************************}

function TBitButton.GetClassName;
begin
GetClassName:='BitButton';
end;

{************************************************************************
*
*    Name:            TBitButton.Paint
*
*    Purpose:        Paints one of the bitmaps into the window depending on
*                    the current state.
*
*    Parameters:    DC                - device context to paint into
*                    PaintInfo    - painting information
*
*    Return:        None
*
************************************************************************}

procedure TBitButton.Paint(DC:HDC; var PaintInfo:TPaintStruct);
var    BitsDC:HDC;
        OldBitmap:HBitMap;
        OldBrush:HBrush;
begin

{ draw the border }

if Default then
    OldBrush:=SelectObject(DC,GetStockObject(Black_Brush))
else
    OldBrush:=SelectObject(DC,GetStockObject(White_Brush));
PatBlt(DC,0,0,Attr.W,1,PatCopy);
PatBlt(DC,0,0,1,Attr.H,PatCopy);
PatBlt(DC,0,Attr.H-1,Attr.W,1,PatCopy);
PatBlt(DC,Attr.W-1,0,1,Attr.H,PatCopy);
SelectObject(DC,OldBrush);

{ draw the button }

BitsDC:=CreateCompatibleDC(DC);
if Pressed then
    OldBitmap:=SelectObject(BitsDC,DownBits)
else if GetFocus = hWindow then
    OldBitmap:=SelectObject(BitsDC,FocUpBits)
else
    OldBitmap:=SelectObject(BitsDC,UpBits);
BitBlt(DC,1,1,bmWidth,bmHeight,BitsDC,0,0,SrcCopy);
SelectObject(BitsDC,OldBitmap);
DeleteDC(BitsDC);
end;

{------------------------------------------------------------------------
-------------------------------------------------------------------------
----                                    Unit initialization                            ----
-------------------------------------------------------------------------
------------------------------------------------------------------------}

begin
New(Customs,Init(40,10));
end.