[Back to WIN-OS2 SWAG index] [Back to Main SWAG index] [Original]
{
From: chrfa@ida.liu.se (Christer Fahlgren)
For all people out there wishing a Toolbar with TIP-capabilities, I've
written a TIPBAR-unit which is the basic toolbar enhanced with tip
capabilities.
Since I'm no expert programmer I'd appreciate input on this.
Info follows in the file included below.
{**************************************************}
{ }
{ Turbo Pascal for Windows }
{ Tipbar unit - a toolbar with TIP-capabilities }
{ Copyleft (cl) 1994 by Christer Fahlgren }
{ }
{ This source is freeware! Please (ab)use, }
{ change, include in commercial programs, }
{ throw away, WHATEVER you feel like. }
{ }
{ This unit was written because I thought it }
{ would be cool If I could have tooltips myself. }
{ And I gathered that the best way of enhancing }
{ this unit would be to throw it out to the }
{ public programmer mob for scrutiny. }
{ I am no expert at this and It may contain }
{ errors for which I can take no respons- }
{ ibilities. However, please send me your }
{ comments, enhancements and bugs for my and }
{ your benefit. }
{ }
{ I also would like to say that I am a bit tired }
{ of all the people asking for money for petty }
{ source code. }
{ }
{ The inspiration for this unit was the tooltip }
{ C++ code which I found the other day. }
{ }
{ }
{ This toolbar relies on the original toolbar }
{ which resides in the \examples\win\toolbar }
{ directory in BP7. }
{ }
{ Enjoy! }
{ }
{ Christer Fahlgren }
{ Email: chrfa@ida.liu.se }
{ Snail: Västanågatan 26A:204 }
{ S-582 35 Linköping }
{ Sweden }
{**************************************************}
{--------------------------------------------------
Q:What do I do if I already use the toolbar unit
in Borland Pascal???
A:First add Tipbar to your uses clause
Then add a parameter to your init statement
of your toolbar like this:
Init(ParentWin, AName, Orient) ->
Init(ParentWin, Aname, Orient, Delay) where
Delay is the delay in milliseconds for the help
to show up.
Change occurences of TToolbar to TTipbar
Change occurences of PToolbar to PTipbar
Lastly you have to redefine your old
ToolBarData statements with the new resource-
name HelpToolBarData. This resource looks
like the old ToolBarData but a null-terminated
string is included for every tool. This string
can maximum be 255 chars.
Example:
AHelpToolbar HelpToolBarData
BEGIN
2 (Number of tools and spacers in this resource )
tb_open (id of a bitmap )
cm_open (menu id )
"Opens a file\0" (Text which is null-terminated )
tb_save (id of a bitmap )
cm_save (menu id )
"Saves the file\0" (Text which is null-terminated )
END
----------------------------------------------------------}
{----------------------------------------------------------}
{ }
{ INFORMATION AND PRECAUTIONS }
{ --------------------------- }
{ The Store and Load methods are NOT tested! }
{ It uses one timer (a scarce resource in Win 3.x) }
{ }
{ This unit is NOT thoroughly tested and all use is at }
{ your own risk, BUT it SEEMS to work well. }
{----------------------------------------------------------}
{----------------------------------------------------------}
{ Possible ENHANCEMENTS }
{ --------------------- }
{ Store the font for the popupwindow in the toolbar }
{ instead of creating it each time in the HelpWindow }
{ No more than one calculating of the size of the text }
{ in the popupwindow. }
{----------------------------------------------------------}
unit TipBar;
interface
uses Winprocs, Wintypes, Objects, OWindows, Strings, Win31, toolbar;
type
PTipbar = ^TTipbar;
PTipbutton = ^TTipbutton;
PHelpWindow=^THelpWindow;
{ This is the definition to the Popupwindow which shows the tip}
THelpWindow=object(TWindow)
LogicalFont : TLOGFONT;
ToolToHelp : PTipbutton;
constructor Init (AParent : PTipbar; Tool : PTipbutton; WherePos : TPoint;
Width, Height : Word);
procedure Paint (DC : HDC; var PS : TPaintStruct); virtual;
end;
{ This is a normal toolbarbutton with an extra string variable}
TTipbutton=object(TToolbutton)
HelpString:array[0..255] of char;
end;
{ This is the definition of our new Tipbar }
TTipbar = object(TToolbar)
Help : Boolean; {Decides if we should help or not}
Timer : Word; {Timer to use}
ToolToHelp : PTipButton; {Points to the button to help, it is nil if no
button needs help}
PopWin : PHelpWindow; {Pointer to the Helpwindow if one exists}
OldMouseCoord : Tpoint; {Helps remember the mousecoordinate}
Delay : Word;
constructor Init(AParent : PWindow; AName : PChar; Orient : Word; Delaypar
: word);
destructor done; virtual;
constructor Load(var S: TStream);
procedure Store(var S: TStream); virtual;
function GetClassName: PChar; virtual;
procedure GetWindowClass(var WC: TWndClass); virtual;
procedure ReadResource; virtual;
procedure Timermsg(Var Msg:TMessage); virtual wm_first+wm_timer;
procedure GetToolUnder(P:Tpoint);
procedure WMMouseMove(var Msg: TMessage);
virtual wm_First + wm_MouseMove;
function CreateTool(Num: Integer; Origin: TPoint; Command: Word;
BitmapName: PChar): PTool; virtual;
procedure EnableHelp;
procedure DisableHelp;
procedure ChangeDelay(Delaypar:Word);
end;
const
RTipbar: TStreamRec = (
ObjType: 12302;
VmtLink: Ofs(TypeOf(TTipbar)^);
Load: @TTipbar.Load;
Store: @TTipbar.Store);
implementation
constructor TTipbar.Init (AParent : PWindow; AName : PChar; Orient : Word;
Delaypar : word);
begin
inherited Init(AParent,Aname,orient);
Timer := 0;
Delay := Delaypar;
Popwin := nil;
ToolToHelp := nil;
Help := TRUE; {Default is to show help}
end;
destructor TTipbar.Done;
begin
KillTimer(Hwindow,1);
inherited Done;
end;
procedure TTipbar.Enablehelp;
begin
Help:=TRUE;
end;
procedure TTipbar.Disablehelp;
begin
Help:=FALSE;
end;
procedure TTipbar.ChangeDelay(Delaypar:Word);
begin
Delay:=Delaypar;
end;
constructor TTipbar.Load(var S: TStream);
var
X: Integer;
procedure RestoreStates(P : PTool); far;
begin
P^.Read(S);
end;
begin
inherited Load(S);
Attr.Style := ws_Child or ws_Visible or ws_Border ;
SetFlags(wb_MDIChild, False);
DefaultProc := @DefWindowProc;
Capture := nil;
S.Read(Orientation, SizeOf(Orientation));
Tools.Init(8,8);
ResName := nil;
S.Read(X, SizeOf(X));
if X = 0 then
S.Read(PtrRec(ResName).Ofs, SizeOf(Word))
else
ResName := S.StrRead;
ReadResource;
if Status <> em_InvalidChild then
Tools.ForEach(@RestoreStates)
else
S.Status := stGetError;
end;
procedure TTipbar.Store(var S: TStream);
var
X: Integer;
procedure SaveStates(P : PTool); far;
begin
P^.Write(S);
end;
begin
inherited Store(S);
S.Write(Orientation, SizeOf(Orientation));
if HiWord(Longint(ResName)) <> 0 then
begin
X := 1;
S.Write(X, SizeOf(X));
S.StrWrite(ResName);
end
else
begin
X := 0;
S.Write(X, SizeOf(X));
S.Write(PtrRec(ResName).Ofs, SizeOf(Word));
end;
Tools.ForEach(@SaveStates);
end;
procedure TTipbar.ReadResource;
type
ResRec = record
Bitmap,
Command: Word;
end;
PResArray = ^TResArray;
TResArray = array [1..$FFF0 div sizeof(ResRec)] of ResRec;
var
ResIdHandle: THandle;
ResDataHandle: THandle;
ResDataPtr: PResArray;
Count: Word;
X: Word;
Origin: TPoint;
BitInfo: TBitmap;
P: PTool;
begin
ResIDHandle := FindResource(HInstance, ResName, 'HelpToolBarData');
ResDataHandle := LoadResource(HInstance, ResIDHandle);
ResDataPtr := LockResource(ResDataHandle);
if (ResIDHandle = 0) or (ResDataHandle = 0) or (ResDataPtr = nil) then
begin
Status := em_InvalidChild;
Exit;
end;
X := 0;
Origin.X := 2;
Origin.Y := 2;
Count := PWord(ResDataPtr)^;
Inc(LongInt(ResDataPtr), SizeOf(Count)); { Skip Count }
for X := 1 to Count do
with ResDataPtr^[1] do
begin
P := CreateTool(X, Origin, Command, PChar(Bitmap));
if P <> nil then
begin
NextToolOrigin(X, Origin, P);
Tools.Insert(P);
end;
Inc(Longint(ResDataPtr),sizeof(Resrec));
if Bitmap<>0 then
begin
Strcopy(PTipbutton(P)^.HelpString,Pchar(Resdataptr));
inc(LongInt(ResdataPtr),strlen(PTipbutton(P)^.HelpString)+1);
end;
end;
Inc(Attr.H, 8);
Inc(Attr.W, 8);
UnlockResource(ResDataHandle);
FreeResource(ResDataHandle);
end;
function TTipbar.CreateTool( Num : Integer; Origin : TPoint; Command : Word;
BitmapName : PChar): PTool;
begin
if Word(BitmapName) = 0 then
CreateTool := New(PToolSpacer, Init(@Self, Command))
else
CreateTool := New(PTipButton, Init(@Self, Origin.X, Origin.Y, Command,
BitmapName));
end;
function TTipbar.GetClassName: PChar;
begin
GetClassName := 'Tipbar';
end;
procedure TTipbar.GetWindowClass(var WC: TWndClass);
begin
TWindow.GetWindowClass(WC);
WC.hbrBackground := GetStockObject(LtGray_Brush);
end;
procedure TTipbar.WMMouseMove(var Msg: TMessage);
begin
if Popwin<>nil then
begin
if not((OldMouseCoord.x=TPoint(Msg.Lparam).x) and
(OldMouseCoord.y=TPoint(Msg.Lparam).y)) then
begin
Popwin^.Done;
popwin:=NIL;
end;
end;
If HELP then GetToolUnder(TPoint(Msg.Lparam));
if (Capture <> nil) then
Capture^.ContinueCapture(TPoint(Msg.LParam));
end;
procedure TTipbar.GetToolUnder(P:TPoint);
function IsUnder(Item:PTool):boolean; far;
begin
IsUnder := Item^.HitTest(P);
end;
begin
ToolToHelp := Tools.firstThat(@IsUnder);
if ToolToHelp <> nil then
begin
SetTimer( Hwindow, 1, Delay, nil);
OldMouseCoord.x := P.x;
OldMouseCoord.y := P.y;
end;
end;
procedure TTipbar.Timermsg(Var Msg:TMessage);
var Co : Tpoint;
begin
GetCursorPos(Co);
ScreenToClient(Hwindow,Co);
GetToolUnder(Co);
if (PopwIN = nil) and (ToolToHelp <> nil) then
begin
co.x := OldMouseCoord.x;
co.y := OldMouseCoord.y;
ClientToScreen(Hwindow,Co);
Popwin := new(PHelpWindow,Init(@self,ToolToHelp,Co,10,10));
Application^.MakeWindow(Popwin);
ShowWindow(Popwin^.HWindow,SW_SHOWNOACTIVATE);
KillTimer(Hwindow,1);
end;
end;
constructor THelpWindow.Init(AParent : PTipbar; Tool : PTipbutton; WherePos :
TPoint; Width, Height : Word);
var Odc:HDC;
Rect:TRect;
Font,OldFont:HFONT;
begin
with LogicalFont do
begin
lfHeight := 14;
lfWidth := 0;
lfEscapement := 0;
lfOrientation := 0;
lfWeight := FW_NORMAL;
lfItalic := 0;
lfUnderline := 0;
lfStrikeOut := 0;
lfCharSet := ANSI_CharSet;
lfOutPrecision := Out_Default_Precis;
lfClipPrecision := Clip_Default_Precis;
lfQuality := Proof_Quality;
lfPitchAndFamily:= Variable_Pitch or FF_Roman;
StrCopy(lfFaceName,'Arial');
end;
inherited Init(Aparent,nil);
ToolToHelp := Tool;
{ Firstly, we will position the window att the x coordinate of the cursor and
10 pixels below the y}
attr.x := Wherepos.x;
attr.y := Wherepos.y+10;
{ Then, we calculate the height of the text but we set the maximum width to
be 70 pixels}
setRect(Rect,0,0,70,0);
font := CreateFontIndirect(LogicalFont);
Odc := GetDC(0);
OldFont := Selectobject(odc,font);
Drawtext(ODc, ToolToHelp^.HelpString, strlen(ToolToHelp^.HelpString), Rect,
DT_LEFT or DT_CALCRECT or DT_WORDBREAK);
{Now, we have the width and height of the text in Rect. Then we add a bit to
center the text. }
Attr.w := Rect.right+10;
Attr.h := Rect.bottom+10;
Selectobject(odc,OldFont);
Deleteobject(Font);
ReleaseDC(0,Odc);
{ The style is pretty important}
Attr.Style := ws_border or ws_popup or ws_disabled ;
end;
procedure THelpWindow.Paint(DC: HDC; var PS: TPaintStruct);
var Rect:TRect;
Font,OldFont:HFONT;
begin
{First, we measure again the size of the text, unnecessary this should be
stored in an instance variable}
{instead. A future enhancement.}
setRect(Rect,0,0,70,0);
Font := CreateFontIndirect(LogicalFont);
OldFont := Selectobject(dc,font);
Drawtext(DC, ToolToHelp^.HelpString,strlen(ToolToHelp^.HelpString),Rect
DT_LEFT or DT_CALCRECT or DT_WORDBREAK);
OffsetRect(Rect,5,5);
Drawtext(DC,ToolToHelp^.HelpString,strlen(ToolToHelp^.HelpString),Rect
DT_LEFT or DT_WORDBREAK );
SelectObject(DC,OldFont);
Deleteobject(Font);
end;
begin
end.
[Back to WIN-OS2 SWAG index] [Back to Main SWAG index] [Original]