diff --git a/internal/2.2.2/1/DemoProj/Demo.cfg b/internal/2.2.2/1/DemoProj/Demo.cfg new file mode 100644 index 0000000..6b67b6f --- /dev/null +++ b/internal/2.2.2/1/DemoProj/Demo.cfg @@ -0,0 +1,33 @@ +-$A+ +-$B- +-$C+ +-$D+ +-$E- +-$F- +-$G+ +-$H+ +-$I+ +-$J+ +-$K- +-$L+ +-$M- +-$N+ +-$O+ +-$P+ +-$Q- +-$R- +-$S- +-$T- +-$U- +-$V+ +-$W- +-$X+ +-$Y- +-$Z1 +-cg +-AWinTypes=Windows;WinProcs=Windows;DbiTypes=BDE;DbiProcs=BDE;DbiErrs=BDE; +-H+ +-W+ +-M +-$M16384,1048576 +-K$00400000 diff --git a/internal/2.2.2/1/DemoProj/Demo.dof b/internal/2.2.2/1/DemoProj/Demo.dof new file mode 100644 index 0000000..d8a22f2 --- /dev/null +++ b/internal/2.2.2/1/DemoProj/Demo.dof @@ -0,0 +1,29 @@ +[Compiler] +A=1 +B=0 +C=1 +D=1 +E=0 +F=0 +G=1 +H=1 +I=1 +J=1 +K=0 +L=1 +M=0 +N=1 +O=1 +P=1 +Q=0 +R=0 +S=0 +T=0 +U=0 +V=1 +W=0 +X=1 +Y=0 +Z=1 +ShowHints=1 +ShowWarnings=1 diff --git a/internal/2.2.2/1/DemoProj/Demo.dpr b/internal/2.2.2/1/DemoProj/Demo.dpr new file mode 100644 index 0000000..1697c6c --- /dev/null +++ b/internal/2.2.2/1/DemoProj/Demo.dpr @@ -0,0 +1,22 @@ +program Demo; + +uses + Forms, + Demo1 in 'Demo1.pas' {Form1}; + +{$R *.RES} + +{$IFDEF CLR} +[STAThread] // All VCL.NET projects that use Toolbar2000 must include this +{$ENDIF} +begin + Application.Initialize; + {$IFDEF CONDITIONALEXPRESSIONS} + {$IF CompilerVersion >= 18.5} + Application.MainFormOnTaskbar := True; + {$IFEND} + {$ENDIF} + Application.CreateForm(TForm1, Form1); + Application.Run; +end. + diff --git a/internal/2.2.2/1/DemoProj/Demo.res b/internal/2.2.2/1/DemoProj/Demo.res new file mode 100644 index 0000000..a8371ab Binary files /dev/null and b/internal/2.2.2/1/DemoProj/Demo.res differ diff --git a/internal/2.2.2/1/DemoProj/Demo1.dfm b/internal/2.2.2/1/DemoProj/Demo1.dfm new file mode 100644 index 0000000..2ebc239 Binary files /dev/null and b/internal/2.2.2/1/DemoProj/Demo1.dfm differ diff --git a/internal/2.2.2/1/DemoProj/Demo1.pas b/internal/2.2.2/1/DemoProj/Demo1.pas new file mode 100644 index 0000000..77c64b9 --- /dev/null +++ b/internal/2.2.2/1/DemoProj/Demo1.pas @@ -0,0 +1,254 @@ +unit Demo1; + +{ + Toolbar2000 demo project + + $jrsoftware: tb2k/DemoProj/Demo1.pas,v 1.9 2006/03/12 23:11:58 jr Exp $ +} + +interface + +uses + Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs, + StdCtrls, ExtCtrls, Menus, ActnList, ImgList, ComCtrls, + TB2Item, TB2ExtItems, TB2Dock, TB2Toolbar, TB2MRU; + +type + TForm1 = class(TForm) + ActionList: TActionList; + actNew: TAction; + actOpen: TAction; + actSave: TAction; + actSaveAs: TAction; + actPageSetup: TAction; + actPrint: TAction; + actExit: TAction; + actUndo: TAction; + actCut: TAction; + actCopy: TAction; + actPaste: TAction; + actDelete: TAction; + actSelectAll: TAction; + actTimeDate: TAction; + actWordWrap: TAction; + actSetFont: TAction; + actFind: TAction; + actFindNext: TAction; + actReplace: TAction; + actHelpTopics: TAction; + actAbout: TAction; + actTestButton: TAction; + actTestEdit: TTBEditAction; + DockTop: TTBDock; + MenuToolbar: TTBToolbar; + ImageList: TTBImageList; + FMenu: TTBSubmenuItem; + FNew: TTBItem; + FOpen: TTBItem; + FSave: TTBItem; + FSaveAs: TTBItem; + FPageSetup: TTBItem; + FPrint: TTBItem; + FExit: TTBItem; + EMenu: TTBSubmenuItem; + EUndo: TTBItem; + ECut: TTBItem; + ECopy: TTBItem; + EPaste: TTBItem; + EDelete: TTBItem; + ESelectAll: TTBItem; + ETimeDate: TTBItem; + EWordWrap: TTBItem; + ESetFont: TTBItem; + SMenu: TTBSubmenuItem; + SFind: TTBItem; + SFindNext: TTBItem; + SReplace: TTBItem; + HMenu: TTBSubmenuItem; + HHelpTopics: TTBItem; + HAbout: TTBItem; + FMRU: TTBMRUListItem; + NBSeparatorItem3: TTBSeparatorItem; + NBSeparatorItem4: TTBSeparatorItem; + TestEdit: TTBEditItem; + MainToolbar: TTBToolbar; + NewButton: TTBItem; + OpenButton: TTBItem; + SaveButton: TTBItem; + DockBottom: TTBDock; + DockLeft: TTBDock; + DockRight: TTBDock; + BottomToolbar: TTBToolbar; + PopupMenuBarButton: TTBItem; + PopupToolbarButton: TTBItem; + Memo1: TMemo; + ContextPopupMenu: TTBPopupMenu; + StatusBar: TStatusBar; + ToolbarPopupMenu: TTBPopupMenu; + MRUList: TTBMRUList; + PrintButton: TTBItem; + CutButton: TTBItem; + CopyButton: TTBItem; + PasteButton: TTBItem; + UndoButton: TTBSubmenuItem; + actPrintPreview: TAction; + TBItem1: TTBItem; + FormatToolbar: TTBToolbar; + BoldItem: TTBItem; + ItalicItem: TTBItem; + UnderlineItem: TTBItem; + TBSeparatorItem1: TTBSeparatorItem; + AlignLeftItem: TTBItem; + CenterItem: TTBItem; + AlignRightItem: TTBItem; + TBSeparatorItem2: TTBSeparatorItem; + BulletsItem: TTBItem; + NBItem34: TTBItem; + NBSeparatorItem6: TTBSeparatorItem; + NBItem35: TTBItem; + NBItem36: TTBItem; + NBItem37: TTBItem; + NBItem38: TTBItem; + NBSeparatorItem7: TTBSeparatorItem; + NBItem39: TTBItem; + ComboBox1: TComboBox; + TBControlItem1: TTBControlItem; + TBSeparatorItem3: TTBSeparatorItem; + TBControlItem2: TTBControlItem; + ComboBox2: TComboBox; + actBold: TAction; + actItalic: TAction; + actUnderline: TAction; + actAlignLeft: TAction; + actCenter: TAction; + actAlignRight: TAction; + TBSeparatorItem4: TTBSeparatorItem; + actRedo: TAction; + RedoButton: TTBSubmenuItem; + TBItem2: TTBItem; + TBItem3: TTBItem; + TBItem4: TTBItem; + ERedo: TTBItem; + VMenu: TTBSubmenuItem; + VToolbars: TTBSubmenuItem; + VTStandard: TTBVisibilityToggleItem; + VTFormatting: TTBVisibilityToggleItem; + VTBottom: TTBVisibilityToggleItem; + VStatusBar: TTBItem; + actBullets: TAction; + procedure FormCreate(Sender: TObject); + procedure ItemClick(Sender: TObject); + procedure PopupMenuBarButtonClick(Sender: TObject); + procedure PopupToolbarButtonClick(Sender: TObject); + procedure MRUListClick(Sender: TObject; const Filename: String); + procedure AlignClick(Sender: TObject); + procedure BulletsItemClick(Sender: TObject); + procedure BoldItemClick(Sender: TObject); + procedure ItalicItemClick(Sender: TObject); + procedure UnderlineItemClick(Sender: TObject); + procedure VStatusBarClick(Sender: TObject); + procedure VMenuClick(Sender: TObject); + private + { Private declarations } + procedure OnHint(Sender: TObject); + public + { Public declarations } + end; + +var + Form1: TForm1; + +implementation + +uses + {$IFDEF CLR} Types, {$ENDIF} + CommCtrl, TB2Version; + +{$R *.DFM} + +procedure TForm1.FormCreate(Sender: TObject); +begin + Memo1.Text := 'Running on ' + Toolbar2000VersionPropText; + Application.OnHint := OnHint; +end; + +procedure TForm1.OnHint(Sender: TObject); +begin + StatusBar.Panels[0].Text := Application.Hint; +end; + +procedure TForm1.ItemClick(Sender: TObject); +begin + Application.MessageBox( {$IFNDEF CLR} PChar {$ENDIF} + ('You selected:'#13#10#13#10 + (Sender as TComponent).Name), + 'OnClick handler', MB_OK or MB_ICONINFORMATION); +end; + +procedure TForm1.MRUListClick(Sender: TObject; const Filename: String); +begin + Application.MessageBox( {$IFNDEF CLR} PChar {$ENDIF} + (Format('You selected "%s" from the MRU list.', [Filename])), + 'MRUListClick', MB_OK or MB_ICONINFORMATION); +end; + +procedure TForm1.VMenuClick(Sender: TObject); +begin + VStatusBar.Checked := StatusBar.Visible; +end; + +procedure TForm1.VStatusBarClick(Sender: TObject); +begin + { Force the StatusBar to always be at the bottom of the form. Without this + line of code, the status bar sometimes may appear above the bottom dock. + This is not a bug in Toolbar2000, but rather is due to the design of the + VCL's alignment system. } + StatusBar.Top := ClientHeight; + + { Toggle the status bar's visibility } + StatusBar.Visible := not StatusBar.Visible; +end; + +procedure TForm1.AlignClick(Sender: TObject); +begin + AlignLeftItem.Checked := (Sender = actAlignLeft); + CenterItem.Checked := (Sender = actCenter); + AlignRightItem.Checked := (Sender = actAlignRight); +end; + +procedure TForm1.BulletsItemClick(Sender: TObject); +begin + BulletsItem.Checked := not BulletsItem.Checked; +end; + +procedure TForm1.BoldItemClick(Sender: TObject); +begin + BoldItem.Checked := not BoldItem.Checked; +end; + +procedure TForm1.ItalicItemClick(Sender: TObject); +begin + ItalicItem.Checked := not ItalicItem.Checked; +end; + +procedure TForm1.UnderlineItemClick(Sender: TObject); +begin + UnderlineItem.Checked := not UnderlineItem.Checked; +end; + +procedure TForm1.PopupMenuBarButtonClick(Sender: TObject); +var + P: TPoint; +begin + P := Memo1.ClientToScreen(Point(8, 8)); + MenuToolbar.Items.Popup(P.X, P.Y, True); +end; + +procedure TForm1.PopupToolbarButtonClick(Sender: TObject); +var + P: TPoint; +begin + P := Memo1.ClientToScreen(Point(8, 8)); + MainToolbar.Items.Popup(P.X, P.Y, True); +end; + +end. diff --git a/internal/2.2.2/1/DemoProj/DemoBCB.bpr b/internal/2.2.2/1/DemoProj/DemoBCB.bpr new file mode 100644 index 0000000..9800232 --- /dev/null +++ b/internal/2.2.2/1/DemoProj/DemoBCB.bpr @@ -0,0 +1,179 @@ +# --------------------------------------------------------------------------- +!if !$d(BCB) +BCB = $(MAKEDIR)\.. +!endif + +# --------------------------------------------------------------------------- +# IDE SECTION +# --------------------------------------------------------------------------- +# The following section of the project makefile is managed by the BCB IDE. +# It is recommended to use the IDE to change any of the values in this +# section. +# --------------------------------------------------------------------------- + +VERSION = BCB.04.04 +# --------------------------------------------------------------------------- +PROJECT = DemoBCB.exe +OBJFILES = Demo1.obj DemoBCB.obj +RESFILES = DemoBCB.res +RESDEPEN = $(RESFILES) Demo1.dfm +LIBFILES = +LIBRARIES = vcl40.lib +SPARELIBS = vcl40.lib +PACKAGES = +DEFFILE = +# --------------------------------------------------------------------------- +PATHCPP = .; +PATHASM = .; +PATHPAS = .; +PATHRC = .; +DEBUGLIBPATH = $(BCB)\lib\debug +RELEASELIBPATH = $(BCB)\lib\release +USERDEFINES = +SYSDEFINES = _RTLDLL;NO_STRICT +# --------------------------------------------------------------------------- +CFLAG1 = -I$(BCB)\include;$(BCB)\include\vcl -Od -Hc -H=$(BCB)\lib\vcl40.csm -w -Ve -r- \ + -a8 -k -y -v -vi- -c -b- -w-par -w-inl -Vx -tW -tWM \ + -D$(SYSDEFINES);$(USERDEFINES) +PFLAGS = -U$(BCB)\Projects\Lib;$(BCB)\lib\obj;$(BCB)\lib;$(RELEASELIBPATH) \ + -I$(BCB)\include;$(BCB)\include\vcl -$YD -$W -$O- -v -JPHNE -M +RFLAGS = -i$(BCB)\include;$(BCB)\include\vcl +AFLAGS = /i$(BCB)\include /i$(BCB)\include\vcl /mx /w2 /zd +LFLAGS = -L$(BCB)\Projects\Lib;$(BCB)\lib\obj;$(BCB)\lib;$(RELEASELIBPATH) -aa -Tpe -x \ + -Gn -v +# --------------------------------------------------------------------------- +ALLOBJ = c0w32.obj Memmgr.Lib sysinit.obj $(OBJFILES) +ALLRES = $(RESFILES) +ALLLIB = $(LIBFILES) $(LIBRARIES) import32.lib cp32mti.lib +# --------------------------------------------------------------------------- +!ifdef IDEOPTIONS + +[Version Info] +IncludeVerInfo=0 +AutoIncBuild=0 +MajorVer=1 +MinorVer=0 +Release=0 +Build=0 +Debug=0 +PreRelease=0 +Special=0 +Private=0 +DLL=0 +Locale=1033 +CodePage=1252 + +[Version Info Keys] +CompanyName= +FileDescription= +FileVersion=1.0.0.0 +InternalName= +LegalCopyright= +LegalTrademarks= +OriginalFilename= +ProductName= +ProductVersion=1.0.0.0 +Comments= + +[Debugging] +DebugSourceDirs=$(BCB)\source\vcl + +[Parameters] +RunParams= +HostApplication= +RemoteHost= +RemotePath= +RemoteDebug=0 + +[Compiler] +InMemoryExe=0 +ShowInfoMsgs=0 + +!endif + +# --------------------------------------------------------------------------- +# MAKE SECTION +# --------------------------------------------------------------------------- +# This section of the project file is not used by the BCB IDE. It is for +# the benefit of building from the command-line using the MAKE utility. +# --------------------------------------------------------------------------- + +.autodepend +# --------------------------------------------------------------------------- +!if !$d(BCC32) +BCC32 = bcc32 +!endif + +!if !$d(CPP32) +CPP32 = cpp32 +!endif + +!if !$d(DCC32) +DCC32 = dcc32 +!endif + +!if !$d(TASM32) +TASM32 = tasm32 +!endif + +!if !$d(LINKER) +LINKER = ilink32 +!endif + +!if !$d(BRCC32) +BRCC32 = brcc32 +!endif + +# --------------------------------------------------------------------------- +!if $d(PATHCPP) +.PATH.CPP = $(PATHCPP) +.PATH.C = $(PATHCPP) +!endif + +!if $d(PATHPAS) +.PATH.PAS = $(PATHPAS) +!endif + +!if $d(PATHASM) +.PATH.ASM = $(PATHASM) +!endif + +!if $d(PATHRC) +.PATH.RC = $(PATHRC) +!endif +# --------------------------------------------------------------------------- +$(PROJECT): $(OBJFILES) $(RESDEPEN) $(DEFFILE) + $(BCB)\BIN\$(LINKER) @&&! + $(LFLAGS) + + $(ALLOBJ), + + $(PROJECT),, + + $(ALLLIB), + + $(DEFFILE), + + $(ALLRES) +! +# --------------------------------------------------------------------------- +.pas.hpp: + $(BCB)\BIN\$(DCC32) $(PFLAGS) {$< } + +.pas.obj: + $(BCB)\BIN\$(DCC32) $(PFLAGS) {$< } + +.cpp.obj: + $(BCB)\BIN\$(BCC32) $(CFLAG1) -n$(@D) {$< } + +.c.obj: + $(BCB)\BIN\$(BCC32) $(CFLAG1) -n$(@D) {$< } + +.c.i: + $(BCB)\BIN\$(CPP32) $(CFLAG1) -n. {$< } + +.cpp.i: + $(BCB)\BIN\$(CPP32) $(CFLAG1) -n. {$< } + +.asm.obj: + $(BCB)\BIN\$(TASM32) $(AFLAGS) $<, $@ + +.rc.res: + $(BCB)\BIN\$(BRCC32) $(RFLAGS) -fo$@ $< +# --------------------------------------------------------------------------- + diff --git a/internal/2.2.2/1/DemoProj/DemoBCB.cpp b/internal/2.2.2/1/DemoProj/DemoBCB.cpp new file mode 100644 index 0000000..b4ea3e5 --- /dev/null +++ b/internal/2.2.2/1/DemoProj/DemoBCB.cpp @@ -0,0 +1,22 @@ +//--------------------------------------------------------------------------- +#include +#pragma hdrstop +USERES("DemoBCB.res"); +USEFORMNS("Demo1.pas", Demo1, Form1); +//--------------------------------------------------------------------------- +WINAPI WinMain(HINSTANCE, HINSTANCE, LPSTR, int) +{ + try + { + Application->Initialize(); + Application->CreateForm(__classid(TForm1), &Form1); + Application->Run(); + } + catch (Exception &exception) + { + Application->ShowException(&exception); + } + return 0; +} +//--------------------------------------------------------------------------- + diff --git a/internal/2.2.2/1/DemoProj/DemoBCB.res b/internal/2.2.2/1/DemoProj/DemoBCB.res new file mode 100644 index 0000000..32b522d Binary files /dev/null and b/internal/2.2.2/1/DemoProj/DemoBCB.res differ diff --git a/internal/2.2.2/1/DemoProj/DemoBCB6.bpr b/internal/2.2.2/1/DemoProj/DemoBCB6.bpr new file mode 100644 index 0000000..28a1267 --- /dev/null +++ b/internal/2.2.2/1/DemoProj/DemoBCB6.bpr @@ -0,0 +1,115 @@ + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + +[Version Info] +IncludeVerInfo=0 +AutoIncBuild=0 +MajorVer=1 +MinorVer=0 +Release=0 +Build=0 +Debug=0 +PreRelease=0 +Special=0 +Private=0 +DLL=0 +Locale=1033 +CodePage=1252 + +[Version Info Keys] +CompanyName= +FileDescription= +FileVersion=1.0.0.0 +InternalName= +LegalCopyright= +LegalTrademarks= +OriginalFilename= +ProductName= +ProductVersion=1.0.0.0 +Comments= + +[Debugging] +DebugSourceDirs=$(BCB)\source\vcl + +[Parameters] +RunParams= +Launcher= +UseLauncher=0 +DebugCWD= +HostApplication= +RemoteHost= +RemotePath= +RemoteLauncher= +RemoteCWD= +RemoteDebug=0 + +[Compiler] +ShowInfoMsgs=0 +LinkDebugVcl=0 +LinkCGLIB=0 + +[Language] +ActiveLang= +ProjectLang= +RootDir= + + \ No newline at end of file diff --git a/internal/2.2.2/1/DemoProj/DemoBCB6.cpp b/internal/2.2.2/1/DemoProj/DemoBCB6.cpp new file mode 100644 index 0000000..c762f01 --- /dev/null +++ b/internal/2.2.2/1/DemoProj/DemoBCB6.cpp @@ -0,0 +1,34 @@ +//--------------------------------------------------------------------------- + +#include +#pragma hdrstop +//--------------------------------------------------------------------------- +USEFORMNS("Demo1.pas", Demo1, Form1); +//--------------------------------------------------------------------------- +WINAPI WinMain(HINSTANCE, HINSTANCE, LPSTR, int) +{ + try + { + Application->Initialize(); + Application->CreateForm(__classid(TForm1), &Form1); + Application->Run(); + } + catch (Exception &exception) + { + Application->ShowException(&exception); + } + catch (...) + { + try + { + throw Exception(""); + } + catch (Exception &exception) + { + Application->ShowException(&exception); + } + } + return 0; +} +//--------------------------------------------------------------------------- + diff --git a/internal/2.2.2/1/DemoProj/DemoBCB6.res b/internal/2.2.2/1/DemoProj/DemoBCB6.res new file mode 100644 index 0000000..e468bf9 Binary files /dev/null and b/internal/2.2.2/1/DemoProj/DemoBCB6.res differ diff --git a/internal/2.2.2/1/GPL-LICENSE.txt b/internal/2.2.2/1/GPL-LICENSE.txt new file mode 100644 index 0000000..45645b4 --- /dev/null +++ b/internal/2.2.2/1/GPL-LICENSE.txt @@ -0,0 +1,340 @@ + GNU GENERAL PUBLIC LICENSE + Version 2, June 1991 + + Copyright (C) 1989, 1991 Free Software Foundation, Inc. + 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA + Everyone is permitted to copy and distribute verbatim copies + of this license document, but changing it is not allowed. + + Preamble + + The licenses for most software are designed to take away your +freedom to share and change it. By contrast, the GNU General Public +License is intended to guarantee your freedom to share and change free +software--to make sure the software is free for all its users. This +General Public License applies to most of the Free Software +Foundation's software and to any other program whose authors commit to +using it. (Some other Free Software Foundation software is covered by +the GNU Library General Public License instead.) You can apply it to +your programs, too. + + When we speak of free software, we are referring to freedom, not +price. Our General Public Licenses are designed to make sure that you +have the freedom to distribute copies of free software (and charge for +this service if you wish), that you receive source code or can get it +if you want it, that you can change the software or use pieces of it +in new free programs; and that you know you can do these things. + + To protect your rights, we need to make restrictions that forbid +anyone to deny you these rights or to ask you to surrender the rights. +These restrictions translate to certain responsibilities for you if you +distribute copies of the software, or if you modify it. + + For example, if you distribute copies of such a program, whether +gratis or for a fee, you must give the recipients all the rights that +you have. You must make sure that they, too, receive or can get the +source code. And you must show them these terms so they know their +rights. + + We protect your rights with two steps: (1) copyright the software, and +(2) offer you this license which gives you legal permission to copy, +distribute and/or modify the software. + + Also, for each author's protection and ours, we want to make certain +that everyone understands that there is no warranty for this free +software. If the software is modified by someone else and passed on, we +want its recipients to know that what they have is not the original, so +that any problems introduced by others will not reflect on the original +authors' reputations. + + Finally, any free program is threatened constantly by software +patents. We wish to avoid the danger that redistributors of a free +program will individually obtain patent licenses, in effect making the +program proprietary. To prevent this, we have made it clear that any +patent must be licensed for everyone's free use or not licensed at all. + + The precise terms and conditions for copying, distribution and +modification follow. + + GNU GENERAL PUBLIC LICENSE + TERMS AND CONDITIONS FOR COPYING, DISTRIBUTION AND MODIFICATION + + 0. This License applies to any program or other work which contains +a notice placed by the copyright holder saying it may be distributed +under the terms of this General Public License. The "Program", below, +refers to any such program or work, and a "work based on the Program" +means either the Program or any derivative work under copyright law: +that is to say, a work containing the Program or a portion of it, +either verbatim or with modifications and/or translated into another +language. (Hereinafter, translation is included without limitation in +the term "modification".) Each licensee is addressed as "you". + +Activities other than copying, distribution and modification are not +covered by this License; they are outside its scope. The act of +running the Program is not restricted, and the output from the Program +is covered only if its contents constitute a work based on the +Program (independent of having been made by running the Program). +Whether that is true depends on what the Program does. + + 1. You may copy and distribute verbatim copies of the Program's +source code as you receive it, in any medium, provided that you +conspicuously and appropriately publish on each copy an appropriate +copyright notice and disclaimer of warranty; keep intact all the +notices that refer to this License and to the absence of any warranty; +and give any other recipients of the Program a copy of this License +along with the Program. + +You may charge a fee for the physical act of transferring a copy, and +you may at your option offer warranty protection in exchange for a fee. + + 2. You may modify your copy or copies of the Program or any portion +of it, thus forming a work based on the Program, and copy and +distribute such modifications or work under the terms of Section 1 +above, provided that you also meet all of these conditions: + + a) You must cause the modified files to carry prominent notices + stating that you changed the files and the date of any change. + + b) You must cause any work that you distribute or publish, that in + whole or in part contains or is derived from the Program or any + part thereof, to be licensed as a whole at no charge to all third + parties under the terms of this License. + + c) If the modified program normally reads commands interactively + when run, you must cause it, when started running for such + interactive use in the most ordinary way, to print or display an + announcement including an appropriate copyright notice and a + notice that there is no warranty (or else, saying that you provide + a warranty) and that users may redistribute the program under + these conditions, and telling the user how to view a copy of this + License. (Exception: if the Program itself is interactive but + does not normally print such an announcement, your work based on + the Program is not required to print an announcement.) + +These requirements apply to the modified work as a whole. If +identifiable sections of that work are not derived from the Program, +and can be reasonably considered independent and separate works in +themselves, then this License, and its terms, do not apply to those +sections when you distribute them as separate works. But when you +distribute the same sections as part of a whole which is a work based +on the Program, the distribution of the whole must be on the terms of +this License, whose permissions for other licensees extend to the +entire whole, and thus to each and every part regardless of who wrote it. + +Thus, it is not the intent of this section to claim rights or contest +your rights to work written entirely by you; rather, the intent is to +exercise the right to control the distribution of derivative or +collective works based on the Program. + +In addition, mere aggregation of another work not based on the Program +with the Program (or with a work based on the Program) on a volume of +a storage or distribution medium does not bring the other work under +the scope of this License. + + 3. You may copy and distribute the Program (or a work based on it, +under Section 2) in object code or executable form under the terms of +Sections 1 and 2 above provided that you also do one of the following: + + a) Accompany it with the complete corresponding machine-readable + source code, which must be distributed under the terms of Sections + 1 and 2 above on a medium customarily used for software interchange; or, + + b) Accompany it with a written offer, valid for at least three + years, to give any third party, for a charge no more than your + cost of physically performing source distribution, a complete + machine-readable copy of the corresponding source code, to be + distributed under the terms of Sections 1 and 2 above on a medium + customarily used for software interchange; or, + + c) Accompany it with the information you received as to the offer + to distribute corresponding source code. (This alternative is + allowed only for noncommercial distribution and only if you + received the program in object code or executable form with such + an offer, in accord with Subsection b above.) + +The source code for a work means the preferred form of the work for +making modifications to it. For an executable work, complete source +code means all the source code for all modules it contains, plus any +associated interface definition files, plus the scripts used to +control compilation and installation of the executable. However, as a +special exception, the source code distributed need not include +anything that is normally distributed (in either source or binary +form) with the major components (compiler, kernel, and so on) of the +operating system on which the executable runs, unless that component +itself accompanies the executable. + +If distribution of executable or object code is made by offering +access to copy from a designated place, then offering equivalent +access to copy the source code from the same place counts as +distribution of the source code, even though third parties are not +compelled to copy the source along with the object code. + + 4. You may not copy, modify, sublicense, or distribute the Program +except as expressly provided under this License. Any attempt +otherwise to copy, modify, sublicense or distribute the Program is +void, and will automatically terminate your rights under this License. +However, parties who have received copies, or rights, from you under +this License will not have their licenses terminated so long as such +parties remain in full compliance. + + 5. You are not required to accept this License, since you have not +signed it. However, nothing else grants you permission to modify or +distribute the Program or its derivative works. These actions are +prohibited by law if you do not accept this License. Therefore, by +modifying or distributing the Program (or any work based on the +Program), you indicate your acceptance of this License to do so, and +all its terms and conditions for copying, distributing or modifying +the Program or works based on it. + + 6. Each time you redistribute the Program (or any work based on the +Program), the recipient automatically receives a license from the +original licensor to copy, distribute or modify the Program subject to +these terms and conditions. You may not impose any further +restrictions on the recipients' exercise of the rights granted herein. +You are not responsible for enforcing compliance by third parties to +this License. + + 7. If, as a consequence of a court judgment or allegation of patent +infringement or for any other reason (not limited to patent issues), +conditions are imposed on you (whether by court order, agreement or +otherwise) that contradict the conditions of this License, they do not +excuse you from the conditions of this License. If you cannot +distribute so as to satisfy simultaneously your obligations under this +License and any other pertinent obligations, then as a consequence you +may not distribute the Program at all. For example, if a patent +license would not permit royalty-free redistribution of the Program by +all those who receive copies directly or indirectly through you, then +the only way you could satisfy both it and this License would be to +refrain entirely from distribution of the Program. + +If any portion of this section is held invalid or unenforceable under +any particular circumstance, the balance of the section is intended to +apply and the section as a whole is intended to apply in other +circumstances. + +It is not the purpose of this section to induce you to infringe any +patents or other property right claims or to contest validity of any +such claims; this section has the sole purpose of protecting the +integrity of the free software distribution system, which is +implemented by public license practices. Many people have made +generous contributions to the wide range of software distributed +through that system in reliance on consistent application of that +system; it is up to the author/donor to decide if he or she is willing +to distribute software through any other system and a licensee cannot +impose that choice. + +This section is intended to make thoroughly clear what is believed to +be a consequence of the rest of this License. + + 8. If the distribution and/or use of the Program is restricted in +certain countries either by patents or by copyrighted interfaces, the +original copyright holder who places the Program under this License +may add an explicit geographical distribution limitation excluding +those countries, so that distribution is permitted only in or among +countries not thus excluded. In such case, this License incorporates +the limitation as if written in the body of this License. + + 9. The Free Software Foundation may publish revised and/or new versions +of the General Public License from time to time. Such new versions will +be similar in spirit to the present version, but may differ in detail to +address new problems or concerns. + +Each version is given a distinguishing version number. If the Program +specifies a version number of this License which applies to it and "any +later version", you have the option of following the terms and conditions +either of that version or of any later version published by the Free +Software Foundation. If the Program does not specify a version number of +this License, you may choose any version ever published by the Free Software +Foundation. + + 10. If you wish to incorporate parts of the Program into other free +programs whose distribution conditions are different, write to the author +to ask for permission. For software which is copyrighted by the Free +Software Foundation, write to the Free Software Foundation; we sometimes +make exceptions for this. Our decision will be guided by the two goals +of preserving the free status of all derivatives of our free software and +of promoting the sharing and reuse of software generally. + + NO WARRANTY + + 11. BECAUSE THE PROGRAM IS LICENSED FREE OF CHARGE, THERE IS NO WARRANTY +FOR THE PROGRAM, TO THE EXTENT PERMITTED BY APPLICABLE LAW. EXCEPT WHEN +OTHERWISE STATED IN WRITING THE COPYRIGHT HOLDERS AND/OR OTHER PARTIES +PROVIDE THE PROGRAM "AS IS" WITHOUT WARRANTY OF ANY KIND, EITHER EXPRESSED +OR IMPLIED, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF +MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE. THE ENTIRE RISK AS +TO THE QUALITY AND PERFORMANCE OF THE PROGRAM IS WITH YOU. SHOULD THE +PROGRAM PROVE DEFECTIVE, YOU ASSUME THE COST OF ALL NECESSARY SERVICING, +REPAIR OR CORRECTION. + + 12. IN NO EVENT UNLESS REQUIRED BY APPLICABLE LAW OR AGREED TO IN WRITING +WILL ANY COPYRIGHT HOLDER, OR ANY OTHER PARTY WHO MAY MODIFY AND/OR +REDISTRIBUTE THE PROGRAM AS PERMITTED ABOVE, BE LIABLE TO YOU FOR DAMAGES, +INCLUDING ANY GENERAL, SPECIAL, INCIDENTAL OR CONSEQUENTIAL DAMAGES ARISING +OUT OF THE USE OR INABILITY TO USE THE PROGRAM (INCLUDING BUT NOT LIMITED +TO LOSS OF DATA OR DATA BEING RENDERED INACCURATE OR LOSSES SUSTAINED BY +YOU OR THIRD PARTIES OR A FAILURE OF THE PROGRAM TO OPERATE WITH ANY OTHER +PROGRAMS), EVEN IF SUCH HOLDER OR OTHER PARTY HAS BEEN ADVISED OF THE +POSSIBILITY OF SUCH DAMAGES. + + END OF TERMS AND CONDITIONS + + How to Apply These Terms to Your New Programs + + If you develop a new program, and you want it to be of the greatest +possible use to the public, the best way to achieve this is to make it +free software which everyone can redistribute and change under these terms. + + To do so, attach the following notices to the program. It is safest +to attach them to the start of each source file to most effectively +convey the exclusion of warranty; and each file should have at least +the "copyright" line and a pointer to where the full notice is found. + + + Copyright (C) + + This program is free software; you can redistribute it and/or modify + it under the terms of the GNU General Public License as published by + the Free Software Foundation; either version 2 of the License, or + (at your option) any later version. + + This program 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 General Public License for more details. + + You should have received a copy of the GNU General Public License + along with this program; if not, write to the Free Software + Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA + + +Also add information on how to contact you by electronic and paper mail. + +If the program is interactive, make it output a short notice like this +when it starts in an interactive mode: + + Gnomovision version 69, Copyright (C) year name of author + Gnomovision comes with ABSOLUTELY NO WARRANTY; for details type `show w'. + This is free software, and you are welcome to redistribute it + under certain conditions; type `show c' for details. + +The hypothetical commands `show w' and `show c' should show the appropriate +parts of the General Public License. Of course, the commands you use may +be called something other than `show w' and `show c'; they could even be +mouse-clicks or menu items--whatever suits your program. + +You should also get your employer (if you work as a programmer) or your +school, if any, to sign a "copyright disclaimer" for the program, if +necessary. Here is a sample; alter the names: + + Yoyodyne, Inc., hereby disclaims all copyright interest in the program + `Gnomovision' (which makes passes at compilers) written by James Hacker. + + , 1 April 1989 + Ty Coon, President of Vice + +This General Public License does not permit incorporating your program into +proprietary programs. If your program is a subroutine library, you may +consider it more useful to permit linking proprietary applications with the +library. If this is what you want to do, use the GNU Library General +Public License instead of this License. diff --git a/internal/2.2.2/1/Glyphs.zip b/internal/2.2.2/1/Glyphs.zip new file mode 100644 index 0000000..6070442 Binary files /dev/null and b/internal/2.2.2/1/Glyphs.zip differ diff --git a/internal/2.2.2/1/LICENSE.txt b/internal/2.2.2/1/LICENSE.txt new file mode 100644 index 0000000..47c1846 --- /dev/null +++ b/internal/2.2.2/1/LICENSE.txt @@ -0,0 +1,17 @@ +All files included in the Toolbar2000 archive are Copyright (C) 1998-2008 +Jordan Russell. + +Use and/or distribution of the files requires compliance with the +"Toolbar2000 License", found in TB2k-LICENSE.txt or at: + + http://www.jrsoftware.org/files/tb2k/TB2k-LICENSE.txt + +Alternatively, at your option, the files may be used and/or distributed under +the terms of the "GNU General Public License", found in GPL-LICENSE.txt or at: + + http://www.jrsoftware.org/files/tb2k/GPL-LICENSE.txt + +NOTE: If you choose the GPL license option, your application as a whole must +also be licensed under the GPL. (Refer to section 2b of the GPL license.) +Therefore, you cannot choose the GPL license option if your application is +proprietary/closed-source. diff --git a/internal/2.2.2/1/Lib/D11/TB2Acc.dcu b/internal/2.2.2/1/Lib/D11/TB2Acc.dcu new file mode 100644 index 0000000..3abd61a Binary files /dev/null and b/internal/2.2.2/1/Lib/D11/TB2Acc.dcu differ diff --git a/internal/2.2.2/1/Lib/D11/TB2Anim.dcu b/internal/2.2.2/1/Lib/D11/TB2Anim.dcu new file mode 100644 index 0000000..3c40573 Binary files /dev/null and b/internal/2.2.2/1/Lib/D11/TB2Anim.dcu differ diff --git a/internal/2.2.2/1/Lib/D11/TB2Common.dcu b/internal/2.2.2/1/Lib/D11/TB2Common.dcu new file mode 100644 index 0000000..b63f44c Binary files /dev/null and b/internal/2.2.2/1/Lib/D11/TB2Common.dcu differ diff --git a/internal/2.2.2/1/Lib/D11/TB2Consts.dcu b/internal/2.2.2/1/Lib/D11/TB2Consts.dcu new file mode 100644 index 0000000..98b2bed Binary files /dev/null and b/internal/2.2.2/1/Lib/D11/TB2Consts.dcu differ diff --git a/internal/2.2.2/1/Lib/D11/TB2Dock.dcu b/internal/2.2.2/1/Lib/D11/TB2Dock.dcu new file mode 100644 index 0000000..28e0458 Binary files /dev/null and b/internal/2.2.2/1/Lib/D11/TB2Dock.dcu differ diff --git a/internal/2.2.2/1/Lib/D11/TB2DsgnConvertOptions.dcu b/internal/2.2.2/1/Lib/D11/TB2DsgnConvertOptions.dcu new file mode 100644 index 0000000..ee230c7 Binary files /dev/null and b/internal/2.2.2/1/Lib/D11/TB2DsgnConvertOptions.dcu differ diff --git a/internal/2.2.2/1/Lib/D11/TB2DsgnConvertOptions.dfm b/internal/2.2.2/1/Lib/D11/TB2DsgnConvertOptions.dfm new file mode 100644 index 0000000..9d5ad45 Binary files /dev/null and b/internal/2.2.2/1/Lib/D11/TB2DsgnConvertOptions.dfm differ diff --git a/internal/2.2.2/1/Lib/D11/TB2DsgnConverter.dcu b/internal/2.2.2/1/Lib/D11/TB2DsgnConverter.dcu new file mode 100644 index 0000000..ea33e71 Binary files /dev/null and b/internal/2.2.2/1/Lib/D11/TB2DsgnConverter.dcu differ diff --git a/internal/2.2.2/1/Lib/D11/TB2DsgnConverter.dfm b/internal/2.2.2/1/Lib/D11/TB2DsgnConverter.dfm new file mode 100644 index 0000000..f684c17 Binary files /dev/null and b/internal/2.2.2/1/Lib/D11/TB2DsgnConverter.dfm differ diff --git a/internal/2.2.2/1/Lib/D11/TB2DsgnItemEditor.dcu b/internal/2.2.2/1/Lib/D11/TB2DsgnItemEditor.dcu new file mode 100644 index 0000000..c2e0f9c Binary files /dev/null and b/internal/2.2.2/1/Lib/D11/TB2DsgnItemEditor.dcu differ diff --git a/internal/2.2.2/1/Lib/D11/TB2DsgnItemEditor.dfm b/internal/2.2.2/1/Lib/D11/TB2DsgnItemEditor.dfm new file mode 100644 index 0000000..748a7cd Binary files /dev/null and b/internal/2.2.2/1/Lib/D11/TB2DsgnItemEditor.dfm differ diff --git a/internal/2.2.2/1/Lib/D11/TB2DsgnItemEditor.res b/internal/2.2.2/1/Lib/D11/TB2DsgnItemEditor.res new file mode 100644 index 0000000..938763e Binary files /dev/null and b/internal/2.2.2/1/Lib/D11/TB2DsgnItemEditor.res differ diff --git a/internal/2.2.2/1/Lib/D11/TB2ExtItems.dcu b/internal/2.2.2/1/Lib/D11/TB2ExtItems.dcu new file mode 100644 index 0000000..557754d Binary files /dev/null and b/internal/2.2.2/1/Lib/D11/TB2ExtItems.dcu differ diff --git a/internal/2.2.2/1/Lib/D11/TB2Hook.dcu b/internal/2.2.2/1/Lib/D11/TB2Hook.dcu new file mode 100644 index 0000000..4bb35e9 Binary files /dev/null and b/internal/2.2.2/1/Lib/D11/TB2Hook.dcu differ diff --git a/internal/2.2.2/1/Lib/D11/TB2Item.dcu b/internal/2.2.2/1/Lib/D11/TB2Item.dcu new file mode 100644 index 0000000..d29d1cc Binary files /dev/null and b/internal/2.2.2/1/Lib/D11/TB2Item.dcu differ diff --git a/internal/2.2.2/1/Lib/D11/TB2MDI.dcu b/internal/2.2.2/1/Lib/D11/TB2MDI.dcu new file mode 100644 index 0000000..06ad1d7 Binary files /dev/null and b/internal/2.2.2/1/Lib/D11/TB2MDI.dcu differ diff --git a/internal/2.2.2/1/Lib/D11/TB2MDI.res b/internal/2.2.2/1/Lib/D11/TB2MDI.res new file mode 100644 index 0000000..4a62035 Binary files /dev/null and b/internal/2.2.2/1/Lib/D11/TB2MDI.res differ diff --git a/internal/2.2.2/1/Lib/D11/TB2MRU.dcu b/internal/2.2.2/1/Lib/D11/TB2MRU.dcu new file mode 100644 index 0000000..39f8fda Binary files /dev/null and b/internal/2.2.2/1/Lib/D11/TB2MRU.dcu differ diff --git a/internal/2.2.2/1/Lib/D11/TB2Reg.dcu b/internal/2.2.2/1/Lib/D11/TB2Reg.dcu new file mode 100644 index 0000000..9795648 Binary files /dev/null and b/internal/2.2.2/1/Lib/D11/TB2Reg.dcu differ diff --git a/internal/2.2.2/1/Lib/D11/TB2ResCursors.res b/internal/2.2.2/1/Lib/D11/TB2ResCursors.res new file mode 100644 index 0000000..e09ab15 Binary files /dev/null and b/internal/2.2.2/1/Lib/D11/TB2ResCursors.res differ diff --git a/internal/2.2.2/1/Lib/D11/TB2ToolWindow.dcu b/internal/2.2.2/1/Lib/D11/TB2ToolWindow.dcu new file mode 100644 index 0000000..3586990 Binary files /dev/null and b/internal/2.2.2/1/Lib/D11/TB2ToolWindow.dcu differ diff --git a/internal/2.2.2/1/Lib/D11/TB2Toolbar.dcu b/internal/2.2.2/1/Lib/D11/TB2Toolbar.dcu new file mode 100644 index 0000000..1abc0e7 Binary files /dev/null and b/internal/2.2.2/1/Lib/D11/TB2Toolbar.dcu differ diff --git a/internal/2.2.2/1/Lib/D11/TB2Ver.inc b/internal/2.2.2/1/Lib/D11/TB2Ver.inc new file mode 100644 index 0000000..f96696b --- /dev/null +++ b/internal/2.2.2/1/Lib/D11/TB2Ver.inc @@ -0,0 +1,64 @@ +{ $jrsoftware: tb2k/Source/TB2Ver.inc,v 1.11 2008/09/13 21:06:45 jr Exp $ } + +{ Determine Delphi/C++Builder version } +{$IFNDEF VER90} { if it's not Delphi 2.0 } + {$IFNDEF VER93} { and it's not C++Builder 1.0 } + {$DEFINE JR_D3} { then it must be at least Delphi 3 or C++Builder 3 } + {$IFNDEF VER100} { if it's not Delphi 3.0 } + {$IFNDEF VER120} { Delphi 4/5's command line compiler doesn't like the ObjExportAll directive, so don't include it on Delphi 4/5 } + {$IFNDEF VER130} + {$ObjExportAll On} { <- needed for compatibility with run-time packages in C++Builder 3+ } + {$ENDIF} + {$ENDIF} + {$IFNDEF VER110} { and it's not C++Builder 3.0 } + {$DEFINE JR_D4} { then it must be at least Delphi 4 or C++Builder 4 } + {$IFNDEF VER120} {$IFNDEF VER125} { if it's not Delphi 4 or C++Builder 4 } + {$DEFINE JR_D5} { then it must be at least Delphi 5 or C++Builder 5 } + {$IFNDEF VER130} { if it's not Delphi 5 or C++Builder 5 } + {$DEFINE JR_D6} { then it must be at least Delphi 6 or C++Builder 6 } + {$IFNDEF VER140} { if it's not Delphi 6 or C++Builder 6 } + {$DEFINE JR_D7} { then it must be at least Delphi 7 } + {$IFNDEF VER150} { if it's not Delphi 7 } + {$DEFINE JR_D8} { then it must be at least Delphi 8 } + {$IFNDEF VER160} { if it's not Delphi 8 } + {$DEFINE JR_D9} { then it must be at least Delphi 9 (2005) } + {$IFNDEF VER170} { if it's not Delphi 9 (2005) } + {$DEFINE JR_D10} { then it must be at least Delphi 10 (2006) } + { Delphi 11 (2007) is an odd case: it defines VER180 and VER185 on Win32, and VER190 on .NET } + {$IFDEF VER185} { if it's Win32 Delphi 11 (2007) exactly } + {$DEFINE JR_D11} { then it must be at least Delphi 11 (2007) } + {$ENDIF} + {$IFNDEF VER180} { if it's neither Delphi 10 (2006) nor Win32 Delphi 11 (2007) } + {$DEFINE JR_D11} { then it must be at least Delphi 11 (2007) } + {$IFNDEF VER190} { if it's not .NET Delphi 11 (2007) } + {$DEFINE JR_D12} { then it must be at least Delphi 12 (2009) } + {$ENDIF} + {$ENDIF} + {$ENDIF} + {$ENDIF} + {$ENDIF} + {$ENDIF} + {$ENDIF} + {$ENDIF} {$ENDIF} + {$ENDIF} + {$ENDIF} + {$ENDIF} +{$ENDIF} + +{$IFDEF JR_D6} + {$IF SizeOf(Char) > 1} + {$DEFINE JR_WIDESTR} { defined if String type = WideString } + {$IFEND} + {$IF not Defined(CLR) and (SizeOf(Pointer) <> 4)} + {$MESSAGE WARN 'This version of Toolbar2000 has not been tested on 64-bit Delphi for Win32'} + {$IFEND} +{$ENDIF} + +{$ALIGN ON} +{$BOOLEVAL OFF} +{$LONGSTRINGS ON} +{$TYPEDADDRESS OFF} +{$WRITEABLECONST ON} +{$IFDEF JR_D6} + {$WARN SYMBOL_PLATFORM OFF} +{$ENDIF} diff --git a/internal/2.2.2/1/Lib/D11/TB2Version.dcu b/internal/2.2.2/1/Lib/D11/TB2Version.dcu new file mode 100644 index 0000000..153764a Binary files /dev/null and b/internal/2.2.2/1/Lib/D11/TB2Version.dcu differ diff --git a/internal/2.2.2/1/Lib/D11/tb2k_d11.bpl b/internal/2.2.2/1/Lib/D11/tb2k_d11.bpl new file mode 100644 index 0000000..38b21c7 Binary files /dev/null and b/internal/2.2.2/1/Lib/D11/tb2k_d11.bpl differ diff --git a/internal/2.2.2/1/Lib/D11/tb2k_d11.dcp b/internal/2.2.2/1/Lib/D11/tb2k_d11.dcp new file mode 100644 index 0000000..cdd2157 Binary files /dev/null and b/internal/2.2.2/1/Lib/D11/tb2k_d11.dcp differ diff --git a/internal/2.2.2/1/Lib/D11/tb2k_d11.dcu b/internal/2.2.2/1/Lib/D11/tb2k_d11.dcu new file mode 100644 index 0000000..4736f80 Binary files /dev/null and b/internal/2.2.2/1/Lib/D11/tb2k_d11.dcu differ diff --git a/internal/2.2.2/1/Lib/D11/tb2kdsgn_d11.bpl b/internal/2.2.2/1/Lib/D11/tb2kdsgn_d11.bpl new file mode 100644 index 0000000..c1d4483 Binary files /dev/null and b/internal/2.2.2/1/Lib/D11/tb2kdsgn_d11.bpl differ diff --git a/internal/2.2.2/1/Lib/D11/tb2kdsgn_d11.dcp b/internal/2.2.2/1/Lib/D11/tb2kdsgn_d11.dcp new file mode 100644 index 0000000..39ff18b Binary files /dev/null and b/internal/2.2.2/1/Lib/D11/tb2kdsgn_d11.dcp differ diff --git a/internal/2.2.2/1/Lib/D11/tb2kdsgn_d11.dcu b/internal/2.2.2/1/Lib/D11/tb2kdsgn_d11.dcu new file mode 100644 index 0000000..8c31252 Binary files /dev/null and b/internal/2.2.2/1/Lib/D11/tb2kdsgn_d11.dcu differ diff --git a/internal/2.2.2/1/Packages/TB2k_D11Group.groupproj b/internal/2.2.2/1/Packages/TB2k_D11Group.groupproj new file mode 100644 index 0000000..ae9329a --- /dev/null +++ b/internal/2.2.2/1/Packages/TB2k_D11Group.groupproj @@ -0,0 +1,44 @@ + + + {b13d8c1b-fcdb-4ac9-8e43-5525fb4724c8} + + + + + + + + Default.Personality + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + \ No newline at end of file diff --git a/internal/2.2.2/1/Packages/tb2k_cb4.bpk b/internal/2.2.2/1/Packages/tb2k_cb4.bpk new file mode 100644 index 0000000..71a7b35 --- /dev/null +++ b/internal/2.2.2/1/Packages/tb2k_cb4.bpk @@ -0,0 +1,183 @@ +# --------------------------------------------------------------------------- +!if !$d(BCB) +BCB = $(MAKEDIR)\.. +!endif + +# --------------------------------------------------------------------------- +# IDE SECTION +# --------------------------------------------------------------------------- +# The following section of the project makefile is managed by the BCB IDE. +# It is recommended to use the IDE to change any of the values in this +# section. +# --------------------------------------------------------------------------- + +VERSION = BCB.04.04 +# --------------------------------------------------------------------------- +PROJECT = tb2k_cb4.bpl +OBJFILES = ..\Source\TB2Common.obj ..\Source\TB2Consts.obj ..\Source\TB2Dock.obj \ + ..\Source\TB2ExtItems.obj ..\Source\TB2Item.obj ..\Source\TB2Toolbar.obj \ + ..\Source\TB2Version.obj ..\Source\TB2Hook.obj ..\Source\TB2ToolWindow.obj \ + ..\Source\TB2MRU.obj ..\Source\TB2Anim.obj ..\Source\TB2MDI.obj \ + ..\Source\TB2Acc.obj tb2k_cb4.obj +RESFILES = +RESDEPEN = $(RESFILES) +LIBFILES = +LIBRARIES = +SPARELIBS = Vcl40.lib +PACKAGES = vcl40.bpi +DEFFILE = +# --------------------------------------------------------------------------- +PATHCPP = .; +PATHASM = .; +PATHPAS = .;..\Source +PATHRC = .; +DEBUGLIBPATH = $(BCB)\lib\debug +RELEASELIBPATH = $(BCB)\lib\release +USERDEFINES = +SYSDEFINES = _RTLDLL;NO_STRICT;USEPACKAGES +# --------------------------------------------------------------------------- +CFLAG1 = -I..\Source;$(BCB)\include;$(BCB)\include\vcl -Od -Hc -H=$(BCB)\lib\vcl40.csm \ + -w -Ve -r- -a8 -k -y -v -vi- -c -b- -w-par -w-inl -Vx -tWM \ + -D$(SYSDEFINES);$(USERDEFINES) +PFLAGS = -U..\Source;$(BCB)\lib\obj;$(BCB)\lib;$(RELEASELIBPATH) \ + -I..\Source;$(BCB)\include;$(BCB)\include\vcl -$YD -$J- -v -JPHNE -M +RFLAGS = -i..\Source;$(BCB)\include;$(BCB)\include\vcl +AFLAGS = /i..\Source /i$(BCB)\include /i$(BCB)\include\vcl /mx /w2 /zd +LFLAGS = -L..\Source;$(BCB)\lib\obj;$(BCB)\lib;$(RELEASELIBPATH) \ + -D"Toolbar2000 Components (Jordan Russell)" -aa -Tpp -Gpr -x -Gn -Gl -Gi -v +# --------------------------------------------------------------------------- +ALLOBJ = c0pkg32.obj Memmgr.Lib $(PACKAGES) sysinit.obj $(OBJFILES) +ALLRES = $(RESFILES) +ALLLIB = $(LIBFILES) $(LIBRARIES) import32.lib cp32mti.lib +# --------------------------------------------------------------------------- +!ifdef IDEOPTIONS + +[Version Info] +IncludeVerInfo=0 +AutoIncBuild=0 +MajorVer=1 +MinorVer=0 +Release=0 +Build=0 +Debug=0 +PreRelease=0 +Special=0 +Private=0 +DLL=0 +Locale=1033 +CodePage=1252 + +[Version Info Keys] +CompanyName= +FileDescription= +FileVersion=1.0.0.0 +InternalName= +LegalCopyright= +LegalTrademarks= +OriginalFilename= +ProductName= +ProductVersion=1.0.0.0 +Comments= + +[Debugging] +DebugSourceDirs=$(BCB)\source\vcl + +[Parameters] +RunParams= +HostApplication= +RemoteHost= +RemotePath= +RemoteDebug=0 + +[Compiler] +InMemoryExe=0 +ShowInfoMsgs=0 + +!endif + +# --------------------------------------------------------------------------- +# MAKE SECTION +# --------------------------------------------------------------------------- +# This section of the project file is not used by the BCB IDE. It is for +# the benefit of building from the command-line using the MAKE utility. +# --------------------------------------------------------------------------- + +.autodepend +# --------------------------------------------------------------------------- +!if !$d(BCC32) +BCC32 = bcc32 +!endif + +!if !$d(CPP32) +CPP32 = cpp32 +!endif + +!if !$d(DCC32) +DCC32 = dcc32 +!endif + +!if !$d(TASM32) +TASM32 = tasm32 +!endif + +!if !$d(LINKER) +LINKER = ilink32 +!endif + +!if !$d(BRCC32) +BRCC32 = brcc32 +!endif + +# --------------------------------------------------------------------------- +!if $d(PATHCPP) +.PATH.CPP = $(PATHCPP) +.PATH.C = $(PATHCPP) +!endif + +!if $d(PATHPAS) +.PATH.PAS = $(PATHPAS) +!endif + +!if $d(PATHASM) +.PATH.ASM = $(PATHASM) +!endif + +!if $d(PATHRC) +.PATH.RC = $(PATHRC) +!endif +# --------------------------------------------------------------------------- +$(PROJECT): $(OBJFILES) $(RESDEPEN) $(DEFFILE) + $(BCB)\BIN\$(LINKER) @&&! + $(LFLAGS) + + $(ALLOBJ), + + $(PROJECT),, + + $(ALLLIB), + + $(DEFFILE), + + $(ALLRES) +! +# --------------------------------------------------------------------------- +.pas.hpp: + $(BCB)\BIN\$(DCC32) $(PFLAGS) {$< } + +.pas.obj: + $(BCB)\BIN\$(DCC32) $(PFLAGS) {$< } + +.cpp.obj: + $(BCB)\BIN\$(BCC32) $(CFLAG1) -n$(@D) {$< } + +.c.obj: + $(BCB)\BIN\$(BCC32) $(CFLAG1) -n$(@D) {$< } + +.c.i: + $(BCB)\BIN\$(CPP32) $(CFLAG1) -n. {$< } + +.cpp.i: + $(BCB)\BIN\$(CPP32) $(CFLAG1) -n. {$< } + +.asm.obj: + $(BCB)\BIN\$(TASM32) $(AFLAGS) $<, $@ + +.rc.res: + $(BCB)\BIN\$(BRCC32) $(RFLAGS) -fo$@ $< +# --------------------------------------------------------------------------- + diff --git a/internal/2.2.2/1/Packages/tb2k_cb4.cpp b/internal/2.2.2/1/Packages/tb2k_cb4.cpp new file mode 100644 index 0000000..65d5caa --- /dev/null +++ b/internal/2.2.2/1/Packages/tb2k_cb4.cpp @@ -0,0 +1,29 @@ +// $jrsoftware: tb2k/Packages/tb2k_cb4.cpp,v 1.9 2003/07/04 22:53:21 jr Exp $ +//--------------------------------------------------------------------------- +#include +#pragma hdrstop +USEPACKAGE("vcl40.bpi"); +USEUNIT("..\Source\TB2Common.pas"); +USEUNIT("..\Source\TB2Consts.pas"); +USEUNIT("..\Source\TB2Dock.pas"); +USEUNIT("..\Source\TB2ExtItems.pas"); +USEUNIT("..\Source\TB2Item.pas"); +USEUNIT("..\Source\TB2Toolbar.pas"); +USEUNIT("..\Source\TB2Version.pas"); +USEUNIT("..\Source\TB2Hook.pas"); +USEUNIT("..\Source\TB2ToolWindow.pas"); +USEUNIT("..\Source\TB2MRU.pas"); +USEUNIT("..\Source\TB2Anim.pas"); +USEUNIT("..\Source\TB2MDI.pas"); +USEUNIT("..\Source\TB2Acc.pas"); +//--------------------------------------------------------------------------- +#pragma package(smart_init) +//--------------------------------------------------------------------------- +// Package source. +//--------------------------------------------------------------------------- +int WINAPI DllEntryPoint(HINSTANCE hinst, unsigned long reason, void*) +{ + return 1; +} +//--------------------------------------------------------------------------- + diff --git a/internal/2.2.2/1/Packages/tb2k_cb5.bpk b/internal/2.2.2/1/Packages/tb2k_cb5.bpk new file mode 100644 index 0000000..21efbe7 --- /dev/null +++ b/internal/2.2.2/1/Packages/tb2k_cb5.bpk @@ -0,0 +1,96 @@ + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + +[Version Info] +IncludeVerInfo=0 +AutoIncBuild=0 +MajorVer=1 +MinorVer=0 +Release=0 +Build=0 +Debug=0 +PreRelease=0 +Special=0 +Private=0 +DLL=0 +Locale=1033 +CodePage=1252 + +[Version Info Keys] +CompanyName= +FileDescription= +FileVersion=1.0.0.0 +InternalName= +LegalCopyright= +LegalTrademarks= +OriginalFilename= +ProductName= +ProductVersion=1.0.0.0 +Comments= + +[Debugging] +DebugSourceDirs=$(BCB)\source\vcl + +[Parameters] +RunParams= +HostApplication= +RemoteHost= +RemotePath= +RemoteDebug=0 + +[Compiler] +ShowInfoMsgs=0 +LinkDebugVcl=0 +LinkCGLIB=0 + +[Language] +ActiveLang= +ProjectLang= +RootDir= + + \ No newline at end of file diff --git a/internal/2.2.2/1/Packages/tb2k_cb5.cpp b/internal/2.2.2/1/Packages/tb2k_cb5.cpp new file mode 100644 index 0000000..33d2c2b --- /dev/null +++ b/internal/2.2.2/1/Packages/tb2k_cb5.cpp @@ -0,0 +1,29 @@ +// $jrsoftware: tb2k/Packages/tb2k_cb5.cpp,v 1.9 2003/07/04 22:53:21 jr Exp $ +//--------------------------------------------------------------------------- +#include +#pragma hdrstop +USEPACKAGE("vcl50.bpi"); +USEUNIT("..\Source\TB2Common.pas"); +USEUNIT("..\Source\TB2Consts.pas"); +USEUNIT("..\Source\TB2Dock.pas"); +USEUNIT("..\Source\TB2ExtItems.pas"); +USEUNIT("..\Source\TB2Item.pas"); +USEUNIT("..\Source\TB2Toolbar.pas"); +USEUNIT("..\Source\TB2Version.pas"); +USEUNIT("..\Source\TB2Hook.pas"); +USEUNIT("..\Source\TB2ToolWindow.pas"); +USEUNIT("..\Source\TB2MRU.pas"); +USEUNIT("..\Source\TB2Anim.pas"); +USEUNIT("..\Source\TB2MDI.pas"); +USEUNIT("..\Source\TB2Acc.pas"); +//--------------------------------------------------------------------------- +#pragma package(smart_init) +//--------------------------------------------------------------------------- +// Package source. +//--------------------------------------------------------------------------- +int WINAPI DllEntryPoint(HINSTANCE hinst, unsigned long reason, void*) +{ + return 1; +} +//--------------------------------------------------------------------------- + diff --git a/internal/2.2.2/1/Packages/tb2k_cb6.bpk b/internal/2.2.2/1/Packages/tb2k_cb6.bpk new file mode 100644 index 0000000..580309c --- /dev/null +++ b/internal/2.2.2/1/Packages/tb2k_cb6.bpk @@ -0,0 +1,130 @@ + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + +[Version Info] +IncludeVerInfo=0 +AutoIncBuild=0 +MajorVer=1 +MinorVer=0 +Release=0 +Build=0 +Debug=0 +PreRelease=0 +Special=0 +Private=0 +DLL=0 +Locale=1033 +CodePage=1252 + +[Version Info Keys] +CompanyName= +FileDescription= +FileVersion=1.0.0.0 +InternalName= +LegalCopyright= +LegalTrademarks= +OriginalFilename= +ProductName= +ProductVersion=1.0.0.0 +Comments= + +[Debugging] +DebugSourceDirs=$(BCB)\source\vcl + +[Parameters] +RunParams= +Launcher= +UseLauncher=0 +DebugCWD= +HostApplication= +RemoteHost= +RemotePath= +RemoteLauncher= +RemoteCWD= +RemoteDebug=0 + +[Compiler] +ShowInfoMsgs=0 +LinkDebugVcl=0 +LinkCGLIB=0 + +[Language] +ActiveLang= +ProjectLang= +RootDir= + +[Linker] +LibPrefix= +LibSuffix= +LibVersion= + + \ No newline at end of file diff --git a/internal/2.2.2/1/Packages/tb2k_cb6.cpp b/internal/2.2.2/1/Packages/tb2k_cb6.cpp new file mode 100644 index 0000000..79fe10f --- /dev/null +++ b/internal/2.2.2/1/Packages/tb2k_cb6.cpp @@ -0,0 +1,14 @@ +// $jrsoftware: tb2k/Packages/tb2k_cb6.cpp,v 1.2 2002/11/14 18:07:19 jr Exp $ +//--------------------------------------------------------------------------- +#include +#pragma hdrstop +#pragma package(smart_init) +//--------------------------------------------------------------------------- +// Package source. +//--------------------------------------------------------------------------- +int WINAPI DllEntryPoint(HINSTANCE hinst, unsigned long reason, void*) +{ + return 1; +} +//--------------------------------------------------------------------------- + diff --git a/internal/2.2.2/1/Packages/tb2k_d10.bdsproj b/internal/2.2.2/1/Packages/tb2k_d10.bdsproj new file mode 100644 index 0000000..5915d11 --- /dev/null +++ b/internal/2.2.2/1/Packages/tb2k_d10.bdsproj @@ -0,0 +1,175 @@ + + + + + + + + + + + + tb2k_d10.dpk + + + 7.0 + + + 8 + 0 + 1 + 1 + 0 + 0 + 1 + 1 + 1 + 0 + 0 + 1 + 0 + 1 + 1 + 1 + 0 + 0 + 0 + 0 + 0 + 1 + 0 + 1 + 1 + 1 + True + True + WinTypes=Windows;WinProcs=Windows;DbiTypes=BDE;DbiProcs=BDE;DbiErrs=BDE; + + False + + True + True + True + True + True + True + True + True + True + True + True + True + True + True + True + True + True + True + True + True + True + True + True + True + True + True + True + True + True + True + True + True + True + True + True + True + True + True + True + True + True + True + True + True + True + True + False + False + False + True + True + True + True + True + True + + + + 0 + 44 + False + 1 + False + False + False + 16384 + 1048576 + 1069547520 + Toolbar2000 Components (Jordan Russell) + + + + ..\Lib\D10 + + + + + + + False + + + + + + False + + + True + False + + + + $00000000 + + + + False + False + 1 + 0 + 0 + 0 + False + False + False + False + False + 1033 + 1252 + + + + + 1.0.0.0 + + + + + + 1.0.0.0 + + + + diff --git a/internal/2.2.2/1/Packages/tb2k_d10.dpk b/internal/2.2.2/1/Packages/tb2k_d10.dpk new file mode 100644 index 0000000..450237d --- /dev/null +++ b/internal/2.2.2/1/Packages/tb2k_d10.dpk @@ -0,0 +1,48 @@ +package tb2k_d10; + +{$R *.res} +{$ALIGN 8} +{$ASSERTIONS ON} +{$BOOLEVAL OFF} +{$DEBUGINFO ON} +{$EXTENDEDSYNTAX ON} +{$IMPORTEDDATA ON} +{$IOCHECKS ON} +{$LOCALSYMBOLS ON} +{$LONGSTRINGS ON} +{$OPENSTRINGS ON} +{$OPTIMIZATION ON} +{$OVERFLOWCHECKS OFF} +{$RANGECHECKS OFF} +{$REFERENCEINFO ON} +{$SAFEDIVIDE OFF} +{$STACKFRAMES OFF} +{$TYPEDADDRESS OFF} +{$VARSTRINGCHECKS ON} +{$WRITEABLECONST OFF} +{$MINENUMSIZE 1} +{$IMAGEBASE $3FC00000} +{$DESCRIPTION 'Toolbar2000 Components (Jordan Russell)'} +{$RUNONLY} +{$IMPLICITBUILD OFF} + +requires + vcl; + +contains + TB2Version in '..\Source\TB2Version.pas', + TB2Toolbar in '..\Source\TB2Toolbar.pas', + TB2Consts in '..\Source\TB2Consts.pas', + TB2Dock in '..\Source\TB2Dock.pas', + TB2ExtItems in '..\Source\TB2ExtItems.pas', + TB2Item in '..\Source\TB2Item.pas', + TB2Common in '..\Source\TB2Common.pas', + TB2Hook in '..\Source\TB2Hook.pas', + TB2ToolWindow in '..\Source\TB2ToolWindow.pas', + TB2MRU in '..\Source\TB2MRU.pas', + TB2Anim in '..\Source\TB2Anim.pas', + TB2MDI in '..\Source\TB2MDI.pas', + TB2Acc in '..\Source\TB2Acc.pas'; + +end. + diff --git a/internal/2.2.2/1/Packages/tb2k_d10.res b/internal/2.2.2/1/Packages/tb2k_d10.res new file mode 100644 index 0000000..36f26e2 Binary files /dev/null and b/internal/2.2.2/1/Packages/tb2k_d10.res differ diff --git a/internal/2.2.2/1/Packages/tb2k_d11.dpk b/internal/2.2.2/1/Packages/tb2k_d11.dpk new file mode 100644 index 0000000..61686e3 --- /dev/null +++ b/internal/2.2.2/1/Packages/tb2k_d11.dpk @@ -0,0 +1,49 @@ +package tb2k_d11; + +{$R *.res} +{$ALIGN 8} +{$ASSERTIONS ON} +{$BOOLEVAL OFF} +{$DEBUGINFO OFF} +{$EXTENDEDSYNTAX ON} +{$IMPORTEDDATA ON} +{$IOCHECKS ON} +{$LOCALSYMBOLS OFF} +{$LONGSTRINGS ON} +{$OPENSTRINGS ON} +{$OPTIMIZATION ON} +{$OVERFLOWCHECKS OFF} +{$RANGECHECKS OFF} +{$REFERENCEINFO OFF} +{$SAFEDIVIDE OFF} +{$STACKFRAMES OFF} +{$TYPEDADDRESS OFF} +{$VARSTRINGCHECKS ON} +{$WRITEABLECONST OFF} +{$MINENUMSIZE 1} +{$IMAGEBASE $400000} +{$DESCRIPTION 'Toolbar2000 Components (Jordan Russell)'} +{$RUNONLY} +{$IMPLICITBUILD OFF} +{$DEFINE RELEASE} + +requires + rtl, + vcl; + +contains + TB2Version in '..\Source\TB2Version.pas', + TB2Toolbar in '..\Source\TB2Toolbar.pas', + TB2Consts in '..\Source\TB2Consts.pas', + TB2Dock in '..\Source\TB2Dock.pas', + TB2ExtItems in '..\Source\TB2ExtItems.pas', + TB2Item in '..\Source\TB2Item.pas', + TB2Common in '..\Source\TB2Common.pas', + TB2Hook in '..\Source\TB2Hook.pas', + TB2ToolWindow in '..\Source\TB2ToolWindow.pas', + TB2MRU in '..\Source\TB2MRU.pas', + TB2Anim in '..\Source\TB2Anim.pas', + TB2MDI in '..\Source\TB2MDI.pas', + TB2Acc in '..\Source\TB2Acc.pas'; + +end. diff --git a/internal/2.2.2/1/Packages/tb2k_d11.dproj b/internal/2.2.2/1/Packages/tb2k_d11.dproj new file mode 100644 index 0000000..203c448 --- /dev/null +++ b/internal/2.2.2/1/Packages/tb2k_d11.dproj @@ -0,0 +1,545 @@ + + + + {42085cda-8f18-4859-a681-a3109ff5e295} + tb2k_d11.dpk + Release + AnyCPU + DCC32 + ..\Lib\D11\tb2k_d11.bpl + + + 7.0 + False + False + 0 + RELEASE + ..\Lib\D11 + ..\Lib\D11 + ..\Lib\D11 + ..\Lib\D11 + ..\Lib\D11 + ..\Lib\D11 + + + 7.0 + DEBUG + All + ..\Lib\D11 + ..\Lib\D11 + ..\Lib\D11 + ..\Lib\D11 + ..\Lib\D11 + ..\Lib\D11 + + + Delphi.Personality + Package + +FalseTrueFalseFalseFalseTrueToolbar2000 Components (Jordan Russell)TrueFalse1000FalseFalseFalseFalseFalse103312521.0.0.01.0.0.0tb2k_d11.dpk + + + + + MainSource + + + + + + + + + + + + + + + + + + + diff --git a/internal/2.2.2/1/Packages/tb2k_d11.res b/internal/2.2.2/1/Packages/tb2k_d11.res new file mode 100644 index 0000000..1bf5a8c Binary files /dev/null and b/internal/2.2.2/1/Packages/tb2k_d11.res differ diff --git a/internal/2.2.2/1/Packages/tb2k_d12.dpk b/internal/2.2.2/1/Packages/tb2k_d12.dpk new file mode 100644 index 0000000..41f57e6 --- /dev/null +++ b/internal/2.2.2/1/Packages/tb2k_d12.dpk @@ -0,0 +1,48 @@ +package tb2k_d12; + +{$R *.res} +{$ALIGN 8} +{$ASSERTIONS ON} +{$BOOLEVAL OFF} +{$DEBUGINFO ON} +{$EXTENDEDSYNTAX ON} +{$IMPORTEDDATA ON} +{$IOCHECKS ON} +{$LOCALSYMBOLS ON} +{$LONGSTRINGS ON} +{$OPENSTRINGS ON} +{$OPTIMIZATION ON} +{$OVERFLOWCHECKS OFF} +{$RANGECHECKS OFF} +{$REFERENCEINFO ON} +{$SAFEDIVIDE OFF} +{$STACKFRAMES OFF} +{$TYPEDADDRESS OFF} +{$VARSTRINGCHECKS ON} +{$WRITEABLECONST OFF} +{$MINENUMSIZE 1} +{$IMAGEBASE $3FC00000} +{$DESCRIPTION 'Toolbar2000 Components (Jordan Russell)'} +{$RUNONLY} +{$IMPLICITBUILD OFF} + +requires + rtl, + vcl; + +contains + TB2Version in '..\Source\TB2Version.pas', + TB2Toolbar in '..\Source\TB2Toolbar.pas', + TB2Consts in '..\Source\TB2Consts.pas', + TB2Dock in '..\Source\TB2Dock.pas', + TB2ExtItems in '..\Source\TB2ExtItems.pas', + TB2Item in '..\Source\TB2Item.pas', + TB2Common in '..\Source\TB2Common.pas', + TB2Hook in '..\Source\TB2Hook.pas', + TB2ToolWindow in '..\Source\TB2ToolWindow.pas', + TB2MRU in '..\Source\TB2MRU.pas', + TB2Anim in '..\Source\TB2Anim.pas', + TB2MDI in '..\Source\TB2MDI.pas', + TB2Acc in '..\Source\TB2Acc.pas'; + +end. diff --git a/internal/2.2.2/1/Packages/tb2k_d12.dproj b/internal/2.2.2/1/Packages/tb2k_d12.dproj new file mode 100644 index 0000000..4fe3f4c --- /dev/null +++ b/internal/2.2.2/1/Packages/tb2k_d12.dproj @@ -0,0 +1,130 @@ + + + {1EA50D74-2EC7-4FC2-AA38-747CD0E9BCCA} + tb2k_d12.dpk + 12.0 + Debug + DCC32 + + + true + + + true + Base + true + + + true + Base + true + + + true + false + ..\Lib\D12 + ..\Lib\D12 + ..\Lib\D12 + ..\Lib\D12 + true + All + Toolbar2000 Components (Jordan Russell) + 3FC00000 + 1 + true + WinTypes=Windows;WinProcs=Windows;DbiTypes=BDE;DbiProcs=BDE;DbiErrs=BDE;$(DCC_UnitAlias) + x86 + tb2k_d12.bpl + false + false + true + false + false + false + + + false + RELEASE;$(DCC_Define) + 0 + false + + + DEBUG;$(DCC_Define) + + + + MainSource + + + + + + + + + + + + + + + + + + Base + + + Cfg_2 + Base + + + Cfg_1 + Base + + + + + Delphi.Personality.12 + Package + + + + tb2k_d12.dpk + + + False + True + False + + + False + False + 1 + 0 + 0 + 0 + False + False + False + False + False + 1033 + 1252 + + + + + 1.0.0.0 + + + + + + 1.0.0.0 + + + + + 12 + + diff --git a/internal/2.2.2/1/Packages/tb2k_d12.res b/internal/2.2.2/1/Packages/tb2k_d12.res new file mode 100644 index 0000000..36f26e2 Binary files /dev/null and b/internal/2.2.2/1/Packages/tb2k_d12.res differ diff --git a/internal/2.2.2/1/Packages/tb2k_d4.dpk b/internal/2.2.2/1/Packages/tb2k_d4.dpk new file mode 100644 index 0000000..c4b03d9 --- /dev/null +++ b/internal/2.2.2/1/Packages/tb2k_d4.dpk @@ -0,0 +1,47 @@ +package tb2k_d4; + +{$R *.RES} +{$ALIGN ON} +{$ASSERTIONS ON} +{$BOOLEVAL OFF} +{$DEBUGINFO ON} +{$EXTENDEDSYNTAX ON} +{$IMPORTEDDATA ON} +{$IOCHECKS ON} +{$LOCALSYMBOLS ON} +{$LONGSTRINGS ON} +{$OPENSTRINGS ON} +{$OPTIMIZATION ON} +{$OVERFLOWCHECKS OFF} +{$RANGECHECKS OFF} +{$REFERENCEINFO ON} +{$SAFEDIVIDE OFF} +{$STACKFRAMES OFF} +{$TYPEDADDRESS OFF} +{$VARSTRINGCHECKS ON} +{$WRITEABLECONST OFF} +{$MINENUMSIZE 1} +{$IMAGEBASE $3FC00000} +{$DESCRIPTION 'Toolbar2000 Components (Jordan Russell)'} +{$IMPLICITBUILD ON} + +requires + vcl40; + +contains + TB2Version in '..\Source\TB2Version.pas', + TB2Toolbar in '..\Source\TB2Toolbar.pas', + TB2Consts in '..\Source\TB2Consts.pas', + TB2Dock in '..\Source\TB2Dock.pas', + TB2ExtItems in '..\Source\TB2ExtItems.pas', + TB2Item in '..\Source\TB2Item.pas', + TB2Common in '..\Source\TB2Common.pas', + TB2Hook in '..\Source\TB2Hook.pas', + TB2ToolWindow in '..\Source\TB2ToolWindow.pas', + TB2MRU in '..\Source\TB2MRU.pas', + TB2Anim in '..\Source\TB2Anim.pas', + TB2MDI in '..\Source\TB2MDI.pas', + TB2Acc in '..\Source\TB2Acc.pas'; + +end. + diff --git a/internal/2.2.2/1/Packages/tb2k_d4.res b/internal/2.2.2/1/Packages/tb2k_d4.res new file mode 100644 index 0000000..36f26e2 Binary files /dev/null and b/internal/2.2.2/1/Packages/tb2k_d4.res differ diff --git a/internal/2.2.2/1/Packages/tb2k_d5.dpk b/internal/2.2.2/1/Packages/tb2k_d5.dpk new file mode 100644 index 0000000..28e5be4 --- /dev/null +++ b/internal/2.2.2/1/Packages/tb2k_d5.dpk @@ -0,0 +1,48 @@ +package tb2k_d5; + +{$R *.RES} +{$ALIGN ON} +{$ASSERTIONS ON} +{$BOOLEVAL OFF} +{$DEBUGINFO ON} +{$EXTENDEDSYNTAX ON} +{$IMPORTEDDATA ON} +{$IOCHECKS ON} +{$LOCALSYMBOLS ON} +{$LONGSTRINGS ON} +{$OPENSTRINGS ON} +{$OPTIMIZATION ON} +{$OVERFLOWCHECKS OFF} +{$RANGECHECKS OFF} +{$REFERENCEINFO ON} +{$SAFEDIVIDE OFF} +{$STACKFRAMES OFF} +{$TYPEDADDRESS OFF} +{$VARSTRINGCHECKS ON} +{$WRITEABLECONST OFF} +{$MINENUMSIZE 1} +{$IMAGEBASE $3FC00000} +{$DESCRIPTION 'Toolbar2000 Components (Jordan Russell)'} +{$RUNONLY} +{$IMPLICITBUILD ON} + +requires + vcl50; + +contains + TB2Version in '..\Source\TB2Version.pas', + TB2Toolbar in '..\Source\TB2Toolbar.pas', + TB2Consts in '..\Source\TB2Consts.pas', + TB2Dock in '..\Source\TB2Dock.pas', + TB2ExtItems in '..\Source\TB2ExtItems.pas', + TB2Item in '..\Source\TB2Item.pas', + TB2Common in '..\Source\TB2Common.pas', + TB2Hook in '..\Source\TB2Hook.pas', + TB2ToolWindow in '..\Source\TB2ToolWindow.pas', + TB2MRU in '..\Source\TB2MRU.pas', + TB2Anim in '..\Source\TB2Anim.pas', + TB2MDI in '..\Source\TB2MDI.pas', + TB2Acc in '..\Source\TB2Acc.pas'; + +end. + diff --git a/internal/2.2.2/1/Packages/tb2k_d5.res b/internal/2.2.2/1/Packages/tb2k_d5.res new file mode 100644 index 0000000..36f26e2 Binary files /dev/null and b/internal/2.2.2/1/Packages/tb2k_d5.res differ diff --git a/internal/2.2.2/1/Packages/tb2k_d6.dpk b/internal/2.2.2/1/Packages/tb2k_d6.dpk new file mode 100644 index 0000000..ea37a26 --- /dev/null +++ b/internal/2.2.2/1/Packages/tb2k_d6.dpk @@ -0,0 +1,48 @@ +package tb2k_d6; + +{$R *.res} +{$ALIGN 8} +{$ASSERTIONS ON} +{$BOOLEVAL OFF} +{$DEBUGINFO ON} +{$EXTENDEDSYNTAX ON} +{$IMPORTEDDATA ON} +{$IOCHECKS ON} +{$LOCALSYMBOLS ON} +{$LONGSTRINGS ON} +{$OPENSTRINGS ON} +{$OPTIMIZATION ON} +{$OVERFLOWCHECKS OFF} +{$RANGECHECKS OFF} +{$REFERENCEINFO ON} +{$SAFEDIVIDE OFF} +{$STACKFRAMES OFF} +{$TYPEDADDRESS OFF} +{$VARSTRINGCHECKS ON} +{$WRITEABLECONST OFF} +{$MINENUMSIZE 1} +{$IMAGEBASE $3FC00000} +{$DESCRIPTION 'Toolbar2000 Components (Jordan Russell)'} +{$RUNONLY} +{$IMPLICITBUILD ON} + +requires + vcl; + +contains + TB2Version in '..\Source\TB2Version.pas', + TB2Toolbar in '..\Source\TB2Toolbar.pas', + TB2Consts in '..\Source\TB2Consts.pas', + TB2Dock in '..\Source\TB2Dock.pas', + TB2ExtItems in '..\Source\TB2ExtItems.pas', + TB2Item in '..\Source\TB2Item.pas', + TB2Common in '..\Source\TB2Common.pas', + TB2Hook in '..\Source\TB2Hook.pas', + TB2ToolWindow in '..\Source\TB2ToolWindow.pas', + TB2MRU in '..\Source\TB2MRU.pas', + TB2Anim in '..\Source\TB2Anim.pas', + TB2MDI in '..\Source\TB2MDI.pas', + TB2Acc in '..\Source\TB2Acc.pas'; + +end. + diff --git a/internal/2.2.2/1/Packages/tb2k_d6.res b/internal/2.2.2/1/Packages/tb2k_d6.res new file mode 100644 index 0000000..36f26e2 Binary files /dev/null and b/internal/2.2.2/1/Packages/tb2k_d6.res differ diff --git a/internal/2.2.2/1/Packages/tb2k_d7.dpk b/internal/2.2.2/1/Packages/tb2k_d7.dpk new file mode 100644 index 0000000..bc6fb9c --- /dev/null +++ b/internal/2.2.2/1/Packages/tb2k_d7.dpk @@ -0,0 +1,48 @@ +package tb2k_d7; + +{$R *.res} +{$ALIGN 8} +{$ASSERTIONS ON} +{$BOOLEVAL OFF} +{$DEBUGINFO ON} +{$EXTENDEDSYNTAX ON} +{$IMPORTEDDATA ON} +{$IOCHECKS ON} +{$LOCALSYMBOLS ON} +{$LONGSTRINGS ON} +{$OPENSTRINGS ON} +{$OPTIMIZATION ON} +{$OVERFLOWCHECKS OFF} +{$RANGECHECKS OFF} +{$REFERENCEINFO ON} +{$SAFEDIVIDE OFF} +{$STACKFRAMES OFF} +{$TYPEDADDRESS OFF} +{$VARSTRINGCHECKS ON} +{$WRITEABLECONST OFF} +{$MINENUMSIZE 1} +{$IMAGEBASE $3FC00000} +{$DESCRIPTION 'Toolbar2000 Components (Jordan Russell)'} +{$RUNONLY} +{$IMPLICITBUILD ON} + +requires + vcl; + +contains + TB2Version in '..\Source\TB2Version.pas', + TB2Toolbar in '..\Source\TB2Toolbar.pas', + TB2Consts in '..\Source\TB2Consts.pas', + TB2Dock in '..\Source\TB2Dock.pas', + TB2ExtItems in '..\Source\TB2ExtItems.pas', + TB2Item in '..\Source\TB2Item.pas', + TB2Common in '..\Source\TB2Common.pas', + TB2Hook in '..\Source\TB2Hook.pas', + TB2ToolWindow in '..\Source\TB2ToolWindow.pas', + TB2MRU in '..\Source\TB2MRU.pas', + TB2Anim in '..\Source\TB2Anim.pas', + TB2MDI in '..\Source\TB2MDI.pas', + TB2Acc in '..\Source\TB2Acc.pas'; + +end. + diff --git a/internal/2.2.2/1/Packages/tb2k_d7.res b/internal/2.2.2/1/Packages/tb2k_d7.res new file mode 100644 index 0000000..36f26e2 Binary files /dev/null and b/internal/2.2.2/1/Packages/tb2k_d7.res differ diff --git a/internal/2.2.2/1/Packages/tb2k_d9.dpk b/internal/2.2.2/1/Packages/tb2k_d9.dpk new file mode 100644 index 0000000..56949e2 --- /dev/null +++ b/internal/2.2.2/1/Packages/tb2k_d9.dpk @@ -0,0 +1,48 @@ +package tb2k_d9; + +{$R *.res} +{$ALIGN 8} +{$ASSERTIONS ON} +{$BOOLEVAL OFF} +{$DEBUGINFO ON} +{$EXTENDEDSYNTAX ON} +{$IMPORTEDDATA ON} +{$IOCHECKS ON} +{$LOCALSYMBOLS ON} +{$LONGSTRINGS ON} +{$OPENSTRINGS ON} +{$OPTIMIZATION ON} +{$OVERFLOWCHECKS OFF} +{$RANGECHECKS OFF} +{$REFERENCEINFO ON} +{$SAFEDIVIDE OFF} +{$STACKFRAMES OFF} +{$TYPEDADDRESS OFF} +{$VARSTRINGCHECKS ON} +{$WRITEABLECONST OFF} +{$MINENUMSIZE 1} +{$IMAGEBASE $3FC00000} +{$DESCRIPTION 'Toolbar2000 Components (Jordan Russell)'} +{$RUNONLY} +{$IMPLICITBUILD ON} + +requires + vcl; + +contains + TB2Version in '..\Source\TB2Version.pas', + TB2Toolbar in '..\Source\TB2Toolbar.pas', + TB2Consts in '..\Source\TB2Consts.pas', + TB2Dock in '..\Source\TB2Dock.pas', + TB2ExtItems in '..\Source\TB2ExtItems.pas', + TB2Item in '..\Source\TB2Item.pas', + TB2Common in '..\Source\TB2Common.pas', + TB2Hook in '..\Source\TB2Hook.pas', + TB2ToolWindow in '..\Source\TB2ToolWindow.pas', + TB2MRU in '..\Source\TB2MRU.pas', + TB2Anim in '..\Source\TB2Anim.pas', + TB2MDI in '..\Source\TB2MDI.pas', + TB2Acc in '..\Source\TB2Acc.pas'; + +end. + diff --git a/internal/2.2.2/1/Packages/tb2k_d9.res b/internal/2.2.2/1/Packages/tb2k_d9.res new file mode 100644 index 0000000..36f26e2 Binary files /dev/null and b/internal/2.2.2/1/Packages/tb2k_d9.res differ diff --git a/internal/2.2.2/1/Packages/tb2k_dn10.bdsproj b/internal/2.2.2/1/Packages/tb2k_dn10.bdsproj new file mode 100644 index 0000000..89d1181 --- /dev/null +++ b/internal/2.2.2/1/Packages/tb2k_dn10.bdsproj @@ -0,0 +1,197 @@ + + + + + + + + + + + + tb2k_dn10.dpk + + + 7.0 + + + 0 + 0 + 1 + 1 + 0 + 0 + 1 + 1 + 1 + 0 + 0 + 1 + 0 + 1 + 1 + 1 + 0 + 0 + 0 + 0 + 0 + 1 + 0 + 1 + 1 + 1 + True + True + WinTypes=Borland.Vcl.Windows;WinProcs=Borland.Vcl.Windows;DbiTypes=BDE;DbiProcs=BDE;DbiErrs=BDE; + + False + + True + True + True + True + True + False + True + True + True + True + True + True + True + True + True + True + True + True + True + True + True + True + True + True + True + True + True + True + True + True + True + True + True + True + True + True + True + True + True + True + True + True + True + True + True + True + True + True + True + True + True + True + True + True + True + + + + 0 + 0 + False + 1 + True + False + False + 4096 + 1048576 + 1061158912 + Toolbar2000 .NET Components (Jordan Russell) + + + + ..\Lib\DN10 + $(BDSPROJECTSDIR)\Bpl + $(BDSPROJECTSDIR)\Bpl + + + + + False + + + + + + False + + + True + False + + + + $00000000 + + + + True + False + 1 + 0 + 0 + 0 + False + False + False + False + False + 1033 + 1252 + + + + + 1.0.0.0 + + + + + + 1.0.0.0 + + + + + + + + + + + + + + + + + + + + + + + + + + diff --git a/internal/2.2.2/1/Packages/tb2k_dn10.dpk b/internal/2.2.2/1/Packages/tb2k_dn10.dpk new file mode 100644 index 0000000..001eaf6 --- /dev/null +++ b/internal/2.2.2/1/Packages/tb2k_dn10.dpk @@ -0,0 +1,120 @@ +package tb2k_dn10; + +{$ALIGN 0} +{$ASSERTIONS ON} +{$BOOLEVAL OFF} +{$DEBUGINFO ON} +{$EXTENDEDSYNTAX ON} +{$IMPORTEDDATA ON} +{$IOCHECKS ON} +{$LOCALSYMBOLS ON} +{$LONGSTRINGS ON} +{$OPENSTRINGS ON} +{$OPTIMIZATION ON} +{$OVERFLOWCHECKS OFF} +{$RANGECHECKS OFF} +{$REFERENCEINFO ON} +{$SAFEDIVIDE OFF} +{$STACKFRAMES OFF} +{$TYPEDADDRESS OFF} +{$VARSTRINGCHECKS ON} +{$WRITEABLECONST OFF} +{$MINENUMSIZE 1} +{$IMAGEBASE $3F400000} +{$DESCRIPTION 'Toolbar2000 .NET Components (Jordan Russell)'} +{$RUNONLY} +{$IMPLICITBUILD OFF} + +requires + System.Drawing, + Borland.Delphi, + Borland.Vcl, + Borland.VclRtl; + +contains + TB2Version in '..\Source\TB2Version.pas', + TB2Toolbar in '..\Source\TB2Toolbar.pas', + TB2Consts in '..\Source\TB2Consts.pas', + TB2Dock in '..\Source\TB2Dock.pas', + TB2ExtItems in '..\Source\TB2ExtItems.pas', + TB2Item in '..\Source\TB2Item.pas', + TB2Common in '..\Source\TB2Common.pas', + TB2Hook in '..\Source\TB2Hook.pas', + TB2ToolWindow in '..\Source\TB2ToolWindow.pas', + TB2MRU in '..\Source\TB2MRU.pas', + TB2Anim in '..\Source\TB2Anim.pas', + TB2MDI in '..\Source\TB2MDI.pas', + TB2Acc in '..\Source\TB2Acc.pas', + TB2OleMarshal in '..\Source\TB2OleMarshal.pas'; + +[assembly: AssemblyDescription('')] +[assembly: AssemblyConfiguration('')] +[assembly: AssemblyCompany('')] +[assembly: AssemblyProduct('')] +[assembly: AssemblyCopyright('')] +[assembly: AssemblyTrademark('')] +[assembly: AssemblyCulture('')] + + +// The Delphi compiler controls the AssemblyTitleAttribute via the ExeDescription. +// You can set this in the IDE via the Project Options. +// Manually setting the AssemblyTitle attribute below will override the IDE +// setting. +// [assembly: AssemblyTitle('')] + + +// +// Version information for an assembly consists of the following four values: +// +// Major Version +// Minor Version +// Build Number +// Revision +// +// You can specify all the values or you can default the Revision and Build Numbers +// by using the '*' as shown below: + +//[assembly: AssemblyVersion('1.0.*')] + +// +// In order to sign your assembly you must specify a key to use. Refer to the +// Microsoft .NET Framework documentation for more information on assembly signing. +// +// Use the attributes below to control which key is used for signing. +// +// Notes: +// (*) If no key is specified, the assembly is not signed. +// (*) KeyName refers to a key that has been installed in the Crypto Service +// Provider (CSP) on your machine. KeyFile refers to a file which contains +// a key. +// (*) If the KeyFile and the KeyName values are both specified, the +// following processing occurs: +// (1) If the KeyName can be found in the CSP, that key is used. +// (2) If the KeyName does not exist and the KeyFile does exist, the key +// in the KeyFile is installed into the CSP and used. +// (*) In order to create a KeyFile, you can use the sn.exe (Strong Name) utility. +// When specifying the KeyFile, the location of the KeyFile should be +// relative to the project output directory. For example, if your KeyFile is +// located in the project directory, you would specify the AssemblyKeyFile +// attribute as [assembly: AssemblyKeyFile('mykey.snk')], provided your output +// directory is the project directory (the default). +// (*) Delay Signing is an advanced option - see the Microsoft .NET Framework +// documentation for more information on this. +// +[assembly: AssemblyDelaySign(false)] +[assembly: AssemblyKeyFile('')] +[assembly: AssemblyKeyName('')] + +// +// Use the attributes below to control the COM visibility of your assembly. By +// default the entire assembly is visible to COM. Setting ComVisible to false +// is the recommended default for your assembly. To then expose a class and interface +// to COM set ComVisible to true on each one. It is also recommended to add a +// Guid attribute. +// + +[assembly: ComVisible(False)] +//[assembly: Guid('')] +//[assembly: TypeLibVersion(1, 0)] + +end. diff --git a/internal/2.2.2/1/Packages/tb2k_dn11.dpk b/internal/2.2.2/1/Packages/tb2k_dn11.dpk new file mode 100644 index 0000000..836af2d --- /dev/null +++ b/internal/2.2.2/1/Packages/tb2k_dn11.dpk @@ -0,0 +1,120 @@ +package tb2k_dn11; + +{$ALIGN 0} +{$ASSERTIONS ON} +{$BOOLEVAL OFF} +{$DEBUGINFO ON} +{$EXTENDEDSYNTAX ON} +{$IMPORTEDDATA ON} +{$IOCHECKS ON} +{$LOCALSYMBOLS ON} +{$LONGSTRINGS ON} +{$OPENSTRINGS ON} +{$OPTIMIZATION ON} +{$OVERFLOWCHECKS OFF} +{$RANGECHECKS OFF} +{$REFERENCEINFO ON} +{$SAFEDIVIDE OFF} +{$STACKFRAMES OFF} +{$TYPEDADDRESS OFF} +{$VARSTRINGCHECKS ON} +{$WRITEABLECONST OFF} +{$MINENUMSIZE 1} +{$IMAGEBASE $3F400000} +{$DESCRIPTION 'Toolbar2000 .NET Components (Jordan Russell)'} +{$RUNONLY} +{$IMPLICITBUILD OFF} +{$DEFINE DEBUG} + +requires + Borland.Delphi, + Borland.VclRtl, + Borland.Vcl; + +contains + TB2Version in '..\Source\TB2Version.pas', + TB2Toolbar in '..\Source\TB2Toolbar.pas', + TB2Consts in '..\Source\TB2Consts.pas', + TB2Dock in '..\Source\TB2Dock.pas', + TB2ExtItems in '..\Source\TB2ExtItems.pas', + TB2Item in '..\Source\TB2Item.pas', + TB2Common in '..\Source\TB2Common.pas', + TB2Hook in '..\Source\TB2Hook.pas', + TB2ToolWindow in '..\Source\TB2ToolWindow.pas', + TB2MRU in '..\Source\TB2MRU.pas', + TB2Anim in '..\Source\TB2Anim.pas', + TB2MDI in '..\Source\TB2MDI.pas', + TB2Acc in '..\Source\TB2Acc.pas', + TB2OleMarshal in '..\Source\TB2OleMarshal.pas'; + +[assembly: AssemblyDescription('')] +[assembly: AssemblyConfiguration('')] +[assembly: AssemblyCompany('')] +[assembly: AssemblyProduct('')] +[assembly: AssemblyCopyright('')] +[assembly: AssemblyTrademark('')] +[assembly: AssemblyCulture('')] + + +// The Delphi compiler controls the AssemblyTitleAttribute via the ExeDescription. +// You can set this in the IDE via the Project Options. +// Manually setting the AssemblyTitle attribute below will override the IDE +// setting. +// [assembly: AssemblyTitle('')] + + +// +// Version information for an assembly consists of the following four values: +// +// Major Version +// Minor Version +// Build Number +// Revision +// +// You can specify all the values or you can default the Revision and Build Numbers +// by using the '*' as shown below: + +//[assembly: AssemblyVersion('1.0.*')] + +// +// In order to sign your assembly you must specify a key to use. Refer to the +// Microsoft .NET Framework documentation for more information on assembly signing. +// +// Use the attributes below to control which key is used for signing. +// +// Notes: +// (*) If no key is specified, the assembly is not signed. +// (*) KeyName refers to a key that has been installed in the Crypto Service +// Provider (CSP) on your machine. KeyFile refers to a file which contains +// a key. +// (*) If the KeyFile and the KeyName values are both specified, the +// following processing occurs: +// (1) If the KeyName can be found in the CSP, that key is used. +// (2) If the KeyName does not exist and the KeyFile does exist, the key +// in the KeyFile is installed into the CSP and used. +// (*) In order to create a KeyFile, you can use the sn.exe (Strong Name) utility. +// When specifying the KeyFile, the location of the KeyFile should be +// relative to the project output directory. For example, if your KeyFile is +// located in the project directory, you would specify the AssemblyKeyFile +// attribute as [assembly: AssemblyKeyFile('mykey.snk')], provided your output +// directory is the project directory (the default). +// (*) Delay Signing is an advanced option - see the Microsoft .NET Framework +// documentation for more information on this. +// +[assembly: AssemblyDelaySign(false)] +[assembly: AssemblyKeyFile('')] +[assembly: AssemblyKeyName('')] + +// +// Use the attributes below to control the COM visibility of your assembly. By +// default the entire assembly is visible to COM. Setting ComVisible to false +// is the recommended default for your assembly. To then expose a class and interface +// to COM set ComVisible to true on each one. It is also recommended to add a +// Guid attribute. +// + +[assembly: ComVisible(False)] +//[assembly: Guid('')] +//[assembly: TypeLibVersion(1, 0)] + +end. diff --git a/internal/2.2.2/1/Packages/tb2k_dn11.dproj b/internal/2.2.2/1/Packages/tb2k_dn11.dproj new file mode 100644 index 0000000..e347261 --- /dev/null +++ b/internal/2.2.2/1/Packages/tb2k_dn11.dproj @@ -0,0 +1,82 @@ + + + {e64e9cd0-bdee-45e5-a97a-7e85f9f52092} + Debug + AnyCPU + DCCIL + tb2k_dn11.dll + tb2k_dn11.dpk + + + 7.0 + False + False + 0 + RELEASE + 3F400000 + False + ..\Lib\DN11 + ..\Lib\DN11 + ..\Lib\DN11 + + + 7.0 + True + True + DEBUG + 3F400000 + False + ..\Lib\DN11 + ..\Lib\DN11 + ..\Lib\DN11 + + + DelphiDotNet.Personality + + +FalseTrueFalseFalseFalseTrueToolbar2000 .NET Components (Jordan Russell)TrueFalse1000FalseFalseFalseFalseFalse103312521.0.0.01.0.0.0tb2k_dn11.dpk + + + + Borland.VclRtl + 11.0.5000.9245 + Borland.VclRtl.dll + Borland.VclRtl.dll + False + + + Borland.Vcl + 11.0.5000.9245 + Borland.Vcl.dll + Borland.Vcl.dll + False + + + Borland.Delphi + 11.0.5000.9245 + Borland.Delphi.dll + Borland.Delphi.dll + False + + + + + MainSource + + + + + + + + + + + + + + + + + + \ No newline at end of file diff --git a/internal/2.2.2/1/Packages/tb2kdsgn_cb4.bpk b/internal/2.2.2/1/Packages/tb2kdsgn_cb4.bpk new file mode 100644 index 0000000..e3fe08e --- /dev/null +++ b/internal/2.2.2/1/Packages/tb2kdsgn_cb4.bpk @@ -0,0 +1,181 @@ +# --------------------------------------------------------------------------- +!if !$d(BCB) +BCB = $(MAKEDIR)\.. +!endif + +# --------------------------------------------------------------------------- +# IDE SECTION +# --------------------------------------------------------------------------- +# The following section of the project makefile is managed by the BCB IDE. +# It is recommended to use the IDE to change any of the values in this +# section. +# --------------------------------------------------------------------------- + +VERSION = BCB.04.04 +# --------------------------------------------------------------------------- +PROJECT = tb2kdsgn_cb4.bpl +OBJFILES = ..\Source\TB2DsgnConverter.obj ..\Source\TB2DsgnItemEditor.obj \ + ..\Source\TB2DsgnConvertOptions.obj ..\Source\TB2Reg.obj tb2kdsgn_cb4.obj +RESFILES = ..\Source\TB2Reg.dcr +RESDEPEN = $(RESFILES) ..\Source\TB2DsgnConverter.dfm ..\Source\TB2DsgnItemEditor.dfm \ + ..\Source\TB2DsgnConvertOptions.dfm +LIBFILES = +LIBRARIES = +SPARELIBS = Vcl40.lib +PACKAGES = vcl40.bpi dclstd40.bpi tb2k_cb4.bpi +DEFFILE = +# --------------------------------------------------------------------------- +PATHCPP = .; +PATHASM = .; +PATHPAS = .;..\Source +PATHRC = .; +DEBUGLIBPATH = $(BCB)\lib\debug +RELEASELIBPATH = $(BCB)\lib\release +USERDEFINES = +SYSDEFINES = _RTLDLL;NO_STRICT;USEPACKAGES +# --------------------------------------------------------------------------- +CFLAG1 = -I..\Source;$(BCB)\include;$(BCB)\include\vcl -Od -Hc -H=$(BCB)\lib\vcl40.csm \ + -w -Ve -r- -a8 -k -y -v -vi- -c -b- -w-par -w-inl -Vx -tWM \ + -D$(SYSDEFINES);$(USERDEFINES) +PFLAGS = -U..\Source;$(BCB)\Projects\Lib;$(BCB)\lib\obj;$(BCB)\lib;$(RELEASELIBPATH) \ + -I..\Source;$(BCB)\include;$(BCB)\include\vcl -$YD -$J- -v -JPHNE -M -LUdclstd40 +RFLAGS = -i..\Source;$(BCB)\include;$(BCB)\include\vcl +AFLAGS = /i..\Source /i$(BCB)\include /i$(BCB)\include\vcl /mx /w2 /zd +LFLAGS = -L..\Source;$(BCB)\Projects\Lib;$(BCB)\lib\obj;$(BCB)\lib;$(RELEASELIBPATH) \ + -D"Toolbar2000 Design Package (Jordan Russell)" -aa -Tpp -Gpd -x -Gn -Gl -Gi -v +# --------------------------------------------------------------------------- +ALLOBJ = c0pkg32.obj Memmgr.Lib $(PACKAGES) sysinit.obj $(OBJFILES) +ALLRES = $(RESFILES) +ALLLIB = $(LIBFILES) $(LIBRARIES) import32.lib cp32mti.lib +# --------------------------------------------------------------------------- +!ifdef IDEOPTIONS + +[Version Info] +IncludeVerInfo=0 +AutoIncBuild=0 +MajorVer=1 +MinorVer=0 +Release=0 +Build=0 +Debug=0 +PreRelease=0 +Special=0 +Private=0 +DLL=0 +Locale=1033 +CodePage=1252 + +[Version Info Keys] +CompanyName= +FileDescription= +FileVersion=1.0.0.0 +InternalName= +LegalCopyright= +LegalTrademarks= +OriginalFilename= +ProductName= +ProductVersion=1.0.0.0 +Comments= + +[Debugging] +DebugSourceDirs=$(BCB)\source\vcl + +[Parameters] +RunParams= +HostApplication= +RemoteHost= +RemotePath= +RemoteDebug=0 + +[Compiler] +InMemoryExe=0 +ShowInfoMsgs=0 + +!endif + +# --------------------------------------------------------------------------- +# MAKE SECTION +# --------------------------------------------------------------------------- +# This section of the project file is not used by the BCB IDE. It is for +# the benefit of building from the command-line using the MAKE utility. +# --------------------------------------------------------------------------- + +.autodepend +# --------------------------------------------------------------------------- +!if !$d(BCC32) +BCC32 = bcc32 +!endif + +!if !$d(CPP32) +CPP32 = cpp32 +!endif + +!if !$d(DCC32) +DCC32 = dcc32 +!endif + +!if !$d(TASM32) +TASM32 = tasm32 +!endif + +!if !$d(LINKER) +LINKER = ilink32 +!endif + +!if !$d(BRCC32) +BRCC32 = brcc32 +!endif + +# --------------------------------------------------------------------------- +!if $d(PATHCPP) +.PATH.CPP = $(PATHCPP) +.PATH.C = $(PATHCPP) +!endif + +!if $d(PATHPAS) +.PATH.PAS = $(PATHPAS) +!endif + +!if $d(PATHASM) +.PATH.ASM = $(PATHASM) +!endif + +!if $d(PATHRC) +.PATH.RC = $(PATHRC) +!endif +# --------------------------------------------------------------------------- +$(PROJECT): $(OBJFILES) $(RESDEPEN) $(DEFFILE) + $(BCB)\BIN\$(LINKER) @&&! + $(LFLAGS) + + $(ALLOBJ), + + $(PROJECT),, + + $(ALLLIB), + + $(DEFFILE), + + $(ALLRES) +! +# --------------------------------------------------------------------------- +.pas.hpp: + $(BCB)\BIN\$(DCC32) $(PFLAGS) {$< } + +.pas.obj: + $(BCB)\BIN\$(DCC32) $(PFLAGS) {$< } + +.cpp.obj: + $(BCB)\BIN\$(BCC32) $(CFLAG1) -n$(@D) {$< } + +.c.obj: + $(BCB)\BIN\$(BCC32) $(CFLAG1) -n$(@D) {$< } + +.c.i: + $(BCB)\BIN\$(CPP32) $(CFLAG1) -n. {$< } + +.cpp.i: + $(BCB)\BIN\$(CPP32) $(CFLAG1) -n. {$< } + +.asm.obj: + $(BCB)\BIN\$(TASM32) $(AFLAGS) $<, $@ + +.rc.res: + $(BCB)\BIN\$(BRCC32) $(RFLAGS) -fo$@ $< +# --------------------------------------------------------------------------- + diff --git a/internal/2.2.2/1/Packages/tb2kdsgn_cb4.cpp b/internal/2.2.2/1/Packages/tb2kdsgn_cb4.cpp new file mode 100644 index 0000000..08b9d21 --- /dev/null +++ b/internal/2.2.2/1/Packages/tb2kdsgn_cb4.cpp @@ -0,0 +1,23 @@ +// $jrsoftware: tb2k/Packages/tb2kdsgn_cb4.cpp,v 1.4 2002/11/14 18:15:59 jr Exp $ +//--------------------------------------------------------------------------- +#include +#pragma hdrstop +USEPACKAGE("vcl40.bpi"); +USEFORMNS("..\Source\TB2DsgnConverter.pas", Tb2dsgnconverter, TBConverterForm); +USEFORMNS("..\Source\TB2DsgnItemEditor.pas", Tb2dsgnitemeditor, TBItemEditForm); +USEFORMNS("..\Source\TB2DsgnConvertOptions.pas", Tb2dsgnconvertoptions, TBConvertOptionsForm); +USEUNIT("..\Source\TB2Reg.pas"); +USERES("..\Source\TB2Reg.dcr"); +USEPACKAGE("dclstd40.bpi"); +USEPACKAGE("tb2k_cb4.bpi"); +//--------------------------------------------------------------------------- +#pragma package(smart_init) +//--------------------------------------------------------------------------- +// Package source. +//--------------------------------------------------------------------------- +int WINAPI DllEntryPoint(HINSTANCE hinst, unsigned long reason, void*) +{ + return 1; +} +//--------------------------------------------------------------------------- + diff --git a/internal/2.2.2/1/Packages/tb2kdsgn_cb5.bpk b/internal/2.2.2/1/Packages/tb2kdsgn_cb5.bpk new file mode 100644 index 0000000..2950fbf --- /dev/null +++ b/internal/2.2.2/1/Packages/tb2kdsgn_cb5.bpk @@ -0,0 +1,95 @@ + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + +[Version Info] +IncludeVerInfo=0 +AutoIncBuild=0 +MajorVer=1 +MinorVer=0 +Release=0 +Build=0 +Debug=0 +PreRelease=0 +Special=0 +Private=0 +DLL=0 +Locale=1033 +CodePage=1252 + +[Version Info Keys] +CompanyName= +FileDescription= +FileVersion=1.0.0.0 +InternalName= +LegalCopyright= +LegalTrademarks= +OriginalFilename= +ProductName= +ProductVersion=1.0.0.0 +Comments= + +[Debugging] +DebugSourceDirs=$(BCB)\source\vcl + +[Parameters] +RunParams= +HostApplication= +RemoteHost= +RemotePath= +RemoteDebug=0 + +[Compiler] +ShowInfoMsgs=0 +LinkDebugVcl=0 +LinkCGLIB=0 + +[Language] +ActiveLang= +ProjectLang= +RootDir= + + \ No newline at end of file diff --git a/internal/2.2.2/1/Packages/tb2kdsgn_cb5.cpp b/internal/2.2.2/1/Packages/tb2kdsgn_cb5.cpp new file mode 100644 index 0000000..ba1bbd8 --- /dev/null +++ b/internal/2.2.2/1/Packages/tb2kdsgn_cb5.cpp @@ -0,0 +1,23 @@ +// $jrsoftware: tb2k/Packages/tb2kdsgn_cb5.cpp,v 1.4 2002/11/14 18:15:59 jr Exp $ +//--------------------------------------------------------------------------- +#include +#pragma hdrstop +USEPACKAGE("vcl50.bpi"); +USEFORMNS("..\Source\TB2DsgnConverter.pas", Tb2dsgnconverter, TBConverterForm); +USEFORMNS("..\Source\TB2DsgnItemEditor.pas", Tb2dsgnitemeditor, TBItemEditForm); +USEFORMNS("..\Source\TB2DsgnConvertOptions.pas", Tb2dsgnconvertoptions, TBConvertOptionsForm); +USEUNIT("..\Source\TB2Reg.pas"); +USERES("..\Source\TB2Reg.dcr"); +USEPACKAGE("dclstd50.bpi"); +USEPACKAGE("tb2k_cb5.bpi"); +//--------------------------------------------------------------------------- +#pragma package(smart_init) +//--------------------------------------------------------------------------- +// Package source. +//--------------------------------------------------------------------------- +int WINAPI DllEntryPoint(HINSTANCE hinst, unsigned long reason, void*) +{ + return 1; +} +//--------------------------------------------------------------------------- + diff --git a/internal/2.2.2/1/Packages/tb2kdsgn_cb6.bpk b/internal/2.2.2/1/Packages/tb2kdsgn_cb6.bpk new file mode 100644 index 0000000..1223631 --- /dev/null +++ b/internal/2.2.2/1/Packages/tb2kdsgn_cb6.bpk @@ -0,0 +1,125 @@ + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + +[Version Info] +IncludeVerInfo=0 +AutoIncBuild=0 +MajorVer=1 +MinorVer=0 +Release=0 +Build=0 +Debug=0 +PreRelease=0 +Special=0 +Private=0 +DLL=0 +Locale=1033 +CodePage=1252 + +[Version Info Keys] +CompanyName= +FileDescription= +FileVersion=1.0.0.0 +InternalName= +LegalCopyright= +LegalTrademarks= +OriginalFilename= +ProductName= +ProductVersion=1.0.0.0 +Comments= + +[Debugging] +DebugSourceDirs=$(BCB)\source\vcl + +[Parameters] +RunParams= +Launcher= +UseLauncher=0 +DebugCWD= +HostApplication= +RemoteHost= +RemotePath= +RemoteLauncher= +RemoteCWD= +RemoteDebug=0 + +[Compiler] +ShowInfoMsgs=0 +LinkDebugVcl=0 +LinkCGLIB=0 + +[Language] +ActiveLang= +ProjectLang= +RootDir= + +[Linker] +LibPrefix= +LibSuffix= +LibVersion= + + \ No newline at end of file diff --git a/internal/2.2.2/1/Packages/tb2kdsgn_cb6.cpp b/internal/2.2.2/1/Packages/tb2kdsgn_cb6.cpp new file mode 100644 index 0000000..6fabfa6 --- /dev/null +++ b/internal/2.2.2/1/Packages/tb2kdsgn_cb6.cpp @@ -0,0 +1,18 @@ +// $jrsoftware: tb2k/Packages/tb2kdsgn_cb6.cpp,v 1.2 2002/11/14 18:07:19 jr Exp $ +//--------------------------------------------------------------------------- +#include +#pragma hdrstop +USEFORMNS("..\Source\TB2DsgnConverter.pas", Tb2dsgnconverter, TBConverterForm); +USEFORMNS("..\Source\TB2DsgnItemEditor.pas", Tb2dsgnitemeditor, TBItemEditForm); +USEFORMNS("..\Source\TB2DsgnConvertOptions.pas", Tb2dsgnconvertoptions, TBConvertOptionsForm); +//--------------------------------------------------------------------------- +#pragma package(smart_init) +//--------------------------------------------------------------------------- +// Package source. +//--------------------------------------------------------------------------- +int WINAPI DllEntryPoint(HINSTANCE hinst, unsigned long reason, void*) +{ + return 1; +} +//--------------------------------------------------------------------------- + diff --git a/internal/2.2.2/1/Packages/tb2kdsgn_d10.bdsproj b/internal/2.2.2/1/Packages/tb2kdsgn_d10.bdsproj new file mode 100644 index 0000000..e208fd9 --- /dev/null +++ b/internal/2.2.2/1/Packages/tb2kdsgn_d10.bdsproj @@ -0,0 +1,175 @@ + + + + + + + + + + + + tb2kdsgn_d10.dpk + + + 7.0 + + + 8 + 0 + 1 + 1 + 0 + 0 + 1 + 1 + 1 + 0 + 0 + 1 + 0 + 1 + 1 + 1 + 0 + 0 + 0 + 0 + 0 + 1 + 0 + 1 + 1 + 1 + True + True + WinTypes=Windows;WinProcs=Windows;DbiTypes=BDE;DbiProcs=BDE;DbiErrs=BDE; + + False + + True + True + True + True + True + True + True + True + True + True + True + True + True + True + True + True + True + True + True + True + True + True + True + True + True + True + True + True + True + True + True + True + True + True + True + True + True + True + True + True + True + True + True + True + True + True + False + False + False + True + True + True + True + True + True + + + + 0 + 44 + False + 1 + False + False + False + 16384 + 1048576 + 1065353216 + Toolbar2000 Design Package (Jordan Russell) + + + + + + + + + + + False + + + + + + False + + + True + False + + + + $00000000 + + + + False + False + 1 + 0 + 0 + 0 + False + False + False + False + False + 1033 + 1252 + + + + + 1.0.0.0 + + + + + + 1.0.0.0 + + + + diff --git a/internal/2.2.2/1/Packages/tb2kdsgn_d10.dpk b/internal/2.2.2/1/Packages/tb2kdsgn_d10.dpk new file mode 100644 index 0000000..6286adf --- /dev/null +++ b/internal/2.2.2/1/Packages/tb2kdsgn_d10.dpk @@ -0,0 +1,42 @@ +package tb2kdsgn_d10; + +{$R *.res} +{$R '..\Source\TB2Reg.dcr'} +{$ALIGN 8} +{$ASSERTIONS ON} +{$BOOLEVAL OFF} +{$DEBUGINFO ON} +{$EXTENDEDSYNTAX ON} +{$IMPORTEDDATA ON} +{$IOCHECKS ON} +{$LOCALSYMBOLS ON} +{$LONGSTRINGS ON} +{$OPENSTRINGS ON} +{$OPTIMIZATION ON} +{$OVERFLOWCHECKS OFF} +{$RANGECHECKS OFF} +{$REFERENCEINFO ON} +{$SAFEDIVIDE OFF} +{$STACKFRAMES OFF} +{$TYPEDADDRESS OFF} +{$VARSTRINGCHECKS ON} +{$WRITEABLECONST OFF} +{$MINENUMSIZE 1} +{$IMAGEBASE $3F800000} +{$DESCRIPTION 'Toolbar2000 Design Package (Jordan Russell)'} +{$DESIGNONLY} +{$IMPLICITBUILD OFF} + +requires + vcl, + dclstd, + tb2k_d10; + +contains + TB2Reg in '..\Source\TB2Reg.pas', + TB2DsgnItemEditor in '..\Source\TB2DsgnItemEditor.pas' {TBItemEditForm}, + TB2DsgnConverter in '..\Source\TB2DsgnConverter.pas' {TBConverterForm}, + TB2DsgnConvertOptions in '..\Source\TB2DsgnConvertOptions.pas' {TBConvertOptionsForm}; + +end. + diff --git a/internal/2.2.2/1/Packages/tb2kdsgn_d10.res b/internal/2.2.2/1/Packages/tb2kdsgn_d10.res new file mode 100644 index 0000000..36f26e2 Binary files /dev/null and b/internal/2.2.2/1/Packages/tb2kdsgn_d10.res differ diff --git a/internal/2.2.2/1/Packages/tb2kdsgn_d11.bpi b/internal/2.2.2/1/Packages/tb2kdsgn_d11.bpi new file mode 100644 index 0000000..ffa6f2e Binary files /dev/null and b/internal/2.2.2/1/Packages/tb2kdsgn_d11.bpi differ diff --git a/internal/2.2.2/1/Packages/tb2kdsgn_d11.dpk b/internal/2.2.2/1/Packages/tb2kdsgn_d11.dpk new file mode 100644 index 0000000..5765851 --- /dev/null +++ b/internal/2.2.2/1/Packages/tb2kdsgn_d11.dpk @@ -0,0 +1,43 @@ +package tb2kdsgn_d11; + +{$R *.res} +{$R '..\Source\TB2Reg.dcr'} +{$ALIGN 8} +{$ASSERTIONS ON} +{$BOOLEVAL OFF} +{$DEBUGINFO OFF} +{$EXTENDEDSYNTAX ON} +{$IMPORTEDDATA ON} +{$IOCHECKS ON} +{$LOCALSYMBOLS OFF} +{$LONGSTRINGS ON} +{$OPENSTRINGS ON} +{$OPTIMIZATION ON} +{$OVERFLOWCHECKS OFF} +{$RANGECHECKS OFF} +{$REFERENCEINFO OFF} +{$SAFEDIVIDE OFF} +{$STACKFRAMES OFF} +{$TYPEDADDRESS OFF} +{$VARSTRINGCHECKS ON} +{$WRITEABLECONST OFF} +{$MINENUMSIZE 1} +{$IMAGEBASE $400000} +{$DESCRIPTION 'Toolbar2000 Design Package (Jordan Russell)'} +{$DESIGNONLY} +{$IMPLICITBUILD OFF} +{$DEFINE RELEASE} + +requires + rtl, + vcl, + dclstd, + tb2k_d11; + +contains + TB2Reg in '..\Source\TB2Reg.pas', + TB2DsgnItemEditor in '..\Source\TB2DsgnItemEditor.pas' {TBItemEditForm}, + TB2DsgnConverter in '..\Source\TB2DsgnConverter.pas' {TBConverterForm}, + TB2DsgnConvertOptions in '..\Source\TB2DsgnConvertOptions.pas' {TBConvertOptionsForm}; + +end. diff --git a/internal/2.2.2/1/Packages/tb2kdsgn_d11.dproj b/internal/2.2.2/1/Packages/tb2kdsgn_d11.dproj new file mode 100644 index 0000000..07d76d0 --- /dev/null +++ b/internal/2.2.2/1/Packages/tb2kdsgn_d11.dproj @@ -0,0 +1,552 @@ + + + {e51188c3-1c1e-47eb-b42e-bb80872f9ae7} + tb2kdsgn_d11.dpk + Release + AnyCPU + DCC32 + ..\Lib\D11\tb2kdsgn_d11.bpl + + + 7.0 + False + False + 0 + RELEASE + ..\Lib\D11 + ..\Lib\D11 + ..\Lib\D11 + ..\Lib\D11 + ..\Lib\D11 + ..\Lib\D11 + ..\Lib\D11 + ..\Lib\D11 + ..\Lib\D11 + + + 7.0 + DEBUG + All + 3F800000 + ..\Lib\D11 + ..\Lib\D11 + ..\Lib\D11 + ..\Lib\D11 + ..\Lib\D11 + ..\Lib\D11 + ..\Lib\D11 + ..\Lib\D11 + ..\Lib\D11 + + + Delphi.Personality + Package + +FalseTrueFalseFalseTrueFalseToolbar2000 Design Package (Jordan Russell)TrueFalse1000FalseFalseFalseFalseFalse103312521.0.0.01.0.0.0tb2kdsgn_d11.dpk + + + + + MainSource + + +
TBConverterForm
+ + +
TBConvertOptionsForm
+ + +
TBItemEditForm
+ + + + + + + + + + + diff --git a/internal/2.2.2/1/Packages/tb2kdsgn_d11.res b/internal/2.2.2/1/Packages/tb2kdsgn_d11.res new file mode 100644 index 0000000..1bf5a8c Binary files /dev/null and b/internal/2.2.2/1/Packages/tb2kdsgn_d11.res differ diff --git a/internal/2.2.2/1/Packages/tb2kdsgn_d12.dpk b/internal/2.2.2/1/Packages/tb2kdsgn_d12.dpk new file mode 100644 index 0000000..b3ebd84 --- /dev/null +++ b/internal/2.2.2/1/Packages/tb2kdsgn_d12.dpk @@ -0,0 +1,42 @@ +package tb2kdsgn_d12; + +{$R *.res} +{$R '..\Source\TB2Reg.dcr'} +{$ALIGN 8} +{$ASSERTIONS ON} +{$BOOLEVAL OFF} +{$DEBUGINFO ON} +{$EXTENDEDSYNTAX ON} +{$IMPORTEDDATA ON} +{$IOCHECKS ON} +{$LOCALSYMBOLS ON} +{$LONGSTRINGS ON} +{$OPENSTRINGS ON} +{$OPTIMIZATION ON} +{$OVERFLOWCHECKS OFF} +{$RANGECHECKS OFF} +{$REFERENCEINFO ON} +{$SAFEDIVIDE OFF} +{$STACKFRAMES OFF} +{$TYPEDADDRESS OFF} +{$VARSTRINGCHECKS ON} +{$WRITEABLECONST OFF} +{$MINENUMSIZE 1} +{$IMAGEBASE $3F800000} +{$DESCRIPTION 'Toolbar2000 Design Package (Jordan Russell)'} +{$DESIGNONLY} +{$IMPLICITBUILD OFF} + +requires + rtl, + vcl, + dclstd, + tb2k_d12; + +contains + TB2Reg in '..\Source\TB2Reg.pas', + TB2DsgnItemEditor in '..\Source\TB2DsgnItemEditor.pas' {TBItemEditForm}, + TB2DsgnConverter in '..\Source\TB2DsgnConverter.pas' {TBConverterForm}, + TB2DsgnConvertOptions in '..\Source\TB2DsgnConvertOptions.pas' {TBConvertOptionsForm}; + +end. diff --git a/internal/2.2.2/1/Packages/tb2kdsgn_d12.dproj b/internal/2.2.2/1/Packages/tb2kdsgn_d12.dproj new file mode 100644 index 0000000..7bea712 --- /dev/null +++ b/internal/2.2.2/1/Packages/tb2kdsgn_d12.dproj @@ -0,0 +1,126 @@ + + + {D9827544-06D4-4C36-9AA3-5858B2C844EA} + tb2kdsgn_d12.dpk + 12.0 + Debug + DCC32 + + + true + + + true + Base + true + + + true + Base + true + + + 3F800000 + tb2kdsgn_d12.bpl + 1 + true + x86 + WinTypes=Windows;WinProcs=Windows;DbiTypes=BDE;DbiProcs=BDE;DbiErrs=BDE;$(DCC_UnitAlias) + Toolbar2000 Design Package (Jordan Russell) + All + false + false + true + true + false + true + false + false + + + false + RELEASE;$(DCC_Define) + 0 + false + + + DEBUG;$(DCC_Define) + + + + MainSource + + + + + + + + +
TBItemEditForm
+ + +
TBConverterForm
+ + +
TBConvertOptionsForm
+ + + + Base + + + Cfg_2 + Base + + + Cfg_1 + Base + + + + + Delphi.Personality.12 + Package + + + + tb2kdsgn_d12.dpk + + + False + True + False + + + False + False + 1 + 0 + 0 + 0 + False + False + False + False + False + 1033 + 1252 + + + + + 1.0.0.0 + + + + + + 1.0.0.0 + + + + + 12 + + diff --git a/internal/2.2.2/1/Packages/tb2kdsgn_d12.res b/internal/2.2.2/1/Packages/tb2kdsgn_d12.res new file mode 100644 index 0000000..36f26e2 Binary files /dev/null and b/internal/2.2.2/1/Packages/tb2kdsgn_d12.res differ diff --git a/internal/2.2.2/1/Packages/tb2kdsgn_d4.dpk b/internal/2.2.2/1/Packages/tb2kdsgn_d4.dpk new file mode 100644 index 0000000..b9c2f4e --- /dev/null +++ b/internal/2.2.2/1/Packages/tb2kdsgn_d4.dpk @@ -0,0 +1,42 @@ +package tb2kdsgn_d4; + +{$R *.RES} +{$R '..\Source\TB2Reg.dcr'} +{$ALIGN ON} +{$ASSERTIONS ON} +{$BOOLEVAL OFF} +{$DEBUGINFO ON} +{$EXTENDEDSYNTAX ON} +{$IMPORTEDDATA ON} +{$IOCHECKS ON} +{$LOCALSYMBOLS ON} +{$LONGSTRINGS ON} +{$OPENSTRINGS ON} +{$OPTIMIZATION ON} +{$OVERFLOWCHECKS OFF} +{$RANGECHECKS OFF} +{$REFERENCEINFO ON} +{$SAFEDIVIDE OFF} +{$STACKFRAMES OFF} +{$TYPEDADDRESS OFF} +{$VARSTRINGCHECKS ON} +{$WRITEABLECONST OFF} +{$MINENUMSIZE 1} +{$IMAGEBASE $3F800000} +{$DESCRIPTION 'Toolbar2000 Design Package (Jordan Russell)'} +{$DESIGNONLY} +{$IMPLICITBUILD ON} + +requires + vcl40, + dclstd40, + tb2k_d4; + +contains + TB2Reg in '..\Source\TB2Reg.pas', + TB2DsgnItemEditor in '..\Source\TB2DsgnItemEditor.pas' {TBItemEditForm}, + TB2DsgnConverter in '..\Source\TB2DsgnConverter.pas' {TBConverterForm}, + TB2DsgnConvertOptions in '..\Source\TB2DsgnConvertOptions.pas' {TBConvertOptionsForm}; + +end. + diff --git a/internal/2.2.2/1/Packages/tb2kdsgn_d4.res b/internal/2.2.2/1/Packages/tb2kdsgn_d4.res new file mode 100644 index 0000000..36f26e2 Binary files /dev/null and b/internal/2.2.2/1/Packages/tb2kdsgn_d4.res differ diff --git a/internal/2.2.2/1/Packages/tb2kdsgn_d5.dpk b/internal/2.2.2/1/Packages/tb2kdsgn_d5.dpk new file mode 100644 index 0000000..bb80ebc --- /dev/null +++ b/internal/2.2.2/1/Packages/tb2kdsgn_d5.dpk @@ -0,0 +1,42 @@ +package tb2kdsgn_d5; + +{$R *.RES} +{$R '..\Source\TB2Reg.dcr'} +{$ALIGN ON} +{$ASSERTIONS ON} +{$BOOLEVAL OFF} +{$DEBUGINFO ON} +{$EXTENDEDSYNTAX ON} +{$IMPORTEDDATA ON} +{$IOCHECKS ON} +{$LOCALSYMBOLS ON} +{$LONGSTRINGS ON} +{$OPENSTRINGS ON} +{$OPTIMIZATION ON} +{$OVERFLOWCHECKS OFF} +{$RANGECHECKS OFF} +{$REFERENCEINFO ON} +{$SAFEDIVIDE OFF} +{$STACKFRAMES OFF} +{$TYPEDADDRESS OFF} +{$VARSTRINGCHECKS ON} +{$WRITEABLECONST OFF} +{$MINENUMSIZE 1} +{$IMAGEBASE $3F800000} +{$DESCRIPTION 'Toolbar2000 Design Package (Jordan Russell)'} +{$DESIGNONLY} +{$IMPLICITBUILD ON} + +requires + vcl50, + dclstd50, + tb2k_d5; + +contains + TB2Reg in '..\Source\TB2Reg.pas', + TB2DsgnItemEditor in '..\Source\TB2DsgnItemEditor.pas' {TBItemEditForm}, + TB2DsgnConverter in '..\Source\TB2DsgnConverter.pas' {TBConverterForm}, + TB2DsgnConvertOptions in '..\Source\TB2DsgnConvertOptions.pas' {TBConvertOptionsForm}; + +end. + diff --git a/internal/2.2.2/1/Packages/tb2kdsgn_d5.res b/internal/2.2.2/1/Packages/tb2kdsgn_d5.res new file mode 100644 index 0000000..36f26e2 Binary files /dev/null and b/internal/2.2.2/1/Packages/tb2kdsgn_d5.res differ diff --git a/internal/2.2.2/1/Packages/tb2kdsgn_d6.dpk b/internal/2.2.2/1/Packages/tb2kdsgn_d6.dpk new file mode 100644 index 0000000..da87e9e --- /dev/null +++ b/internal/2.2.2/1/Packages/tb2kdsgn_d6.dpk @@ -0,0 +1,42 @@ +package tb2kdsgn_d6; + +{$R *.res} +{$R '..\Source\TB2Reg.dcr'} +{$ALIGN 8} +{$ASSERTIONS ON} +{$BOOLEVAL OFF} +{$DEBUGINFO ON} +{$EXTENDEDSYNTAX ON} +{$IMPORTEDDATA ON} +{$IOCHECKS ON} +{$LOCALSYMBOLS ON} +{$LONGSTRINGS ON} +{$OPENSTRINGS ON} +{$OPTIMIZATION ON} +{$OVERFLOWCHECKS OFF} +{$RANGECHECKS OFF} +{$REFERENCEINFO ON} +{$SAFEDIVIDE OFF} +{$STACKFRAMES OFF} +{$TYPEDADDRESS OFF} +{$VARSTRINGCHECKS ON} +{$WRITEABLECONST OFF} +{$MINENUMSIZE 1} +{$IMAGEBASE $3F800000} +{$DESCRIPTION 'Toolbar2000 Design Package (Jordan Russell)'} +{$DESIGNONLY} +{$IMPLICITBUILD ON} + +requires + vcl, + dclstd, + tb2k_d6; + +contains + TB2Reg in '..\Source\TB2Reg.pas', + TB2DsgnItemEditor in '..\Source\TB2DsgnItemEditor.pas' {TBItemEditForm}, + TB2DsgnConverter in '..\Source\TB2DsgnConverter.pas' {TBConverterForm}, + TB2DsgnConvertOptions in '..\Source\TB2DsgnConvertOptions.pas' {TBConvertOptionsForm}; + +end. + diff --git a/internal/2.2.2/1/Packages/tb2kdsgn_d6.res b/internal/2.2.2/1/Packages/tb2kdsgn_d6.res new file mode 100644 index 0000000..36f26e2 Binary files /dev/null and b/internal/2.2.2/1/Packages/tb2kdsgn_d6.res differ diff --git a/internal/2.2.2/1/Packages/tb2kdsgn_d7.dpk b/internal/2.2.2/1/Packages/tb2kdsgn_d7.dpk new file mode 100644 index 0000000..805b074 --- /dev/null +++ b/internal/2.2.2/1/Packages/tb2kdsgn_d7.dpk @@ -0,0 +1,42 @@ +package tb2kdsgn_d7; + +{$R *.res} +{$R '..\Source\TB2Reg.dcr'} +{$ALIGN 8} +{$ASSERTIONS ON} +{$BOOLEVAL OFF} +{$DEBUGINFO ON} +{$EXTENDEDSYNTAX ON} +{$IMPORTEDDATA ON} +{$IOCHECKS ON} +{$LOCALSYMBOLS ON} +{$LONGSTRINGS ON} +{$OPENSTRINGS ON} +{$OPTIMIZATION ON} +{$OVERFLOWCHECKS OFF} +{$RANGECHECKS OFF} +{$REFERENCEINFO ON} +{$SAFEDIVIDE OFF} +{$STACKFRAMES OFF} +{$TYPEDADDRESS OFF} +{$VARSTRINGCHECKS ON} +{$WRITEABLECONST OFF} +{$MINENUMSIZE 1} +{$IMAGEBASE $3F800000} +{$DESCRIPTION 'Toolbar2000 Design Package (Jordan Russell)'} +{$DESIGNONLY} +{$IMPLICITBUILD ON} + +requires + vcl, + dclstd, + tb2k_d7; + +contains + TB2Reg in '..\Source\TB2Reg.pas', + TB2DsgnItemEditor in '..\Source\TB2DsgnItemEditor.pas' {TBItemEditForm}, + TB2DsgnConverter in '..\Source\TB2DsgnConverter.pas' {TBConverterForm}, + TB2DsgnConvertOptions in '..\Source\TB2DsgnConvertOptions.pas' {TBConvertOptionsForm}; + +end. + diff --git a/internal/2.2.2/1/Packages/tb2kdsgn_d7.res b/internal/2.2.2/1/Packages/tb2kdsgn_d7.res new file mode 100644 index 0000000..36f26e2 Binary files /dev/null and b/internal/2.2.2/1/Packages/tb2kdsgn_d7.res differ diff --git a/internal/2.2.2/1/Packages/tb2kdsgn_d9.dpk b/internal/2.2.2/1/Packages/tb2kdsgn_d9.dpk new file mode 100644 index 0000000..ca4e64a --- /dev/null +++ b/internal/2.2.2/1/Packages/tb2kdsgn_d9.dpk @@ -0,0 +1,42 @@ +package tb2kdsgn_d9; + +{$R *.res} +{$R '..\Source\TB2Reg.dcr'} +{$ALIGN 8} +{$ASSERTIONS ON} +{$BOOLEVAL OFF} +{$DEBUGINFO ON} +{$EXTENDEDSYNTAX ON} +{$IMPORTEDDATA ON} +{$IOCHECKS ON} +{$LOCALSYMBOLS ON} +{$LONGSTRINGS ON} +{$OPENSTRINGS ON} +{$OPTIMIZATION ON} +{$OVERFLOWCHECKS OFF} +{$RANGECHECKS OFF} +{$REFERENCEINFO ON} +{$SAFEDIVIDE OFF} +{$STACKFRAMES OFF} +{$TYPEDADDRESS OFF} +{$VARSTRINGCHECKS ON} +{$WRITEABLECONST OFF} +{$MINENUMSIZE 1} +{$IMAGEBASE $3F800000} +{$DESCRIPTION 'Toolbar2000 Design Package (Jordan Russell)'} +{$DESIGNONLY} +{$IMPLICITBUILD ON} + +requires + vcl, + dclstd, + tb2k_d9; + +contains + TB2Reg in '..\Source\TB2Reg.pas', + TB2DsgnItemEditor in '..\Source\TB2DsgnItemEditor.pas' {TBItemEditForm}, + TB2DsgnConverter in '..\Source\TB2DsgnConverter.pas' {TBConverterForm}, + TB2DsgnConvertOptions in '..\Source\TB2DsgnConvertOptions.pas' {TBConvertOptionsForm}; + +end. + diff --git a/internal/2.2.2/1/Packages/tb2kdsgn_d9.res b/internal/2.2.2/1/Packages/tb2kdsgn_d9.res new file mode 100644 index 0000000..36f26e2 Binary files /dev/null and b/internal/2.2.2/1/Packages/tb2kdsgn_d9.res differ diff --git a/internal/2.2.2/1/Packages/tb2kdsgn_dn10.bdsproj b/internal/2.2.2/1/Packages/tb2kdsgn_dn10.bdsproj new file mode 100644 index 0000000..149e279 --- /dev/null +++ b/internal/2.2.2/1/Packages/tb2kdsgn_dn10.bdsproj @@ -0,0 +1,188 @@ + + + + + + + + + + + + tb2kdsgn_dn10.dpk + + + 7.0 + + + 0 + 0 + 1 + 1 + 0 + 0 + 1 + 1 + 1 + 0 + 0 + 1 + 0 + 1 + 1 + 1 + 0 + 0 + 0 + 0 + 0 + 1 + 0 + 1 + 1 + 1 + True + True + WinTypes=Borland.Vcl.Windows;WinProcs=Borland.Vcl.Windows;DbiTypes=BDE;DbiProcs=BDE;DbiErrs=BDE; + Borland.Vcl.Design + False + + True + True + True + True + True + False + True + True + True + True + True + True + True + True + True + True + True + True + True + True + True + True + True + True + True + True + True + True + True + True + True + True + True + True + True + True + True + True + True + True + True + True + True + True + True + True + True + True + True + True + True + True + True + True + True + + + + 0 + 0 + False + 1 + True + False + False + 4096 + 1048576 + 1056964608 + Toolbar2000 .NET Design Package (Jordan Russell) + + + + + $(BDSPROJECTSDIR)\Bpl + $(BDSPROJECTSDIR)\Bpl + + + + + True + + + + + + False + + + True + False + + + + $00000000 + + + + True + False + 1 + 0 + 0 + 0 + False + False + False + False + False + 1033 + 1252 + + + + + 1.0.0.0 + + + + + + 1.0.0.0 + + + + + + + + + + + + + + + + + diff --git a/internal/2.2.2/1/Packages/tb2kdsgn_dn10.dpk b/internal/2.2.2/1/Packages/tb2kdsgn_dn10.dpk new file mode 100644 index 0000000..418a15d --- /dev/null +++ b/internal/2.2.2/1/Packages/tb2kdsgn_dn10.dpk @@ -0,0 +1,111 @@ +package tb2kdsgn_dn10; + +{$ALIGN 0} +{$ASSERTIONS ON} +{$BOOLEVAL OFF} +{$DEBUGINFO ON} +{$EXTENDEDSYNTAX ON} +{$IMPORTEDDATA ON} +{$IOCHECKS ON} +{$LOCALSYMBOLS ON} +{$LONGSTRINGS ON} +{$OPENSTRINGS ON} +{$OPTIMIZATION ON} +{$OVERFLOWCHECKS OFF} +{$RANGECHECKS OFF} +{$REFERENCEINFO ON} +{$SAFEDIVIDE OFF} +{$STACKFRAMES OFF} +{$TYPEDADDRESS OFF} +{$VARSTRINGCHECKS ON} +{$WRITEABLECONST OFF} +{$MINENUMSIZE 1} +{$IMAGEBASE $3F000000} +{$DESCRIPTION 'Toolbar2000 .NET Design Package (Jordan Russell)'} +{$DESIGNONLY} +{$IMPLICITBUILD OFF} + +requires + System.Drawing, + Borland.Delphi, + Borland.Studio.Vcl.Design, + Borland.Vcl.Design.Standard, + tb2k_dn10; + +contains + TB2Reg in '..\Source\TB2Reg.pas', + TB2DsgnItemEditor in '..\Source\TB2DsgnItemEditor.pas', + TB2DsgnConverter in '..\Source\TB2DsgnConverter.pas', + TB2DsgnConvertOptions in '..\Source\TB2DsgnConvertOptions.pas'; + +[assembly: AssemblyDescription('')] +[assembly: AssemblyConfiguration('')] +[assembly: AssemblyCompany('')] +[assembly: AssemblyProduct('')] +[assembly: AssemblyCopyright('')] +[assembly: AssemblyTrademark('')] +[assembly: AssemblyCulture('')] + + +// The Delphi compiler controls the AssemblyTitleAttribute via the ExeDescription. +// You can set this in the IDE via the Project Options. +// Manually setting the AssemblyTitle attribute below will override the IDE +// setting. +// [assembly: AssemblyTitle('')] + + +// +// Version information for an assembly consists of the following four values: +// +// Major Version +// Minor Version +// Build Number +// Revision +// +// You can specify all the values or you can default the Revision and Build Numbers +// by using the '*' as shown below: + +//[assembly: AssemblyVersion('1.0.*')] + +// +// In order to sign your assembly you must specify a key to use. Refer to the +// Microsoft .NET Framework documentation for more information on assembly signing. +// +// Use the attributes below to control which key is used for signing. +// +// Notes: +// (*) If no key is specified, the assembly is not signed. +// (*) KeyName refers to a key that has been installed in the Crypto Service +// Provider (CSP) on your machine. KeyFile refers to a file which contains +// a key. +// (*) If the KeyFile and the KeyName values are both specified, the +// following processing occurs: +// (1) If the KeyName can be found in the CSP, that key is used. +// (2) If the KeyName does not exist and the KeyFile does exist, the key +// in the KeyFile is installed into the CSP and used. +// (*) In order to create a KeyFile, you can use the sn.exe (Strong Name) utility. +// When specifying the KeyFile, the location of the KeyFile should be +// relative to the project output directory. For example, if your KeyFile is +// located in the project directory, you would specify the AssemblyKeyFile +// attribute as [assembly: AssemblyKeyFile('mykey.snk')], provided your output +// directory is the project directory (the default). +// (*) Delay Signing is an advanced option - see the Microsoft .NET Framework +// documentation for more information on this. +// +[assembly: AssemblyDelaySign(false)] +[assembly: AssemblyKeyFile('')] +[assembly: AssemblyKeyName('')] + +// +// Use the attributes below to control the COM visibility of your assembly. By +// default the entire assembly is visible to COM. Setting ComVisible to false +// is the recommended default for your assembly. To then expose a class and interface +// to COM set ComVisible to true on each one. It is also recommended to add a +// Guid attribute. +// + +[assembly: ComVisible(False)] +//[assembly: Guid('')] +//[assembly: TypeLibVersion(1, 0)] + +end. diff --git a/internal/2.2.2/1/Packages/tb2kdsgn_dn11.dpk b/internal/2.2.2/1/Packages/tb2kdsgn_dn11.dpk new file mode 100644 index 0000000..b36d21b --- /dev/null +++ b/internal/2.2.2/1/Packages/tb2kdsgn_dn11.dpk @@ -0,0 +1,112 @@ +package tb2kdsgn_dn11; + +{$ALIGN 0} +{$ASSERTIONS ON} +{$BOOLEVAL OFF} +{$DEBUGINFO ON} +{$EXTENDEDSYNTAX ON} +{$IMPORTEDDATA ON} +{$IOCHECKS ON} +{$LOCALSYMBOLS ON} +{$LONGSTRINGS ON} +{$OPENSTRINGS ON} +{$OPTIMIZATION ON} +{$OVERFLOWCHECKS OFF} +{$RANGECHECKS OFF} +{$REFERENCEINFO ON} +{$SAFEDIVIDE OFF} +{$STACKFRAMES OFF} +{$TYPEDADDRESS OFF} +{$VARSTRINGCHECKS ON} +{$WRITEABLECONST OFF} +{$MINENUMSIZE 1} +{$IMAGEBASE $3F000000} +{$DESCRIPTION 'Toolbar2000 .NET Design Package (Jordan Russell)'} +{$DESIGNONLY} +{$IMPLICITBUILD OFF} +{$DEFINE DEBUG} + +requires + Borland.Delphi, + Borland.Vcl, + Borland.VclRtl, + Borland.Vcl.Design.Standard, + tb2k_dn11; + +contains + TB2Reg in '..\Source\TB2Reg.pas', + TB2DsgnItemEditor in '..\Source\TB2DsgnItemEditor.pas', + TB2DsgnConverter in '..\Source\TB2DsgnConverter.pas', + TB2DsgnConvertOptions in '..\Source\TB2DsgnConvertOptions.pas'; + +[assembly: AssemblyDescription('')] +[assembly: AssemblyConfiguration('')] +[assembly: AssemblyCompany('')] +[assembly: AssemblyProduct('')] +[assembly: AssemblyCopyright('')] +[assembly: AssemblyTrademark('')] +[assembly: AssemblyCulture('')] + + +// The Delphi compiler controls the AssemblyTitleAttribute via the ExeDescription. +// You can set this in the IDE via the Project Options. +// Manually setting the AssemblyTitle attribute below will override the IDE +// setting. +// [assembly: AssemblyTitle('')] + + +// +// Version information for an assembly consists of the following four values: +// +// Major Version +// Minor Version +// Build Number +// Revision +// +// You can specify all the values or you can default the Revision and Build Numbers +// by using the '*' as shown below: + +//[assembly: AssemblyVersion('1.0.*')] + +// +// In order to sign your assembly you must specify a key to use. Refer to the +// Microsoft .NET Framework documentation for more information on assembly signing. +// +// Use the attributes below to control which key is used for signing. +// +// Notes: +// (*) If no key is specified, the assembly is not signed. +// (*) KeyName refers to a key that has been installed in the Crypto Service +// Provider (CSP) on your machine. KeyFile refers to a file which contains +// a key. +// (*) If the KeyFile and the KeyName values are both specified, the +// following processing occurs: +// (1) If the KeyName can be found in the CSP, that key is used. +// (2) If the KeyName does not exist and the KeyFile does exist, the key +// in the KeyFile is installed into the CSP and used. +// (*) In order to create a KeyFile, you can use the sn.exe (Strong Name) utility. +// When specifying the KeyFile, the location of the KeyFile should be +// relative to the project output directory. For example, if your KeyFile is +// located in the project directory, you would specify the AssemblyKeyFile +// attribute as [assembly: AssemblyKeyFile('mykey.snk')], provided your output +// directory is the project directory (the default). +// (*) Delay Signing is an advanced option - see the Microsoft .NET Framework +// documentation for more information on this. +// +[assembly: AssemblyDelaySign(false)] +[assembly: AssemblyKeyFile('')] +[assembly: AssemblyKeyName('')] + +// +// Use the attributes below to control the COM visibility of your assembly. By +// default the entire assembly is visible to COM. Setting ComVisible to false +// is the recommended default for your assembly. To then expose a class and interface +// to COM set ComVisible to true on each one. It is also recommended to add a +// Guid attribute. +// + +[assembly: ComVisible(False)] +//[assembly: Guid('')] +//[assembly: TypeLibVersion(1, 0)] + +end. diff --git a/internal/2.2.2/1/Packages/tb2kdsgn_dn11.dproj b/internal/2.2.2/1/Packages/tb2kdsgn_dn11.dproj new file mode 100644 index 0000000..621b653 --- /dev/null +++ b/internal/2.2.2/1/Packages/tb2kdsgn_dn11.dproj @@ -0,0 +1,82 @@ + + + {be3d3497-f4e5-4f7b-a5f7-0ad1f00fddb2} + Debug + AnyCPU + DCCIL + tb2kdsgn_dn11.dll + tb2kdsgn_dn11.dpk + + + 7.0 + False + False + 0 + RELEASE + 3F000000 + False + Borland.Vcl.Design + + + 7.0 + True + True + DEBUG + 3F000000 + False + Borland.Vcl.Design + + + DelphiDotNet.Personality + + +FalseTrueFalseFalseTrueFalseToolbar2000 .NET Design Package (Jordan Russell)TrueFalse1000FalseFalseFalseFalseFalse103312521.0.0.01.0.0.0tb2kdsgn_dn11.dpk + + + + Borland.VclRtl + 11.0.5000.9245 + Borland.VclRtl.dll + Borland.VclRtl.dll + False + + + Borland.Vcl + 11.0.5000.9245 + Borland.Vcl.dll + Borland.Vcl.dll + False + + + tb2k_dn11 + 0.0.0.0 + tb2k_dn11.dll + tb2k_dn11.dll + False + + + Borland.Delphi + 11.0.5000.9245 + Borland.Delphi.dll + Borland.Delphi.dll + False + + + Borland.Vcl.Design.Standard + 11.0.5000.9245 + Borland.Vcl.Design.Standard.dll + Borland.Vcl.Design.Standard.dll + False + + + + + MainSource + + + + + + + + \ No newline at end of file diff --git a/internal/2.2.2/1/README.txt b/internal/2.2.2/1/README.txt new file mode 100644 index 0000000..c8c520e --- /dev/null +++ b/internal/2.2.2/1/README.txt @@ -0,0 +1,22 @@ +=========================================================================== + Toolbar2000 README +=========================================================================== + +Thank you for downloading Toolbar2000. + +For details on installing and using Toolbar2000, please refer to the +Toolbar2000 help file - tb2k.chm. To open it, double-click it in Windows +Explorer. + +This file is in HTML Help format. If you are using an older version of +Windows that does not come with HTML Help, it can be downloaded at: + + http://msdn.microsoft.com/library/en-us/htmlhelp/html/hwMicrosoftHTMLHelpDownloads.asp + +You will also need Internet Explorer 4.0 or later (5.0 is preferred), +downloadable from: + + http://www.microsoft.com/ie/ + + +- Jordan Russell (www.jrsoftware.org) diff --git a/internal/2.2.2/1/Source/Icons/TB2DsgnEditorImages.bmp b/internal/2.2.2/1/Source/Icons/TB2DsgnEditorImages.bmp new file mode 100644 index 0000000..2419979 Binary files /dev/null and b/internal/2.2.2/1/Source/Icons/TB2DsgnEditorImages.bmp differ diff --git a/internal/2.2.2/1/Source/Icons/TTBBackground.bmp b/internal/2.2.2/1/Source/Icons/TTBBackground.bmp new file mode 100644 index 0000000..ce49b5b Binary files /dev/null and b/internal/2.2.2/1/Source/Icons/TTBBackground.bmp differ diff --git a/internal/2.2.2/1/Source/Icons/TTBBackground16.bmp b/internal/2.2.2/1/Source/Icons/TTBBackground16.bmp new file mode 100644 index 0000000..05dc86b Binary files /dev/null and b/internal/2.2.2/1/Source/Icons/TTBBackground16.bmp differ diff --git a/internal/2.2.2/1/Source/Icons/TTBDock.bmp b/internal/2.2.2/1/Source/Icons/TTBDock.bmp new file mode 100644 index 0000000..d711a0f Binary files /dev/null and b/internal/2.2.2/1/Source/Icons/TTBDock.bmp differ diff --git a/internal/2.2.2/1/Source/Icons/TTBDock16.bmp b/internal/2.2.2/1/Source/Icons/TTBDock16.bmp new file mode 100644 index 0000000..a6ff48d Binary files /dev/null and b/internal/2.2.2/1/Source/Icons/TTBDock16.bmp differ diff --git a/internal/2.2.2/1/Source/Icons/TTBEditItem.bmp b/internal/2.2.2/1/Source/Icons/TTBEditItem.bmp new file mode 100644 index 0000000..08036fa Binary files /dev/null and b/internal/2.2.2/1/Source/Icons/TTBEditItem.bmp differ diff --git a/internal/2.2.2/1/Source/Icons/TTBGroupItem.bmp b/internal/2.2.2/1/Source/Icons/TTBGroupItem.bmp new file mode 100644 index 0000000..0932b29 Binary files /dev/null and b/internal/2.2.2/1/Source/Icons/TTBGroupItem.bmp differ diff --git a/internal/2.2.2/1/Source/Icons/TTBImageList.bmp b/internal/2.2.2/1/Source/Icons/TTBImageList.bmp new file mode 100644 index 0000000..9754808 Binary files /dev/null and b/internal/2.2.2/1/Source/Icons/TTBImageList.bmp differ diff --git a/internal/2.2.2/1/Source/Icons/TTBImageList16.bmp b/internal/2.2.2/1/Source/Icons/TTBImageList16.bmp new file mode 100644 index 0000000..289b503 Binary files /dev/null and b/internal/2.2.2/1/Source/Icons/TTBImageList16.bmp differ diff --git a/internal/2.2.2/1/Source/Icons/TTBItemContainer.bmp b/internal/2.2.2/1/Source/Icons/TTBItemContainer.bmp new file mode 100644 index 0000000..5794333 Binary files /dev/null and b/internal/2.2.2/1/Source/Icons/TTBItemContainer.bmp differ diff --git a/internal/2.2.2/1/Source/Icons/TTBItemContainer16.bmp b/internal/2.2.2/1/Source/Icons/TTBItemContainer16.bmp new file mode 100644 index 0000000..82417d0 Binary files /dev/null and b/internal/2.2.2/1/Source/Icons/TTBItemContainer16.bmp differ diff --git a/internal/2.2.2/1/Source/Icons/TTBMDIHandler.bmp b/internal/2.2.2/1/Source/Icons/TTBMDIHandler.bmp new file mode 100644 index 0000000..5e5f87d Binary files /dev/null and b/internal/2.2.2/1/Source/Icons/TTBMDIHandler.bmp differ diff --git a/internal/2.2.2/1/Source/Icons/TTBMDIHandler16.bmp b/internal/2.2.2/1/Source/Icons/TTBMDIHandler16.bmp new file mode 100644 index 0000000..809e478 Binary files /dev/null and b/internal/2.2.2/1/Source/Icons/TTBMDIHandler16.bmp differ diff --git a/internal/2.2.2/1/Source/Icons/TTBMDIWindowItem.bmp b/internal/2.2.2/1/Source/Icons/TTBMDIWindowItem.bmp new file mode 100644 index 0000000..431011f Binary files /dev/null and b/internal/2.2.2/1/Source/Icons/TTBMDIWindowItem.bmp differ diff --git a/internal/2.2.2/1/Source/Icons/TTBMRUList.bmp b/internal/2.2.2/1/Source/Icons/TTBMRUList.bmp new file mode 100644 index 0000000..ccd304e Binary files /dev/null and b/internal/2.2.2/1/Source/Icons/TTBMRUList.bmp differ diff --git a/internal/2.2.2/1/Source/Icons/TTBMRUList16.bmp b/internal/2.2.2/1/Source/Icons/TTBMRUList16.bmp new file mode 100644 index 0000000..48654a6 Binary files /dev/null and b/internal/2.2.2/1/Source/Icons/TTBMRUList16.bmp differ diff --git a/internal/2.2.2/1/Source/Icons/TTBMRUListItem.bmp b/internal/2.2.2/1/Source/Icons/TTBMRUListItem.bmp new file mode 100644 index 0000000..b8b5f41 Binary files /dev/null and b/internal/2.2.2/1/Source/Icons/TTBMRUListItem.bmp differ diff --git a/internal/2.2.2/1/Source/Icons/TTBPopupMenu.bmp b/internal/2.2.2/1/Source/Icons/TTBPopupMenu.bmp new file mode 100644 index 0000000..2a485e5 Binary files /dev/null and b/internal/2.2.2/1/Source/Icons/TTBPopupMenu.bmp differ diff --git a/internal/2.2.2/1/Source/Icons/TTBPopupMenu16.bmp b/internal/2.2.2/1/Source/Icons/TTBPopupMenu16.bmp new file mode 100644 index 0000000..b3504ed Binary files /dev/null and b/internal/2.2.2/1/Source/Icons/TTBPopupMenu16.bmp differ diff --git a/internal/2.2.2/1/Source/Icons/TTBToolWindow.bmp b/internal/2.2.2/1/Source/Icons/TTBToolWindow.bmp new file mode 100644 index 0000000..48981e5 Binary files /dev/null and b/internal/2.2.2/1/Source/Icons/TTBToolWindow.bmp differ diff --git a/internal/2.2.2/1/Source/Icons/TTBToolWindow16.bmp b/internal/2.2.2/1/Source/Icons/TTBToolWindow16.bmp new file mode 100644 index 0000000..bc2712f Binary files /dev/null and b/internal/2.2.2/1/Source/Icons/TTBToolWindow16.bmp differ diff --git a/internal/2.2.2/1/Source/Icons/TTBToolbar.bmp b/internal/2.2.2/1/Source/Icons/TTBToolbar.bmp new file mode 100644 index 0000000..557096b Binary files /dev/null and b/internal/2.2.2/1/Source/Icons/TTBToolbar.bmp differ diff --git a/internal/2.2.2/1/Source/Icons/TTBToolbar16.bmp b/internal/2.2.2/1/Source/Icons/TTBToolbar16.bmp new file mode 100644 index 0000000..80c1d66 Binary files /dev/null and b/internal/2.2.2/1/Source/Icons/TTBToolbar16.bmp differ diff --git a/internal/2.2.2/1/Source/Icons/Thumbs.db b/internal/2.2.2/1/Source/Icons/Thumbs.db new file mode 100644 index 0000000..b8cd70c Binary files /dev/null and b/internal/2.2.2/1/Source/Icons/Thumbs.db differ diff --git a/internal/2.2.2/1/Source/TB2Acc.pas b/internal/2.2.2/1/Source/TB2Acc.pas new file mode 100644 index 0000000..bcfd73b --- /dev/null +++ b/internal/2.2.2/1/Source/TB2Acc.pas @@ -0,0 +1,1393 @@ +unit TB2Acc; + +{ + Toolbar2000 + Copyright (C) 1998-2008 by Jordan Russell + All rights reserved. + + The contents of this file are subject to the "Toolbar2000 License"; you may + not use or distribute this file except in compliance with the + "Toolbar2000 License". A copy of the "Toolbar2000 License" may be found in + TB2k-LICENSE.txt or at: + http://www.jrsoftware.org/files/tb2k/TB2k-LICENSE.txt + + Alternatively, the contents of this file may be used under the terms of the + GNU General Public License (the "GPL"), in which case the provisions of the + GPL are applicable instead of those in the "Toolbar2000 License". A copy of + the GPL may be found in GPL-LICENSE.txt or at: + http://www.jrsoftware.org/files/tb2k/GPL-LICENSE.txt + If you wish to allow use of your version of this file only under the terms of + the GPL and not to allow others to use your version of this file under the + "Toolbar2000 License", indicate your decision by deleting the provisions + above and replace them with the notice and other provisions required by the + GPL. If you do not delete the provisions above, a recipient may use your + version of this file under either the "Toolbar2000 License" or the GPL. + + $jrsoftware: tb2k/Source/TB2Acc.pas,v 1.9 2008/04/19 05:31:00 jr Exp $ + + This unit is used internally to implement the IAccessible interface on + TTBView and TTBItemViewer for Microsoft Active Accessibility support. +} + +interface + +{$I TB2Ver.inc} + +uses + Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs, + {$IFDEF CLR} System.Runtime.InteropServices, {$ENDIF} + TB2Item; + +type + { Our declaration for IAccessible } + {$IFNDEF CLR} + TTBVariant = OleVariant; + ITBAccessible = interface(IDispatch) + ['{618736E0-3C3D-11CF-810C-00AA00389B71}'] + function get_accParent(out ppdispParent: IDispatch): HRESULT; stdcall; + function get_accChildCount(out pcountChildren: Integer): HRESULT; stdcall; + function get_accChild(varChild: TTBVariant; out ppdispChild: IDispatch): HRESULT; stdcall; + function get_accName(varChild: TTBVariant; out pszName: WideString): HRESULT; stdcall; + function get_accValue(varChild: TTBVariant; out pszValue: WideString): HRESULT; stdcall; + function get_accDescription(varChild: TTBVariant; out pszDescription: WideString): HRESULT; stdcall; + function get_accRole(varChild: TTBVariant; out pvarRole: TTBVariant): HRESULT; stdcall; + function get_accState(varChild: TTBVariant; out pvarState: TTBVariant): HRESULT; stdcall; + function get_accHelp(varChild: TTBVariant; out pszHelp: WideString): HRESULT; stdcall; + function get_accHelpTopic(out pszHelpFile: WideString; varChild: TTBVariant; out pidTopic: Integer): HRESULT; stdcall; + function get_accKeyboardShortcut(varChild: TTBVariant; out pszKeyboardShortcut: WideString): HRESULT; stdcall; + function get_accFocus(out pvarID: TTBVariant): HRESULT; stdcall; + function get_accSelection(out pvarChildren: TTBVariant): HRESULT; stdcall; + function get_accDefaultAction(varChild: TTBVariant; out pszDefaultAction: WideString): HRESULT; stdcall; + function accSelect(flagsSelect: Integer; varChild: TTBVariant): HRESULT; stdcall; + function accLocation(out pxLeft: Integer; out pyTop: Integer; out pcxWidth: Integer; + out pcyHeight: Integer; varChild: TTBVariant): HRESULT; stdcall; + function accNavigate(navDir: Integer; varStart: TTBVariant; out pvarEnd: TTBVariant): HRESULT; stdcall; + function accHitTest(xLeft: Integer; yTop: Integer; out pvarID: TTBVariant): HRESULT; stdcall; + function accDoDefaultAction(varChild: TTBVariant): HRESULT; stdcall; + function put_accName(varChild: TTBVariant; const pszName: WideString): HRESULT; stdcall; + function put_accValue(varChild: TTBVariant; const pszValue: WideString): HRESULT; stdcall; + end; + {$ELSE} + TTBVariant = TObject; + [ComImport, + GuidAttribute('618736E0-3C3D-11CF-810C-00AA00389B71'), + InterfaceTypeAttribute(ComInterfaceType.InterfaceIsDual)] + ITBAccessible = interface + [PreserveSig] + function get_accParent([out, MarshalAs(UnmanagedType.IDispatch)] out ppdispParent): HRESULT; + [PreserveSig] + function get_accChildCount(out pcountChildren: Integer): HRESULT; + [PreserveSig] + function get_accChild(varChild: TTBVariant; [out, MarshalAs(UnmanagedType.IDispatch)] out ppdispChild): HRESULT; + [PreserveSig] + function get_accName(varChild: TTBVariant; out pszName: WideString): HRESULT; + [PreserveSig] + function get_accValue(varChild: TTBVariant; out pszValue: WideString): HRESULT; + [PreserveSig] + function get_accDescription(varChild: TTBVariant; out pszDescription: WideString): HRESULT; + [PreserveSig] + function get_accRole(varChild: TTBVariant; out pvarRole: TTBVariant): HRESULT; + [PreserveSig] + function get_accState(varChild: TTBVariant; out pvarState: TTBVariant): HRESULT; + [PreserveSig] + function get_accHelp(varChild: TTBVariant; out pszHelp: WideString): HRESULT; + [PreserveSig] + function get_accHelpTopic(out pszHelpFile: WideString; varChild: TTBVariant; out pidTopic: Integer): HRESULT; + [PreserveSig] + function get_accKeyboardShortcut(varChild: TTBVariant; out pszKeyboardShortcut: WideString): HRESULT; + [PreserveSig] + function get_accFocus(out pvarID: TTBVariant): HRESULT; + [PreserveSig] + function get_accSelection(out pvarChildren: TTBVariant): HRESULT; + [PreserveSig] + function get_accDefaultAction(varChild: TTBVariant; out pszDefaultAction: WideString): HRESULT; + [PreserveSig] + function accSelect(flagsSelect: Integer; varChild: TTBVariant): HRESULT; + [PreserveSig] + function accLocation(out pxLeft: Integer; out pyTop: Integer; out pcxWidth: Integer; + out pcyHeight: Integer; varChild: TTBVariant): HRESULT; + [PreserveSig] + function accNavigate(navDir: Integer; varStart: TTBVariant; out pvarEnd: TTBVariant): HRESULT; + [PreserveSig] + function accHitTest(xLeft: Integer; yTop: Integer; out pvarID: TTBVariant): HRESULT; + [PreserveSig] + function accDoDefaultAction(varChild: TTBVariant): HRESULT; + [PreserveSig] + function put_accName(varChild: TTBVariant; const pszName: WideString): HRESULT; + [PreserveSig] + function put_accValue(varChild: TTBVariant; const pszValue: WideString): HRESULT; + end; + {$ENDIF} + + TTBCustomAccObject = class(TTBBaseAccObject) + private + {$IFNDEF CLR} + FPrevious, FNext: TTBCustomAccObject; + {$ENDIF} + public + {$IFNDEF CLR} + constructor Create; + destructor Destroy; override; + {$ENDIF} + end; + + {$IFDEF CLR} + { Note: Without ComVisible(true), attempts to return objects in IAccessible's + IDispatch-type out parameters fail with InvalidCastException } + [ComVisible(true)] + {$ENDIF} + TTBViewAccObject = class(TTBCustomAccObject, ITBAccessible) + private + FView: TTBView; + function Check(const varChild: TTBVariant; var ErrorCode: HRESULT): Boolean; + { ITBAccessible } + function accDoDefaultAction(varChild: TTBVariant): HRESULT; {$IFNDEF CLR}stdcall;{$ENDIF} + function accHitTest(xLeft: Integer; yTop: Integer; out pvarID: TTBVariant): HRESULT; {$IFNDEF CLR}stdcall;{$ENDIF} + function accLocation(out pxLeft: Integer; out pyTop: Integer; out pcxWidth: Integer; + out pcyHeight: Integer; varChild: TTBVariant): HRESULT; {$IFNDEF CLR}stdcall;{$ENDIF} + function accNavigate(navDir: Integer; varStart: TTBVariant; out pvarEnd: TTBVariant): HRESULT; {$IFNDEF CLR}stdcall;{$ENDIF} + function accSelect(flagsSelect: Integer; varChild: TTBVariant): HRESULT; {$IFNDEF CLR}stdcall;{$ENDIF} + function get_accChild(varChild: TTBVariant; out ppdispChild {$IFNDEF CLR}: IDispatch{$ENDIF}): HRESULT; {$IFNDEF CLR}stdcall;{$ENDIF} + function get_accChildCount(out pcountChildren: Integer): HRESULT; {$IFNDEF CLR}stdcall;{$ENDIF} + function get_accDefaultAction(varChild: TTBVariant; out pszDefaultAction: WideString): HRESULT; {$IFNDEF CLR}stdcall;{$ENDIF} + function get_accDescription(varChild: TTBVariant; out pszDescription: WideString): HRESULT; {$IFNDEF CLR}stdcall;{$ENDIF} + function get_accFocus(out pvarID: TTBVariant): HRESULT; {$IFNDEF CLR}stdcall;{$ENDIF} + function get_accHelp(varChild: TTBVariant; out pszHelp: WideString): HRESULT; {$IFNDEF CLR}stdcall;{$ENDIF} + function get_accHelpTopic(out pszHelpFile: WideString; varChild: TTBVariant; out pidTopic: Integer): HRESULT; {$IFNDEF CLR}stdcall;{$ENDIF} + function get_accKeyboardShortcut(varChild: TTBVariant; out pszKeyboardShortcut: WideString): HRESULT; {$IFNDEF CLR}stdcall;{$ENDIF} + function get_accName(varChild: TTBVariant; out pszName: WideString): HRESULT; {$IFNDEF CLR}stdcall;{$ENDIF} + function get_accParent(out ppdispParent {$IFNDEF CLR}: IDispatch{$ENDIF}): HRESULT; {$IFNDEF CLR}stdcall;{$ENDIF} + function get_accRole(varChild: TTBVariant; out pvarRole: TTBVariant): HRESULT; {$IFNDEF CLR}stdcall;{$ENDIF} + function get_accSelection(out pvarChildren: TTBVariant): HRESULT; {$IFNDEF CLR}stdcall;{$ENDIF} + function get_accState(varChild: TTBVariant; out pvarState: TTBVariant): HRESULT; {$IFNDEF CLR}stdcall;{$ENDIF} + function get_accValue(varChild: TTBVariant; out pszValue: WideString): HRESULT; {$IFNDEF CLR}stdcall;{$ENDIF} + function put_accName(varChild: TTBVariant; const pszName: WideString): HRESULT; {$IFNDEF CLR}stdcall;{$ENDIF} + function put_accValue(varChild: TTBVariant; const pszValue: WideString): HRESULT; {$IFNDEF CLR}stdcall;{$ENDIF} + {$IFDEF CLR} + strict protected + procedure Finalize; override; + {$ENDIF} + public + constructor Create(AView: TTBView); + {$IFNDEF CLR} + destructor Destroy; override; + {$ENDIF} + procedure ClientIsDestroying; override; + end; + + {$IFDEF CLR} + [ComVisible(true)] + {$ENDIF} + TTBItemViewerAccObject = class(TTBCustomAccObject, ITBAccessible) + private + FViewer: TTBItemViewer; + function Check(const varChild: TTBVariant; var ErrorCode: HRESULT): Boolean; + function IsActionable: Boolean; + function IsAvailable: Boolean; + function IsFocusable: Boolean; + { ITBAccessible } + function accDoDefaultAction(varChild: TTBVariant): HRESULT; {$IFNDEF CLR}stdcall;{$ENDIF} + function accHitTest(xLeft: Integer; yTop: Integer; out pvarID: TTBVariant): HRESULT; {$IFNDEF CLR}stdcall;{$ENDIF} + function accLocation(out pxLeft: Integer; out pyTop: Integer; out pcxWidth: Integer; + out pcyHeight: Integer; varChild: TTBVariant): HRESULT; {$IFNDEF CLR}stdcall;{$ENDIF} + function accNavigate(navDir: Integer; varStart: TTBVariant; out pvarEnd: TTBVariant): HRESULT; {$IFNDEF CLR}stdcall;{$ENDIF} + function accSelect(flagsSelect: Integer; varChild: TTBVariant): HRESULT; {$IFNDEF CLR}stdcall;{$ENDIF} + function get_accChild(varChild: TTBVariant; out ppdispChild {$IFNDEF CLR}: IDispatch{$ENDIF}): HRESULT; {$IFNDEF CLR}stdcall;{$ENDIF} + function get_accChildCount(out pcountChildren: Integer): HRESULT; {$IFNDEF CLR}stdcall;{$ENDIF} + function get_accDefaultAction(varChild: TTBVariant; out pszDefaultAction: WideString): HRESULT; {$IFNDEF CLR}stdcall;{$ENDIF} + function get_accDescription(varChild: TTBVariant; out pszDescription: WideString): HRESULT; {$IFNDEF CLR}stdcall;{$ENDIF} + function get_accFocus(out pvarID: TTBVariant): HRESULT; {$IFNDEF CLR}stdcall;{$ENDIF} + function get_accHelp(varChild: TTBVariant; out pszHelp: WideString): HRESULT; {$IFNDEF CLR}stdcall;{$ENDIF} + function get_accHelpTopic(out pszHelpFile: WideString; varChild: TTBVariant; out pidTopic: Integer): HRESULT; {$IFNDEF CLR}stdcall;{$ENDIF} + function get_accKeyboardShortcut(varChild: TTBVariant; out pszKeyboardShortcut: WideString): HRESULT; {$IFNDEF CLR}stdcall;{$ENDIF} + function get_accName(varChild: TTBVariant; out pszName: WideString): HRESULT; {$IFNDEF CLR}stdcall;{$ENDIF} + function get_accParent(out ppdispParent {$IFNDEF CLR}: IDispatch{$ENDIF}): HRESULT; {$IFNDEF CLR}stdcall;{$ENDIF} + function get_accRole(varChild: TTBVariant; out pvarRole: TTBVariant): HRESULT; {$IFNDEF CLR}stdcall;{$ENDIF} + function get_accSelection(out pvarChildren: TTBVariant): HRESULT; {$IFNDEF CLR}stdcall;{$ENDIF} + function get_accState(varChild: TTBVariant; out pvarState: TTBVariant): HRESULT; {$IFNDEF CLR}stdcall;{$ENDIF} + function get_accValue(varChild: TTBVariant; out pszValue: WideString): HRESULT; {$IFNDEF CLR}stdcall;{$ENDIF} + function put_accName(varChild: TTBVariant; const pszName: WideString): HRESULT; {$IFNDEF CLR}stdcall;{$ENDIF} + function put_accValue(varChild: TTBVariant; const pszValue: WideString): HRESULT; {$IFNDEF CLR}stdcall;{$ENDIF} + {$IFDEF CLR} + strict protected + procedure Finalize; override; + {$ENDIF} + public + constructor Create(AViewer: TTBItemViewer); + {$IFNDEF CLR} + destructor Destroy; override; + {$ENDIF} + procedure ClientIsDestroying; override; + procedure HandleAccSelect(const AExecute: Boolean); + end; + +procedure CallNotifyWinEvent(event: DWORD; hwnd: HWND; idObject: DWORD; + idChild: Longint); +function InitializeOleAcc: Boolean; + +{$IFNDEF CLR} +var + LresultFromObjectFunc: function(const riid: TGUID; wParam: WPARAM; + pUnk: IUnknown): LRESULT; stdcall; + AccessibleObjectFromWindowFunc: function(hwnd: HWND; dwId: DWORD; + const riid: TGUID; out ppvObject): HRESULT; stdcall; +{$ELSE} +function LresultFromObjectFunc([in, MarshalAs(UnmanagedType.LPStruct)] riid: TGUID; + wParam: WPARAM; [in, MarshalAs(UnmanagedType.IUnknown)] pUnk: TObject): LRESULT; +function AccessibleObjectFromWindowFunc(hwnd: HWND; dwId: DWORD; + [in, MarshalAs(UnmanagedType.LPStruct)] riid: TGUID; + [MarshalAs(UnmanagedType.Interface)] out ppvObject): HRESULT; +{$ENDIF} + +var + { For debugging purposes only: } + ViewAccObjectInstances: Integer = 0; + ItemViewerAccObjectInstances: Integer = 0; + +implementation + +uses + {$IFDEF CLR} System.Security, System.Threading, Types, {$ENDIF} + {$IFNDEF CLR} {$IFDEF JR_D6} Variants, {$ENDIF} {$ENDIF} + ActiveX, Menus, TB2Common; + +const + { Constants from OleAcc.h } + ROLE_SYSTEM_MENUBAR = $2; + ROLE_SYSTEM_CLIENT = $a; + ROLE_SYSTEM_MENUPOPUP = $b; + ROLE_SYSTEM_MENUITEM = $c; + ROLE_SYSTEM_SEPARATOR = $15; + ROLE_SYSTEM_TOOLBAR = $16; + ROLE_SYSTEM_PUSHBUTTON = $2b; + ROLE_SYSTEM_BUTTONMENU = $39; + + STATE_SYSTEM_HASPOPUP = $40000000; + + NAVDIR_UP = 1; + NAVDIR_DOWN = 2; + NAVDIR_LEFT = 3; + NAVDIR_RIGHT = 4; + NAVDIR_NEXT = 5; + NAVDIR_PREVIOUS = 6; + NAVDIR_FIRSTCHILD = 7; + NAVDIR_LASTCHILD = 8; + + SELFLAG_TAKEFOCUS = 1; + +type + {$IFNDEF CLR} + TControlAccess = class(TControl); + {$ENDIF} + TTBViewAccess = class(TTBView); + TTBCustomItemAccess = class(TTBCustomItem); + TTBItemViewerAccess = class(TTBItemViewer); + +{$IFNDEF CLR} +var + LastAccObject: TTBCustomAccObject; { last object in the linked list } + LastAccObjectCritSect: TRTLCriticalSection; + + NotifyWinEventInited: BOOL; + NotifyWinEventFunc: procedure(event: DWORD; hwnd: HWND; idObject: Longint; + idChild: Longint); stdcall; +{$ENDIF} + +{$IFDEF CLR} +[SuppressUnmanagedCodeSecurity, DllImport('oleacc.dll', CharSet = CharSet.Ansi, SetLastError = True, EntryPoint = 'LresultFromObject')] +function LresultFromObjectFunc; external; +[SuppressUnmanagedCodeSecurity, DllImport('oleacc.dll', CharSet = CharSet.Ansi, SetLastError = True, EntryPoint = 'AccessibleObjectFromWindow')] +function AccessibleObjectFromWindowFunc; external; +{$ENDIF} + +procedure CallNotifyWinEvent(event: DWORD; hwnd: HWND; idObject: DWORD; + idChild: Longint); +begin + {$IFNDEF CLR} + if not NotifyWinEventInited then begin + NotifyWinEventFunc := GetProcAddress(GetModuleHandle(user32), 'NotifyWinEvent'); + InterlockedExchange(Integer(NotifyWinEventInited), Ord(True)); + end; + if Assigned(NotifyWinEventFunc) then + NotifyWinEventFunc(event, hwnd, Longint(idObject), idChild); + {$ELSE} + { NotifyWinEvent is supported on all platforms .NET supports } + NotifyWinEvent(event, hwnd, Longint(idObject), idChild); + {$ENDIF} +end; + +var + OleAccInited: Integer; + OleAccAvailable: BOOL; + +function InitializeOleAcc: Boolean; +var + M: HMODULE; +begin + if OleAccInited = 0 then begin + M := {$IFDEF JR_D5} SafeLoadLibrary {$ELSE} LoadLibrary {$ENDIF} ('oleacc.dll'); + if M <> 0 then begin + {$IFNDEF CLR} + LresultFromObjectFunc := GetProcAddress(M, 'LresultFromObject'); + AccessibleObjectFromWindowFunc := GetProcAddress(M, 'AccessibleObjectFromWindow'); + if Assigned(LresultFromObjectFunc) and + Assigned(AccessibleObjectFromWindowFunc) then + {$ENDIF} + OleAccAvailable := True; + end; + InterlockedExchange(OleAccInited, 1); + end; + Result := OleAccAvailable; +end; + +{$IFNDEF CLR} +function AccObjectFromWindow(const Wnd: HWND; out ADisp: IDispatch): HRESULT; +begin + Result := AccessibleObjectFromWindowFunc(Wnd, OBJID_WINDOW, IDispatch, ADisp); + if Result <> S_OK then + ADisp := nil; +end; +{$ELSE} +function AccObjectFromWindow(const Wnd: HWND; out ADisp): HRESULT; +begin + Result := AccessibleObjectFromWindowFunc(Wnd, OBJID_WINDOW, + TypeOf(IDispatch).GUID, ADisp); + if Result <> S_OK then + ADisp := nil; +end; +{$ENDIF} + +{$IFNDEF CLR} +procedure DisconnectAccObjects; +{ This procedure calls CoDisconnectObject() on all acc. objects still + allocated. This is needed to prevent potential AV's when TB2k is compiled + into a DLL, since a DLL may be freed by the application while an MSAA + client still holds acc. object references. } +var + Obj, PrevObj: TTBCustomAccObject; +begin + Obj := LastAccObject; + while Assigned(Obj) do begin + { Make a copy of Obj.FPrevious since CoDisconnectObject may cause Obj + to be freed } + PrevObj := Obj.FPrevious; + { CoDisconnectObject should cause remote MSAA clients to release all + references to the object, thus destroying it (assuming the local + application doesn't have references of its own). } + CoDisconnectObject(Obj, 0); + Obj := PrevObj; + end; +end; +{$ELSE} +{ DisconnectAccObjects isn't implemented on .NET because: + - I'm not sure it's needed (the case mentioned above doesn't apply). + - Keeping references to objects in a global linked list would prevent the GC + from ever reclaiming the unused ones. + - The current implementation of TTBStandardOleMarshalObject.DisconnectObject + always returns E_NOTIMPL, so CoDisconnectObject would fail. + - Windows Forms doesn't appear to do it. (Its accessible objects are + derived from StandardOleMarshalObject, and they don't appear to override + the default E_NOTIMPL handling.) } +{$ENDIF} + +function GetAltKeyName: String; +{ This silly function is needed since ShortCutToText(VK_MENU) fails on Delphi + and C++Builder versions <= 4 } +{$IFNDEF CLR} +var + ScanCode: UINT; + KeyName: array[0..255] of Char; +begin + ScanCode := MapVirtualKey(VK_MENU, 0) shl 16; + if (ScanCode <> 0) and + (GetKeyNameText(ScanCode, KeyName, SizeOf(KeyName) div SizeOf(KeyName[0])) > 0) then + Result := KeyName + else + Result := 'Alt'; { shouldn't get here, but just in case... } +end; +{$ELSE} +begin + Result := ShortCutToText(VK_MENU); +end; +{$ENDIF} + +function VarIsInteger(const AVar: TTBVariant): Boolean; +{ Returns True if the specified variant is of type VT_I4, the only integer + type used/allowed in MSAA } +begin + {$IFNDEF CLR} + Result := (VarType(AVar) = varInteger); + {$ELSE} + Result := Assigned(AVar) and (System.Type.GetTypeCode(AVar.GetType) = TypeCode.Int32); + {$ENDIF} +end; + +procedure AssignObjectToVar(var AVariant: TTBVariant; const AObject: TTBBaseAccObject); +{ Creates a VT_DISPATCH-type variant that references AObject } +begin + {$IFNDEF CLR} + AVariant := IDispatch(AObject); + {$ELSE} + AVariant := AObject; + {$ENDIF} +end; + +{ TTBCustomAccObject } + +{$IFNDEF CLR} +constructor TTBCustomAccObject.Create; +begin + inherited Create; + { Add Self to linked list of objects } + EnterCriticalSection(LastAccObjectCritSect); + try + FPrevious := LastAccObject; + if Assigned(FPrevious) then + FPrevious.FNext := Self; + LastAccObject := Self; + finally + LeaveCriticalSection(LastAccObjectCritSect); + end; +end; +{$ENDIF} + +{$IFNDEF CLR} +destructor TTBCustomAccObject.Destroy; +begin + { Remove Self from linked list of objects } + EnterCriticalSection(LastAccObjectCritSect); + try + if LastAccObject = Self then + LastAccObject := FPrevious; + if Assigned(FPrevious) then + FPrevious.FNext := FNext; + if Assigned(FNext) then + FNext.FPrevious := FPrevious; + finally + LeaveCriticalSection(LastAccObjectCritSect); + end; + inherited; +end; +{$ENDIF} + +{ TTBViewAccObject } + +constructor TTBViewAccObject.Create(AView: TTBView); +begin + inherited Create; + FView := AView; + InterlockedIncrement(ViewAccObjectInstances); +end; + +{$IFNDEF CLR} +destructor TTBViewAccObject.Destroy; +begin + InterlockedDecrement(ViewAccObjectInstances); + if Assigned(FView) then begin + TTBViewAccess(FView).FAccObjectInstance := nil; + FView := nil; + end; + inherited; +end; +{$ELSE} +procedure TTBViewAccObject.Finalize; +begin + InterlockedDecrement(ViewAccObjectInstances); + inherited; +end; +{$ENDIF} + +procedure TTBViewAccObject.ClientIsDestroying; +begin + FView := nil; +end; + +function TTBViewAccObject.Check(const varChild: TTBVariant; + var ErrorCode: HRESULT): Boolean; +begin + if FView = nil then begin + ErrorCode := E_FAIL; + Result := False; + end + else if not VarIsInteger(varChild) or (Integer(varChild) <> CHILDID_SELF) then begin + ErrorCode := E_INVALIDARG; + Result := False; + end + else + Result := True; +end; + +function TTBViewAccObject.accDoDefaultAction(varChild: TTBVariant): HRESULT; +begin + Result := S_FALSE; +end; + +function TTBViewAccObject.accHitTest(xLeft, yTop: Integer; + out pvarID: TTBVariant): HRESULT; +var + ViewWnd, W: HWND; + R: TRect; + P: TPoint; + D: {$IFNDEF CLR} IDispatch {$ELSE} TObject {$ENDIF}; + V: TTBItemViewer; +begin + try + if FView = nil then begin + Result := E_FAIL; + Exit; + end; + ViewWnd := FView.Window.Handle; + GetWindowRect(ViewWnd, R); + P.X := xLeft; + P.Y := yTop; + if PtInRect(R, P) then begin + P := FView.Window.ScreenToClient(P); + W := ChildWindowFromPointEx(ViewWnd, P, CWP_SKIPINVISIBLE); + if (W <> 0) and (W <> ViewWnd) then begin + { Point is inside a child window (most likely belonging to a + TTBControlItem) } + Result := AccObjectFromWindow(W, D); + pvarID := D; + end + else begin + V := FView.ViewerFromPoint(P); + if Assigned(V) then + AssignObjectToVar(pvarID, V.GetAccObject) + else + pvarID := TTBVariant(Integer(CHILDID_SELF)); + Result := S_OK; + end; + end + else + Result := S_FALSE; + except + Result := E_UNEXPECTED; + end; +end; + +function TTBViewAccObject.accLocation(out pxLeft, pyTop, pcxWidth, + pcyHeight: Integer; varChild: TTBVariant): HRESULT; +var + R: TRect; +begin + try + if not Check(varChild, Result) then + Exit; + GetWindowRect(FView.Window.Handle, R); + pxLeft := R.Left; + pyTop := R.Top; + pcxWidth := R.Right - R.Left; + pcyHeight := R.Bottom - R.Top; + Result := S_OK; + except + Result := E_UNEXPECTED; + end; +end; + +function TTBViewAccObject.accNavigate(navDir: Integer; varStart: TTBVariant; + out pvarEnd: TTBVariant): HRESULT; +var + I: Integer; +begin + try + if not Check(varStart, Result) then + Exit; + Result := S_FALSE; + case navDir of + NAVDIR_FIRSTCHILD: begin + for I := 0 to FView.ViewerCount-1 do + if FView.Viewers[I].IsAccessible then begin + AssignObjectToVar(pvarEnd, FView.Viewers[I].GetAccObject); + Result := S_OK; + Break; + end; + end; + NAVDIR_LASTCHILD: begin + for I := FView.ViewerCount-1 downto 0 do + if FView.Viewers[I].IsAccessible then begin + AssignObjectToVar(pvarEnd, FView.Viewers[I].GetAccObject); + Result := S_OK; + Break; + end; + end; + end; + except + Result := E_UNEXPECTED; + end; +end; + +function TTBViewAccObject.accSelect(flagsSelect: Integer; + varChild: TTBVariant): HRESULT; +begin + Result := DISP_E_MEMBERNOTFOUND; +end; + +function TTBViewAccObject.get_accChild(varChild: TTBVariant; + out ppdispChild {$IFNDEF CLR}: IDispatch{$ENDIF}): HRESULT; +var + I, J: Integer; + Viewer: TTBItemViewer; + Ctl: TControl; +begin + try + if FView = nil then begin + Result := E_FAIL; + Exit; + end; + if not VarIsInteger(varChild) then begin + Result := E_INVALIDARG; + Exit; + end; + I := Integer(varChild); + if I = CHILDID_SELF then begin + ppdispChild := Self; + Result := S_OK; + end + else begin + { Convert a one-based child index (I) into a real viewer index (J) } + J := 0; + while J < FView.ViewerCount do begin + if FView.Viewers[J].IsAccessible then begin + if I = 1 then Break; + Dec(I); + end; + Inc(J); + end; + if J >= FView.ViewerCount then begin + { 'I' was either negative or too high } + Result := E_INVALIDARG; + Exit; + end; + Viewer := FView.Viewers[J]; + if Viewer.Item is TTBControlItem then begin + { For windowed controls, return the window's accessible object instead + of the item viewer's } + Ctl := TTBControlItem(Viewer.Item).Control; + if (Ctl is TWinControl) and TWinControl(Ctl).HandleAllocated then begin + Result := AccObjectFromWindow(TWinControl(Ctl).Handle, ppdispChild); + Exit; + end; + end; + ppdispChild := Viewer.GetAccObject; + Result := S_OK; + end; + except + Result := E_UNEXPECTED; + end; +end; + +function TTBViewAccObject.get_accChildCount(out pcountChildren: Integer): HRESULT; +var + Count, I: Integer; +begin + try + if Assigned(FView) then begin + Count := 0; + for I := 0 to FView.ViewerCount-1 do + if FView.Viewers[I].IsAccessible then + Inc(Count); + pCountChildren := Count; + Result := S_OK; + end + else + Result := E_FAIL; + except + Result := E_UNEXPECTED; + end; +end; + +function TTBViewAccObject.get_accDefaultAction(varChild: TTBVariant; + out pszDefaultAction: WideString): HRESULT; +begin + Result := S_FALSE; +end; + +function TTBViewAccObject.get_accDescription(varChild: TTBVariant; + out pszDescription: WideString): HRESULT; +begin + Result := S_FALSE; +end; + +function TTBViewAccObject.get_accFocus(out pvarID: TTBVariant): HRESULT; +begin + Result := S_FALSE; +end; + +function TTBViewAccObject.get_accHelp(varChild: TTBVariant; + out pszHelp: WideString): HRESULT; +begin + Result := S_FALSE; +end; + +function TTBViewAccObject.get_accHelpTopic(out pszHelpFile: WideString; + varChild: TTBVariant; out pidTopic: Integer): HRESULT; +begin + pidTopic := 0; { Delphi doesn't implicitly clear Integer 'out' parameters } + Result := S_FALSE; +end; + +function TTBViewAccObject.get_accKeyboardShortcut(varChild: TTBVariant; + out pszKeyboardShortcut: WideString): HRESULT; +begin + try + if not Check(varChild, Result) then + Exit; + if vsMenuBar in FView.Style then begin + pszKeyboardShortcut := GetAltKeyName; + Result := S_OK; + end + else + Result := S_FALSE; + except + Result := E_UNEXPECTED; + end; +end; + +function TTBViewAccObject.get_accName(varChild: TTBVariant; + out pszName: WideString): HRESULT; +var + S: String; +begin + try + if not Check(varChild, Result) then + Exit; + if Assigned(FView.ParentView) and Assigned(FView.ParentView.OpenViewer) then + S := StripAccelChars(TTBItemViewerAccess(FView.ParentView.OpenViewer).GetCaptionText); + if S = '' then + {$IFNDEF CLR} + S := TControlAccess(FView.Window).Caption; + {$ELSE} + S := FView.Window.GetText; + {$ENDIF} + pszName := S; + Result := S_OK; + except + Result := E_UNEXPECTED; + end; +end; + +function TTBViewAccObject.get_accParent(out ppdispParent {$IFNDEF CLR}: IDispatch{$ENDIF}): HRESULT; +begin + try + if Assigned(FView) then begin + if Assigned(FView.ParentView) and Assigned(FView.ParentView.OpenViewer) then begin + ppdispParent := FView.ParentView.OpenViewer.GetAccObject; + Result := S_OK; + end + else + Result := AccObjectFromWindow(FView.Window.Handle, ppdispParent); + end + else + Result := E_FAIL; + except + Result := E_UNEXPECTED; + end; +end; + +function TTBViewAccObject.get_accRole(varChild: TTBVariant; + out pvarRole: TTBVariant): HRESULT; +var + Role: Integer; +begin + try + if not Check(varChild, Result) then + Exit; + if FView.IsPopup then + Role := ROLE_SYSTEM_MENUPOPUP + else begin + if vsMenuBar in FView.Style then + Role := ROLE_SYSTEM_MENUBAR + else + Role := ROLE_SYSTEM_TOOLBAR; + end; + pvarRole := TTBVariant(Role); + Result := S_OK; + except + Result := E_UNEXPECTED; + end; +end; + +function TTBViewAccObject.get_accSelection(out pvarChildren: TTBVariant): HRESULT; +begin + Result := S_FALSE; +end; + +function TTBViewAccObject.get_accState(varChild: TTBVariant; + out pvarState: TTBVariant): HRESULT; +begin + try + if not Check(varChild, Result) then + Exit; + pvarState := TTBVariant(Integer(0)); + Result := S_OK; + except + Result := E_UNEXPECTED; + end; +end; + +function TTBViewAccObject.get_accValue(varChild: TTBVariant; + out pszValue: WideString): HRESULT; +begin + Result := S_FALSE; +end; + +function TTBViewAccObject.put_accName(varChild: TTBVariant; + const pszName: WideString): HRESULT; +begin + Result := S_FALSE; +end; + +function TTBViewAccObject.put_accValue(varChild: TTBVariant; + const pszValue: WideString): HRESULT; +begin + Result := S_FALSE; +end; + +{ TTBItemViewerAccObject } + +constructor TTBItemViewerAccObject.Create(AViewer: TTBItemViewer); +begin + inherited Create; + FViewer := AViewer; + InterlockedIncrement(ItemViewerAccObjectInstances); +end; + +{$IFNDEF CLR} +destructor TTBItemViewerAccObject.Destroy; +begin + InterlockedDecrement(ItemViewerAccObjectInstances); + if Assigned(FViewer) then begin + TTBItemViewerAccess(FViewer).FAccObjectInstance := nil; + FViewer := nil; + end; + inherited; +end; +{$ELSE} +procedure TTBItemViewerAccObject.Finalize; +begin + InterlockedDecrement(ItemViewerAccObjectInstances); + inherited; +end; +{$ENDIF} + +procedure TTBItemViewerAccObject.ClientIsDestroying; +begin + FViewer := nil; +end; + +function TTBItemViewerAccObject.Check(const varChild: TTBVariant; + var ErrorCode: HRESULT): Boolean; +begin + if FViewer = nil then begin + ErrorCode := E_FAIL; + Result := False; + end + else if not VarIsInteger(varChild) or (Integer(varChild) <> CHILDID_SELF) then begin + ErrorCode := E_INVALIDARG; + Result := False; + end + else + Result := True; +end; + +function TTBItemViewerAccObject.IsActionable: Boolean; +{ Returns True if 'doDefaultAction' may be performed on the viewer, i.e. if + it's visible/off-edge/clipped, enabled & selectable, and the view is + focusable. } +begin + Result := FViewer.IsAccessible and IsAvailable and IsFocusable; +end; + +function TTBItemViewerAccObject.IsAvailable: Boolean; +{ Returns True if the viewer's item is enabled and selectable } +begin + Result := FViewer.Item.Enabled and + (tbisSelectable in TTBCustomItemAccess(FViewer.Item).ItemStyle); +end; + +function TTBItemViewerAccObject.IsFocusable: Boolean; +{ Returns True if viewers on the view can be 'focused' (i.e. the view's window + doesn't have the csDesigning state, the window is visible and enabled, and + the application is active). } + + function IsWindowAndParentsEnabled(W: HWND): Boolean; + begin + Result := True; + repeat + if not IsWindowEnabled(W) then begin + Result := False; + Break; + end; + W := GetParent(W); + until W = 0; + end; + +var + ViewWnd, ActiveWnd: HWND; +begin + Result := False; + if csDesigning in FViewer.View.Window.ComponentState then + Exit; + ViewWnd := FViewer.View.Window.Handle; + if IsWindowVisible(ViewWnd) and IsWindowAndParentsEnabled(ViewWnd) then begin + if vsModal in FViewer.View.State then + Result := True + else begin + ActiveWnd := GetActiveWindow; + if (ActiveWnd <> 0) and + ((ActiveWnd = ViewWnd) or IsChild(ActiveWnd, ViewWnd)) then + Result := True; + end; + end; +end; + +procedure TTBItemViewerAccObject.HandleAccSelect(const AExecute: Boolean); +begin + if Assigned(FViewer) and + ((AExecute and IsActionable) or (not AExecute and IsFocusable)) then begin + FViewer.View.Selected := FViewer; + FViewer.View.ScrollSelectedIntoView; + if vsModal in FViewer.View.State then begin + if AExecute then + FViewer.View.ExecuteSelected(False); + end + else if (FViewer.View.ParentView = nil) and (GetCapture = 0) then begin + if AExecute then + FViewer.View.EnterToolbarLoop([tbetExecuteSelected, tbetFromMSAA]) + else + FViewer.View.EnterToolbarLoop([tbetFromMSAA]); + end; + end; +end; + +function TTBItemViewerAccObject.accDoDefaultAction(varChild: TTBVariant): HRESULT; +begin + try + if not Check(varChild, Result) then + Exit; + { NOTE: This must be kept in synch with get_accDefaultAction } + if IsActionable then begin + Result := S_OK; + if FViewer.View.OpenViewer = FViewer then begin + FViewer.View.CancelChildPopups; + { Like standard menus, cancel the modal loop when a top-level menu + is closed } + if (vsModal in FViewer.View.State) and not FViewer.View.IsPopup then + FViewer.View.EndModal; + end + else begin + FViewer.View.Selected := FViewer; + FViewer.View.ScrollSelectedIntoView; + TTBItemViewerAccess(FViewer).PostAccSelect(True); + end; + end + else + { Note: Standard menus return DISP_E_MEMBERNOTFOUND in this case but + that doesn't make much sense. The member is there but just isn't + currently available. } + Result := E_FAIL; + except + Result := E_UNEXPECTED; + end; +end; + +function TTBItemViewerAccObject.accHitTest(xLeft, yTop: Integer; + out pvarID: TTBVariant): HRESULT; +var + P: TPoint; +begin + try + if FViewer = nil then begin + Result := E_FAIL; + Exit; + end; + P := FViewer.View.Window.ScreenToClient(Point(xLeft, yTop)); + if PtInRect(FViewer.BoundsRect, P) then begin + pvarID := TTBVariant(Integer(CHILDID_SELF)); + Result := S_OK; + end + else + Result := S_FALSE; + except + Result := E_UNEXPECTED; + end; +end; + +function TTBItemViewerAccObject.accLocation(out pxLeft, pyTop, pcxWidth, + pcyHeight: Integer; varChild: TTBVariant): HRESULT; +var + R: TRect; + P: TPoint; +begin + try + if not Check(varChild, Result) then + Exit; + R := FViewer.BoundsRect; + P := FViewer.View.Window.ClientToScreen(Point(0, 0)); + OffsetRect(R, P.X, P.Y); + pxLeft := R.Left; + pyTop := R.Top; + pcxWidth := R.Right - R.Left; + pcyHeight := R.Bottom - R.Top; + Result := S_OK; + except + Result := E_UNEXPECTED; + end; +end; + +function TTBItemViewerAccObject.accNavigate(navDir: Integer; varStart: TTBVariant; + out pvarEnd: TTBVariant): HRESULT; +var + I, J: Integer; + View: TTBView; +begin + try + if not Check(varStart, Result) then + Exit; + Result := S_FALSE; + if (navDir = NAVDIR_FIRSTCHILD) or (navDir = NAVDIR_LASTCHILD) then begin + { Return the child view's acc. object } + View := FViewer.View.OpenViewerView; + if Assigned(View) then begin + AssignObjectToVar(pvarEnd, View.GetAccObject); + Result := S_OK; + end; + end + else begin + I := FViewer.View.IndexOf(FViewer); + if I >= 0 then begin + case navDir of + NAVDIR_UP, NAVDIR_LEFT, NAVDIR_PREVIOUS: + for J := I-1 downto 0 do + if FViewer.View.Viewers[J].IsAccessible then begin + AssignObjectToVar(pvarEnd, FViewer.View.Viewers[J].GetAccObject); + Result := S_OK; + Break; + end; + NAVDIR_DOWN, NAVDIR_RIGHT, NAVDIR_NEXT: + for J := I+1 to FViewer.View.ViewerCount-1 do + if FViewer.View.Viewers[J].IsAccessible then begin + AssignObjectToVar(pvarEnd, FViewer.View.Viewers[J].GetAccObject); + Result := S_OK; + Break; + end; + end; + end; + end; + except + Result := E_UNEXPECTED; + end; +end; + +function TTBItemViewerAccObject.accSelect(flagsSelect: Integer; + varChild: TTBVariant): HRESULT; +begin + try + if not Check(varChild, Result) then + Exit; + if flagsSelect <> SELFLAG_TAKEFOCUS then begin + Result := E_INVALIDARG; + Exit; + end; + if IsFocusable and (FViewer.Show or FViewer.Clipped) then begin + FViewer.View.Selected := FViewer; + FViewer.View.ScrollSelectedIntoView; + if not(vsModal in FViewer.View.State) and + (FViewer.View.ParentView = nil) then + TTBItemViewerAccess(FViewer).PostAccSelect(False); + end + else + Result := E_FAIL; + { ^ what Office XP returns when you try focusing an off-edge item } + except + Result := E_UNEXPECTED; + end; +end; + +function TTBItemViewerAccObject.get_accChild(varChild: TTBVariant; + out ppdispChild {$IFNDEF CLR}: IDispatch{$ENDIF}): HRESULT; +var + View: TTBView; +begin + try + if FViewer = nil then begin + Result := E_FAIL; + Exit; + end; + Result := E_INVALIDARG; + if VarIsInteger(varChild) then begin + if Integer(varChild) = CHILDID_SELF then begin + ppdispChild := Self; + Result := S_OK; + end + else if Integer(varChild) = 1 then begin + { Return the child view's acc. object } + View := FViewer.View.OpenViewerView; + if Assigned(View) then begin + ppdispChild := View.GetAccObject; + Result := S_OK; + end; + end; + end; + except + Result := E_UNEXPECTED; + end; +end; + +function TTBItemViewerAccObject.get_accChildCount(out pcountChildren: Integer): HRESULT; +begin + try + if FViewer = nil then begin + Result := E_FAIL; + Exit; + end; + { Return 1 if the viewer has a child view } + if FViewer.View.OpenViewer = FViewer then + pCountChildren := 1 + else + pCountChildren := 0; + Result := S_OK; + except + Result := E_UNEXPECTED; + end; +end; + +function TTBItemViewerAccObject.get_accDefaultAction(varChild: TTBVariant; + out pszDefaultAction: WideString): HRESULT; +begin + try + if not Check(varChild, Result) then + Exit; + if IsActionable then begin + { I'm not sure if these should be localized, or even if any screen + readers make use of this text... + NOTE: This must be kept in synch with accDoDefaultAction } + if FViewer.View.OpenViewer = FViewer then + pszDefaultAction := 'Close' + else if tbisSubmenu in TTBCustomItemAccess(FViewer.Item).ItemStyle then + pszDefaultAction := 'Open' + else if FViewer.View.IsPopup or (vsMenuBar in FViewer.View.Style) then + pszDefaultAction := 'Execute' + else + pszDefaultAction := 'Press'; + Result := S_OK; + end + else + Result := S_FALSE; + except + Result := E_UNEXPECTED; + end; +end; + +function TTBItemViewerAccObject.get_accDescription(varChild: TTBVariant; + out pszDescription: WideString): HRESULT; +begin + Result := S_FALSE; +end; + +function TTBItemViewerAccObject.get_accFocus(out pvarID: TTBVariant): HRESULT; +begin + try + if FViewer = nil then begin + Result := E_FAIL; + Exit; + end; + if (vsModal in FViewer.View.State) and + (FViewer.View.Selected = FViewer) then begin + pvarID := TTBVariant(Integer(CHILDID_SELF)); + Result := S_OK; + end + else + Result := S_FALSE; + except + Result := E_UNEXPECTED; + end; +end; + +function TTBItemViewerAccObject.get_accHelp(varChild: TTBVariant; + out pszHelp: WideString): HRESULT; +begin + Result := S_FALSE; +end; + +function TTBItemViewerAccObject.get_accHelpTopic(out pszHelpFile: WideString; + varChild: TTBVariant; out pidTopic: Integer): HRESULT; +begin + pidTopic := 0; { Delphi doesn't implicitly clear Integer 'out' parameters } + Result := S_FALSE; +end; + +function TTBItemViewerAccObject.get_accKeyboardShortcut(varChild: TTBVariant; + out pszKeyboardShortcut: WideString): HRESULT; +var + C: Char; +begin + try + if not Check(varChild, Result) then + Exit; + Result := S_FALSE; + if TTBItemViewerAccess(FViewer).CaptionShown then begin + C := FindAccelChar(TTBItemViewerAccess(FViewer).GetCaptionText); + if C <> #0 then begin + C := CharToLower(C); { like standard menus, always use lowercase... } + if FViewer.View.IsPopup then + pszKeyboardShortcut := C + else begin + { Prefix 'Alt+' } + pszKeyboardShortcut := GetAltKeyName + '+' + C; + end; + Result := S_OK; + end; + end; + except + Result := E_UNEXPECTED; + end; +end; + +function TTBItemViewerAccObject.get_accName(varChild: TTBVariant; + out pszName: WideString): HRESULT; +var + C, S: String; +begin + try + if not Check(varChild, Result) then + Exit; + C := StripAccelChars(TTBItemViewerAccess(FViewer).GetCaptionText); + if not FViewer.IsToolbarStyle then + S := FViewer.Item.GetShortCutText; + if S = '' then + pszName := C + else + pszName := C + #9 + S; + Result := S_OK; + except + Result := E_UNEXPECTED; + end; +end; + +function TTBItemViewerAccObject.get_accParent(out ppdispParent {$IFNDEF CLR}: IDispatch{$ENDIF}): HRESULT; +begin + try + if Assigned(FViewer) then begin + ppdispParent := FViewer.View.GetAccObject; + Result := S_OK; + end + else + Result := E_FAIL; + except + Result := E_UNEXPECTED; + end; +end; + +function TTBItemViewerAccObject.get_accRole(varChild: TTBVariant; + out pvarRole: TTBVariant): HRESULT; +begin + try + if not Check(varChild, Result) then + Exit; + pvarRole := TTBVariant(Integer(TTBItemViewerAccess(FViewer).GetAccRole)); + Result := S_OK; + except + Result := E_UNEXPECTED; + end; +end; + +function TTBItemViewerAccObject.get_accSelection(out pvarChildren: TTBVariant): HRESULT; +begin + Result := S_FALSE; +end; + +function TTBItemViewerAccObject.get_accState(varChild: TTBVariant; + out pvarState: TTBVariant): HRESULT; +var + Flags: Integer; +begin + try + if not Check(varChild, Result) then + Exit; + Flags := 0; + if FViewer.View.Selected = FViewer then begin + Flags := Flags or STATE_SYSTEM_HOTTRACKED; + if vsModal in FViewer.View.State then + Flags := Flags or STATE_SYSTEM_FOCUSED; + if FViewer.View.MouseOverSelected and FViewer.View.Capture then + { ^ based on "IsPushed :=" code in TTBView.DrawItem } + Flags := Flags or STATE_SYSTEM_PRESSED; + end; + if tbisSubmenu in TTBCustomItemAccess(FViewer.Item).ItemStyle then + Flags := Flags or STATE_SYSTEM_HASPOPUP; + if FViewer.Show or FViewer.Clipped then begin + if IsFocusable then + Flags := Flags or STATE_SYSTEM_FOCUSABLE; + end + else begin + { Mark off-edge items as invisible, like Office } + Flags := Flags or STATE_SYSTEM_INVISIBLE; + end; + if not IsAvailable then + Flags := Flags or STATE_SYSTEM_UNAVAILABLE; + if FViewer.Item.Checked then + Flags := Flags or STATE_SYSTEM_CHECKED; + pvarState := TTBVariant(Flags); + Result := S_OK; + except + Result := E_UNEXPECTED; + end; +end; + +function TTBItemViewerAccObject.get_accValue(varChild: TTBVariant; + out pszValue: WideString): HRESULT; +begin + try + if not Check(varChild, Result) then + Exit; + if TTBItemViewerAccess(FViewer).GetAccValue(pszValue) then + Result := S_OK + else begin + { When S_FALSE is returned, the Inspect tool wants NULL in pszValue. + On Delphi for Win32, '' is NULL. On .NET, we have to assign nil. } + pszValue := {$IFNDEF CLR} '' {$ELSE} nil {$ENDIF}; + Result := S_FALSE; + end; + except + Result := E_UNEXPECTED; + end; +end; + +function TTBItemViewerAccObject.put_accName(varChild: TTBVariant; + const pszName: WideString): HRESULT; +begin + Result := S_FALSE; +end; + +function TTBItemViewerAccObject.put_accValue(varChild: TTBVariant; + const pszValue: WideString): HRESULT; +begin + Result := S_FALSE; +end; + +{$IFNDEF CLR} +{ Note: This COM initialization code based on code from DBTables } +var + SaveInitProc: Pointer; + NeedToUninitialize: Boolean; + +procedure InitCOM; +begin + if SaveInitProc <> nil then TProcedure(SaveInitProc); + NeedToUninitialize := SUCCEEDED(CoInitialize(nil)); +end; + +initialization + InitializeCriticalSection(LastAccObjectCritSect); + if not IsLibrary then begin + SaveInitProc := InitProc; + InitProc := @InitCOM; + end; +finalization + DisconnectAccObjects; + if NeedToUninitialize then + CoUninitialize; + DeleteCriticalSection(LastAccObjectCritSect); +{$ENDIF} +end. diff --git a/internal/2.2.2/1/Source/TB2Anim.pas b/internal/2.2.2/1/Source/TB2Anim.pas new file mode 100644 index 0000000..96d9756 --- /dev/null +++ b/internal/2.2.2/1/Source/TB2Anim.pas @@ -0,0 +1,323 @@ +unit TB2Anim; + +{ + Toolbar2000 + Copyright (C) 1998-2008 by Jordan Russell + All rights reserved. + + The contents of this file are subject to the "Toolbar2000 License"; you may + not use or distribute this file except in compliance with the + "Toolbar2000 License". A copy of the "Toolbar2000 License" may be found in + TB2k-LICENSE.txt or at: + http://www.jrsoftware.org/files/tb2k/TB2k-LICENSE.txt + + Alternatively, the contents of this file may be used under the terms of the + GNU General Public License (the "GPL"), in which case the provisions of the + GPL are applicable instead of those in the "Toolbar2000 License". A copy of + the GPL may be found in GPL-LICENSE.txt or at: + http://www.jrsoftware.org/files/tb2k/GPL-LICENSE.txt + If you wish to allow use of your version of this file only under the terms of + the GPL and not to allow others to use your version of this file under the + "Toolbar2000 License", indicate your decision by deleting the provisions + above and replace them with the notice and other provisions required by the + GPL. If you do not delete the provisions above, a recipient may use your + version of this file under either the "Toolbar2000 License" or the GPL. + + $jrsoftware: tb2k/Source/TB2Anim.pas,v 1.13 2008/09/19 16:41:00 jr Exp $ +} + +interface + +{$I TB2Ver.inc} +{$Q-} + +uses + Windows, Messages, SysUtils, Classes; + +const + WM_TB2K_ANIMATIONENDED = WM_USER + $556; + +type + TTBAnimationDirection = set of (tbadLeft, tbadRight, tbadDown, tbadUp); + +procedure TBStartAnimation(const AWnd: HWND; const ABlend: Boolean; + const ADirection: TTBAnimationDirection); +procedure TBUpdateAnimation; +procedure TBEndAnimation(const Wnd: HWND); +function TBIsAnimationInProgress: Boolean; + +implementation + +uses + {$IFDEF CLR} System.Security, System.Runtime.InteropServices, System.Threading, {$ENDIF} + TB2Common; + +{ Notes to self: + - It originally had the NOMIRRORBITMAP flag on the BitBlt calls, because + Windows 2000's AnimateWindow function has it. But it had to be removed + because on Windows 98 with the Standard VGA or VMware video driver, it + caused no bits to be blitted, even though Windows 98 is supposed to + support NOMIRRORBITMAP according to the documentation. I don't think it's + necessary anyway. +} + +const + DCX_USESTYLE = $10000; + WS_EX_LAYERED = $80000; + NOMIRRORBITMAP = $80000000; + ULW_ALPHA = 2; + +type + PAnimateThreadFuncData = ^TAnimateThreadFuncData; + TAnimateThreadFuncData = record + FRunning: Boolean; + FWnd: HWND; + FTime: Integer; + FBlending: Boolean; + FStartStep, FCurStep: Integer; + FStartTime, FLastFrameTime: DWORD; + FWndDC, FBmpDC: HDC; + FBmp: HBITMAP; + FScreenClientRect: TRect; + FSize: TSize; + FLastPos: TPoint; + FDirection: TTBAnimationDirection; + end; + { Delphi.NET 2007 note: Because TRect/TSize/TPoint are wrongly declared as + 'packed', fields of these types must be preceded by an Integer- or + IntPtr-sized field to ensure correct alignment and avoid an alignment + fault on IA-64. } + +{$IFNDEF CLR} +var + UpdateLayeredWindowProc: function(Handle: HWND; hdcDest: HDC; + pptDst: PPoint; _psize: PSize; hdcSrc: HDC; pptSrc: PPoint; + crKey: COLORREF; var pblend: TBLENDFUNCTION; dwFlags: DWORD): BOOL; stdcall; +{$ELSE} +{ We can't use Borland.Vcl.Windows' UpdateLayeredWindow because the "pblend" + parameter is misdeclared (see QC #25130) } +[SuppressUnmanagedCodeSecurity, DllImport(user32, CharSet = CharSet.Ansi, SetLastError = True, EntryPoint = 'UpdateLayeredWindow')] +function UpdateLayeredWindowProc(Handle: HWND; hdcDest: HDC; const pptDst: TPoint; + const _psize: TSize; hdcSrc: HDC; const pptSrc: TPoint; + crKey: COLORREF; [in] var pblend: TBLENDFUNCTION; dwFlags: DWORD): BOOL; overload; external; +[SuppressUnmanagedCodeSecurity, DllImport(user32, CharSet = CharSet.Ansi, SetLastError = True, EntryPoint = 'UpdateLayeredWindow')] +function UpdateLayeredWindowProc(Handle: HWND; hdcDest: HDC; pptDst: IntPtr; + _psize: IntPtr; hdcSrc: HDC; pptSrc: IntPtr; + crKey: COLORREF; [in] var pblend: TBLENDFUNCTION; dwFlags: DWORD): BOOL; overload; external; +{$ENDIF} + +threadvar + AnimateData: TAnimateThreadFuncData; + +procedure FinalizeAnimation; +begin + {$IFNDEF CLR} + with PAnimateThreadFuncData(@AnimateData)^ do begin + {$ELSE} + with AnimateData do begin + {$ENDIF} + FRunning := False; + if FBmpDC <> 0 then begin + if FBlending then + SetWindowLong(FWnd, GWL_EXSTYLE, + GetWindowLong(FWnd, GWL_EXSTYLE) and not WS_EX_LAYERED) + else + SetWindowRgn(FWnd, 0, False); + BitBlt(FWndDC, 0, 0, FSize.cx, FSize.cy, FBmpDC, 0, 0, SRCCOPY); + DeleteDC(FBmpDC); + FBmpDC := 0; + end; + if FBmp <> 0 then begin + DeleteObject(FBmp); + FBmp := 0; + end; + if FWndDC <> 0 then begin + ReleaseDC(FWnd, FWndDC); + FWndDC := 0; + end; + if FWnd <> 0 then begin + SendNotifyMessage(FWnd, WM_TB2K_ANIMATIONENDED, 0, 0); + FWnd := 0; + end; + end; +end; + +function TBIsAnimationInProgress: Boolean; +begin + Result := AnimateData.FRunning; +end; + +procedure TBEndAnimation(const Wnd: HWND); +begin + if AnimateData.FRunning and + ((Wnd = 0) or (AnimateData.FWnd = Wnd)) then + FinalizeAnimation; +end; + +procedure TBStartAnimation(const AWnd: HWND; const ABlend: Boolean; + const ADirection: TTBAnimationDirection); +var + ZeroPt: TPoint; + R: TRect; + Blend: TBlendFunction; + Rgn: HRGN; +begin + FinalizeAnimation; + + ZeroPt.X := 0; + ZeroPt.Y := 0; + + try + {$IFNDEF CLR} + { Note: The pointer cast avoids GetTls calls for every field access } + with PAnimateThreadFuncData(@AnimateData)^ do begin + {$ELSE} + with AnimateData do begin + {$ENDIF} + FWnd := AWnd; + FBlending := ABlend and {$IFNDEF CLR} Assigned(UpdateLayeredWindowProc) + {$ELSE} (Win32MajorVersion >= 5) {$ENDIF}; + FDirection := ADirection; + GetCursorPos(FLastPos); + GetClientRect(FWnd, FScreenClientRect); + MapWindowPoints(FWnd, 0, FScreenClientRect, 2); + GetWindowRect(FWnd, R); + FWndDC := GetDCEx(FWnd, 0, DCX_WINDOW or DCX_CACHE {or DCX_USESTYLE ?}); + if FWndDC = 0 then + RaiseLastOSError; + FSize.cx := R.Right - R.Left; + FSize.cy := R.Bottom - R.Top; + FBmp := CreateCompatibleBitmap(FWndDC, FSize.cx, FSize.cy {or $01000000 ?}); + if FBmp = 0 then + RaiseLastOSError; + FBmpDC := CreateCompatibleDC(FWndDC); + if FBmpDC = 0 then + RaiseLastOSError; + // AnimateWindow calls SetLayout, but I'm not sure that we need to. + //if Assigned(SetLayoutProc) then + // SetLayoutProc(FBmpDC, 0); + SelectObject(FBmpDC, FBmp); + //SetBoundsRect(FBmpDC, nil, DCB_RESET or DCB_ENABLE); + SendMessage(FWnd, WM_PRINT, WPARAM(FBmpDC), PRF_NONCLIENT or PRF_CLIENT or + PRF_ERASEBKGND or PRF_CHILDREN); + //GetBoundsRect + if FBlending then begin + SetWindowLong(FWnd, GWL_EXSTYLE, GetWindowLong(FWnd, GWL_EXSTYLE) or WS_EX_LAYERED); + FTime := 175; { actually more like ~147 because FCurStep starts at 40 } + FCurStep := 40; + Blend.BlendOp := AC_SRC_OVER; + Blend.BlendFlags := 0; + Blend.SourceConstantAlpha := FCurStep; + Blend.AlphaFormat := 0; + Win32Check(UpdateLayeredWindowProc(FWnd, 0, {$IFNDEF CLR}@{$ENDIF} R.TopLeft, + {$IFNDEF CLR}@{$ENDIF} FSize, FBmpDC, {$IFNDEF CLR}@{$ENDIF} ZeroPt, + 0, Blend, ULW_ALPHA)); + end + else begin + FTime := 150; + FCurStep := 0; + Rgn := CreateRectRgn(0, 0, 0, 0); + if not BOOL(SetWindowRgn(FWnd, Rgn, False)) then + DeleteObject(Rgn); { just in case } + end; + FStartStep := FCurStep; + FStartTime := GetTickCount; + FLastFrameTime := FStartTime; + { These are the same flags AnimateWindow uses. SWP_ASYNCWINDOWPOS is + needed or else it doesn't "save bits" properly. + Note: SWP_ASYNCWINDOWPOS seems to have no effect on Windows 95 & NT 4.0, + so bits behind the window are not saved & restored correctly. } + SetWindowPos(FWnd, 0, 0, 0, 0, 0, SWP_NOSIZE or SWP_NOMOVE or + SWP_NOZORDER or SWP_NOACTIVATE or SWP_SHOWWINDOW or SWP_NOREDRAW or + SWP_NOOWNERZORDER or SWP_ASYNCWINDOWPOS); + FRunning := True; + end; + except + FinalizeAnimation; + raise; + end; +end; + +procedure TBUpdateAnimation; +var + ThisFrameTime: DWORD; + ElapsedTime, NewStep: Integer; + P: TPoint; + Blend: TBlendFunction; + X, Y: Integer; + Rgn: HRGN; +begin + {$IFNDEF CLR} + with PAnimateThreadFuncData(@AnimateData)^ do begin + {$ELSE} + with AnimateData do begin + {$ENDIF} + if not FRunning then + Exit; + + { If 10 msec hasn't passed since the last call, exit. We don't want to + monopolize the CPU. } + ThisFrameTime := GetTickCount; + if ThisFrameTime - FLastFrameTime < 10 then + Exit; + FLastFrameTime := ThisFrameTime; + + ElapsedTime := ThisFrameTime - FStartTime; + if (ElapsedTime < 0) or (ElapsedTime >= FTime) then begin + FinalizeAnimation; + Exit; + end; + NewStep := FStartStep + ((255 * ElapsedTime) div FTime); + if (NewStep < 0) or (NewStep >= 255) then begin + FinalizeAnimation; + Exit; + end; + + GetCursorPos(P); + if (P.X <> FLastPos.X) or (P.Y <> FLastPos.Y) then begin + if PtInRect(FScreenClientRect, P) then begin + FinalizeAnimation; + Exit; + end; + FLastPos := P; + end; + + if NewStep > FCurStep then begin + FCurStep := NewStep; + if FBlending then begin + Blend.BlendOp := AC_SRC_OVER; + Blend.BlendFlags := 0; + Blend.SourceConstantAlpha := NewStep; + Blend.AlphaFormat := 0; + UpdateLayeredWindowProc(FWnd, 0, nil, nil, 0, nil, 0, Blend, ULW_ALPHA); + end + else begin + if tbadDown in FDirection then + Y := MulDiv(FSize.cy, NewStep, 255) - FSize.cy + else if tbadUp in FDirection then + Y := FSize.cy - MulDiv(FSize.cy, NewStep, 255) + else + Y := 0; + if tbadRight in FDirection then + X := MulDiv(FSize.cx, NewStep, 255) - FSize.cx + else if tbadLeft in FDirection then + X := FSize.cx - MulDiv(FSize.cx, NewStep, 255) + else + X := 0; + Rgn := CreateRectRgn(X, Y, X + FSize.cx, Y + FSize.cy); + if not BOOL(SetWindowRgn(FWnd, Rgn, False)) then + DeleteObject(Rgn); { just in case } + BitBlt(FWndDC, X, Y, FSize.cx, FSize.cy, FBmpDC, 0, 0, SRCCOPY); + end; + end; + end; +end; + +initialization + {$IFNDEF CLR} + UpdateLayeredWindowProc := GetProcAddress(GetModuleHandle(user32), + 'UpdateLayeredWindow'); + {$ENDIF} +finalization + FinalizeAnimation; +end. diff --git a/internal/2.2.2/1/Source/TB2Common.pas b/internal/2.2.2/1/Source/TB2Common.pas new file mode 100644 index 0000000..e94bb9d --- /dev/null +++ b/internal/2.2.2/1/Source/TB2Common.pas @@ -0,0 +1,1571 @@ +unit TB2Common; + +{ + Toolbar2000 + Copyright (C) 1998-2008 by Jordan Russell + All rights reserved. + + The contents of this file are subject to the "Toolbar2000 License"; you may + not use or distribute this file except in compliance with the + "Toolbar2000 License". A copy of the "Toolbar2000 License" may be found in + TB2k-LICENSE.txt or at: + http://www.jrsoftware.org/files/tb2k/TB2k-LICENSE.txt + + Alternatively, the contents of this file may be used under the terms of the + GNU General Public License (the "GPL"), in which case the provisions of the + GPL are applicable instead of those in the "Toolbar2000 License". A copy of + the GPL may be found in GPL-LICENSE.txt or at: + http://www.jrsoftware.org/files/tb2k/GPL-LICENSE.txt + If you wish to allow use of your version of this file only under the terms of + the GPL and not to allow others to use your version of this file under the + "Toolbar2000 License", indicate your decision by deleting the provisions + above and replace them with the notice and other provisions required by the + GPL. If you do not delete the provisions above, a recipient may use your + version of this file under either the "Toolbar2000 License" or the GPL. + + $jrsoftware: tb2k/Source/TB2Common.pas,v 1.48 2008/09/17 19:46:30 jr Exp $ +} + +interface + +{$I TB2Ver.inc} + +uses + Windows, Classes, SysUtils, Messages, Controls, Forms; + +type + THandleWMPrintNCPaintProc = procedure(Wnd: HWND; DC: HDC; AppData: TObject); + TPaintHandlerProc = procedure(var Message: TWMPaint) of object; + + { The type of item a TList holds; it differs between Win32 and .NET VCL } + TListItemType = {$IFNDEF CLR} Pointer {$ELSE} TObject {$ENDIF}; + + {$IFNDEF CLR} + ClipToLongint = Longint; + {$ENDIF} + +function AddToFrontOfList(var List: TList; Item: TObject): Boolean; +function AddToList(var List: TList; Item: TObject): Boolean; +function ApplicationIsActive: Boolean; +function AreFlatMenusEnabled: Boolean; +function AreKeyboardCuesEnabled: Boolean; +procedure CallLockSetForegroundWindow(const ALock: Boolean); +function CallTrackMouseEvent(const Wnd: HWND; const Flags: DWORD): Boolean; +function CharToLower(const C: Char): Char; +{$IFDEF CLR} +function ClipToLongint(const I: Int64): Longint; inline; +{$ENDIF} +function CreateHalftoneBrush: HBRUSH; +function CreateMonoBitmap(const AWidth, AHeight: Integer; + const ABits: array of Byte): HBITMAP; +function CreateRotatedFont(DC: HDC): HFONT; +procedure DoubleBufferedRepaint(const Wnd: HWND); +procedure DrawHalftoneInvertRect(const DC: HDC; const NewRect, OldRect: TRect; + const NewSize, OldSize: TSize); +procedure DrawRotatedText(const DC: HDC; AText: String; const ARect: TRect; + const AFormat: Cardinal); +procedure DrawSmallWindowCaption(const Wnd: HWND; const DC: HDC; + const ARect: TRect; const AText: String; const AActive: Boolean); +function DrawTextStr(const DC: HDC; const AText: String; var ARect: TRect; + const AFormat: UINT): Integer; +function EscapeAmpersands(const S: String): String; +procedure FillRectWithGradient(const DC: HDC; const R: TRect; + const StartColor, EndColor: TColorRef; const HorizontalDirection: Boolean); +function FindAccelChar(const S: String): Char; +{$IFNDEF JR_D5} +procedure FreeAndNil(var Obj); +{$ENDIF} +function GetInputLocaleCodePage: UINT; +function GetMenuShowDelay: Integer; +function GetMessagePosAsPoint: TPoint; +function GetRectOfMonitorContainingPoint(const P: TPoint; const WorkArea: Boolean): TRect; +function GetRectOfMonitorContainingRect(const R: TRect; const WorkArea: Boolean): TRect; +function GetRectOfMonitorContainingWindow(const W: HWND; const WorkArea: Boolean): TRect; +function GetRectOfPrimaryMonitor(const WorkArea: Boolean): TRect; +function GetSystemNonClientMetrics(var Metrics: TNonClientMetrics): Boolean; +function GetSystemParametersInfoBool(const Param: UINT; const Default: BOOL): BOOL; +function GetTextExtentPoint32Str(const DC: HDC; const AText: String; + out ASize: TSize): BOOL; +function GetTextHeight(const DC: HDC): Integer; +function GetTextWidth(const DC: HDC; S: String; const Prefix: Boolean): Integer; +procedure HandleWMPrint(const Wnd: HWND; var Message: TMessage; + const NCPaintFunc: THandleWMPrintNCPaintProc; const AppData: TObject); +procedure HandleWMPrintClient(const PaintHandlerProc: TPaintHandlerProc; + const Message: {$IFNDEF CLR} TMessage {$ELSE} TWMPrintClient {$ENDIF}); +function IsWindowsXP: Boolean; +procedure InitTrackMouseEvent; +{$IFNDEF JR_D6} +function InvalidPoint(const At: TPoint): Boolean; +{$ENDIF} +function IsFillRectWithGradientAvailable: Boolean; +function Max(A, B: Integer): Integer; +function Min(A, B: Integer): Integer; +{$IFNDEF CLR} +function MethodsEqual(const M1, M2: TMethod): Boolean; +{$ENDIF} +function NeedToPlaySound(const Alias: String): Boolean; +procedure PlaySystemSound(const Alias: String); +procedure ProcessPaintMessages; +{$IFNDEF JR_D6} +procedure RaiseLastOSError; +{$ENDIF} +procedure RemoveMessages(const AMin, AMax: Integer); +procedure RemoveFromList(var List: TList; Item: TObject); +procedure SelectNCUpdateRgn(Wnd: HWND; DC: HDC; Rgn: HRGN); +function StripAccelChars(const S: String): String; +function StripTrailingPunctuation(const S: String): String; +function TextOutStr(const DC: HDC; const X, Y: Integer; + const AText: String): BOOL; +function UsingMultipleMonitors: Boolean; + +const + PopupMenuWindowNCSize = 3; + DT_HIDEPREFIX = $00100000; + +implementation + +uses + {$IFDEF CLR} Types, System.Security, System.Runtime.InteropServices, + System.Text, MultiMon, {$ENDIF} + MMSYSTEM, TB2Version; + +function ApplicationIsActive: Boolean; +{ Returns True if the application is in the foreground } +begin + Result := GetActiveWindow <> 0; +end; + +type + {$IFNDEF CLR} + PPrintEnumProcData = ^TPrintEnumProcData; + TPrintEnumProcData = record + {$ELSE} + TPrintEnumProcData = class + private + {$ENDIF} + PrintChildren: Boolean; + ParentWnd: HWND; + DC: HDC; + PrintFlags: LPARAM; + {$IFDEF CLR} + function PrintEnumProc(Wnd: HWND; LParam: LPARAM): BOOL; + {$ENDIF} + end; + +{$IFNDEF CLR} +function PrintEnumProc(Wnd: HWND; LParam: LPARAM): BOOL; stdcall; +{$ELSE} +function TPrintEnumProcData.PrintEnumProc(Wnd: HWND; LParam: LPARAM): BOOL; +{$ENDIF} +var + R: TRect; + SaveIndex: Integer; +begin + Result := True; { continue enumerating } + {$IFNDEF CLR} + with PPrintEnumProcData(LParam)^ do + {$ENDIF} + begin + { Skip window if it isn't a child/owned window of ParentWnd or isn't visible } + if (HWND(GetWindowLong(Wnd, GWL_HWNDPARENT)) <> ParentWnd) or + (GetWindowLong(Wnd, GWL_STYLE) and WS_VISIBLE = 0) then + { ^ don't use IsWindowVisible since it returns False if the window's + parent window is not visible } + Exit; + GetWindowRect(Wnd, R); + MapWindowPoints(0, ParentWnd, R, 2); + SaveIndex := SaveDC(DC); + { Like Windows, offset the window origin to the top-left coordinates of + the child/owned window } + MoveWindowOrg(DC, R.Left, R.Top); + { Like Windows, intersect the clipping region with the entire rectangle of + the child/owned window } + OffsetRect(R, -R.Left, -R.Top); + IntersectClipRect(DC, R.Left, R.Top, R.Right, R.Bottom); + { Send a WM_PRINT message to the child/owned window } + SendMessage(Wnd, WM_PRINT, WPARAM(DC), PrintFlags); + { Restore the DC's state, in case the WM_PRINT handler didn't put things + back the way it found them } + RestoreDC(DC, SaveIndex); + end; +end; + +procedure HandleWMPrint(const Wnd: HWND; var Message: TMessage; + const NCPaintFunc: THandleWMPrintNCPaintProc; const AppData: TObject); +{ note: AppData is an application-defined value which is passed to NCPaintFunc } +var + DC: HDC; + SaveIndex, SaveIndex2: Integer; + R: TRect; + P: TPoint; + Data: TPrintEnumProcData; +begin + if (Message.LParam and PRF_CHECKVISIBLE = 0) or IsWindowVisible(Wnd) then begin + DC := HDC(Message.WParam); + SaveIndex2 := SaveDC(DC); + try + if Message.LParam and PRF_NONCLIENT <> 0 then begin + SaveIndex := SaveDC(DC); + if Assigned(NCPaintFunc) then + NCPaintFunc(Wnd, DC, AppData); + RestoreDC(DC, SaveIndex); + end; + { Calculate the difference between the top-left corner of the window + and the top-left corner of its client area } + GetWindowRect(Wnd, R); + P.X := 0; P.Y := 0; + ClientToScreen(Wnd, P); + Dec(P.X, R.Left); Dec(P.Y, R.Top); + if Message.LParam and PRF_CLIENT <> 0 then begin + { Like Windows, the flags PRF_ERASEBKGND, PRF_CHILDREN, and PRF_OWNED + are ignored if PRF_CLIENT isn't also specified } + if Message.LParam and PRF_ERASEBKGND <> 0 then begin + { Send WM_ERASEBKGND } + SaveIndex := SaveDC(DC); + if Message.LParam and PRF_NONCLIENT <> 0 then + MoveWindowOrg(DC, P.X, P.Y); + SendMessage(Wnd, WM_ERASEBKGND, Message.WParam, 0); + RestoreDC(DC, SaveIndex); + end; + { Send WM_PRINTCLIENT } + SaveIndex := SaveDC(DC); + if Message.LParam and PRF_NONCLIENT <> 0 then + MoveWindowOrg(DC, P.X, P.Y); + SendMessage(Wnd, WM_PRINTCLIENT, Message.WParam, 0); + RestoreDC(DC, SaveIndex); + { Like Windows, always offset child/owned windows by the size of the + client area even if PRF_NONCLIENT isn't specified (a bug?) } + MoveWindowOrg(DC, P.X, P.Y); + {$IFDEF CLR} + Data := TPrintEnumProcData.Create; + {$ENDIF} + Data.ParentWnd := Wnd; + Data.DC := DC; + { Send WM_PRINT to child/owned windows } + if Message.LParam and PRF_CHILDREN <> 0 then begin + Data.PrintChildren := True; + Data.PrintFlags := (Message.LParam or (PRF_NONCLIENT or PRF_CLIENT or + PRF_ERASEBKGND or PRF_CHILDREN)) and not PRF_CHECKVISIBLE; + {$IFNDEF CLR} + EnumChildWindows(Wnd, @PrintEnumProc, LPARAM(@Data)); + {$ELSE} + EnumChildWindows(Wnd, Data.PrintEnumProc, 0); + {$ENDIF} + end; + if Message.LParam and PRF_OWNED <> 0 then begin + Data.PrintChildren := False; + Data.PrintFlags := Message.LParam; + {$IFNDEF CLR} + EnumWindows(@PrintEnumProc, LPARAM(@Data)); + {$ELSE} + EnumWindows(Data.PrintEnumProc, 0); + {$ENDIF} + end; + end; + finally + RestoreDC(DC, SaveIndex2); + end; + Message.Result := 1; + end + else begin + { Like Windows, return 0 when the PRF_CHECKVISIBLE flag is specified and + the window is not visible } + Message.Result := 0; + end; +end; + +procedure HandleWMPrintClient(const PaintHandlerProc: TPaintHandlerProc; + const Message: {$IFNDEF CLR} TMessage {$ELSE} TWMPrintClient {$ENDIF}); +var + DC: HDC; + Msg: TWMPaint; + SaveIndex: Integer; +begin + {$IFNDEF CLR} + DC := HDC(Message.WParam); + {$ELSE} + DC := Message.DC; + Msg := TWMPaint.Create; + {$ENDIF} + Msg.Msg := WM_PAINT; + Msg.DC := DC; + {$IFNDEF CLR} + Msg.Unused := 0; + {$ENDIF} + Msg.Result := 0; + SaveIndex := SaveDC(DC); + try + PaintHandlerProc(Msg); + finally + RestoreDC(DC, SaveIndex); + end; +end; + +function GetTextHeight(const DC: HDC): Integer; +var + TextMetric: TTextMetric; +begin + GetTextMetrics(DC, TextMetric); + Result := TextMetric.tmHeight; +end; + +function StripAccelChars(const S: String): String; +var + I: Integer; +begin + Result := S; + I := 1; + while I <= Length(Result) do begin + {$IFNDEF JR_WIDESTR} + if not(Result[I] in LeadBytes) then begin + {$ENDIF} + if Result[I] = '&' then + Delete(Result, I, 1); + Inc(I); + {$IFNDEF JR_WIDESTR} + end + else + Inc(I, 2); + {$ENDIF} + end; +end; + +function EscapeAmpersands(const S: String): String; +{ Replaces any '&' characters with '&&' } +var + I: Integer; +begin + Result := S; + I := 1; + while I <= Length(Result) do begin + {$IFNDEF JR_WIDESTR} + if not(Result[I] in LeadBytes) then begin + {$ENDIF} + if Result[I] = '&' then begin + Inc(I); + Insert('&', Result, I); + end; + Inc(I); + {$IFNDEF JR_WIDESTR} + end + else + Inc(I, 2); + {$ENDIF} + end; +end; + +function StripTrailingPunctuation(const S: String): String; +{ Removes any colon (':') or ellipsis ('...') from the end of S and returns + the resulting string } +var + L: Integer; +begin + Result := S; + L := Length(Result); + if (L > 1) and (Result[L] = ':') {$IFNDEF JR_WIDESTR} and (ByteType(Result, L) = mbSingleByte) {$ENDIF} then + SetLength(Result, L-1) + else if (L > 3) and (Result[L-2] = '.') and (Result[L-1] = '.') and + (Result[L] = '.') {$IFNDEF JR_WIDESTR} and (ByteType(Result, L-2) = mbSingleByte) {$ENDIF} then + SetLength(Result, L-3); +end; + +function GetTextWidth(const DC: HDC; S: String; const Prefix: Boolean): Integer; +{ Returns the width of the specified string using the font currently selected + into DC. If Prefix is True, it first removes "&" characters as necessary. } +var + Size: TSize; +begin + { This procedure is 10x faster than using DrawText with the DT_CALCRECT flag } + if Prefix then + S := StripAccelChars(S); + GetTextExtentPoint32Str(DC, S, Size); + Result := Size.cx; +end; + +procedure ProcessPaintMessages; +{ Dispatches all pending WM_PAINT messages. In effect, this is like an + 'UpdateWindow' on all visible windows } +var + Msg: TMsg; +begin + while PeekMessage(Msg, 0, WM_PAINT, WM_PAINT, PM_NOREMOVE) do begin + case Integer(GetMessage(Msg, 0, WM_PAINT, WM_PAINT)) of + -1: Break; { if GetMessage failed } + 0: begin + { Repost WM_QUIT messages } + PostQuitMessage(ClipToLongint(Msg.wParam)); + Break; + end; + end; + DispatchMessage(Msg); + end; +end; + +procedure RemoveMessages(const AMin, AMax: Integer); +{ Removes any messages with the specified ID from the queue } +var + Msg: TMsg; +begin + while PeekMessage(Msg, 0, AMin, AMax, PM_REMOVE) do begin + if Msg.message = WM_QUIT then begin + { Repost WM_QUIT messages } + PostQuitMessage(ClipToLongint(Msg.wParam)); + Break; + end; + end; +end; + +procedure SelectNCUpdateRgn(Wnd: HWND; DC: HDC; Rgn: HRGN); +var + R: TRect; + NewClipRgn: HRGN; +begin + if (Rgn <> 0) and (Rgn <> 1) then begin + GetWindowRect(Wnd, R); + if SelectClipRgn(DC, Rgn) = ERROR then begin + NewClipRgn := CreateRectRgnIndirect(R); + SelectClipRgn(DC, NewClipRgn); + DeleteObject(NewClipRgn); + end; + OffsetClipRgn(DC, -R.Left, -R.Top); + end; +end; + +function AddToList(var List: TList; Item: TObject): Boolean; +{ Returns True if Item didn't already exist in the list } +begin + if List = nil then + List := TList.Create; + Result := List.IndexOf(Item) = -1; + if Result then + List.Add(Item); +end; + +function AddToFrontOfList(var List: TList; Item: TObject): Boolean; +{ Returns True if Item didn't already exist in the list } +begin + if List = nil then + List := TList.Create; + Result := List.IndexOf(Item) = -1; + if Result then + List.Insert(0, Item); +end; + +procedure RemoveFromList(var List: TList; Item: TObject); +begin + if Assigned(List) then begin + List.Remove(Item); + if List.Count = 0 then begin + List.Free; + List := nil; + end; + end; +end; + +const + DefaultMenuShowDelay = 400; +{$IFNDEF CLR} +var + RegMenuShowDelay: Integer; + RegMenuShowDelayInited: BOOL = False; +function GetMenuShowDelay: Integer; + function ReadMenuShowDelayFromRegistry: Integer; + var + K: HKEY; + Typ, DataSize: DWORD; + Data: array[0..31] of Char; + Res: Longint; + E: Integer; + begin + Result := DefaultMenuShowDelay; + if RegOpenKeyEx(HKEY_CURRENT_USER, 'Control Panel\Desktop', 0, + KEY_QUERY_VALUE, K) = ERROR_SUCCESS then begin + DataSize := SizeOf(Data); + Res := RegQueryValueEx(K, 'MenuShowDelay', nil, @Typ, @Data, @DataSize); + RegCloseKey(K); + if Res <> ERROR_FILE_NOT_FOUND then begin + if (Res <> ERROR_SUCCESS) or (Typ <> REG_SZ) then + Result := 0 + else begin + Val(Data, Result, E); + if E <> 0 then Result := 0; + end; + end; + end; + end; +begin + if Lo(GetVersion) >= 4 then begin + if not SystemParametersInfo(106{SPI_GETMENUSHOWDELAY}, 0, @Result, 0) then begin + { SPI_GETMENUSHOWDELAY is only supported by Windows NT 4.0 and Windows 98. + On Windows 95, it must use the registry to retrieve this setting. } + if not RegMenuShowDelayInited then begin + RegMenuShowDelay := ReadMenuShowDelayFromRegistry; + InterlockedExchange(Integer(RegMenuShowDelayInited), Ord(True)); + end; + Result := RegMenuShowDelay; + end; + if Result < 0 then Result := 0; + end + else + Result := DefaultMenuShowDelay; +end; +{$ELSE} +function GetMenuShowDelay: Integer; +begin + { Since .NET requires Windows 98 or later, we can assume that + SPI_GETMENUSHOWDELAY is available } + if not SystemParametersInfo(SPI_GETMENUSHOWDELAY, 0, Result, 0) then + Result := DefaultMenuShowDelay; +end; +{$ENDIF} + +function AreFlatMenusEnabled: Boolean; +{ Returns True if "flat menus" are enabled. Always returns False on pre-XP + Windows versions. } +const + SPI_GETFLATMENU = $1022; +begin + { Interestingly, on Windows 2000, SystemParametersInfo(SPI_GETFLATMENU, ...) + succeeds and can return True in pvParam^ if the proper bit is set in + UserPreferencesMask. Since flat menus are not really used on Windows + 2000, call IsWindowsXP first to see if we're running at least XP. } + Result := IsWindowsXP and GetSystemParametersInfoBool(SPI_GETFLATMENU, False); +end; + +function AreKeyboardCuesEnabled: Boolean; +{ Returns True if "keyboard cues" are enabled. Always returns True on + pre-2000 Windows versions. } +const + SPI_GETKEYBOARDCUES = $100A; +begin + Result := (Win32MajorVersion < 5) or + GetSystemParametersInfoBool(SPI_GETKEYBOARDCUES, True); +end; + +function CreateFrameRectRgn(const ARect: TRect; const ASize: TSize): HRGN; +var + R: TRect; + InsideRgn: HRGN; +begin + if IsRectEmpty(ARect) then begin + { The rectangle is empty, so simply return a normalized empty region } + SetRectEmpty(R); + Result := CreateRectRgnIndirect(R); + end + else begin + Result := CreateRectRgnIndirect(ARect); + if Result <> 0 then begin + { Now hollow out the resulting region so that only a frame is left } + R := ARect; + InflateRect(R, -ASize.cx, -ASize.cy); + { If ASize is greater than the size of ARect, then InflateRect will + return a non-normalized rectangle larger than ARect. Test for this + condition by calling IsRectEmpty. } + if not IsRectEmpty(R) then begin + InsideRgn := CreateRectRgnIndirect(R); + if InsideRgn <> 0 then begin + CombineRgn(Result, Result, InsideRgn, RGN_XOR); + DeleteObject(InsideRgn); + end; + end; + end; + end; +end; + +procedure DrawInvertRect(const DC: HDC; const NewRect, OldRect: TRect; + const NewSize, OldSize: TSize; const Brush: HBRUSH); +{ Draws a dragging outline, hiding the old one if necessary. NewRect and/or + OldRect may be empty. } +var + SaveIndex: Integer; + UpdateRgn, OldRgn: HRGN; + R: TRect; +begin + { Create region containing the new rectangle } + UpdateRgn := CreateFrameRectRgn(NewRect, NewSize); + if UpdateRgn <> 0 then begin + { Combine that region with a region containing the old rectangle } + OldRgn := CreateFrameRectRgn(OldRect, OldSize); + if OldRgn <> 0 then begin + CombineRgn(UpdateRgn, OldRgn, UpdateRgn, RGN_XOR); + DeleteObject(OldRgn); + end; + + { Save the DC state so that the clipping region can be restored } + SaveIndex := SaveDC(DC); + try + { Draw the updated region } + SelectClipRgn(DC, UpdateRgn); + GetClipBox(DC, R); + SelectObject(DC, Brush); + PatBlt(DC, R.Left, R.Top, R.Right-R.Left, R.Bottom-R.Top, PATINVERT); + finally + RestoreDC(DC, SaveIndex); + end; + + DeleteObject(UpdateRgn); + end; +end; + +function CreateMonoBitmap(const AWidth, AHeight: Integer; + const ABits: array of Byte): HBITMAP; +begin + {$IFNDEF CLR} + Result := CreateBitmap(AWidth, AHeight, 1, 1, @ABits[0]); + {$ELSE} + { For some reason there isn't an overloaded version of CreateBitmap that + takes a TBytes parameter, so we have to use two calls } + Result := CreateBitmap(AWidth, AHeight, 1, 1, nil); + SetBitmapBits(Result, Length(ABits), ABits); + {$ENDIF} +end; + +function CreateHalftoneBrush: HBRUSH; +const + GrayPattern: array[0..15] of Byte = ( + $55, 0, $AA, 0, $55, 0, $AA, 0, $55, 0, $AA, 0, $55, 0, $AA, 0); +var + GrayBitmap: HBITMAP; +begin + GrayBitmap := CreateMonoBitmap(8, 8, GrayPattern); + Result := CreatePatternBrush(GrayBitmap); + DeleteObject(GrayBitmap); +end; + +procedure DrawHalftoneInvertRect(const DC: HDC; const NewRect, OldRect: TRect; + const NewSize, OldSize: TSize); +var + Brush: HBRUSH; +begin + Brush := CreateHalftoneBrush; + try + DrawInvertRect(DC, NewRect, OldRect, NewSize, OldSize, Brush); + finally + DeleteObject(Brush); + end; +end; + +var + GradientFillAvailable: Boolean; +{$IFNDEF CLR} +type + { Note: TTriVertex is unusable on Delphi 7 and earlier (COLOR16 is + misdeclared as a Shortint instead of a Word). } + TNewTriVertex = record + x: Longint; + y: Longint; + Red: Word; + Green: Word; + Blue: Word; + Alpha: Word; + end; +var + GradientFillFunc: function(DC: HDC; var Vertex: TNewTriVertex; + NumVertex: ULONG; Mesh: Pointer; NumMesh, Mode: ULONG): BOOL; stdcall; +{$ENDIF} + +procedure InitGradientFillFunc; +{$IFNDEF CLR} +var + M: HMODULE; +{$ENDIF} +begin + if (Win32MajorVersion >= 5) or + ((Win32MajorVersion = 4) and (Win32MinorVersion >= 10)) then begin + {$IFNDEF CLR} + M := {$IFDEF JR_D5} SafeLoadLibrary {$ELSE} LoadLibrary {$ENDIF} ('msimg32.dll'); + if M <> 0 then begin + GradientFillFunc := GetProcAddress(M, 'GradientFill'); + if Assigned(GradientFillFunc) then + GradientFillAvailable := True; + end; + {$ELSE} + GradientFillAvailable := True; + {$ENDIF} + end; +end; + +function IsFillRectWithGradientAvailable: Boolean; +begin + Result := GradientFillAvailable; +end; + +procedure FillRectWithGradient(const DC: HDC; const R: TRect; + const StartColor, EndColor: TColorRef; const HorizontalDirection: Boolean); +var + Vertexes: array[0..1] of {$IFNDEF CLR} TNewTriVertex {$ELSE} TTriVertex {$ENDIF}; + GradientRect: TGradientRect; + Mode: ULONG; +begin + if not GradientFillAvailable then + Exit; + Vertexes[0].x := R.Left; + Vertexes[0].y := R.Top; + Vertexes[0].Red := GetRValue(StartColor) shl 8; + Vertexes[0].Blue := GetBValue(StartColor) shl 8; + Vertexes[0].Green := GetGValue(StartColor) shl 8; + Vertexes[0].Alpha := 0; + Vertexes[1].x := R.Right; + Vertexes[1].y := R.Bottom; + Vertexes[1].Red := GetRValue(EndColor) shl 8; + Vertexes[1].Blue := GetBValue(EndColor) shl 8; + Vertexes[1].Green := GetGValue(EndColor) shl 8; + Vertexes[1].Alpha := 0; + GradientRect.UpperLeft := 0; + GradientRect.LowerRight := 1; + if HorizontalDirection then + Mode := GRADIENT_FILL_RECT_H + else + Mode := GRADIENT_FILL_RECT_V; + {$IFNDEF CLR} + GradientFillFunc(DC, Vertexes[0], 2, @GradientRect, 1, Mode); + {$ELSE} + GradientFill(DC, Vertexes, 2, GradientRect, 1, Mode); + {$ENDIF} +end; + +procedure DrawSmallWindowCaption(const Wnd: HWND; const DC: HDC; + const ARect: TRect; const AText: String; const AActive: Boolean); +{ Draws a (non-themed) small window caption bar. + On Windows Vista, a custom routine is used to work around an ugly bug in + DrawCaption that causes the text to be painted at the wrong coordinates. + Note: The value of the AText parameter may be ignored depending on which + routine is chosen. } + + procedure FillBackground; + const + CaptionBkColors: array[Boolean, Boolean] of Integer = + ((COLOR_INACTIVECAPTION, COLOR_ACTIVECAPTION), + (COLOR_GRADIENTINACTIVECAPTION, COLOR_GRADIENTACTIVECAPTION)); + var + LeftColor, RightColor: TColorRef; + begin + if GetSystemParametersInfoBool(SPI_GETGRADIENTCAPTIONS, False) and + IsFillRectWithGradientAvailable then begin + LeftColor := GetSysColor(CaptionBkColors[False, AActive]); + RightColor := GetSysColor(CaptionBkColors[True, AActive]); + if LeftColor <> RightColor then begin + FillRectWithGradient(DC, ARect, LeftColor, RightColor, True); + Exit; + end; + end; + FillRect(DC, ARect, GetSysColorBrush(CaptionBkColors[False, AActive])); + end; + +const + CaptionTextColors: array[Boolean] of Integer = + (COLOR_INACTIVECAPTIONTEXT, COLOR_CAPTIONTEXT); +var + Flags: UINT; + TextRect: TRect; + NonClientMetrics: TNonClientMetrics; + CaptionFont, SaveFont: HFONT; + SaveBkMode: Integer; + SaveTextColor: TColorRef; +begin + if ARect.Right <= ARect.Left then + Exit; + + { Prior to Windows Vista, continue to use DrawCaption. Don't want to risk + introducing new bugs on old OSes, plus on Windows 98, it's several times + faster than our custom routine. } + if Win32MajorVersion < 6 then begin + Flags := DC_TEXT or DC_SMALLCAP; + if AActive then + Flags := Flags or DC_ACTIVE; + if GetSystemParametersInfoBool(SPI_GETGRADIENTCAPTIONS, False) then + Flags := Flags or DC_GRADIENT; + DrawCaption(Wnd, DC, ARect, Flags); + end + else begin + FillBackground; + TextRect := ARect; + Inc(TextRect.Left, GetSystemMetrics(SM_CXEDGE)); + if (TextRect.Right > TextRect.Left) and + GetSystemNonClientMetrics(NonClientMetrics) then begin + CaptionFont := CreateFontIndirect(NonClientMetrics.lfSmCaptionFont); + if CaptionFont <> 0 then begin + SaveFont := SelectObject(DC, CaptionFont); + SaveBkMode := SetBkMode(DC, TRANSPARENT); + SaveTextColor := SetTextColor(DC, GetSysColor(CaptionTextColors[AActive])); + try + DrawTextStr(DC, AText, TextRect, DT_SINGLELINE or DT_NOPREFIX or + DT_VCENTER or DT_END_ELLIPSIS); + finally + SetTextColor(DC, SaveTextColor); + SetBkMode(DC, SaveBkMode); + SelectObject(DC, SaveFont); + DeleteObject(CaptionFont); + end; + end; + end; + end; +end; + +procedure DoubleBufferedRepaint(const Wnd: HWND); +var + ClientRect, ClipRect, R: TRect; + WndDC, BmpDC: HDC; + Bmp: HBITMAP; + SaveIndex: Integer; +begin + if IsWindowVisible(Wnd) and GetClientRect(Wnd, ClientRect) and + not IsRectEmpty(ClientRect) then begin + ValidateRect(Wnd, nil); + BmpDC := 0; + Bmp := 0; + WndDC := GetDC(Wnd); + if WndDC <> 0 then begin + try + { Only repaint the area that intersects the clipping rectangle } + if (GetClipBox(WndDC, ClipRect) <> Windows.ERROR) and + IntersectRect(R, ClientRect, ClipRect) then begin + Bmp := CreateCompatibleBitmap(WndDC, R.Right - R.Left, R.Bottom - R.Top); + if Bmp <> 0 then begin + BmpDC := CreateCompatibleDC(WndDC); + if BmpDC <> 0 then begin + SelectObject(BmpDC, Bmp); + SaveIndex := SaveDC(BmpDC); + SetWindowOrgEx(BmpDC, R.Left, R.Top, nil); + SendMessage(Wnd, WM_ERASEBKGND, WPARAM(BmpDC), 0); + SendMessage(Wnd, WM_PAINT, WPARAM(BmpDC), 0); + RestoreDC(BmpDC, SaveIndex); + BitBlt(WndDC, R.Left, R.Top, R.Right - R.Left, R.Bottom - R.Top, + BmpDC, 0, 0, SRCCOPY); + Exit; + end; + end; + end; + finally + if BmpDC <> 0 then DeleteDC(BmpDC); + if Bmp <> 0 then DeleteObject(Bmp); + ReleaseDC(Wnd, WndDC); + end; + end; + end; + { Fall back to invalidating if we didn't or couldn't double-buffer } + InvalidateRect(Wnd, nil, True); +end; + +{$IFNDEF CLR} +function MethodsEqual(const M1, M2: TMethod): Boolean; +begin + Result := (M1.Code = M2.Code) and (M1.Data = M2.Data); +end; +{$ENDIF} + +function GetRectOfPrimaryMonitor(const WorkArea: Boolean): TRect; +begin + if not WorkArea or not SystemParametersInfo(SPI_GETWORKAREA, 0, + {$IFNDEF CLR}@{$ENDIF} Result, 0) then + Result := Rect(0, 0, Screen.Width, Screen.Height); +end; + +{$IFNDEF CLR} +{ On Delphi for Win32, we don't use the MultiMon unit because its stubs for + MonitorFromRect and MonitorFromPoint are seriously bugged on Delphi 4. } +type + HMONITOR = type THandle; + TMonitorInfo = record + cbSize: DWORD; + rcMonitor: TRect; + rcWork: TRect; + dwFlags: DWORD; + end; +const + MONITOR_DEFAULTTONEAREST = $2; +var + MultiMonApis: record + MonitorFromRect: function(const lprcScreenCoords: TRect; dwFlags: DWORD): HMONITOR; stdcall; + MonitorFromPoint: function(ptScreenCoords: TPoint; dwFlags: DWORD): HMONITOR; stdcall; + MonitorFromWindow: function(hWnd: HWND; dwFlags: DWORD): HMONITOR; stdcall; + GetMonitorInfo: function(hMonitor: HMONITOR; var lpMonitorInfo: TMonitorInfo): BOOL; stdcall; + end; + MultiMonApisAvailable: Boolean; + +procedure InitMultiMonApis; +var + User32Handle: THandle; +begin + User32Handle := GetModuleHandle(user32); + MultiMonApis.MonitorFromRect := GetProcAddress(User32Handle, 'MonitorFromRect'); + MultiMonApis.MonitorFromPoint := GetProcAddress(User32Handle, 'MonitorFromPoint'); + MultiMonApis.MonitorFromWindow := GetProcAddress(User32Handle, 'MonitorFromWindow'); + MultiMonApis.GetMonitorInfo := GetProcAddress(User32Handle, 'GetMonitorInfoA'); + MultiMonApisAvailable := Assigned(MultiMonApis.MonitorFromRect) and + Assigned(MultiMonApis.MonitorFromPoint) and + Assigned(MultiMonApis.MonitorFromWindow) and + Assigned(MultiMonApis.GetMonitorInfo); +end; +{$ENDIF} + +function UsingMultipleMonitors: Boolean; +{ Returns True if the system has more than one display monitor configured. } +const + SM_CMONITORS = 80; +begin + { Note: On a single monitor Windows 95 or NT 4 system, GetSystemMetrics will + return 0 since those OSes do not support multiple monitors. On later + versions it returns 1. } + Result := {$IFNDEF CLR} MultiMonApisAvailable and {$ENDIF} + (GetSystemMetrics(SM_CMONITORS) > 1); +end; + +function GetRectOfMonitor(const M: HMONITOR; const WorkArea: Boolean; + var R: TRect): Boolean; +var + MonitorInfo: TMonitorInfo; +begin + {$IFNDEF CLR} + MonitorInfo.cbSize := SizeOf(MonitorInfo); + {$ELSE} + MonitorInfo.cbSize := Marshal.SizeOf(TypeOf(TMonitorInfo)); + {$ENDIF} + Result := {$IFNDEF CLR}MultiMonApis.{$ENDIF} GetMonitorInfo(M, MonitorInfo); + if Result then begin + if not WorkArea then + R := MonitorInfo.rcMonitor + else + R := MonitorInfo.rcWork; + end; +end; + +function GetRectOfMonitorContainingRect(const R: TRect; + const WorkArea: Boolean): TRect; +{ Returns the work area of the monitor which the rectangle R intersects with + the most, or the monitor nearest R if no monitors intersect. } +var + M: HMONITOR; +begin + if UsingMultipleMonitors then begin + M := {$IFNDEF CLR}MultiMonApis.{$ENDIF} MonitorFromRect(R, MONITOR_DEFAULTTONEAREST); + if GetRectOfMonitor(M, WorkArea, Result) then + Exit; + end; + Result := GetRectOfPrimaryMonitor(WorkArea); +end; + +function GetRectOfMonitorContainingPoint(const P: TPoint; + const WorkArea: Boolean): TRect; +{ Returns the screen area of the monitor containing the point P, or the monitor + nearest P if P isn't in any monitor's work area. } +var + M: HMONITOR; +begin + if UsingMultipleMonitors then begin + M := {$IFNDEF CLR}MultiMonApis.{$ENDIF} MonitorFromPoint(P, MONITOR_DEFAULTTONEAREST); + if GetRectOfMonitor(M, WorkArea, Result) then + Exit; + end; + Result := GetRectOfPrimaryMonitor(WorkArea); +end; + +function GetRectOfMonitorContainingWindow(const W: HWND; + const WorkArea: Boolean): TRect; +var + M: HMONITOR; +begin + if UsingMultipleMonitors then begin + M := {$IFNDEF CLR}MultiMonApis.{$ENDIF} MonitorFromWindow(W, MONITOR_DEFAULTTONEAREST); + if GetRectOfMonitor(M, WorkArea, Result) then + Exit; + end; + Result := GetRectOfPrimaryMonitor(WorkArea); +end; + +{$IFNDEF CLR} +var + TrackMouseEventInited: BOOL; + TrackMouseEventFunc: function(var EventTrack: TTrackMouseEvent): BOOL; stdcall; + +procedure InitTrackMouseEvent; +var + TrackMouseEventComCtlModule: THandle; +begin + { First look for TrackMouseEvent which is available on Windows 98 & NT 4 only. + If it doesn't exist, look for _TrackMouseEvent which is available on + Windows 95 if IE 3.0 or later is installed. } + if not TrackMouseEventInited then begin + TrackMouseEventFunc := GetProcAddress(GetModuleHandle(user32), + 'TrackMouseEvent'); + if @TrackMouseEventFunc = nil then begin + TrackMouseEventComCtlModule := + {$IFDEF JR_D5} SafeLoadLibrary {$ELSE} LoadLibrary {$ENDIF} (comctl32); + if TrackMouseEventComCtlModule <> 0 then + TrackMouseEventFunc := GetProcAddress(TrackMouseEventComCtlModule, + '_TrackMouseEvent'); + end; + InterlockedExchange(Integer(TrackMouseEventInited), Ord(True)); + end; +end; +{$ELSE} +procedure InitTrackMouseEvent; +begin +end; +{$ENDIF} + +function CallTrackMouseEvent(const Wnd: HWND; const Flags: DWORD): Boolean; +var + Track: TTrackMouseEvent; +begin + {$IFNDEF CLR} + Result := False; + if Assigned(TrackMouseEventFunc) then begin + Track.cbSize := SizeOf(Track); + Track.dwFlags := Flags; + Track.hwndTrack := Wnd; + Track.dwHoverTime := 0; + Result := TrackMouseEventFunc(Track); + end; + {$ELSE} + { .NET doesn't run on 95, so we can assume TrackMouseEvent is available } + Track.cbSize := Marshal.SizeOf(TypeOf(TTrackMouseEvent)); + Track.dwFlags := Flags; + Track.hwndTrack := Wnd; + Track.dwHoverTime := 0; + Result := TrackMouseEvent(Track); + {$ENDIF} +end; + +{$IFNDEF CLR} +var + LockSetForegroundWindowFunc: function(uLockCode: UINT): BOOL; stdcall; +{$ELSE} +[SuppressUnmanagedCodeSecurity, DllImport(user32, CharSet = CharSet.Ansi, SetLastError = True, EntryPoint = 'LockSetForegroundWindow')] +function LockSetForegroundWindowFunc(uLockCode: UINT): BOOL; external; +{$ENDIF} + +procedure CallLockSetForegroundWindow(const ALock: Boolean); +const + LSFW_LOCK = 1; + LSFW_UNLOCK = 2; +begin + {$IFNDEF CLR} + if Assigned(LockSetForegroundWindowFunc) then begin + {$ELSE} + if (Win32MajorVersion >= 5) or + ((Win32MajorVersion = 4) and (Win32MinorVersion >= 90)) then begin + {$ENDIF} + if ALock then + LockSetForegroundWindowFunc(LSFW_LOCK) + else + LockSetForegroundWindowFunc(LSFW_UNLOCK); + end; +end; + +{$IFNDEF JR_D5} +procedure FreeAndNil(var Obj); +var + P: TObject; +begin + P := TObject(Obj); + TObject(Obj) := nil; + P.Free; +end; +{$ENDIF} + +{$IFNDEF JR_D6} +procedure RaiseLastOSError; +begin + RaiseLastWin32Error; +end; +{$ENDIF} + +{$IFDEF CLR} +{ On .NET, when calling DrawText, GetTextExtentPoint32, or TextOut we can't + rely on the marshaller's automatic A/W function selection because they take + a character count. If we passed the result of Length(), as the VCL + incorrectly does in many places, the behavior would be incorrect on DBCS + Windows 9x/Me systems because when a Unicode string is downconverted to ANSI + the character count can increase (i.e. one Unicode character can become two + ANSI characters). + Below we define our own "A" function prototypes that take byte array + parameters, allowing us to pass the result of AnsiEncoding.GetBytes straight + to the functions without any conversion. (Borland's "A" prototypes use + "string" type parameters.) } +[SuppressUnmanagedCodeSecurity, DllImport(user32, CharSet = CharSet.Ansi, SetLastError = True, EntryPoint = 'DrawTextA')] +function _DrawTextA(hDC: HDC; [in] lpString: TBytes; nCount: Integer; + var lpRect: TRect; uFormat: UINT): Integer; external; +[SuppressUnmanagedCodeSecurity, DllImport(gdi32, CharSet = CharSet.Ansi, SetLastError = True, EntryPoint = 'GetTextExtentPoint32A')] +function _GetTextExtentPoint32A(DC: HDC; [in] Str: TBytes; Count: Integer; + out Size: TSize): BOOL; external; +[SuppressUnmanagedCodeSecurity, DllImport(gdi32, CharSet = CharSet.Ansi, SetLastError = True, EntryPoint = 'TextOutA')] +function _TextOutA(DC: HDC; X, Y: Integer; [in] Str: TBytes; + Count: Integer): BOOL; external; +{$ENDIF} + +function DrawTextStr(const DC: HDC; const AText: String; var ARect: TRect; + const AFormat: UINT): Integer; +{$IFNDEF CLR} +begin + Result := DrawText(DC, PChar(AText), Length(AText), ARect, AFormat); +end; +{$ELSE} +var + AnsiStr: TBytes; +begin + if Marshal.SystemDefaultCharSize = 1 then begin + AnsiStr := AnsiEncoding.GetBytes(AText); + Result := _DrawTextA(DC, AnsiStr, Length(AnsiStr), ARect, AFormat); + end + else + Result := DrawTextW(DC, AText, Length(AText), ARect, AFormat); +end; +{$ENDIF} + +function GetTextExtentPoint32Str(const DC: HDC; const AText: String; + out ASize: TSize): BOOL; +{$IFNDEF CLR} +begin + Result := GetTextExtentPoint32(DC, PChar(AText), Length(AText), ASize); +end; +{$ELSE} +var + AnsiStr: TBytes; +begin + if Marshal.SystemDefaultCharSize = 1 then begin + AnsiStr := AnsiEncoding.GetBytes(AText); + Result := _GetTextExtentPoint32A(DC, AnsiStr, Length(AnsiStr), ASize); + end + else + Result := GetTextExtentPoint32W(DC, AText, Length(AText), ASize); +end; +{$ENDIF} + +function TextOutStr(const DC: HDC; const X, Y: Integer; + const AText: String): BOOL; +{$IFNDEF CLR} +begin + Result := TextOut(DC, X, Y, PChar(AText), Length(AText)); +end; +{$ELSE} +var + AnsiStr: TBytes; +begin + if Marshal.SystemDefaultCharSize = 1 then begin + AnsiStr := AnsiEncoding.GetBytes(AText); + Result := _TextOutA(DC, X, Y, AnsiStr, Length(AnsiStr)); + end + else + Result := TextOutW(DC, X, Y, AText, Length(AText)); +end; +{$ENDIF} + +threadvar + FontExistsResult: Boolean; + +{$IFNDEF CLR} +function FontExistsCallback(const lplf: TLogFont; const lptm: TTextMetric; + dwType: DWORD; lpData: LPARAM): Integer; stdcall; +{$ELSE} +function FontExistsCallback([in] var lplf: TLogFont; [in] var lptm: TTextMetric; + dwType: DWORD; lpData: LPARAM): Integer; +{$ENDIF} +begin + FontExistsResult := True; + Result := 0; +end; + +function FontExists(const DC: HDC; const FaceName: String): Boolean; +begin + FontExistsResult := False; + EnumFonts(DC, {$IFNDEF CLR}PChar{$ENDIF}(FaceName), @FontExistsCallback, + {$IFNDEF CLR} nil {$ELSE} 0 {$ENDIF}); + Result := FontExistsResult; +end; + +function CreateRotatedFont(DC: HDC): HFONT; +{ Creates a font based on the DC's current font, but rotated 270 degrees } +var + LogFont: TLogFont; + TM: TTextMetric; + VerticalFontName: String; +begin + if GetObject(GetCurrentObject(DC, OBJ_FONT), + {$IFNDEF CLR} + SizeOf(LogFont), @LogFont + {$ELSE} + Marshal.SizeOf(TypeOf(TLogFont)), LogFont + {$ENDIF} + ) = 0 then begin + { just in case... } + Result := 0; + Exit; + end; + LogFont.lfEscapement := 2700; + LogFont.lfOrientation := 2700; + LogFont.lfOutPrecision := OUT_TT_ONLY_PRECIS; { needed for Win9x } + + { Don't let a random TrueType font be substituted when MS Sans Serif or + Microsoft Sans Serif are used. On Windows 2000 and later, hard-code Tahoma + because Arial can't display Japanese or Thai Unicode characters (on Windows + 2000 at least). On earlier versions, hard-code Arial since NT 4.0 doesn't + ship with Tahoma, and 9x doesn't do Unicode. } + {$IFNDEF CLR} + if (StrIComp(LogFont.lfFaceName, 'MS Sans Serif') = 0) or + (StrIComp(LogFont.lfFaceName, 'Microsoft Sans Serif') = 0) then begin + if Win32MajorVersion >= 5 then + StrPCopy(LogFont.lfFaceName, 'Tahoma') + else + StrPCopy(LogFont.lfFaceName, 'Arial'); + {$ELSE} + if SameText(LogFont.lfFaceName, 'MS Sans Serif', loInvariantLocale) or + SameText(LogFont.lfFaceName, 'Microsoft Sans Serif', loInvariantLocale) then begin + if Win32MajorVersion >= 5 then + LogFont.lfFaceName := 'Tahoma' + else + LogFont.lfFaceName := 'Arial'; + {$ENDIF} + { Set lfHeight to the actual height of the current font. This is needed + to work around a Windows 98 issue: on a clean install of the OS, + SPI_GETNONCLIENTMETRICS returns -5 for lfSmCaptionFont.lfHeight. This is + wrong; it should return -11 for an 8 pt font. With normal, unrotated text + this actually displays correctly, since MS Sans Serif doesn't support + sizes below 8 pt. However, when we change to a TrueType font like Arial, + this becomes a problem because it'll actually create a font that small. } + if GetTextMetrics(DC, TM) then begin + { If the original height was negative, keep it negative } + if LogFont.lfHeight <= 0 then + LogFont.lfHeight := -(TM.tmHeight - TM.tmInternalLeading) + else + LogFont.lfHeight := TM.tmHeight; + end; + end; + + { Use a vertical font if available so that Asian characters aren't drawn + sideways } + VerticalFontName := String('@') + LogFont.lfFaceName; + if FontExists(DC, VerticalFontName) then begin + {$IFNDEF CLR} + StrPLCopy(LogFont.lfFaceName, VerticalFontName, + (SizeOf(LogFont.lfFaceName) div SizeOf(LogFont.lfFaceName[0])) - 1); + {$ELSE} + LogFont.lfFaceName := VerticalFontName; + {$ENDIF} + end; + + Result := CreateFontIndirect(LogFont); +end; + +procedure DrawRotatedText(const DC: HDC; AText: String; const ARect: TRect; + const AFormat: Cardinal); +{ Like DrawText, but draws the text at a 270 degree angle. + The only format flag this function respects is DT_HIDEPREFIX. Text is always + drawn centered. } +var + RotatedFont, SaveFont: HFONT; + TextMetrics: TTextMetric; + X, Y, P, I, SU, FU: Integer; + SaveAlign: UINT; + SavePen, Pen: HPEN; +begin + RotatedFont := CreateRotatedFont(DC); + SaveFont := SelectObject(DC, RotatedFont); + + GetTextMetrics(DC, TextMetrics); + X := ARect.Left + ((ARect.Right - ARect.Left) - TextMetrics.tmHeight) div 2; + Y := ARect.Top + ((ARect.Bottom - ARect.Top) - GetTextWidth(DC, AText, True)) div 2; + + { Find the index of the character that should be underlined. Delete '&' + characters from the string. Like DrawText, only the last prefixed character + will be underlined. } + P := 0; + I := 1; + while I <= Length(AText) do begin + {$IFNDEF JR_WIDESTR} + if AText[I] in LeadBytes then + Inc(I) + else + {$ENDIF} + if AText[I] = '&' then begin + Delete(AText, I, 1); + { If the '&' was the last character, don't underline anything } + if I > Length(AText) then + P := 0 + else if AText[I] <> '&' then + P := I; + end; + Inc(I); + end; + + SaveAlign := SetTextAlign(DC, TA_BOTTOM); + TextOutStr(DC, X, Y, AText); + SetTextAlign(DC, SaveAlign); + { Underline } + if (P > 0) and (AFormat and DT_HIDEPREFIX = 0) then begin + SU := GetTextWidth(DC, Copy(AText, 1, P-1), False); + FU := SU + GetTextWidth(DC, AText[P], False); + Inc(X, TextMetrics.tmDescent - 2); + Pen := CreatePen(PS_SOLID, 1, GetTextColor(DC)); + SavePen := SelectObject(DC, Pen); + MoveToEx(DC, X, Y + SU, nil); + LineTo(DC, X, Y + FU); + SelectObject(DC, SavePen); + DeleteObject(Pen); + end; + + SelectObject(DC, SaveFont); + DeleteObject(RotatedFont); +end; + +function NeedToPlaySound(const Alias: String): Boolean; +{ This function checks the registry to see if the specified sound event alias + is assigned to a file. + The purpose of having this function is so it can avoid calls to PlaySound if + possible, because on Windows 2000 there is an annoying 1/3 second delay on + the first call to PlaySound. + Windows Explorer actually uses this same technique when playing sounds for + the Start menu. } +var + KeyName: String; + K: HKEY; + {$IFNDEF CLR} + Data: array[0..3] of WideChar; + {$ELSE} + Data: TBytes; + DataType: DWORD; + {$ENDIF} + DataSize: DWORD; + ErrorCode: Longint; +begin + if (Win32MajorVersion < 5) or (Win32Platform <> VER_PLATFORM_WIN32_NT) then begin + { No need to check pre-Windows 2000 versions since their PlaySound + functions don't have the delay; always return True. } + Result := True; + Exit; + end; + Result := False; + KeyName := 'AppEvents\Schemes\Apps\.Default\' + Alias + '\.Current'; + if RegOpenKeyEx(HKEY_CURRENT_USER, {$IFNDEF CLR}PChar{$ENDIF}(KeyName), + 0, KEY_QUERY_VALUE, K) = ERROR_SUCCESS then begin + try + {$IFNDEF CLR} + DataSize := SizeOf(Data); + { Note: Use the 'W' version of RegQueryValueEx for more speed } + ErrorCode := RegQueryValueExW(K, nil, nil, nil, @Data, @DataSize); + if ((ErrorCode = ERROR_SUCCESS) and (Data[0] <> #0)) or + (ErrorCode = ERROR_MORE_DATA) then + Result := True; + {$ELSE} + DataSize := 4 * SizeOf(WideChar); + SetLength(Data, DataSize); + ErrorCode := RegQueryValueExW(K, nil, nil, DataType, Data, DataSize); + if ((ErrorCode = ERROR_SUCCESS) and (Data[0] or Data[1] <> 0)) or + (ErrorCode = ERROR_MORE_DATA) then + Result := True; + {$ENDIF} + finally + RegCloseKey(K); + end; + end; +end; + +procedure PlaySystemSound(const Alias: String); +const + SND_SYSTEM = $00200000; +var + Flags: DWORD; +begin + Flags := SND_ALIAS or SND_ASYNC or SND_NODEFAULT; + if Win32Platform <> VER_PLATFORM_WIN32_NT then + Flags := Flags or SND_NOSTOP; { On 9x, native menus' sounds are NOSTOP } + if Win32MajorVersion >= 6 then + Flags := Flags or SND_SYSTEM; + PlaySound({$IFNDEF CLR}PChar{$ENDIF}(Alias), 0, Flags); +end; + +function Max(A, B: Integer): Integer; +begin + if A >= B then + Result := A + else + Result := B; +end; + +function Min(A, B: Integer): Integer; +begin + if A <= B then + Result := A + else + Result := B; +end; + +function FindAccelChar(const S: String): Char; +{ Finds the last accelerator key in S. Returns #0 if no accelerator key was + found. '&&' is ignored. } +{$IFNDEF CLR} +var + P: PChar; +begin + P := PChar(S); + Result := #0; + while True do begin + P := AnsiStrScan(P, '&'); + if P = nil then Break; + Inc(P); + if P^ <> '&' then begin + if P^ = #0 then Break; + Result := P^; + end; + Inc(P); + end; +end; +{$ELSE} +var + Len, I: Integer; +begin + Result := #0; + Len := Length(S); + if Len > 0 then begin { ensures S isn't nil } + I := 1; + while True do begin + I := System.String(S).IndexOf('&', I - 1) + 1; + if (I = 0) or (I >= Len) then + Break; + Inc(I); + if S[I] <> '&' then + Result := S[I]; + Inc(I); + end; + end; +end; +{$ENDIF} + +function IsWindowsXP: Boolean; +begin + Result := (Win32Platform = VER_PLATFORM_WIN32_NT) and + ((Win32MajorVersion > 5) or + ((Win32MajorVersion = 5) and (Win32MinorVersion >= 1))); +end; + +function GetInputLocaleCodePage: UINT; +{ Returns the code page identifier of the active input locale, or CP_ACP if + for some unknown reason it couldn't be determined. } +var + {$IFNDEF CLR} + Buf: array[0..15] of Char; + {$ELSE} + Buf: StringBuilder; + {$ENDIF} + ErrorCode: Integer; +begin + {$IFNDEF CLR} + if GetLocaleInfo(GetKeyboardLayout(0) and $FFFF, LOCALE_IDEFAULTANSICODEPAGE, + Buf, SizeOf(Buf) div SizeOf(Buf[0])) > 0 then begin + Buf[High(Buf)] := #0; { ensure null termination, just in case... } + Val(Buf, Result, ErrorCode); + {$ELSE} + Buf := StringBuilder.Create(16); + if GetLocaleInfo(GetKeyboardLayout(0) and $FFFF, LOCALE_IDEFAULTANSICODEPAGE, + Buf, Buf.Capacity) > 0 then begin + Val(Buf.ToString, Result, ErrorCode); + {$ENDIF} + { Just to be *completely* safe, verify that the code page returned by + GetLocaleInfo actually exists. The result of this function may be fed + into WideCharToMultiByte, and we don't want WideCharToMultiByte to fail + entirely because of a bad code page. } + if (ErrorCode <> 0) or not IsValidCodePage(Result) then + Result := CP_ACP; + end + else + Result := CP_ACP; +end; + +function GetMessagePosAsPoint: TPoint; +var + Pos: DWORD; +begin + Pos := GetMessagePos; + Result.X := Smallint(Pos and $FFFF); + Result.Y := Smallint(Pos shr 16); +end; + +function GetSystemNonClientMetrics(var Metrics: TNonClientMetrics): Boolean; +{$IFNDEF CLR} +begin + Metrics.cbSize := SizeOf(Metrics); + Result := SystemParametersInfo(SPI_GETNONCLIENTMETRICS, SizeOf(Metrics), + @Metrics, 0); +end; +{$ELSE} +begin + {$IFDEF JR_D11} + { On Delphi.NET 2007, Forms.GetNonClientMetrics is marked deprecated } + Metrics.cbSize := Marshal.SizeOf(TypeOf(TNonClientMetrics)); + Result := SystemParametersInfo(SPI_GETNONCLIENTMETRICS, Metrics.cbSize, + Metrics, 0); + {$ELSE} + Result := Forms.GetNonClientMetrics(Metrics); + {$ENDIF} +end; +{$ENDIF} + +function GetSystemParametersInfoBool(const Param: UINT; const Default: BOOL): BOOL; +{ Returns the value of the specified BOOL-type system parameter, or Default + if the function fails } +begin + if not SystemParametersInfo(Param, 0, {$IFNDEF CLR}@{$ENDIF} Result, 0) then + Result := Default; +end; + +{$IFDEF CLR} +{ Use our own declaration for CharLowerBuffA that takes a byte array directly + instead of StringBuilder } +[SuppressUnmanagedCodeSecurity, DllImport(user32, CharSet = CharSet.Ansi, SetLastError = True, EntryPoint = 'CharLowerBuffA')] +function _CharLowerBuffA([in, out] lpsz: TBytes; cchLength: DWORD): DWORD; external; +{$ENDIF} + +function CharToLower(const C: Char): Char; +{ Converts a single character to lowercase using the current code page } +{$IFNDEF CLR} +begin + Result := Char(CharLower(Pointer(Word(C)))); +end; +{$ELSE} +var + AnsiBytes: TBytes; +begin + { Note: On .NET we can't use LowerCase()/String.ToLower() because it uses + linguistic casing rules -- on a Turkish locale "I" is NOT mapped to "i". + This would break accelerator keys when running English apps. With + CharLower, "I" is always mapped to "i". } + if Marshal.SystemDefaultCharSize = 1 then begin + { On Windows 9x/Me we have to use CharLowerBuff since the character may be + two bytes when downconverted to ANSI. And we have to handle the + Unicode->ANSI conversion ourself so that we know the correct length to + pass to the function. } + AnsiBytes := AnsiEncoding.GetBytes(C); + _CharLowerBuffA(AnsiBytes, Length(AnsiBytes)); + Result := AnsiEncoding.GetChars(AnsiBytes)[0]; + end + else + Result := Char(Word(CharLowerW(IntPtr(Word(C))))); +end; +{$ENDIF} + +{$IFNDEF JR_D6} +function InvalidPoint(const At: TPoint): Boolean; +begin + Result := (At.X = -1) and (At.Y = -1); +end; +{$ENDIF} + +{$IFDEF CLR} +function ClipToLongint(const I: Int64): Longint; inline; +{ On Delphi.NET 2007, casting a LPARAM (THandle) directly into a Longint can + raise an overflow exception (possibly a bug?). By passing the LPARAM to + this function, which acts like a Longint(Int64()) cast, the exception can + be avoided. } +begin + Result := Longint(I); +end; +{$ENDIF} + +initialization + InitGradientFillFunc; + {$IFNDEF CLR} + InitMultiMonApis; + LockSetForegroundWindowFunc := GetProcAddress(GetModuleHandle(user32), + 'LockSetForegroundWindow'); + {$ENDIF} +end. diff --git a/internal/2.2.2/1/Source/TB2Consts.pas b/internal/2.2.2/1/Source/TB2Consts.pas new file mode 100644 index 0000000..fb29db0 --- /dev/null +++ b/internal/2.2.2/1/Source/TB2Consts.pas @@ -0,0 +1,34 @@ +unit TB2Consts; +{ $jrsoftware: tb2k/Source/TB2Consts.pas,v 1.8 2006/03/12 23:11:58 jr Exp $ } + +interface + +{$I TB2Ver.inc} + +resourcestring + { Exceptions } + STBToolbarIndexOutOfBounds = 'Toolbar item index out of range'; + STBToolbarItemReinserted = 'Toolbar item already inserted'; + STBToolbarItemParentInvalid = 'Toolbar item cannot be inserted into container of type %s'; + STBViewerNotFound = 'An item viewer associated the specified item could not be found'; + + { TTBChevronItem } + STBChevronItemMoreButtonsHint = 'More Buttons|'; + + { TTBMRUListItem } + STBMRUListItemDefCaption = '(MRU List)'; + + { TTBMDIWindowItem } + STBMDIWindowItemDefCaption = '(Window List)'; + + { TTBDock exception messages } + STBDockParentNotAllowed = 'A TTBDock control cannot be placed inside a tool window or another TTBDock'; + STBDockCannotChangePosition = 'Cannot change Position of a TTBDock if it already contains controls'; + + { TTBCustomDockableWindow exception messages } + STBToolwinNameNotSet = 'Cannot save dockable window''s position because Name property is not set'; + STBToolwinDockedToNameNotSet = 'Cannot save dockable window''s position because DockedTo''s Name property not set'; + +implementation + +end. diff --git a/internal/2.2.2/1/Source/TB2Dock.pas b/internal/2.2.2/1/Source/TB2Dock.pas new file mode 100644 index 0000000..cbc94b1 --- /dev/null +++ b/internal/2.2.2/1/Source/TB2Dock.pas @@ -0,0 +1,5670 @@ +unit TB2Dock; + +{ + Toolbar2000 + Copyright (C) 1998-2008 by Jordan Russell + All rights reserved. + + The contents of this file are subject to the "Toolbar2000 License"; you may + not use or distribute this file except in compliance with the + "Toolbar2000 License". A copy of the "Toolbar2000 License" may be found in + TB2k-LICENSE.txt or at: + http://www.jrsoftware.org/files/tb2k/TB2k-LICENSE.txt + + Alternatively, the contents of this file may be used under the terms of the + GNU General Public License (the "GPL"), in which case the provisions of the + GPL are applicable instead of those in the "Toolbar2000 License". A copy of + the GPL may be found in GPL-LICENSE.txt or at: + http://www.jrsoftware.org/files/tb2k/GPL-LICENSE.txt + If you wish to allow use of your version of this file only under the terms of + the GPL and not to allow others to use your version of this file under the + "Toolbar2000 License", indicate your decision by deleting the provisions + above and replace them with the notice and other provisions required by the + GPL. If you do not delete the provisions above, a recipient may use your + version of this file under either the "Toolbar2000 License" or the GPL. + + $jrsoftware: tb2k/Source/TB2Dock.pas,v 1.127 2008/09/17 20:12:25 jr Exp $ +} + +interface + +{x$DEFINE TB2Dock_DisableLock} +{ Remove the 'x' to enable the define. It will disable calls to + LockWindowUpdate, which it calls to disable screen updates while dragging. + You may want to temporarily enable the define while debugging so you are able + to see your code window while stepping through the dragging routines. } + +{$I TB2Ver.inc} + +uses + Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, IniFiles; + +type + TTBCustomForm = {$IFDEF JR_D3} TCustomForm {$ELSE} TForm {$ENDIF}; + + { TTBDock } + + TTBDockBoundLinesValues = (blTop, blBottom, blLeft, blRight); + TTBDockBoundLines = set of TTBDockBoundLinesValues; + TTBDockPosition = (dpTop, dpBottom, dpLeft, dpRight); + TTBDockType = (dtNotDocked, dtFloating, dtTopBottom, dtLeftRight); + TTBDockableTo = set of TTBDockPosition; + + TTBCustomDockableWindow = class; + TTBBasicBackground = class; + + TTBInsertRemoveEvent = procedure(Sender: TObject; Inserting: Boolean; + Bar: TTBCustomDockableWindow) of object; + TTBRequestDockEvent = procedure(Sender: TObject; Bar: TTBCustomDockableWindow; + var Accept: Boolean) of object; + + TTBDock = class(TCustomControl) + private + { Property values } + FPosition: TTBDockPosition; + FAllowDrag: Boolean; + FBoundLines: TTBDockBoundLines; + FBackground: TTBBasicBackground; + FBkgOnToolbars: Boolean; + FFixAlign: Boolean; + FCommitNewPositions: Boolean; + FLimitToOneRow: Boolean; + FOnInsertRemoveBar: TTBInsertRemoveEvent; + FOnRequestDock: TTBRequestDockEvent; + {$IFNDEF JR_D4} + FOnResize: TNotifyEvent; + {$ENDIF} + + { Internal } + FDisableArrangeToolbars: Integer; { Increment to disable ArrangeToolbars } + FArrangeToolbarsNeeded: Boolean; + FNonClientWidth, FNonClientHeight: Integer; + DockList: TList; { List of the toolbars docked, and those floating and have LastDock + pointing to the dock. Items are casted in TTBCustomDockableWindow's. } + DockVisibleList: TList; { Similar to DockList, but lists only docked and visible toolbars } + + { Property access methods } + //function GetVersion: TToolbar97Version; + procedure SetAllowDrag(Value: Boolean); + procedure SetBackground(Value: TTBBasicBackground); + procedure SetBackgroundOnToolbars(Value: Boolean); + procedure SetBoundLines(Value: TTBDockBoundLines); + procedure SetFixAlign(Value: Boolean); + procedure SetPosition(Value: TTBDockPosition); + //procedure SetVersion(const Value: TToolbar97Version); + + function GetToolbarCount: Integer; + function GetToolbars(Index: Integer): TTBCustomDockableWindow; + + { Internal } + procedure BackgroundChanged(Sender: TObject); + procedure ChangeDockList(const Insert: Boolean; const Bar: TTBCustomDockableWindow); + procedure ChangeWidthHeight(const NewWidth, NewHeight: Integer); + procedure CommitPositions; + procedure DrawNCArea(const DrawToDC: Boolean; const ADC: HDC; + const Clip: HRGN); + function GetDesignModeRowOf(const XY: Integer): Integer; + function HasVisibleToolbars: Boolean; + procedure RelayMsgToFloatingBars({$IFNDEF CLR}var{$ELSE}const{$ENDIF} Message: TMessage); + function ToolbarVisibleOnDock(const AToolbar: TTBCustomDockableWindow): Boolean; + procedure ToolbarVisibilityChanged(const Bar: TTBCustomDockableWindow; + const ForceRemove: Boolean); + + { Messages } + procedure CMDialogChar(var Message: TCMDialogChar); message CM_DIALOGCHAR; + procedure CMDialogKey(var Message: TCMDialogKey); message CM_DIALOGKEY; + procedure CMSysColorChange(var Message: TMessage); message CM_SYSCOLORCHANGE; + procedure WMEraseBkgnd(var Message: TWMEraseBkgnd); message WM_ERASEBKGND; + procedure WMMove(var Message: TWMMove); message WM_MOVE; + {$IFNDEF JR_D4} + procedure WMSize(var Message: TWMSize); message WM_SIZE; + {$ENDIF} + procedure WMNCCalcSize(var Message: TWMNCCalcSize); message WM_NCCALCSIZE; + procedure WMNCPaint(var Message: TMessage); message WM_NCPAINT; + procedure WMPrint(var Message: TMessage); message WM_PRINT; + procedure WMPrintClient(var Message: {$IFNDEF CLR} TMessage {$ELSE} TWMPrintClient {$ENDIF}); message WM_PRINTCLIENT; + procedure WMSysCommand(var Message: TWMSysCommand); message WM_SYSCOMMAND; + protected + procedure AlignControls(AControl: TControl; var Rect: TRect); override; + procedure CreateParams(var Params: TCreateParams); override; + procedure DrawBackground(DC: HDC; const DrawRect: TRect); virtual; + function GetPalette: HPALETTE; override; + procedure InvalidateBackgrounds; + procedure Loaded; override; + procedure Notification(AComponent: TComponent; Operation: TOperation); override; + procedure SetParent(AParent: TWinControl); override; + procedure Paint; override; + function UsingBackground: Boolean; virtual; + public + constructor Create(AOwner: TComponent); override; + destructor Destroy; override; + + procedure ArrangeToolbars; + procedure BeginUpdate; + procedure EndUpdate; + function GetCurrentRowSize(const Row: Integer; var AFullSize: Boolean): Integer; + function GetHighestRow(const HighestEffective: Boolean): Integer; + function GetMinRowSize(const Row: Integer; + const ExcludeControl: TTBCustomDockableWindow): Integer; + + property CommitNewPositions: Boolean read FCommitNewPositions write FCommitNewPositions; + property NonClientWidth: Integer read FNonClientWidth; + property NonClientHeight: Integer read FNonClientHeight; + property ToolbarCount: Integer read GetToolbarCount; + property Toolbars[Index: Integer]: TTBCustomDockableWindow read GetToolbars; + published + property AllowDrag: Boolean read FAllowDrag write SetAllowDrag default True; + property Background: TTBBasicBackground read FBackground write SetBackground; + property BackgroundOnToolbars: Boolean read FBkgOnToolbars write SetBackgroundOnToolbars default True; + property BoundLines: TTBDockBoundLines read FBoundLines write SetBoundLines default []; + property Color default clBtnFace; + property FixAlign: Boolean read FFixAlign write SetFixAlign default False; + property LimitToOneRow: Boolean read FLimitToOneRow write FLimitToOneRow default False; + property PopupMenu; + property Position: TTBDockPosition read FPosition write SetPosition default dpTop; + //property Version: TToolbar97Version read GetVersion write SetVersion stored False; + property Visible; + + {$IFDEF JR_D5} + property OnContextPopup; + {$ENDIF} + property OnInsertRemoveBar: TTBInsertRemoveEvent read FOnInsertRemoveBar write FOnInsertRemoveBar; + property OnMouseDown; + property OnMouseMove; + property OnMouseUp; + property OnRequestDock: TTBRequestDockEvent read FOnRequestDock write FOnRequestDock; + {$IFDEF JR_D4} + property OnResize; + {$ELSE} + property OnResize: TNotifyEvent read FOnResize write FOnResize; + {$ENDIF} + end; + + { TTBFloatingWindowParent - internal } + + TTBToolWindowNCRedrawWhatElement = (twrdBorder, twrdCaption, twrdCloseButton); + TTBToolWindowNCRedrawWhat = set of TTBToolWindowNCRedrawWhatElement; + + TTBFloatingWindowParentClass = class of TTBFloatingWindowParent; + TTBFloatingWindowParent = class(TCustomForm) + private + FCloseButtonDown: Boolean; { True if Close button is currently depressed } + FDockableWindow: TTBCustomDockableWindow; + FParentForm: TTBCustomForm; + FShouldShow: Boolean; + + procedure CallRecreateWnd; + function GetCaptionRect(const AdjustForBorder, MinusCloseButton: Boolean): TRect; + function GetCloseButtonRect(const AdjustForBorder: Boolean): TRect; + procedure SetCloseButtonState(Pushed: Boolean); + procedure RedrawNCArea(const RedrawWhat: TTBToolWindowNCRedrawWhat); + + procedure CMShowingChanged(var Message: TMessage); message CM_SHOWINGCHANGED; + procedure CMDialogKey(var Message: TCMDialogKey); message CM_DIALOGKEY; + procedure CMTextChanged(var Message: TMessage); message CM_TEXTCHANGED; + procedure WMActivate(var Message: TWMActivate); message WM_ACTIVATE; + procedure WMClose(var Message: TWMClose); message WM_CLOSE; + procedure WMGetMinMaxInfo(var Message: TWMGetMinMaxInfo); message WM_GETMINMAXINFO; + procedure WMMouseActivate(var Message: TWMMouseActivate); message WM_MOUSEACTIVATE; + procedure WMMove(var Message: TWMMove); message WM_MOVE; + procedure WMNCCalcSize(var Message: TWMNCCalcSize); message WM_NCCALCSIZE; + procedure WMNCHitTest(var Message: TWMNCHitTest); message WM_NCHITTEST; + procedure WMNCLButtonDblClk(var Message: TWMNCLButtonDblClk); message WM_NCLBUTTONDBLCLK; + procedure WMNCLButtonDown(var Message: TWMNCLButtonDown); message WM_NCLBUTTONDOWN; + procedure WMNCPaint(var Message: TMessage); message WM_NCPAINT; + procedure WMNCRButtonUp(var Message: TWMNCRButtonUp); message WM_NCRBUTTONUP; + procedure WMPrint(var Message: TMessage); message WM_PRINT; + procedure WMPrintClient(var Message: {$IFNDEF CLR} TMessage {$ELSE} TWMPrintClient {$ENDIF}); message WM_PRINTCLIENT; + protected + procedure AlignControls(AControl: TControl; var Rect: TRect); override; + procedure CreateParams(var Params: TCreateParams); override; + procedure DrawNCArea(const DrawToDC: Boolean; const ADC: HDC; + const Clip: HRGN; RedrawWhat: TTBToolWindowNCRedrawWhat); dynamic; + procedure Notification(AComponent: TComponent; Operation: TOperation); override; + property DockableWindow: TTBCustomDockableWindow read FDockableWindow; + property CloseButtonDown: Boolean read FCloseButtonDown; + public + property ParentForm: TTBCustomForm read FParentForm; + end; + + { TTBCustomDockableWindow } + + TTBDockChangingEvent = procedure(Sender: TObject; Floating: Boolean; + DockingTo: TTBDock) of object; + TTBDragHandleStyle = (dhDouble, dhNone, dhSingle); + TTBDockMode = (dmCanFloat, dmCannotFloat, dmCannotFloatOrChangeDocks); + TTBFloatingMode = (fmOnTopOfParentForm, fmOnTopOfAllForms); + TTBSizeHandle = (twshLeft, twshRight, twshTop, twshTopLeft, + twshTopRight, twshBottom, twshBottomLeft, twshBottomRight); + { ^ must be in same order as HTLEFT..HTBOTTOMRIGHT } + TTBPositionExtraData = {$IFNDEF CLR} Pointer {$ELSE} TObject {$ENDIF}; + TTBPositionReadIntProc = function(const ToolbarName, Value: String; const Default: Longint; + const ExtraData: TTBPositionExtraData): Longint; + TTBPositionReadStringProc = function(const ToolbarName, Value, Default: String; + const ExtraData: TTBPositionExtraData): String; + TTBPositionWriteIntProc = procedure(const ToolbarName, Value: String; const Data: Longint; + const ExtraData: TTBPositionExtraData); + TTBPositionWriteStringProc = procedure(const ToolbarName, Value, Data: String; + const ExtraData: TTBPositionExtraData); + TTBReadPositionData = record + ReadIntProc: TTBPositionReadIntProc; + ReadStringProc: TTBPositionReadStringProc; + ExtraData: TTBPositionExtraData; + end; + TTBWritePositionData = record + WriteIntProc: TTBPositionWriteIntProc; + WriteStringProc: TTBPositionWriteStringProc; + ExtraData: TTBPositionExtraData; + end; + TTBDockableWindowStyles = set of (tbdsResizeEightCorner, tbdsResizeClipCursor); + TTBShrinkMode = (tbsmNone, tbsmWrap, tbsmChevron); + + TTBCustomDockableWindow = class(TCustomControl) + private + { Property variables } + FAutoResize: Boolean; + FDockPos, FDockRow, FEffectiveDockPos, FEffectiveDockRow: Integer; + FDocked: Boolean; + FCurrentDock, FDefaultDock, FLastDock: TTBDock; + FCurrentSize: Integer; + FFloating: Boolean; + FOnClose, FOnDockChanged, FOnMove, FOnRecreated, + FOnRecreating, {$IFNDEF JR_D4} FOnResize, {$ENDIF} + FOnVisibleChanged: TNotifyEvent; + FOnCloseQuery: TCloseQueryEvent; + FOnDockChanging, FOnDockChangingHidden: TTBDockChangingEvent; + FActivateParent, FHideWhenInactive, FCloseButton, FCloseButtonWhenDocked, + FFullSize, FResizable, FShowCaption, FStretch, FUseLastDock: Boolean; + FBorderStyle: TBorderStyle; + FDockMode: TTBDockMode; + FDragHandleStyle: TTBDragHandleStyle; + FDockableTo: TTBDockableTo; + FFloatingMode: TTBFloatingMode; + FSmoothDrag: Boolean; + FDockableWindowStyles: TTBDockableWindowStyles; + FLastRowSize: Integer; + FInsertRowBefore: Boolean; + + { Misc. } + FUpdatingBounds, { Incremented while internally changing the bounds. This allows + it to move the toolbar freely in design mode and prevents the + SizeChanging protected method from begin called } + FDisableArrange, { Incremented to disable Arrange } + FDisableOnMove, { Incremented to prevent WM_MOVE handler from calling the OnMoved handler } + FHidden: Integer; { Incremented while the toolbar is temporarily hidden } + FArrangeNeeded, FMoved: Boolean; + FInactiveCaption: Boolean; { True when the caption of the toolbar is currently the inactive color } + FFloatingPosition: TPoint; + FDockForms: TList; + FSavedAtRunTime: Boolean; + //FNonClientWidth, FNonClientHeight: Integer; + FDragMode, FDragSplitting, FDragCanSplit: Boolean; + FSmoothDragging: Boolean; + + { When floating. These are not used in design mode } + FCloseButtonDown: Boolean; { True if Close button is currently depressed } + FCloseButtonHover: Boolean; + FFloatParent: TTBFloatingWindowParent; { Run-time only: The actual Parent of the toolbar when it is floating } + + { Property access methods } + //function GetVersion: TToolbar97Version; + function GetNonClientWidth: Integer; + function GetNonClientHeight: Integer; + function IsLastDockStored: Boolean; + function IsWidthAndHeightStored: Boolean; + procedure SetAutoResize(Value: Boolean); + procedure SetBorderStyle(Value: TBorderStyle); + procedure SetCloseButton(Value: Boolean); + procedure SetCloseButtonWhenDocked(Value: Boolean); + procedure SetCurrentDock(Value: TTBDock); + procedure SetDefaultDock(Value: TTBDock); + procedure SetDockPos(Value: Integer); + procedure SetDockRow(Value: Integer); + procedure SetDragHandleStyle(Value: TTBDragHandleStyle); + procedure SetFloating(Value: Boolean); + procedure SetFloatingMode(Value: TTBFloatingMode); + procedure SetFloatingPosition(Value: TPoint); + procedure SetFullSize(Value: Boolean); + procedure SetLastDock(Value: TTBDock); + procedure SetResizable(Value: Boolean); + procedure SetShowCaption(Value: Boolean); + procedure SetStretch(Value: Boolean); + procedure SetUseLastDock(Value: Boolean); + //procedure SetVersion(const Value: TToolbar97Version); + + { Internal } + procedure CancelNCHover; + procedure DrawDraggingOutline(const DC: HDC; const NewRect, OldRect: TRect; + const NewDocking, OldDocking: Boolean); + procedure RedrawNCArea; + procedure SetCloseButtonState(Pushed: Boolean); + procedure ShowNCContextMenu(const PosX, PosY: Smallint); + procedure Moved; + function GetShowingState: Boolean; + procedure UpdateCaptionState; + procedure UpdateTopmostFlag; + procedure UpdateVisibility; + procedure ReadSavedAtRunTime(Reader: TReader); + procedure WriteSavedAtRunTime(Writer: TWriter); + + { Messages } + procedure CMColorChanged(var Message: TMessage); message CM_COLORCHANGED; + procedure CMMouseLeave(var Message: TMessage); message CM_MOUSELEAVE; + procedure CMTextChanged(var Message: TMessage); message CM_TEXTCHANGED; + procedure CMShowingChanged(var Message: TMessage); message CM_SHOWINGCHANGED; + procedure CMVisibleChanged(var Message: TMessage); message CM_VISIBLECHANGED; + {$IFDEF JR_D5} + procedure WMContextMenu(var Message: TWMContextMenu); message WM_CONTEXTMENU; + {$ENDIF} + procedure WMEraseBkgnd(var Message: TWMEraseBkgnd); message WM_ERASEBKGND; + procedure WMMove(var Message: TWMMove); message WM_MOVE; + procedure WMMouseMove(var Message: TWMMouseMove); message WM_MOUSEMOVE; + procedure WMNCCalcSize(var Message: TWMNCCalcSize); message WM_NCCALCSIZE; + procedure WMNCHitTest(var Message: TWMNCHitTest); message WM_NCHITTEST; + procedure WMNCMouseLeave(var Message: TMessage); message $2A2 {WM_NCMOUSELEAVE}; + procedure WMNCMouseMove(var Message: TWMNCMouseMove); message WM_NCMOUSEMOVE; + procedure WMNCLButtonDblClk(var Message: TWMNCLButtonDblClk); message WM_NCLBUTTONDBLCLK; + procedure WMNCLButtonDown(var Message: TWMNCLButtonDown); message WM_NCLBUTTONDOWN; + procedure WMNCPaint(var Message: TMessage); message WM_NCPAINT; + procedure WMNCRButtonUp(var Message: TWMNCRButtonUp); message WM_NCRBUTTONUP; + procedure WMPrint(var Message: TMessage); message WM_PRINT; + procedure WMPrintClient(var Message: {$IFNDEF CLR} TMessage {$ELSE} TWMPrintClient {$ENDIF}); message WM_PRINTCLIENT; + procedure WMSetCursor(var Message: TWMSetCursor); message WM_SETCURSOR; + {$IFNDEF JR_D4} + procedure WMSize(var Message: TWMSize); message WM_SIZE; + {$ENDIF} + protected + property ActivateParent: Boolean read FActivateParent write FActivateParent default True; + property AutoResize: Boolean read FAutoResize write SetAutoResize default True; + property BorderStyle: TBorderStyle read FBorderStyle write SetBorderStyle default bsSingle; + property Color default clBtnFace; + property CloseButton: Boolean read FCloseButton write SetCloseButton default True; + property CloseButtonDown: Boolean read FCloseButtonDown; + property CloseButtonHover: Boolean read FCloseButtonHover; + property CloseButtonWhenDocked: Boolean read FCloseButtonWhenDocked write SetCloseButtonWhenDocked default False; + property DefaultDock: TTBDock read FDefaultDock write SetDefaultDock; + property DockableTo: TTBDockableTo read FDockableTo write FDockableTo default [dpTop, dpBottom, dpLeft, dpRight]; + property DockableWindowStyles: TTBDockableWindowStyles read FDockableWindowStyles write FDockableWindowStyles; + property DockMode: TTBDockMode read FDockMode write FDockMode default dmCanFloat; + property DragHandleStyle: TTBDragHandleStyle read FDragHandleStyle write SetDragHandleStyle default dhSingle; + property FloatingMode: TTBFloatingMode read FFloatingMode write SetFloatingMode default fmOnTopOfParentForm; + property FullSize: Boolean read FFullSize write SetFullSize default False; + property InactiveCaption: Boolean read FInactiveCaption; + property HideWhenInactive: Boolean read FHideWhenInactive write FHideWhenInactive default True; + property Resizable: Boolean read FResizable write SetResizable default True; + property ShowCaption: Boolean read FShowCaption write SetShowCaption default True; + property SmoothDrag: Boolean read FSmoothDrag write FSmoothDrag default True; + property Stretch: Boolean read FStretch write SetStretch default False; + property UseLastDock: Boolean read FUseLastDock write SetUseLastDock default True; + //property Version: TToolbar97Version read GetVersion write SetVersion stored False; + + property OnClose: TNotifyEvent read FOnClose write FOnClose; + property OnCloseQuery: TCloseQueryEvent read FOnCloseQuery write FOnCloseQuery; + property OnDockChanged: TNotifyEvent read FOnDockChanged write FOnDockChanged; + property OnDockChanging: TTBDockChangingEvent read FOnDockChanging write FOnDockChanging; + property OnDockChangingHidden: TTBDockChangingEvent read FOnDockChangingHidden write FOnDockChangingHidden; + property OnMove: TNotifyEvent read FOnMove write FOnMove; + property OnRecreated: TNotifyEvent read FOnRecreated write FOnRecreated; + property OnRecreating: TNotifyEvent read FOnRecreating write FOnRecreating; + {$IFNDEF JR_D4} + property OnResize: TNotifyEvent read FOnResize write FOnResize; + {$ENDIF} + property OnVisibleChanged: TNotifyEvent read FOnVisibleChanged write FOnVisibleChanged; + + { Overridden methods } + procedure CreateParams(var Params: TCreateParams); override; + procedure DefineProperties(Filer: TFiler); override; + function GetPalette: HPALETTE; override; + procedure Loaded; override; + procedure MouseDown(Button: TMouseButton; Shift: TShiftState; X, Y: Integer); override; + procedure Notification(AComponent: TComponent; Operation: TOperation); override; + function PaletteChanged(Foreground: Boolean): Boolean; override; + procedure SetParent(AParent: TWinControl); override; + + { Methods accessible to descendants } + procedure Arrange; + function CalcNCSizes: TPoint; virtual; + procedure ChangeSize(AWidth, AHeight: Integer); + function ChildControlTransparent(Ctl: TControl): Boolean; dynamic; + procedure Close; + procedure ControlExistsAtPos(const P: TPoint; var ControlExists: Boolean); virtual; + function DoArrange(CanMoveControls: Boolean; PreviousDockType: TTBDockType; + NewFloating: Boolean; NewDock: TTBDock): TPoint; virtual; abstract; + procedure DoDockChangingHidden(NewFloating: Boolean; DockingTo: TTBDock); dynamic; + procedure DoubleClick; + procedure DrawNCArea(const DrawToDC: Boolean; const ADC: HDC; + const Clip: HRGN); virtual; + procedure GetBaseSize(var ASize: TPoint); virtual; abstract; + function GetDockedCloseButtonRect(LeftRight: Boolean): TRect; virtual; + function GetFloatingWindowParentClass: TTBFloatingWindowParentClass; dynamic; + procedure GetMinShrinkSize(var AMinimumSize: Integer); virtual; + procedure GetMinMaxSize(var AMinClientWidth, AMinClientHeight, + AMaxClientWidth, AMaxClientHeight: Integer); virtual; + function GetShrinkMode: TTBShrinkMode; virtual; + procedure InitializeOrdering; dynamic; + function IsAutoResized: Boolean; + procedure ResizeBegin(SizeHandle: TTBSizeHandle); dynamic; + procedure ResizeEnd; dynamic; + procedure ResizeTrack(var Rect: TRect; const OrigRect: TRect); dynamic; + procedure ResizeTrackAccept; dynamic; + procedure SizeChanging(const AWidth, AHeight: Integer); virtual; + public + property Docked: Boolean read FDocked; + property Canvas; + property CurrentDock: TTBDock read FCurrentDock write SetCurrentDock stored False; + property CurrentSize: Integer read FCurrentSize write FCurrentSize; + property DockPos: Integer read FDockPos write SetDockPos default -1; + property DockRow: Integer read FDockRow write SetDockRow default 0; + property DragMode: Boolean read FDragMode; + property DragSplitting: Boolean read FDragSplitting; + property EffectiveDockPos: Integer read FEffectiveDockPos; + property EffectiveDockRow: Integer read FEffectiveDockRow; + property Floating: Boolean read FFloating write SetFloating default False; + property FloatingPosition: TPoint read FFloatingPosition write SetFloatingPosition; + property LastDock: TTBDock read FLastDock write SetLastDock stored IsLastDockStored; + property NonClientWidth: Integer read GetNonClientWidth; + property NonClientHeight: Integer read GetNonClientHeight; + + constructor Create(AOwner: TComponent); override; + destructor Destroy; override; + function GetParentComponent: TComponent; override; + function HasParent: Boolean; override; + procedure SetBounds(ALeft, ATop, AWidth, AHeight: Integer); override; + + procedure AddDockForm(const Form: TTBCustomForm); + procedure AddDockedNCAreaToSize(var S: TPoint; const LeftRight: Boolean); + procedure AddFloatingNCAreaToSize(var S: TPoint); + procedure BeginMoving(const InitX, InitY: Integer); + procedure BeginSizing(const ASizeHandle: TTBSizeHandle); + procedure BeginUpdate; + procedure DoneReadingPositionData(const Data: TTBReadPositionData); dynamic; + procedure EndUpdate; + procedure GetDockedNCArea(var TopLeft, BottomRight: TPoint; + const LeftRight: Boolean); + function GetFloatingBorderSize: TPoint; virtual; + procedure GetFloatingNCArea(var TopLeft, BottomRight: TPoint); + function IsMovable: Boolean; + procedure MoveOnScreen(const OnlyIfFullyOffscreen: Boolean); + procedure ReadPositionData(const Data: TTBReadPositionData); dynamic; + procedure RemoveDockForm(const Form: TTBCustomForm); + procedure WritePositionData(const Data: TTBWritePositionData); dynamic; + published + property Height stored IsWidthAndHeightStored; + property Width stored IsWidthAndHeightStored; + end; + + TTBBasicBackground = class(TComponent) + protected + procedure Draw(DC: HDC; const DrawRect: TRect); virtual; abstract; + function GetPalette: HPALETTE; virtual; abstract; + procedure RegisterChanges(Proc: TNotifyEvent); virtual; abstract; + procedure SysColorChanged; virtual; abstract; + procedure UnregisterChanges(Proc: TNotifyEvent); virtual; abstract; + function UsingBackground: Boolean; virtual; abstract; + end; + + TTBBackground = class(TTBBasicBackground) + private + FBitmap, FBitmapCache: TBitmap; + FBkColor: TColor; + FNotifyList: TList; + FTransparent: Boolean; + procedure BitmapChanged(Sender: TObject); + procedure SetBitmap(Value: TBitmap); + procedure SetBkColor(Value: TColor); + procedure SetTransparent(Value: Boolean); + protected + procedure Draw(DC: HDC; const DrawRect: TRect); override; + function GetPalette: HPALETTE; override; + procedure RegisterChanges(Proc: TNotifyEvent); override; + procedure SysColorChanged; override; + procedure UnregisterChanges(Proc: TNotifyEvent); override; + function UsingBackground: Boolean; override; + public + constructor Create(AOwner: TComponent); override; + destructor Destroy; override; + published + property Bitmap: TBitmap read FBitmap write SetBitmap; + property BkColor: TColor read FBkColor write SetBkColor default clBtnFace; + property Transparent: Boolean read FTransparent write SetTransparent default False; + end; + +procedure TBRegLoadPositions(const OwnerComponent: TComponent; + const RootKey: DWORD; const BaseRegistryKey: String); +procedure TBRegSavePositions(const OwnerComponent: TComponent; + const RootKey: DWORD; const BaseRegistryKey: String); +procedure TBIniLoadPositions(const OwnerComponent: TComponent; + const Filename, SectionNamePrefix: String); overload; +procedure TBIniLoadPositions(const OwnerComponent: TComponent; + const IniFile: TCustomIniFile; const SectionNamePrefix: String); overload; +procedure TBIniSavePositions(const OwnerComponent: TComponent; + const Filename, SectionNamePrefix: String); overload; +procedure TBIniSavePositions(const OwnerComponent: TComponent; + const IniFile: TCustomIniFile; const SectionNamePrefix: String); overload; + +procedure TBCustomLoadPositions(const OwnerComponent: TComponent; + const ReadIntProc: TTBPositionReadIntProc; + const ReadStringProc: TTBPositionReadStringProc; + const ExtraData: TTBPositionExtraData); +procedure TBCustomSavePositions(const OwnerComponent: TComponent; + const WriteIntProc: TTBPositionWriteIntProc; + const WriteStringProc: TTBPositionWriteStringProc; + const ExtraData: TTBPositionExtraData); + +function TBGetDockTypeOf(const Control: TTBDock; const Floating: Boolean): TTBDockType; +function TBGetToolWindowParentForm(const ToolWindow: TTBCustomDockableWindow): + TTBCustomForm; +function TBValidToolWindowParentForm(const ToolWindow: TTBCustomDockableWindow): + TTBCustomForm; + +implementation + +uses + {$IFDEF CLR} Types, System.Runtime.InteropServices, {$ENDIF} + Registry, Consts, Menus, + TB2Common, TB2Hook, TB2Consts; + +type + TControlAccess = class(TControl); + +const + DockedBorderSize = 2; + DockedBorderSize2 = DockedBorderSize*2; + DragHandleSizes: array[Boolean, TTBDragHandleStyle] of Integer = + ((9, 0, 6), (14, 14, 14)); + DragHandleXOffsets: array[Boolean, TTBDragHandleStyle] of Integer = + ((2, 0, 1), (3, 0, 5)); + HT_TB2k_Border = 2000; + HT_TB2k_Close = 2001; + HT_TB2k_Caption = 2002; + + DefaultBarWidthHeight = 8; + + ForceDockAtTopRow = 0; + ForceDockAtLeftPos = -8; + + PositionLeftOrRight = [dpLeft, dpRight]; + + twrdAll = [Low(TTBToolWindowNCRedrawWhatElement)..High(TTBToolWindowNCRedrawWhatElement)]; + + { Constants for TTBCustomDockableWindow registry values/data. + Don't localize any of these names! } + rvRev = 'Rev'; + rdCurrentRev = 2000; + rvVisible = 'Visible'; + rvDockedTo = 'DockedTo'; + rdDockedToFloating = '+'; + rvLastDock = 'LastDock'; + rvDockRow = 'DockRow'; + rvDockPos = 'DockPos'; + rvFloatLeft = 'FloatLeft'; + rvFloatTop = 'FloatTop'; + +threadvar + FloatingToolWindows: TList; + + +{ Misc. functions } + +function GetSmallCaptionHeight: Integer; +{ Returns height of the caption of a small window } +begin + Result := GetSystemMetrics(SM_CYSMCAPTION); +end; + +function GetMDIParent(const Form: TTBCustomForm): TTBCustomForm; +{ Returns the parent of the specified MDI child form. But, if Form isn't a + MDI child, it simply returns Form. } +var + I, J: Integer; +begin + Result := Form; + if Form = nil then Exit; + if {$IFDEF JR_D3} (Form is TForm) and {$ENDIF} + (TForm(Form).FormStyle = fsMDIChild) then + for I := 0 to Screen.FormCount-1 do + with Screen.Forms[I] do begin + if FormStyle <> fsMDIForm then Continue; + for J := 0 to MDIChildCount-1 do + if MDIChildren[J] = Form then begin + Result := Screen.Forms[I]; + Exit; + end; + end; +end; + +function TBGetDockTypeOf(const Control: TTBDock; const Floating: Boolean): TTBDockType; +begin + if Floating then + Result := dtFloating + else + if Control = nil then + Result := dtNotDocked + else begin + if not(Control.Position in PositionLeftOrRight) then + Result := dtTopBottom + else + Result := dtLeftRight; + end; +end; + +function TBGetToolWindowParentForm(const ToolWindow: TTBCustomDockableWindow): TTBCustomForm; +var + Ctl: TWinControl; +begin + Result := nil; + Ctl := ToolWindow; + while Assigned(Ctl.Parent) do begin + if Ctl.Parent is TTBCustomForm then + Result := TTBCustomForm(Ctl.Parent); + Ctl := Ctl.Parent; + end; + { ^ for compatibility with ActiveX controls, that code is used instead of + GetParentForm because it returns nil unless the form is the *topmost* + parent } + if Result is TTBFloatingWindowParent then + Result := TTBFloatingWindowParent(Result).ParentForm; +end; + +function TBValidToolWindowParentForm(const ToolWindow: TTBCustomDockableWindow): TTBCustomForm; +begin + Result := TBGetToolWindowParentForm(ToolWindow); + if Result = nil then + raise EInvalidOperation.{$IFDEF JR_D3}CreateFmt{$ELSE}CreateResFmt{$ENDIF} + (SParentRequired, [ToolWindow.Name]); +end; + +procedure SetWindowOwner(const Wnd, NewOwnerWnd: HWND); +begin + SetWindowLong(Wnd, GWL_HWNDPARENT, + {$IFDEF JR_D11} LONG_PTR {$ELSE} Longint {$ENDIF} (NewOwnerWnd)); +end; + +procedure ToolbarHookProc(Code: THookProcCode; Wnd: HWND; WParam: WPARAM; LParam: LPARAM); +var + I: Integer; + ToolWindow: TTBCustomDockableWindow; + WindowPos: {$IFNDEF CLR} PWindowPos {$ELSE} TWindowPos {$ENDIF}; + Form: TTBCustomForm; +begin + case Code of + hpSendActivate, + hpSendActivateApp: begin + if Assigned(FloatingToolWindows) then + for I := 0 to FloatingToolWindows.Count-1 do + { Hide or restore toolbars when a form or the application is + deactivated or activated, and/or update their caption state + (active/inactive) } + TTBCustomDockableWindow(FloatingToolWindows[I]).UpdateVisibility; + end; + hpSendWindowPosChanged: begin + if Assigned(FloatingToolWindows) then begin + {$IFNDEF CLR} + WindowPos := PWindowPos(LParam); + {$ELSE} + WindowPos := TWindowPos(Marshal.PtrToStructure(IntPtr(LParam), TypeOf(TWindowPos))); + {$ENDIF} + for I := 0 to FloatingToolWindows.Count-1 do begin + ToolWindow := TTBCustomDockableWindow(FloatingToolWindows[I]); + if (ToolWindow.FFloatingMode = fmOnTopOfParentForm) and ToolWindow.HandleAllocated then begin + { Call UpdateVisibility if parent form's visibility has + changed, or if it has been minimized or restored } + if ((WindowPos.flags and (SWP_SHOWWINDOW or SWP_HIDEWINDOW) <> 0) or + (WindowPos.flags and SWP_FRAMECHANGED <> 0)) then begin + Form := TBGetToolWindowParentForm(ToolWindow); + if Assigned(Form) and Form.HandleAllocated and ((Wnd = Form.Handle) or IsChild(Wnd, Form.Handle)) then + ToolWindow.UpdateVisibility; + end; + end; + end; + end; + end; + hpPreDestroy: begin + if Assigned(FloatingToolWindows) then + for I := 0 to FloatingToolWindows.Count-1 do begin + with TTBCustomDockableWindow(FloatingToolWindows[I]) do + { It must remove the form window's ownership of the tool window + *before* the form gets destroyed, otherwise Windows will destroy + the tool window's handle. } + if Assigned(Parent) and Parent.HandleAllocated and + (HWND(GetWindowLong(Parent.Handle, GWL_HWNDPARENT)) = Wnd) then + SetWindowOwner(Parent.Handle, Application.Handle); + { ^ Restore GWL_HWNDPARENT back to Application.Handle } + end; + end; + end; +end; + +type + {$IFNDEF CLR} + PFindWindowData = ^TFindWindowData; + TFindWindowData = record + {$ELSE} + TFindWindowData = class + private + {$ENDIF} + TaskActiveWindow, TaskFirstWindow, TaskFirstTopMost: HWND; + {$IFDEF CLR} + function DoFindWindow(Wnd: HWND; Param: LPARAM): BOOL; + {$ENDIF} + end; + +{$IFNDEF CLR} +function DoFindWindow(Wnd: HWND; Param: LPARAM): BOOL; stdcall; +{$ELSE} +function TFindWindowData.DoFindWindow(Wnd: HWND; Param: LPARAM): BOOL; +{$ENDIF} +begin + {$IFNDEF CLR} + with PFindWindowData(Param)^ do + {$ENDIF} + if (Wnd <> TaskActiveWindow) and (Wnd <> Application.Handle) and + IsWindowVisible(Wnd) and IsWindowEnabled(Wnd) then begin + if GetWindowLong(Wnd, GWL_EXSTYLE) and WS_EX_TOPMOST = 0 then begin + if TaskFirstWindow = 0 then TaskFirstWindow := Wnd; + end + else begin + if TaskFirstTopMost = 0 then TaskFirstTopMost := Wnd; + end; + end; + Result := True; +end; + +function FindTopLevelWindow(ActiveWindow: HWND): HWND; +var + FindData: TFindWindowData; +begin + {$IFDEF CLR} + FindData := TFindWindowData.Create; + {$ENDIF} + with FindData do begin + TaskActiveWindow := ActiveWindow; + TaskFirstWindow := 0; + TaskFirstTopMost := 0; + {$IFNDEF CLR} + EnumThreadWindows(GetCurrentThreadID, @DoFindWindow, LPARAM(@FindData)); + {$ELSE} + EnumThreadWindows(GetCurrentThreadID, DoFindWindow, 0); + {$ENDIF} + if TaskFirstWindow <> 0 then + Result := TaskFirstWindow + else + Result := TaskFirstTopMost; + end; +end; + +function IsAncestorOfWindow(const ParentWnd: HWND; Wnd: HWND): Boolean; +{ Returns True if Wnd is a child of, is owned by, or is the same window as + ParentWnd } +begin + while Wnd <> 0 do begin + if Wnd = ParentWnd then begin + Result := True; + Exit; + end; + Wnd := GetParent(Wnd); + end; + Result := False; +end; + +procedure RecalcNCArea(const Ctl: TWinControl); +begin + if Ctl.HandleAllocated then + SetWindowPos(Ctl.Handle, 0, 0, 0, 0, 0, SWP_FRAMECHANGED or + SWP_NOACTIVATE or SWP_NOMOVE or SWP_NOSIZE or SWP_NOZORDER); +end; + +procedure InvalidateAll(const Ctl: TWinControl); +{ Invalidate both non-client and client area, and erase. } +begin + if Ctl.HandleAllocated then + RedrawWindow(Ctl.Handle, nil, 0, RDW_FRAME or RDW_INVALIDATE or + RDW_ERASE or RDW_NOCHILDREN); +end; + +type + TSetCloseButtonStateProc = procedure(Pushed: Boolean) of object; + +function CloseButtonLoop(const Wnd: HWND; const ButtonRect: TRect; + const SetCloseButtonStateProc: TSetCloseButtonStateProc): Boolean; + function MouseInButton: Boolean; + var + P: TPoint; + begin + GetCursorPos(P); + Result := PtInRect(ButtonRect, P); + end; +var + Msg: TMsg; +begin + Result := False; + + SetCloseButtonStateProc(MouseInButton); + + SetCapture(Wnd); + + try + while GetCapture = Wnd do begin + case Integer(GetMessage(Msg, 0, 0, 0)) of + -1: Break; { if GetMessage failed } + 0: begin + { Repost WM_QUIT messages } + PostQuitMessage(ClipToLongint(Msg.wParam)); + Break; + end; + end; + + case Msg.Message of + WM_KEYDOWN, WM_KEYUP: + { Ignore all keystrokes while in a close button loop } + ; + WM_MOUSEMOVE: begin + { Note to self: WM_MOUSEMOVE messages should never be dispatched + here to ensure no hints get shown } + SetCloseButtonStateProc(MouseInButton); + end; + WM_LBUTTONDOWN, WM_LBUTTONDBLCLK: + { Make sure it doesn't begin another loop } + Break; + WM_LBUTTONUP: begin + if MouseInButton then + Result := True; + Break; + end; + WM_RBUTTONDOWN..WM_MBUTTONDBLCLK: + { Ignore all other mouse up/down messages } + ; + else + TranslateMessage(Msg); + DispatchMessage(Msg); + end; + end; + finally + if GetCapture = Wnd then + ReleaseCapture; + SetCloseButtonStateProc(False); + end; +end; + + +{ TTBDock - internal } + +constructor TTBDock.Create(AOwner: TComponent); +begin + inherited; + + ControlStyle := ControlStyle + [csAcceptsControls, csMenuEvents] - + [csClickEvents, csCaptureMouse, csOpaque]; + FAllowDrag := True; + FBkgOnToolbars := True; + DockList := TList.Create; + DockVisibleList := TList.Create; + Color := clBtnFace; + Position := dpTop; +end; + +procedure TTBDock.CreateParams(var Params: TCreateParams); +begin + inherited; + { Disable complete redraws when size changes. CS_H/VREDRAW cause flicker + and are not necessary for this control at run time } + if not(csDesigning in ComponentState) then + with Params.WindowClass do + Style := Style and not(CS_HREDRAW or CS_VREDRAW); +end; + +destructor TTBDock.Destroy; +begin + if Assigned(FBackground) then + FBackground.UnregisterChanges(BackgroundChanged); + inherited; + DockVisibleList.Free; + DockList.Free; +end; + +procedure TTBDock.SetParent(AParent: TWinControl); +begin + if (AParent is TTBCustomDockableWindow) or (AParent is TTBDock) then + raise EInvalidOperation.Create(STBDockParentNotAllowed); + + inherited; +end; + +procedure TTBDock.BeginUpdate; +begin + Inc(FDisableArrangeToolbars); +end; + +procedure TTBDock.EndUpdate; +begin + Dec(FDisableArrangeToolbars); + if FArrangeToolbarsNeeded and (FDisableArrangeToolbars = 0) then + ArrangeToolbars; +end; + +function TTBDock.HasVisibleToolbars: Boolean; +var + I: Integer; +begin + Result := False; + for I := 0 to DockList.Count-1 do + if ToolbarVisibleOnDock(TTBCustomDockableWindow(DockList[I])) then begin + Result := True; + Break; + end; +end; + +function TTBDock.ToolbarVisibleOnDock(const AToolbar: TTBCustomDockableWindow): Boolean; +begin + Result := (AToolbar.Parent = Self) and + (AToolbar.Visible or (csDesigning in AToolbar.ComponentState)); +end; + +function TTBDock.GetCurrentRowSize(const Row: Integer; + var AFullSize: Boolean): Integer; +var + I, J: Integer; + T: TTBCustomDockableWindow; +begin + Result := 0; + AFullSize := False; + if Row < 0 then Exit; + for I := 0 to DockList.Count-1 do begin + T := TTBCustomDockableWindow(DockList[I]); + if (T.FEffectiveDockRow = Row) and ToolbarVisibleOnDock(T) then begin + AFullSize := T.FullSize; + if not(Position in PositionLeftOrRight) then + J := T.Height + else + J := T.Width; + if J > Result then + Result := J; + end; + end; +end; + +function TTBDock.GetMinRowSize(const Row: Integer; + const ExcludeControl: TTBCustomDockableWindow): Integer; +var + I, J: Integer; + T: TTBCustomDockableWindow; +begin + Result := 0; + if Row < 0 then Exit; + for I := 0 to DockList.Count-1 do begin + T := TTBCustomDockableWindow(DockList[I]); + if (T <> ExcludeControl) and (T.FEffectiveDockRow = Row) and + ToolbarVisibleOnDock(T) then begin + J := T.FLastRowSize; + if J > Result then + Result := J; + end; + end; +end; + +function TTBDock.GetDesignModeRowOf(const XY: Integer): Integer; +{ Similar to GetRowOf, but is a little different to accomidate design mode + better } +var + HighestRowPlus1, R, CurY, CurRowSize: Integer; + FullSize: Boolean; +begin + Result := 0; + HighestRowPlus1 := GetHighestRow(True)+1; + CurY := 0; + for R := 0 to HighestRowPlus1 do begin + Result := R; + if R = HighestRowPlus1 then Break; + CurRowSize := GetCurrentRowSize(R, FullSize); + if CurRowSize = 0 then Continue; + Inc(CurY, CurRowSize); + if XY < CurY then + Break; + end; +end; + +function TTBDock.GetHighestRow(const HighestEffective: Boolean): Integer; +{ Returns highest used row number, or -1 if no rows are used } +var + I, J: Integer; +begin + Result := -1; + for I := 0 to DockList.Count-1 do + with TTBCustomDockableWindow(DockList[I]) do begin + if HighestEffective then + J := FEffectiveDockRow + else + J := FDockRow; + if J > Result then + Result := J; + end; +end; + +procedure TTBDock.ChangeWidthHeight(const NewWidth, NewHeight: Integer); +{ Same as setting Width/Height directly, but does not lose Align position. + Specifically, it ensures that a bottom-aligned dock stays above a + bottom-aligned TStatusBar when the only toolbar on the dock is undocked + and then redocked. } +begin + case Align of + alNone, alTop, alLeft: + SetBounds(Left, Top, NewWidth, NewHeight); + alBottom: + SetBounds(Left, Top-NewHeight+Height, NewWidth, NewHeight); + alRight: + SetBounds(Left-NewWidth+Width, Top, NewWidth, NewHeight); + end; +end; + +procedure TTBDock.AlignControls(AControl: TControl; var Rect: TRect); +begin + ArrangeToolbars; +end; + +function CompareDockRowPos(Item1, Item2: TListItemType): Integer; +begin + Result := TTBCustomDockableWindow(Item1).FDockRow - TTBCustomDockableWindow(Item2).FDockRow; + if Result = 0 then + Result := TTBCustomDockableWindow(Item1).FDockPos - TTBCustomDockableWindow(Item2).FDockPos; +end; + +procedure TTBDock.ArrangeToolbars; +{ The main procedure to arrange all the toolbars docked to it } +type + TPosDataRec = record + Row, ActualRow, PrecSpace, FullSize, MinimumSize, Size, Overlap, Pos: Integer; + ShrinkMode: TTBShrinkMode; + NeedArrange: Boolean; + end; +var + NewDockList: TList; + PosData: array of TPosDataRec; + + function IndexOfDraggingToolbar(const List: TList): Integer; + { Returns index of toolbar in List that's currently being dragged, or -1 } + var + I: Integer; + begin + for I := 0 to List.Count-1 do + if TTBCustomDockableWindow(List[I]).FDragMode then begin + Result := I; + Exit; + end; + Result := -1; + end; + + function ShiftLeft(const Row, StartIndex, MaxSize: Integer): Integer; + { Removes PrecSpace pixels from toolbars at or before StartIndex until the + right edge of the toolbar at StartIndex is <= MaxSize. + Returns the total number of PrecSpace pixels removed from toolbars. } + var + PixelsOffEdge, I, J: Integer; + begin + Result := 0; + PixelsOffEdge := -MaxSize; + for I := 0 to StartIndex do begin + if PosData[I].Row = Row then begin + Inc(PixelsOffEdge, PosData[I].PrecSpace); + Inc(PixelsOffEdge, PosData[I].Size); + end; + end; + if PixelsOffEdge > 0 then + for I := StartIndex downto 0 do begin + if PosData[I].Row = Row then begin + J := PixelsOffEdge; + if PosData[I].PrecSpace < J then + J := PosData[I].PrecSpace; + Dec(PosData[I].PrecSpace, J); + Dec(PixelsOffEdge, J); + Inc(Result, J); + if PixelsOffEdge = 0 then + Break; + end; + end; + end; + + function GetNextToolbar(const GoForward: Boolean; const Row: Integer; + const StartIndex: Integer): Integer; + var + I: Integer; + begin + Result := -1; + I := StartIndex; + while True do begin + if GoForward then begin + Inc(I); + if I >= NewDockList.Count then + Break; + end + else begin + Dec(I); + if I < 0 then + Break; + end; + if PosData[I].Row = Row then begin + Result := I; + Break; + end; + end; + end; + +var + LeftRight: Boolean; + EmptySize, HighestRow, R, CurPos, CurRowPixel, I, J, K, L, ClientW, + ClientH, MaxSize, TotalSize, PixelsPastMaxSize, Offset, CurRealPos, DragIndex, + MinRealPos, DragIndexPos, ToolbarsOnRow, CurRowSize: Integer; + T: TTBCustomDockableWindow; + S: TPoint; + RowIsEmpty: Boolean; +label FoundNextToolbar; +begin + if (FDisableArrangeToolbars > 0) or (csLoading in ComponentState) then begin + FArrangeToolbarsNeeded := True; + Exit; + end; + + NewDockList := nil; + Inc(FDisableArrangeToolbars); + try + { Work around VCL alignment bug when docking toolbars taller or wider than + the client height or width of the form. } + {if not(csDesigning in ComponentState) and HandleAllocated then + SetWindowPos(Handle, HWND_TOP, 0, 0, 0, 0, + SWP_NOACTIVATE or SWP_NOMOVE or SWP_NOSIZE);} + + LeftRight := Position in PositionLeftOrRight; + + if not HasVisibleToolbars then begin + EmptySize := Ord(FFixAlign); + if csDesigning in ComponentState then + EmptySize := 9; + if not LeftRight then + ChangeWidthHeight(Width, EmptySize) + else + ChangeWidthHeight(EmptySize, Height); + Exit; + end; + + { It can't read the ClientWidth and ClientHeight properties because they + attempt to create a handle, which requires Parent to be set. "ClientW" + and "ClientH" are calculated instead. } + ClientW := Width - FNonClientWidth; + if ClientW < 0 then ClientW := 0; + ClientH := Height - FNonClientHeight; + if ClientH < 0 then ClientH := 0; + + { Remove toolbars from DockList & DockVisibleList that are destroying, so + that no methods on these toolbars will be called. + This is needed because in certain rare cases ArrangeToolbars can be + indirectly called while a docked toolbar is being destroyed. } + for I := DockList.Count-1 downto 0 do begin + T := TTBCustomDockableWindow(DockList[I]); + if csDestroying in T.ComponentState then begin + DockList.Delete(I); + DockVisibleList.Remove(T); + end; + end; + + { If LimitToOneRow is True, only use the first row } + if FLimitToOneRow then + for I := 0 to DockList.Count-1 do + with TTBCustomDockableWindow(DockList[I]) do + FDockRow := 0; + + { Copy DockList to NewDockList, and ensure it is in correct ordering + according to DockRow/DockPos } + NewDockList := TList.Create; + NewDockList.Count := DockList.Count; + for I := 0 to NewDockList.Count-1 do + NewDockList[I] := DockList[I]; + I := IndexOfDraggingToolbar(NewDockList); + NewDockList.Sort(CompareDockRowPos); + DragIndex := IndexOfDraggingToolbar(NewDockList); + if (I <> -1) and TTBCustomDockableWindow(NewDockList[DragIndex]).FDragSplitting then begin + { When splitting, don't allow the toolbar being dragged to change + positions in the dock list } + NewDockList.Move(DragIndex, I); + DragIndex := I; + end; + DockVisibleList.Sort(CompareDockRowPos); + { Find highest row number } + HighestRow := GetHighestRow(False); + + { Create a temporary array that holds new position data for the toolbars } + SetLength(PosData, NewDockList.Count); + for I := 0 to NewDockList.Count-1 do begin + T := TTBCustomDockableWindow(NewDockList[I]); + PosData[I].ActualRow := T.FDockRow; + if ToolbarVisibleOnDock(T) then + PosData[I].Row := T.FDockRow + else + PosData[I].Row := -1; + PosData[I].Pos := T.FDockPos; + end; + + { Find FInsertRowBefore=True and FullSize=True toolbars and make sure there + aren't any other toolbars on the same row. If there are, shift them down + a row. } + for L := 0 to 1 do begin + R := 0; + while R <= HighestRow do begin + for I := 0 to NewDockList.Count-1 do begin + T := TTBCustomDockableWindow(NewDockList[I]); + if (PosData[I].ActualRow = R) and + (((L = 0) and T.FInsertRowBefore and not LimitToOneRow) or + ((L = 1) and T.FullSize)) then + for J := 0 to NewDockList.Count-1 do + if (J <> I) and (PosData[J].ActualRow = R) then begin + for K := 0 to NewDockList.Count-1 do begin + if K <> I then begin + if PosData[K].ActualRow >= R then + Inc(PosData[K].ActualRow); + if PosData[K].Row >= R then + Inc(PosData[K].Row); + end; + end; + Inc(HighestRow); + Break; + end; + end; + Inc(R); + end; + end; + + { Remove blank rows. + Note that rows that contain only invisible or currently floating toolbars + are intentionally not removed, so that when the toolbars are shown again, + they stay on their own row. } + R := 0; + while R <= HighestRow do begin + RowIsEmpty := True; + for I := 0 to NewDockList.Count-1 do + if PosData[I].ActualRow = R then begin + RowIsEmpty := False; + Break; + end; + if RowIsEmpty then begin + { Shift all ones higher than R back one } + for I := 0 to NewDockList.Count-1 do begin + if PosData[I].ActualRow > R then + Dec(PosData[I].ActualRow); + if PosData[I].Row > R then + Dec(PosData[I].Row); + end; + Dec(HighestRow); + end + else + Inc(R); + end; + + { Calculate positions and sizes of each row } + R := 0; + while R <= HighestRow do begin + if not LeftRight then + MaxSize := ClientW + else + MaxSize := ClientH; + + { Set initial sizes } + TotalSize := 0; + ToolbarsOnRow := 0; + MinRealPos := 0; + for I := 0 to NewDockList.Count-1 do begin + if PosData[I].Row = R then begin + T := TTBCustomDockableWindow(NewDockList[I]); + T.GetBaseSize(S); + if not LeftRight then + J := S.X + T.NonClientWidth + else + J := S.Y + T.NonClientHeight; + PosData[I].FullSize := J; + PosData[I].Size := J; + PosData[I].ShrinkMode := T.GetShrinkMode; + PosData[I].MinimumSize := 0; + T.GetMinShrinkSize(PosData[I].MinimumSize); + if PosData[I].MinimumSize > PosData[I].FullSize then + { don't allow minimum shrink size to be less than full size } + PosData[I].MinimumSize := PosData[I].FullSize; + if PosData[I].ShrinkMode = tbsmChevron then + Inc(MinRealPos, PosData[I].MinimumSize) + else + Inc(MinRealPos, PosData[I].FullSize); + { If the toolbar isn't the first toolbar on the row, and the toolbar + would go off the edge even after it's shrunk, then move it onto a + row of its own } + if (ToolbarsOnRow > 0) and (MinRealPos > MaxSize) and + not LimitToOneRow then begin + for K := I to NewDockList.Count-1 do begin + if PosData[K].ActualRow >= R then + Inc(PosData[K].ActualRow); + if PosData[K].Row >= R then + Inc(PosData[K].Row); + end; + Inc(HighestRow); + Break; + end; + Inc(TotalSize, J); + Inc(ToolbarsOnRow); + end; + end; + PixelsPastMaxSize := TotalSize - MaxSize; + + { Set initial arrangement; don't shrink toolbars yet } + DragIndexPos := 0; + CurPos := 0; + CurRealPos := 0; + MinRealPos := 0; + for I := 0 to NewDockList.Count-1 do begin + T := TTBCustomDockableWindow(NewDockList[I]); + if PosData[I].Row = R then begin + if (CurPos = 0) and (T.FullSize or T.Stretch) then + { Force to left } + J := 0 + else + J := T.FDockPos; + if I = DragIndex then + DragIndexPos := J; + { Don't let this toolbar overlap preceding toolbars by more than + the sum of their minimum sizes } + if J < MinRealPos then + J := MinRealPos; + if J > CurPos then begin + { There's a gap between the left edge or previous toolbar and + this toolbar } + if PixelsPastMaxSize <= 0 then begin + PosData[I].PrecSpace := J - CurPos; + CurPos := J; + end + else + { Don't allow a gap if exceeding MaxSize } + J := CurPos; + end + else begin + if J < CurRealPos then + PosData[I].Overlap := CurRealPos - J; + end; + + Inc(CurPos, PosData[I].Size); + CurRealPos := J + PosData[I].Size; + Inc(MinRealPos, PosData[I].MinimumSize); + end; + end; + + { If we aren't exceeding MaxSize, allow the toolbar being dragged + to push other toolbars to the left } + if (PixelsPastMaxSize < 0) and (DragIndex <> -1) and + (PosData[DragIndex].Row = R) then begin + I := GetNextToolbar(False, R, DragIndex); + if I <> -1 then begin + J := ShiftLeft(R, I, DragIndexPos); + if J > 0 then begin + { Ensure that toolbars that follow the toolbar being dragged stay + at the same place by increasing PrecSpace on the next toolbar } + I := GetNextToolbar(True, R, DragIndex); + if I <> -1 then + Inc(PosData[I].PrecSpace, J); + end; + end; + end; + + { If any toolbars are going off the edge of the dock, try to make them + at least partially visible by shifting preceding toolbars left } + I := GetNextToolbar(False, R, NewDockList.Count); + if I <> -1 then + ShiftLeft(R, I, MaxSize); + + { Shrink toolbars that overlap other toolbars (Overlaps[x] > 0) } + if PixelsPastMaxSize > 0 then begin + Offset := 0; + for I := 0 to NewDockList.Count-1 do begin + if PosData[I].Row <> R then + Continue; + T := TTBCustomDockableWindow(NewDockList[I]); + if (ToolbarsOnRow > 1) and T.FDragMode then + T.FDragCanSplit := True; + Inc(Offset, PosData[I].Overlap); + if Offset > PixelsPastMaxSize then + Offset := PixelsPastMaxSize; + if Offset > 0 then + for J := I-1 downto 0 do begin + if PosData[J].Row <> R then + Continue; + { How much can we shrink this toolbar J to get toolbar I to + its preferred position? } + if PosData[J].ShrinkMode = tbsmChevron then + L := Offset + else + L := 0; + K := -(PosData[J].Size - L - PosData[J].MinimumSize); { the number of pixels that exceed the minimum size } + if K > 0 then + { Don't shrink a toolbar below its minimum allowed size } + Dec(L, K); + Dec(PosData[J].Size, L); + Dec(PixelsPastMaxSize, L); + Dec(Offset, L); + if (Offset = 0) or + { This is needed so toolbars can push other toolbars to the + right when splitting: } + (J = DragIndex) then + Break; + end; + end; + end; + + { Still exceeding MaxSize? Make sure the rightmost toolbar(s) are + at least partially visible with a width of MinimumSize } + if PixelsPastMaxSize > 0 then begin + for I := NewDockList.Count-1 downto 0 do begin + if (PosData[I].Row <> R) or (PosData[I].ShrinkMode = tbsmNone) or + ((PosData[I].ShrinkMode = tbsmWrap) and (ToolbarsOnRow > 1)) then + Continue; + J := PosData[I].Size - PosData[I].MinimumSize; + if J > 0 then begin { can we shrink this toolbar any? } + if J > PixelsPastMaxSize then + J := PixelsPastMaxSize; + Dec(PosData[I].Size, J); + Dec(PixelsPastMaxSize, J); + end; + if PixelsPastMaxSize = 0 then + Break; + end; + end; + + { Set Poses, and adjust size of FullSize & Stretch toolbars } + CurPos := 0; + for I := 0 to NewDockList.Count-1 do begin + T := TTBCustomDockableWindow(NewDockList[I]); + if PosData[I].Row = R then begin + if T.FullSize or T.Stretch then begin + { Remove any preceding space from this toolbar } + Inc(PosData[I].Size, PosData[I].PrecSpace); + PosData[I].PrecSpace := 0; + end; + Inc(CurPos, PosData[I].PrecSpace); + if T.FullSize then begin + { Claim all space } + if PosData[I].Size < MaxSize then + PosData[I].Size := MaxSize; + end + else if T.Stretch then begin + { Steal any preceding space from the next toolbar } + for J := I+1 to NewDockList.Count-1 do + if PosData[J].Row = R then begin + Inc(PosData[I].Size, PosData[J].PrecSpace); + PosData[J].PrecSpace := 0; + goto FoundNextToolbar; + end; + { or claim any remaining space } + if PosData[I].Size < MaxSize - CurPos then + PosData[I].Size := MaxSize - CurPos; + FoundNextToolbar: + end; + PosData[I].Pos := CurPos; + Inc(CurPos, PosData[I].Size); + end; + end; + + Inc(R); + end; + + for I := 0 to NewDockList.Count-1 do begin + T := TTBCustomDockableWindow(NewDockList[I]); + T.FEffectiveDockRow := PosData[I].ActualRow; + T.FEffectiveDockPos := PosData[I].Pos; + { If FCommitNewPositions is True, update all the toolbars' DockPos and + DockRow properties to match the actual positions. + Also update the ordering of DockList to match NewDockList } + if FCommitNewPositions then begin + T.FDockRow := T.FEffectiveDockRow; + T.FDockPos := T.FEffectiveDockPos; + DockList[I] := NewDockList[I]; + end; + end; + + { Now actually move the toolbars } + CurRowPixel := 0; + for R := 0 to HighestRow do begin + CurRowSize := -1; + for I := 0 to NewDockList.Count-1 do begin + T := TTBCustomDockableWindow(NewDockList[I]); + if PosData[I].Row = R then begin + K := T.FCurrentSize; + T.FCurrentSize := PosData[I].Size; + if PosData[I].Size >= PosData[I].FullSize then begin + T.FCurrentSize := 0; + { Reason: so that if new items are added to a non-shrunk toolbar + at run-time (causing its width to increase), the toolbar won't + shrink unnecessarily } + end; + if (PosData[I].ShrinkMode <> tbsmNone) and (T.FCurrentSize <> K) then begin + { If Size is changing and we are to display a chevron or wrap, + call DoArrange to get an accurate row size } + S := T.DoArrange(False, TBGetDockTypeOf(Self, False), False, Self); + { Force a rearrange in case the actual size isn't changing but the + chevron visibility might have changed (which can happen if + items are added to a FullSize=True toolbar at run-time) } + PosData[I].NeedArrange := True; + end + else begin + if (PosData[I].ShrinkMode = tbsmWrap) and (PosData[I].Size < PosData[I].FullSize) then begin + { Preserve existing height (or width) on a wrapped toolbar + whose size isn't changing now } + S.X := T.Width - T.NonClientWidth; + S.Y := T.Height - T.NonClientHeight; + end + else + T.GetBaseSize(S); + end; + if not LeftRight then + K := S.Y + else + K := S.X; + T.FLastRowSize := K; + if K > CurRowSize then + CurRowSize := K; + end; + end; + if CurRowSize <> -1 then + Inc(CurRowSize, DockedBorderSize2) + else + CurRowSize := 0; + for I := 0 to NewDockList.Count-1 do begin + T := TTBCustomDockableWindow(NewDockList[I]); + if PosData[I].Row = R then begin + Inc(T.FUpdatingBounds); + try + K := T.FCurrentSize; + if PosData[I].NeedArrange then + T.FArrangeNeeded := True; + if not LeftRight then + T.SetBounds(PosData[I].Pos, CurRowPixel, PosData[I].Size, CurRowSize) + else + T.SetBounds(CurRowPixel, PosData[I].Pos, CurRowSize, PosData[I].Size); + if T.FArrangeNeeded then + { ^ don't arrange again if SetBounds call already caused one } + T.Arrange; + { Restore FCurrentSize since TTBToolbarView.DoUpdatePositions + clears it } + T.FCurrentSize := K; + finally + Dec(T.FUpdatingBounds); + end; + end; + end; + Inc(CurRowPixel, CurRowSize); + end; + + { Set the size of the dock } + if not LeftRight then + ChangeWidthHeight(Width, CurRowPixel + FNonClientHeight) + else + ChangeWidthHeight(CurRowPixel + FNonClientWidth, Height); + finally + Dec(FDisableArrangeToolbars); + FArrangeToolbarsNeeded := False; + FCommitNewPositions := False; + NewDockList.Free; + end; +end; + +procedure TTBDock.CommitPositions; +{ Copies docked toolbars' EffectiveDockRow and EffectiveDockPos properties + into DockRow and DockPos respectively. + Note that this does not reorder DockList like ArrangeToolbars does when + FCommitNewPositions=True. } +var + I: Integer; + T: TTBCustomDockableWindow; +begin + for I := 0 to DockVisibleList.Count-1 do begin + T := TTBCustomDockableWindow(DockVisibleList[I]); + T.FDockRow := T.FEffectiveDockRow; + T.FDockPos := T.FEffectiveDockPos; + end; +end; + +procedure TTBDock.ChangeDockList(const Insert: Boolean; + const Bar: TTBCustomDockableWindow); +{ Inserts or removes Bar from DockList } +var + I: Integer; +begin + I := DockList.IndexOf(Bar); + if Insert then begin + if I = -1 then begin + Bar.FreeNotification(Self); + DockList.Add(Bar); + end; + end + else begin + if I <> -1 then + DockList.Delete(I); + end; + ToolbarVisibilityChanged(Bar, False); +end; + +procedure TTBDock.ToolbarVisibilityChanged(const Bar: TTBCustomDockableWindow; + const ForceRemove: Boolean); +var + Modified, VisibleOnDock: Boolean; + I: Integer; +begin + Modified := False; + I := DockVisibleList.IndexOf(Bar); + VisibleOnDock := not ForceRemove and ToolbarVisibleOnDock(Bar); + if VisibleOnDock then begin + if I = -1 then begin + DockVisibleList.Add(Bar); + Modified := True; + end; + end + else begin + if I <> -1 then begin + DockVisibleList.Remove(Bar); + Modified := True; + end; + end; + + if Modified then begin + ArrangeToolbars; + + if Assigned(FOnInsertRemoveBar) then + FOnInsertRemoveBar(Self, VisibleOnDock, Bar); + end; +end; + +procedure TTBDock.Loaded; +begin + inherited; + { Rearranging is disabled while the component is loading, so now that it's + loaded, rearrange it. } + ArrangeToolbars; +end; + +procedure TTBDock.Notification(AComponent: TComponent; Operation: TOperation); +begin + inherited; + if Operation = opRemove then begin + if AComponent = FBackground then + Background := nil + else if AComponent is TTBCustomDockableWindow then begin + DockList.Remove(AComponent); + DockVisibleList.Remove(AComponent); + end; + end; +end; + +function TTBDock.GetPalette: HPALETTE; +begin + if UsingBackground and Assigned(FBackground) then + { ^ by default UsingBackground returns False if FBackground isn't assigned, + but UsingBackground may be overridden and return True when it isn't } + Result := FBackground.GetPalette + else + Result := 0; +end; + +procedure TTBDock.WMEraseBkgnd(var Message: TWMEraseBkgnd); +var + R, R2: TRect; + P1, P2: TPoint; + SaveIndex: Integer; +begin + { Draw the Background if there is one, otherwise use default erasing + behavior } + if UsingBackground then begin + R := ClientRect; + R2 := R; + { Make up for nonclient area } + P1 := ClientToScreen(Point(0, 0)); + P2 := Parent.ClientToScreen(BoundsRect.TopLeft); + Dec(R2.Left, Left + (P1.X-P2.X)); + Dec(R2.Top, Top + (P1.Y-P2.Y)); + SaveIndex := SaveDC(Message.DC); + IntersectClipRect(Message.DC, R.Left, R.Top, R.Right, R.Bottom); + DrawBackground(Message.DC, R2); + RestoreDC(Message.DC, SaveIndex); + Message.Result := 1; + end + else + inherited; +end; + +procedure TTBDock.Paint; +var + R: TRect; +begin + inherited; + { Draw dotted border in design mode } + if csDesigning in ComponentState then begin + R := ClientRect; + with Canvas do begin + Pen.Style := psDot; + Pen.Color := clBtnShadow; + Brush.Style := bsClear; + Rectangle(R.Left, R.Top, R.Right, R.Bottom); + Pen.Style := psSolid; + end; + end; +end; + +procedure TTBDock.WMMove(var Message: TWMMove); +begin + inherited; + if UsingBackground then + InvalidateBackgrounds; +end; + +{$IFNDEF JR_D4} +procedure TTBDock.WMSize(var Message: TWMSize); +begin + inherited; + if not(csLoading in ComponentState) and Assigned(FOnResize) then + FOnResize(Self); +end; +{$ENDIF} + +procedure TTBDock.WMNCCalcSize(var Message: TWMNCCalcSize); + + procedure ApplyToRect(var R: TRect); + begin + if blTop in BoundLines then Inc(R.Top); + if blBottom in BoundLines then Dec(R.Bottom); + if blLeft in BoundLines then Inc(R.Left); + if blRight in BoundLines then Dec(R.Right); + end; + +{$IFDEF CLR} +var + Params: TNCCalcSizeParams; +{$ENDIF} +begin + inherited; + { note to self: non-client size is stored in FNonClientWidth & + FNonClientHeight } + {$IFNDEF CLR} + ApplyToRect(Message.CalcSize_Params.rgrc[0]); + {$ELSE} + Params := Message.CalcSize_Params; + ApplyToRect(Params.rgrc0); + Message.CalcSize_Params := Params; + {$ENDIF} +end; + +procedure TTBDock.DrawNCArea(const DrawToDC: Boolean; const ADC: HDC; + const Clip: HRGN); + + procedure DrawLine(const DC: HDC; const X1, Y1, X2, Y2: Integer); + begin + MoveToEx(DC, X1, Y1, nil); LineTo(DC, X2, Y2); + end; +var + RW, R, R2, RC: TRect; + DC: HDC; + HighlightPen, ShadowPen, SavePen: HPEN; + FillBrush: HBRUSH; +label SkipFillRect; +begin + { This works around WM_NCPAINT problem described at top of source code } + {no! R := Rect(0, 0, Width, Height);} + GetWindowRect(Handle, RW); + R := RW; + OffsetRect(R, -R.Left, -R.Top); + + if not DrawToDC then + DC := GetWindowDC(Handle) + else + DC := ADC; + try + { Use update region } + if not DrawToDC then + SelectNCUpdateRgn(Handle, DC, Clip); + + { Draw BoundLines } + R2 := R; + if (BoundLines <> []) and + ((csDesigning in ComponentState) or HasVisibleToolbars) then begin + HighlightPen := CreatePen(PS_SOLID, 1, GetSysColor(COLOR_BTNHIGHLIGHT)); + ShadowPen := CreatePen(PS_SOLID, 1, GetSysColor(COLOR_BTNSHADOW)); + SavePen := SelectObject(DC, ShadowPen); + if blTop in BoundLines then begin + DrawLine(DC, R.Left, R.Top, R.Right, R.Top); + Inc(R2.Top); + end; + if blLeft in BoundLines then begin + DrawLine(DC, R.Left, R.Top, R.Left, R.Bottom); + Inc(R2.Left); + end; + SelectObject(DC, HighlightPen); + if blBottom in BoundLines then begin + DrawLine(DC, R.Left, R.Bottom-1, R.Right, R.Bottom-1); + Dec(R2.Bottom); + end; + if blRight in BoundLines then begin + DrawLine(DC, R.Right-1, R.Top, R.Right-1, R.Bottom); + Dec(R2.Right); + end; + SelectObject(DC, SavePen); + DeleteObject(ShadowPen); + DeleteObject(HighlightPen); + end; + Windows.GetClientRect(Handle, RC); + if not IsRectEmpty(RC) then begin + { ^ ExcludeClipRect can't be passed rectangles that have (Bottom < Top) or + (Right < Left) since it doesn't treat them as empty } + MapWindowPoints(Handle, 0, RC, 2); + OffsetRect(RC, -RW.Left, -RW.Top); + if EqualRect(RC, R2) then + { Skip FillRect because there would be nothing left after ExcludeClipRect } + goto SkipFillRect; + ExcludeClipRect(DC, RC.Left, RC.Top, RC.Right, RC.Bottom); + end; + FillBrush := CreateSolidBrush(ColorToRGB(Color)); + FillRect(DC, R2, FillBrush); + DeleteObject(FillBrush); + SkipFillRect: + finally + if not DrawToDC then + ReleaseDC(Handle, DC); + end; +end; + +procedure TTBDock.WMNCPaint(var Message: TMessage); +begin + DrawNCArea(False, 0, HRGN(Message.WParam)); +end; + +procedure DockNCPaintProc(Wnd: HWND; DC: HDC; AppData: TObject); +begin + TTBDock(AppData).DrawNCArea(True, DC, 0); +end; + +procedure TTBDock.WMPrint(var Message: TMessage); +begin + HandleWMPrint(Handle, Message, DockNCPaintProc, Self); +end; + +procedure TTBDock.WMPrintClient(var Message: + {$IFNDEF CLR} TMessage {$ELSE} TWMPrintClient {$ENDIF}); +begin + HandleWMPrintClient(PaintHandler, Message); +end; + +procedure TTBDock.CMSysColorChange(var Message: TMessage); +begin + inherited; + if Assigned(FBackground) then + FBackground.SysColorChanged; +end; + +procedure TTBDock.RelayMsgToFloatingBars({$IFNDEF CLR}var{$ELSE}const{$ENDIF} Message: TMessage); +var + I: Integer; + T: TTBCustomDockableWindow; +begin + for I := 0 to DockList.Count-1 do begin + T := TTBCustomDockableWindow(DockList[I]); + { Note: We must be careful about relaying WM_SYSCOMMAND. We can't send it + to classes that don't have special handling for it (as indicated by the + csMenuEvents style, which TTBToolWindow lacks) because the VCL's + default handling would send it back to the main form, resulting in + infinite recursion. } + if ((Message.Msg <> WM_SYSCOMMAND) or (csMenuEvents in T.ControlStyle)) and + T.Floating and T.CanFocus then begin + Message.Result := T.Perform(Message.Msg, Message.WParam, Message.LParam); + if Message.Result <> 0 then + Exit; + end; + end; +end; + +procedure TTBDock.WMSysCommand(var Message: TWMSysCommand); +begin + { Relay WM_SYSCOMMAND messages to floating toolbars which were formerly + docked. That way, items on floating menu bars can be accessed with Alt. } + if Message.CmdType and $FFF0 = SC_KEYMENU then + RelayMsgToFloatingBars({$IFNDEF CLR} TMessage(Message) {$ELSE} Message.OriginalMessage {$ENDIF}); +end; + +procedure TTBDock.CMDialogKey(var Message: TCMDialogKey); +begin + RelayMsgToFloatingBars({$IFNDEF CLR} TMessage(Message) {$ELSE} Message.OriginalMessage {$ENDIF}); + if Message.Result = 0 then + inherited; +end; + +procedure TTBDock.CMDialogChar(var Message: TCMDialogChar); +begin + RelayMsgToFloatingBars({$IFNDEF CLR} TMessage(Message) {$ELSE} Message.OriginalMessage {$ENDIF}); + if Message.Result = 0 then + inherited; +end; + +{ TTBDock - property access methods } + +procedure TTBDock.SetAllowDrag(Value: Boolean); +var + I: Integer; +begin + if FAllowDrag <> Value then begin + FAllowDrag := Value; + for I := 0 to ControlCount-1 do + if Controls[I] is TTBCustomDockableWindow then + RecalcNCArea(TTBCustomDockableWindow(Controls[I])); + end; +end; + +function TTBDock.UsingBackground: Boolean; +begin + Result := Assigned(FBackground) and FBackground.UsingBackground; +end; + +procedure TTBDock.DrawBackground(DC: HDC; const DrawRect: TRect); +begin + FBackground.Draw(DC, DrawRect); +end; + +procedure TTBDock.InvalidateBackgrounds; +{ Called after background is changed } +var + I: Integer; + T: TTBCustomDockableWindow; +begin + Invalidate; + { Synchronize child toolbars also } + for I := 0 to DockList.Count-1 do begin + T := TTBCustomDockableWindow(DockList[I]); + if ToolbarVisibleOnDock(T) then + { Invalidate both non-client and client area } + InvalidateAll(T); + end; +end; + +procedure TTBDock.SetBackground(Value: TTBBasicBackground); +begin + if FBackground <> Value then begin + if Assigned(FBackground) then + FBackground.UnregisterChanges(BackgroundChanged); + FBackground := Value; + if Assigned(Value) then begin + Value.FreeNotification(Self); + Value.RegisterChanges(BackgroundChanged); + end; + InvalidateBackgrounds; + end; +end; + +procedure TTBDock.BackgroundChanged(Sender: TObject); +begin + InvalidateBackgrounds; +end; + +procedure TTBDock.SetBackgroundOnToolbars(Value: Boolean); +begin + if FBkgOnToolbars <> Value then begin + FBkgOnToolbars := Value; + InvalidateBackgrounds; + end; +end; + +procedure TTBDock.SetBoundLines(Value: TTBDockBoundLines); +var + X, Y: Integer; + B: TTBDockBoundLines; +begin + if FBoundLines <> Value then begin + FBoundLines := Value; + X := 0; + Y := 0; + B := BoundLines; { optimization } + if blTop in B then Inc(Y); + if blBottom in B then Inc(Y); + if blLeft in B then Inc(X); + if blRight in B then Inc(X); + FNonClientWidth := X; + FNonClientHeight := Y; + RecalcNCArea(Self); + end; +end; + +procedure TTBDock.SetFixAlign(Value: Boolean); +begin + if FFixAlign <> Value then begin + FFixAlign := Value; + ArrangeToolbars; + end; +end; + +procedure TTBDock.SetPosition(Value: TTBDockPosition); +begin + if (FPosition <> Value) and (ControlCount <> 0) then + raise EInvalidOperation.Create(STBDockCannotChangePosition); + FPosition := Value; + case Position of + dpTop: Align := alTop; + dpBottom: Align := alBottom; + dpLeft: Align := alLeft; + dpRight: Align := alRight; + end; +end; + +function TTBDock.GetToolbarCount: Integer; +begin + Result := DockVisibleList.Count; +end; + +function TTBDock.GetToolbars(Index: Integer): TTBCustomDockableWindow; +begin + Result := TTBCustomDockableWindow(DockVisibleList[Index]); +end; + +(*function TTBDock.GetVersion: TToolbar97Version; +begin + Result := Toolbar97VersionPropText; +end; + +procedure TTBDock.SetVersion(const Value: TToolbar97Version); +begin + { write method required for the property to show up in Object Inspector } +end;*) + + +{ TTBFloatingWindowParent - Internal } + +procedure TTBFloatingWindowParent.CreateParams(var Params: TCreateParams); +const + ThickFrames: array[Boolean] of DWORD = (0, WS_THICKFRAME); +begin + inherited; + + { Disable complete redraws when size changes. CS_H/VREDRAW cause flicker + and are not necessary for this control at run time } + if not(csDesigning in ComponentState) then + with Params.WindowClass do + Style := Style and not(CS_HREDRAW or CS_VREDRAW); + + with Params do begin + { Note: WS_THICKFRAME and WS_BORDER styles are included to ensure that + sizing grips are displayed on child controls with scrollbars. The + thick frame or border is not drawn by Windows; TCustomToolWindow97 + handles all border drawing by itself. } + if not(csDesigning in ComponentState) then + Style := WS_POPUP or WS_BORDER or ThickFrames[FDockableWindow.FResizable] + else + Style := Style or WS_BORDER or ThickFrames[FDockableWindow.FResizable]; + { The WS_EX_TOOLWINDOW style is needed so there isn't a taskbar button + for the toolbar when FloatingMode = fmOnTopOfAllForms. } + ExStyle := WS_EX_TOOLWINDOW; + end; +end; + +procedure TTBFloatingWindowParent.Notification(AComponent: TComponent; + Operation: TOperation); +begin + inherited; + if (Operation = opRemove) and (AComponent = FParentForm) then + FParentForm := nil; +end; + +procedure TTBFloatingWindowParent.AlignControls(AControl: TControl; var Rect: TRect); +begin + { ignore Align setting of the child toolbar } +end; + +procedure TTBFloatingWindowParent.WMGetMinMaxInfo(var Message: TWMGetMinMaxInfo); +{$IFDEF CLR} +var + Temp: TMinMaxInfo; +{$ENDIF} +begin + inherited; + { Because the window uses the WS_THICKFRAME style (but not for the usual + purpose), it must process the WM_GETMINMAXINFO message to remove the + minimum and maximum size limits it imposes by default. } + {$IFNDEF CLR} + with Message.MinMaxInfo^ do begin + {$ELSE} + Temp := Message.MinMaxInfo; + with Temp do begin + {$ENDIF} + with ptMinTrackSize do begin + X := 1; + Y := 1; + { Note to self: Don't put GetMinimumSize code here, since + ClientWidth/Height values are sometimes invalid during a RecreateWnd } + end; + with ptMaxTrackSize do begin + { Because of the 16-bit (signed) size limitations of Windows 95, + Smallints must be used instead of Integers or Longints } + X := High(Smallint); + Y := High(Smallint); + end; + end; + {$IFDEF CLR} + Message.MinMaxInfo := Temp; + {$ENDIF} +end; + +procedure TTBFloatingWindowParent.CMShowingChanged(var Message: TMessage); +const + ShowFlags: array[Boolean] of UINT = ( + SWP_NOSIZE or SWP_NOMOVE or SWP_NOZORDER or SWP_NOACTIVATE or SWP_HIDEWINDOW, + SWP_NOSIZE or SWP_NOMOVE or SWP_NOZORDER or SWP_NOACTIVATE or SWP_SHOWWINDOW); +begin + { Must override TCustomForm/TForm's CM_SHOWINGCHANGED handler so that the + form doesn't get activated when Visible is set to True. } + SetWindowPos(WindowHandle, 0, 0, 0, 0, 0, ShowFlags[Showing and FShouldShow]); +end; + +procedure TTBFloatingWindowParent.CMDialogKey(var Message: TCMDialogKey); +begin + { If Escape if pressed on a floating toolbar, return focus to the form } + if (Message.CharCode = VK_ESCAPE) and + (KeyDataToShiftState(ClipToLongint(Message.KeyData)) = []) and + Assigned(ParentForm) then begin + ParentForm.SetFocus; + Message.Result := 1; + end + else + inherited; +end; + +procedure TTBFloatingWindowParent.CMTextChanged(var Message: TMessage); +begin + inherited; + RedrawNCArea([twrdCaption]); +end; + +function TTBFloatingWindowParent.GetCaptionRect(const AdjustForBorder, + MinusCloseButton: Boolean): TRect; +var + P: TPoint; +begin + Result := Rect(0, 0, ClientWidth, GetSmallCaptionHeight-1); + if MinusCloseButton then + Dec(Result.Right, Result.Bottom); + if AdjustForBorder then begin + P := FDockableWindow.GetFloatingBorderSize; + OffsetRect(Result, P.X, P.Y); + end; +end; + +function TTBFloatingWindowParent.GetCloseButtonRect(const AdjustForBorder: Boolean): TRect; +begin + Result := GetCaptionRect(AdjustForBorder, False); + Result.Left := Result.Right - (GetSmallCaptionHeight-1); +end; + +procedure TTBFloatingWindowParent.WMNCCalcSize(var Message: TWMNCCalcSize); + + procedure ApplyToRect(var R: TRect); + var + TL, BR: TPoint; + begin + FDockableWindow.GetFloatingNCArea(TL, BR); + Inc(R.Left, TL.X); + Inc(R.Top, TL.Y); + Dec(R.Right, BR.X); + Dec(R.Bottom, BR.Y); + end; + +{$IFDEF CLR} +var + Params: TNCCalcSizeParams; +{$ENDIF} +begin + { Doesn't call inherited since it overrides the normal NC sizes } + Message.Result := 0; + {$IFNDEF CLR} + ApplyToRect(Message.CalcSize_Params.rgrc[0]); + {$ELSE} + Params := Message.CalcSize_Params; + ApplyToRect(Params.rgrc0); + Message.CalcSize_Params := Params; + {$ENDIF} +end; + +procedure TTBFloatingWindowParent.WMNCPaint(var Message: TMessage); +begin + { Don't call inherited because it overrides the default NC painting } + DrawNCArea(False, 0, HRGN(Message.WParam), twrdAll); +end; + +procedure FloatingWindowParentNCPaintProc(Wnd: HWND; DC: HDC; AppData: TObject); +begin + with TTBFloatingWindowParent(AppData) do + DrawNCArea(True, DC, 0, twrdAll); +end; + +procedure TTBFloatingWindowParent.WMPrint(var Message: TMessage); +begin + HandleWMPrint(Handle, Message, FloatingWindowParentNCPaintProc, Self); +end; + +procedure TTBFloatingWindowParent.WMPrintClient(var Message: + {$IFNDEF CLR} TMessage {$ELSE} TWMPrintClient {$ENDIF}); +begin + HandleWMPrintClient(PaintHandler, Message); +end; + +procedure TTBFloatingWindowParent.WMNCHitTest(var Message: TWMNCHitTest); +var + P: TPoint; + R: TRect; + BorderSize: TPoint; + C: Integer; +begin + inherited; + with Message do begin + P := SmallPointToPoint(Pos); + GetWindowRect(Handle, R); + Dec(P.X, R.Left); Dec(P.Y, R.Top); + if Result <> HTCLIENT then begin + Result := HTNOWHERE; + if FDockableWindow.ShowCaption and PtInRect(GetCaptionRect(True, False), P) then begin + if FDockableWindow.FCloseButton and PtInRect(GetCloseButtonRect(True), P) then + Result := HT_TB2k_Close + else + Result := HT_TB2k_Caption; + end + else + if FDockableWindow.Resizable then begin + BorderSize := FDockableWindow.GetFloatingBorderSize; + if not(tbdsResizeEightCorner in FDockableWindow.FDockableWindowStyles) then begin + if (P.Y >= 0) and (P.Y < BorderSize.Y) then Result := HTTOP else + if (P.Y < Height) and (P.Y >= Height-BorderSize.Y-1) then Result := HTBOTTOM else + if (P.X >= 0) and (P.X < BorderSize.X) then Result := HTLEFT else + if (P.X < Width) and (P.X >= Width-BorderSize.X-1) then Result := HTRIGHT; + end + else begin + C := BorderSize.X + (GetSmallCaptionHeight-1); + if (P.X >= 0) and (P.X < BorderSize.X) then begin + Result := HTLEFT; + if (P.Y < C) then Result := HTTOPLEFT else + if (P.Y >= Height-C) then Result := HTBOTTOMLEFT; + end + else + if (P.X < Width) and (P.X >= Width-BorderSize.X-1) then begin + Result := HTRIGHT; + if (P.Y < C) then Result := HTTOPRIGHT else + if (P.Y >= Height-C) then Result := HTBOTTOMRIGHT; + end + else + if (P.Y >= 0) and (P.Y < BorderSize.Y) then begin + Result := HTTOP; + if (P.X < C) then Result := HTTOPLEFT else + if (P.X >= Width-C) then Result := HTTOPRIGHT; + end + else + if (P.Y < Height) and (P.Y >= Height-BorderSize.Y-1) then begin + Result := HTBOTTOM; + if (P.X < C) then Result := HTBOTTOMLEFT else + if (P.X >= Width-C) then Result := HTBOTTOMRIGHT; + end; + end; + end; + end; + end; +end; + +procedure TTBFloatingWindowParent.SetCloseButtonState(Pushed: Boolean); +begin + if FCloseButtonDown <> Pushed then begin + FCloseButtonDown := Pushed; + RedrawNCArea([twrdCloseButton]); + end; +end; + +procedure TTBFloatingWindowParent.WMNCLButtonDown(var Message: TWMNCLButtonDown); +var + P: TPoint; + R, BR: TRect; +begin + case ClipToLongint(Message.HitTest) of + HT_TB2k_Caption: begin + P := FDockableWindow.ScreenToClient(Point(Message.XCursor, Message.YCursor)); + FDockableWindow.BeginMoving(P.X, P.Y); + end; + HTLEFT..HTBOTTOMRIGHT: + if FDockableWindow.Resizable then + FDockableWindow.BeginSizing(TTBSizeHandle(ClipToLongint(Message.HitTest) - HTLEFT)); + HT_TB2k_Close: begin + GetWindowRect(Handle, R); + BR := GetCloseButtonRect(True); + OffsetRect(BR, R.Left, R.Top); + if CloseButtonLoop(Handle, BR, SetCloseButtonState) then + FDockableWindow.Close; + end; + else + inherited; + end; +end; + +procedure TTBFloatingWindowParent.WMNCLButtonDblClk(var Message: TWMNCLButtonDblClk); +begin + if ClipToLongint(Message.HitTest) = HT_TB2k_Caption then + FDockableWindow.DoubleClick; +end; + +procedure TTBFloatingWindowParent.WMNCRButtonUp(var Message: TWMNCRButtonUp); +begin + FDockableWindow.ShowNCContextMenu(Message.XCursor, Message.YCursor); +end; + +procedure TTBFloatingWindowParent.WMClose(var Message: TWMClose); +var + MDIParentForm: TTBCustomForm; +begin + { A floating toolbar does not use WM_CLOSE messages when its close button + is clicked, but Windows still sends a WM_CLOSE message if the user + presses Alt+F4 while one of the toolbar's controls is focused. Inherited + is not called since we do not want Windows' default processing - which + destroys the window. Instead, relay the message to the parent form. } + MDIParentForm := GetMDIParent(TBGetToolWindowParentForm(FDockableWindow)); + if Assigned(MDIParentForm) and MDIParentForm.HandleAllocated then + SendMessage(MDIParentForm.Handle, WM_CLOSE, 0, 0); + { Note to self: MDIParentForm is used instead of OwnerForm since MDI + childs don't process Alt+F4 as Close } +end; + +procedure TTBFloatingWindowParent.WMActivate(var Message: TWMActivate); +var + ParentForm: TTBCustomForm; +begin + if csDesigning in ComponentState then begin + inherited; + Exit; + end; + + ParentForm := GetMDIParent(TBGetToolWindowParentForm(FDockableWindow)); + + if Assigned(ParentForm) and ParentForm.HandleAllocated then + SendMessage(ParentForm.Handle, WM_NCACTIVATE, Ord(Message.Active <> WA_INACTIVE), 0); + + if Message.Active <> WA_INACTIVE then begin + { This works around a "gotcha" in TCustomForm.CMShowingChanged. When a form + is hidden, it uses the internal VCL function FindTopMostWindow to + find a new active window. The problem is that handles of floating + toolbars on the form being hidden can be returned by + FindTopMostWindow, so the following code is used to prevent floating + toolbars on the hidden form from being left active. } + if not IsWindowVisible(Handle) then + { ^ Calling IsWindowVisible with a floating toolbar handle will + always return False if its parent form is hidden since the + WH_CALLWNDPROC hook automatically updates the toolbars' + visibility. } + { Find and activate a window besides this toolbar } + SetActiveWindow(FindTopLevelWindow(Handle)) + else + { If the toolbar is being activated and the previous active window wasn't + its parent form, the form is activated instead. This is done so that if + the application is deactivated while a floating toolbar was active and + the application is reactivated again, it returns focus to the form. } + if Assigned(ParentForm) and ParentForm.HandleAllocated and + (Message.ActiveWindow <> ParentForm.Handle) then + SetActiveWindow(ParentForm.Handle); + end; +end; + +procedure TTBFloatingWindowParent.WMMouseActivate(var Message: TWMMouseActivate); +var + ParentForm, MDIParentForm: TTBCustomForm; +begin + if csDesigning in ComponentState then begin + inherited; + Exit; + end; + + { When floating, prevent the toolbar from activating when clicked. + This is so it doesn't take the focus away from the window that had it } + Message.Result := MA_NOACTIVATE; + + { Similar to calling BringWindowToTop, but doesn't activate it } + SetWindowPos(Handle, HWND_TOP, 0, 0, 0, 0, + SWP_NOACTIVATE or SWP_NOMOVE or SWP_NOSIZE); + + { Since it is returning MA_NOACTIVATE, activate the form instead. } + ParentForm := TBGetToolWindowParentForm(FDockableWindow); + MDIParentForm := GetMDIParent(ParentForm); + if (FDockableWindow.FFloatingMode = fmOnTopOfParentForm) and + FDockableWindow.FActivateParent and + Assigned(MDIParentForm) and (GetActiveWindow <> Handle) then begin + { ^ Note to self: The GetActiveWindow check must be in there so that + double-clicks work properly on controls like Edits } + if MDIParentForm.HandleAllocated then + SetActiveWindow(MDIParentForm.Handle); + if (MDIParentForm <> ParentForm) and { if it's an MDI child form } + ParentForm.HandleAllocated then + BringWindowToTop(ParentForm.Handle); + end; +end; + +procedure TTBFloatingWindowParent.WMMove(var Message: TWMMove); +begin + inherited; + FDockableWindow.Moved; +end; + +procedure TTBFloatingWindowParent.DrawNCArea(const DrawToDC: Boolean; + const ADC: HDC; const Clip: HRGN; RedrawWhat: TTBToolWindowNCRedrawWhat); +{ Redraws all the non-client area (the border, title bar, and close button) of + the toolbar when it is floating. } +const + BorderColors: array[Boolean] of Integer = + (COLOR_ACTIVEBORDER, COLOR_INACTIVEBORDER); + CaptionBkColors: array[Boolean, Boolean] of Integer = + ((COLOR_ACTIVECAPTION, COLOR_INACTIVECAPTION), + (COLOR_GRADIENTACTIVECAPTION, COLOR_GRADIENTINACTIVECAPTION)); + CloseButtonState: array[Boolean] of UINT = (0, DFCS_PUSHED); +var + DC: HDC; + R, R2: TRect; + Gradient: Boolean; + SavePen: HPEN; + SaveIndex: Integer; + S: TPoint; +begin + if not HandleAllocated then Exit; + + if not DrawToDC then + DC := GetWindowDC(Handle) + else + DC := ADC; + try + { Use update region } + if not DrawToDC then + SelectNCUpdateRgn(Handle, DC, Clip); + + { Work around an apparent NT 4.0 & 2000 bug. If the width of the DC is + greater than the width of the screen, then any call to ExcludeClipRect + inexplicably shrinks the clipping rectangle to the screen width. I've + found that calling IntersectClipRect as done below magically fixes the + problem (but I'm not sure why). } + GetWindowRect(Handle, R); OffsetRect(R, -R.Left, -R.Top); + IntersectClipRect(DC, R.Left, R.Top, R.Right, R.Bottom); + + Gradient := GetSystemParametersInfoBool(SPI_GETGRADIENTCAPTIONS, False); + + { Border } + if twrdBorder in RedrawWhat then begin + { This works around WM_NCPAINT problem described at top of source code } + {no! R := Rect(0, 0, Width, Height);} + GetWindowRect(Handle, R); OffsetRect(R, -R.Left, -R.Top); + R2 := R; + DrawEdge(DC, R, EDGE_RAISED, BF_RECT or BF_ADJUST); + S := FDockableWindow.GetFloatingBorderSize; + InflateRect(R2, -(S.X - 1), -(S.Y - 1)); + FrameRect(DC, R2, GetSysColorBrush(COLOR_BTNFACE)); + SaveIndex := SaveDC(DC); + ExcludeClipRect(DC, R2.Left, R2.Top, R2.Right, R2.Bottom); + FillRect(DC, R, GetSysColorBrush(BorderColors[FDockableWindow.FInactiveCaption])); + RestoreDC(DC, SaveIndex); + end; + + if FDockableWindow.ShowCaption then begin + if (twrdCaption in RedrawWhat) and FDockableWindow.FCloseButton and + (twrdCloseButton in RedrawWhat) then + SaveIndex := SaveDC(DC) + else + SaveIndex := 0; + try + if SaveIndex <> 0 then + with GetCloseButtonRect(True) do + { Reduces flicker } + ExcludeClipRect(DC, Left, Top, Right, Bottom); + + { Caption } + if twrdCaption in RedrawWhat then begin + R := GetCaptionRect(True, FDockableWindow.FCloseButton); + DrawSmallWindowCaption(Handle, DC, R, Caption, + not FDockableWindow.FInactiveCaption); + + { Line below caption } + R := GetCaptionRect(True, False); + SavePen := SelectObject(DC, CreatePen(PS_SOLID, 1, GetSysColor(COLOR_BTNFACE))); + MoveToEx(DC, R.Left, R.Bottom, nil); + LineTo(DC, R.Right, R.Bottom); + DeleteObject(SelectObject(DC, SavePen)); + end; + finally + if SaveIndex <> 0 then + RestoreDC(DC, SaveIndex); + end; + + { Close button } + if FDockableWindow.FCloseButton then begin + R := GetCloseButtonRect(True); + R2 := R; + InflateRect(R2, 0, -2); + Dec(R2.Right, 2); + if twrdCaption in RedrawWhat then begin + SaveIndex := SaveDC(DC); + ExcludeClipRect(DC, R2.Left, R2.Top, R2.Right, R2.Bottom); + FillRect(DC, R, GetSysColorBrush(CaptionBkColors[Gradient, + FDockableWindow.FInactiveCaption])); + RestoreDC(DC, SaveIndex); + end; + if twrdCloseButton in RedrawWhat then + DrawFrameControl(DC, R2, DFC_CAPTION, DFCS_CAPTIONCLOSE or + CloseButtonState[FCloseButtonDown]); + end; + end; + finally + if not DrawToDC then + ReleaseDC(Handle, DC); + end; +end; + +procedure TTBFloatingWindowParent.RedrawNCArea(const RedrawWhat: TTBToolWindowNCRedrawWhat); +begin + { Note: IsWindowVisible is called as an optimization. There's no need to + draw on invisible windows. } + if HandleAllocated and IsWindowVisible(Handle) then + DrawNCArea(False, 0, 0, RedrawWhat); +end; + +procedure TTBFloatingWindowParent.CallRecreateWnd; +{ This method exists for Delphi.NET: If we try to call RecreateWnd directly + in TTBCustomDockableWindow.SetResizable, we get this compiler error: + "Only methods of descendant types may access protected member + [Borland.Vcl]TWinControl.RecreateWnd across assembly boundaries" } +begin + RecreateWnd; +end; + + +{ TTBCustomDockableWindow } + +constructor TTBCustomDockableWindow.Create(AOwner: TComponent); +begin + inherited; + + ControlStyle := ControlStyle + + [csAcceptsControls, csClickEvents, csDoubleClicks, csSetCaption] - + [csCaptureMouse{capturing is done manually}, csOpaque]; + FAutoResize := True; + FActivateParent := True; + FBorderStyle := bsSingle; + FCloseButton := True; + FDockableTo := [dpTop, dpBottom, dpLeft, dpRight]; + FDockableWindowStyles := [tbdsResizeEightCorner, tbdsResizeClipCursor]; + FDockPos := -1; + FDragHandleStyle := dhSingle; + FEffectiveDockRow := -1; + FHideWhenInactive := True; + FResizable := True; + FShowCaption := True; + FSmoothDrag := True; + FUseLastDock := True; + + Color := clBtnFace; + + if not(csDesigning in ComponentState) then + InstallHookProc(Self, ToolbarHookProc, [hpSendActivate, hpSendActivateApp, + hpSendWindowPosChanged, hpPreDestroy]); + InitTrackMouseEvent; +end; + +destructor TTBCustomDockableWindow.Destroy; +begin + inherited; + FreeAndNil(FDockForms); { must be done after 'inherited' because Notification accesses FDockForms } + FreeAndNil(FFloatParent); + UninstallHookProc(Self, ToolbarHookProc); +end; + +function TTBCustomDockableWindow.HasParent: Boolean; +begin + if Parent is TTBFloatingWindowParent then + Result := False + else + Result := inherited HasParent; +end; + +function TTBCustomDockableWindow.GetParentComponent: TComponent; +begin + if Parent is TTBFloatingWindowParent then + Result := nil + else + Result := inherited GetParentComponent; +end; + +procedure TTBCustomDockableWindow.Moved; +begin + if not(csLoading in ComponentState) and Assigned(FOnMove) and (FDisableOnMove <= 0) then + FOnMove(Self); +end; + +procedure TTBCustomDockableWindow.WMMove(var Message: TWMMove); + + procedure Redraw; + { Redraws the control using an off-screen bitmap to avoid flicker } + var + CR, R: TRect; + W: HWND; + DC, BmpDC: HDC; + Bmp: HBITMAP; + begin + if not HandleAllocated then Exit; + CR := ClientRect; + W := Handle; + if GetUpdateRect(W, R, False) and EqualRect(R, CR) then begin + { The client area is already completely invalid, so don't bother using + an off-screen bitmap } + InvalidateAll(Self); + Exit; + end; + ValidateRect(W, nil); + BmpDC := 0; + Bmp := 0; + DC := GetDC(W); + try + BmpDC := CreateCompatibleDC(DC); + Bmp := CreateCompatibleBitmap(DC, CR.Right, CR.Bottom); + SelectObject(BmpDC, Bmp); + SendMessage(W, WM_NCPAINT, 0, 0); + SendMessage(W, WM_ERASEBKGND, WPARAM(BmpDC), 0); + SendMessage(W, WM_PAINT, WPARAM(BmpDC), 0); + BitBlt(DC, 0, 0, CR.Right, CR.Bottom, BmpDC, 0, 0, SRCCOPY); + finally + if BmpDC <> 0 then DeleteDC(BmpDC); + if Bmp <> 0 then DeleteObject(Bmp); + ReleaseDC(W, DC); + end; + end; + +begin + inherited; + FMoved := True; + if Docked and CurrentDock.UsingBackground then begin + { Needs to redraw so that the background is lined up with the dock at the + new position. } + Redraw; + end; + Moved; +end; + +{$IFNDEF JR_D4} +procedure TTBCustomDockableWindow.WMSize(var Message: TWMSize); +begin + inherited; + if not(csLoading in ComponentState) and Assigned(FOnResize) then + FOnResize(Self); +end; +{$ENDIF} + +procedure TTBCustomDockableWindow.UpdateCaptionState; +{ Updates the caption active/inactive state of a floating tool window. + Called when the tool window is visible or is about to be shown. } + + function IsPopupWindowActive: Boolean; + const + IID_ITBPopupWindow: TGUID = '{E45CBE74-1ECF-44CB-B064-6D45B1924708}'; + var + Ctl: TWinControl; + {$IFDEF CLR} + Intfs: array of System.Type; + I: Integer; + {$ENDIF} + begin + Ctl := FindControl(GetActiveWindow); + { Instead of using "is TTBPopupWindow", which would require linking to the + TB2Item unit, check if the control implements the ITBPopupWindow + interface. This will tell us if it's a TTBPopupWindow or descendant. } + {$IFNDEF CLR} + Result := Assigned(Ctl) and Assigned(Ctl.GetInterfaceEntry(IID_ITBPopupWindow)); + {$ELSE} + Result := False; + if Assigned(Ctl) then begin + Intfs := TypeOf(Ctl).GetInterfaces; + for I := Low(Intfs) to High(Intfs) do begin + if Intfs[I].GUID = IID_ITBPopupWindow then begin + Result := True; + Break; + end; + end; + end; + {$ENDIF} + end; + + function GetActiveFormWindow: HWND; + var + Ctl: TWinControl; + begin + Result := GetActiveWindow; + { If the active window is a TTBFloatingWindowParent (i.e. a control on a + floating toolbar is focused), return the parent form handle instead } + Ctl := FindControl(Result); + if Assigned(Ctl) and (Ctl is TTBFloatingWindowParent) then begin + Ctl := TTBFloatingWindowParent(Ctl).ParentForm; + if Assigned(Ctl) and Ctl.HandleAllocated then + Result := Ctl.Handle; + end; + end; + +var + Inactive: Boolean; + ActiveWnd: HWND; +begin + { Update caption state if floating, but not if a control on a popup window + (e.g. a TTBEditItem) is currently focused; we don't want the captions on + all floating toolbars to turn gray in that case. (The caption state will + get updated when we're called the next time the active window changes, + i.e. when the user dismisses the popup window.) } + if (Parent is TTBFloatingWindowParent) and Parent.HandleAllocated and + not IsPopupWindowActive then begin + Inactive := False; + if not ApplicationIsActive then + Inactive := True + else if (FFloatingMode = fmOnTopOfParentForm) and + (HWND(GetWindowLong(Parent.Handle, GWL_HWNDPARENT)) <> Application.Handle) then begin + { Use inactive caption if the active window doesn't own the float parent + (directly or indirectly). Note: For compatibility with browser-embedded + TActiveForms, we use IsAncestorOfWindow instead of checking + TBGetToolWindowParentForm. } + ActiveWnd := GetActiveFormWindow; + if (ActiveWnd = 0) or not IsAncestorOfWindow(ActiveWnd, Parent.Handle) then + Inactive := True; + end; + if FInactiveCaption <> Inactive then begin + FInactiveCaption := Inactive; + TTBFloatingWindowParent(Parent).RedrawNCArea(twrdAll); + end; + end; +end; + +function TTBCustomDockableWindow.GetShowingState: Boolean; + + function IsWindowVisibleAndNotMinimized(Wnd: HWND): Boolean; + begin + Result := IsWindowVisible(Wnd); + if Result then begin + { Wnd may not be a top-level window (e.g. in the case of an MDI child + form, or an ActiveForm embedded in a web page), so go up the chain of + parent windows and see if any of them are minimized } + repeat + if IsIconic(Wnd) then begin + Result := False; + Break; + end; + { Stop if we're at a top-level window (no need to check owner windows) } + if GetWindowLong(Wnd, GWL_STYLE) and WS_CHILD = 0 then + Break; + Wnd := GetParent(Wnd); + until Wnd = 0; + end; + end; + +var + HideFloatingToolbars: Boolean; + ParentForm: TTBCustomForm; +begin + Result := Showing and (FHidden = 0); + if Floating and not(csDesigning in ComponentState) then begin + HideFloatingToolbars := FFloatingMode = fmOnTopOfParentForm; + if HideFloatingToolbars then begin + ParentForm := TBGetToolWindowParentForm(Self); + if Assigned(ParentForm) and ParentForm.HandleAllocated and + IsWindowVisibleAndNotMinimized(ParentForm.Handle) then + HideFloatingToolbars := False; + end; + Result := Result and not (HideFloatingToolbars or (FHideWhenInactive and not ApplicationIsActive)); + end; +end; + +procedure TTBCustomDockableWindow.UpdateVisibility; +{ Updates the visibility of the tool window, and additionally the caption + state if floating and showing } +var + IsVisible: Boolean; +begin + if HandleAllocated then begin + IsVisible := IsWindowVisible(Handle); + if IsVisible <> GetShowingState then begin + Perform(CM_SHOWINGCHANGED, 0, 0); + { Note: CMShowingChanged will call UpdateCaptionState automatically + when floating and showing } + end + else if IsVisible and Floating then begin + { If we're floating and we didn't send the CM_SHOWINGCHANGED message + then we have to call UpdateCaptionState manually } + UpdateCaptionState; + end; + end; +end; + +function IsTopmost(const Wnd: HWND): Boolean; +begin + Result := GetWindowLong(Wnd, GWL_EXSTYLE) and WS_EX_TOPMOST <> 0; +end; + +procedure TTBCustomDockableWindow.UpdateTopmostFlag; +const + Wnds: array[Boolean] of HWND = (HWND_NOTOPMOST, HWND_TOPMOST); +var + ShouldBeTopmost: Boolean; +begin + if HandleAllocated then begin + if FFloatingMode = fmOnTopOfAllForms then + ShouldBeTopmost := True + else + ShouldBeTopmost := IsTopmost(HWND(GetWindowLong(Parent.Handle, GWL_HWNDPARENT))); + if ShouldBeTopmost <> IsTopmost(Parent.Handle) then + { ^ it must check if it already was topmost or non-topmost or else + it causes problems on Win95/98 for some reason } + SetWindowPos(Parent.Handle, Wnds[ShouldBeTopmost], 0, 0, 0, 0, + SWP_NOACTIVATE or SWP_NOMOVE or SWP_NOSIZE); + end; +end; + +procedure TTBCustomDockableWindow.CMShowingChanged(var Message: TMessage); + + function GetPrevWnd(W: HWND): HWND; + var + WasTopmost, Done: Boolean; + ParentWnd: HWND; + begin + WasTopmost := IsTopmost(Parent.Handle); + Result := W; + repeat + Done := True; + Result := GetWindow(Result, GW_HWNDPREV); + ParentWnd := Result; + while ParentWnd <> 0 do begin + if WasTopmost and not IsTopmost(ParentWnd) then begin + Done := False; + Break; + end; + ParentWnd := HWND(GetWindowLong(ParentWnd, GWL_HWNDPARENT)); + if ParentWnd = W then begin + Done := False; + Break; + end; + end; + until Done; + end; + +const + ShowFlags: array[Boolean] of UINT = ( + SWP_NOSIZE or SWP_NOMOVE or SWP_NOZORDER or SWP_NOACTIVATE or SWP_HIDEWINDOW, + SWP_NOSIZE or SWP_NOMOVE or SWP_NOZORDER or SWP_NOACTIVATE or SWP_SHOWWINDOW); +var + Show: Boolean; + Form: TTBCustomForm; +begin + { inherited isn't called since TTBCustomDockableWindow handles CM_SHOWINGCHANGED + itself. For reference, the original TWinControl implementation is: + const + ShowFlags: array[Boolean] of Word = ( + SWP_NOSIZE + SWP_NOMOVE + SWP_NOZORDER + SWP_NOACTIVATE + SWP_HIDEWINDOW, + SWP_NOSIZE + SWP_NOMOVE + SWP_NOZORDER + SWP_NOACTIVATE + SWP_SHOWWINDOW); + begin + SetWindowPos(FHandle, 0, 0, 0, 0, 0, ShowFlags[FShowing]); + end; + } + if HandleAllocated then begin + Show := GetShowingState; + if Parent is TTBFloatingWindowParent then begin + if Show then begin + { If the toolbar is floating, set its "owner window" to the parent form + so that the toolbar window always stays on top of the form } + if FFloatingMode = fmOnTopOfParentForm then begin + Form := GetMDIParent(TBGetToolWindowParentForm(Self)); + if Assigned(Form) and Form.HandleAllocated and + (HWND(GetWindowLong(Parent.Handle, GWL_HWNDPARENT)) <> Form.Handle) then begin + SetWindowOwner(Parent.Handle, Form.Handle); + { Following is necessarily to make it immediately realize the + GWL_HWNDPARENT change } + SetWindowPos(Parent.Handle, GetPrevWnd(Form.Handle), 0, 0, 0, 0, SWP_NOACTIVATE or + SWP_NOMOVE or SWP_NOSIZE); + end; + end + else begin + SetWindowOwner(Parent.Handle, Application.Handle); + end; + { Initialize caption state after setting owner but before showing } + UpdateCaptionState; + end; + UpdateTopmostFlag; + { Show/hide the TTBFloatingWindowParent. The following lines had to be + added to fix a problem that was in 1.65d/e. In 1.65d/e, it always + kept TTBFloatingWindowParent visible (this change was made to improve + compatibility with D4's Actions), but this for some odd reason would + cause a Stack Overflow error if the program's main form was closed + while a floating toolwindow was focused. (This problem did not occur + on NT.) } + TTBFloatingWindowParent(Parent).FShouldShow := Show; + Parent.Perform(CM_SHOWINGCHANGED, 0, 0); + end; + SetWindowPos(Handle, 0, 0, 0, 0, 0, ShowFlags[Show]); + if not Show and (GetActiveWindow = Handle) then + { If the window is hidden but is still active, find and activate a + different window } + SetActiveWindow(FindTopLevelWindow(Handle)); + end; +end; + +procedure TTBCustomDockableWindow.CreateParams(var Params: TCreateParams); +begin + inherited; + + { Disable complete redraws when size changes. CS_H/VREDRAW cause flicker + and are not necessary for this control at run time } + if not(csDesigning in ComponentState) then + with Params.WindowClass do + Style := Style and not(CS_HREDRAW or CS_VREDRAW); +end; + +procedure TTBCustomDockableWindow.Notification(AComponent: TComponent; Operation: TOperation); +begin + inherited; + if Operation = opRemove then begin + if AComponent = FDefaultDock then + FDefaultDock := nil + else + if AComponent = FLastDock then + FLastDock := nil + else + RemoveFromList(FDockForms, AComponent); + end; +end; + +procedure TTBCustomDockableWindow.MoveOnScreen(const OnlyIfFullyOffscreen: Boolean); +{ Moves the (floating) toolbar so that it is fully (or at least mostly) in + view on the screen } +var + R, S, Test: TRect; +begin + if Floating then begin + R := Parent.BoundsRect; + S := GetRectOfMonitorContainingRect(R, True); + + if OnlyIfFullyOffscreen and IntersectRect(Test, R, S) then + Exit; + + if R.Right > S.Right then + OffsetRect(R, S.Right - R.Right, 0); + if R.Bottom > S.Bottom then + OffsetRect(R, 0, S.Bottom - R.Bottom); + if R.Left < S.Left then + OffsetRect(R, S.Left - R.Left, 0); + if R.Top < S.Top then + OffsetRect(R, 0, S.Top - R.Top); + Parent.BoundsRect := R; + end; +end; + +procedure TTBCustomDockableWindow.ReadPositionData(const Data: TTBReadPositionData); +begin +end; + +procedure TTBCustomDockableWindow.DoneReadingPositionData(const Data: TTBReadPositionData); +begin +end; + +procedure TTBCustomDockableWindow.WritePositionData(const Data: TTBWritePositionData); +begin +end; + +procedure TTBCustomDockableWindow.InitializeOrdering; +begin +end; + +procedure TTBCustomDockableWindow.SizeChanging(const AWidth, AHeight: Integer); +begin +end; + +procedure TTBCustomDockableWindow.ReadSavedAtRunTime(Reader: TReader); +begin + FSavedAtRunTime := Reader.ReadBoolean; +end; + +procedure TTBCustomDockableWindow.WriteSavedAtRunTime(Writer: TWriter); +begin + { WriteSavedAtRunTime only called when not(csDesigning in ComponentState) } + Writer.WriteBoolean(True); +end; + +procedure TTBCustomDockableWindow.DefineProperties(Filer: TFiler); +begin + inherited; + Filer.DefineProperty('SavedAtRunTime', ReadSavedAtRunTime, + WriteSavedAtRunTime, not(csDesigning in ComponentState)); +end; + +procedure TTBCustomDockableWindow.Loaded; +var + R: TRect; +begin + inherited; + { Adjust coordinates if it was initially floating } + if not FSavedAtRunTime and not(csDesigning in ComponentState) and + (Parent is TTBFloatingWindowParent) then begin + R := BoundsRect; + MapWindowPoints(TBValidToolWindowParentForm(Self).Handle, 0, R, 2); + BoundsRect := R; + MoveOnScreen(False); + end; + InitializeOrdering; + { Arranging is disabled while component was loading, so arrange now } + Arrange; +end; + +procedure TTBCustomDockableWindow.BeginUpdate; +begin + Inc(FDisableArrange); +end; + +procedure TTBCustomDockableWindow.EndUpdate; +begin + Dec(FDisableArrange); + if FArrangeNeeded and (FDisableArrange = 0) then + Arrange; +end; + +procedure TTBCustomDockableWindow.AddDockForm(const Form: TTBCustomForm); +begin + if Form = nil then Exit; + if AddToList(FDockForms, Form) then + Form.FreeNotification(Self); +end; + +procedure TTBCustomDockableWindow.RemoveDockForm(const Form: TTBCustomForm); +begin + RemoveFromList(FDockForms, Form); +end; + +function TTBCustomDockableWindow.IsAutoResized: Boolean; +begin + Result := AutoResize or Assigned(CurrentDock) or Floating; +end; + +procedure TTBCustomDockableWindow.ChangeSize(AWidth, AHeight: Integer); +var + S: TPoint; +begin + if Docked then + CurrentDock.ArrangeToolbars + else begin + S := CalcNCSizes; + Inc(AWidth, S.X); + Inc(AHeight, S.Y); + { Leave the width and/or height alone if the control is Anchored + (or Aligned) } + if not Floating then begin + if (akLeft in Anchors) and (akRight in Anchors) then + AWidth := Width; + if (akTop in Anchors) and (akBottom in Anchors) then + AHeight := Height; + end; + Inc(FUpdatingBounds); + try + SetBounds(Left, Top, AWidth, AHeight); + finally + Dec(FUpdatingBounds); + end; + end; +end; + +procedure TTBCustomDockableWindow.Arrange; +var + Size: TPoint; +begin + if (FDisableArrange > 0) or + { Prevent flicker while loading } + (csLoading in ComponentState) or + { Don't call DoArrangeControls when Parent is nil. The VCL sets Parent to + 'nil' during destruction of a component; we can't have an OrderControls + call after a descendant control has freed its data. } + (Parent = nil) then begin + FArrangeNeeded := True; + Exit; + end; + + FArrangeNeeded := False; + + Size := DoArrange(True, TBGetDockTypeOf(CurrentDock, Floating), Floating, + CurrentDock); + if IsAutoResized then + ChangeSize(Size.X, Size.Y); +end; + +procedure TTBCustomDockableWindow.SetBounds(ALeft, ATop, AWidth, AHeight: Integer); +begin + if not(csDesigning in ComponentState) and Floating then begin + { Force Top & Left to 0 if floating } + ALeft := 0; + ATop := 0; + if Parent is TTBFloatingWindowParent then + with Parent do + SetBounds(Left, Top, (Width-ClientWidth) + AWidth, + (Height-ClientHeight) + AHeight); + end; + if (FUpdatingBounds = 0) and ((AWidth <> Width) or (AHeight <> Height)) then + SizeChanging(AWidth, AHeight); + { This allows you to drag the toolbar around the dock at design time } + if (csDesigning in ComponentState) and not(csLoading in ComponentState) and + Docked and (FUpdatingBounds = 0) and ((ALeft <> Left) or (ATop <> Top)) then begin + if not(CurrentDock.Position in PositionLeftOrRight) then begin + FDockRow := CurrentDock.GetDesignModeRowOf(ATop+(Height div 2)); + FDockPos := ALeft; + end + else begin + FDockRow := CurrentDock.GetDesignModeRowOf(ALeft+(Width div 2)); + FDockPos := ATop; + end; + inherited SetBounds(Left, Top, AWidth, AHeight); { only pass any size changes } + CurrentDock.ArrangeToolbars; { let ArrangeToolbars take care of position changes } + end + else begin + inherited; + {if not(csLoading in ComponentState) and Floating and (FUpdatingBounds = 0) then + FFloatingPosition := BoundsRect.TopLeft;} + end; +end; + +procedure TTBCustomDockableWindow.SetParent(AParent: TWinControl); + procedure UpdateFloatingToolWindows; + begin + if Parent is TTBFloatingWindowParent then begin + AddToList(FloatingToolWindows, Self); + Parent.SetBounds(FFloatingPosition.X, FFloatingPosition.Y, + Parent.Width, Parent.Height); + end + else + RemoveFromList(FloatingToolWindows, Self); + end; + function ParentToCurrentDock(const Ctl: TWinControl): TTBDock; + begin + if Ctl is TTBDock then + Result := TTBDock(Ctl) + else + Result := nil; + end; +var + OldCurrentDock, NewCurrentDock: TTBDock; + NewFloating: Boolean; + SaveHandle: HWND; +begin + OldCurrentDock := ParentToCurrentDock(Parent); + NewCurrentDock := ParentToCurrentDock(AParent); + NewFloating := AParent is TTBFloatingWindowParent; + + if AParent = Parent then begin + { Even though AParent is the same as the current Parent, this code is + necessary because when the VCL destroys the parent of the tool window, + it calls TWinControl.Remove to set FParent instead of using SetParent. + However TControl.Destroy does call SetParent(nil), so it is + eventually notified of the change before it is destroyed. } + FCurrentDock := NewCurrentDock; + FFloating := NewFloating; + FDocked := Assigned(FCurrentDock); + UpdateFloatingToolWindows; + end + else begin + if not(csDestroying in ComponentState) and Assigned(AParent) then begin + if Assigned(FOnDockChanging) then + FOnDockChanging(Self, NewFloating, NewCurrentDock); + if Assigned(FOnRecreating) then + FOnRecreating(Self); + end; + + { Before changing between docked and floating state (and vice-versa) + or between docks, increment FHidden and call UpdateVisibility to hide the + toolbar. This prevents any flashing while it's being moved } + Inc(FHidden); + Inc(FDisableOnMove); + try + UpdateVisibility; + if Assigned(OldCurrentDock) then + OldCurrentDock.BeginUpdate; + if Assigned(NewCurrentDock) then + NewCurrentDock.BeginUpdate; + Inc(FUpdatingBounds); + try + if Assigned(AParent) then + DoDockChangingHidden(NewFloating, NewCurrentDock); + BeginUpdate; + try + { FCurrentSize probably won't be valid after changing Parents, so + reset it to zero } + FCurrentSize := 0; + + if Parent is TTBDock then begin + if not FUseLastDock or (FLastDock <> Parent) then + TTBDock(Parent).ChangeDockList(False, Self); + TTBDock(Parent).ToolbarVisibilityChanged(Self, True); + end; + + { By default, the VCL destroys a control's window handle when it + changes parents. Prevent that from happening by capturing the + current handle, detaching the control from its current parent, + then restoring the handle back. } + SaveHandle := 0; + if Assigned(AParent) then begin + SaveHandle := WindowHandle; + WindowHandle := 0; + end; + inherited SetParent(nil); + FCurrentDock := NewCurrentDock; + FFloating := NewFloating; + FDocked := Assigned(FCurrentDock); + try + if SaveHandle <> 0 then begin + WindowHandle := SaveHandle; + Windows.SetParent(SaveHandle, AParent.Handle); + SetWindowPos(SaveHandle, 0, 0, 0, 0, 0, SWP_FRAMECHANGED or + SWP_NOACTIVATE or SWP_NOMOVE or SWP_NOSIZE or SWP_NOZORDER); + end; + inherited; + except + { Failure is rare, but just in case, restore these back. } + FCurrentDock := ParentToCurrentDock(Parent); + FFloating := Parent is TTBFloatingWindowParent; + FDocked := Assigned(FCurrentDock); + raise; + end; + + { FEffectiveDockRow probably won't be valid on the new Parent, so + reset it to -1 so that GetMinRowSize will temporarily ignore this + toolbar } + FEffectiveDockRow := -1; + + { To conserve resources, free FFloatParent if it's no longer the + Parent. But don't do this while FSmoothDragging=True, because + destroying the window the user initially clicked down on causes + Windows to stop delivering mouse-move messages when the cursor is + moved over other applications' windows, even if we still have the + mouse capture. } + if not FSmoothDragging and + Assigned(FFloatParent) and (Parent <> FFloatParent) then + FreeAndNil(FFloatParent); + + if Parent is TTBDock then begin + if FUseLastDock and not FSmoothDragging then begin + LastDock := TTBDock(Parent); { calls ChangeDockList if LastDock changes } + TTBDock(Parent).ToolbarVisibilityChanged(Self, False); + end + else + TTBDock(Parent).ChangeDockList(True, Self); + end; + + UpdateFloatingToolWindows; + + { Schedule an arrange } + Arrange; + finally + EndUpdate; + end; + finally + Dec(FUpdatingBounds); + if Assigned(NewCurrentDock) then + NewCurrentDock.EndUpdate; + if Assigned(OldCurrentDock) then + OldCurrentDock.EndUpdate; + end; + finally + Dec(FDisableOnMove); + Dec(FHidden); + UpdateVisibility; + { ^ The above UpdateVisibility call not only updates the tool window's + visibility after decrementing FHidden, it also sets the + active/inactive state of the caption. } + end; + if Assigned(Parent) then + Moved; + + if not(csDestroying in ComponentState) and Assigned(AParent) then begin + if Assigned(FOnRecreated) then + FOnRecreated(Self); + if Assigned(FOnDockChanged) then + FOnDockChanged(Self); + end; + end; +end; + +procedure TTBCustomDockableWindow.AddDockedNCAreaToSize(var S: TPoint; + const LeftRight: Boolean); +var + TopLeft, BottomRight: TPoint; +begin + GetDockedNCArea(TopLeft, BottomRight, LeftRight); + Inc(S.X, TopLeft.X + BottomRight.X); + Inc(S.Y, TopLeft.Y + BottomRight.Y); +end; + +procedure TTBCustomDockableWindow.AddFloatingNCAreaToSize(var S: TPoint); +var + TopLeft, BottomRight: TPoint; +begin + GetFloatingNCArea(TopLeft, BottomRight); + Inc(S.X, TopLeft.X + BottomRight.X); + Inc(S.Y, TopLeft.Y + BottomRight.Y); +end; + +procedure TTBCustomDockableWindow.GetDockedNCArea(var TopLeft, BottomRight: TPoint; + const LeftRight: Boolean); +var + Z: Integer; +begin + Z := DockedBorderSize; { code optimization... } + TopLeft.X := Z; + TopLeft.Y := Z; + BottomRight.X := Z; + BottomRight.Y := Z; + if not LeftRight then begin + Inc(TopLeft.X, DragHandleSizes[CloseButtonWhenDocked, DragHandleStyle]); + //if FShowChevron then + // Inc(BottomRight.X, tbChevronSize); + end + else begin + Inc(TopLeft.Y, DragHandleSizes[CloseButtonWhenDocked, DragHandleStyle]); + //if FShowChevron then + // Inc(BottomRight.Y, tbChevronSize); + end; +end; + +function TTBCustomDockableWindow.GetFloatingBorderSize: TPoint; +{ Returns size of a thick border. Note that, depending on the Windows version, + this may not be the same as the actual window metrics since it draws its + own border } +const + XMetrics: array[Boolean] of Integer = (SM_CXDLGFRAME, SM_CXFRAME); + YMetrics: array[Boolean] of Integer = (SM_CYDLGFRAME, SM_CYFRAME); +begin + Result.X := GetSystemMetrics(XMetrics[Resizable]); + Result.Y := GetSystemMetrics(YMetrics[Resizable]); +end; + +procedure TTBCustomDockableWindow.GetFloatingNCArea(var TopLeft, BottomRight: TPoint); +begin + with GetFloatingBorderSize do begin + TopLeft.X := X; + TopLeft.Y := Y; + if ShowCaption then + Inc(TopLeft.Y, GetSmallCaptionHeight); + BottomRight.X := X; + BottomRight.Y := Y; + end; +end; + +function TTBCustomDockableWindow.GetDockedCloseButtonRect(LeftRight: Boolean): TRect; +var + X, Y, Z: Integer; +begin + Z := DragHandleSizes[CloseButtonWhenDocked, FDragHandleStyle] - 3; + if not LeftRight then begin + X := DockedBorderSize+1; + Y := DockedBorderSize; + end + else begin + X := (ClientWidth + DockedBorderSize) - Z; + Y := DockedBorderSize+1; + end; + Result := Bounds(X, Y, Z, Z); +end; + +function TTBCustomDockableWindow.CalcNCSizes: TPoint; +var + Z: Integer; +begin + if not Docked then begin + Result.X := 0; + Result.Y := 0; + end + else begin + Result.X := DockedBorderSize2; + Result.Y := DockedBorderSize2; + if CurrentDock.FAllowDrag then begin + Z := DragHandleSizes[FCloseButtonWhenDocked, FDragHandleStyle]; + if not(CurrentDock.Position in PositionLeftOrRight) then + Inc(Result.X, Z) + else + Inc(Result.Y, Z); + end; + end; +end; + +procedure TTBCustomDockableWindow.WMNCCalcSize(var Message: TWMNCCalcSize); + + procedure ApplyToRect(var R: TRect); + var + Z: Integer; + begin + InflateRect(R, -DockedBorderSize, -DockedBorderSize); + if CurrentDock.FAllowDrag then begin + Z := DragHandleSizes[FCloseButtonWhenDocked, FDragHandleStyle]; + if not(CurrentDock.Position in PositionLeftOrRight) then + Inc(R.Left, Z) + else + Inc(R.Top, Z); + end; + end; + +{$IFDEF CLR} +var + Params: TNCCalcSizeParams; +{$ENDIF} +begin + { Doesn't call inherited since it overrides the normal NC sizes } + Message.Result := 0; + if Docked then begin + {$IFNDEF CLR} + ApplyToRect(Message.CalcSize_Params.rgrc[0]); + {$ELSE} + Params := Message.CalcSize_Params; + ApplyToRect(Params.rgrc0); + Message.CalcSize_Params := Params; + {$ENDIF} + end; +end; + +procedure TTBCustomDockableWindow.WMSetCursor(var Message: TWMSetCursor); +var + P: TPoint; + R: TRect; + I: Integer; +begin + if Docked and CurrentDock.FAllowDrag and + (Message.CursorWnd = WindowHandle) and + (Smallint(Message.HitTest) = HT_TB2k_Border) and + (DragHandleStyle <> dhNone) then begin + GetCursorPos(P); + GetWindowRect(Handle, R); + if not(CurrentDock.Position in PositionLeftOrRight) then + I := P.X - R.Left + else + I := P.Y - R.Top; + if I < DockedBorderSize + DragHandleSizes[CloseButtonWhenDocked, DragHandleStyle] then begin + SetCursor(LoadCursor(0, IDC_SIZEALL)); + Message.Result := 1; + Exit; + end; + end; + inherited; +end; + +procedure TTBCustomDockableWindow.DrawNCArea(const DrawToDC: Boolean; + const ADC: HDC; const Clip: HRGN); +{ Redraws all the non-client area of the toolbar when it is docked. } +var + DC: HDC; + R: TRect; + VerticalDock: Boolean; + X, Y, Y2, Y3, YO, S, SaveIndex: Integer; + R2, R3, R4: TRect; + P1, P2: TPoint; + Brush: HBRUSH; + Clr: TColorRef; + UsingBackground, B: Boolean; + + procedure DrawRaisedEdge(R: TRect; const FillInterior: Boolean); + const + FillMiddle: array[Boolean] of UINT = (0, BF_MIDDLE); + begin + DrawEdge(DC, R, BDR_RAISEDINNER, BF_RECT or FillMiddle[FillInterior]); + end; + + function CreateCloseButtonBitmap: HBITMAP; + const + Pattern: array[0..15] of Byte = + (0, 0, $CC, 0, $78, 0, $30, 0, $78, 0, $CC, 0, 0, 0, 0, 0); + begin + Result := CreateMonoBitmap(8, 8, Pattern); + end; + + procedure DrawButtonBitmap(const Bmp: HBITMAP); + var + TempBmp: TBitmap; + begin + TempBmp := TBitmap.Create; + try + TempBmp.Handle := Bmp; + SetTextColor(DC, clBlack); + SetBkColor(DC, clWhite); + SelectObject(DC, GetSysColorBrush(COLOR_BTNTEXT)); + BitBlt(DC, R2.Left, R2.Top, R2.Right - R2.Left, R2.Bottom - R2.Top, + TempBmp.Canvas.Handle, 0, 0, $00E20746 {ROP_DSPDxax}); + finally + TempBmp.Free; + end; + end; + +const + CloseButtonState: array[Boolean] of UINT = (0, DFCS_PUSHED); +begin + if not Docked or not HandleAllocated then Exit; + + if not DrawToDC then + DC := GetWindowDC(Handle) + else + DC := ADC; + try + { Use update region } + if not DrawToDC then + SelectNCUpdateRgn(Handle, DC, Clip); + + { This works around WM_NCPAINT problem described at top of source code } + {no! R := Rect(0, 0, Width, Height);} + GetWindowRect(Handle, R); OffsetRect(R, -R.Left, -R.Top); + + VerticalDock := CurrentDock.Position in PositionLeftOrRight; + + Brush := CreateSolidBrush(ColorToRGB(Color)); + + UsingBackground := CurrentDock.UsingBackground and CurrentDock.FBkgOnToolbars; + + { Border } + if BorderStyle = bsSingle then + DrawRaisedEdge(R, False) + else + FrameRect(DC, R, Brush); + R2 := R; + InflateRect(R2, -1, -1); + if not UsingBackground then + FrameRect(DC, R2, Brush); + + { Draw the Background } + if UsingBackground then begin + R2 := R; + P1 := CurrentDock.ClientToScreen(Point(0, 0)); + P2 := CurrentDock.Parent.ClientToScreen(CurrentDock.BoundsRect.TopLeft); + Dec(R2.Left, Left + CurrentDock.Left + (P1.X-P2.X)); + Dec(R2.Top, Top + CurrentDock.Top + (P1.Y-P2.Y)); + InflateRect(R, -1, -1); + GetWindowRect(Handle, R4); + R3 := ClientRect; + with ClientToScreen(Point(0, 0)) do + OffsetRect(R3, X-R4.Left, Y-R4.Top); + SaveIndex := SaveDC(DC); + IntersectClipRect(DC, R.Left, R.Top, R.Right, R.Bottom); + ExcludeClipRect(DC, R3.Left, R3.Top, R3.Right, R3.Bottom); + CurrentDock.DrawBackground(DC, R2); + RestoreDC(DC, SaveIndex); + end; + + { The drag handle at the left, or top } + if CurrentDock.FAllowDrag then begin + SaveIndex := SaveDC(DC); + if not VerticalDock then + Y2 := ClientHeight + else + Y2 := ClientWidth; + Inc(Y2, DockedBorderSize); + S := DragHandleSizes[FCloseButtonWhenDocked, FDragHandleStyle]; + if FDragHandleStyle <> dhNone then begin + Y3 := Y2; + X := DockedBorderSize + DragHandleXOffsets[FCloseButtonWhenDocked, FDragHandleStyle]; + Y := DockedBorderSize; + YO := Ord(FDragHandleStyle = dhSingle); + if FCloseButtonWhenDocked then begin + if not VerticalDock then + Inc(Y, S - 2) + else + Dec(Y3, S - 2); + end; + Clr := GetSysColor(COLOR_BTNHIGHLIGHT); + for B := False to (FDragHandleStyle = dhDouble) do begin + if not VerticalDock then + R2 := Rect(X, Y+YO, X+3, Y2-YO) + else + R2 := Rect(Y+YO, X, Y3-YO, X+3); + DrawRaisedEdge(R2, True); + if not VerticalDock then + SetPixelV(DC, X, Y2-1-YO, Clr) + else + SetPixelV(DC, Y3-1-YO, X, Clr); + ExcludeClipRect(DC, R2.Left, R2.Top, R2.Right, R2.Bottom); + Inc(X, 3); + end; + end; + if not UsingBackground then begin + if not VerticalDock then + R2 := Rect(DockedBorderSize, DockedBorderSize, + DockedBorderSize+S, Y2) + else + R2 := Rect(DockedBorderSize, DockedBorderSize, + Y2, DockedBorderSize+S); + FillRect(DC, R2, Brush); + end; + RestoreDC(DC, SaveIndex); + { Close button } + if FCloseButtonWhenDocked then begin + R2 := GetDockedCloseButtonRect(VerticalDock); + if FCloseButtonDown then + DrawEdge(DC, R2, BDR_SUNKENOUTER, BF_RECT) + else if FCloseButtonHover then + DrawRaisedEdge(R2, False); + InflateRect(R2, -2, -2); + if FCloseButtonDown then + OffsetRect(R2, 1, 1); + DrawButtonBitmap(CreateCloseButtonBitmap); + end; + end; + + DeleteObject(Brush); + finally + if not DrawToDC then + ReleaseDC(Handle, DC); + end; +end; + +procedure TTBCustomDockableWindow.RedrawNCArea; +begin + { Note: IsWindowVisible is called as an optimization. There's no need to + draw on invisible windows. } + if HandleAllocated and IsWindowVisible(Handle) then + DrawNCArea(False, 0, 0); +end; + +procedure TTBCustomDockableWindow.WMNCPaint(var Message: TMessage); +begin + { Don't call inherited because it overrides the default NC painting } + DrawNCArea(False, 0, HRGN(Message.WParam)); +end; + +procedure DockableWindowNCPaintProc(Wnd: HWND; DC: HDC; AppData: TObject); +begin + with TTBCustomDockableWindow(AppData) do + DrawNCArea(True, DC, 0) +end; + +procedure TTBCustomDockableWindow.WMPrint(var Message: TMessage); +begin + HandleWMPrint(Handle, Message, DockableWindowNCPaintProc, Self); +end; + +procedure TTBCustomDockableWindow.WMPrintClient(var Message: + {$IFNDEF CLR} TMessage {$ELSE} TWMPrintClient {$ENDIF}); +begin + HandleWMPrintClient(PaintHandler, Message); +end; + +procedure TTBCustomDockableWindow.WMEraseBkgnd(var Message: TWMEraseBkgnd); +var + R, R2, R3: TRect; + P1, P2: TPoint; + SaveIndex: Integer; +begin + if Docked and CurrentDock.UsingBackground and CurrentDock.FBkgOnToolbars then begin + R := ClientRect; + R2 := R; + P1 := CurrentDock.ClientToScreen(Point(0, 0)); + P2 := CurrentDock.Parent.ClientToScreen(CurrentDock.BoundsRect.TopLeft); + Dec(R2.Left, Left + CurrentDock.Left + (P1.X-P2.X)); + Dec(R2.Top, Top + CurrentDock.Top + (P1.Y-P2.Y)); + GetWindowRect(Handle, R3); + with ClientToScreen(Point(0, 0)) do begin + Inc(R2.Left, R3.Left-X); + Inc(R2.Top, R3.Top-Y); + end; + SaveIndex := SaveDC(Message.DC); + IntersectClipRect(Message.DC, R.Left, R.Top, R.Right, R.Bottom); + CurrentDock.DrawBackground(Message.DC, R2); + RestoreDC(Message.DC, SaveIndex); + Message.Result := 1; + end + else + inherited; +end; + +function TTBCustomDockableWindow.GetPalette: HPALETTE; +begin + if Docked then + Result := CurrentDock.GetPalette + else + Result := 0; +end; + +function TTBCustomDockableWindow.PaletteChanged(Foreground: Boolean): Boolean; +begin + Result := inherited PaletteChanged(Foreground); + if Result and not Foreground then begin + { There seems to be a bug in Delphi's palette handling. When the form is + inactive and another window realizes a palette, docked TToolbar97s + weren't getting redrawn. So this workaround code was added. } + InvalidateAll(Self); + end; +end; + +procedure TTBCustomDockableWindow.DrawDraggingOutline(const DC: HDC; + const NewRect, OldRect: TRect; const NewDocking, OldDocking: Boolean); +var + NewSize, OldSize: TSize; +begin + with GetFloatingBorderSize do begin + if NewDocking then NewSize.cx := 1 else NewSize.cx := X; + NewSize.cy := NewSize.cx; + if OldDocking then OldSize.cx := 1 else OldSize.cx := X; + OldSize.cy := OldSize.cx; + end; + DrawHalftoneInvertRect(DC, NewRect, OldRect, NewSize, OldSize); +end; + +procedure TTBCustomDockableWindow.CMColorChanged(var Message: TMessage); +begin + { Make sure non-client area is redrawn } + InvalidateAll(Self); + inherited; { the inherited handler calls Invalidate } +end; + +procedure TTBCustomDockableWindow.CMTextChanged(var Message: TMessage); +begin + inherited; + if Parent is TTBFloatingWindowParent then + TTBFloatingWindowParent(Parent).Caption := Caption; +end; + +procedure TTBCustomDockableWindow.CMVisibleChanged(var Message: TMessage); +begin + if not(csDesigning in ComponentState) and Docked then + CurrentDock.ToolbarVisibilityChanged(Self, False); + inherited; + if Assigned(FOnVisibleChanged) then + FOnVisibleChanged(Self); +end; + +type + TRowSize = record + Size: Integer; + FullSizeRow: Boolean; + end; + TDockedSize = class + Dock: TTBDock; + BoundsRect: TRect; + Size: TPoint; + RowSizes: array of TRowSize; + end; + +procedure TTBCustomDockableWindow.BeginMoving(const InitX, InitY: Integer); +const + SplitCursors: array[Boolean] of {$IFNDEF CLR} PChar {$ELSE} Integer {$ENDIF} = + (IDC_SIZEWE, IDC_SIZENS); +var + UseSmoothDrag: Boolean; + DockList: TList; + NewDockedSizes: TList; + OriginalDock, MouseOverDock: TTBDock; + MoveRect: TRect; + StartDocking, PreventDocking, PreventFloating, WatchForSplit, SplitVertical: Boolean; + ScreenDC: HDC; + OldCursor: HCURSOR; + NPoint, DPoint: TPoint; + OriginalDockRow, OriginalDockPos: Integer; + FirstPos, LastPos, CurPos: TPoint; + + function FindDockedSize(const ADock: TTBDock): TDockedSize; + var + I: Integer; + begin + for I := 0 to NewDockedSizes.Count-1 do begin + Result := TDockedSize(NewDockedSizes[I]); + if Result.Dock = ADock then + Exit; + end; + Result := nil; + end; + + function GetRowOf(const RowSizes: array of TRowSize; const XY: Integer; + var Before: Boolean): Integer; + { Returns row number of the specified coordinate. Before is set to True if it + was in the top (or left) quarter of the row. } + var + HighestRow, R, CurY, NextY, CurRowSize, EdgeSize: Integer; + FullSizeRow: Boolean; + begin + Before := False; + HighestRow := High(RowSizes); + CurY := 0; + for R := 0 to HighestRow do begin + CurRowSize := RowSizes[R].Size; + FullSizeRow := FullSize or RowSizes[R].FullSizeRow; + if CurRowSize = 0 then + Continue; + NextY := CurY + CurRowSize; + if not FullSizeRow then + EdgeSize := CurRowSize div 4 + else + EdgeSize := CurRowSize div 2; + if XY < CurY + EdgeSize then begin + Result := R; + Before := True; + Exit; + end; + if not FullSizeRow and (XY < NextY - EdgeSize) then begin + Result := R; + Exit; + end; + CurY := NextY; + end; + Result := HighestRow+1; + end; + + procedure Dropped; + var + NewDockRow: Integer; + Before: Boolean; + MoveRectClient: TRect; + C: Integer; + DockedSize: TDockedSize; + begin + if MouseOverDock <> nil then begin + DockedSize := FindDockedSize(MouseOverDock); + MoveRectClient := MoveRect; + OffsetRect(MoveRectClient, -DockedSize.BoundsRect.Left, + -DockedSize.BoundsRect.Top); + if not FDragSplitting then begin + if not(MouseOverDock.Position in PositionLeftOrRight) then + C := (MoveRectClient.Top+MoveRectClient.Bottom) div 2 + else + C := (MoveRectClient.Left+MoveRectClient.Right) div 2; + NewDockRow := GetRowOf(DockedSize.RowSizes, C, Before); + if Before then + WatchForSplit := False; + end + else begin + NewDockRow := FDockRow; + Before := False; + end; + if WatchForSplit then begin + if (MouseOverDock <> OriginalDock) or (NewDockRow <> OriginalDockRow) then + WatchForSplit := False + else begin + if not SplitVertical then + C := FirstPos.X - LastPos.X + else + C := FirstPos.Y - LastPos.Y; + if Abs(C) >= 10 then begin + WatchForSplit := False; + FDragSplitting := True; + SetCursor(LoadCursor(0, SplitCursors[SplitVertical])); + end; + end; + end; + FDockRow := NewDockRow; + if not(MouseOverDock.Position in PositionLeftOrRight) then + FDockPos := MoveRectClient.Left + else + FDockPos := MoveRectClient.Top; + Parent := MouseOverDock; + if not FSmoothDragging then + CurrentDock.CommitNewPositions := True; + FInsertRowBefore := Before; + try + CurrentDock.ArrangeToolbars; + finally + FInsertRowBefore := False; + end; + end + else begin + WatchForSplit := False; + FloatingPosition := MoveRect.TopLeft; + Floating := True; + { Make sure it doesn't go completely off the screen } + MoveOnScreen(True); + end; + + { Make sure it's repainted immediately (looks better on really slow + computers when smooth dragging is enabled) } + Update; + end; + + procedure MouseMoved; + var + OldMouseOverDock: TTBDock; + OldMoveRect: TRect; + Pos: TPoint; + + function GetDockRect(Control: TTBDock): TRect; + var + I: Integer; + begin + for I := 0 to NewDockedSizes.Count-1 do + with TDockedSize(NewDockedSizes[I]) do begin + if Dock <> Control then Continue; + Result := Bounds(Pos.X-MulDiv(Size.X-1, NPoint.X, DPoint.X), + Pos.Y-MulDiv(Size.Y-1, NPoint.Y, DPoint.Y), + Size.X, Size.Y); + Exit; + end; + SetRectEmpty(Result); + end; + + function CheckIfCanDockTo(Control: TTBDock; R: TRect): Boolean; + const + DockSensX = 25; + DockSensY = 25; + var + S, Temp: TRect; + Sens: Integer; + begin + with Control do begin + Result := False; + + InflateRect(R, 3, 3); + S := GetDockRect(Control); + + { Like Office, distribute ~25 pixels of extra dock detection area + to the left side if the toolbar was grabbed at the left, both sides + if the toolbar was grabbed at the middle, or the right side if + toolbar was grabbed at the right. If outside, don't try to dock. } + Sens := MulDiv(DockSensX, NPoint.X, DPoint.X); + if (Pos.X < R.Left-(DockSensX-Sens)) or (Pos.X >= R.Right+Sens) then + Exit; + + { Don't try to dock to the left or right if pointer is above or below + the boundaries of the dock } + if (Control.Position in PositionLeftOrRight) and + ((Pos.Y < R.Top) or (Pos.Y >= R.Bottom)) then + Exit; + + { And also distribute ~25 pixels of extra dock detection area to + the top or bottom side } + Sens := MulDiv(DockSensY, NPoint.Y, DPoint.Y); + if (Pos.Y < R.Top-(DockSensY-Sens)) or (Pos.Y >= R.Bottom+Sens) then + Exit; + + Result := IntersectRect(Temp, R, S); + end; + end; + + var + R, R2: TRect; + I: Integer; + Dock: TTBDock; + Accept: Boolean; + TL, BR: TPoint; + begin + OldMouseOverDock := MouseOverDock; + OldMoveRect := MoveRect; + + GetCursorPos(Pos); + + if FDragSplitting then + MouseOverDock := CurrentDock + else begin + { Check if it can dock } + MouseOverDock := nil; + if StartDocking and not PreventDocking then + for I := 0 to DockList.Count-1 do begin + Dock := TTBDock(DockList[I]); + if CheckIfCanDockTo(Dock, FindDockedSize(Dock).BoundsRect) then begin + MouseOverDock := Dock; + Accept := True; + if Assigned(MouseOverDock.FOnRequestDock) then + MouseOverDock.FOnRequestDock(MouseOverDock, Self, Accept); + if Accept then + Break + else + MouseOverDock := nil; + end; + end; + end; + + { If not docking, clip the point so it doesn't get dragged under the + taskbar } + if MouseOverDock = nil then begin + R := GetRectOfMonitorContainingPoint(Pos, True); + if Pos.X < R.Left then Pos.X := R.Left; + if Pos.X > R.Right then Pos.X := R.Right; + if Pos.Y < R.Top then Pos.Y := R.Top; + if Pos.Y > R.Bottom then Pos.Y := R.Bottom; + end; + + MoveRect := GetDockRect(MouseOverDock); + + { Make sure title bar (or at least part of the toolbar) is still accessible + if it's dragged almost completely off the screen. This prevents the + problem seen in Office 97 where you drag it offscreen so that only the + border is visible, sometimes leaving you no way to move it back short of + resetting the toolbar. } + if MouseOverDock = nil then begin + R2 := GetRectOfMonitorContainingPoint(Pos, True); + R := R2; + with GetFloatingBorderSize do + InflateRect(R, -(X+4), -(Y+4)); + if MoveRect.Bottom < R.Top then + OffsetRect(MoveRect, 0, R.Top-MoveRect.Bottom); + if MoveRect.Top > R.Bottom then + OffsetRect(MoveRect, 0, R.Bottom-MoveRect.Top); + if MoveRect.Right < R.Left then + OffsetRect(MoveRect, R.Left-MoveRect.Right, 0); + if MoveRect.Left > R.Right then + OffsetRect(MoveRect, R.Right-MoveRect.Left, 0); + + GetFloatingNCArea(TL, BR); + I := R2.Top + 4 - TL.Y; + if MoveRect.Top < I then + OffsetRect(MoveRect, 0, I-MoveRect.Top); + end; + + { Empty MoveRect if it's wanting to float but it's not allowed to, and + set the mouse cursor accordingly. } + if PreventFloating and not Assigned(MouseOverDock) then begin + SetRectEmpty(MoveRect); + SetCursor(LoadCursor(0, IDC_NO)); + end + else begin + if FDragSplitting then + SetCursor(LoadCursor(0, SplitCursors[SplitVertical])) + else + SetCursor(OldCursor); + end; + + { Update the dragging outline } + if not UseSmoothDrag then + DrawDraggingOutline(ScreenDC, MoveRect, OldMoveRect, MouseOverDock <> nil, + OldMouseOverDock <> nil) + else + if not IsRectEmpty(MoveRect) then + Dropped; + end; + + procedure BuildDockList; + + function AcceptableDock(const D: TTBDock): Boolean; + begin + Result := D.FAllowDrag and (D.Position in DockableTo); + end; + + procedure Recurse(const ParentCtl: TWinControl); + var + D: TTBDockPosition; + I: Integer; + begin + if ContainsControl(ParentCtl) or not ParentCtl.HandleAllocated or + not IsWindowVisible(ParentCtl.Handle) then + Exit; + with ParentCtl do begin + for D := Low(D) to High(D) do + for I := 0 to ParentCtl.ControlCount-1 do + if (Controls[I] is TTBDock) and (TTBDock(Controls[I]).Position = D) then + Recurse(TWinControl(Controls[I])); + for I := 0 to ParentCtl.ControlCount-1 do + if (Controls[I] is TWinControl) and not(Controls[I] is TTBDock) then + Recurse(TWinControl(Controls[I])); + end; + if (ParentCtl is TTBDock) and AcceptableDock(TTBDock(ParentCtl)) and + (DockList.IndexOf(ParentCtl) = -1) then + DockList.Add(ParentCtl); + end; + + var + ParentForm: TTBCustomForm; + DockFormsList: TList; + I, J: Integer; + begin + { Manually add CurrentDock to the DockList first so that it gets priority + over other docks } + if Assigned(CurrentDock) and AcceptableDock(CurrentDock) then + DockList.Add(CurrentDock); + ParentForm := TBGetToolWindowParentForm(Self); + DockFormsList := TList.Create; + try + if Assigned(FDockForms) then begin + for I := 0 to Screen.{$IFDEF JR_D3}CustomFormCount{$ELSE}FormCount{$ENDIF}-1 do begin + J := FDockForms.IndexOf(Screen.{$IFDEF JR_D3}CustomForms{$ELSE}Forms{$ENDIF}[I]); + if (J <> -1) and (FDockForms[J] <> ParentForm) then + DockFormsList.Add(FDockForms[J]); + end; + end; + if Assigned(ParentForm) then + DockFormsList.Insert(0, ParentForm); + for I := 0 to DockFormsList.Count-1 do + Recurse(TWinControl(DockFormsList[I])); + finally + DockFormsList.Free; + end; + end; + +var + Accept: Boolean; + R: TRect; + Msg: TMsg; + NewDockedSize: TDockedSize; + I, J: Integer; +begin + Accept := False; + SplitVertical := False; + WatchForSplit := False; + OriginalDock := CurrentDock; + OriginalDockRow := FDockRow; + OriginalDockPos := FDockPos; + try + FDragMode := True; + FDragSplitting := False; + if Docked then begin + FDragCanSplit := False; + CurrentDock.CommitNewPositions := True; + CurrentDock.ArrangeToolbars; { needed for WatchForSplit assignment below } + SplitVertical := CurrentDock.Position in PositionLeftOrRight; + WatchForSplit := FDragCanSplit; + end; + DockList := nil; + NewDockedSizes := nil; + try + UseSmoothDrag := FSmoothDrag; + FSmoothDragging := UseSmoothDrag; + + NPoint := Point(InitX, InitY); + { Adjust for non-client area } + if not(Parent is TTBFloatingWindowParent) then begin + GetWindowRect(Handle, R); + R.BottomRight := ClientToScreen(Point(0, 0)); + DPoint := Point(Width-1, Height-1); + end + else begin + GetWindowRect(Parent.Handle, R); + R.BottomRight := Parent.ClientToScreen(Point(0, 0)); + DPoint := Point(Parent.Width-1, Parent.Height-1); + end; + Dec(NPoint.X, R.Left-R.Right); + Dec(NPoint.Y, R.Top-R.Bottom); + + PreventDocking := GetKeyState(VK_CONTROL) < 0; + PreventFloating := DockMode <> dmCanFloat; + + { Build list of all TTBDock's on the form } + DockList := TList.Create; + if DockMode <> dmCannotFloatOrChangeDocks then + BuildDockList + else + if Docked then + DockList.Add(CurrentDock); + + { Ensure positions of each possible dock are committed } + for I := 0 to DockList.Count-1 do + TTBDock(DockList[I]).CommitPositions; + + { Set up potential sizes for each dock type } + NewDockedSizes := TList.Create; + for I := -1 to DockList.Count-1 do begin + NewDockedSizes.Expand; + NewDockedSize := TDockedSize.Create; + try + with NewDockedSize do begin + if I = -1 then begin + { -1 adds the floating size } + Dock := nil; + SetRectEmpty(BoundsRect); + Size := DoArrange(False, TBGetDockTypeOf(CurrentDock, Floating), True, nil); + AddFloatingNCAreaToSize(Size); + end + else begin + Dock := TTBDock(DockList[I]); + BoundsRect := Dock.ClientRect; + MapWindowPoints(Dock.Handle, 0, BoundsRect, 2); + if Dock <> CurrentDock then begin + Size := DoArrange(False, TBGetDockTypeOf(CurrentDock, Floating), False, Dock); + AddDockedNCAreaToSize(Size, Dock.Position in PositionLeftOrRight); + end + else + Size := Point(Width, Height); + end; + end; + if Assigned(NewDockedSize.Dock) then begin + SetLength(NewDockedSize.RowSizes, NewDockedSize.Dock.GetHighestRow(True) + 1); + for J := 0 to High(NewDockedSize.RowSizes) do begin + NewDockedSize.RowSizes[J].Size := NewDockedSize.Dock.GetCurrentRowSize(J, + NewDockedSize.RowSizes[J].FullSizeRow); + end; + end; + except + NewDockedSize.Free; + raise; + end; + NewDockedSizes.Add(NewDockedSize); + end; + + { Before locking, make sure all pending paint messages are processed } + ProcessPaintMessages; + + { Save the original mouse cursor } + OldCursor := GetCursor; + + SetRectEmpty(MoveRect); + if not UseSmoothDrag then begin + { This uses LockWindowUpdate to suppress all window updating so the + dragging outlines doesn't sometimes get garbled. (This is safe, and in + fact, is the main purpose of the LockWindowUpdate function) + IMPORTANT! While debugging you might want to enable the 'TB2Dock_DisableLock' + conditional define (see top of the source code). } + {$IFNDEF TB2Dock_DisableLock} + LockWindowUpdate(GetDesktopWindow); + {$ENDIF} + { Get a DC of the entire screen. Works around the window update lock + by specifying DCX_LOCKWINDOWUPDATE. } + ScreenDC := GetDCEx(GetDesktopWindow, 0, + DCX_LOCKWINDOWUPDATE or DCX_CACHE or DCX_WINDOW); + end + else + ScreenDC := 0; + try + SetCapture(Handle); + + { Initialize } + StartDocking := Docked; + MouseOverDock := nil; + GetCursorPos(FirstPos); + LastPos := FirstPos; + MouseMoved; + StartDocking := True; + + { Stay in message loop until capture is lost. Capture is removed either + by this procedure manually doing it, or by an outside influence (like + a message box or menu popping up) } + while GetCapture = Handle do begin + case Integer(GetMessage(Msg, 0, 0, 0)) of + -1: Break; { if GetMessage failed } + 0: begin + { Repost WM_QUIT messages } + PostQuitMessage(ClipToLongint(Msg.wParam)); + Break; + end; + end; + + case Msg.Message of + WM_KEYDOWN, WM_KEYUP: + { Ignore all keystrokes while dragging. But process Ctrl and Escape } + case Word(Msg.wParam) of + VK_CONTROL: + if PreventDocking <> (Msg.Message = WM_KEYDOWN) then begin + PreventDocking := Msg.Message = WM_KEYDOWN; + MouseMoved; + end; + VK_ESCAPE: + Break; + end; + WM_MOUSEMOVE: begin + { Note to self: WM_MOUSEMOVE messages should never be dispatched + here to ensure no hints get shown during the drag process } + CurPos := GetMessagePosAsPoint; + if (LastPos.X <> CurPos.X) or (LastPos.Y <> CurPos.Y) then begin + MouseMoved; + LastPos := CurPos; + end; + end; + WM_LBUTTONDOWN, WM_LBUTTONDBLCLK: + { Make sure it doesn't begin another loop } + Break; + WM_LBUTTONUP: begin + Accept := True; + Break; + end; + WM_RBUTTONDOWN..WM_MBUTTONDBLCLK: + { Ignore all other mouse up/down messages } + ; + else + TranslateMessage(Msg); + DispatchMessage(Msg); + end; + end; + finally + { Since it sometimes breaks out of the loop without capture being + released } + if GetCapture = Handle then + ReleaseCapture; + + if not UseSmoothDrag then begin + { Hide dragging outline. Since NT will release a window update lock if + another thread comes to the foreground, it has to release the DC + and get a new one for erasing the dragging outline. Otherwise, + the DrawDraggingOutline appears to have no effect when this happens. } + ReleaseDC(GetDesktopWindow, ScreenDC); + ScreenDC := GetDCEx(GetDesktopWindow, 0, + DCX_LOCKWINDOWUPDATE or DCX_CACHE or DCX_WINDOW); + SetRectEmpty(R); + DrawDraggingOutline(ScreenDC, R, MoveRect, True, MouseOverDock <> nil); + ReleaseDC(GetDesktopWindow, ScreenDC); + + { Release window update lock } + {$IFNDEF TB2Dock_DisableLock} + LockWindowUpdate(0); + {$ENDIF} + end; + end; + + { Move to new position only if MoveRect isn't empty } + FSmoothDragging := False; + if Accept and not IsRectEmpty(MoveRect) then + { Note: Dropped must be called again after FSmoothDragging is reset to + False so that TTBDock.ArrangeToolbars makes the DockPos changes + permanent } + Dropped; + + { LastDock isn't automatically updated while FSmoothDragging=True, so + update it now that it's back to False } + if FUseLastDock and Assigned(CurrentDock) then + LastDock := CurrentDock; + + { To conserve resources, free FFloatParent if it's no longer the Parent. + (SetParent doesn't do this automatically when FSmoothDragging=True.) } + if Assigned(FFloatParent) and (Parent <> FFloatParent) then + FreeAndNil(FFloatParent); + finally + FSmoothDragging := False; + if not Docked then begin + { If we didn't end up docking, restore the original DockRow & DockPos + values } + FDockRow := OriginalDockRow; + FDockPos := OriginalDockPos; + end; + if Assigned(NewDockedSizes) then begin + for I := NewDockedSizes.Count-1 downto 0 do + TDockedSize(NewDockedSizes[I]).Free; + NewDockedSizes.Free; + end; + DockList.Free; + end; + finally + FDragMode := False; + FDragSplitting := False; + end; +end; + +function TTBCustomDockableWindow.ChildControlTransparent(Ctl: TControl): Boolean; +begin + Result := False; +end; + +procedure TTBCustomDockableWindow.ControlExistsAtPos(const P: TPoint; + var ControlExists: Boolean); +var + I: Integer; +begin + for I := 0 to ControlCount-1 do + if not ChildControlTransparent(Controls[I]) and Controls[I].Visible and + PtInRect(Controls[I].BoundsRect, P) then begin + ControlExists := True; + Break; + end; +end; + +procedure TTBCustomDockableWindow.DoubleClick; +begin + if Docked then begin + if DockMode = dmCanFloat then begin + Floating := True; + MoveOnScreen(True); + end; + end + else + if Assigned(LastDock) then + Parent := LastDock + else + if Assigned(DefaultDock) then begin + FDockRow := ForceDockAtTopRow; + FDockPos := ForceDockAtLeftPos; + Parent := DefaultDock; + end; +end; + +function TTBCustomDockableWindow.IsMovable: Boolean; +begin + Result := (Docked and CurrentDock.FAllowDrag) or Floating; +end; + +procedure TTBCustomDockableWindow.MouseDown(Button: TMouseButton; + Shift: TShiftState; X, Y: Integer); +var + P: TPoint; + CtlExists: Boolean; +begin + inherited; + if (Button <> mbLeft) or not IsMovable then + Exit; + { Ignore message if user clicked on a child control } + P := Point(X, Y); + if PtInRect(ClientRect, P) then begin + CtlExists := False; + ControlExistsAtPos(P, CtlExists); + if CtlExists then + Exit; + end; + + if not(ssDouble in Shift) then begin + BeginMoving(X, Y); + MouseUp(mbLeft, [], -1, -1); + end + else + { Handle double click } + DoubleClick; +end; + +procedure TTBCustomDockableWindow.WMNCHitTest(var Message: TWMNCHitTest); +var + P: TPoint; + R: TRect; +begin + inherited; + if Docked then + with Message do begin + P := SmallPointToPoint(Pos); + GetWindowRect(Handle, R); + Dec(P.X, R.Left); Dec(P.Y, R.Top); + if Result <> HTCLIENT then begin + Result := HTNOWHERE; + if FCloseButtonWhenDocked and CurrentDock.FAllowDrag and + PtInRect(GetDockedCloseButtonRect( + TBGetDockTypeOf(CurrentDock, Floating) = dtLeftRight), P) then + Result := HT_TB2k_Close + else + Result := HT_TB2k_Border; + end; + end; +end; + +procedure TTBCustomDockableWindow.WMNCMouseMove(var Message: TWMNCMouseMove); +var + InArea: Boolean; +begin + inherited; + { Note: TME_NONCLIENT was introduced in Windows 98 and 2000 } + if (Win32MajorVersion >= 5) or + (Win32MajorVersion = 4) and (Win32MinorVersion >= 10) then + CallTrackMouseEvent(Handle, TME_LEAVE or $10 {TME_NONCLIENT}); + InArea := (ClipToLongint(Message.HitTest) = HT_TB2k_Close); + if FCloseButtonHover <> InArea then begin + FCloseButtonHover := InArea; + RedrawNCArea; + end; +end; + +procedure TTBCustomDockableWindow.WMNCMouseLeave(var Message: TMessage); +begin + if not MouseCapture then + CancelNCHover; + inherited; +end; + +procedure TTBCustomDockableWindow.CMMouseLeave(var Message: TMessage); +begin + inherited; + { On Windows versions that can't send a WM_NCMOUSELEAVE message, trap + CM_MOUSELEAVE to detect when the mouse moves from the non-client area to + another control. } + CancelNCHover; +end; + +procedure TTBCustomDockableWindow.WMMouseMove(var Message: TWMMouseMove); +begin + { On Windows versions that can't send a WM_NCMOUSELEAVE message, trap + WM_MOUSEMOVE to detect when the mouse moves from the non-client area to + the client area. + Note: We are overriding WM_MOUSEMOVE instead of MouseMove so that our + processing always gets done first. } + CancelNCHover; + inherited; +end; + +procedure TTBCustomDockableWindow.CancelNCHover; +begin + if FCloseButtonHover then begin + FCloseButtonHover := False; + RedrawNCArea; + end; +end; + +procedure TTBCustomDockableWindow.Close; +var + Accept: Boolean; +begin + Accept := True; + if Assigned(FOnCloseQuery) then + FOnCloseQuery(Self, Accept); + { Did the CloseQuery event return True? } + if Accept then begin + Hide; + if Assigned(FOnClose) then + FOnClose(Self); + end; +end; + +procedure TTBCustomDockableWindow.SetCloseButtonState(Pushed: Boolean); +begin + if FCloseButtonDown <> Pushed then begin + FCloseButtonDown := Pushed; + RedrawNCArea; + end; +end; + +procedure TTBCustomDockableWindow.WMNCLButtonDown(var Message: TWMNCLButtonDown); +var + R, BR: TRect; + P: TPoint; +begin + case ClipToLongint(Message.HitTest) of + HT_TB2k_Close: begin + GetWindowRect(Handle, R); + BR := GetDockedCloseButtonRect( + TBGetDockTypeOf(CurrentDock, Floating) = dtLeftRight); + OffsetRect(BR, R.Left, R.Top); + if CloseButtonLoop(Handle, BR, SetCloseButtonState) then + Close; + end; + HT_TB2k_Border: begin + P := ScreenToClient(GetMessagePosAsPoint); + if IsMovable then + BeginMoving(P.X, P.Y); + end; + else + inherited; + end; +end; + +procedure TTBCustomDockableWindow.WMNCLButtonDblClk(var Message: TWMNCLButtonDblClk); +begin + if ClipToLongint(Message.HitTest) = HT_TB2k_Border then begin + if IsMovable then + DoubleClick; + end + else + inherited; +end; + +procedure TTBCustomDockableWindow.ShowNCContextMenu(const PosX, PosY: Smallint); + + {$IFNDEF JR_D5} + { Note: this is identical to TControl.CheckMenuPopup (from Delphi 4), + except where noted. + TControl.CheckMenuPopup is unfortunately 'private', so it can't be called + outside of the Controls unit. } + procedure CheckMenuPopup; + var + Control: TControl; + PopupMenu: TPopupMenu; + begin + if csDesigning in ComponentState then Exit; + Control := Self; + while Control <> nil do + begin + { Added TControlAccess cast because GetPopupMenu is 'protected' } + PopupMenu := TControlAccess(Control).GetPopupMenu; + if (PopupMenu <> nil) then + begin + if not PopupMenu.AutoPopup then Exit; + SendCancelMode(nil); + PopupMenu.PopupComponent := Control; + { Changed the following. LPARAM of WM_NCRBUTTONUP is in screen + coordinates, not client coordinates } + {with ClientToScreen(SmallPointToPoint(Pos)) do + PopupMenu.Popup(X, Y);} + PopupMenu.Popup(PosX, PosY); + Exit; + end; + Control := Control.Parent; + end; + end; + {$ENDIF} + +begin + {$IFDEF JR_D5} + { Delphi 5 and later use the WM_CONTEXTMENU message for popup menus } + SendMessage(Handle, WM_CONTEXTMENU, WPARAM(Handle), MAKELPARAM(Word(PosX), Word(PosY))); + {$ELSE} + CheckMenuPopup; + {$ENDIF} +end; + +procedure TTBCustomDockableWindow.WMNCRButtonUp(var Message: TWMNCRButtonUp); +begin + ShowNCContextMenu(Message.XCursor, Message.YCursor); +end; + +{$IFDEF JR_D5} +procedure TTBCustomDockableWindow.WMContextMenu(var Message: TWMContextMenu); +{ Unfortunately TControl.WMContextMenu ignores clicks in the non-client area. + On docked toolbars, we need right clicks on the border, part of the + non-client area, to display the popup menu. The only way I see to have it do + that is to create a new version of WMContextMenu specifically for the + non-client area, and that is what this method is. + Note: This is identical to Delphi 2006's TControl.WMContextMenu, except where + noted. } +var + Pt, Temp: TPoint; + Handled: Boolean; + PopupMenu: TPopupMenu; +begin + { Added 'inherited;' here } + inherited; + if Message.Result <> 0 then Exit; + if csDesigning in ComponentState then + begin + inherited; + Exit; + end; + + Pt := SmallPointToPoint(Message.Pos); + if InvalidPoint(Pt) then + Temp := Pt + else + begin + Temp := ScreenToClient(Pt); + { Changed the following. We're only interested in the non-client area } + {if not PtInRect(ClientRect, Temp) then} + if PtInRect(ClientRect, Temp) then + begin + {inherited;} + Exit; + end; + end; + + Handled := False; + DoContextPopup(Temp, Handled); + Message.Result := Ord(Handled); + if Handled then Exit; + + PopupMenu := GetPopupMenu; + if (PopupMenu <> nil) and PopupMenu.AutoPopup then + begin + SendCancelMode(Self); + PopupMenu.PopupComponent := Self; + if InvalidPoint(Pt) then + Pt := ClientToScreen(Point(0, 0)); + PopupMenu.Popup(Pt.X, Pt.Y); + Message.Result := 1; + end; + + if Message.Result = 0 then + inherited; +end; +{$ENDIF} + +procedure TTBCustomDockableWindow.GetMinShrinkSize(var AMinimumSize: Integer); +begin +end; + +function TTBCustomDockableWindow.GetFloatingWindowParentClass: TTBFloatingWindowParentClass; +begin + Result := TTBFloatingWindowParent; +end; + +procedure TTBCustomDockableWindow.GetMinMaxSize(var AMinClientWidth, + AMinClientHeight, AMaxClientWidth, AMaxClientHeight: Integer); +begin +end; + +function TTBCustomDockableWindow.GetShrinkMode: TTBShrinkMode; +begin + Result := tbsmNone; +end; + +procedure TTBCustomDockableWindow.ResizeBegin; +begin +end; + +procedure TTBCustomDockableWindow.ResizeTrack(var Rect: TRect; const OrigRect: TRect); +begin +end; + +procedure TTBCustomDockableWindow.ResizeTrackAccept; +begin +end; + +procedure TTBCustomDockableWindow.ResizeEnd; +begin +end; + +procedure TTBCustomDockableWindow.BeginSizing(const ASizeHandle: TTBSizeHandle); +var + UseSmoothDrag, DragX, DragY, ReverseX, ReverseY: Boolean; + MinWidth, MinHeight, MaxWidth, MaxHeight: Integer; + DragRect, OrigDragRect: TRect; + ScreenDC: HDC; + OrigPos, OldPos: TPoint; + + procedure DoResize; + begin + BeginUpdate; + try + ResizeTrackAccept; + Parent.BoundsRect := DragRect; + SetBounds(Left, Top, Parent.ClientWidth, Parent.ClientHeight); + finally + EndUpdate; + end; + + { Make sure it doesn't go completely off the screen } + MoveOnScreen(True); + end; + + procedure MouseMoved; + var + Pos: TPoint; + OldDragRect: TRect; + begin + GetCursorPos(Pos); + { It needs to check if the cursor actually moved since last time. This is + because a call to LockWindowUpdate (apparently) generates a mouse move + message even when mouse hasn't moved. } + if (Pos.X = OldPos.X) and (Pos.Y = OldPos.Y) then Exit; + OldPos := Pos; + + OldDragRect := DragRect; + DragRect := OrigDragRect; + if DragX then begin + if not ReverseX then Inc(DragRect.Right, Pos.X-OrigPos.X) + else Inc(DragRect.Left, Pos.X-OrigPos.X); + end; + if DragY then begin + if not ReverseY then Inc(DragRect.Bottom, Pos.Y-OrigPos.Y) + else Inc(DragRect.Top, Pos.Y-OrigPos.Y); + end; + if DragRect.Right-DragRect.Left < MinWidth then begin + if not ReverseX then DragRect.Right := DragRect.Left + MinWidth + else DragRect.Left := DragRect.Right - MinWidth; + end; + if (MaxWidth > 0) and (DragRect.Right-DragRect.Left > MaxWidth) then begin + if not ReverseX then DragRect.Right := DragRect.Left + MaxWidth + else DragRect.Left := DragRect.Right - MaxWidth; + end; + if DragRect.Bottom-DragRect.Top < MinHeight then begin + if not ReverseY then DragRect.Bottom := DragRect.Top + MinHeight + else DragRect.Top := DragRect.Bottom - MinHeight; + end; + if (MaxHeight > 0) and (DragRect.Bottom-DragRect.Top > MaxHeight) then begin + if not ReverseY then DragRect.Bottom := DragRect.Top + MaxHeight + else DragRect.Top := DragRect.Bottom - MaxHeight; + end; + + ResizeTrack(DragRect, OrigDragRect); + if not UseSmoothDrag then + DrawDraggingOutline(ScreenDC, DragRect, OldDragRect, False, False) + else + DoResize; + end; +var + Accept: Boolean; + Msg: TMsg; + R: TRect; +begin + if not Floating then Exit; + + Accept := False; + + UseSmoothDrag := FSmoothDrag; + + MinWidth := 0; + MinHeight := 0; + MaxWidth := 0; + MaxHeight := 0; + GetMinMaxSize(MinWidth, MinHeight, MaxWidth, MaxHeight); + Inc(MinWidth, Parent.Width-Width); + Inc(MinHeight, Parent.Height-Height); + if MaxWidth > 0 then + Inc(MaxWidth, Parent.Width-Width); + if MaxHeight > 0 then + Inc(MaxHeight, Parent.Height-Height); + + DragX := ASizeHandle in [twshLeft, twshRight, twshTopLeft, twshTopRight, + twshBottomLeft, twshBottomRight]; + ReverseX := ASizeHandle in [twshLeft, twshTopLeft, twshBottomLeft]; + DragY := ASizeHandle in [twshTop, twshTopLeft, twshTopRight, twshBottom, + twshBottomLeft, twshBottomRight]; + ReverseY := ASizeHandle in [twshTop, twshTopLeft, twshTopRight]; + + ResizeBegin(ASizeHandle); + try + { Before locking, make sure all pending paint messages are processed } + ProcessPaintMessages; + + if not UseSmoothDrag then begin + { This uses LockWindowUpdate to suppress all window updating so the + dragging outlines doesn't sometimes get garbled. (This is safe, and in + fact, is the main purpose of the LockWindowUpdate function) + IMPORTANT! While debugging you might want to enable the 'TB2Dock_DisableLock' + conditional define (see top of the source code). } + {$IFNDEF TB2Dock_DisableLock} + LockWindowUpdate(GetDesktopWindow); + {$ENDIF} + { Get a DC of the entire screen. Works around the window update lock + by specifying DCX_LOCKWINDOWUPDATE. } + ScreenDC := GetDCEx(GetDesktopWindow, 0, + DCX_LOCKWINDOWUPDATE or DCX_CACHE or DCX_WINDOW); + end + else + ScreenDC := 0; + try + SetCapture(Handle); + if (tbdsResizeClipCursor in FDockableWindowStyles) and + not UsingMultipleMonitors then begin + R := GetRectOfPrimaryMonitor(False); + ClipCursor({$IFNDEF CLR}@{$ENDIF} R); + end; + + { Initialize } + OrigDragRect := Parent.BoundsRect; + DragRect := OrigDragRect; + if not UseSmoothDrag then begin + SetRectEmpty(R); + DrawDraggingOutline(ScreenDC, DragRect, R, False, False); + end; + GetCursorPos(OrigPos); + OldPos := OrigPos; + + { Stay in message loop until capture is lost. Capture is removed either + by this procedure manually doing it, or by an outside influence (like + a message box or menu popping up) } + while GetCapture = Handle do begin + case Integer(GetMessage(Msg, 0, 0, 0)) of + -1: Break; { if GetMessage failed } + 0: begin + { Repost WM_QUIT messages } + PostQuitMessage(ClipToLongint(Msg.wParam)); + Break; + end; + end; + + case Msg.Message of + WM_KEYDOWN, WM_KEYUP: + { Ignore all keystrokes while sizing except for Escape } + if Word(Msg.wParam) = VK_ESCAPE then + Break; + WM_MOUSEMOVE: + { Note to self: WM_MOUSEMOVE messages should never be dispatched + here to ensure no hints get shown during the drag process } + MouseMoved; + WM_LBUTTONDOWN, WM_LBUTTONDBLCLK: + { Make sure it doesn't begin another loop } + Break; + WM_LBUTTONUP: begin + Accept := True; + Break; + end; + WM_RBUTTONDOWN..WM_MBUTTONDBLCLK: + { Ignore all other mouse up/down messages } + ; + else + TranslateMessage(Msg); + DispatchMessage(Msg); + end; + end; + finally + { Since it sometimes breaks out of the loop without capture being + released } + if GetCapture = Handle then + ReleaseCapture; + ClipCursor(nil); + + if not UseSmoothDrag then begin + { Hide dragging outline. Since NT will release a window update lock if + another thread comes to the foreground, it has to release the DC + and get a new one for erasing the dragging outline. Otherwise, + the DrawDraggingOutline appears to have no effect when this happens. } + ReleaseDC(GetDesktopWindow, ScreenDC); + ScreenDC := GetDCEx(GetDesktopWindow, 0, + DCX_LOCKWINDOWUPDATE or DCX_CACHE or DCX_WINDOW); + SetRectEmpty(R); + DrawDraggingOutline(ScreenDC, R, DragRect, False, False); + ReleaseDC(GetDesktopWindow, ScreenDC); + + { Release window update lock } + {$IFNDEF TB2Dock_DisableLock} + LockWindowUpdate(0); + {$ENDIF} + end; + end; + + if not UseSmoothDrag and Accept then + DoResize; + finally + ResizeEnd; + end; +end; + +procedure TTBCustomDockableWindow.DoDockChangingHidden(NewFloating: Boolean; + DockingTo: TTBDock); +begin + if not(csDestroying in ComponentState) and Assigned(FOnDockChangingHidden) then + FOnDockChangingHidden(Self, NewFloating, DockingTo); +end; + +{ TTBCustomDockableWindow - property access methods } + +function TTBCustomDockableWindow.GetNonClientWidth: Integer; +begin + Result := CalcNCSizes.X; +end; + +function TTBCustomDockableWindow.GetNonClientHeight: Integer; +begin + Result := CalcNCSizes.Y; +end; + +function TTBCustomDockableWindow.IsLastDockStored: Boolean; +begin + Result := FCurrentDock = nil; {}{should this be changed to 'Floating'?} +end; + +function TTBCustomDockableWindow.IsWidthAndHeightStored: Boolean; +begin + Result := (CurrentDock = nil) and not Floating; +end; + +procedure TTBCustomDockableWindow.SetCloseButton(Value: Boolean); +begin + if FCloseButton <> Value then begin + FCloseButton := Value; + + { Update the close button's visibility } + if Parent is TTBFloatingWindowParent then + TTBFloatingWindowParent(Parent).RedrawNCArea([twrdCaption, twrdCloseButton]); + end; +end; + +procedure TTBCustomDockableWindow.SetCloseButtonWhenDocked(Value: Boolean); +begin + if FCloseButtonWhenDocked <> Value then begin + FCloseButtonWhenDocked := Value; + if Docked then + RecalcNCArea(Self); + end; +end; + +procedure TTBCustomDockableWindow.SetDefaultDock(Value: TTBDock); +begin + if FDefaultDock <> Value then begin + FDefaultDock := Value; + if Assigned(Value) then + Value.FreeNotification(Self); + end; +end; + +procedure TTBCustomDockableWindow.SetCurrentDock(Value: TTBDock); +begin + if not(csLoading in ComponentState) then begin + if Assigned(Value) then + Parent := Value + else + Parent := TBValidToolWindowParentForm(Self); + end; +end; + +procedure TTBCustomDockableWindow.SetDockPos(Value: Integer); +begin + FDockPos := Value; + if Docked then + CurrentDock.ArrangeToolbars; +end; + +procedure TTBCustomDockableWindow.SetDockRow(Value: Integer); +begin + FDockRow := Value; + if Docked then + CurrentDock.ArrangeToolbars; +end; + +procedure TTBCustomDockableWindow.SetAutoResize(Value: Boolean); +begin + if FAutoResize <> Value then begin + FAutoResize := Value; + if Value then + Arrange; + end; +end; + +procedure TTBCustomDockableWindow.SetBorderStyle(Value: TBorderStyle); +begin + if FBorderStyle <> Value then begin + FBorderStyle := Value; + if Docked then + RecalcNCArea(Self); + end; +end; + +procedure TTBCustomDockableWindow.SetDragHandleStyle(Value: TTBDragHandleStyle); +begin + if FDragHandleStyle <> Value then begin + FDragHandleStyle := Value; + if Docked then + RecalcNCArea(Self); + end; +end; + +procedure TTBCustomDockableWindow.SetFloating(Value: Boolean); +var + ParentFrm: TTBCustomForm; + NewFloatParent: TTBFloatingWindowParent; +begin + if FFloating <> Value then begin + if Value and not(csDesigning in ComponentState) then begin + ParentFrm := TBValidToolWindowParentForm(Self); + if FFloatParent = nil then begin + NewFloatParent := GetFloatingWindowParentClass.CreateNew(nil); + try + with NewFloatParent do begin + FDockableWindow := Self; + BorderStyle := bsToolWindow; + ShowHint := True; + Visible := True; + { Note: The above line doesn't actually make it visible at this + point since FShouldShow is still False. } + end; + except + NewFloatParent.Free; + raise; + end; + FFloatParent := NewFloatParent; + end; + ParentFrm.FreeNotification(FFloatParent); + FFloatParent.FParentForm := ParentFrm; + FFloatParent.Caption := Caption; + Parent := FFloatParent; + SetBounds(0, 0, Width, Height); + end + else + Parent := TBValidToolWindowParentForm(Self); + end; +end; + +procedure TTBCustomDockableWindow.SetFloatingMode(Value: TTBFloatingMode); +begin + if FFloatingMode <> Value then begin + FFloatingMode := Value; + if HandleAllocated then + Perform(CM_SHOWINGCHANGED, 0, 0); + end; +end; + +procedure TTBCustomDockableWindow.SetFloatingPosition(Value: TPoint); +begin + FFloatingPosition := Value; + if Floating and Assigned(Parent) then + Parent.SetBounds(Value.X, Value.Y, Parent.Width, Parent.Height); +end; + +procedure TTBCustomDockableWindow.SetFullSize(Value: Boolean); +begin + if FFullSize <> Value then begin + FFullSize := Value; + if Docked then + CurrentDock.ArrangeToolbars; + end; +end; + +procedure TTBCustomDockableWindow.SetLastDock(Value: TTBDock); +begin + if FUseLastDock and Assigned(FCurrentDock) then + { When docked, LastDock must be equal to DockedTo } + Value := FCurrentDock; + if FLastDock <> Value then begin + if Assigned(FLastDock) and (FLastDock <> Parent) then + FLastDock.ChangeDockList(False, Self); + FLastDock := Value; + if Assigned(Value) then begin + FUseLastDock := True; + Value.FreeNotification(Self); + Value.ChangeDockList(True, Self); + end; + end; +end; + +procedure TTBCustomDockableWindow.SetResizable(Value: Boolean); +begin + if FResizable <> Value then begin + FResizable := Value; + if Floating and (Parent is TTBFloatingWindowParent) then begin + { Recreate the window handle because Resizable affects whether the + tool window is created with a WS_THICKFRAME style } + TTBFloatingWindowParent(Parent).CallRecreateWnd; + end; + end; +end; + +procedure TTBCustomDockableWindow.SetShowCaption(Value: Boolean); +begin + if FShowCaption <> Value then begin + FShowCaption := Value; + if Floating then begin + { Recalculate FloatingWindowParent's NC area, and resize the toolbar + accordingly } + RecalcNCArea(Parent); + Arrange; + end; + end; +end; + +procedure TTBCustomDockableWindow.SetStretch(Value: Boolean); +begin + if FStretch <> Value then begin + FStretch := Value; + if Docked then + CurrentDock.ArrangeToolbars; + end; +end; + +procedure TTBCustomDockableWindow.SetUseLastDock(Value: Boolean); +begin + if FUseLastDock <> Value then begin + FUseLastDock := Value; + if not Value then + LastDock := nil + else + LastDock := FCurrentDock; + end; +end; + +(*function TTBCustomDockableWindow.GetVersion: TToolbar97Version; +begin + Result := Toolbar97VersionPropText; +end; + +procedure TTBCustomDockableWindow.SetVersion(const Value: TToolbar97Version); +begin + { write method required for the property to show up in Object Inspector } +end;*) + + +{ TTBBackground } + +{$IFNDEF CLR} +type + PNotifyEvent = ^TNotifyEvent; +{$ENDIF} + +constructor TTBBackground.Create(AOwner: TComponent); +begin + inherited; + FBkColor := clBtnFace; + FBitmap := TBitmap.Create; + FBitmap.OnChange := BitmapChanged; +end; + +destructor TTBBackground.Destroy; +{$IFNDEF CLR} +var + I: Integer; +{$ENDIF} +begin + inherited; + FBitmapCache.Free; + FBitmap.Free; + if Assigned(FNotifyList) then begin + {$IFNDEF CLR} + for I := FNotifyList.Count-1 downto 0 do + Dispose(PNotifyEvent(FNotifyList[I])); + {$ENDIF} + FNotifyList.Free; + end; +end; + +procedure TTBBackground.BitmapChanged(Sender: TObject); +var + I: Integer; +begin + { Erase the cache and notify } + FreeAndNil(FBitmapCache); + if Assigned(FNotifyList) then + for I := 0 to FNotifyList.Count-1 do + {$IFNDEF CLR} + PNotifyEvent(FNotifyList[I])^(Self); + {$ELSE} + TNotifyEvent(FNotifyList[I])(Self); + {$ENDIF} +end; + +procedure TTBBackground.Draw(DC: HDC; const DrawRect: TRect); +var + UseBmp: TBitmap; + R2: TRect; + SaveIndex: Integer; + DC2: HDC; + Brush: HBRUSH; + P: TPoint; +begin + if FBitmapCache = nil then begin + FBitmapCache := TBitmap.Create; + FBitmapCache.Palette := CopyPalette(FBitmap.Palette); + FBitmapCache.Width := FBitmap.Width; + FBitmapCache.Height := FBitmap.Height; + if not FTransparent then begin + { Copy from a possible DIB to our DDB } + BitBlt(FBitmapCache.Canvas.Handle, 0, 0, FBitmapCache.Width, + FBitmapCache.Height, FBitmap.Canvas.Handle, 0, 0, SRCCOPY); + end + else begin + with FBitmapCache do begin + Canvas.Brush.Color := FBkColor; + R2 := Rect(0, 0, Width, Height); + Canvas.BrushCopy(R2, FBitmap, R2, + FBitmap.Canvas.Pixels[0, Height-1] or $02000000); + end; + end; + FBitmap.Dormant; + end; + UseBmp := FBitmapCache; + + DC2 := 0; + SaveIndex := SaveDC(DC); + try + if UseBmp.Palette <> 0 then begin + SelectPalette(DC, UseBmp.Palette, True); + RealizePalette(DC); + end; + { Note: versions of Toolbar97 prior to 1.68 used 'UseBmp.Canvas.Handle' + instead of DC2 in the BitBlt call. This was changed because there + seems to be a bug in D2/BCB1's Graphics.pas: if you called + .Background.LoadFromFile() twice the background + would not be shown. } + if (UseBmp.Width = 8) and (UseBmp.Height = 8) then begin + { Use pattern brushes to draw 8x8 bitmaps. + Note: Win9x can't use bitmaps <8x8 in size for pattern brushes } + Brush := CreatePatternBrush(UseBmp.Handle); + GetWindowOrgEx(DC, P); + SetBrushOrgEx(DC, DrawRect.Left - P.X, DrawRect.Top - P.Y, nil); + FillRect(DC, DrawRect, Brush); + DeleteObject(Brush); + end + else begin + { BitBlt is faster than pattern brushes on large bitmaps } + DC2 := CreateCompatibleDC(DC); + SelectObject(DC2, UseBmp.Handle); + R2 := DrawRect; + while R2.Left < R2.Right do begin + while R2.Top < R2.Bottom do begin + BitBlt(DC, R2.Left, R2.Top, UseBmp.Width, UseBmp.Height, + DC2, 0, 0, SRCCOPY); + Inc(R2.Top, UseBmp.Height); + end; + R2.Top := DrawRect.Top; + Inc(R2.Left, UseBmp.Width); + end; + end; + finally + if DC2 <> 0 then + DeleteDC(DC2); + { Restore the palette and brush origin back } + RestoreDC(DC, SaveIndex); + end; +end; + +function TTBBackground.GetPalette: HPALETTE; +begin + Result := FBitmap.Palette; +end; + +procedure TTBBackground.SysColorChanged; +begin + if FTransparent and (FBkColor < 0) then + BitmapChanged(nil); +end; + +function TTBBackground.UsingBackground: Boolean; +begin + Result := (FBitmap.Width <> 0) and (FBitmap.Height <> 0); +end; + +procedure TTBBackground.RegisterChanges(Proc: TNotifyEvent); +var + I: Integer; + {$IFNDEF CLR} + P: PNotifyEvent; + {$ENDIF} +begin + if FNotifyList = nil then + FNotifyList := TList.Create; + for I := 0 to FNotifyList.Count-1 do begin + {$IFNDEF CLR} + P := FNotifyList[I]; + if MethodsEqual(TMethod(P^), TMethod(Proc)) then + {$ELSE} + if @TNotifyEvent(FNotifyList[I]) = @Proc then + {$ENDIF} + Exit; + end; + {$IFNDEF CLR} + FNotifyList.Expand; + New(P); + P^ := Proc; + FNotifyList.Add(P); + {$ELSE} + FNotifyList.Add(@Proc); + {$ENDIF} +end; + +procedure TTBBackground.UnregisterChanges(Proc: TNotifyEvent); +var + I: Integer; + {$IFNDEF CLR} + P: PNotifyEvent; + {$ENDIF} +begin + if FNotifyList = nil then + Exit; + for I := 0 to FNotifyList.Count-1 do begin + {$IFNDEF CLR} + P := FNotifyList[I]; + if MethodsEqual(TMethod(P^), TMethod(Proc)) then begin + {$ELSE} + if @TNotifyEvent(FNotifyList[I]) = @Proc then begin + {$ENDIF} + FNotifyList.Delete(I); + {$IFNDEF CLR} + Dispose(P); + {$ENDIF} + Break; + end; + end; +end; + +procedure TTBBackground.SetBkColor(Value: TColor); +begin + if FBkColor <> Value then begin + FBkColor := Value; + if FTransparent then + BitmapChanged(nil); + end; +end; + +procedure TTBBackground.SetBitmap(Value: TBitmap); +begin + FBitmap.Assign(Value); +end; + +procedure TTBBackground.SetTransparent(Value: Boolean); +begin + if FTransparent <> Value then begin + FTransparent := Value; + BitmapChanged(nil); + end; +end; + + +{ Global procedures } + +procedure TBCustomLoadPositions(const OwnerComponent: TComponent; + const ReadIntProc: TTBPositionReadIntProc; + const ReadStringProc: TTBPositionReadStringProc; + const ExtraData: TTBPositionExtraData); +var + Rev: Integer; + + function FindDock(AName: String): TTBDock; + var + I: Integer; + begin + Result := nil; + for I := 0 to OwnerComponent.ComponentCount-1 do + if (OwnerComponent.Components[I] is TTBDock) and + {$IFNDEF CLR} + (CompareText(OwnerComponent.Components[I].Name, AName) = 0) then begin + {$ELSE} + SameText(OwnerComponent.Components[I].Name, AName, loInvariantLocale) then begin + {$ENDIF} + Result := TTBDock(OwnerComponent.Components[I]); + Break; + end; + end; + + procedure ReadValues(const Toolbar: TTBCustomDockableWindow; const NewDock: TTBDock); + var + Pos: TPoint; + Data: TTBReadPositionData; + LastDockName: String; + ADock: TTBDock; + begin + with Toolbar do begin + DockRow := ReadIntProc(Name, rvDockRow, DockRow, ExtraData); + DockPos := ReadIntProc(Name, rvDockPos, DockPos, ExtraData); + Pos.X := ReadIntProc(Name, rvFloatLeft, 0, ExtraData); + Pos.Y := ReadIntProc(Name, rvFloatTop, 0, ExtraData); + Data.ReadIntProc := ReadIntProc; + Data.ReadStringProc := ReadStringProc; + Data.ExtraData := ExtraData; + ReadPositionData(Data); + FloatingPosition := Pos; + if Assigned(NewDock) then + Parent := NewDock + else begin + //Parent := Form; + Floating := True; + MoveOnScreen(True); + if (Rev >= 3) and FUseLastDock then begin + LastDockName := ReadStringProc(Name, rvLastDock, '', ExtraData); + if LastDockName <> '' then begin + ADock := FindDock(LastDockName); + if Assigned(ADock) then + LastDock := ADock; + end; + end; + end; + Arrange; + DoneReadingPositionData(Data); + end; + end; + +var + DocksDisabled: TList; + I: Integer; + ToolWindow: TComponent; + ADock: TTBDock; + DockedToName: String; +begin + DocksDisabled := TList.Create; + try + with OwnerComponent do + for I := 0 to ComponentCount-1 do + if Components[I] is TTBDock then begin + TTBDock(Components[I]).BeginUpdate; + DocksDisabled.Add(Components[I]); + end; + + for I := 0 to OwnerComponent.ComponentCount-1 do begin + ToolWindow := OwnerComponent.Components[I]; + if ToolWindow is TTBCustomDockableWindow then + with TTBCustomDockableWindow(ToolWindow) do begin + {}{should skip over toolbars that are neither Docked nor Floating } + if Name = '' then + Continue; + Rev := ReadIntProc(Name, rvRev, 0, ExtraData); + if Rev = 2000 then begin + Visible := ReadIntProc(Name, rvVisible, Ord(Visible), ExtraData) <> 0; + DockedToName := ReadStringProc(Name, rvDockedTo, '', ExtraData); + if DockedToName <> '' then begin + if DockedToName <> rdDockedToFloating then begin + ADock := FindDock(DockedToName); + if (ADock <> nil) and (ADock.FAllowDrag) then + ReadValues(TTBCustomDockableWindow(ToolWindow), ADock); + end + else + ReadValues(TTBCustomDockableWindow(ToolWindow), nil); + end; + end; + end; + end; + finally + for I := DocksDisabled.Count-1 downto 0 do + TTBDock(DocksDisabled[I]).EndUpdate; + DocksDisabled.Free; + end; +end; + +procedure TBCustomSavePositions(const OwnerComponent: TComponent; + const WriteIntProc: TTBPositionWriteIntProc; + const WriteStringProc: TTBPositionWriteStringProc; + const ExtraData: TTBPositionExtraData); +var + I: Integer; + N, L: String; + Data: TTBWritePositionData; +begin + for I := 0 to OwnerComponent.ComponentCount-1 do + if OwnerComponent.Components[I] is TTBCustomDockableWindow then + with TTBCustomDockableWindow(OwnerComponent.Components[I]) do begin + if Name = '' then + Continue; + if Floating then + N := rdDockedToFloating + else if Docked then begin + if CurrentDock.FAllowDrag then begin + N := CurrentDock.Name; + if N = '' then + raise Exception.Create(STBToolwinDockedToNameNotSet); + end + else + N := ''; + end + else + Continue; { skip if it's neither floating nor docked } + L := ''; + if Assigned(FLastDock) then + L := FLastDock.Name; + WriteIntProc(Name, rvRev, rdCurrentRev, ExtraData); + WriteIntProc(Name, rvVisible, Ord(Visible), ExtraData); + WriteStringProc(Name, rvDockedTo, N, ExtraData); + WriteStringProc(Name, rvLastDock, L, ExtraData); + WriteIntProc(Name, rvDockRow, FDockRow, ExtraData); + WriteIntProc(Name, rvDockPos, FDockPos, ExtraData); + WriteIntProc(Name, rvFloatLeft, FFloatingPosition.X, ExtraData); + WriteIntProc(Name, rvFloatTop, FFloatingPosition.Y, ExtraData); + Data.WriteIntProc := WriteIntProc; + Data.WriteStringProc := WriteStringProc; + Data.ExtraData := ExtraData; + WritePositionData(Data); + end; +end; + +type + TIniReadWriteData = class + private + IniFile: TCustomIniFile; + SectionNamePrefix: String; + end; + +function IniReadInt(const ToolbarName, Value: String; const Default: Longint; + const ExtraData: TTBPositionExtraData): Longint; +begin + Result := TIniReadWriteData(ExtraData).IniFile.ReadInteger( + TIniReadWriteData(ExtraData).SectionNamePrefix + ToolbarName, Value, Default); +end; +function IniReadString(const ToolbarName, Value, Default: String; + const ExtraData: TTBPositionExtraData): String; +begin + Result := TIniReadWriteData(ExtraData).IniFile.ReadString( + TIniReadWriteData(ExtraData).SectionNamePrefix + ToolbarName, Value, Default); +end; +procedure IniWriteInt(const ToolbarName, Value: String; const Data: Longint; + const ExtraData: TTBPositionExtraData); +begin + TIniReadWriteData(ExtraData).IniFile.WriteInteger( + TIniReadWriteData(ExtraData).SectionNamePrefix + ToolbarName, Value, Data); +end; +procedure IniWriteString(const ToolbarName, Value, Data: String; + const ExtraData: TTBPositionExtraData); +begin + TIniReadWriteData(ExtraData).IniFile.WriteString( + TIniReadWriteData(ExtraData).SectionNamePrefix + ToolbarName, Value, Data); +end; + +procedure TBIniLoadPositions(const OwnerComponent: TComponent; + const IniFile: TCustomIniFile; const SectionNamePrefix: String); +var + Data: TIniReadWriteData; +begin + Data := TIniReadWriteData.Create; + try + Data.IniFile := IniFile; + Data.SectionNamePrefix := SectionNamePrefix; + TBCustomLoadPositions(OwnerComponent, IniReadInt, IniReadString, Data); + finally + Data.Free; + end; +end; + +procedure TBIniLoadPositions(const OwnerComponent: TComponent; + const Filename, SectionNamePrefix: String); +var + IniFile: TIniFile; +begin + IniFile := TIniFile.Create(Filename); + try + TBIniLoadPositions(OwnerComponent, IniFile, SectionNamePrefix); + finally + IniFile.Free; + end; +end; + +procedure TBIniSavePositions(const OwnerComponent: TComponent; + const IniFile: TCustomIniFile; const SectionNamePrefix: String); +var + Data: TIniReadWriteData; +begin + Data := TIniReadWriteData.Create; + try + Data.IniFile := IniFile; + Data.SectionNamePrefix := SectionNamePrefix; + TBCustomSavePositions(OwnerComponent, IniWriteInt, IniWriteString, Data); + finally + Data.Free; + end; +end; + +procedure TBIniSavePositions(const OwnerComponent: TComponent; + const Filename, SectionNamePrefix: String); +var + IniFile: TIniFile; +begin + IniFile := TIniFile.Create(Filename); + try + TBIniSavePositions(OwnerComponent, IniFile, SectionNamePrefix); + finally + IniFile.Free; + end; +end; + +function RegReadInt(const ToolbarName, Value: String; const Default: Longint; + const ExtraData: TTBPositionExtraData): Longint; +begin + Result := TRegIniFile(ExtraData).ReadInteger(ToolbarName, Value, Default); +end; +function RegReadString(const ToolbarName, Value, Default: String; + const ExtraData: TTBPositionExtraData): String; +begin + Result := TRegIniFile(ExtraData).ReadString(ToolbarName, Value, Default); +end; +procedure RegWriteInt(const ToolbarName, Value: String; const Data: Longint; + const ExtraData: TTBPositionExtraData); +begin + TRegIniFile(ExtraData).WriteInteger(ToolbarName, Value, Data); +end; +procedure RegWriteString(const ToolbarName, Value, Data: String; + const ExtraData: TTBPositionExtraData); +begin + TRegIniFile(ExtraData).WriteString(ToolbarName, Value, Data); +end; + +procedure TBRegLoadPositions(const OwnerComponent: TComponent; + const RootKey: DWORD; const BaseRegistryKey: String); +var + Reg: TRegIniFile; +begin + Reg := TRegIniFile.Create(''); + try + {$IFDEF JR_D5} + Reg.Access := KEY_QUERY_VALUE; + {$ENDIF} + Reg.RootKey := RootKey; + if Reg.OpenKey(BaseRegistryKey, False) then + TBCustomLoadPositions(OwnerComponent, RegReadInt, RegReadString, Reg); + finally + Reg.Free; + end; +end; + +procedure TBRegSavePositions(const OwnerComponent: TComponent; + const RootKey: DWORD; const BaseRegistryKey: String); +var + Reg: TRegIniFile; +begin + Reg := TRegIniFile.Create(''); + try + Reg.RootKey := RootKey; + Reg.CreateKey(BaseRegistryKey); + if Reg.OpenKey(BaseRegistryKey, True) then + TBCustomSavePositions(OwnerComponent, RegWriteInt, RegWriteString, Reg); + finally + Reg.Free; + end; +end; + +end. diff --git a/internal/2.2.2/1/Source/TB2DsgnConvertOptions.dfm b/internal/2.2.2/1/Source/TB2DsgnConvertOptions.dfm new file mode 100644 index 0000000..9d5ad45 Binary files /dev/null and b/internal/2.2.2/1/Source/TB2DsgnConvertOptions.dfm differ diff --git a/internal/2.2.2/1/Source/TB2DsgnConvertOptions.dfm.txt b/internal/2.2.2/1/Source/TB2DsgnConvertOptions.dfm.txt new file mode 100644 index 0000000..a1b062f --- /dev/null +++ b/internal/2.2.2/1/Source/TB2DsgnConvertOptions.dfm.txt @@ -0,0 +1,65 @@ +object TBConvertOptionsForm: TTBConvertOptionsForm + Left = 225 + Top = 133 + BorderIcons = [biSystemMenu, biMinimize] + BorderStyle = bsDialog + Caption = 'Convert Menu' + ClientHeight = 90 + ClientWidth = 249 + Color = clBtnFace + Font.Charset = DEFAULT_CHARSET + Font.Color = clWindowText + Font.Height = -11 + Font.Name = 'MS Sans Serif' + Font.Style = [] + OldCreateOrder = False + Position = poScreenCenter + PixelsPerInch = 96 + TextHeight = 13 + object Label1: TLabel + Left = 8 + Top = 8 + Width = 81 + Height = 13 + Caption = '&Menu to convert:' + FocusControl = MenuCombo + end + object MenuCombo: TComboBox + Left = 8 + Top = 24 + Width = 233 + Height = 21 + Style = csDropDownList + ItemHeight = 13 + TabOrder = 0 + end + object ConvertButton: TButton + Left = 8 + Top = 57 + Width = 73 + Height = 23 + Caption = '&Convert' + Default = True + ModalResult = 1 + TabOrder = 1 + end + object HelpButton: TButton + Left = 168 + Top = 57 + Width = 73 + Height = 23 + Caption = '&Help' + TabOrder = 2 + OnClick = HelpButtonClick + end + object Button1: TButton + Left = 88 + Top = 57 + Width = 73 + Height = 23 + Cancel = True + Caption = 'Cancel' + ModalResult = 2 + TabOrder = 3 + end +end diff --git a/internal/2.2.2/1/Source/TB2DsgnConvertOptions.pas b/internal/2.2.2/1/Source/TB2DsgnConvertOptions.pas new file mode 100644 index 0000000..5c47a46 --- /dev/null +++ b/internal/2.2.2/1/Source/TB2DsgnConvertOptions.pas @@ -0,0 +1,67 @@ +unit TB2DsgnConvertOptions; + +{ + Toolbar2000 + Copyright (C) 1998-2005 by Jordan Russell + All rights reserved. + + The contents of this file are subject to the "Toolbar2000 License"; you may + not use or distribute this file except in compliance with the + "Toolbar2000 License". A copy of the "Toolbar2000 License" may be found in + TB2k-LICENSE.txt or at: + http://www.jrsoftware.org/files/tb2k/TB2k-LICENSE.txt + + Alternatively, the contents of this file may be used under the terms of the + GNU General Public License (the "GPL"), in which case the provisions of the + GPL are applicable instead of those in the "Toolbar2000 License". A copy of + the GPL may be found in GPL-LICENSE.txt or at: + http://www.jrsoftware.org/files/tb2k/GPL-LICENSE.txt + If you wish to allow use of your version of this file only under the terms of + the GPL and not to allow others to use your version of this file under the + "Toolbar2000 License", indicate your decision by deleting the provisions + above and replace them with the notice and other provisions required by the + GPL. If you do not delete the provisions above, a recipient may use your + version of this file under either the "Toolbar2000 License" or the GPL. + + $jrsoftware: tb2k/Source/TB2DsgnConvertOptions.pas,v 1.6 2005/01/06 03:56:50 jr Exp $ +} + +interface + +uses + Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs, + StdCtrls; + +type + TTBConvertOptionsForm = class(TForm) + MenuCombo: TComboBox; + Label1: TLabel; + ConvertButton: TButton; + HelpButton: TButton; + Button1: TButton; + procedure HelpButtonClick(Sender: TObject); + private + { Private declarations } + public + { Public declarations } + end; + +implementation + +{$R *.DFM} + +procedure TTBConvertOptionsForm.HelpButtonClick(Sender: TObject); +const + SMsg1 = 'This will import the contents of a TMainMenu or TPopupMenu ' + + 'component on the form.'#13#10#13#10 + + 'The new items will take the names of the old menu ' + + 'items. The old menu items will have "_OLD" appended to the end of ' + + 'their names.'#13#10#13#10 + + 'After the conversion process completes, you should verify that ' + + 'everything was copied correctly. Afterward, you may delete the ' + + 'old menu component.'; +begin + Application.MessageBox(SMsg1, 'Convert Help', MB_OK or MB_ICONINFORMATION); +end; + +end. diff --git a/internal/2.2.2/1/Source/TB2DsgnConverter.dfm b/internal/2.2.2/1/Source/TB2DsgnConverter.dfm new file mode 100644 index 0000000..f684c17 Binary files /dev/null and b/internal/2.2.2/1/Source/TB2DsgnConverter.dfm differ diff --git a/internal/2.2.2/1/Source/TB2DsgnConverter.dfm.txt b/internal/2.2.2/1/Source/TB2DsgnConverter.dfm.txt new file mode 100644 index 0000000..7d2cbaf --- /dev/null +++ b/internal/2.2.2/1/Source/TB2DsgnConverter.dfm.txt @@ -0,0 +1,51 @@ +object TBConverterForm: TTBConverterForm + Left = 200 + Top = 104 + AutoScroll = False + Caption = 'Conversion Status' + ClientHeight = 218 + ClientWidth = 425 + Color = clBtnFace + Font.Charset = DEFAULT_CHARSET + Font.Color = clWindowText + Font.Height = -11 + Font.Name = 'MS Sans Serif' + Font.Style = [] + OldCreateOrder = True + Position = poScreenCenter + OnClose = FormClose + PixelsPerInch = 96 + TextHeight = 13 + object MessageList: TListBox + Left = 8 + Top = 8 + Width = 409 + Height = 169 + Anchors = [akLeft, akTop, akRight, akBottom] + ItemHeight = 13 + TabOrder = 0 + end + object CloseButton: TButton + Left = 176 + Top = 185 + Width = 73 + Height = 23 + Anchors = [akRight, akBottom] + Cancel = True + Caption = '&Close' + Enabled = False + TabOrder = 1 + OnClick = CloseButtonClick + end + object CopyButton: TButton + Left = 256 + Top = 185 + Width = 161 + Height = 23 + Anchors = [akRight, akBottom] + Caption = 'C&opy Messages to Clipboard' + Enabled = False + TabOrder = 2 + OnClick = CopyButtonClick + end +end diff --git a/internal/2.2.2/1/Source/TB2DsgnConverter.pas b/internal/2.2.2/1/Source/TB2DsgnConverter.pas new file mode 100644 index 0000000..e1a2456 --- /dev/null +++ b/internal/2.2.2/1/Source/TB2DsgnConverter.pas @@ -0,0 +1,217 @@ +unit TB2DsgnConverter; + +{ + Toolbar2000 + Copyright (C) 1998-2005 by Jordan Russell + All rights reserved. + + The contents of this file are subject to the "Toolbar2000 License"; you may + not use or distribute this file except in compliance with the + "Toolbar2000 License". A copy of the "Toolbar2000 License" may be found in + TB2k-LICENSE.txt or at: + http://www.jrsoftware.org/files/tb2k/TB2k-LICENSE.txt + + Alternatively, the contents of this file may be used under the terms of the + GNU General Public License (the "GPL"), in which case the provisions of the + GPL are applicable instead of those in the "Toolbar2000 License". A copy of + the GPL may be found in GPL-LICENSE.txt or at: + http://www.jrsoftware.org/files/tb2k/GPL-LICENSE.txt + If you wish to allow use of your version of this file only under the terms of + the GPL and not to allow others to use your version of this file under the + "Toolbar2000 License", indicate your decision by deleting the provisions + above and replace them with the notice and other provisions required by the + GPL. If you do not delete the provisions above, a recipient may use your + version of this file under either the "Toolbar2000 License" or the GPL. + + $jrsoftware: tb2k/Source/TB2DsgnConverter.pas,v 1.16 2005/01/06 03:56:50 jr Exp $ +} + +interface + +{$I TB2Ver.inc} + +uses + Windows, SysUtils, Classes, Controls, Forms, Menus, StdCtrls, + TB2Item; + +type + TTBConverterForm = class(TForm) + MessageList: TListBox; + CloseButton: TButton; + CopyButton: TButton; + procedure CloseButtonClick(Sender: TObject); + procedure CopyButtonClick(Sender: TObject); + procedure FormClose(Sender: TObject; var Action: TCloseAction); + end; + +procedure DoConvert(const ParentItem: TTBCustomItem; const Owner: TComponent); + +implementation + +{$R *.DFM} + +uses + Clipbrd, TB2DsgnConvertOptions; + +procedure DoConvert(const ParentItem: TTBCustomItem; const Owner: TComponent); +const + SPropNotTransferred = 'Warning: %s property not transferred on ''%s''.'; +var + ConverterForm: TTBConverterForm; + + procedure Log(const S: String); + begin + ConverterForm.MessageList.Items.Add(S); + ConverterForm.MessageList.TopIndex := ConverterForm.MessageList.Items.Count-1; + ConverterForm.Update; + end; + + procedure Recurse(MenuItem: TMenuItem; TBItem: TTBCustomItem); + var + I: Integer; + Src: TMenuItem; + IsSep, IsSubmenu: Boolean; + Dst: TTBCustomItem; + N: String; + begin + for I := 0 to MenuItem.Count-1 do begin + Src := MenuItem[I]; + IsSep := (Src.Caption = '-'); + IsSubmenu := False; + if not IsSep then begin + if Src.Count > 0 then + IsSubmenu := True; + if not IsSubmenu then + Dst := TTBItem.Create(Owner) + else + Dst := TTBSubmenuItem.Create(Owner); + Dst.Action := Src.Action; + {$IFDEF JR_D6} + Dst.AutoCheck := Src.AutoCheck; + {$ENDIF} + Dst.Caption := Src.Caption; + Dst.Checked := Src.Checked; + if Src.Default then + Dst.Options := Dst.Options + [tboDefault]; + Dst.Enabled := Src.Enabled; + Dst.GroupIndex := Src.GroupIndex; + Dst.HelpContext := Src.HelpContext; + Dst.ImageIndex := Src.ImageIndex; + Dst.RadioItem := Src.RadioItem; + Dst.ShortCut := Src.ShortCut; + {$IFDEF JR_D5} + Dst.SubMenuImages := Src.SubMenuImages; + {$ENDIF} + Dst.OnClick := Src.OnClick; + end + else begin + Dst := TTBSeparatorItem.Create(Owner); + end; + Dst.Hint := Src.Hint; + Dst.Tag := Src.Tag; + Dst.Visible := Src.Visible; + if not IsSep then + { Temporarily clear the menu item's OnClick property, so that renaming + the menu item doesn't cause the function name to change } + Src.OnClick := nil; + try + N := Src.Name; + Src.Name := N + '_OLD'; + Dst.Name := N; + finally + if not IsSep then + Src.OnClick := Dst.OnClick; + end; + TBItem.Add(Dst); + {$IFDEF JR_D5} + if @Src.OnAdvancedDrawItem <> nil then + Log(Format(SPropNotTransferred, ['OnAdvancedDrawItem', Dst.Name])); + {$ENDIF} + if @Src.OnDrawItem <> nil then + Log(Format(SPropNotTransferred, ['OnDrawItem', Dst.Name])); + if @Src.OnMeasureItem <> nil then + Log(Format(SPropNotTransferred, ['OnMeasureItem', Dst.Name])); + if IsSubmenu then + Recurse(Src, Dst); + end; + end; + +var + OptionsForm: TTBConvertOptionsForm; + I: Integer; + C: TComponent; + Menu: TMenu; +begin + Menu := nil; + OptionsForm := TTBConvertOptionsForm.Create(Application); + try + for I := 0 to Owner.ComponentCount-1 do begin + C := Owner.Components[I]; + if (C is TMenu) and not(C is TTBPopupMenu) then + OptionsForm.MenuCombo.Items.AddObject(C.Name, C); + end; + if OptionsForm.MenuCombo.Items.Count = 0 then + raise Exception.Create('Could not find any menus on the form to convert'); + OptionsForm.MenuCombo.ItemIndex := 0; + if (OptionsForm.ShowModal <> mrOK) or (OptionsForm.MenuCombo.ItemIndex < 0) then + Exit; + Menu := TMenu(OptionsForm.MenuCombo.Items.Objects[OptionsForm.MenuCombo.ItemIndex]); + finally + OptionsForm.Free; + end; + ParentItem.SubMenuImages := Menu.Images; + ConverterForm := TTBConverterForm.Create(Application); + ConverterForm.Show; + ConverterForm.Update; + Log(Format('Converting ''%s'', please wait...', [Menu.Name])); + ParentItem.ViewBeginUpdate; + try + Recurse(Menu.Items, ParentItem); + finally + ParentItem.ViewEndUpdate; + end; + Log('Done!'); + ConverterForm.CloseButton.Enabled := True; + ConverterForm.CopyButton.Enabled := True; +end; + + +{ TTBConverterForm } + +procedure TTBConverterForm.FormClose(Sender: TObject; + var Action: TCloseAction); +begin + Action := caFree; +end; + +procedure TTBConverterForm.CloseButtonClick(Sender: TObject); +begin + Close; +end; + +procedure TTBConverterForm.CopyButtonClick(Sender: TObject); +begin + Clipboard.AsText := MessageList.Items.Text; +end; + + +procedure FreeConverterForms; +var + I: Integer; + Form: TCustomForm; +label Restart; +begin + Restart: + for I := 0 to Screen.CustomFormCount-1 do begin + Form := Screen.CustomForms[I]; + if Form is TTBConverterForm then begin + Form.Free; + goto Restart; + end; + end; +end; + +initialization +finalization + FreeConverterForms; +end. diff --git a/internal/2.2.2/1/Source/TB2DsgnItemEditor.dfm b/internal/2.2.2/1/Source/TB2DsgnItemEditor.dfm new file mode 100644 index 0000000..748a7cd Binary files /dev/null and b/internal/2.2.2/1/Source/TB2DsgnItemEditor.dfm differ diff --git a/internal/2.2.2/1/Source/TB2DsgnItemEditor.dfm.txt b/internal/2.2.2/1/Source/TB2DsgnItemEditor.dfm.txt new file mode 100644 index 0000000..a2a3205 --- /dev/null +++ b/internal/2.2.2/1/Source/TB2DsgnItemEditor.dfm.txt @@ -0,0 +1,184 @@ +object TBItemEditForm: TTBItemEditForm + Left = 200 + Top = 104 + AutoScroll = False + BorderIcons = [biSystemMenu, biMinimize] + ClientHeight = 247 + ClientWidth = 440 + Color = clBtnFace + Font.Charset = DEFAULT_CHARSET + Font.Color = clWindowText + Font.Height = -11 + Font.Name = 'MS Sans Serif' + Font.Style = [] + OldCreateOrder = True + Position = poScreenCenter + OnActivate = FormActivate + OnClose = FormClose + PixelsPerInch = 96 + TextHeight = 13 + object Splitter1: TSplitter + Left = 129 + Top = 19 + Width = 3 + Height = 228 + Cursor = crHSplit + ResizeStyle = rsUpdate + end + object TreeView: TTreeView + Left = 0 + Top = 19 + Width = 129 + Height = 228 + Align = alLeft + HideSelection = False + Indent = 19 + ReadOnly = True + ShowRoot = False + TabOrder = 2 + OnChange = TreeViewChange + OnDragDrop = TreeViewDragDrop + OnDragOver = TreeViewDragOver + OnEnter = TreeViewEnter + OnKeyDown = TreeViewKeyDown + OnKeyPress = TreeViewKeyPress + end + object ListView: TListView + Left = 132 + Top = 19 + Width = 308 + Height = 228 + Align = alClient + Columns = < + item + Caption = 'Caption' + Width = 160 + end + item + Caption = 'Type' + Width = 120 + end> + ColumnClick = False + DragMode = dmAutomatic + HideSelection = False + MultiSelect = True + ReadOnly = True + RowSelect = True + PopupMenu = TBPopupMenu1 + TabOrder = 1 + ViewStyle = vsReport + OnChange = ListViewChange + OnDblClick = ListViewDblClick + OnEnter = ListViewEnter + OnDragDrop = ListViewDragDrop + OnDragOver = ListViewDragOver + OnKeyDown = ListViewKeyDown + OnKeyPress = ListViewKeyPress + end + object Toolbar: TTBToolbar + Left = 0 + Top = 0 + Width = 440 + Height = 19 + Align = alTop + Caption = 'Toolbar' + DockPos = 0 + FullSize = True + LinkSubitems = ToolbarItems + ParentShowHint = False + ShowHint = True + TabOrder = 0 + end + object TBPopupMenu1: TTBPopupMenu + LinkSubitems = ToolbarItems + Left = 256 + Top = 120 + end + object TBItemContainer1: TTBItemContainer + Left = 224 + Top = 120 + object ToolbarItems: TTBSubmenuItem + object NewItemButton: TTBItem + Caption = 'New &Item' + Hint = 'New Item' + ImageIndex = 0 + ShortCut = 45 + OnClick = NewItemButtonClick + end + object NewSubmenuButton: TTBItem + Caption = 'New &Submenu' + Hint = 'New Submenu' + ImageIndex = 1 + ShortCut = 16429 + OnClick = NewSubmenuButtonClick + end + object NewSepButton: TTBItem + Caption = 'New Se¶tor' + Hint = 'New Separator' + ImageIndex = 2 + ShortCut = 189 + OnClick = NewSepButtonClick + end + object MoreMenu: TTBSubmenuItem + Caption = '&More' + Options = [tboDropdownArrow] + end + object TBSeparatorItem1: TTBSeparatorItem + end + object CutButton: TTBItem + Caption = 'Cu&t' + Enabled = False + Hint = 'Cut' + ImageIndex = 5 + OnClick = CutButtonClick + end + object CopyButton: TTBItem + Caption = '&Copy' + Enabled = False + Hint = 'Copy' + ImageIndex = 4 + OnClick = CopyButtonClick + end + object PasteButton: TTBItem + Caption = '&Paste' + Hint = 'Paste' + ImageIndex = 6 + OnClick = PasteButtonClick + end + object DeleteButton: TTBItem + Caption = '&Delete Item' + Enabled = False + Hint = 'Delete Item' + ImageIndex = 3 + ShortCut = 46 + OnClick = DeleteButtonClick + end + object TBSeparatorItem2: TTBSeparatorItem + end + object MoveUpButton: TTBItem + Caption = 'Move &Up' + Hint = 'Move Up' + ImageIndex = 7 + ShortCut = 32806 + OnClick = MoveUpButtonClick + end + object MoveDownButton: TTBItem + Caption = 'Move D&own' + Hint = 'Move Down' + ImageIndex = 8 + ShortCut = 32808 + OnClick = MoveDownButtonClick + end + object TBSeparatorItem3: TTBSeparatorItem + end + object TBSubmenuItem1: TTBSubmenuItem + Caption = '&Tools' + Options = [tboDropdownArrow] + object TConvertMenu: TTBItem + Caption = '&Convert TMainMenu/TPopupMenu...' + OnClick = TConvertMenuClick + end + end + end + end +end diff --git a/internal/2.2.2/1/Source/TB2DsgnItemEditor.pas b/internal/2.2.2/1/Source/TB2DsgnItemEditor.pas new file mode 100644 index 0000000..a8b35fc --- /dev/null +++ b/internal/2.2.2/1/Source/TB2DsgnItemEditor.pas @@ -0,0 +1,1439 @@ +unit TB2DsgnItemEditor; + +{ + Toolbar2000 + Copyright (C) 1998-2008 by Jordan Russell + All rights reserved. + + The contents of this file are subject to the "Toolbar2000 License"; you may + not use or distribute this file except in compliance with the + "Toolbar2000 License". A copy of the "Toolbar2000 License" may be found in + TB2k-LICENSE.txt or at: + http://www.jrsoftware.org/files/tb2k/TB2k-LICENSE.txt + + Alternatively, the contents of this file may be used under the terms of the + GNU General Public License (the "GPL"), in which case the provisions of the + GPL are applicable instead of those in the "Toolbar2000 License". A copy of + the GPL may be found in GPL-LICENSE.txt or at: + http://www.jrsoftware.org/files/tb2k/GPL-LICENSE.txt + If you wish to allow use of your version of this file only under the terms of + the GPL and not to allow others to use your version of this file under the + "Toolbar2000 License", indicate your decision by deleting the provisions + above and replace them with the notice and other provisions required by the + GPL. If you do not delete the provisions above, a recipient may use your + version of this file under either the "Toolbar2000 License" or the GPL. + + $jrsoftware: tb2k/Source/TB2DsgnItemEditor.pas,v 1.63 2008/09/25 18:49:31 jr Exp $ +} + +interface + +{$I TB2Ver.inc} + +uses + Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs, + {$IFDEF CLR} System.ComponentModel, {$ENDIF} + StdCtrls, ExtCtrls, Buttons, ComCtrls, ImgList, Menus, + TB2Item, TB2Toolbar, TB2Dock, + {$IFDEF JR_D6} + DesignIntf, DesignWindows, DesignEditors; + {$ELSE} + DsgnIntf, DsgnWnds, LibIntf; + {$ENDIF} + +const + CM_DEFERUPDATE = WM_USER + 100; + +type + TTBItemEditForm = class(TDesignWindow) + TreeView: TTreeView; + ListView: TListView; + Splitter1: TSplitter; + Toolbar: TTBToolbar; + NewSubmenuButton: TTBItem; + NewItemButton: TTBItem; + NewSepButton: TTBItem; + DeleteButton: TTBItem; + TBSeparatorItem1: TTBSeparatorItem; + TBPopupMenu1: TTBPopupMenu; + TBItemContainer1: TTBItemContainer; + ToolbarItems: TTBSubmenuItem; + CopyButton: TTBItem; + CutButton: TTBItem; + PasteButton: TTBItem; + MoreMenu: TTBSubmenuItem; + TBSeparatorItem2: TTBSeparatorItem; + TBSubmenuItem1: TTBSubmenuItem; + TConvertMenu: TTBItem; + TBSeparatorItem3: TTBSeparatorItem; + MoveUpButton: TTBItem; + MoveDownButton: TTBItem; + procedure FormClose(Sender: TObject; var Action: TCloseAction); + procedure TreeViewChange(Sender: TObject; Node: TTreeNode); + procedure NewSubmenuButtonClick(Sender: TObject); + procedure NewItemButtonClick(Sender: TObject); + procedure ListViewChange(Sender: TObject; Item: TListItem; + Change: TItemChange); + procedure DeleteButtonClick(Sender: TObject); + procedure NewSepButtonClick(Sender: TObject); + procedure ListViewDragOver(Sender, Source: TObject; X, Y: Integer; + State: TDragState; var Accept: Boolean); + procedure ListViewDragDrop(Sender, Source: TObject; X, Y: Integer); + procedure TreeViewEnter(Sender: TObject); + procedure TreeViewDragDrop(Sender, Source: TObject; X, Y: Integer); + procedure TreeViewDragOver(Sender, Source: TObject; X, Y: Integer; + State: TDragState; var Accept: Boolean); + procedure CopyButtonClick(Sender: TObject); + procedure ListViewKeyDown(Sender: TObject; var Key: Word; + Shift: TShiftState); + procedure CutButtonClick(Sender: TObject); + procedure PasteButtonClick(Sender: TObject); + procedure FormActivate(Sender: TObject); + procedure ListViewKeyPress(Sender: TObject; var Key: Char); + procedure ListViewDblClick(Sender: TObject); + procedure ListViewEnter(Sender: TObject); + procedure TreeViewKeyDown(Sender: TObject; var Key: Word; + Shift: TShiftState); + procedure TConvertMenuClick(Sender: TObject); + procedure TreeViewKeyPress(Sender: TObject; var Key: Char); + procedure MoveUpButtonClick(Sender: TObject); + procedure MoveDownButtonClick(Sender: TObject); + private + FParentComponent: TComponent; + FRootItem, FSelParentItem: TTBCustomItem; + FNotifyItemList: TList; + FSettingSel, FRebuildingTree, FRebuildingList: Integer; + function AddListViewItem(const Index: Integer; + const Item: TTBCustomItem): TListItem; + procedure CMDeferUpdate(var Message: TMessage); message CM_DEFERUPDATE; + procedure Copy; + procedure CreateNewItem(const AClass: TTBCustomItemClass); + procedure Cut; + procedure Delete; + procedure DeleteItem(const Item: TTBCustomItem); + function GetItemTreeCaption(AItem: TTBCustomItem): String; + procedure GetSelItemList(const AList: TList); + procedure ItemNotification(Ancestor: TTBCustomItem; Relayed: Boolean; + Action: TTBItemChangedAction; Index: Integer; Item: TTBCustomItem); + procedure MoreItemClick(Sender: TObject); + procedure MoveItem(CurIndex, NewIndex: Integer); + procedure Paste; + procedure RebuildList; + procedure RebuildTree; + procedure SelectInObjectInspector(AList: TList); + procedure SetSelParentItem(ASelParentItem: TTBCustomItem); + function TreeViewDragHandler(Sender, Source: TObject; X, Y: Integer; + Drop: Boolean): Boolean; + procedure UnregisterAllNotifications; + protected + procedure Notification(AComponent: TComponent; Operation: TOperation); override; + function UniqueName(Component: TComponent): String; override; + public + constructor Create(AOwner: TComponent); override; + destructor Destroy; override; + {$IFDEF JR_D6} + function EditAction(Action: TEditAction): Boolean; override; + {$ELSE} + procedure EditAction(Action: TEditAction); override; + {$ENDIF} + function GetEditState: TEditState; override; + end; + + TTBItemsEditor = class(TDefaultEditor) + public + procedure Edit; override; + procedure ExecuteVerb(Index: Integer); override; + function GetVerb(Index: Integer): String; override; + function GetVerbCount: Integer; override; + end; + + TTBItemsPropertyEditor = class(TStringProperty) + public + procedure Edit; override; + function GetAttributes: TPropertyAttributes; override; + function GetValue: String; override; + end; + +procedure TBRegisterItemClass(AClass: TTBCustomItemClass; + const ACaption: String; ResInstance: HINST); + +implementation + +{$R *.DFM} + +uses + {$IFDEF CLR} System.Drawing, System.IO, System.Reflection, {$ENDIF} + TypInfo, CommCtrl, TB2Version, TB2Common, TB2DsgnConverter; + +type +{$IFNDEF JR_D5} + TDesignerSelectionList = TComponentList; +{$ENDIF} +{$IFDEF JR_D6} + TDesignerSelectionList = IDesignerSelections; +{$ENDIF} + + TItemClassInfo = class + ItemClass: TTBCustomItemClass; + Caption: String; + ImageIndex: Integer; + end; + +var + ItemClasses: TList; + ItemImageList: TImageList; + +{$IFNDEF JR_D6} +function CreateSelectionList: TDesignerSelectionList; +begin + Result := TDesignerSelectionList.Create; +end; +{$ENDIF} + +procedure FreeItemClasses; +var + I: Integer; + IC: TList; +begin + if ItemClasses = nil then Exit; + IC := ItemClasses; + ItemClasses := nil; + for I := IC.Count-1 downto 0 do + TItemClassInfo(IC[I]).Free; + IC.Free; +end; + +{ Note: AFAIK, there is no need for a similar function on .NET since assemblies + can't be unloaded. When a design-time package is uninstalled, it remains + loaded until the IDE is restarted. } +{$IFNDEF CLR} +procedure UnregisterModuleItemClasses(AModule: {$IFDEF JR_D5} LongWord {$ELSE} Integer {$ENDIF}); +var + I: Integer; + Info: TItemClassInfo; +begin + I := 0; + while I < ItemClasses.Count do begin + Info := TItemClassInfo(ItemClasses[I]); + if FindClassHInstance(Info.ItemClass) = AModule then begin + ItemClasses.Delete(I); + Info.Free; + end + else + Inc(I); + end; + { Note: TTBItemEditForm also holds references to item classes, but since + Delphi automatically closes all editor forms before compiling/removing + a package, we don't need to remove them. } +end; +{$ENDIF} + +{$IFNDEF CLR} +function LoadItemImage(Instance: HINST; const ResName: String): Integer; +var + Bmp: TBitmap; +begin + Bmp := TBitmap.Create; + try + Bmp.Handle := LoadBitmap(Instance, {$IFNDEF CLR}PChar{$ENDIF}(ResName)); + if Bmp.Handle = 0 then + Result := -1 + else + Result := ItemImageList.AddMasked(Bmp, Bmp.Canvas.Pixels[0, Bmp.Height-1]); + finally + Bmp.Free; + end; +end; +{$ELSE} +function LoadItemImage(const AAssembly: System.Reflection.Assembly; + const ResName: String): Integer; +var + Bmp: TBitmap; + ResStream: System.IO.Stream; + ResBmp: System.Drawing.Bitmap; +begin + Bmp := TBitmap.Create; + try + ResStream := AAssembly.GetManifestResourceStream(ResName); + if ResStream = nil then begin + Result := -1; + Exit; + end; + try + ResBmp := System.Drawing.Bitmap.Create(ResStream); + try + Bmp.LoadFromBitmap(ResBmp); + finally + ResBmp.Dispose; + end; + finally + ResStream.Close; + end; + Result := ItemImageList.AddMasked(Bmp, Bmp.Canvas.Pixels[0, Bmp.Height-1]); + finally + Bmp.Free; + end; +end; +{$ENDIF} + +procedure TBRegisterItemClass(AClass: TTBCustomItemClass; + const ACaption: String; ResInstance: HINST); +var + I: Integer; + Info: TItemClassInfo; +begin + { Hack for Delphi.NET 2006 bug: + If you start Delphi, open & rebuild the tb2k_dn10 package only, then open + the Demo project, the IDE calls the Register procedure on tb2kdsgn_d10 a + second time, without reloading either of the two packages. As a result, + the TBRegisterItemClass calls are repeated. To avoid doubled items on the + editor form's More menu, check if the class was already registered. } + for I := 0 to ItemClasses.Count-1 do + if TItemClassInfo(ItemClasses[I]).ItemClass = AClass then + Exit; + Info := TItemClassInfo.Create; + Info.ItemClass := AClass; + Info.Caption := ACaption; + {$IFNDEF CLR} + Info.ImageIndex := LoadItemImage(ResInstance, + Uppercase(AClass.ClassName {$IFDEF JR_D9} , loInvariantLocale {$ENDIF})); + {$ELSE} + Info.ImageIndex := LoadItemImage(Assembly.GetCallingAssembly, + AClass.ClassName + '.bmp'); + {$ENDIF} + ItemClasses.Add(Info); +end; + +function GetItemClassImage(AClass: TTBCustomItemClass): Integer; +var + I: Integer; + Info: TItemClassInfo; +begin + for I := ItemClasses.Count-1 downto 0 do begin + Info := TItemClassInfo(ItemClasses[I]); + if AClass.InheritsFrom(Info.ItemClass) then begin + Result := Info.ImageIndex; + if Result >= 0 then + Exit; + end; + end; + if AClass.InheritsFrom(TTBSubmenuItem) then + Result := 1 + else if AClass.InheritsFrom(TTBSeparatorItem) then + Result := 2 + else + Result := 0; +end; + +procedure ShowEditForm(AParentComponent: TComponent; ARootItem: TTBCustomItem; + const ADesigner: {$IFDEF JR_D6} IDesigner {$ELSE} IFormDesigner {$ENDIF}); +var + I: Integer; + Form: TCustomForm; + EditForm: TTBItemEditForm; +begin + if Assigned(ARootItem.LinkSubitems) then begin + case MessageDlg(Format('The LinkSubitems property is set to ''%s''. ' + + 'Would you like to edit that item instead?', + [ARootItem.LinkSubitems.Name]), mtConfirmation, [mbYes, mbNo, mbCancel], 0) of + mrYes: begin + AParentComponent := ARootItem.LinkSubitems; + ARootItem := ARootItem.LinkSubitems; + end; + mrCancel: Exit; + end; + end; + for I := 0 to Screen.FormCount-1 do begin + Form := Screen.Forms[I]; + if Form is TTBItemEditForm then + if TTBItemEditForm(Form).FRootItem = ARootItem then begin + Form.Show; + if Form.WindowState = wsMinimized then + Form.WindowState := wsNormal; + Exit; + end; + end; + EditForm := TTBItemEditForm.Create(Application); + try + EditForm.Designer := ADesigner; + EditForm.FParentComponent := AParentComponent; + AParentComponent.FreeNotification(EditForm); + EditForm.FRootItem := ARootItem; + ARootItem.FreeNotification(EditForm); + EditForm.FSelParentItem := ARootItem; + EditForm.Caption := 'Editing ' + AParentComponent.Name; + EditForm.RebuildTree; + EditForm.RebuildList; + {$IFDEF JR_D9} + EditForm.PopupMode := pmExplicit; + {$ENDIF} + EditForm.Show; + except + EditForm.Free; + raise; + end; +end; + +function IsSubmenuItem(Item: TTBCustomItem): Boolean; +begin + Result := tbisSubitemsEditable in Item.GetItemStyle; +end; + +procedure ShowVersion; +const + AboutText = + '%s'#13#10 + + 'Copyright (C) 1998-2008 by Jordan Russell'#13#10 + + 'For conditions of distribution and use, see LICENSE.TXT.'#13#10 + + #13#10 + + 'Visit my web site for the latest versions of Toolbar2000:'#13#10 + + 'http://www.jrsoftware.org/'; +begin + MessageDlg(Format(AboutText, [Toolbar2000VersionPropText]), mtInformation, + [mbOK], 0); +end; + + +{ TTBItemEditForm } + +constructor TTBItemEditForm.Create(AOwner: TComponent); +var + I: Integer; + Info: TItemClassInfo; + Item: TTBItem; +begin + inherited; + FNotifyItemList := TList.Create; + ToolbarItems.SubMenuImages := ItemImageList; + ListView.SmallImages := ItemImageList; + { Populate the 'More' menu } + for I := 0 to ItemClasses.Count-1 do begin + Info := TItemClassInfo(ItemClasses[I]); + Item := TTBItem.Create(Self); + Item.Caption := Info.Caption; + Item.ImageIndex := GetItemClassImage(Info.ItemClass); + Item.Tag := {$IFNDEF CLR}Integer{$ELSE}TTag{$ENDIF}(Info.ItemClass); + Item.OnClick := MoreItemClick; + MoreMenu.Add(Item); + end; +end; + +destructor TTBItemEditForm.Destroy; +begin + inherited; + if Assigned(FNotifyItemList) then begin + UnregisterAllNotifications; + FNotifyItemList.Free; + FNotifyItemList := nil; + end; +end; + +procedure TTBItemEditForm.FormClose(Sender: TObject; + var Action: TCloseAction); +begin + Action := caFree; +end; + +procedure TTBItemEditForm.FormActivate(Sender: TObject); +begin + SetSelParentItem(FSelParentItem); +end; + +procedure TTBItemEditForm.Notification(AComponent: TComponent; + Operation: TOperation); +begin + inherited; + if (Operation = opRemove) and + ((AComponent = FParentComponent) or (AComponent = FRootItem)) then + { Must use Free instead of Close, since Close causes the freeing of the + form to be delayed until the next message. We have to destroy the form + immediately, otherwise Delphi will crash when Compile is clicked on the + TB2k package. } + Free; + {}{temp:} + (*if (Operation = opRemove) and (FNotifyItemList.IndexOf(AComponent) <> -1) then begin + outputdebugstring(pchar('Still in list: ' + AComponent.name)); + //beep; + end;*) +end; + +function TTBItemEditForm.UniqueName(Component: TComponent): String; +begin + Result := Designer.UniqueName(Component.ClassName); +end; + +function TTBItemEditForm.GetEditState: TEditState; +begin + Result := []; + if ActiveControl = ListView then begin + if Assigned(ListView.Selected) then + Result := [esCanDelete, esCanCut, esCanCopy]; + if ClipboardComponents then + Include(Result, esCanPaste); + end; +end; + +{$IFDEF JR_D6} +function TTBItemEditForm.EditAction(Action: TEditAction): Boolean; +{$ELSE} +procedure TTBItemEditForm.EditAction(Action: TEditAction); +{$ENDIF} +begin + {$IFDEF JR_D6} + Result := True; + {$ENDIF} + case Action of + eaCut: Cut; + eaCopy: Copy; + eaPaste: Paste; + eaDelete: Delete; + {$IFDEF JR_D6} + else + Result := False; + {$ENDIF} + end; +end; + +procedure TTBItemEditForm.UnregisterAllNotifications; +var + I: Integer; +begin + for I := FNotifyItemList.Count-1 downto 0 do begin + //outputdebugstring(pchar('Unregall: ' + TTBCustomItem(FNotifyItemList[I]).name)); + TTBCustomItem(FNotifyItemList[I]).UnregisterNotification(ItemNotification); + FNotifyItemList.Delete(I); + end; +end; + +procedure TTBItemEditForm.ItemNotification(Ancestor: TTBCustomItem; + Relayed: Boolean; Action: TTBItemChangedAction; Index: Integer; + Item: TTBCustomItem); +var + ListItem: TListItem; + TreeNode: TTreeNode; + I: Integer; + C: String; +begin + { Manipulate the list view when items are inserted, deleted, or their Caption + changes } + case Action of + tbicInserted: + begin + if (Ancestor = FSelParentItem) and not Relayed then + AddListViewItem(Index, Item); + if IsSubmenuItem(Item) then + RebuildTree; + end; + tbicDeleting: + if (Ancestor = FSelParentItem) and not Relayed then begin + ListItem := ListView.FindData(0, Item, True, False); + if Assigned(ListItem) then + ListItem.Delete; + end; + tbicInvalidateAndResize: + if (Ancestor = FSelParentItem) and not Relayed then begin + ListItem := ListView.FindData(0, Item, True, False); + if Assigned(ListItem) and (ListItem.Caption <> TTBCustomItem(Item).Caption) then + ListItem.Caption := TTBCustomItem(Item).Caption; + end; + end; + { Update tree view when an item is deleted, or a Caption changes } + if Action = tbicDeleting then begin + I := FNotifyItemList.IndexOf(Item); + if I <> -1 then begin + //outputdebugstring(pchar('Deleting, so unreging: ' + item.name)); + TTBCustomItem(Item).UnregisterNotification(ItemNotification); + FNotifyItemList.Delete(I); + end; + end; + if Action in [tbicDeleting, tbicInvalidateAndResize, tbicNameChanged] then begin + TreeNode := TreeView.Items.GetFirstNode; + while Assigned(TreeNode) do begin + if TreeNode.Data = Item then begin + if Action = tbicDeleting then begin + TreeNode.Delete; + if FSelParentItem = Item then + SetSelParentItem(TTBCustomItem(Item).Parent); + end + else begin + { tbicInvalidateAndResize, tbicNameChanged: } + C := GetItemTreeCaption(Item); + if TreeNode.Text <> C then + TreeNode.Text := C; + end; + Break; + end; + TreeNode := TreeNode.GetNext; + end; + end; +end; + +function TTBItemEditForm.GetItemTreeCaption(AItem: TTBCustomItem): String; +begin + if AItem <> FRootItem then begin + Result := AItem.Caption; + if Result = '' then + Result := '[' + AItem.Name + ']'; + end + else + Result := '(Root)'; +end; + +procedure TTBItemEditForm.RebuildTree; + + procedure Recurse(const AParentItem: TTBCustomItem; const ATreeNode: TTreeNode; + var FoundSelParentItem: TTreeNode); + var + I: Integer; + NewNode: TTreeNode; + ChildItem: TTBCustomItem; + begin + {}AParentItem.FreeNotification(Self); + AParentItem.RegisterNotification(ItemNotification); + FNotifyItemList.Add(AParentItem); + NewNode := TreeView.Items.AddChild(ATreeNode, GetItemTreeCaption(AParentItem)); + NewNode.Data := AParentItem; + if AParentItem = FSelParentItem then + FoundSelParentItem := NewNode; + for I := 0 to AParentItem.Count-1 do begin + ChildItem := AParentItem[I]; + if IsSubmenuItem(ChildItem) then + Recurse(ChildItem, NewNode, FoundSelParentItem); + end; + end; + +var + FoundSelParentItem: TTreeNode; +begin + Inc(FRebuildingTree); + try + TreeView.Items.BeginUpdate; + try + TreeView.Items.Clear; + UnregisterAllNotifications; + FoundSelParentItem := nil; + Recurse(FRootItem, nil, FoundSelParentItem); + if FoundSelParentItem = nil then + SetSelParentItem(FRootItem) + else + TreeView.Selected := FoundSelParentItem; + TreeView.Items[0].Expand(True); + finally + TreeView.Items.EndUpdate; + end; + finally + Dec(FRebuildingTree); + end; +end; + +function TTBItemEditForm.AddListViewItem(const Index: Integer; + const Item: TTBCustomItem): TListItem; +begin + Result := ListView.Items.Insert(Index); + Result.Data := Item; + if not(Item is TTBControlItem) then begin + Result.Caption := Item.Caption; + Result.Subitems.Add(Item.ClassName); + Result.ImageIndex := GetItemClassImage(TTBCustomItemClass(Item.ClassType)); + end + else begin + Result.Caption := '(Control)'; + Result.Subitems.Add(Item.ClassName); + Result.ImageIndex := -1; + end; +end; + +procedure TTBItemEditForm.RebuildList; +var + ChildItem: TTBCustomItem; + I: Integer; +begin + Inc(FRebuildingList); + try + ListView.Items.BeginUpdate; + try + ListView.Items.Clear; + if Assigned(FSelParentItem) then begin + for I := 0 to FSelParentItem.Count-1 do begin + ChildItem := FSelParentItem[I]; + { Check for csDestroying because deleting an item in the tree view + causes the parent item to be selected, and the parent item won't + get a notification that the item is deleting since notifications + were already sent } + if not(csDestroying in ChildItem.ComponentState) then + AddListViewItem(I, ChildItem); + end; + { Add an empty item to the end } + ListView.Items.Add.ImageIndex := -1; + end; + finally + ListView.Items.EndUpdate; + end; + { Work around a strange TListView bug(?). Without this, the column header + isn't painted properly. } + if HandleAllocated then + SetWindowPos(ListView.Handle, 0, 0, 0, 0, 0, SWP_FRAMECHANGED or + SWP_NOACTIVATE or SWP_NOMOVE or SWP_NOSIZE or SWP_NOZORDER); + finally + Dec(FRebuildingList); + end; +end; + +procedure TTBItemEditForm.SelectInObjectInspector(AList: TList); +var + CompList1, CompList2: TDesignerSelectionList; + I: Integer; + C: TComponent; +begin + { Designer.SetSelections will make components appear selected on the form. + It will also select the component in Object Inspector, but only if the + form has the focus. TDesignWindow.SetSelection will select the component + in Object Inspector regardless of whether the form has the focus. } + CompList1 := CreateSelectionList; + CompList2 := CreateSelectionList; + for I := 0 to AList.Count-1 do begin + C := TComponent(AList[I]); + { Must check for csDestroying. If SetSelection is passed a component that's + destroying, Delphi will crash. } + if not(csDestroying in C.ComponentState) then begin + CompList1.Add(C); + CompList2.Add(C); + end; + end; + if CompList1.Count = 0 then begin + {$IFNDEF JR_D6} + CompList1.Free; + CompList2.Free; + {$ENDIF} + end + else begin + Designer.SetSelections(CompList1); + { Note: Never pass an empty list to SetSelection or Delphi will crash } + { History here: + - 1.34: SetSelection call remarked out because it fixed Delphi 6 issue + with random AV's after the editor was closed. + - 1.38: SetSelection call restored because without it, Ctrl+X/C/V didn't + work. + - 1.40: SetSelection call disabled on Delphi 6 only because AV problem + still seems to exist despite another change which I thought fixed it. + On D6 it isn't necessary to call SetSelection for Ctrl+X/C/V to work. + Note: Using "ComponentDesigner.SetSelection(Designer, nil, CompList2);" + instead seems to fix the AV problem, but for consistency with Delphi's + TMainMenu editor (which only selects items when its parent form is + focused), I decided not to call SetSelection at all on D6. + } + {$IFNDEF JR_D6} + SetSelection(CompList2); + {$ENDIF} + end; +end; + +procedure TTBItemEditForm.GetSelItemList(const AList: TList); +var + ListItem: TListItem; +begin + ListItem := nil; + while True do begin + ListItem := ListView.GetNextItem(ListItem, sdAll, [isSelected]); + if ListItem = nil then + Break; + if Assigned(ListItem.Data) then + AList.Add(ListItem.Data); + end; +end; + +procedure TTBItemEditForm.SetSelParentItem(ASelParentItem: TTBCustomItem); +{ - Rebuilds the list view to match a new selection (ASelParentItem) in the + tree view + - Updates toolbar + - Selects selected item(s) into Object Inspector } +var + I: Integer; + TreeNode: TTreeNode; + ItemIsSelected: Boolean; + List: TList; +begin + if FSettingSel > 0 then + Exit; + List := TList.Create; + Inc(FSettingSel); + try + if FSelParentItem <> ASelParentItem then begin + FSelParentItem := ASelParentItem; + NewSubmenuButton.Enabled := Assigned(ASelParentItem); + NewItemButton.Enabled := Assigned(ASelParentItem); + NewSepButton.Enabled := Assigned(ASelParentItem); + for I := 0 to MoreMenu.Count-1 do + MoreMenu[I].Enabled := Assigned(ASelParentItem); + if not Assigned(TreeView.Selected) or (TreeView.Selected.Data <> FSelParentItem) then begin + if FSelParentItem = nil then + TreeView.Selected := nil + else begin + TreeNode := TreeView.Items.GetFirstNode; + while Assigned(TreeNode) do begin + if TreeNode.Data = FSelParentItem then begin + TreeView.Selected := TreeNode; + Break; + end; + TreeNode := TreeNode.GetNext; + end; + end; + end; + RebuildList; + end; + + ItemIsSelected := (ActiveControl = ListView) and Assigned(ListView.Selected) and + Assigned(ListView.Selected.Data); + if ItemIsSelected then + GetSelItemList(List); + + CutButton.Enabled := ItemIsSelected; + CopyButton.Enabled := ItemIsSelected; + PasteButton.Enabled := (ActiveControl = ListView); + DeleteButton.Enabled := ItemIsSelected or + ((ActiveControl = TreeView) and (FSelParentItem <> FRootItem)); + MoveUpButton.Enabled := ItemIsSelected and + (FSelParentItem.IndexOf(TTBCustomItem(List.First)) > 0); + MoveDownButton.Enabled := ItemIsSelected and + (FSelParentItem.IndexOf(TTBCustomItem(List.Last)) < FSelParentItem.Count-1); + + if ActiveControl = ListView then begin + if List.Count = 0 then + { No item was selected, or the blank item was selected. + Select the root item so it looks like no item was selected in + Object Inspector } + List.Add(FRootItem); + end + else if not Assigned(ASelParentItem) or (ASelParentItem = FRootItem) then + List.Add(FParentComponent) + else + List.Add(ASelParentItem); + SelectInObjectInspector(List); + finally + Dec(FSettingSel); + List.Free; + end; +end; + +procedure TTBItemEditForm.Cut; +begin + Copy; + Delete; +end; + +procedure TTBItemEditForm.Copy; +var + SelList: TList; + CompList: TDesignerSelectionList; + I: Integer; + Item: TTBCustomItem; +begin + if ListView.Selected = nil then Exit; + CompList := nil; + SelList := TList.Create; + try + GetSelItemList(SelList); + CompList := CreateSelectionList; + for I := 0 to SelList.Count-1 do begin + Item := TTBCustomItem(SelList[I]); + if Item is TTBControlItem then + raise EInvalidOperation.Create('Cannot cut or copy TTBControlItems'); + CompList.Add(Item); + end; + CopyComponents(FParentComponent.Owner, CompList); + finally + {$IFNDEF JR_D6} + CompList.Free; + {$ENDIF} + SelList.Free; + end; +end; + +procedure TTBItemEditForm.Paste; +var + CompList: TDesignerSelectionList; +begin + if FSelParentItem = nil then Exit; + CompList := CreateSelectionList; + try + PasteComponents(FParentComponent.Owner, FSelParentItem, CompList); + if CompList.Count <> 0 then + Designer.Modified; + finally + {$IFNDEF JR_D6} + CompList.Free; + {$ENDIF} + end; +end; + +procedure TTBItemEditForm.DeleteItem(const Item: TTBCustomItem); +begin + if csAncestor in Item.ComponentState then + raise EInvalidOperation.Create('Items introduced in an ancestor form cannot be deleted'); + //Designer.ValidateRename(Item, Item.Name, ''); + Item.Free; + Designer.Modified; +end; + +procedure TTBItemEditForm.Delete; +var + List: TList; + Item: TTBCustomItem; + ListItem: TListItem; +begin + List := TList.Create; + try + List.Add(FSelParentItem); + SelectInObjectInspector(List); + finally + List.Free; + end; + FSelParentItem.ViewBeginUpdate; + try + while Assigned(ListView.Selected) do begin + Item := TTBCustomItem(ListView.Selected.Data); + if Item = nil then + Break; + DeleteItem(Item); + end; + finally + FSelParentItem.ViewEndUpdate; + end; + { After deleting the items, select the item with the focus } + ListItem := ListView.GetNextItem(nil, sdAll, [isFocused]); + if Assigned(ListItem) then + ListItem.Selected := True; +end; + +procedure TTBItemEditForm.MoveItem(CurIndex, NewIndex: Integer); +var + WasFocused: Boolean; +begin + WasFocused := ListView.Items[CurIndex].Focused; + + FSelParentItem.Move(CurIndex, NewIndex); + Designer.Modified; + + if WasFocused then + ListView.Items[NewIndex].Focused := True; + ListView.Items[NewIndex].Selected := True; +end; + +procedure TTBItemEditForm.TreeViewChange(Sender: TObject; Node: TTreeNode); +var + NewSelectedParentItem: TTBCustomItem; +begin + if (FRebuildingTree > 0) or (FSettingSel > 0) then Exit; + if Node = nil then + NewSelectedParentItem := nil + else + NewSelectedParentItem := TTBCustomItem(Node.Data); + SetSelParentItem(NewSelectedParentItem); +end; + +procedure TTBItemEditForm.TreeViewEnter(Sender: TObject); +{ When the tree view gets the focus, act as if the currently selected item + was clicked. } +begin + ListView.Selected := nil; + SetSelParentItem(FSelParentItem); +end; + +procedure TTBItemEditForm.CMDeferUpdate(var Message: TMessage); +begin + SetSelParentItem(FSelParentItem); +end; + +procedure TTBItemEditForm.ListViewChange(Sender: TObject; Item: TListItem; + Change: TItemChange); +var + Msg: TMsg; +begin + if (FRebuildingList > 0) or (FSettingSel > 0) or (Change <> ctState) or + (csDestroying in ListView.ComponentState) then + Exit; + if not PeekMessage(Msg, Handle, CM_DEFERUPDATE, CM_DEFERUPDATE, + PM_NOREMOVE or PM_NOYIELD) then + PostMessage(Handle, CM_DEFERUPDATE, 0, 0); +end; + +procedure TTBItemEditForm.ListViewEnter(Sender: TObject); +begin + { When list view gets the focus, update the toolbar } + SetSelParentItem(FSelParentItem); +end; + +procedure TTBItemEditForm.ListViewDblClick(Sender: TObject); +var + SelItem: TTBCustomItem; + PropCount, I: Integer; + Props: {$IFNDEF CLR} PPropList {$ELSE} TPropList {$ENDIF}; + PropInfo: {$IFNDEF CLR} PPropInfo {$ELSE} TPropInfo {$ENDIF}; + MethodName: String; + Method: TMethod; +begin + SelItem := nil; + if Assigned(ListView.Selected) then + SelItem := TTBCustomItem(ListView.Selected.Data); + if SelItem = nil then Exit; + if IsSubmenuItem(SelItem) then begin + SetSelParentItem(SelItem); + Exit; + end; + {$IFNDEF CLR} + PropCount := GetPropList(SelItem.ClassInfo, [tkMethod], nil); + GetMem(Props, PropCount * SizeOf(PPropInfo)); + try + GetPropList(SelItem.ClassInfo, [tkMethod], Props); + {$ELSE} + Props := GetPropList(SelItem.ClassInfo, [tkMethod]); + PropCount := Length(Props); + {$ENDIF} + for I := PropCount-1 downto 0 do begin + PropInfo := Props[I]; + {$IFNDEF CLR} + if CompareText(String(PropInfo.Name), 'OnClick') = 0 then begin + {$ELSE} + if SameText(PropInfo.Name, 'OnClick', loInvariantLocale) then begin + {$ENDIF} + Method := GetMethodProp(SelItem, PropInfo); + MethodName := Designer.GetMethodName(Method); + if MethodName = '' then begin + MethodName := SelItem.Name + 'Click'; + Method := Designer.CreateMethod(MethodName, GetTypeData( + {$IFNDEF CLR} PropInfo.PropType^ {$ELSE} PropInfo.TypeInfo {$ENDIF})); + SetMethodProp(SelItem, PropInfo, Method); + Designer.Modified; + end; + if Designer.MethodExists(MethodName) then + Designer.ShowMethod(MethodName); + Break; + end; + end; + {$IFNDEF CLR} + finally + FreeMem(Props); + end; + {$ENDIF} +end; + +procedure TTBItemEditForm.ListViewKeyDown(Sender: TObject; var Key: Word; + Shift: TShiftState); +begin + case Key of + VK_RETURN: begin + Key := 0; + ActivateInspector(#0); + end; + VK_INSERT: begin + Key := 0; + if ssCtrl in Shift then + NewSubmenuButtonClick(Sender) + else + NewItemButtonClick(Sender); + end; + VK_DELETE: begin + Key := 0; + Delete; + end; + end; +end; + +procedure TTBItemEditForm.TreeViewKeyDown(Sender: TObject; var Key: Word; + Shift: TShiftState); +begin + case Key of + VK_RETURN: begin + Key := 0; + ActivateInspector(#0); + end; + VK_DELETE: begin + Key := 0; + DeleteButtonClick(Sender); + end; + end; +end; + +procedure TTBItemEditForm.TreeViewKeyPress(Sender: TObject; var Key: Char); +begin + if (Key >= #33) and (Key <= #126) then begin + ActivateInspector(Key); + Key := #0; + end + else if Key = #13 then + Key := #0; { suppress beep } +end; + +procedure TTBItemEditForm.ListViewKeyPress(Sender: TObject; var Key: Char); +begin + if Key = '-' then begin + NewSepButtonClick(Sender); + Key := #0; + end + else if (Key >= #33) and (Key <= #126) then begin + ActivateInspector(Key); + Key := #0; + end; +end; + +procedure TTBItemEditForm.ListViewDragOver(Sender, Source: TObject; X, + Y: Integer; State: TDragState; var Accept: Boolean); +{ List item dragged over the list view } +var + Item: TListItem; +begin + Accept := False; + if (Sender = ListView) and (Source = ListView) and (ListView.SelCount = 1) then begin + Item := ListView.GetItemAt(X, Y); + if Assigned(Item) and (Item <> ListView.Selected) then + Accept := True; + end; +end; + +procedure TTBItemEditForm.ListViewDragDrop(Sender, Source: TObject; X, + Y: Integer); +{ List item dropped onto another list item } +var + ListItem: TListItem; + Item: TTBCustomItem; + NewIndex: Integer; +begin + if (Sender = ListView) and (Source = ListView) and (ListView.SelCount = 1) then begin + ListItem := ListView.GetItemAt(X, Y); + if Assigned(ListItem) and (ListItem <> ListView.Selected) and Assigned(FSelParentItem) then begin + NewIndex := FSelParentItem.IndexOf(TTBCustomItem(ListItem.Data)); + if NewIndex <> -1 then begin + ListView.Items.BeginUpdate; + { For good performance and to prevent Object Inspector flicker, increment + FSettingSel to prevent calls to SetSelParentItem while moving items } + Inc(FSettingSel); + try + Item := TTBCustomItem(ListView.Selected.Data); + MoveItem(FSelParentItem.IndexOf(Item), NewIndex); + finally + Dec(FSettingSel); + ListView.Items.EndUpdate; + end; + { After decrementing FSettingSel, now call SetSelParentItem, to update + the toolbar buttons } + SetSelParentItem(FSelParentItem); + end; + end; + end; +end; + +function TTBItemEditForm.TreeViewDragHandler(Sender, Source: TObject; + X, Y: Integer; Drop: Boolean): Boolean; +var + Node: TTreeNode; + ListItem: TListItem; + Item, NewParentItem: TTBCustomItem; + ItemList: TList; + I: Integer; + NeedRebuildTree: Boolean; +begin + Result := False; + if (Sender = TreeView) and (Source = ListView) then begin + Node := TreeView.GetNodeAt(X, Y); + if Assigned(Node) and (Node <> TreeView.Selected) then begin + NewParentItem := TTBCustomItem(Node.Data); + ItemList := TList.Create; + try + ListItem := nil; + while True do begin + ListItem := ListView.GetNextItem(ListItem, sdAll, [isSelected]); + if ListItem = nil then + Break; + Item := TTBCustomItem(ListItem.Data); + if Assigned(Item) and (Item <> NewParentItem) and + not Item.ContainsItem(NewParentItem) and + not(Item is TTBControlItem) then begin + Result := True; + ItemList.Add(Item); + end; + end; + if Drop then begin + NeedRebuildTree := False; + for I := 0 to ItemList.Count-1 do begin + Item := TTBCustomItem(ItemList[I]); + Item.Parent.Remove(Item); + NewParentItem.Add(Item); + Designer.Modified; + if IsSubmenuItem(Item) then + NeedRebuildTree := True; + end; + if NeedRebuildTree then + RebuildTree; + end; + finally + ItemList.Free; + end; + end; + end; +end; + +procedure TTBItemEditForm.TreeViewDragOver(Sender, Source: TObject; X, + Y: Integer; State: TDragState; var Accept: Boolean); +{ List item dragged over the tree view } +begin + Accept := TreeViewDragHandler(Sender, Source, X, Y, False); +end; + +procedure TTBItemEditForm.TreeViewDragDrop(Sender, Source: TObject; X, + Y: Integer); +{ List item dropped onto the tree view } +begin + TreeViewDragHandler(Sender, Source, X, Y, True); +end; + +procedure TTBItemEditForm.CreateNewItem(const AClass: TTBCustomItemClass); +var + NewIndex: Integer; + NewItem: TTBCustomItem; + ListItem: TListItem; +begin + if FSelParentItem = nil then Exit; + NewIndex := -1; + if (GetKeyState(VK_SHIFT) >= 0) and Assigned(ListView.Selected) then + NewIndex := FSelParentItem.IndexOf(TTBCustomItem(ListView.Selected.Data)); + if NewIndex = -1 then + NewIndex := FSelParentItem.Count; + NewItem := AClass.Create(FParentComponent.Owner{Designer.Form}); + try + NewItem.Name := Designer.UniqueName(NewItem.ClassName); + FSelParentItem.Insert(NewIndex, NewItem); + except + NewItem.Free; + raise; + end; + Designer.Modified; + ListView.Selected := nil; + ListItem := ListView.FindData(0, NewItem, True, False); + if Assigned(ListItem) then begin + ListItem.Selected := True; + ListItem.Focused := True; + ListItem.MakeVisible(False); + ListView.SetFocus; + end; +end; + +procedure TTBItemEditForm.NewSubmenuButtonClick(Sender: TObject); +begin + CreateNewItem(TTBSubmenuItem); +end; + +procedure TTBItemEditForm.NewItemButtonClick(Sender: TObject); +begin + CreateNewItem(TTBItem); +end; + +procedure TTBItemEditForm.NewSepButtonClick(Sender: TObject); +begin + CreateNewItem(TTBSeparatorItem); +end; + +procedure TTBItemEditForm.MoreItemClick(Sender: TObject); +begin + CreateNewItem(TTBCustomItemClass((Sender as TTBItem).Tag)); +end; + +procedure TTBItemEditForm.CutButtonClick(Sender: TObject); +begin + Cut; +end; + +procedure TTBItemEditForm.CopyButtonClick(Sender: TObject); +begin + Copy; +end; + +procedure TTBItemEditForm.PasteButtonClick(Sender: TObject); +begin + Paste; +end; + +procedure TTBItemEditForm.DeleteButtonClick(Sender: TObject); +begin + if ActiveControl = ListView then + Delete + else if (ActiveControl = TreeView) and (FSelParentItem <> FRootItem) then + DeleteItem(FSelParentItem); +end; + +procedure TTBItemEditForm.MoveUpButtonClick(Sender: TObject); +var + SelList: TList; + I, J: Integer; + Item: TTBCustomItem; + ListItem: TListItem; +begin + if FSelParentItem = nil then Exit; + SelList := TList.Create; + try + GetSelItemList(SelList); + if SelList.Count = 0 then Exit; + + ListView.Items.BeginUpdate; + FSelParentItem.ViewBeginUpdate; + { For good performance and to prevent Object Inspector flicker, increment + FSettingSel to prevent calls to SetSelParentItem while moving items } + Inc(FSettingSel); + try + for I := 0 to SelList.Count-1 do begin + Item := TTBCustomItem(SelList[I]); + J := FSelParentItem.IndexOf(Item); + if J <> -1 then + MoveItem(J, J-1); + end; + ListItem := ListView.FindData(0, SelList[0], True, False); + if Assigned(ListItem) then + ListItem.MakeVisible(False); + finally + Dec(FSettingSel); + FSelParentItem.ViewEndUpdate; + ListView.Items.EndUpdate; + end; + { After decrementing FSettingSel, now call SetSelParentItem, to update + the toolbar buttons } + SetSelParentItem(FSelParentItem); + finally + SelList.Free; + end; +end; + +procedure TTBItemEditForm.MoveDownButtonClick(Sender: TObject); +var + SelList: TList; + I, J: Integer; + Item: TTBCustomItem; + ListItem: TListItem; +begin + if FSelParentItem = nil then Exit; + SelList := TList.Create; + try + GetSelItemList(SelList); + if SelList.Count = 0 then Exit; + + ListView.Items.BeginUpdate; + FSelParentItem.ViewBeginUpdate; + { For good performance and to prevent Object Inspector flicker, increment + FSettingSel to prevent calls to SetSelParentItem while moving items } + Inc(FSettingSel); + try + for I := SelList.Count-1 downto 0 do begin + Item := TTBCustomItem(SelList[I]); + J := FSelParentItem.IndexOf(Item); + if J <> -1 then + MoveItem(J, J+1); + end; + ListItem := ListView.FindData(0, SelList[SelList.Count-1], True, False); + if Assigned(ListItem) then + ListItem.MakeVisible(False); + finally + Dec(FSettingSel); + FSelParentItem.ViewEndUpdate; + ListView.Items.EndUpdate; + end; + { After decrementing FSettingSel, now call SetSelParentItem, to update + the toolbar buttons } + SetSelParentItem(FSelParentItem); + finally + SelList.Free; + end; +end; + +procedure TTBItemEditForm.TConvertMenuClick(Sender: TObject); +begin + if FSelParentItem = nil then Exit; + DoConvert(FSelParentItem, FParentComponent.Owner); +end; + + +{ TTBItemsEditor } + +procedure TTBItemsEditor.Edit; +var + Item: TTBCustomItem; +begin + if Assigned(Component) then begin + Item := TBGetItems(Component); + if Assigned(Item) then + ShowEditForm(Component, Item, Designer); + end; +end; + +procedure TTBItemsEditor.ExecuteVerb(Index: Integer); +begin + case Index of + 0: Edit; + 1: ShowVersion; + end; +end; + +function TTBItemsEditor.GetVerbCount: Integer; +begin + Result := 2; +end; + +function TTBItemsEditor.GetVerb(Index: Integer): String; +begin + case Index of + 0: Result := 'Edit...'; + 1: Result := 'Version...'; + else + Result := ''; + end; +end; + + +{ TTBItemsPropertyEditor } + +procedure TTBItemsPropertyEditor.Edit; +var + Editor: {$IFDEF JR_D6} IComponentEditor {$ELSE} TComponentEditor {$ENDIF}; +begin + if PropCount <> 1 then Exit; + Editor := GetComponentEditor(GetComponent(0) as TComponent, Designer); + try + Editor.Edit; + finally + {$IFNDEF JR_D6} + Editor.Free; + {$ENDIF} + end; +end; + +function TTBItemsPropertyEditor.GetAttributes: TPropertyAttributes; +begin + Result := inherited GetAttributes + [paDialog, paReadOnly]; +end; + +function TTBItemsPropertyEditor.GetValue: String; +begin + Result := '(TB2000 Items)'; +end; + +initialization + ItemImageList := TImageList.Create(nil); + {$IFNDEF CLR} + ItemImageList.Handle := ImageList_LoadImage(HInstance, 'TB2_DSGNEDITORIMAGES', + 16, 0, clFuchsia, IMAGE_BITMAP, 0); + {$ELSE} + { Initialize the image list as plain ILC_COLOR (4-bit), because on Windows + 2000, at color depths > 16 (what TImageList's ILC_COLORDDB would give us + when running on a true-color display), selected images are drawn with an + ugly dithering effect } + ItemImageList.Handle := ImageList_Create(16, 16, ILC_COLOR or ILC_MASK, 4, 4); + LoadItemImage(Assembly.GetExecutingAssembly, 'TB2DsgnEditorImages.bmp'); + {$ENDIF} + ItemClasses := TList.Create; + {$IFNDEF CLR} + AddModuleUnloadProc(UnregisterModuleItemClasses); + {$ENDIF} +finalization + {$IFNDEF CLR} + RemoveModuleUnloadProc(UnregisterModuleItemClasses); + {$ENDIF} + FreeItemClasses; + FreeAndNil(ItemImageList); +end. diff --git a/internal/2.2.2/1/Source/TB2DsgnItemEditor.res b/internal/2.2.2/1/Source/TB2DsgnItemEditor.res new file mode 100644 index 0000000..938763e Binary files /dev/null and b/internal/2.2.2/1/Source/TB2DsgnItemEditor.res differ diff --git a/internal/2.2.2/1/Source/TB2ExtItems.pas b/internal/2.2.2/1/Source/TB2ExtItems.pas new file mode 100644 index 0000000..1442793 --- /dev/null +++ b/internal/2.2.2/1/Source/TB2ExtItems.pas @@ -0,0 +1,990 @@ +unit TB2ExtItems; + +{ + Toolbar2000 + Copyright (C) 1998-2008 by Jordan Russell + All rights reserved. + + The contents of this file are subject to the "Toolbar2000 License"; you may + not use or distribute this file except in compliance with the + "Toolbar2000 License". A copy of the "Toolbar2000 License" may be found in + TB2k-LICENSE.txt or at: + http://www.jrsoftware.org/files/tb2k/TB2k-LICENSE.txt + + Alternatively, the contents of this file may be used under the terms of the + GNU General Public License (the "GPL"), in which case the provisions of the + GPL are applicable instead of those in the "Toolbar2000 License". A copy of + the GPL may be found in GPL-LICENSE.txt or at: + http://www.jrsoftware.org/files/tb2k/GPL-LICENSE.txt + If you wish to allow use of your version of this file only under the terms of + the GPL and not to allow others to use your version of this file under the + "Toolbar2000 License", indicate your decision by deleting the provisions + above and replace them with the notice and other provisions required by the + GPL. If you do not delete the provisions above, a recipient may use your + version of this file under either the "Toolbar2000 License" or the GPL. + + $jrsoftware: tb2k/Source/TB2ExtItems.pas,v 1.68 2008/04/10 21:51:12 jr Exp $ +} + +interface + +{$I TB2Ver.inc} + +uses + Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs, + StdCtrls, CommCtrl, Menus, ActnList, + TB2Item; + +type + TTBEditItemOption = (tboUseEditWhenVertical); + TTBEditItemOptions = set of TTBEditItemOption; + +const + EditItemDefaultEditOptions = []; + EditItemDefaultEditWidth = 64; + +type + TTBEditItem = class; + TTBEditItemViewer = class; + + TTBAcceptTextEvent = procedure(Sender: TObject; var NewText: String; + var Accept: Boolean) of object; + TTBBeginEditEvent = procedure(Sender: TTBEditItem; Viewer: TTBEditItemViewer; + EditControl: TEdit) of object; + + TTBEditAction = class(TAction) + private + FEditOptions: TTBEditItemOptions; + FEditCaption: String; + FEditWidth: Integer; + FOnAcceptText: TTBAcceptTextEvent; + FText: String; + procedure SetEditCaption(Value: String); + procedure SetEditOptions(Value: TTBEditItemOptions); + procedure SetEditWidth(Value: Integer); + procedure SetOnAcceptText(Value: TTBAcceptTextEvent); + procedure SetText(Value: String); + public + constructor Create(AOwner: TComponent); override; + published + property EditCaption: String read FEditCaption write SetEditCaption; + property EditOptions: TTBEditItemOptions read FEditOptions write SetEditOptions default EditItemDefaultEditOptions; + property EditWidth: Integer read FEditWidth write SetEditWidth default EditItemDefaultEditWidth; + property Text: String read FText write SetText; + + property OnAcceptText: TTBAcceptTextEvent read FOnAcceptText write SetOnAcceptText; + end; + + TTBEditItemActionLink = class(TTBCustomItemActionLink) + protected + procedure AssignClient(AClient: TObject); override; + function IsEditCaptionLinked: Boolean; virtual; + function IsEditOptionsLinked: Boolean; virtual; + function IsEditWidthLinked: Boolean; virtual; + function IsOnAcceptTextLinked: Boolean; virtual; + function IsTextLinked: Boolean; virtual; + procedure SetEditCaption(const Value: String); virtual; + procedure SetEditOptions(Value: TTBEditItemOptions); virtual; + procedure SetEditWidth(const Value: Integer); virtual; + procedure SetOnAcceptText(Value: TTBAcceptTextEvent); virtual; + procedure SetText(const Value: String); virtual; + end; + + TTBEditItem = class(TTBCustomItem) + private + FCharCase: TEditCharCase; + FEditCaption: String; + FEditOptions: TTBEditItemOptions; + FEditWidth: Integer; + FMaxLength: Integer; + FOnAcceptText: TTBAcceptTextEvent; + FOnBeginEdit: TTBBeginEditEvent; + FText: String; + function IsEditCaptionStored: Boolean; + function IsEditOptionsStored: Boolean; + function IsEditWidthStored: Boolean; + function IsTextStored: Boolean; + procedure SetCharCase(Value: TEditCharCase); + procedure SetEditCaption(Value: String); + procedure SetEditOptions(Value: TTBEditItemOptions); + procedure SetEditWidth(Value: Integer); + procedure SetMaxLength(Value: Integer); + procedure SetText(Value: String); + protected + procedure ActionChange(Sender: TObject; CheckDefaults: Boolean); override; + procedure DoBeginEdit(Viewer: TTBEditItemViewer); virtual; + function GetActionLinkClass: TTBCustomItemActionLinkClass; override; + function GetItemViewerClass(AView: TTBView): TTBItemViewerClass; override; + function NeedToRecreateViewer(AViewer: TTBItemViewer): Boolean; override; + public + constructor Create(AOwner: TComponent); override; + procedure Clear; + procedure Click; override; + published + property Action; + property AutoCheck; + property Caption; + property CharCase: TEditCharCase read FCharCase write SetCharCase default ecNormal; + property Checked; + property DisplayMode; + property EditCaption: String read FEditCaption write SetEditCaption stored IsEditCaptionStored; + property EditOptions: TTBEditItemOptions read FEditOptions write SetEditOptions stored IsEditOptionsStored; + property EditWidth: Integer read FEditWidth write SetEditWidth stored IsEditWidthStored; + property MaxLength: Integer read FMaxLength write SetMaxLength default 0; + property Enabled; + property GroupIndex; + property HelpContext; + property Hint; + property ImageIndex; + property InheritOptions; + property MaskOptions; + property Options; + property RadioItem; + property ShortCut; + property Text: String read FText write SetText stored IsTextStored; + property Visible; + + property OnAcceptText: TTBAcceptTextEvent read FOnAcceptText write FOnAcceptText; + property OnBeginEdit: TTBBeginEditEvent read FOnBeginEdit write FOnBeginEdit; + property OnClick; + property OnSelect; + end; + + TTBEditItemViewer = class(TTBItemViewer) + private + FEditControl: TEdit; + FEditControlStatus: set of (ecsContinueLoop, ecsAccept, ecsClose); + function EditLoop(const CapHandle: HWND): Boolean; + procedure EditWndProc(var Message: TMessage); + procedure MouseBeginEdit; + protected + procedure CalcSize(const Canvas: TCanvas; var AWidth, AHeight: Integer); + override; + function CaptionShown: Boolean; override; + function DoExecute: Boolean; override; + function GetAccRole: Integer; override; + function GetAccValue(var Value: WideString): Boolean; override; + function GetCaptionText: String; override; + procedure GetCursor(const Pt: TPoint; var ACursor: HCURSOR); override; + procedure GetEditRect(var R: TRect); virtual; + procedure MouseDown(Shift: TShiftState; X, Y: Integer; + var MouseDownOnMenu: Boolean); override; + procedure MouseUp(X, Y: Integer; MouseWasDownOnMenu: Boolean); override; + procedure Paint(const Canvas: TCanvas; const ClientAreaRect: TRect; + IsSelected, IsPushed, UseDisabledShadow: Boolean); override; + function UsesSameWidth: Boolean; override; + public + property EditControl: TEdit read FEditControl; + end; + + { TTBVisibilityToggleItem } + + TTBVisibilityToggleItem = class(TTBCustomItem) + private + FControl: TControl; + procedure SetControl(Value: TControl); + procedure UpdateProps; + protected + procedure Notification(AComponent: TComponent; Operation: TOperation); override; + public + procedure Click; override; + procedure InitiateAction; override; + published + property Caption; + property Control: TControl read FControl write SetControl; + property DisplayMode; + property Enabled; + property HelpContext; + property Hint; + property ImageIndex; + property Images; + property InheritOptions; + property MaskOptions; + property Options; + property ShortCut; + property Visible; + + property OnClick; + property OnSelect; + end; + + +implementation + +uses + TB2Common, TB2Consts; + +const + EditMenuTextMargin = 3; + EditMenuMidWidth = 4; + +type + TControlAccess = class(TControl); + TEditAccess = {$IFNDEF CLR} class(TEdit) {$ELSE} IControl {$ENDIF}; + + +{ TTBEditAction } + +constructor TTBEditAction.Create(AOwner: TComponent); +begin + inherited; + FEditOptions := EditItemDefaultEditOptions; + FEditWidth := EditItemDefaultEditWidth; + DisableIfNoHandler := False; +end; + +procedure TTBEditAction.SetEditCaption(Value: String); +var + I: Integer; +begin + if FEditCaption <> Value then begin + for I := 0 to FClients.Count - 1 do + if TBasicActionLink(FClients[I]) is TTBEditItemActionLink then + TTBEditItemActionLink(FClients[I]).SetEditCaption(Value); + FEditCaption := Value; + Change; + end; +end; + +procedure TTBEditAction.SetEditOptions(Value: TTBEditItemOptions); +var + I: Integer; +begin + if FEditOptions <> Value then begin + for I := 0 to FClients.Count - 1 do + if TBasicActionLink(FClients[I]) is TTBEditItemActionLink then + TTBEditItemActionLink(FClients[I]).SetEditOptions(Value); + FEditOptions := Value; + Change; + end; +end; + +procedure TTBEditAction.SetEditWidth(Value: Integer); +var + I: Integer; +begin + if FEditWidth <> Value then begin + for I := 0 to FClients.Count - 1 do + if TBasicActionLink(FClients[I]) is TTBEditItemActionLink then + TTBEditItemActionLink(FClients[I]).SetEditWidth(Value); + FEditWidth := Value; + Change; + end; +end; + +procedure TTBEditAction.SetOnAcceptText(Value: TTBAcceptTextEvent); +var + I: Integer; +begin + {$IFNDEF CLR} + if not MethodsEqual(TMethod(FOnAcceptText), TMethod(Value)) then begin + {$ELSE} + if @FOnAcceptText <> @Value then begin + {$ENDIF} + for I := 0 to FClients.Count - 1 do + if TBasicActionLink(FClients[I]) is TTBEditItemActionLink then + TTBEditItemActionLink(FClients[I]).SetOnAcceptText(Value); + FOnAcceptText := Value; + Change; + end; +end; + +procedure TTBEditAction.SetText(Value: String); +var + I: Integer; +begin + if FText <> Value then begin + for I := 0 to FClients.Count - 1 do + if TBasicActionLink(FClients[I]) is TTBEditItemActionLink then + TTBEditItemActionLink(FClients[I]).SetText(Value); + FText := Value; + Change; + end; +end; + + +{ TTBEditItemActionLink } + +procedure TTBEditItemActionLink.AssignClient(AClient: TObject); +begin + FClient := AClient as TTBEditItem; +end; + +function TTBEditItemActionLink.IsEditCaptionLinked: Boolean; +begin + if Action is TTBEditAction then + Result := TTBEditItem(FClient).EditCaption = TTBEditAction(Action).EditCaption + else + Result := False; +end; + +function TTBEditItemActionLink.IsEditOptionsLinked: Boolean; +begin + if Action is TTBEditAction then + Result := TTBEditItem(FClient).EditOptions = TTBEditAction(Action).EditOptions + else + Result := False; +end; + +function TTBEditItemActionLink.IsEditWidthLinked: Boolean; +begin + if Action is TTBEditAction then + Result := TTBEditItem(FClient).EditWidth = TTBEditAction(Action).EditWidth + else + Result := False; +end; + +function TTBEditItemActionLink.IsOnAcceptTextLinked: Boolean; +begin + if Action is TTBEditAction then + {$IFNDEF CLR} + Result := MethodsEqual(TMethod(TTBEditItem(FClient).OnAcceptText), + TMethod(TTBEditAction(Action).OnAcceptText)) + {$ELSE} + Result := @TTBEditItem(FClient).OnAcceptText = @TTBEditAction(Action).OnAcceptText + {$ENDIF} + else + Result := False; +end; + +function TTBEditItemActionLink.IsTextLinked: Boolean; +begin + if Action is TTBEditAction then + Result := TTBEditItem(FClient).Text = TTBEditAction(Action).Text + else + Result := False; +end; + +procedure TTBEditItemActionLink.SetEditCaption(const Value: String); +begin + if IsEditCaptionLinked then TTBEditItem(FClient).EditCaption := Value; +end; + +procedure TTBEditItemActionLink.SetEditOptions(Value: TTBEditItemOptions); +begin + if IsEditOptionsLinked then TTBEditItem(FClient).EditOptions := Value; +end; + +procedure TTBEditItemActionLink.SetEditWidth(const Value: Integer); +begin + if IsEditWidthLinked then TTBEditItem(FClient).EditWidth := Value; +end; + +procedure TTBEditItemActionLink.SetOnAcceptText(Value: TTBAcceptTextEvent); +begin + if IsOnAcceptTextLinked then TTBEditItem(FClient).OnAcceptText := Value; +end; + +procedure TTBEditItemActionLink.SetText(const Value: String); +begin + if IsTextLinked then TTBEditItem(FClient).Text := Value; +end; + + +{ TTBEditItem } + +constructor TTBEditItem.Create(AOwner: TComponent); +begin + inherited; + FEditOptions := EditItemDefaultEditOptions; + FEditWidth := EditItemDefaultEditWidth; +end; + +procedure TTBEditItem.ActionChange(Sender: TObject; CheckDefaults: Boolean); +begin + inherited; + if Action is TTBEditAction then + with TTBEditAction(Sender) do + begin + if not CheckDefaults or (Self.EditCaption = '') then + Self.EditCaption := EditCaption; + if not CheckDefaults or (Self.EditOptions = []) then + Self.EditOptions := EditOptions; + if not CheckDefaults or (Self.Text = '') then + Self.Text := Text; + if not CheckDefaults or not Assigned(Self.OnAcceptText) then + Self.OnAcceptText := OnAcceptText; + end; +end; + +function TTBEditItem.GetActionLinkClass: TTBCustomItemActionLinkClass; +begin + Result := TTBEditItemActionLink; +end; + +function TTBEditItem.GetItemViewerClass(AView: TTBView): TTBItemViewerClass; +begin + if not(tboUseEditWhenVertical in EditOptions) and + (AView.Orientation = tbvoVertical) then + Result := inherited GetItemViewerClass(AView) + else + Result := TTBEditItemViewer; +end; + +function TTBEditItem.NeedToRecreateViewer(AViewer: TTBItemViewer): Boolean; +begin + Result := GetItemViewerClass(AViewer.View) <> AViewer.ClassType; +end; + +procedure TTBEditItem.Clear; +begin + Text := ''; +end; + +procedure TTBEditItem.Click; +begin + inherited; +end; + +procedure TTBEditItem.DoBeginEdit(Viewer: TTBEditItemViewer); +begin + if Assigned(FOnBeginEdit) then + FOnBeginEdit(Self, Viewer, Viewer.EditControl); +end; + +function TTBEditItem.IsEditOptionsStored: Boolean; +begin + Result := (EditOptions <> EditItemDefaultEditOptions) and + ((ActionLink = nil) or not(ActionLink is TTBEditItemActionLink) or + not TTBEditItemActionLink(ActionLink).IsEditOptionsLinked); +end; + +function TTBEditItem.IsEditCaptionStored: Boolean; +begin + Result := (ActionLink = nil) or not(ActionLink is TTBEditItemActionLink) or + not TTBEditItemActionLink(ActionLink).IsEditCaptionLinked; +end; + +function TTBEditItem.IsEditWidthStored: Boolean; +begin + Result := (EditWidth <> EditItemDefaultEditWidth) and + ((ActionLink = nil) or not(ActionLink is TTBEditItemActionLink) or + not TTBEditItemActionLink(ActionLink).IsEditWidthLinked); +end; + +function TTBEditItem.IsTextStored: Boolean; +begin + Result := (ActionLink = nil) or not(ActionLink is TTBEditItemActionLink) or + not TTBEditItemActionLink(ActionLink).IsTextLinked; +end; + +procedure TTBEditItem.SetCharCase(Value: TEditCharCase); +begin + if FCharCase <> Value then begin + FCharCase := Value; + Text := Text; { update case } + end; +end; + +procedure TTBEditItem.SetEditOptions(Value: TTBEditItemOptions); +begin + if FEditOptions <> Value then begin + FEditOptions := Value; + Change(True); + end; +end; + +procedure TTBEditItem.SetEditCaption(Value: String); +begin + if FEditCaption <> Value then begin + FEditCaption := Value; + Change(True); + end; +end; + +procedure TTBEditItem.SetEditWidth(Value: Integer); +begin + if FEditWidth <> Value then begin + FEditWidth := Value; + Change(True); + end; +end; + +procedure TTBEditItem.SetMaxLength(Value: Integer); +begin + if FMaxLength <> Value then begin + FMaxLength := Value; + Change(False); + end; +end; + +procedure TTBEditItem.SetText(Value: String); +begin + case FCharCase of + ecUpperCase: Value := {$IFNDEF CLR} AnsiUpperCase {$ELSE} UpperCase {$ENDIF} (Value); + ecLowerCase: Value := {$IFNDEF CLR} AnsiLowerCase {$ELSE} LowerCase {$ENDIF} (Value); + end; + if FText <> Value then begin + FText := Value; + Change(False); + end; +end; + + +{ TTBEditItemViewer } + +procedure TTBEditItemViewer.EditWndProc(var Message: TMessage); +var + Item: TTBEditItem; + + procedure AcceptText; + var + S: String; + Accept: Boolean; + begin + S := FEditControl.Text; + Accept := True; + if Assigned(Item.FOnAcceptText) then + Item.FOnAcceptText(Self, S, Accept); + if Accept then + Item.Text := S; + end; + +begin + Item := TTBEditItem(Self.Item); + if Message.Msg = WM_CHAR then + case Word(Message.WParam) of + VK_TAB: begin + FEditControlStatus := [ecsAccept]; + AcceptText; + Exit; + end; + VK_RETURN: begin + FEditControlStatus := [ecsAccept, ecsClose]; + AcceptText; + Exit; + end; + VK_ESCAPE: begin + FEditControlStatus := []; + Exit; + end; + end; + TEditAccess(FEditControl).WndProc(Message); + if Message.Msg = WM_KILLFOCUS then begin + { Someone has stolen the focus from us, so 'cancel mode'. (We have to + handle WM_KILLFOCUS in addition to the upstream WM_CANCELMODE handling + since we don't always hold the mouse capture.) } + View.CancelMode; + FEditControlStatus := [ecsClose]; + end; +end; + +procedure TTBEditItemViewer.GetEditRect(var R: TRect); +var + Item: TTBEditItem; + DC: HDC; +begin + Item := TTBEditItem(Self.Item); + DC := GetDC(0); + try + SelectObject(DC, View.GetFont.Handle); + R := BoundsRect; + if not View.IsToolbar and (Item.EditCaption <> '') then begin + Inc(R.Left, GetTextWidth(DC, Item.EditCaption, True) + + EditMenuMidWidth + EditMenuTextMargin * 2); + end; + finally + ReleaseDC(0, DC); + end; +end; + +procedure TTBEditItemViewer.CalcSize(const Canvas: TCanvas; + var AWidth, AHeight: Integer); +var + Item: TTBEditItem; + DC: HDC; +begin + Item := TTBEditItem(Self.Item); + DC := Canvas.Handle; + AWidth := Item.FEditWidth; + AHeight := GetTextHeight(DC) + (EditMenuTextMargin * 2) + 1; + if not IsToolbarStyle and (Item.EditCaption <> '') then begin + Inc(AWidth, GetTextWidth(DC, Item.EditCaption, True) + EditMenuMidWidth + + EditMenuTextMargin * 2); + end; + { Review: Should the height include external leading on fonts that use it, + such as the default menu font on Windows Me Trad. Chinese? Office 2000 + seems to insist on using Tahoma on Chinese Windows, so I'm not sure how it + handles external leading on edit items. } +end; + +function TTBEditItemViewer.CaptionShown: Boolean; +begin + Result := not IsToolbarStyle and inherited CaptionShown; +end; + +function TTBEditItemViewer.GetCaptionText: String; +begin + Result := TTBEditItem(Item).EditCaption; +end; + +procedure TTBEditItemViewer.Paint(const Canvas: TCanvas; + const ClientAreaRect: TRect; IsSelected, IsPushed, UseDisabledShadow: Boolean); +const + FillColors: array[Boolean] of TColor = (clBtnFace, clWindow); + TextColors: array[Boolean] of TColor = (clGrayText, clWindowText); +var + Item: TTBEditItem; + S: String; + R: TRect; + W: Integer; +begin + Item := TTBEditItem(Self.Item); + R := ClientAreaRect; + + { Caption } + if not IsToolbarStyle and (Item.EditCaption <> '') then begin + S := Item.EditCaption; + W := GetTextWidth(Canvas.Handle, S, True) + EditMenuTextMargin * 2; + R.Right := R.Left + W; + if IsSelected then + Canvas.FillRect(R); + Inc(R.Left, EditMenuTextMargin); + DrawItemCaption(Canvas, R, S, UseDisabledShadow, DT_SINGLELINE or + DT_LEFT or DT_VCENTER); + R := ClientAreaRect; + Inc(R.Left, W + EditMenuMidWidth); + end; + + { Border } + if IsSelected and Item.Enabled then + DrawEdge(Canvas.Handle, R, BDR_SUNKENOUTER, BF_RECT); + InflateRect(R, -1, -1); + Canvas.Brush.Color := FillColors[not Item.Enabled]; + Canvas.FrameRect(R); + InflateRect(R, -1, -1); + + { Fill } + Canvas.Brush.Color := FillColors[Item.Enabled]; + Canvas.FillRect(R); + InflateRect(R, -1, -1); + + { Text } + if Item.Text <> '' then begin + S := Item.Text; + Canvas.Brush.Style := bsClear; { speed optimization } + Canvas.Font.Color := TextColors[Item.Enabled]; + DrawTextStr(Canvas.Handle, S, R, DT_SINGLELINE or DT_NOPREFIX); + end; +end; + +procedure TTBEditItemViewer.GetCursor(const Pt: TPoint; var ACursor: HCURSOR); +var + R: TRect; +begin + if not Item.Enabled then + Exit; + GetEditRect(R); + OffsetRect(R, -BoundsRect.Left, -BoundsRect.Top); + InflateRect(R, -2, -2); + if PtInRect(R, Pt) then + ACursor := LoadCursor(0, IDC_IBEAM); +end; + +function TTBEditItemViewer.EditLoop(const CapHandle: HWND): Boolean; + + procedure ControlMessageLoop; + + function PointInWindow(const Wnd: HWND; const P: TPoint): Boolean; + var + W: HWND; + begin + Result := False; + W := WindowFromPoint(P); + if W = 0 then Exit; + if W = Wnd then + Result := True + else + if IsChild(Wnd, W) then + Result := True; + end; + + function ContinueLoop: Boolean; + begin + Result := (ecsContinueLoop in FEditControlStatus) and + not View.IsModalEnding and FEditControl.Focused and Item.Enabled; + { Note: View.IsModalEnding is checked since TTBView.CancelMode doesn't + destroy popup windows; it merely hides them and calls EndModal. So if + IsModalEnding returns True we can infer that CancelMode was likely + called. } + end; + + var + Msg: TMsg; + IsKeypadDigit: Boolean; + ScanCode: Byte; + V: Integer; + begin + try + while ContinueLoop do begin + { Examine the next message before popping it out of the queue } + if not PeekMessage(Msg, 0, 0, 0, PM_NOREMOVE) then begin + WaitMessage; + Continue; + end; + case Msg.message of + WM_SYSKEYDOWN: begin + { Exit immediately if Alt+[key] or F10 are pressed, but not + Alt+Shift, Alt+`, or Alt+[keypad digit] } + if not(Word(Msg.wParam) in [VK_MENU, VK_SHIFT, VK_HANJA]) then begin + IsKeypadDigit := False; + { This detect digits regardless of whether Num Lock is on: } + ScanCode := Byte(Msg.lParam shr 16); + if ScanCode <> 0 then + for V := VK_NUMPAD0 to VK_NUMPAD9 do + if MapVirtualKey(V, 0) = ScanCode then begin + IsKeypadDigit := True; + Break; + end; + if not IsKeypadDigit then begin + FEditControlStatus := [ecsClose]; + Exit; + end; + end; + end; + WM_SYSKEYUP: begin + { Exit when Alt is released by itself } + if Word(Msg.wParam) = VK_MENU then begin + FEditControlStatus := [ecsClose]; + Exit; + end; + end; + WM_LBUTTONDOWN, WM_LBUTTONDBLCLK, + WM_RBUTTONDOWN, WM_RBUTTONDBLCLK, + WM_MBUTTONDOWN, WM_MBUTTONDBLCLK, + WM_NCLBUTTONDOWN, WM_NCLBUTTONDBLCLK, + WM_NCRBUTTONDOWN, WM_NCRBUTTONDBLCLK, + WM_NCMBUTTONDOWN, WM_NCMBUTTONDBLCLK: begin + { If a mouse click outside the edit control is in the queue, + exit and let the upstream message loop deal with it } + if Msg.hwnd <> FEditControl.Handle then + Exit; + end; + WM_MOUSEMOVE, WM_NCMOUSEMOVE: begin + if GetCapture = CapHandle then begin + if PointInWindow(FEditControl.Handle, Msg.pt) then + ReleaseCapture; + end + else if GetCapture = 0 then begin + if not PointInWindow(FEditControl.Handle, Msg.pt) then + SetCapture(CapHandle); + end; + if GetCapture = CapHandle then + SetCursor(LoadCursor(0, IDC_ARROW)); + end; + end; + { Now pop the message out of the queue } + if not PeekMessage(Msg, 0, Msg.message, Msg.message, PM_REMOVE or PM_NOYIELD) then + Continue; + if ((Msg.message >= WM_MOUSEFIRST) and (Msg.message <= WM_MOUSELAST)) and + (Msg.hwnd = CapHandle) then + { discard, so that the selection doesn't get changed } + else begin + TranslateMessage(Msg); + DispatchMessage(Msg); + end; + end; + finally + { Make sure there are no outstanding WM_*CHAR messages } + RemoveMessages(WM_CHAR, WM_DEADCHAR); + RemoveMessages(WM_SYSCHAR, WM_SYSDEADCHAR); + end; + end; + + procedure RestoreEditControlWndProc; + {$IFNDEF CLR} + var + OrigWndProc: TWndMethod; + begin + { NOTE: We can't assign WndProc to WindowProc directly because on Delphi 4 + and 5, the compiler generates incorrect code, causing an AV at run-time } + OrigWndProc := TEditAccess(FEditControl).WndProc; + FEditControl.WindowProc := OrigWndProc; + end; + {$ELSE} + begin + IControl(FEditControl).RestoreWndProc; + end; + {$ENDIF} + +var + Item: TTBEditItem; + R: TRect; + ActiveWnd, FocusWnd: HWND; +begin + Item := TTBEditItem(Self.Item); + GetEditRect(R); + if IsRectEmpty(R) then begin + Result := False; + Exit; + end; + + ActiveWnd := GetActiveWindow; + FocusWnd := GetFocus; + + { Create the edit control } + InflateRect(R, -3, -3); + //View.FreeNotification(Self); + FEditControl := TEdit.Create(nil); + try + FEditControl.Visible := False; + FEditControl.BorderStyle := bsNone; + FEditControl.AutoSize := False; + FEditControl.Font.Assign(View.GetFont); + FEditControl.Text := Item.Text; + FEditControl.CharCase := Item.FCharCase; + FEditControl.MaxLength := Item.FMaxLength; + FEditControl.BoundsRect := R; + FEditControl.WindowProc := EditWndProc; + FEditControl.ParentWindow := View.Window.Handle; + FEditControl.SelectAll; + Item.DoBeginEdit(Self); + FEditControl.Visible := True; + FEditControl.SetFocus; + if GetActiveWindow <> ActiveWnd then + { don't gray out title bar of old active window } + SendMessage(ActiveWnd, WM_NCACTIVATE, 1, 0) + else + ActiveWnd := 0; + + FEditControlStatus := [ecsContinueLoop]; + ControlMessageLoop; + finally + { Restore the original window procedure before destroying the control so + it doesn't see a WM_KILLFOCUS message } + RestoreEditControlWndProc; + FreeAndNil(FEditControl); + end; + + { ensure the area underneath the edit control is repainted immediately } + View.Window.Update; + { If app is still active, set focus to previous control and restore capture + to CapHandle if another control hasn't taken it } + if GetActiveWindow <> 0 then begin + SetFocus(FocusWnd); + if GetCapture = 0 then + SetCapture(CapHandle); + end; + if ActiveWnd <> 0 then + SendMessage(ActiveWnd, WM_NCACTIVATE, Ord(GetActiveWindow = ActiveWnd), 0); + { The SetFocus call above can change the Z order of windows. If the parent + window is a popup window, reassert its topmostness. } + if View.Window is TTBPopupWindow then + SetWindowPos(View.Window.Handle, HWND_TOPMOST, 0, 0, 0, 0, + SWP_NOACTIVATE or SWP_NOMOVE or SWP_NOSIZE); + { Send an MSAA "focus" event now that we're returning to the regular modal loop } + View.NotifyFocusEvent; + + Result := ecsClose in FEditControlStatus; + if not Result and (GetCapture = CapHandle) then begin + if ecsAccept in FEditControlStatus then + { if we are accepting but not closing, Tab must have been pressed } + View.Selected := View.NextSelectable(View.Selected, + GetKeyState(VK_SHIFT) >= 0); + end; +end; + +function TTBEditItemViewer.DoExecute: Boolean; +begin + { Close any delay-close popup menus before entering the edit loop } + View.CancelChildPopups; + Result := False; + if EditLoop(View.GetCaptureWnd) then begin + View.EndModal; + if ecsAccept in FEditControlStatus then + Result := True; + end; +end; + +procedure TTBEditItemViewer.MouseBeginEdit; +begin + if Item.Enabled then + Execute(True) + else begin + if (View.ParentView = nil) and not View.IsPopup then + View.EndModal; + end; +end; + +procedure TTBEditItemViewer.MouseDown(Shift: TShiftState; X, Y: Integer; + var MouseDownOnMenu: Boolean); +begin + if IsPtInButtonPart(X, Y) then { for TBX... } + MouseBeginEdit + else + inherited; +end; + +procedure TTBEditItemViewer.MouseUp(X, Y: Integer; MouseWasDownOnMenu: Boolean); +begin + if IsPtInButtonPart(X, Y) then { for TBX... } + MouseBeginEdit + else + inherited; +end; + +function TTBEditItemViewer.UsesSameWidth: Boolean; +begin + Result := False; +end; + +function TTBEditItemViewer.GetAccRole: Integer; +const + ROLE_SYSTEM_TEXT = $2a; { from OleAcc.h } +begin + Result := ROLE_SYSTEM_TEXT; +end; + +function TTBEditItemViewer.GetAccValue(var Value: WideString): Boolean; +begin + Value := TTBEditItem(Item).Text; + Result := True; +end; + + +{ TTBToolbarVisibilityItem } + +procedure TTBVisibilityToggleItem.Click; +begin + if Assigned(FControl) then + FControl.Visible := not FControl.Visible; + inherited; +end; + +procedure TTBVisibilityToggleItem.InitiateAction; +begin + UpdateProps; +end; + +procedure TTBVisibilityToggleItem.Notification(AComponent: TComponent; + Operation: TOperation); +begin + inherited; + if (Operation = opRemove) and (AComponent = FControl) then + Control := nil; +end; + +procedure TTBVisibilityToggleItem.SetControl(Value: TControl); +begin + if FControl <> Value then begin + FControl := Value; + if Assigned(Value) then begin + Value.FreeNotification(Self); + if (Caption = '') and not(csLoading in ComponentState) then + {$IFNDEF CLR} + Caption := TControlAccess(Value).Caption; + {$ELSE} + Caption := Value.GetText; + {$ENDIF} + end; + UpdateProps; + end; +end; + +procedure TTBVisibilityToggleItem.UpdateProps; +begin + if (ComponentState * [csDesigning, csLoading, csDestroying] = []) then + Checked := Assigned(FControl) and FControl.Visible; +end; + +end. diff --git a/internal/2.2.2/1/Source/TB2Hook.pas b/internal/2.2.2/1/Source/TB2Hook.pas new file mode 100644 index 0000000..fbc6f62 --- /dev/null +++ b/internal/2.2.2/1/Source/TB2Hook.pas @@ -0,0 +1,344 @@ +unit TB2Hook; + +{ + Toolbar2000 + Copyright (C) 1998-2006 by Jordan Russell + All rights reserved. + + The contents of this file are subject to the "Toolbar2000 License"; you may + not use or distribute this file except in compliance with the + "Toolbar2000 License". A copy of the "Toolbar2000 License" may be found in + TB2k-LICENSE.txt or at: + http://www.jrsoftware.org/files/tb2k/TB2k-LICENSE.txt + + Alternatively, the contents of this file may be used under the terms of the + GNU General Public License (the "GPL"), in which case the provisions of the + GPL are applicable instead of those in the "Toolbar2000 License". A copy of + the GPL may be found in GPL-LICENSE.txt or at: + http://www.jrsoftware.org/files/tb2k/GPL-LICENSE.txt + If you wish to allow use of your version of this file only under the terms of + the GPL and not to allow others to use your version of this file under the + "Toolbar2000 License", indicate your decision by deleting the provisions + above and replace them with the notice and other provisions required by the + GPL. If you do not delete the provisions above, a recipient may use your + version of this file under either the "Toolbar2000 License" or the GPL. + + $jrsoftware: tb2k/Source/TB2Hook.pas,v 1.17 2006/03/12 23:11:59 jr Exp $ +} + +interface + +uses + Windows; + +type + THookProcCode = (hpSendActivate, hpSendActivateApp, hpSendWindowPosChanged, + hpPreDestroy, hpGetMessage); + THookProcCodes = set of THookProcCode; + + THookProc = procedure(Code: THookProcCode; Wnd: HWND; WParam: WPARAM; LParam: LPARAM); + +procedure InstallHookProc(AUser: TObject; AProc: THookProc; ACodes: THookProcCodes); +procedure UninstallHookProc(AUser: TObject; AProc: THookProc); + +implementation + +uses + {$IFDEF CLR} System.Runtime.InteropServices, {$ENDIF} + SysUtils, Classes, Messages, TB2Common; + +type + THookType = (htCallWndProc, htCBT, htGetMessage); + THookTypes = set of THookType; + + THookUserData = class + Prev: THookUserData; + User: TObject; + InstalledHookTypes: THookTypes; + end; + + THookProcData = class + Proc: THookProc; + Codes: THookProcCodes; + LastUserData: THookUserData; + end; + + THookInfo = class + Handles: array[THookType] of HHOOK; + Counts: array[THookType] of Longint; + end; + +threadvar + HookInfo: THookInfo; + HookProcList: TList; + + +function CallWndProcHook(Code: Integer; WParam: WPARAM; LParam: LPARAM): LRESULT; +{$IFNDEF CLR} stdcall; {$ENDIF} +type + THookProcCodeMsgs = hpSendActivate..hpSendWindowPosChanged; +const + MsgMap: array[THookProcCodeMsgs] of UINT = + (WM_ACTIVATE, WM_ACTIVATEAPP, WM_WINDOWPOSCHANGED); +var + J: THookProcCodeMsgs; + I: Integer; + CWPStruct: {$IFNDEF CLR} PCWPStruct {$ELSE} TCWPStruct {$ENDIF}; +begin + if Assigned(HookProcList) and (Code = HC_ACTION) then begin + {$IFNDEF CLR} + CWPStruct := PCWPStruct(LParam); + {$ELSE} + CWPStruct := TCWPStruct(Marshal.PtrToStructure(IntPtr(LParam), TypeOf(TCWPStruct))); + {$ENDIF} + for J := Low(J) to High(J) do + if CWPStruct.Message = MsgMap[J] then begin + for I := 0 to HookProcList.Count-1 do + try + with THookProcData(HookProcList.List[I]) do + if J in Codes then + Proc(J, CWPStruct.hwnd, CWPStruct.WParam, CWPStruct.LParam); + except + end; + Break; + end; + end; + Result := CallNextHookEx(HookInfo.Handles[htCallWndProc], Code, WParam, LParam); +end; + +function CBTHook(Code: Integer; WParam: WPARAM; LParam: LPARAM): LRESULT; +{$IFNDEF CLR} stdcall; {$ENDIF} +var + I: Integer; +begin + if Assigned(HookProcList) and (Code = HCBT_DESTROYWND) then + for I := 0 to HookProcList.Count-1 do + try + with THookProcData(HookProcList.List[I]) do + if hpPreDestroy in Codes then + Proc(hpPreDestroy, HWND(WParam), 0, 0); + except + end; + Result := CallNextHookEx(HookInfo.Handles[htCBT], Code, WParam, LParam); +end; + +function GetMessageHook(Code: Integer; WParam: WPARAM; LParam: LPARAM): LRESULT; +{$IFNDEF CLR} stdcall; {$ENDIF} +var + I: Integer; +begin + if Assigned(HookProcList) and (Code = HC_ACTION) then + for I := 0 to HookProcList.Count-1 do + try + with THookProcData(HookProcList.List[I]) do + if hpGetMessage in Codes then + Proc(hpGetMessage, 0, WParam, LParam); + except + end; + Result := CallNextHookEx(HookInfo.Handles[htGetMessage], Code, WParam, LParam); +end; + +function HookCodesToTypes(Codes: THookProcCodes): THookTypes; +const + HookCodeToType: array[THookProcCode] of THookType = + (htCallWndProc, htCallWndProc, htCallWndProc, htCBT, htGetMessage); +var + J: THookProcCode; +begin + Result := []; + for J := Low(J) to High(J) do + if J in Codes then + Include(Result, HookCodeToType[J]); +end; + +var + HookProcs: array[THookType] of TFNHookProc; +const + HookIDs: array[THookType] of Integer = + (WH_CALLWNDPROC, WH_CBT, WH_GETMESSAGE); + +procedure InstallHooks(ATypes: THookTypes; var InstalledTypes: THookTypes); +var + T: THookType; +begin + if HookInfo = nil then + HookInfo := THookInfo.Create; + + { Don't increment reference counts for hook types that were already + installed previously } + ATypes := ATypes - InstalledTypes; + + { Increment reference counts first. This should never raise an exception. } + for T := Low(T) to High(T) do + if T in ATypes then begin + Inc(HookInfo.Counts[T]); + Include(InstalledTypes, T); + end; + + { Then install the hooks } + for T := Low(T) to High(T) do + if T in InstalledTypes then begin + if HookInfo.Handles[T] = 0 then begin + { On Windows NT platforms, SetWindowsHookExW is used to work around an + apparent bug in Windows NT/2000/XP: if an 'ANSI' WH_GETMESSAGE hook + is called *before* a 'wide' WH_GETMESSAGE hook, then WM_*CHAR + messages passed to the 'wide' hook use ANSI character codes. + This is needed for compatibility with the combination of Tnt Unicode + Controls and Keyman. See "Widechar's and tb2k" thread on the + newsgroup from 2003-09-23 for more information. } + if Win32Platform = VER_PLATFORM_WIN32_NT then + HookInfo.Handles[T] := SetWindowsHookExW(HookIDs[T], HookProcs[T], + 0, GetCurrentThreadId) + else + HookInfo.Handles[T] := SetWindowsHookEx(HookIDs[T], HookProcs[T], + 0, GetCurrentThreadId); + { .NET note: A reference to the delegate passed to SetWindowsHookEx + must exist for as long as the hook is installed, otherwise the GC + will collect it and the app will crash. Hence we always pass a + global variable (HookProcs[]) to SetWindowsHookEx. } + end; + end; +end; + +procedure UninstallHooks(const ATypes: THookTypes; const Force: Boolean); +var + T: THookType; +begin + { HookInfo can be nil if InstallHooks was never called previously (e.g. when + we're being called with Force=True), or if it was called but failed with + an exception } + if HookInfo = nil then + Exit; + + { Decrement reference counts first. This should never raise an exception. } + if not Force then + for T := Low(T) to High(T) do + if T in ATypes then + Dec(HookInfo.Counts[T]); + + { Then uninstall the hooks } + for T := Low(T) to High(T) do + if T in ATypes then begin + if (Force or (HookInfo.Counts[T] = 0)) and (HookInfo.Handles[T] <> 0) then begin + UnhookWindowsHookEx(HookInfo.Handles[T]); + HookInfo.Handles[T] := 0; + end; + end; + + { If all hooks are uninstalled, free HookInfo } + for T := Low(T) to High(T) do + if (HookInfo.Counts[T] <> 0) or (HookInfo.Handles[T] <> 0) then + Exit; + FreeAndNil(HookInfo); +end; + +procedure InstallHookProc(AUser: TObject; AProc: THookProc; ACodes: THookProcCodes); +var + Found: Boolean; + I: Integer; + UserData: THookUserData; + ProcData: THookProcData; +label 1; +begin + if HookProcList = nil then + HookProcList := TList.Create; + Found := False; + UserData := nil; { avoid warning } + for I := 0 to HookProcList.Count-1 do begin + ProcData := THookProcData(HookProcList[I]); + if @ProcData.Proc = @AProc then begin + UserData := ProcData.LastUserData; + while Assigned(UserData) do begin + if UserData.User = AUser then begin + { InstallHookProc was already called for AUser/AProc. Go ahead and + call InstallHooks again just in case the hooks weren't successfully + installed last time. } + goto 1; + end; + UserData := UserData.Prev; + end; + UserData := THookUserData.Create; + UserData.Prev := ProcData.LastUserData; + UserData.User := AUser; + UserData.InstalledHookTypes := []; + ProcData.LastUserData := UserData; + Found := True; + Break; + end; + end; + if not Found then begin + UserData := THookUserData.Create; + try + UserData.Prev := nil; + UserData.User := AUser; + UserData.InstalledHookTypes := []; + HookProcList.Expand; + ProcData := THookProcData.Create; + except + UserData.Free; + raise; + end; + ProcData.Proc := AProc; + ProcData.Codes := ACodes; + ProcData.LastUserData := UserData; + HookProcList.Add(ProcData); + end; +1:InstallHooks(HookCodesToTypes(ACodes), UserData.InstalledHookTypes); +end; + +procedure UninstallHookProc(AUser: TObject; AProc: THookProc); +var + I: Integer; + ProcData: THookProcData; + NextUserData, UserData: THookUserData; + T: THookTypes; +begin + if HookProcList = nil then Exit; + for I := 0 to HookProcList.Count-1 do begin + ProcData := THookProcData(HookProcList[I]); + if @ProcData.Proc = @AProc then begin + { Locate the UserData record } + NextUserData := nil; + UserData := ProcData.LastUserData; + while Assigned(UserData) and (UserData.User <> AUser) do begin + NextUserData := UserData; + UserData := UserData.Prev; + end; + if UserData = nil then + Exit; + + { Remove record from linked list } + if NextUserData = nil then begin + { It's the last item in the list } + if UserData.Prev = nil then begin + { It's the only item in the list, so destroy the ProcData record } + HookProcList.Delete(I); + ProcData.Free; + end + else + ProcData.LastUserData := UserData.Prev; + end + else + NextUserData.Prev := UserData.Prev; + + T := UserData.InstalledHookTypes; + UserData.Free; + UninstallHooks(T, False); + Break; + end; + end; + if HookProcList.Count = 0 then + FreeAndNil(HookProcList); +end; + + +initialization + { Work around Delphi.NET 2005 bug: declaring a constant array of procedural + types crashes the compiler (see QC #10381; 2006 fixes it). So we instead + declare HookProcs as a variable, and initialize the elements here. } + HookProcs[htCallWndProc] := CallWndProcHook; + HookProcs[htCBT] := CBTHook; + HookProcs[htGetMessage] := GetMessageHook; +finalization + UninstallHooks([Low(THookType)..High(THookType)], True); +end. diff --git a/internal/2.2.2/1/Source/TB2Item.pas b/internal/2.2.2/1/Source/TB2Item.pas new file mode 100644 index 0000000..6891cdd --- /dev/null +++ b/internal/2.2.2/1/Source/TB2Item.pas @@ -0,0 +1,6982 @@ +unit TB2Item; + +{ + Toolbar2000 + Copyright (C) 1998-2008 by Jordan Russell + All rights reserved. + + The contents of this file are subject to the "Toolbar2000 License"; you may + not use or distribute this file except in compliance with the + "Toolbar2000 License". A copy of the "Toolbar2000 License" may be found in + TB2k-LICENSE.txt or at: + http://www.jrsoftware.org/files/tb2k/TB2k-LICENSE.txt + + Alternatively, the contents of this file may be used under the terms of the + GNU General Public License (the "GPL"), in which case the provisions of the + GPL are applicable instead of those in the "Toolbar2000 License". A copy of + the GPL may be found in GPL-LICENSE.txt or at: + http://www.jrsoftware.org/files/tb2k/GPL-LICENSE.txt + If you wish to allow use of your version of this file only under the terms of + the GPL and not to allow others to use your version of this file under the + "Toolbar2000 License", indicate your decision by deleting the provisions + above and replace them with the notice and other provisions required by the + GPL. If you do not delete the provisions above, a recipient may use your + version of this file under either the "Toolbar2000 License" or the GPL. + + $jrsoftware: tb2k/Source/TB2Item.pas,v 1.313 2008/09/19 16:35:48 jr Exp $ +} + +interface + +{$I TB2Ver.inc} +{x$DEFINE TB2K_NO_ANIMATION} + { Enabling the above define disables all menu animation. For debugging + purpose only. } +{x$DEFINE TB2K_USE_STRICT_O2K_MENU_STYLE} + { Enabling the above define forces it to use clBtnFace for the menu color + instead of clMenu, and disables the use of flat menu borders on Windows + XP with themes enabled. } + +uses + Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs, + {$IFDEF CLR} TB2OleMarshal, {$ENDIF} + StdCtrls, CommCtrl, Menus, ActnList, ImgList, TB2Anim; + +type + TTBCustomItem = class; + TTBCustomItemClass = class of TTBCustomItem; + TTBCustomItemActionLink = class; + TTBCustomItemActionLinkClass = class of TTBCustomItemActionLink; + TTBItemViewer = class; + TTBItemViewerClass = class of TTBItemViewer; + TTBPopupWindow = class; + TTBPopupWindowClass = class of TTBPopupWindow; + TTBView = class; + + TTBDoneAction = (tbdaNone, tbdaCancel, tbdaClickItem, tbdaOpenSystemMenu, + tbdaHelpContext); + TTBDoneActionData = record + DoneAction: TTBDoneAction; + { tbdaClickItem-specific fields: } + ClickItem: TTBCustomItem; + Sound: Boolean; + { tbdaOpenSystemMenu-specific fields: } + Wnd: HWND; + Key: Word; + { tbdaHelpContext-specific fields: } + ContextID: Integer; + end; + TTBInsertItemProc = procedure(AParent: TComponent; AItem: TTBCustomItem) of object; + TTBItemChangedAction = (tbicInserted, tbicDeleting, tbicSubitemsChanged, + tbicSubitemsBeginUpdate, tbicSubitemsEndUpdate, tbicInvalidate, + tbicInvalidateAndResize, tbicRecreateItemViewers, tbicNameChanged, + tbicSubMenuImagesChanged); + TTBItemChangedProc = procedure(Sender: TTBCustomItem; Relayed: Boolean; + Action: TTBItemChangedAction; Index: Integer; Item: TTBCustomItem) of object; + TTBItemDisplayMode = (nbdmDefault, nbdmTextOnly, nbdmTextOnlyInMenus, nbdmImageAndText); + TTBItemOption = (tboDefault, tboDropdownArrow, tboImageAboveCaption, + tboLongHintInMenuOnly, tboNoAutoHint, tboNoRotation, tboSameWidth, + tboShowHint, tboToolbarStyle, tboToolbarSize); + TTBItemOptions = set of TTBItemOption; + TTBItemStyle = set of (tbisSubmenu, tbisSelectable, tbisSeparator, + tbisEmbeddedGroup, tbisClicksTransparent, tbisCombo, tbisNoAutoOpen, + tbisSubitemsEditable, tbisNoLineBreak, tbisRightAlign, tbisDontSelectFirst, + tbisRedrawOnSelChange, tbisRedrawOnMouseOverChange); + TTBPopupAlignment = (tbpaLeft, tbpaRight, tbpaCenter); + TTBPopupEvent = procedure(Sender: TTBCustomItem; FromLink: Boolean) of object; + TTBSelectEvent = procedure(Sender: TTBCustomItem; Viewer: TTBItemViewer; + Selecting: Boolean) of object; + + ETBItemError = class(Exception); + + TTBImageChangeLink = class(TChangeLink) + private + FLastWidth, FLastHeight: Integer; + end; + {$IFNDEF JR_D5} + TImageIndex = type Integer; + {$ENDIF} + + TTBCustomItem = class(TComponent) + private + FActionLink: TTBCustomItemActionLink; + FAutoCheck: Boolean; + FCaption: String; + FChecked: Boolean; + FDisplayMode: TTBItemDisplayMode; + FEnabled: Boolean; + FEffectiveOptions: TTBItemOptions; + FGroupIndex: Integer; + FHelpContext: THelpContext; + FHint: String; + FImageIndex: TImageIndex; + FImages: TCustomImageList; + FImagesChangeLink: TTBImageChangeLink; + FItems: TList; + FItemStyle: TTBItemStyle; + FLinkParents: TList; + FMaskOptions: TTBItemOptions; + FOptions: TTBItemOptions; + FInheritOptions: Boolean; + FNotifyList: TList; + FOnClick: TNotifyEvent; + FOnPopup: TTBPopupEvent; + FOnSelect: TTBSelectEvent; + FParent: TTBCustomItem; + FParentComponent: TComponent; + FRadioItem: Boolean; + FShortCut: TShortCut; + FSubMenuImages: TCustomImageList; + FSubMenuImagesChangeLink: TTBImageChangeLink; + FLinkSubitems: TTBCustomItem; + FVisible: Boolean; + + procedure DoActionChange(Sender: TObject); + function ChangeImages(var AImages: TCustomImageList; + const Value: TCustomImageList; var AChangeLink: TTBImageChangeLink): Boolean; + class procedure ClickWndProc(var Message: TMessage); {$IFDEF CLR} static; {$ENDIF} + function FindItemWithShortCut(AShortCut: TShortCut; + var ATopmostParent: TTBCustomItem): TTBCustomItem; + function FixOptions(const AOptions: TTBItemOptions): TTBItemOptions; + function GetAction: TBasicAction; + function GetCount: Integer; + function GetItem(Index: Integer): TTBCustomItem; + procedure ImageListChangeHandler(Sender: TObject); + procedure InternalNotify(Ancestor: TTBCustomItem; NestingLevel: Integer; + Action: TTBItemChangedAction; Index: Integer; Item: TTBCustomItem); + {$IFDEF JR_D6} + function IsAutoCheckStored: Boolean; + {$ENDIF} + function IsCaptionStored: Boolean; + function IsCheckedStored: Boolean; + function IsEnabledStored: Boolean; + function IsHelpContextStored: Boolean; + function IsHintStored: Boolean; + function IsImageIndexStored: Boolean; + function IsOnClickStored: Boolean; + function IsShortCutStored: Boolean; + function IsVisibleStored: Boolean; + procedure Notify(Action: TTBItemChangedAction; Index: Integer; Item: TTBCustomItem); + procedure RefreshOptions; + procedure SetAction(Value: TBasicAction); + procedure SetCaption(Value: String); + procedure SetChecked(Value: Boolean); + procedure SetDisplayMode(Value: TTBItemDisplayMode); + procedure SetEnabled(Value: Boolean); + procedure SetGroupIndex(Value: Integer); + procedure SetImageIndex(Value: TImageIndex); + procedure SetImages(Value: TCustomImageList); + procedure SetInheritOptions(Value: Boolean); + procedure SetLinkSubitems(Value: TTBCustomItem); + procedure SetMaskOptions(Value: TTBItemOptions); + procedure SetOptions(Value: TTBItemOptions); + procedure SetRadioItem(Value: Boolean); + procedure SetSubMenuImages(Value: TCustomImageList); + procedure SetVisible(Value: Boolean); + procedure SubMenuImagesChanged; + procedure TurnSiblingsOff; + protected + procedure ActionChange(Sender: TObject; CheckDefaults: Boolean); dynamic; + procedure Change(NeedResize: Boolean); virtual; + function CreatePopup(const ParentView: TTBView; const ParentViewer: TTBItemViewer; + const PositionAsSubmenu, SelectFirstItem, Customizing: Boolean; + const APopupPoint: TPoint; const Alignment: TTBPopupAlignment): TTBPopupWindow; virtual; + procedure DoPopup(Sender: TTBCustomItem; FromLink: Boolean); virtual; + procedure EnabledChanged; virtual; + function GetActionLinkClass: TTBCustomItemActionLinkClass; dynamic; + function GetChevronParentView: TTBView; virtual; + procedure GetChildren(Proc: TGetChildProc; Root: TComponent); override; + function GetItemViewerClass(AView: TTBView): TTBItemViewerClass; virtual; + function GetPopupWindowClass: TTBPopupWindowClass; virtual; + class procedure IndexError; + procedure Loaded; override; + function NeedToRecreateViewer(AViewer: TTBItemViewer): Boolean; virtual; + procedure Notification(AComponent: TComponent; Operation: TOperation); override; + function OpenPopup(const SelectFirstItem, TrackRightButton: Boolean; + const PopupPoint: TPoint; const Alignment: TTBPopupAlignment; + const ReturnClickedItemOnly: Boolean): TTBCustomItem; + procedure RecreateItemViewers; + procedure SetChildOrder(Child: TComponent; Order: Integer); override; + procedure SetName(const NewName: TComponentName); override; + {$IFNDEF CLR} + procedure SetParentComponent(Value: TComponent); override; + {$ENDIF} + + property ActionLink: TTBCustomItemActionLink read FActionLink write FActionLink; + property ItemStyle: TTBItemStyle read FItemStyle write FItemStyle; + public + constructor Create(AOwner: TComponent); override; + destructor Destroy; override; + function HasParent: Boolean; override; + function GetParentComponent: TComponent; override; + + procedure Add(AItem: TTBCustomItem); + procedure Clear; + procedure Click; virtual; + function ContainsItem(AItem: TTBCustomItem): Boolean; + procedure Delete(Index: Integer); + function GetItemStyle: TTBItemStyle; + function GetShortCutText: String; + function IndexOf(AItem: TTBCustomItem): Integer; + procedure InitiateAction; virtual; + procedure Insert(NewIndex: Integer; AItem: TTBCustomItem); + function IsShortCut(var Message: TWMKey): Boolean; + procedure Move(CurIndex, NewIndex: Integer); + function Popup(X, Y: Integer; TrackRightButton: Boolean; + Alignment: TTBPopupAlignment = tbpaLeft; + ReturnClickedItemOnly: Boolean = False): TTBCustomItem; + procedure PostClick; + procedure RegisterNotification(ANotify: TTBItemChangedProc); + procedure Remove(Item: TTBCustomItem); + {$IFDEF CLR} + procedure SetParentComponent(Value: TComponent); override; + {$ENDIF} + procedure UnregisterNotification(ANotify: TTBItemChangedProc); + procedure ViewBeginUpdate; + procedure ViewEndUpdate; + + property Action: TBasicAction read GetAction write SetAction; + property AutoCheck: Boolean read FAutoCheck write FAutoCheck {$IFDEF JR_D6} stored IsAutoCheckStored {$ENDIF} default False; + property Caption: String read FCaption write SetCaption stored IsCaptionStored; + property Count: Integer read GetCount; + property Checked: Boolean read FChecked write SetChecked stored IsCheckedStored default False; + property DisplayMode: TTBItemDisplayMode read FDisplayMode write SetDisplayMode default nbdmDefault; + property EffectiveOptions: TTBItemOptions read FEffectiveOptions; + property Enabled: Boolean read FEnabled write SetEnabled stored IsEnabledStored default True; + property GroupIndex: Integer read FGroupIndex write SetGroupIndex default 0; + property HelpContext: THelpContext read FHelpContext write FHelpContext stored IsHelpContextStored default 0; + property Hint: String read FHint write FHint stored IsHintStored; + property ImageIndex: TImageIndex read FImageIndex write SetImageIndex stored IsImageIndexStored default -1; + property Images: TCustomImageList read FImages write SetImages; + property InheritOptions: Boolean read FInheritOptions write SetInheritOptions default True; + property Items[Index: Integer]: TTBCustomItem read GetItem; default; + property LinkSubitems: TTBCustomItem read FLinkSubitems write SetLinkSubitems; + property MaskOptions: TTBItemOptions read FMaskOptions write SetMaskOptions default []; + property Options: TTBItemOptions read FOptions write SetOptions default []; + property Parent: TTBCustomItem read FParent; + property ParentComponent: TComponent read FParentComponent write FParentComponent; + property RadioItem: Boolean read FRadioItem write SetRadioItem default False; + property ShortCut: TShortCut read FShortCut write FShortCut stored IsShortCutStored default 0; + property SubMenuImages: TCustomImageList read FSubMenuImages write SetSubMenuImages; + property Visible: Boolean read FVisible write SetVisible stored IsVisibleStored default True; + property OnClick: TNotifyEvent read FOnClick write FOnClick stored IsOnClickStored; + property OnPopup: TTBPopupEvent read FOnPopup write FOnPopup; + property OnSelect: TTBSelectEvent read FOnSelect write FOnSelect; + end; + + TTBCustomItemActionLink = class(TActionLink) + protected + FClient: TTBCustomItem; + procedure AssignClient(AClient: TObject); override; + {$IFDEF JR_D6} + function IsAutoCheckLinked: Boolean; virtual; + {$ENDIF} + function IsCaptionLinked: Boolean; override; + function IsCheckedLinked: Boolean; override; + function IsEnabledLinked: Boolean; override; + function IsHelpContextLinked: Boolean; override; + function IsHintLinked: Boolean; override; + function IsImageIndexLinked: Boolean; override; + function IsShortCutLinked: Boolean; override; + function IsVisibleLinked: Boolean; override; + function IsOnExecuteLinked: Boolean; override; + {$IFDEF JR_D6} + procedure SetAutoCheck(Value: Boolean); override; + {$ENDIF} + procedure SetCaption(const Value: String); override; + procedure SetChecked(Value: Boolean); override; + procedure SetEnabled(Value: Boolean); override; + procedure SetHelpContext(Value: THelpContext); override; + procedure SetHint(const Value: String); override; + procedure SetImageIndex(Value: Integer); override; + procedure SetShortCut(Value: TShortCut); override; + procedure SetVisible(Value: Boolean); override; + procedure SetOnExecute(Value: TNotifyEvent); override; + end; + + {$IFNDEF CLR} + TTBBaseAccObject = class(TInterfacedObject, IDispatch) + {$ELSE} + TTBBaseAccObject = class(TTBStandardOleMarshalObject) + {$ENDIF} + public + procedure ClientIsDestroying; virtual; abstract; + {$IFNDEF CLR} + { IDispatch } + function GetTypeInfoCount(out Count: Integer): HResult; stdcall; + function GetTypeInfo(Index, LocaleID: Integer; out TypeInfo): HResult; stdcall; + function GetIDsOfNames(const IID: TGUID; Names: Pointer; + NameCount, LocaleID: Integer; DispIDs: Pointer): HResult; stdcall; + function Invoke(DispID: Integer; const IID: TGUID; LocaleID: Integer; + Flags: Word; var Params; VarResult, ExcepInfo, ArgErr: Pointer): HResult; stdcall; + {$ENDIF} + end; + + TTBItemViewer = class + private + FBoundsRect: TRect; + FClipped: Boolean; + FGroupLevel: Integer; + FItem: TTBCustomItem; + FOffEdge: Boolean; + FShow: Boolean; + FView: TTBView; + procedure AccSelect(const AExecute: Boolean); + function GetIndex: Integer; + protected + FAccObjectInstance: TTBBaseAccObject; + procedure CalcSize(const Canvas: TCanvas; var AWidth, AHeight: Integer); + virtual; + function CaptionShown: Boolean; dynamic; + function DoExecute: Boolean; virtual; + procedure DrawItemCaption(const Canvas: TCanvas; ARect: TRect; + const ACaption: String; ADrawDisabledShadow: Boolean; AFormat: UINT); virtual; + procedure Entering; virtual; + function GetAccRole: Integer; virtual; + function GetAccValue(var Value: WideString): Boolean; virtual; + function GetCaptionText: String; virtual; + procedure GetCursor(const Pt: TPoint; var ACursor: HCURSOR); virtual; + function GetImageList: TCustomImageList; + function ImageShown: Boolean; + function IsRotated: Boolean; + function IsToolbarSize: Boolean; + function IsPtInButtonPart(X, Y: Integer): Boolean; virtual; + procedure KeyDown(var Key: Word; Shift: TShiftState); virtual; + procedure Leaving; virtual; + procedure LosingCapture; virtual; + procedure MouseDown(Shift: TShiftState; X, Y: Integer; + var MouseDownOnMenu: Boolean); virtual; + procedure MouseMove(X, Y: Integer); virtual; + procedure MouseUp(X, Y: Integer; MouseWasDownOnMenu: Boolean); virtual; + procedure MouseWheel(WheelDelta: Integer; X, Y: Integer); virtual; + procedure Paint(const Canvas: TCanvas; const ClientAreaRect: TRect; + IsSelected, IsPushed, UseDisabledShadow: Boolean); virtual; + procedure PostAccSelect(const AExecute: Boolean); + function UsesSameWidth: Boolean; virtual; + public + State: set of (tbisInvalidated, tbisLineSep); + property BoundsRect: TRect read FBoundsRect; + property Clipped: Boolean read FClipped; + property Index: Integer read GetIndex; + property Item: TTBCustomItem read FItem; + property OffEdge: Boolean read FOffEdge; + property Show: Boolean read FShow; + property View: TTBView read FView; + constructor Create(AView: TTBView; AItem: TTBCustomItem; AGroupLevel: Integer); virtual; + destructor Destroy; override; + procedure Execute(AGivePriority: Boolean); + function GetAccObject: TTBBaseAccObject; + function GetHintText: String; + function IsAccessible: Boolean; + function IsToolbarStyle: Boolean; + function ScreenToClient(const P: TPoint): TPoint; + end; + TTBViewOrientation = (tbvoHorizontal, tbvoVertical, tbvoFloating); + TTBEnterToolbarLoopOptions = set of (tbetMouseDown, tbetExecuteSelected, + tbetFromMSAA); + TTBViewState = set of (vsModal, vsMouseInWindow, vsDrawInOrder, vsOppositePopup, + vsIgnoreFirstMouseUp, vsShowAccels, vsDropDownMenus, vsNoAnimation); + TTBViewStyle = set of (vsMenuBar, vsUseHiddenAccels, vsAlwaysShowHints); + TTBViewTimerID = (tiOpen, tiClose, tiScrollUp, tiScrollDown); + + TTBViewClass = class of TTBView; + TTBView = class(TComponent) + private + FViewers: TList; { at front to minimize code size } + FActiveTimers: set of TTBViewTimerID; + FBackgroundColor: TColor; + FBaseSize: TPoint; + FCapture: Boolean; + FCaptureWnd: HWND; + FChevronOffset: Integer; + FChevronParentView: TTBView; + FChevronSize: Integer; + FCurParentItem: TTBCustomItem; + FCustomizing: Boolean; + FDoneActionData: TTBDoneActionData; + FInternalViewersAtEnd: Integer; + FInternalViewersAtFront: Integer; + FIsPopup: Boolean; + FIsToolbar: Boolean; + FMaxHeight: Integer; + FMonitorRect: TRect; + FMouseOverSelected: Boolean; + FNewViewersGetHighestPriority: Boolean; + FOpenViewer: TTBItemViewer; + FOpenViewerView: TTBView; + FOpenViewerWindow: TTBPopupWindow; + FParentView: TTBView; + FParentItem: TTBCustomItem; + FPriorityList: TList; + FOrientation: TTBViewOrientation; + FScrollOffset: Integer; + FSelected: TTBItemViewer; + FSelectedViaMouse: Boolean; + FShowDownArrow: Boolean; + FShowUpArrow: Boolean; + FState: TTBViewState; + FStyle: TTBViewStyle; + FUpdating: Integer; + FUsePriorityList: Boolean; + FValidated: Boolean; + FWindow: TWinControl; + FWrapOffset: Integer; + + procedure DeletingViewer(Viewer: TTBItemViewer); + procedure DrawItem(Viewer: TTBItemViewer; DrawTo: TCanvas; Offscreen: Boolean); + procedure FreeViewers; + function GetViewer(Index: Integer): TTBItemViewer; + function GetViewerCount: Integer; {$IFDEF JR_D9} inline; {$ENDIF} + procedure ImagesChanged; + function InsertItemViewers(const NewIndex: Integer; + const AItem: TTBCustomItem; const AGroupLevel: Integer; + const AddToPriorityList, TopOfPriorityList: Boolean): Integer; + procedure ItemNotification(Ancestor: TTBCustomItem; Relayed: Boolean; + Action: TTBItemChangedAction; Index: Integer; Item: TTBCustomItem); + procedure LinkNotification(Ancestor: TTBCustomItem; Relayed: Boolean; + Action: TTBItemChangedAction; Index: Integer; Item: TTBCustomItem); + procedure RecreateItemViewer(const I: Integer); + procedure Scroll(ADown: Boolean); + procedure SetCustomizing(Value: Boolean); + procedure SetSelected(Value: TTBItemViewer); + procedure SetUsePriorityList(Value: Boolean); + procedure StartTimer(const ATimer: TTBViewTimerID; const Interval: Integer); + procedure StopAllTimers; + procedure StopTimer(const ATimer: TTBViewTimerID); + procedure UpdateCurParentItem; + protected + FAccObjectInstance: TTBBaseAccObject; + procedure AutoSize(AWidth, AHeight: Integer); virtual; + function CalculatePositions(const CanMoveControls: Boolean; + const AOrientation: TTBViewOrientation; + AWrapOffset, AChevronOffset, AChevronSize: Integer; + var ABaseSize, TotalSize: TPoint; + var AWrappedLines: Integer): Boolean; + procedure DoUpdatePositions(var ASize: TPoint); virtual; + function GetChevronItem: TTBCustomItem; virtual; + procedure GetMargins(AOrientation: TTBViewOrientation; var Margins: TRect); + virtual; + function GetMDIButtonsItem: TTBCustomItem; virtual; + function GetMDISystemMenuItem: TTBCustomItem; virtual; + function GetParentToolbarView: TTBView; + function GetRootView: TTBView; + function HandleWMGetObject(var Message: TMessage): Boolean; + procedure InitiateActions; + procedure KeyDown(var Key: Word; Shift: TShiftState); virtual; + procedure Notification(AComponent: TComponent; Operation: TOperation); override; + procedure SetAccelsVisibility(AShowAccels: Boolean); + public + constructor Create(AOwner: TComponent; AParentView: TTBView; + AParentItem: TTBCustomItem; AWindow: TWinControl; + AIsToolbar, ACustomizing, AUsePriorityList: Boolean); reintroduce; virtual; + destructor Destroy; override; + procedure BeginUpdate; + procedure CancelCapture; + procedure CancelChildPopups; + procedure CancelMode; + procedure CloseChildPopups; + function ContainsView(AView: TTBView): Boolean; + procedure DrawSubitems(ACanvas: TCanvas); + procedure EndModal; + procedure EndModalWithClick(AViewer: TTBItemViewer); + procedure EndModalWithHelp(AContextID: Integer); + procedure EndModalWithSystemMenu(AWnd: HWND; AKey: Word); + procedure EndUpdate; + procedure EnterToolbarLoop(Options: TTBEnterToolbarLoopOptions); + procedure ExecuteSelected(AGivePriority: Boolean); + function Find(Item: TTBCustomItem): TTBItemViewer; + function FirstSelectable: TTBItemViewer; + function GetAccObject: TTBBaseAccObject; + function GetCaptureWnd: HWND; + function GetFont: TFont; virtual; + procedure GetOffEdgeControlList(const List: TList); + procedure GivePriority(AViewer: TTBItemViewer); + procedure HandleHintShowMessage(var Message: TCMHintShow); + function HighestPriorityViewer: TTBItemViewer; + procedure Invalidate(AViewer: TTBItemViewer); + procedure InvalidatePositions; virtual; + function IndexOf(AViewer: TTBItemViewer): Integer; + function IsModalEnding: Boolean; + function NextSelectable(CurViewer: TTBItemViewer; GoForward: Boolean): TTBItemViewer; + function NextSelectableWithAccel(CurViewer: TTBItemViewer; Key: Char; + RequirePrimaryAccel: Boolean; var IsOnlyItemWithAccel: Boolean): TTBItemViewer; + procedure NotifyFocusEvent; + function OpenChildPopup(const SelectFirstItem: Boolean): Boolean; + procedure RecreateAllViewers; + procedure ScrollSelectedIntoView; + procedure Select(Value: TTBItemViewer; ViaMouse: Boolean); + procedure SetCapture; + procedure TryValidatePositions; + procedure UpdateSelection(const P: TPoint; const AllowNewSelection: Boolean); + function UpdatePositions: TPoint; + procedure ValidatePositions; + function ViewerFromPoint(const P: TPoint): TTBItemViewer; + + property BackgroundColor: TColor read FBackgroundColor write FBackgroundColor; + property BaseSize: TPoint read FBaseSize; + property Capture: Boolean read FCapture; + property ChevronOffset: Integer read FChevronOffset write FChevronOffset; + property ChevronSize: Integer read FChevronSize write FChevronSize; + property Customizing: Boolean read FCustomizing write SetCustomizing; + property IsPopup: Boolean read FIsPopup; + property IsToolbar: Boolean read FIsToolbar; + property MouseOverSelected: Boolean read FMouseOverSelected; + property NewViewersGetHighestPriority: Boolean read FNewViewersGetHighestPriority + write FNewViewersGetHighestPriority; + property ParentView: TTBView read FParentView; + property ParentItem: TTBCustomItem read FParentItem; + property OpenViewer: TTBItemViewer read FOpenViewer; + property OpenViewerView: TTBView read FOpenViewerView; + property Orientation: TTBViewOrientation read FOrientation write FOrientation; + property Selected: TTBItemViewer read FSelected write SetSelected; + property SelectedViaMouse: Boolean read FSelectedViaMouse; + property State: TTBViewState read FState; + property Style: TTBViewStyle read FStyle write FStyle; + property UsePriorityList: Boolean read FUsePriorityList write SetUsePriorityList; + property Viewers[Index: Integer]: TTBItemViewer read GetViewer; + property ViewerCount: Integer read GetViewerCount; + property Window: TWinControl read FWindow; + property WrapOffset: Integer read FWrapOffset write FWrapOffset; + end; + + TTBRootItemClass = class of TTBRootItem; + TTBRootItem = class(TTBCustomItem); + { same as TTBCustomItem, except there's a property editor for it } + + TTBItem = class(TTBCustomItem) + published + property Action; + property AutoCheck; + property Caption; + property Checked; + property DisplayMode; + property Enabled; + property GroupIndex; + property HelpContext; + property Hint; + property ImageIndex; + property Images; + property InheritOptions; + property MaskOptions; + property Options; + property RadioItem; + property ShortCut; + property Visible; + + property OnClick; + property OnSelect; + end; + + TTBGroupItem = class(TTBCustomItem) + public + constructor Create(AOwner: TComponent); override; + published + property InheritOptions; + property LinkSubitems; + property MaskOptions; + property Options; + end; + + TTBSubmenuItem = class(TTBCustomItem) + private + function GetDropdownCombo: Boolean; + procedure SetDropdownCombo(Value: Boolean); + public + constructor Create(AOwner: TComponent); override; + published + property Action; + property AutoCheck; + property Caption; + property Checked; + //property DisplayAsToolbar; + property DisplayMode; + property DropdownCombo: Boolean read GetDropdownCombo write SetDropdownCombo default False; + property Enabled; + property GroupIndex; + property HelpContext; + property Hint; + property ImageIndex; + property Images; + property InheritOptions; + property LinkSubitems; + property MaskOptions; + property Options; + property RadioItem; + property ShortCut; + property SubMenuImages; + property Visible; + + property OnClick; + property OnPopup; + property OnSelect; + end; + + TTBSeparatorItem = class(TTBCustomItem) + private + FBlank: Boolean; + procedure SetBlank(Value: Boolean); + protected + function GetItemViewerClass(AView: TTBView): TTBItemViewerClass; override; + public + constructor Create(AOwner: TComponent); override; + published + property Blank: Boolean read FBlank write SetBlank default False; + property Hint; + property Visible; + end; + + TTBSeparatorItemViewer = class(TTBItemViewer) + protected + procedure CalcSize(const Canvas: TCanvas; + var AWidth, AHeight: Integer); override; + procedure Paint(const Canvas: TCanvas; const ClientAreaRect: TRect; + IsSelected, IsPushed, UseDisabledShadow: Boolean); override; + function UsesSameWidth: Boolean; override; + end; + + TTBControlItem = class(TTBCustomItem) + private + FControl: TControl; + FDontFreeControl: Boolean; + procedure SetControl(Value: TControl); + protected + procedure Notification(AComponent: TComponent; Operation: TOperation); override; + public + constructor Create(AOwner: TComponent); override; + destructor Destroy; override; + property DontFreeControl: Boolean read FDontFreeControl write FDontFreeControl; + published + property Control: TControl read FControl write SetControl; + end; + + TTBPopupView = class(TTBView) + protected + procedure AutoSize(AWidth, AHeight: Integer); override; + public + function GetFont: TFont; override; + end; + + ITBPopupWindow = interface + ['{E45CBE74-1ECF-44CB-B064-6D45B1924708}'] + end; + + TTBPopupWindow = class(TCustomControl, ITBPopupWindow) + private + FAccelsVisibilitySet: Boolean; + FAnimationDirection: TTBAnimationDirection; + FView: TTBView; + procedure CMHintShow(var Message: TCMHintShow); message CM_HINTSHOW; + procedure CMShowingChanged(var Message: TMessage); message CM_SHOWINGCHANGED; + procedure WMClose(var Message: TWMClose); message WM_CLOSE; + procedure WMEraseBkgnd(var Message: TWMEraseBkgnd); message WM_ERASEBKGND; + procedure WMGetObject(var Message: TMessage); message WM_GETOBJECT; + procedure WMNCCalcSize(var Message: TWMNCCalcSize); message WM_NCCALCSIZE; + procedure WMNCPaint(var Message: TMessage); message WM_NCPAINT; + procedure WMPaint(var Message: TWMPaint); message WM_PAINT; + procedure WMPrint(var Message: TMessage); message WM_PRINT; + procedure WMPrintClient(var Message: {$IFNDEF CLR} TMessage {$ELSE} TWMPrintClient {$ENDIF}); message WM_PRINTCLIENT; + protected + procedure CreateParams(var Params: TCreateParams); override; + procedure CreateWnd; override; + procedure DestroyWindowHandle; override; + function GetViewClass: TTBViewClass; dynamic; + procedure Paint; override; + procedure PaintScrollArrows; virtual; + public + constructor CreatePopupWindow(AOwner: TComponent; const AParentView: TTBView; + const AItem: TTBCustomItem; const ACustomizing: Boolean); virtual; + destructor Destroy; override; + + property View: TTBView read FView; + end; + + ITBItems = interface + ['{A5C0D7CC-3EC4-4090-A0F8-3D03271877EA}'] + function GetItems: TTBCustomItem; + end; + + TTBItemContainer = class(TComponent, ITBItems) + private + FItem: TTBRootItem; + function GetImages: TCustomImageList; + function GetItems: TTBCustomItem; + procedure SetImages(Value: TCustomImageList); + protected + procedure GetChildren(Proc: TGetChildProc; Root: TComponent); override; + public + constructor Create(AOwner: TComponent); override; + destructor Destroy; override; + + property Items: TTBRootItem read FItem; + published + property Images: TCustomImageList read GetImages write SetImages; + end; + + TTBPopupMenu = class(TPopupMenu, ITBItems) + private + FItem: TTBRootItem; + //procedure SetItems(Value: TTBCustomItem); + function GetImages: TCustomImageList; + function GetItems: TTBCustomItem; + function GetLinkSubitems: TTBCustomItem; + function GetOptions: TTBItemOptions; + procedure RootItemClick(Sender: TObject); + procedure SetImages(Value: TCustomImageList); + procedure SetLinkSubitems(Value: TTBCustomItem); + procedure SetOptions(Value: TTBItemOptions); + protected + {$IFNDEF JR_D5} + procedure DoPopup(Sender: TObject); + {$ENDIF} + function GetRootItemClass: TTBRootItemClass; dynamic; + procedure SetChildOrder(Child: TComponent; Order: Integer); override; + public + constructor Create(AOwner: TComponent); override; + destructor Destroy; override; + procedure GetChildren(Proc: TGetChildProc; Root: TComponent); override; + function IsShortCut(var Message: TWMKey): Boolean; override; + procedure Popup(X, Y: Integer); override; + function PopupEx(X, Y: Integer; ReturnClickedItemOnly: Boolean = False): TTBCustomItem; + published + property Images: TCustomImageList read GetImages write SetImages; + property Items: TTBRootItem read FItem; + property LinkSubitems: TTBCustomItem read GetLinkSubitems write SetLinkSubitems; + property Options: TTBItemOptions read GetOptions write SetOptions default []; + end; + + TTBCustomImageList = class(TImageList) + private + FCheckedImages: TCustomImageList; + FCheckedImagesChangeLink: TChangeLink; + FDisabledImages: TCustomImageList; + FDisabledImagesChangeLink: TChangeLink; + FHotImages: TCustomImageList; + FHotImagesChangeLink: TChangeLink; + FImagesBitmap: TBitmap; + FImagesBitmapMaskColor: TColor; + procedure ChangeImages(var AImageList: TCustomImageList; + Value: TCustomImageList; AChangeLink: TChangeLink); + procedure ImageListChanged(Sender: TObject); + procedure ImagesBitmapChanged(Sender: TObject); + procedure SetCheckedImages(Value: TCustomImageList); + procedure SetDisabledImages(Value: TCustomImageList); + procedure SetHotImages(Value: TCustomImageList); + procedure SetImagesBitmap(Value: TBitmap); + procedure SetImagesBitmapMaskColor(Value: TColor); + {$IFDEF CLR} + procedure WriteLeft(Writer: TWriter); + procedure WriteTop(Writer: TWriter); + {$ENDIF} + protected + procedure DefineProperties(Filer: TFiler); override; + procedure Notification(AComponent: TComponent; Operation: TOperation); override; + property CheckedImages: TCustomImageList read FCheckedImages write SetCheckedImages; + property DisabledImages: TCustomImageList read FDisabledImages write SetDisabledImages; + property HotImages: TCustomImageList read FHotImages write SetHotImages; + property ImagesBitmap: TBitmap read FImagesBitmap write SetImagesBitmap; + property ImagesBitmapMaskColor: TColor read FImagesBitmapMaskColor + write SetImagesBitmapMaskColor default clFuchsia; + public + constructor Create(AOwner: TComponent); override; + destructor Destroy; override; + procedure DrawState(Canvas: TCanvas; X, Y, Index: Integer; + Enabled, Selected, Checked: Boolean); virtual; + end; + + TTBImageList = class(TTBCustomImageList) + published + property CheckedImages; + property DisabledImages; + property HotImages; + property ImagesBitmap; + property ImagesBitmapMaskColor; + end; + +const + {$IFNDEF TB2K_USE_STRICT_O2K_MENU_STYLE} + tbMenuBkColor = clMenu; + tbMenuTextColor = clMenuText; + {$ELSE} + tbMenuBkColor = clBtnFace; + tbMenuTextColor = clBtnText; + {$ENDIF} + + tbMenuVerticalMargin = 4; + tbMenuImageTextSpace = 1; + tbMenuLeftTextMargin = 2; + tbMenuRightTextMargin = 3; + + tbMenuSeparatorOffset = 12; + + tbMenuScrollArrowHeight = 19; + + tbDropdownArrowWidth = 8; + tbDropdownArrowMargin = 3; + tbDropdownComboArrowWidth = 11; + tbDropdownComboMargin = 2; + + tbLineSpacing = 6; + tbLineSepOffset = 1; + tbDockedLineSepOffset = 4; + + WM_TB2K_CLICKITEM = WM_USER + $100; + +function TBGetItems(const AObject: TObject): TTBCustomItem; +procedure TBInitToolbarSystemFont; + +var + ToolbarFont: TFont; + + +implementation + +uses + {$IFDEF CLR} System.Runtime.InteropServices, System.Text, System.Threading, + Types, WinUtils, {$ENDIF} + TB2Consts, TB2Common, IMM, TB2Acc; + +{$UNDEF ALLOCHWND_CLASSES} +{$IFNDEF CLR} + {$IFDEF JR_D6} + {$DEFINE ALLOCHWND_CLASSES} + {$ENDIF} +{$ENDIF} + +var + LastPos: TPoint; + +threadvar + ClickWndRefCount: Integer; + ClickWnd: HWND; + ClickList: TList; + +type + TTBModalHandler = class + private + FCreatedWnd: Boolean; + FInited: Boolean; + FWnd: HWND; + FRootPopup: TTBPopupWindow; + FSaveFocusWnd: HWND; + procedure WndProc(var Msg: TMessage); + public + constructor Create(AExistingWnd: HWND); + destructor Destroy; override; + procedure Loop(const RootView: TTBView; const AMouseDown, AExecuteSelected, + AFromMSAA, TrackRightButton: Boolean); + property RootPopup: TTBPopupWindow read FRootPopup write FRootPopup; + property Wnd: HWND read FWnd; + end; + + TItemChangedNotificationData = class + private + Proc: TTBItemChangedProc; + RefCount: Integer; + end; + + {$IFNDEF CLR} + TComponentAccess = class(TComponent); + TControlAccess = class(TControl); + {$ENDIF} + +const + ViewTimerBaseID = 9000; + MaxGroupLevel = 10; + + +{ Misc. } + +function TBGetItems(const AObject: TObject): TTBCustomItem; +{ If AObject is an item, returns AObject, otherwise finds the root item + associated with AObject. If AObject is not a TTBCustomItem and does not + implement the ITBItems interface, nil is returned. } +var + Intf: ITBItems; +begin + if AObject is TTBCustomItem then + Result := TTBCustomItem(AObject) + else begin + {$IFNDEF CLR} + if AObject.GetInterface(ITBItems, Intf) then + {$ELSE} + Intf := ITBItems(AObject); + if Assigned(Intf) then + {$ENDIF} + Result := Intf.GetItems + else + Result := nil; + end; +end; + +procedure DestroyClickWnd; +begin + if ClickWnd <> 0 then begin + {$IFDEF ALLOCHWND_CLASSES}Classes.{$ENDIF} DeallocateHWnd(ClickWnd); + ClickWnd := 0; + end; + FreeAndNil(ClickList); +end; + +procedure ReferenceClickWnd; +begin + Inc(ClickWndRefCount); +end; + +procedure ReleaseClickWnd; +begin + Dec(ClickWndRefCount); + if ClickWndRefCount = 0 then + DestroyClickWnd; +end; + +procedure QueueClick(const AItem: TObject; const AArg: Integer); +{ Adds an item to ClickList and posts a message to handle it. AItem must be + either a TTBCustomItem or TTBItemViewer. } +var + I: Integer; +begin + if ClickWnd = 0 then + ClickWnd := {$IFDEF ALLOCHWND_CLASSES}Classes.{$ENDIF} AllocateHWnd(TTBCustomItem.ClickWndProc); + if ClickList = nil then + ClickList := TList.Create; + + { Add a new item to ClickList or replace an empty one } + I := ClickList.IndexOf(nil); + if I = -1 then + I := ClickList.Add(AItem) + else + ClickList[I] := AItem; + + PostMessage(ClickWnd, WM_TB2K_CLICKITEM, AArg, I); +end; + +procedure RemoveFromClickList(const AItem: TObject); +{ Any class that potentially calls QueueClick needs to call RemoveFromClickList + before an instance is destroyed to ensure that any references to the + instance still in ClickList are removed. } +var + I: Integer; +begin + if Assigned(ClickList) and Assigned(AItem) then + for I := 0 to ClickList.Count-1 do + if ClickList[I] = AItem then + ClickList[I] := ClickList; + { ^ The special value of ClickList is assigned to the item instead of + of nil because we want the index to stay reserved until the + WM_TB2K_CLICKITEM message for the index is processed. We don't want + the WM_TB2K_CLICKITEM message that's still in the queue to later + refer to a different item; this would result in queued clicks being + processed in the wrong order in a case like this: + A.PostClick; B.PostClick; A.Free; C.PostClick; + C's click would end up being processed before A's, because C would + get A's index. } +end; + +function ProcessDoneAction(const DoneActionData: TTBDoneActionData; + const ReturnClickedItemOnly: Boolean): TTBCustomItem; +begin + Result := nil; + case DoneActionData.DoneAction of + tbdaNone: ; + tbdaClickItem: begin + if DoneActionData.Sound and NeedToPlaySound('MenuCommand') then + PlaySystemSound('MenuCommand'); + Result := DoneActionData.ClickItem; + if not ReturnClickedItemOnly then + Result.PostClick; + end; + tbdaOpenSystemMenu: begin + SendMessage(DoneActionData.Wnd, WM_SYSCOMMAND, SC_KEYMENU, DoneActionData.Key); + end; + tbdaHelpContext: begin + { Based on code in TPopupList.WndProc: } + if Assigned(Screen.ActiveForm) and + (biHelp in Screen.ActiveForm.BorderIcons) then + Application.HelpCommand(HELP_CONTEXTPOPUP, DoneActionData.ContextID) + else + Application.HelpContext(DoneActionData.ContextID); + end; + end; +end; + + +{ TTBCustomItemActionLink } + +procedure TTBCustomItemActionLink.AssignClient(AClient: TObject); +begin + FClient := AClient as TTBCustomItem; +end; + +{$IFDEF JR_D6} +function TTBCustomItemActionLink.IsAutoCheckLinked: Boolean; +begin + Result := (FClient.AutoCheck = (Action as TCustomAction).AutoCheck); +end; +{$ENDIF} + +function TTBCustomItemActionLink.IsCaptionLinked: Boolean; +begin + Result := inherited IsCaptionLinked and + (FClient.Caption = (Action as TCustomAction).Caption); +end; + +function TTBCustomItemActionLink.IsCheckedLinked: Boolean; +begin + Result := inherited IsCheckedLinked and + (FClient.Checked = (Action as TCustomAction).Checked); +end; + +function TTBCustomItemActionLink.IsEnabledLinked: Boolean; +begin + Result := inherited IsEnabledLinked and + (FClient.Enabled = (Action as TCustomAction).Enabled); +end; + +function TTBCustomItemActionLink.IsHelpContextLinked: Boolean; +begin + Result := inherited IsHelpContextLinked and + (FClient.HelpContext = (Action as TCustomAction).HelpContext); +end; + +function TTBCustomItemActionLink.IsHintLinked: Boolean; +begin + Result := inherited IsHintLinked and + (FClient.Hint = (Action as TCustomAction).Hint); +end; + +function TTBCustomItemActionLink.IsImageIndexLinked: Boolean; +begin + Result := inherited IsImageIndexLinked and + (FClient.ImageIndex = (Action as TCustomAction).ImageIndex); +end; + +function TTBCustomItemActionLink.IsShortCutLinked: Boolean; +begin + Result := inherited IsShortCutLinked and + (FClient.ShortCut = (Action as TCustomAction).ShortCut); +end; + +function TTBCustomItemActionLink.IsVisibleLinked: Boolean; +begin + Result := inherited IsVisibleLinked and + (FClient.Visible = (Action as TCustomAction).Visible); +end; + +function TTBCustomItemActionLink.IsOnExecuteLinked: Boolean; +begin + Result := inherited IsOnExecuteLinked and + {$IFNDEF CLR} + MethodsEqual(TMethod(FClient.OnClick), TMethod(Action.OnExecute)); + {$ELSE} + (@FClient.OnClick = @Action.OnExecute); + {$ENDIF} +end; + +{$IFDEF JR_D6} +procedure TTBCustomItemActionLink.SetAutoCheck(Value: Boolean); +begin + if IsAutoCheckLinked then FClient.AutoCheck := Value; +end; +{$ENDIF} + +procedure TTBCustomItemActionLink.SetCaption(const Value: string); +begin + if IsCaptionLinked then FClient.Caption := Value; +end; + +procedure TTBCustomItemActionLink.SetChecked(Value: Boolean); +begin + if IsCheckedLinked then FClient.Checked := Value; +end; + +procedure TTBCustomItemActionLink.SetEnabled(Value: Boolean); +begin + if IsEnabledLinked then FClient.Enabled := Value; +end; + +procedure TTBCustomItemActionLink.SetHelpContext(Value: THelpContext); +begin + if IsHelpContextLinked then FClient.HelpContext := Value; +end; + +procedure TTBCustomItemActionLink.SetHint(const Value: string); +begin + if IsHintLinked then FClient.Hint := Value; +end; + +procedure TTBCustomItemActionLink.SetImageIndex(Value: Integer); +begin + if IsImageIndexLinked then FClient.ImageIndex := Value; +end; + +procedure TTBCustomItemActionLink.SetShortCut(Value: TShortCut); +begin + if IsShortCutLinked then FClient.ShortCut := Value; +end; + +procedure TTBCustomItemActionLink.SetVisible(Value: Boolean); +begin + if IsVisibleLinked then FClient.Visible := Value; +end; + +procedure TTBCustomItemActionLink.SetOnExecute(Value: TNotifyEvent); +begin + if IsOnExecuteLinked then FClient.OnClick := Value; +end; + + +{ TTBCustomItem } + +{}function ItemContainingItems(const AItem: TTBCustomItem): TTBCustomItem; +begin + if Assigned(AItem) and Assigned(AItem.FLinkSubitems) then + Result := AItem.FLinkSubitems + else + Result := AItem; +end; + +constructor TTBCustomItem.Create(AOwner: TComponent); +begin + inherited; + FEnabled := True; + FImageIndex := -1; + FInheritOptions := True; + FItemStyle := [tbisSelectable, tbisRedrawOnSelChange, tbisRedrawOnMouseOverChange]; + FVisible := True; + ReferenceClickWnd; +end; + +destructor TTBCustomItem.Destroy; +var + I: Integer; +begin + Destroying; + RemoveFromClickList(Self); + { Changed in 0.33. Moved FParent.Remove call *after* the child items are + deleted. } + for I := Count-1 downto 0 do + Items[I].Free; + if Assigned(FParent) then + FParent.Remove(Self); + FreeAndNil(FItems); + FActionLink.Free; + FActionLink := nil; + FreeAndNil(FSubMenuImagesChangeLink); + FreeAndNil(FImagesChangeLink); + inherited; + if Assigned(FNotifyList) then begin + for I := FNotifyList.Count-1 downto 0 do + TItemChangedNotificationData(FNotifyList[I]).Free; + FNotifyList.Free; + end; + FLinkParents.Free; + ReleaseClickWnd; +end; + +{$IFDEF JR_D6} +function TTBCustomItem.IsAutoCheckStored: Boolean; +begin + Result := (ActionLink = nil) or not FActionLink.IsAutoCheckLinked; +end; +{$ENDIF} + +function TTBCustomItem.IsCaptionStored: Boolean; +begin + Result := (ActionLink = nil) or not FActionLink.IsCaptionLinked; +end; + +function TTBCustomItem.IsCheckedStored: Boolean; +begin + Result := (ActionLink = nil) or not FActionLink.IsCheckedLinked; +end; + +function TTBCustomItem.IsEnabledStored: Boolean; +begin + Result := (ActionLink = nil) or not FActionLink.IsEnabledLinked; +end; + +function TTBCustomItem.IsHintStored: Boolean; +begin + Result := (ActionLink = nil) or not FActionLink.IsHintLinked; +end; + +function TTBCustomItem.IsHelpContextStored: Boolean; +begin + Result := (ActionLink = nil) or not FActionLink.IsHelpContextLinked; +end; + +function TTBCustomItem.IsImageIndexStored: Boolean; +begin + Result := (ActionLink = nil) or not FActionLink.IsImageIndexLinked; +end; + +function TTBCustomItem.IsShortCutStored: Boolean; +begin + Result := (ActionLink = nil) or not FActionLink.IsShortCutLinked; +end; + +function TTBCustomItem.IsVisibleStored: Boolean; +begin + Result := (ActionLink = nil) or not FActionLink.IsVisibleLinked; +end; + +function TTBCustomItem.IsOnClickStored: Boolean; +begin + Result := (ActionLink = nil) or not FActionLink.IsOnExecuteLinked; +end; + +function TTBCustomItem.GetAction: TBasicAction; +begin + if FActionLink <> nil then + Result := FActionLink.Action + else + Result := nil; +end; + +function TTBCustomItem.GetActionLinkClass: TTBCustomItemActionLinkClass; +begin + Result := TTBCustomItemActionLink; +end; + +procedure TTBCustomItem.DoActionChange(Sender: TObject); +begin + if Sender = Action then ActionChange(Sender, False); +end; + +procedure TTBCustomItem.ActionChange(Sender: TObject; CheckDefaults: Boolean); +begin + if Action is TCustomAction then + with TCustomAction(Sender) do + begin + {$IFDEF JR_D6} + if not CheckDefaults or (Self.AutoCheck = False) then + Self.AutoCheck := AutoCheck; + {$ENDIF} + if not CheckDefaults or (Self.Caption = '') then + Self.Caption := Caption; + if not CheckDefaults or (Self.Checked = False) then + Self.Checked := Checked; + if not CheckDefaults or (Self.Enabled = True) then + Self.Enabled := Enabled; + if not CheckDefaults or (Self.HelpContext = 0) then + Self.HelpContext := HelpContext; + if not CheckDefaults or (Self.Hint = '') then + Self.Hint := Hint; + if not CheckDefaults or (Self.ImageIndex = -1) then + Self.ImageIndex := ImageIndex; + if not CheckDefaults or (Self.ShortCut = scNone) then + Self.ShortCut := ShortCut; + if not CheckDefaults or (Self.Visible = True) then + Self.Visible := Visible; + if not CheckDefaults or not Assigned(Self.OnClick) then + Self.OnClick := OnExecute; + end; +end; + +procedure TTBCustomItem.SetAction(Value: TBasicAction); +begin + if Value = nil then begin + FActionLink.Free; + FActionLink := nil; + end + else begin + if FActionLink = nil then + FActionLink := GetActionLinkClass.Create(Self); + FActionLink.Action := Value; + FActionLink.OnChange := DoActionChange; + { Note: Delphi's Controls.pas and Menus.pas merely check for + "csLoading in Value.ComponentState" here. But that doesn't help when + the Action property references an action on another form / data module + that has already finished loading. So we check two things: + 1. csLoading in Value.ComponentState + 2. csLoading in ComponentState + In the typical case where the item and action list reside on the same + form, #1 and #2 are both true. + Only #1 is true when Action references an action on another form / data + module that is created *after* the item (e.g. if Form1.TBItem1.Action = + Form2.Action1, and Form1 is created before Form2). + Only #2 is true when Action references an action on another form / data + module that is created *before* the item (e.g. if Form2.TBItem1.Action = + Form1.Action1, and Form1 is created before Form2). } + ActionChange(Value, (csLoading in Value.ComponentState) or + (csLoading in ComponentState)); + Value.FreeNotification(Self); + end; +end; + +procedure TTBCustomItem.InitiateAction; +begin + if FActionLink <> nil then FActionLink.Update; +end; + +procedure TTBCustomItem.Loaded; +begin + inherited; + if Action <> nil then ActionChange(Action, True); +end; + +procedure TTBCustomItem.GetChildren(Proc: TGetChildProc; Root: TComponent); +var + I: Integer; +begin + for I := 0 to Count-1 do + Proc(Items[I]); +end; + +procedure TTBCustomItem.SetChildOrder(Child: TComponent; Order: Integer); +var + I: Integer; +begin + I := IndexOf(Child as TTBCustomItem); + if I <> -1 then + Move(I, Order); +end; + +function TTBCustomItem.HasParent: Boolean; +begin + Result := True; +end; + +function TTBCustomItem.GetParentComponent: TComponent; +begin + if (FParent <> nil) and (FParent.FParentComponent <> nil) then + Result := FParent.FParentComponent + else + Result := FParent; +end; + +procedure TTBCustomItem.SetName(const NewName: TComponentName); +begin + if Name <> NewName then begin + inherited; + if Assigned(FParent) then + FParent.Notify(tbicNameChanged, -1, Self); + end; +end; + +procedure TTBCustomItem.SetParentComponent(Value: TComponent); +var + RootItem: TTBCustomItem; +begin + if FParent <> nil then FParent.Remove(Self); + if Value <> nil then begin + RootItem := TBGetItems(Value); + if Assigned(RootItem) then + RootItem.Add(Self) + else + raise ETBItemError.CreateFmt(STBToolbarItemParentInvalid, [Value.ClassName]); + end; +end; + +procedure TTBCustomItem.Notification(AComponent: TComponent; + Operation: TOperation); +begin + inherited; + if Operation = opRemove then begin + RemoveFromList(FLinkParents, AComponent); + if AComponent = Action then Action := nil; + if AComponent = Images then Images := nil; + if AComponent = SubMenuImages then SubMenuImages := nil; + if AComponent = LinkSubitems then LinkSubitems := nil; + end; +end; + +class procedure TTBCustomItem.IndexError; +begin + raise ETBItemError.Create(STBToolbarIndexOutOfBounds); +end; + +class procedure TTBCustomItem.ClickWndProc(var Message: TMessage); +var + List: TList; + I: Integer; + Item: TObject; +begin + if Message.Msg = WM_TB2K_CLICKITEM then begin + List := ClickList; { optimization... } + if Assigned(List) then begin + I := ClipToLongint(Message.LParam); + if (I >= 0) and (I < List.Count) then begin + Item := List[I]; + List[I] := nil; + { If the item value is set to ClickList, then it was 'removed' from + the list by RemoveFromClickList } + if Item = List then + Item := nil; + end + else + Item := nil; + + { Remove trailing nil items from ClickList. This is not *necessary*, but + it will make RemoveFromClickList faster if we clean out items that + aren't used, and may never be used again. } + for I := List.Count-1 downto 0 do begin + if List[I] = nil then + List.Delete(I) + else + Break; + end; + + if Assigned(Item) then begin + try + if Item is TTBCustomItem then + TTBCustomItem(Item).Click + else if Item is TTBItemViewer then + TTBItemViewer(Item).AccSelect(Message.WParam <> 0); + except + Application.HandleException(Item); + end; + end; + end; + end + else + with Message do + Result := DefWindowProc(ClickWnd, Msg, wParam, lParam); +end; + +procedure TTBCustomItem.PostClick; +{ Posts a message to the message queue that causes the item's Click handler to + be executed when control is returned to the message loop. + This should be called instead of Click when a WM_SYSCOMMAND message is + (possibly) currently being handled, because TApplication.WndProc's + CM_APPSYSCOMMAND handler disables the VCL's processing of focus messages + until the Perform(WM_SYSCOMMAND, ...) call returns. (An OnClick handler which + calls TForm.ShowModal needs focus messages to be enabled or else the form + will be shown with no initial focus.) } +begin + QueueClick(Self, 0); +end; + +procedure TTBCustomItem.Click; +begin + if Enabled then begin + { Following code based on D6's TMenuItem.Click } + {$IFDEF JR_D6} + if (not Assigned(ActionLink) and AutoCheck) or + (Assigned(ActionLink) and not ActionLink.IsAutoCheckLinked and AutoCheck) then + {$ELSE} + if AutoCheck then + {$ENDIF} + Checked := not Checked; + { Following code based on D4's TControl.Click } + { Call OnClick if assigned and not equal to associated action's OnExecute. + If associated action's OnExecute assigned then call it, otherwise, call + OnClick. } + if Assigned(FOnClick) and (Action <> nil) and + {$IFNDEF CLR} + not MethodsEqual(TMethod(FOnClick), TMethod(Action.OnExecute)) then + {$ELSE} + (@FOnClick <> @Action.OnExecute) then + {$ENDIF} + FOnClick(Self) + else + if not(csDesigning in ComponentState) and (ActionLink <> nil) then + ActionLink.Execute {$IFDEF JR_D6}(Self){$ENDIF} + else + if Assigned(FOnClick) then + FOnClick(Self); + end; +end; + +function TTBCustomItem.GetCount: Integer; +begin + if FItems = nil then + Result := 0 + else + Result := FItems.Count; +end; + +function TTBCustomItem.GetItem(Index: Integer): TTBCustomItem; +begin + if (FItems = nil) or (Index < 0) or (Index >= FItems.Count) then begin + IndexError; + Result := nil; + Exit; + end; + Result := TTBCustomItem(FItems.List[Index]); +end; + +procedure TTBCustomItem.Add(AItem: TTBCustomItem); +begin + Insert(Count, AItem); +end; + +procedure TTBCustomItem.InternalNotify(Ancestor: TTBCustomItem; + NestingLevel: Integer; Action: TTBItemChangedAction; Index: Integer; + Item: TTBCustomItem); +{ Note: Ancestor is Item's parent, or in the case of a group item relayed + notification, it can also be a group item which *links* to Item's parent + (i.e. ItemContainingItems(Ancestor) = Item.Parent). } + + procedure RelayToParentOf(const AItem: TTBCustomItem); + begin + if NestingLevel > MaxGroupLevel then + Exit; + if (tbisEmbeddedGroup in AItem.ItemStyle) and Assigned(AItem.Parent) then begin + if Ancestor = Self then + AItem.Parent.InternalNotify(AItem, NestingLevel + 1, Action, Index, Item) + else + { Don't alter Ancestor on subsequent relays; only on the first. } + AItem.Parent.InternalNotify(Ancestor, NestingLevel + 1, Action, Index, Item); + end; + end; + +var + I: Integer; + P: TTBCustomItem; + SaveProc: TTBItemChangedProc; +begin + { If Self is a group item, relay the notification to the parent } + RelayToParentOf(Self); + { If any group items are linked to Self, relay the notification to + those items' parents } + if Assigned(FLinkParents) then + for I := 0 to FLinkParents.Count-1 do begin + P := TTBCustomItem(FLinkParents[I]); + if P <> Parent then + RelayToParentOf(P); + end; + if Assigned(FNotifyList) then begin + I := 0; + while I < FNotifyList.Count do begin + with TItemChangedNotificationData(FNotifyList[I]) do begin + SaveProc := Proc; + Proc(Ancestor, Ancestor <> Self, Action, Index, Item); + end; + { Is I now out of bounds? } + if I >= FNotifyList.Count then + Break; + { Only proceed to the next index if the list didn't change } + {$IFNDEF CLR} + if MethodsEqual(TMethod(TItemChangedNotificationData(FNotifyList[I]).Proc), + TMethod(SaveProc)) then + {$ELSE} + if @TItemChangedNotificationData(FNotifyList[I]).Proc = @SaveProc then + {$ENDIF} + Inc(I); + end; + end; +end; + +procedure TTBCustomItem.Notify(Action: TTBItemChangedAction; Index: Integer; + Item: TTBCustomItem); +begin + InternalNotify(Self, 0, Action, Index, Item); +end; + +procedure TTBCustomItem.ViewBeginUpdate; +begin + Notify(tbicSubitemsBeginUpdate, -1, nil); +end; + +procedure TTBCustomItem.ViewEndUpdate; +begin + Notify(tbicSubitemsEndUpdate, -1, nil); +end; + +procedure TTBCustomItem.Insert(NewIndex: Integer; AItem: TTBCustomItem); +begin + if Assigned(AItem.FParent) then + raise ETBItemError.Create(STBToolbarItemReinserted); + if (NewIndex < 0) or (NewIndex > Count) then IndexError; + if FItems = nil then + FItems := TList.Create; + FItems.Insert(NewIndex, AItem); + AItem.FParent := Self; + ViewBeginUpdate; + try + Notify(tbicInserted, NewIndex, AItem); + AItem.RefreshOptions; + finally + ViewEndUpdate; + end; +end; + +procedure TTBCustomItem.Delete(Index: Integer); +var + Item: TTBCustomItem; +begin + Item := Items[Index]; { will raise exception if out of range } + Notify(tbicDeleting, Index, Item); + Item.FParent := nil; + FItems.Delete(Index); +end; + +function TTBCustomItem.IndexOf(AItem: TTBCustomItem): Integer; +var + I: Integer; +begin + for I := 0 to Count-1 do + if FItems.List[I] = AItem then begin + Result := I; + Exit; + end; + Result := -1; +end; + +procedure TTBCustomItem.Remove(Item: TTBCustomItem); +var + I: Integer; +begin + I := IndexOf(Item); + //if I = -1 then raise ETBItemError.Create(STBToolbarItemNotFound); + if I <> -1 then + Delete(I); +end; + +procedure TTBCustomItem.Clear; +var + I: Integer; +begin + for I := Count-1 downto 0 do + Items[I].Free; +end; + +procedure TTBCustomItem.Move(CurIndex, NewIndex: Integer); +var + Item: TTBCustomItem; +begin + if CurIndex <> NewIndex then begin + if (NewIndex < 0) or (NewIndex >= Count) then IndexError; + Item := Items[CurIndex]; + ViewBeginUpdate; + try + Delete(CurIndex); + Insert(NewIndex, Item); + finally + ViewEndUpdate; + end; + end; +end; + +function TTBCustomItem.ContainsItem(AItem: TTBCustomItem): Boolean; +begin + while Assigned(AItem) and (AItem <> Self) do + AItem := AItem.Parent; + Result := Assigned(AItem); +end; + +procedure TTBCustomItem.RegisterNotification(ANotify: TTBItemChangedProc); +var + I: Integer; + Data: TItemChangedNotificationData; +begin + if FNotifyList = nil then FNotifyList := TList.Create; + for I := 0 to FNotifyList.Count-1 do + with TItemChangedNotificationData(FNotifyList[I]) do + {$IFNDEF CLR} + if MethodsEqual(TMethod(ANotify), TMethod(Proc)) then begin + {$ELSE} + if @ANotify = @Proc then begin + {$ENDIF} + Inc(RefCount); + Exit; + end; + FNotifyList.Expand; + Data := TItemChangedNotificationData.Create; + Data.Proc := ANotify; + Data.RefCount := 1; + FNotifyList.Add(Data); +end; + +procedure TTBCustomItem.UnregisterNotification(ANotify: TTBItemChangedProc); +var + I: Integer; + Data: TItemChangedNotificationData; +begin + if Assigned(FNotifyList) then + for I := 0 to FNotifyList.Count-1 do begin + Data := TItemChangedNotificationData(FNotifyList[I]); + {$IFNDEF CLR} + if MethodsEqual(TMethod(Data.Proc), TMethod(ANotify)) then begin + {$ELSE} + if @Data.Proc = @ANotify then begin + {$ENDIF} + Dec(Data.RefCount); + if Data.RefCount = 0 then begin + FNotifyList.Delete(I); + Data.Free; + if FNotifyList.Count = 0 then + FreeAndNil(FNotifyList); + end; + Break; + end; + end; +end; + +function TTBCustomItem.GetPopupWindowClass: TTBPopupWindowClass; +begin + Result := TTBPopupWindow; +end; + +procedure TTBCustomItem.DoPopup(Sender: TTBCustomItem; FromLink: Boolean); +begin + if Assigned(FOnPopup) then + FOnPopup(Sender, FromLink); + if not(tbisCombo in ItemStyle) then + Click; +end; + +var + PlayedSound: Boolean = False; + +function TTBCustomItem.CreatePopup(const ParentView: TTBView; + const ParentViewer: TTBItemViewer; const PositionAsSubmenu, SelectFirstItem, + Customizing: Boolean; const APopupPoint: TPoint; + const Alignment: TTBPopupAlignment): TTBPopupWindow; + + function CountObscured(X, Y, W, H: Integer): Integer; + var + I: Integer; + P: TPoint; + V: TTBItemViewer; + begin + Result := 0; + if ParentView = nil then + Exit; + P := ParentView.FWindow.ClientToScreen(Point(0, 0)); + Dec(X, P.X); + Dec(Y, P.Y); + Inc(W, X); + Inc(H, Y); + for I := 0 to ParentView.FViewers.Count-1 do begin + V := ParentView.Viewers[I]; + if V.Show and (V.BoundsRect.Left >= X) and (V.BoundsRect.Right <= W) and + (V.BoundsRect.Top >= Y) and (V.BoundsRect.Bottom <= H) then + Inc(Result); + end; + end; + +var + EventItem, ParentItem: TTBCustomItem; + Opposite: Boolean; + ChevronParentView: TTBView; + X, X2, Y, Y2, W, H: Integer; + P: TPoint; + RepeatCalcX: Boolean; + ParentItemRect: TRect; + MonitorRect: TRect; + AnimDir: TTBAnimationDirection; +begin + EventItem := ItemContainingItems(Self); + if EventItem <> Self then + EventItem.DoPopup(Self, True); + DoPopup(Self, False); + + ChevronParentView := GetChevronParentView; + if ChevronParentView = nil then + ParentItem := Self + else + ParentItem := ChevronParentView.FParentItem; + + Opposite := Assigned(ParentView) and (vsOppositePopup in ParentView.FState); + Result := GetPopupWindowClass.CreatePopupWindow(nil, ParentView, ParentItem, + Customizing); + try + if Assigned(ChevronParentView) then begin + ChevronParentView.FreeNotification(Result.View); + Result.View.FChevronParentView := ChevronParentView; + Result.View.FIsToolbar := True; + Result.View.Style := Result.View.Style + + (ChevronParentView.Style * [vsAlwaysShowHints]); + Result.Color := clBtnFace; + end; + + { Calculate ParentItemRect, and MonitorRect (the rectangle of the monitor + that the popup window will be confined to) } + if Assigned(ParentView) then begin + ParentView.ValidatePositions; + ParentItemRect := ParentViewer.BoundsRect; + P := ParentView.FWindow.ClientToScreen(Point(0, 0)); + OffsetRect(ParentItemRect, P.X, P.Y); + if not IsRectEmpty(ParentView.FMonitorRect) then + MonitorRect := ParentView.FMonitorRect + else + MonitorRect := GetRectOfMonitorContainingRect(ParentItemRect, False); + end + else begin + ParentItemRect.TopLeft := APopupPoint; + ParentItemRect.BottomRight := APopupPoint; + MonitorRect := GetRectOfMonitorContainingPoint(APopupPoint, False); + end; + Result.View.FMonitorRect := MonitorRect; + + { Initialize item positions and size of the popup window } + if ChevronParentView = nil then + Result.View.FMaxHeight := (MonitorRect.Bottom - MonitorRect.Top) - + (PopupMenuWindowNCSize * 2) + else + Result.View.WrapOffset := (MonitorRect.Right - MonitorRect.Left) - + (PopupMenuWindowNCSize * 2); + if SelectFirstItem then + Result.View.Selected := Result.View.FirstSelectable; + Result.View.UpdatePositions; + W := Result.Width; + H := Result.Height; + + { Calculate initial X,Y position of the popup window } + if Assigned(ParentView) then begin + if not PositionAsSubmenu then begin + if ChevronParentView = nil then begin + if (ParentView = nil) or (ParentView.FOrientation <> tbvoVertical) then begin + if GetSystemMetrics(SM_MENUDROPALIGNMENT) = 0 then + X := ParentItemRect.Left + else + X := ParentItemRect.Right - W; + Y := ParentItemRect.Bottom; + end + else begin + X := ParentItemRect.Left - W; + Y := ParentItemRect.Top; + end; + end + else begin + if ChevronParentView.FOrientation <> tbvoVertical then begin + X := ParentItemRect.Right - W; + Y := ParentItemRect.Bottom; + end + else begin + X := ParentItemRect.Left - W; + Y := ParentItemRect.Top; + end; + end; + end + else begin + X := ParentItemRect.Right - PopupMenuWindowNCSize; + Y := ParentItemRect.Top - PopupMenuWindowNCSize; + end; + end + else begin + X := APopupPoint.X; + Y := APopupPoint.Y; + case Alignment of + tbpaRight: Dec(X, W); + tbpaCenter: Dec(X, W div 2); + end; + end; + + { Adjust the Y position of the popup window } + { If the window is going off the bottom of the monitor, try placing it + above the parent item } + if (Y + H > MonitorRect.Bottom) and + ((ParentView = nil) or (ParentView.FOrientation <> tbvoVertical)) then begin + if not PositionAsSubmenu then + Y2 := ParentItemRect.Top + else + Y2 := ParentItemRect.Bottom + PopupMenuWindowNCSize; + Dec(Y2, H); + { Only place it above the parent item if it isn't going to go off the + top of the monitor } + if Y2 >= MonitorRect.Top then + Y := Y2; + end; + { If it's still going off the bottom (which can be possible if a menu bar + was off the screen to begin with), clip it to the bottom of the monitor } + if Y + H > MonitorRect.Bottom then + Y := MonitorRect.Bottom - H; + if Y < MonitorRect.Top then + Y := MonitorRect.Top; + + { Other adjustments to the position of the popup window } + if not PositionAsSubmenu then begin + if (ParentView = nil) and (Alignment = tbpaRight) and (X < MonitorRect.Left) then + Inc(X, W); + if X + W > MonitorRect.Right then begin + if Assigned(ParentView) or (Alignment <> tbpaLeft) then + X := MonitorRect.Right; + Dec(X, W); + end; + if X < MonitorRect.Left then + X := MonitorRect.Left; + if (ParentView = nil) or (ParentView.FOrientation <> tbvoVertical) then begin + Y2 := ParentItemRect.Top - H; + if Y2 >= MonitorRect.Top then begin + { Would the popup window obscure less items if it popped out to the + top instead? } + if (CountObscured(X, Y2, W, H) < CountObscured(X, Y, W, H)) or + ((Y < ParentItemRect.Bottom) and (Y + H > ParentItemRect.Top) and + (X < ParentItemRect.Right) and (X + W > ParentItemRect.Left)) then + Y := Y2; + end; + { Make sure a tall popup window doesn't overlap the parent item } + if (Y < ParentItemRect.Bottom) and (Y + H > ParentItemRect.Top) and + (X < ParentItemRect.Right) and (X + W > ParentItemRect.Left) then begin + if ParentItemRect.Right + W <= MonitorRect.Right then + X := ParentItemRect.Right + else + X := ParentItemRect.Left - W; + if X < MonitorRect.Top then + X := MonitorRect.Top; + end; + end + else begin + X2 := ParentItemRect.Right; + if X2 + W <= MonitorRect.Right then begin + { Would the popup window obscure less items if it popped out to the + right instead? } + if (CountObscured(X2, Y, W, H) < CountObscured(X, Y, W, H)) or + ((Y < ParentItemRect.Bottom) and (Y + H > ParentItemRect.Top) and + (X < ParentItemRect.Right) and (X + W > ParentItemRect.Left)) then + X := X2; + end; + { Make sure a wide popup window doesn't overlap the parent item } + if (Y < ParentItemRect.Bottom) and (Y + H > ParentItemRect.Top) and + (X < ParentItemRect.Right) and (X + W > ParentItemRect.Left) then begin + if ParentItemRect.Bottom + H <= MonitorRect.Bottom then + Y := ParentItemRect.Bottom + else + Y := ParentItemRect.Top - H; + if Y < MonitorRect.Top then + Y := MonitorRect.Top; + end; + end; + end + else begin + { Make nested submenus go from left to right on the screen. Each it + runs out of space on the screen, switch directions } + repeat + RepeatCalcX := False; + X2 := X; + if Opposite or (X2 + W > MonitorRect.Right) then begin + if Assigned(ParentView) then + X2 := ParentItemRect.Left + PopupMenuWindowNCSize; + Dec(X2, W); + if not Opposite then + Include(Result.View.FState, vsOppositePopup) + else begin + if X2 < MonitorRect.Left then begin + Opposite := False; + RepeatCalcX := True; + end + else + Include(Result.View.FState, vsOppositePopup); + end; + end; + until not RepeatCalcX; + X := X2; + if X < MonitorRect.Left then + X := MonitorRect.Left; + end; + + { Determine animation direction } + AnimDir := []; + if not PositionAsSubmenu then begin + if Y >= ParentItemRect.Bottom then + Include(AnimDir, tbadDown) + else if Y + H <= ParentItemRect.Top then + Include(AnimDir, tbadUp); + if X >= ParentItemRect.Right then + Include(AnimDir, tbadRight) + else if X + W <= ParentItemRect.Left then + Include(AnimDir, tbadLeft); + end + else begin + if X + W div 2 >= ParentItemRect.Left + (ParentItemRect.Right - ParentItemRect.Left) div 2 then + Include(AnimDir, tbadRight) + else + Include(AnimDir, tbadLeft); + end; + Result.FAnimationDirection := AnimDir; + + Result.SetBounds(X, Y, W, H); + if Assigned(ParentView) then begin + Result.FreeNotification(ParentView); + ParentView.FOpenViewerWindow := Result; + ParentView.FOpenViewerView := Result.View; + ParentView.FOpenViewer := ParentViewer; + if ParentView.FIsToolbar then begin + Include(ParentView.FState, vsDropDownMenus); + ParentView.Invalidate(ParentViewer); + ParentView.FWindow.Update; + end; + end; + Include(Result.View.FState, vsDrawInOrder); + if not NeedToPlaySound('MenuPopup') then begin + { Don't call PlaySound if we don't have to } + Result.Visible := True; + end + else begin + if not PlayedSound then begin + { Work around Windows 2000 "bug" where there's a 1/3 second delay upon the + first call to PlaySound (or sndPlaySound) by painting the window + completely first. This way the delay isn't very noticable. } + PlayedSound := True; + Result.Visible := True; + Result.Update; + PlaySystemSound('MenuPopup'); + end + else begin + PlaySystemSound('MenuPopup'); + Result.Visible := True; + end; + end; + CallNotifyWinEvent(EVENT_SYSTEM_MENUPOPUPSTART, Result.View.FWindow.Handle, + OBJID_CLIENT, CHILDID_SELF); + { Call NotifyFocusEvent now that the window is visible } + if Assigned(Result.View.Selected) then + Result.View.NotifyFocusEvent; + except + Result.Free; + raise; + end; +end; + +function TTBCustomItem.OpenPopup(const SelectFirstItem, TrackRightButton: Boolean; + const PopupPoint: TPoint; const Alignment: TTBPopupAlignment; + const ReturnClickedItemOnly: Boolean): TTBCustomItem; +var + ModalHandler: TTBModalHandler; + Popup: TTBPopupWindow; + DoneActionData: TTBDoneActionData; +begin + ModalHandler := TTBModalHandler.Create(0); + try + Popup := CreatePopup(nil, nil, False, SelectFirstItem, False, PopupPoint, + Alignment); + try + Include(Popup.View.FState, vsIgnoreFirstMouseUp); + ModalHandler.RootPopup := Popup; + ModalHandler.Loop(Popup.View, False, False, False, TrackRightButton); + DoneActionData := Popup.View.FDoneActionData; + finally + ModalHandler.RootPopup := nil; + { Remove vsModal state from the root view before any TTBView.Destroy + methods get called, so that NotifyFocusEvent becomes a no-op } + Exclude(Popup.View.FState, vsModal); + Popup.Free; + end; + finally + ModalHandler.Free; + end; + Result := ProcessDoneAction(DoneActionData, ReturnClickedItemOnly); +end; + +function TTBCustomItem.Popup(X, Y: Integer; TrackRightButton: Boolean; + Alignment: TTBPopupAlignment = tbpaLeft; + ReturnClickedItemOnly: Boolean = False): TTBCustomItem; +var + P: TPoint; +begin + P.X := X; + P.Y := Y; + Result := OpenPopup(False, TrackRightButton, P, Alignment, + ReturnClickedItemOnly); +end; + +function TTBCustomItem.FindItemWithShortCut(AShortCut: TShortCut; + var ATopmostParent: TTBCustomItem): TTBCustomItem; + + function DoItem(AParentItem: TTBCustomItem; LinkDepth: Integer): TTBCustomItem; + var + I: Integer; + NewParentItem, Item: TTBCustomItem; + begin + Result := nil; + NewParentItem := AParentItem; + if Assigned(NewParentItem.LinkSubitems) then begin + NewParentItem := NewParentItem.LinkSubitems; + Inc(LinkDepth); + if LinkDepth > 25 then + Exit; { prevent infinite link recursion } + end; + for I := 0 to NewParentItem.Count-1 do begin + Item := NewParentItem.Items[I]; + if Item.ShortCut = AShortCut then begin + Result := Item; + Exit; + end; + Result := DoItem(Item, LinkDepth); + if Assigned(Result) then begin + ATopmostParent := Item; + Exit; + end; + end; + end; + +begin + ATopmostParent := nil; + Result := DoItem(Self, 0); +end; + +function TTBCustomItem.IsShortCut(var Message: TWMKey): Boolean; +var + ShortCut: TShortCut; + ShiftState: TShiftState; + ShortCutItem, TopmostItem, Item, EventItem: TTBCustomItem; + I: Integer; +label StartOver; +begin + Result := False; + ShiftState := KeyDataToShiftState(ClipToLongint(Message.KeyData)); + ShortCut := Menus.ShortCut(Message.CharCode, ShiftState); +StartOver: + ShortCutItem := FindItemWithShortCut(ShortCut, TopmostItem); + if Assigned(ShortCutItem) then begin + { Send OnPopup/OnClick events to ShortCutItem's parents so that they can + update the Enabled state of ShortCutItem if needed } + Item := Self; + repeat + if not Item.Enabled then + Exit; + EventItem := ItemContainingItems(Item); + if not(csDesigning in ComponentState) then begin + for I := 0 to EventItem.Count-1 do + EventItem.Items[I].InitiateAction; + end; + if not(tbisEmbeddedGroup in Item.ItemStyle) then begin + if EventItem <> Item then begin + try + EventItem.DoPopup(Item, True); + except + Application.HandleException(Self); + end; + end; + try + Item.DoPopup(Item, False); + except + Application.HandleException(Self); + end; + end; + ShortCutItem := Item.FindItemWithShortCut(ShortCut, TopmostItem); + if ShortCutItem = nil then + { Can no longer find the shortcut inside TopmostItem. Start over + because the shortcut might have moved. } + goto StartOver; + Item := TopmostItem; + until Item = nil; + if ShortCutItem.Enabled then begin + try + ShortCutItem.Click; + except + Application.HandleException(Self); + end; + Result := True; + end; + end; +end; + +function TTBCustomItem.GetChevronParentView: TTBView; +begin + Result := nil; +end; + +function TTBCustomItem.GetItemViewerClass(AView: TTBView): TTBItemViewerClass; +begin + Result := TTBItemViewer; +end; + +function TTBCustomItem.NeedToRecreateViewer(AViewer: TTBItemViewer): Boolean; +begin + Result := False; +end; + +function TTBCustomItem.GetItemStyle: TTBItemStyle; +begin + { This public method exists for TB2DsgnItemEditor. It needs access to + ItemStyle but can't access a protected member across assembly boundaries. } + Result := FItemStyle; +end; + +function TTBCustomItem.GetShortCutText: String; +var + P: Integer; +begin + P := Pos(#9, Caption); + if P = 0 then begin + if ShortCut <> 0 then + Result := ShortCutToText(ShortCut) + else + Result := ''; + end + else + Result := Copy(Caption, P+1, Maxint); +end; + +procedure TTBCustomItem.Change(NeedResize: Boolean); +const + ItemChangedActions: array[Boolean] of TTBItemChangedAction = + (tbicInvalidate, tbicInvalidateAndResize); +begin + if Assigned(FParent) then + FParent.Notify(ItemChangedActions[NeedResize], -1, Self); +end; + +procedure TTBCustomItem.RecreateItemViewers; +begin + if Assigned(FParent) then + FParent.Notify(tbicRecreateItemViewers, -1, Self); +end; + +procedure TTBCustomItem.ImageListChangeHandler(Sender: TObject); +var + Resize: Boolean; +begin + if Sender = FSubMenuImages then begin + FSubMenuImagesChangeLink.FLastWidth := FSubMenuImages.Width; + FSubMenuImagesChangeLink.FLastHeight := FSubMenuImages.Height; + SubMenuImagesChanged; + end + else begin + { Sender is FImages } + Resize := False; + if (FImagesChangeLink.FLastWidth <> FImages.Width) or + (FImagesChangeLink.FLastHeight <> FImages.Height) then begin + FImagesChangeLink.FLastWidth := FImages.Width; + FImagesChangeLink.FLastHeight := FImages.Height; + Resize := True; + end; + Change(Resize); + end; +end; + +procedure TTBCustomItem.SubMenuImagesChanged; +begin + Notify(tbicSubMenuImagesChanged, -1, nil); +end; + +procedure TTBCustomItem.TurnSiblingsOff; +var + I: Integer; + Item: TTBCustomItem; +begin + if (GroupIndex <> 0) and Assigned(FParent) then begin + for I := 0 to FParent.Count-1 do begin + Item := FParent[I]; + if (Item <> Self) and (Item.GroupIndex = GroupIndex) then + Item.Checked := False; + end; + end; +end; + +procedure TTBCustomItem.SetCaption(Value: String); +begin + if FCaption <> Value then begin + FCaption := Value; + Change(True); + end; +end; + +procedure TTBCustomItem.SetChecked(Value: Boolean); +begin + if FChecked <> Value then begin + FChecked := Value; + Change(False); + if Value then + TurnSiblingsOff; + end; +end; + +procedure TTBCustomItem.SetDisplayMode(Value: TTBItemDisplayMode); +begin + if FDisplayMode <> Value then begin + FDisplayMode := Value; + Change(True); + end; +end; + +procedure TTBCustomItem.EnabledChanged; +begin + Change(False); +end; + +procedure TTBCustomItem.SetEnabled(Value: Boolean); +begin + if FEnabled <> Value then begin + FEnabled := Value; + EnabledChanged; + end; +end; + +procedure TTBCustomItem.SetGroupIndex(Value: Integer); +begin + if FGroupIndex <> Value then begin + FGroupIndex := Value; + if Checked then + TurnSiblingsOff; + end; +end; + +procedure TTBCustomItem.SetImageIndex(Value: TImageIndex); +var + HadNoImage: Boolean; +begin + if FImageIndex <> Value then begin + HadNoImage := FImageIndex = -1; + FImageIndex := Value; + Change(HadNoImage xor (Value = -1)); + end; +end; + +function TTBCustomItem.ChangeImages(var AImages: TCustomImageList; + const Value: TCustomImageList; var AChangeLink: TTBImageChangeLink): Boolean; +{ Returns True if image list was resized } +var + LastWidth, LastHeight: Integer; +begin + Result := False; + LastWidth := -1; + LastHeight := -1; + if Assigned(AImages) then begin + LastWidth := AImages.Width; + LastHeight := AImages.Height; + AImages.UnregisterChanges(AChangeLink); + if Value = nil then begin + AChangeLink.Free; + AChangeLink := nil; + Result := True; + end; + end; + AImages := Value; + if Assigned(Value) then begin + Result := (Value.Width <> LastWidth) or (Value.Height <> LastHeight); + if AChangeLink = nil then begin + AChangeLink := TTBImageChangeLink.Create; + AChangeLink.FLastWidth := Value.Width; + AChangeLink.FLastHeight := Value.Height; + AChangeLink.OnChange := ImageListChangeHandler; + end; + Value.RegisterChanges(AChangeLink); + Value.FreeNotification(Self); + end; +end; + +procedure TTBCustomItem.SetImages(Value: TCustomImageList); +begin + if FImages <> Value then + Change(ChangeImages(FImages, Value, FImagesChangeLink)); +end; + +procedure TTBCustomItem.SetSubMenuImages(Value: TCustomImageList); +begin + if FSubMenuImages <> Value then begin + ChangeImages(FSubMenuImages, Value, FSubMenuImagesChangeLink); + SubMenuImagesChanged; + end; +end; + +procedure TTBCustomItem.SetInheritOptions(Value: Boolean); +begin + if FInheritOptions <> Value then begin + FInheritOptions := Value; + RefreshOptions; + end; +end; + +procedure TTBCustomItem.SetLinkSubitems(Value: TTBCustomItem); +begin + if Value = Self then + Value := nil; + if FLinkSubitems <> Value then begin + if Assigned(FLinkSubitems) then + RemoveFromList(FLinkSubitems.FLinkParents, Self); + FLinkSubitems := Value; + if Assigned(Value) then begin + Value.FreeNotification(Self); + AddToList(Value.FLinkParents, Self); + end; + Notify(tbicSubitemsChanged, -1, nil); + end; +end; + +function TTBCustomItem.FixOptions(const AOptions: TTBItemOptions): TTBItemOptions; +begin + Result := AOptions; + if not(tboToolbarStyle in Result) then + Exclude(Result, tboToolbarSize); +end; + +procedure TTBCustomItem.RefreshOptions; +const + NonInheritedOptions = [tboDefault]; + ChangeOptions = [tboDefault, tboDropdownArrow, tboImageAboveCaption, + tboNoRotation, tboSameWidth, tboToolbarStyle, tboToolbarSize]; +var + OldOptions, NewOptions: TTBItemOptions; + I: Integer; + Item: TTBCustomItem; +begin + OldOptions := FEffectiveOptions; + if FInheritOptions and Assigned(FParent) then + NewOptions := FParent.FEffectiveOptions - NonInheritedOptions + else + NewOptions := []; + NewOptions := FixOptions(NewOptions - FMaskOptions + FOptions); + if FEffectiveOptions <> NewOptions then begin + FEffectiveOptions := NewOptions; + if (OldOptions * ChangeOptions) <> (NewOptions * ChangeOptions) then + Change(True); + for I := 0 to Count-1 do begin + Item := Items[I]; + if Item.FInheritOptions then + Item.RefreshOptions; + end; + end; +end; + +procedure TTBCustomItem.SetMaskOptions(Value: TTBItemOptions); +begin + if FMaskOptions <> Value then begin + FMaskOptions := Value; + RefreshOptions; + end; +end; + +procedure TTBCustomItem.SetOptions(Value: TTBItemOptions); +begin + Value := FixOptions(Value); + if FOptions <> Value then begin + FOptions := Value; + RefreshOptions; + end; +end; + +procedure TTBCustomItem.SetRadioItem(Value: Boolean); +begin + if FRadioItem <> Value then begin + FRadioItem := Value; + Change(False); + end; +end; + +procedure TTBCustomItem.SetVisible(Value: Boolean); +begin + if FVisible <> Value then begin + FVisible := Value; + Change(True); + end; +end; + + +{ TTBGroupItem } + +constructor TTBGroupItem.Create(AOwner: TComponent); +begin + inherited; + ItemStyle := ItemStyle + [tbisEmbeddedGroup, tbisSubitemsEditable]; +end; + + +{ TTBSubmenuItem } + +constructor TTBSubmenuItem.Create(AOwner: TComponent); +begin + inherited; + ItemStyle := ItemStyle + [tbisSubMenu, tbisSubitemsEditable]; +end; + +function TTBSubmenuItem.GetDropdownCombo: Boolean; +begin + Result := tbisCombo in ItemStyle; +end; + +procedure TTBSubmenuItem.SetDropdownCombo(Value: Boolean); +begin + if (tbisCombo in ItemStyle) <> Value then begin + if Value then + ItemStyle := ItemStyle + [tbisCombo] + else + ItemStyle := ItemStyle - [tbisCombo]; + Change(True); + end; +end; + + +{ TTBSeparatorItem } + +constructor TTBSeparatorItem.Create(AOwner: TComponent); +begin + inherited; + ItemStyle := ItemStyle - [tbisSelectable, tbisRedrawOnSelChange, + tbisRedrawOnMouseOverChange] + [tbisSeparator, tbisClicksTransparent]; +end; + +function TTBSeparatorItem.GetItemViewerClass(AView: TTBView): TTBItemViewerClass; +begin + Result := TTBSeparatorItemViewer; +end; + +procedure TTBSeparatorItem.SetBlank(Value: Boolean); +begin + if FBlank <> Value then begin + FBlank := Value; + Change(False); + end; +end; + + +{ TTBSeparatorItemViewer } + +procedure TTBSeparatorItemViewer.CalcSize(const Canvas: TCanvas; + var AWidth, AHeight: Integer); +begin + if not IsToolbarStyle then + { Office 2000's menu separators have a hard-coded height of 10 } + AHeight := 10 + else begin + AWidth := 6; + AHeight := 6; + end; +end; + +procedure TTBSeparatorItemViewer.Paint(const Canvas: TCanvas; + const ClientAreaRect: TRect; IsSelected, IsPushed, UseDisabledShadow: Boolean); +var + DC: HDC; + R: TRect; + ToolbarStyle, Horiz, LineSep: Boolean; +begin + DC := Canvas.Handle; + if TTBSeparatorItem(Item).FBlank then + Exit; + + R := ClientAreaRect; + ToolbarStyle := IsToolbarStyle; + Horiz := not ToolbarStyle or (View.FOrientation = tbvoVertical); + LineSep := tbisLineSep in State; + if LineSep then + Horiz := not Horiz; + if Horiz then begin + R.Top := R.Bottom div 2 - 1; + if not ToolbarStyle then + InflateRect(R, -tbMenuSeparatorOffset, 0) + else if LineSep then begin + if View.FOrientation = tbvoFloating then + InflateRect(R, -tbLineSepOffset, 0) + else + InflateRect(R, -tbDockedLineSepOffset, 0); + end; + DrawEdge(DC, R, EDGE_ETCHED, BF_TOP); + end + else begin + R.Left := R.Right div 2 - 1; + if LineSep then + InflateRect(R, 0, -tbDockedLineSepOffset); + DrawEdge(DC, R, EDGE_ETCHED, BF_LEFT); + end; +end; + +function TTBSeparatorItemViewer.UsesSameWidth: Boolean; +begin + Result := False; +end; + + +{ TTBControlItem } + +constructor TTBControlItem.Create(AOwner: TComponent); +begin + inherited; + ItemStyle := ItemStyle - [tbisSelectable] + [tbisClicksTransparent]; +end; + +destructor TTBControlItem.Destroy; +begin + inherited; + { Free the associated control *after* the item is completely destroyed } + if not FDontFreeControl and Assigned(FControl) and + not(csAncestor in FControl.ComponentState) then + FControl.Free; +end; + +procedure TTBControlItem.Notification(AComponent: TComponent; + Operation: TOperation); +begin + inherited; + if (Operation = opRemove) and (AComponent = FControl) then + Control := nil; +end; + +procedure TTBControlItem.SetControl(Value: TControl); +begin + if FControl <> Value then begin + FControl := Value; + if Assigned(Value) then + Value.FreeNotification(Self); + Change(True); + end; +end; + + +{ TTBItemViewer } + +constructor TTBItemViewer.Create(AView: TTBView; AItem: TTBCustomItem; + AGroupLevel: Integer); +begin + inherited Create; + FItem := AItem; + FView := AView; + FGroupLevel := AGroupLevel; + ReferenceClickWnd; +end; + +destructor TTBItemViewer.Destroy; +begin + RemoveFromClickList(Self); + if Assigned(FAccObjectInstance) then begin + FAccObjectInstance.ClientIsDestroying; + FAccObjectInstance := nil; + end; + inherited; + ReleaseClickWnd; +end; + +function TTBItemViewer.GetAccObject: TTBBaseAccObject; +begin + if FAccObjectInstance = nil then begin + if not InitializeOleAcc then begin + Result := nil; + Exit; + end; + FAccObjectInstance := TTBItemViewerAccObject.Create(Self); + end; + Result := FAccObjectInstance; +end; + +procedure TTBItemViewer.AccSelect(const AExecute: Boolean); +{ Called by ClickWndProc when an item of type TTBItemViewer is in ClickList } +var + Obj: {$IFNDEF CLR} IDispatch {$ELSE} TTBBaseAccObject {$ENDIF}; +begin + { Ensure FAccObjectInstance is created by calling GetAccObject. Store the + reference as an interface so that the object will be destroyed when we + exit if it's no longer used. } + Obj := GetAccObject; + if Assigned(Obj) then + (FAccObjectInstance as TTBItemViewerAccObject).HandleAccSelect(AExecute); +end; + +procedure TTBItemViewer.PostAccSelect(const AExecute: Boolean); +{ Internally called by TTBItemViewerAccObject. Don't call directly. } +begin + QueueClick(Self, Ord(AExecute)); +end; + +function TTBItemViewer.IsAccessible: Boolean; +{ Returns True if MSAA clients should know about the viewer, specifically + if it's either shown, off-edge, or clipped (in other words, not completely + invisible/inaccessible). } +begin + { Note: Can't simply check Item.Visible because the chevron item's Visible + property is always True } + Result := Show or OffEdge or Clipped; +end; + +function TTBItemViewer.GetCaptionText: String; +var + P: Integer; +begin + Result := Item.Caption; + P := Pos(#9, Result); + if P <> 0 then + SetLength(Result, P-1); +end; + +function TTBItemViewer.GetHintText: String; +begin + Result := GetShortHint(Item.Hint); + { If there is no short hint, use the caption for the hint. Like Office, + strip any trailing colon or ellipsis. } + if (Result = '') and not(tboNoAutoHint in Item.EffectiveOptions) and + (not(tbisSubmenu in Item.ItemStyle) or (tbisCombo in Item.ItemStyle) or + not CaptionShown) then + Result := StripAccelChars(StripTrailingPunctuation(GetCaptionText)); + { Call associated action's OnHint event handler to post-process the hint } + if Assigned(Item.ActionLink) and + (Item.ActionLink.Action is TCustomAction) then begin + if not TCustomAction(Item.ActionLink.Action).DoHint(Result) then + Result := ''; + { Note: TControlActionLink.DoShowHint actually misinterprets the result + of DoHint, but we get it right... } + end; + { Add shortcut text } + if (Result <> '') and Application.HintShortCuts and + (Item.ShortCut <> scNone) then + Result := Format('%s (%s)', [Result, ShortCutToText(Item.ShortCut)]); +end; + +function TTBItemViewer.CaptionShown: Boolean; +begin + Result := (GetCaptionText <> '') and (not IsToolbarSize or + (Item.ImageIndex < 0) or (Item.DisplayMode in [nbdmTextOnly, nbdmImageAndText])) or + (tboImageAboveCaption in Item.EffectiveOptions); +end; + +function TTBItemViewer.ImageShown: Boolean; +begin + {}{should also return false if Images=nil (use UsedImageList?)} + ImageShown := (Item.ImageIndex >= 0) and + ((Item.DisplayMode in [nbdmDefault, nbdmImageAndText]) or + (IsToolbarStyle and (Item.DisplayMode = nbdmTextOnlyInMenus))); +end; + +function TTBItemViewer.GetImageList: TCustomImageList; +var + V: TTBView; +begin + Result := Item.Images; + if Assigned(Result) then + Exit; + V := View; + repeat + if Assigned(V.FCurParentItem) then begin + Result := V.FCurParentItem.SubMenuImages; + if Assigned(Result) then + Break; + end; + if Assigned(V.FParentItem) then begin + Result := V.FParentItem.SubMenuImages; + if Assigned(Result) then + Break; + end; + V := V.FParentView; + until V = nil; +end; + +function TTBItemViewer.IsRotated: Boolean; +{ Returns True if the caption should be drawn with rotated (vertical) text, + underneath the image } +begin + Result := (View.Orientation = tbvoVertical) and + not (tboNoRotation in Item.EffectiveOptions) and + not (tboImageAboveCaption in Item.EffectiveOptions); +end; + +procedure TTBItemViewer.CalcSize(const Canvas: TCanvas; + var AWidth, AHeight: Integer); +var + ToolbarStyle: Boolean; + DC: HDC; + TextMetrics: TTextMetric; + H, LeftMargin: Integer; + ImgList: TCustomImageList; + S: String; + RotatedFont, SaveFont: HFONT; +begin + ToolbarStyle := IsToolbarStyle; + DC := Canvas.Handle; + ImgList := GetImageList; + if ToolbarStyle then begin + AWidth := 6; + AHeight := 6; + end + else begin + AWidth := 0; + AHeight := 0; + end; + if not ToolbarStyle or CaptionShown then begin + if not IsRotated then begin + GetTextMetrics(DC, TextMetrics); + Inc(AHeight, TextMetrics.tmHeight); + Inc(AWidth, GetTextWidth(DC, GetCaptionText, True)); + if ToolbarStyle then + Inc(AWidth, 6); + end + else begin + { Vertical text isn't always the same size as horizontal text, so we have + to select the rotated font into the DC to get an accurate size } + RotatedFont := CreateRotatedFont(DC); + SaveFont := SelectObject(DC, RotatedFont); + GetTextMetrics(DC, TextMetrics); + Inc(AWidth, TextMetrics.tmHeight); + Inc(AHeight, GetTextWidth(DC, GetCaptionText, True)); + if ToolbarStyle then + Inc(AHeight, 6); + SelectObject(DC, SaveFont); + DeleteObject(RotatedFont); + end; + end; + if ToolbarStyle and ImageShown and Assigned(ImgList) then begin + if not IsRotated and not(tboImageAboveCaption in Item.EffectiveOptions) then begin + Inc(AWidth, ImgList.Width + 1); + if AHeight < ImgList.Height + 6 then + AHeight := ImgList.Height + 6; + end + else begin + Inc(AHeight, ImgList.Height); + if AWidth < ImgList.Width + 7 then + AWidth := ImgList.Width + 7; + end; + end; + if ToolbarStyle and (tbisSubmenu in Item.ItemStyle) then begin + if tbisCombo in Item.ItemStyle then + Inc(AWidth, tbDropdownComboArrowWidth) + else + if tboDropdownArrow in Item.EffectiveOptions then begin + if View.Orientation <> tbvoVertical then + Inc(AWidth, tbDropdownArrowWidth) + else + Inc(AHeight, tbDropdownArrowWidth); + end; + end; + if not ToolbarStyle then begin + Inc(AHeight, TextMetrics.tmExternalLeading + tbMenuVerticalMargin); + if Assigned(ImgList) then begin + H := ImgList.Height + 3; + if H > AHeight then + AHeight := H; + LeftMargin := MulDiv(ImgList.Width + 3, AHeight, H); + end + else + LeftMargin := AHeight; + Inc(AWidth, LeftMargin + tbMenuImageTextSpace + tbMenuLeftTextMargin + + tbMenuRightTextMargin); + S := Item.GetShortCutText; + if S <> '' then + Inc(AWidth, (AHeight - 6) + GetTextWidth(DC, S, True)); + Inc(AWidth, AHeight); + end; +end; + +procedure TTBItemViewer.DrawItemCaption(const Canvas: TCanvas; ARect: TRect; + const ACaption: String; ADrawDisabledShadow: Boolean; AFormat: UINT); +var + DC: HDC; + + procedure Draw; + begin + if not IsRotated then + DrawTextStr(DC, ACaption, ARect, AFormat) + else + DrawRotatedText(DC, ACaption, ARect, AFormat); + end; + +var + ShadowColor, HighlightColor, SaveTextColor: DWORD; +begin + DC := Canvas.Handle; + if not ADrawDisabledShadow then + Draw + else begin + ShadowColor := GetSysColor(COLOR_BTNSHADOW); + HighlightColor := GetSysColor(COLOR_BTNHIGHLIGHT); + OffsetRect(ARect, 1, 1); + SaveTextColor := SetTextColor(DC, HighlightColor); + Draw; + OffsetRect(ARect, -1, -1); + SetTextColor(DC, ShadowColor); + Draw; + SetTextColor(DC, SaveTextColor); + end; +end; + +procedure TTBItemViewer.Paint(const Canvas: TCanvas; + const ClientAreaRect: TRect; IsSelected, IsPushed, UseDisabledShadow: Boolean); +var + ShowEnabled, HasArrow: Boolean; + MenuCheckWidth, MenuCheckHeight: Integer; + + function GetDrawTextFlags: UINT; + begin + Result := 0; + if not AreKeyboardCuesEnabled and (vsUseHiddenAccels in View.FStyle) and + not(vsShowAccels in View.FState) then + Result := DT_HIDEPREFIX; + end; + + procedure DrawSubmenuArrow; + var + BR: TRect; + Bmp: TBitmap; + + procedure DrawWithColor(AColor: TColor); + const + ROP_DSPDxax = $00E20746; + var + DC: HDC; + SaveTextColor, SaveBkColor: TColorRef; + begin + Canvas.Brush.Color := AColor; + DC := Canvas.Handle; + SaveTextColor := SetTextColor(DC, clWhite); + SaveBkColor := SetBkColor(DC, clBlack); + BitBlt(DC, BR.Left, BR.Top, MenuCheckWidth, MenuCheckHeight, + Bmp.Canvas.Handle, 0, 0, ROP_DSPDxax); + SetBkColor(DC, SaveBkColor); + SetTextColor(DC, SaveTextColor); + Canvas.Brush.Style := bsClear; + end; + + begin + Bmp := TBitmap.Create; + try + Bmp.Monochrome := True; + Bmp.Width := MenuCheckWidth; + Bmp.Height := MenuCheckHeight; + BR := Rect(0, 0, MenuCheckWidth, MenuCheckHeight); + DrawFrameControl(Bmp.Canvas.Handle, BR, DFC_MENU, DFCS_MENUARROW); + OffsetRect(BR, ClientAreaRect.Right - MenuCheckWidth, + ClientAreaRect.Top + ((ClientAreaRect.Bottom - ClientAreaRect.Top) - MenuCheckHeight) div 2); + if not UseDisabledShadow then begin + if ShowEnabled and (tbisCombo in Item.ItemStyle) and IsSelected then begin + OffsetRect(BR, 1, 1); + DrawWithColor(clBtnText); + end + else + DrawWithColor(Canvas.Font.Color); + end + else begin + OffsetRect(BR, 1, 1); + DrawWithColor(clBtnHighlight); + OffsetRect(BR, -1, -1); + DrawWithColor(clBtnShadow); + end; + finally + Bmp.Free; + end; + end; + + procedure DrawDropdownArrow(R: TRect; Rotated: Boolean); + + procedure DrawWithColor(AColor: TColor); + var + X, Y: Integer; + P: array[0..2] of TPoint; + begin + X := (R.Left + R.Right) div 2; + Y := (R.Top + R.Bottom) div 2; + if not Rotated then begin + Dec(Y); + P[0].X := X-2; + P[0].Y := Y; + P[1].X := X+2; + P[1].Y := Y; + P[2].X := X; + P[2].Y := Y+2; + end + else begin + Dec(X); + P[0].X := X; + P[0].Y := Y+2; + P[1].X := X; + P[1].Y := Y-2; + P[2].X := X-2; + P[2].Y := Y; + end; + Canvas.Pen.Color := AColor; + Canvas.Brush.Color := AColor; + Canvas.Polygon(P); + end; + + begin + if not UseDisabledShadow then + DrawWithColor(Canvas.Font.Color) + else begin + OffsetRect(R, 1, 1); + DrawWithColor(clBtnHighlight); + OffsetRect(R, -1, -1); + DrawWithColor(clBtnShadow); + end; + end; + + function GetDitherBitmap: TBitmap; + begin + Result := AllocPatternBitmap(clBtnFace, clBtnHighlight); + Result.HandleType := bmDDB; { needed for Win95, or else brush is solid white } + end; + +const + EdgeStyles: array[Boolean] of UINT = (BDR_RAISEDINNER, BDR_SUNKENOUTER); + BlackCheckMarkPoints: array[0..6] of TPoint = ( + (X: -2; Y: -2), (X: 0; Y: 0), (X: 4; Y: -4), + (X: 4; Y: -3), (X: 0; Y: 1), (X: -2; Y: -1), + (X: -2; Y: -2)); + WhiteCheckMarkPoints: array[0..4] of TPoint = ( + (X: -3; Y: -2), (X: -3; Y: -1), (X: 0; Y: 2), + (X: 5; Y: -3), (X: 5; Y: -5)); +var + ToolbarStyle, ImageIsShown: Boolean; + R, RC, RD: TRect; + S: String; + ImgList: TCustomImageList; + I, X, Y: Integer; + BlackPoints: array[0..6] of TPoint; + WhitePoints: array[0..4] of TPoint; + DrawTextFlags: UINT; + LeftMargin: Integer; + TextMetrics: TTextMetric; +begin + ToolbarStyle := IsToolbarStyle; + ShowEnabled := Item.Enabled or View.Customizing; + HasArrow := (tbisSubmenu in Item.ItemStyle) and + ((tbisCombo in Item.ItemStyle) or (tboDropdownArrow in Item.EffectiveOptions)); + MenuCheckWidth := GetSystemMetrics(SM_CXMENUCHECK); + MenuCheckHeight := GetSystemMetrics(SM_CYMENUCHECK); + ImgList := GetImageList; + ImageIsShown := ImageShown and Assigned(ImgList); + LeftMargin := 0; + if not ToolbarStyle then begin + if Assigned(ImgList) then + LeftMargin := MulDiv(ImgList.Width + 3, ClientAreaRect.Bottom, ImgList.Height + 3) + else + LeftMargin := ClientAreaRect.Bottom; + end; + + { Border } + RC := ClientAreaRect; + if ToolbarStyle then begin + if HasArrow then begin + if tbisCombo in Item.ItemStyle then begin + Dec(RC.Right, tbDropdownComboMargin); + RD := RC; + Dec(RC.Right, tbDropdownComboArrowWidth - tbDropdownComboMargin); + RD.Left := RC.Right; + end + else begin + if View.Orientation <> tbvoVertical then + RD := Rect(RC.Right - tbDropdownArrowWidth - tbDropdownArrowMargin, 0, + RC.Right - tbDropdownArrowMargin, RC.Bottom) + else + RD := Rect(0, RC.Bottom - tbDropdownArrowWidth - tbDropdownArrowMargin, + RC.Right, RC.Bottom - tbDropdownArrowMargin); + end; + end + else + SetRectEmpty(RD); + if (IsSelected and ShowEnabled) or Item.Checked or + (csDesigning in Item.ComponentState) then begin + if not(tbisCombo in Item.ItemStyle) then + DrawEdge(Canvas.Handle, RC, EdgeStyles[IsPushed or Item.Checked], BF_RECT) + else begin + DrawEdge(Canvas.Handle, RC, EdgeStyles[(IsPushed and View.FCapture) or Item.Checked], BF_RECT); + if (IsSelected and ShowEnabled) or + (csDesigning in Item.ComponentState) then + DrawEdge(Canvas.Handle, RD, EdgeStyles[IsPushed and not View.FCapture], BF_RECT); + end; + end; + if HasArrow then begin + if not(tbisCombo in Item.ItemStyle) and IsPushed then + OffsetRect(RD, 1, 1); + DrawDropdownArrow(RD, not(tbisCombo in Item.ItemStyle) and + (View.Orientation = tbvoVertical)); + end; + InflateRect(RC, -1, -1); + if Item.Checked and not (IsSelected and ShowEnabled) then begin + Canvas.Brush.Bitmap := GetDitherBitmap; + Canvas.FillRect(RC); + Canvas.Brush.Style := bsClear; + end; + InflateRect(RC, -1, -1); + if Item.Checked or + ((IsSelected and IsPushed) and + (not(tbisCombo in Item.ItemStyle) or View.FCapture)) then + OffsetRect(RC, 1, 1); + if HasArrow and not(tbisCombo in Item.ItemStyle) then begin + if View.Orientation <> tbvoVertical then + Dec(RC.Right, tbDropdownArrowWidth) + else + Dec(RC.Bottom, tbDropdownArrowWidth); + end; + end + else begin + { On selected menu items, fill the background with the selected color. + Note: This assumes the brush color was not changed from the initial + value. } + if IsSelected then begin + R := RC; + if ImageIsShown or Item.Checked then + Inc(R.Left, LeftMargin + tbMenuImageTextSpace); + if (tbisCombo in Item.ItemStyle) and IsSelected and ShowEnabled then + Dec(R.Right, MenuCheckWidth); + Canvas.FillRect(R); + end; + end; + + { Adjust brush & font } + Canvas.Brush.Style := bsClear; + if tboDefault in Item.EffectiveOptions then + with Canvas.Font do Style := Style + [fsBold]; + GetTextMetrics(Canvas.Handle, TextMetrics); + + { Caption } + if CaptionShown then begin + S := GetCaptionText; + R := RC; + DrawTextFlags := GetDrawTextFlags; + if ToolbarStyle then begin + if ImageIsShown then begin + if not IsRotated and not(tboImageAboveCaption in Item.EffectiveOptions) then + Inc(R.Left, ImgList.Width + 1) + else + Inc(R.Top, ImgList.Height + 1); + end; + DrawItemCaption(Canvas, R, S, UseDisabledShadow, + DT_SINGLELINE or DT_CENTER or DT_VCENTER or DrawTextFlags) + end + else begin + Inc(R.Left, LeftMargin + tbMenuImageTextSpace + tbMenuLeftTextMargin); + { Like standard menus, shift the text up one pixel if the text height + is 4 pixels less than the total item height. This is done so underlined + characters aren't displayed too low. } + if (R.Bottom - R.Top) - (TextMetrics.tmHeight + TextMetrics.tmExternalLeading) = tbMenuVerticalMargin then + Dec(R.Bottom); + Inc(R.Top, TextMetrics.tmExternalLeading); + DrawItemCaption(Canvas, R, S, UseDisabledShadow, + DT_SINGLELINE or DT_LEFT or DT_VCENTER or DrawTextFlags); + end; + end; + + { Shortcut and/or submenu arrow (menus only) } + if not ToolbarStyle then begin + S := Item.GetShortCutText; + if S <> '' then begin + R := RC; + R.Left := R.Right - (R.Bottom - R.Top) - GetTextWidth(Canvas.Handle, S, True); + { Like standard menus, shift the text up one pixel if the text height + is 4 pixels less than the total item height. This is done so underlined + characters aren't displayed too low. } + if (R.Bottom - R.Top) - (TextMetrics.tmHeight + TextMetrics.tmExternalLeading) = tbMenuVerticalMargin then + Dec(R.Bottom); + Inc(R.Top, TextMetrics.tmExternalLeading); + DrawItemCaption(Canvas, R, S, UseDisabledShadow, + DT_SINGLELINE or DT_LEFT or DT_VCENTER or DT_NOPREFIX); + end; + if tbisSubmenu in Item.ItemStyle then begin + if tbisCombo in Item.ItemStyle then begin + R := RC; + R.Left := R.Right - MenuCheckWidth; + if IsSelected and ShowEnabled then + DrawEdge(Canvas.Handle, R, BDR_SUNKENOUTER, BF_RECT or BF_MIDDLE) + else begin + Dec(R.Left); + if not IsSelected then + DrawEdge(Canvas.Handle, R, EDGE_ETCHED, BF_LEFT) + else + DrawEdge(Canvas.Handle, R, BDR_SUNKENOUTER, BF_LEFT); + end; + end; + DrawSubmenuArrow; + end; + end; + + { Image, or check box } + if ImageIsShown or (not ToolbarStyle and Item.Checked) then begin + R := RC; + if ToolbarStyle then begin + if not IsRotated and not(tboImageAboveCaption in Item.EffectiveOptions) then + R.Right := R.Left + ImgList.Width + 2 + else + R.Bottom := R.Top + ImgList.Height + 2; + end + else begin + R.Right := R.Left + LeftMargin; + if (IsSelected and ShowEnabled) or Item.Checked then + DrawEdge(Canvas.Handle, R, EdgeStyles[Item.Checked], BF_RECT or BF_MIDDLE); + if Item.Checked and not IsSelected then begin + InflateRect(R, -1, -1); + Canvas.Brush.Bitmap := GetDitherBitmap; + Canvas.FillRect(R); + Canvas.Brush.Style := bsClear; + InflateRect(R, 1, 1); + end; + if Item.Checked then + OffsetRect(R, 1, 1); + end; + if ImageIsShown then begin + X := R.Left + ((R.Right - R.Left) - ImgList.Width) div 2; + Y := R.Top + ((R.Bottom - R.Top) - ImgList.Height) div 2; + if ImgList is TTBCustomImageList then + TTBCustomImageList(ImgList).DrawState(Canvas, X, Y, Item.ImageIndex, + ShowEnabled, IsSelected, Item.Checked) + else + ImgList.Draw(Canvas, X, Y, Item.ImageIndex, ShowEnabled); + end + else + if not ToolbarStyle and Item.Checked then begin + { Draw default check mark or radio button image when user hasn't + specified their own } + X := (R.Left + R.Right) div 2; + Y := (R.Top + R.Bottom) div 2; + if Item.RadioItem then begin + Canvas.Pen.Color := clBtnText; + Canvas.Brush.Color := clBtnText; + Canvas.RoundRect(X-3, Y-3, X+2, Y+2, 2, 2); + Canvas.Pen.Color := clBtnHighlight; + Canvas.Brush.Style := bsClear; + Canvas.RoundRect(X-4, Y-4, X+3, Y+3, 6, 6); + end + else begin + Dec(X, 2); + Inc(Y); + for I := Low(BlackPoints) to High(BlackPoints) do begin + BlackPoints[I].X := X + BlackCheckMarkPoints[I].X; + BlackPoints[I].Y := Y + BlackCheckMarkPoints[I].Y; + end; + for I := Low(WhitePoints) to High(WhitePoints) do begin + WhitePoints[I].X := X + WhiteCheckMarkPoints[I].X; + WhitePoints[I].Y := Y + WhiteCheckMarkPoints[I].Y; + end; + Canvas.Pen.Color := clBtnText; + Polyline(Canvas.Handle, BlackPoints, Length(BlackPoints)); + Canvas.Pen.Color := clBtnHighlight; + Polyline(Canvas.Handle, WhitePoints, Length(WhitePoints)); + end; + end; + end; +end; + +procedure TTBItemViewer.GetCursor(const Pt: TPoint; var ACursor: HCURSOR); +begin +end; + +function TTBItemViewer.GetIndex: Integer; +begin + Result := View.IndexOf(Self); +end; + +function TTBItemViewer.IsToolbarSize: Boolean; +begin + Result := View.FIsToolbar or (tboToolbarSize in Item.FEffectiveOptions); +end; + +function TTBItemViewer.IsToolbarStyle: Boolean; +begin + Result := View.FIsToolbar or (tboToolbarStyle in Item.FEffectiveOptions); +end; + +function TTBItemViewer.IsPtInButtonPart(X, Y: Integer): Boolean; +var + W: Integer; +begin + Result := not(tbisSubmenu in Item.ItemStyle); + if tbisCombo in Item.ItemStyle then begin + if IsToolbarStyle then + W := tbDropdownComboArrowWidth + else + W := GetSystemMetrics(SM_CXMENUCHECK); + Result := X < (BoundsRect.Right - BoundsRect.Left) - W; + end; +end; + +procedure TTBItemViewer.MouseDown(Shift: TShiftState; X, Y: Integer; + var MouseDownOnMenu: Boolean); + + procedure HandleDefaultDoubleClick(const View: TTBView); + { Looks for a tboDefault item in View and ends the modal loop if it finds + one. } + var + I: Integer; + Viewer: TTBItemViewer; + Item: TTBCustomItem; + begin + for I := 0 to View.FViewers.Count-1 do begin + Viewer := View.Viewers[I]; + Item := Viewer.Item; + if (Viewer.Show or Viewer.Clipped) and (tboDefault in Item.EffectiveOptions) and + (tbisSelectable in Item.ItemStyle) and Item.Enabled and Item.Visible then begin + Viewer.Execute(True); + Break; + end; + end; + end; + +var + WasAlreadyOpen: Boolean; +begin + if not Item.Enabled then begin + if (View.FParentView = nil) and not View.FIsPopup then + View.EndModal; + Exit; + end; + if IsPtInButtonPart(X, Y) then begin + if IsToolbarStyle then begin + View.CancelChildPopups; + View.SetCapture; + View.Invalidate(Self); + end; + end + else begin + WasAlreadyOpen := (View.FOpenViewer = Self); + if View.OpenChildPopup(False) then begin + if WasAlreadyOpen and ((View.FParentView = nil) and not View.FIsPopup) then + MouseDownOnMenu := True; + if (ssDouble in Shift) and not(tbisCombo in Item.ItemStyle) then + HandleDefaultDoubleClick(View.FOpenViewerView); + end; + end; +end; + +procedure TTBItemViewer.MouseMove(X, Y: Integer); +begin +end; + +procedure TTBItemViewer.MouseUp(X, Y: Integer; MouseWasDownOnMenu: Boolean); +var + HadCapture, IsToolbarItem: Boolean; +begin + HadCapture := View.FCapture; + View.CancelCapture; + IsToolbarItem := (View.FParentView = nil) and not View.FIsPopup; + if not View.FMouseOverSelected or not Item.Enabled or + (tbisClicksTransparent in Item.ItemStyle) then begin + if IsToolbarItem then + View.EndModal; + Exit; + end; + if (tbisSubmenu in Item.ItemStyle) and not IsPtInButtonPart(X, Y) then begin + if IsToolbarItem and MouseWasDownOnMenu then + View.EndModal; + end + else begin + { it's a 'normal' item } + if not IsToolbarStyle or HadCapture then + Execute(True); + end; +end; + +procedure TTBItemViewer.MouseWheel(WheelDelta, X, Y: Integer); +begin +end; + +procedure TTBItemViewer.LosingCapture; +begin + View.Invalidate(Self); +end; + +procedure TTBItemViewer.Entering; +begin + if Assigned(Item.FOnSelect) then + Item.FOnSelect(Item, Self, True); +end; + +procedure TTBItemViewer.Leaving; +begin + if Assigned(Item.FOnSelect) then + Item.FOnSelect(Item, Self, False); +end; + +procedure TTBItemViewer.KeyDown(var Key: Word; Shift: TShiftState); +begin +end; + +function TTBItemViewer.ScreenToClient(const P: TPoint): TPoint; +begin + Result := View.FWindow.ScreenToClient(P); + Dec(Result.X, BoundsRect.Left); + Dec(Result.Y, BoundsRect.Top); +end; + +function TTBItemViewer.UsesSameWidth: Boolean; +{ If UsesSameWidth returns True, the item viewer's width will be expanded to + match the widest item viewer on the same view whose UsesSameWidth method + also returns True. } +begin + Result := (tboImageAboveCaption in Item.FEffectiveOptions) and + (tboSameWidth in Item.FEffectiveOptions) and IsToolbarSize; +end; + +function TTBItemViewer.DoExecute: Boolean; +{ Low-level 'execute' handler. Returns True if the caller should call + GivePriority on the viewer (normally, if the 'execute' operation was a + success and the modal loop is ending). } +begin + View.EndModalWithClick(Self); + Result := True; +end; + +procedure TTBItemViewer.Execute(AGivePriority: Boolean); +{ Calls DoExecute and, if applicable, View.GivePriority. Note that it is up to + the caller to check the viewer's visibility and enabled state. } +begin + if DoExecute and AGivePriority then + View.GivePriority(Self); +end; + +function TTBItemViewer.GetAccRole: Integer; +{ Returns the MSAA "role" of the viewer. } +const + { Constants from OleAcc.h } + ROLE_SYSTEM_CLIENT = $a; + ROLE_SYSTEM_MENUITEM = $c; + ROLE_SYSTEM_SEPARATOR = $15; + ROLE_SYSTEM_PUSHBUTTON = $2b; + ROLE_SYSTEM_BUTTONMENU = $39; +begin + if Item is TTBControlItem then + Result := ROLE_SYSTEM_CLIENT + else if tbisSeparator in Item.ItemStyle then + Result := ROLE_SYSTEM_SEPARATOR + else if View.IsPopup or (vsMenuBar in View.Style) then + Result := ROLE_SYSTEM_MENUITEM + else if tbisSubmenu in Item.ItemStyle then + Result := ROLE_SYSTEM_BUTTONMENU + else + Result := ROLE_SYSTEM_PUSHBUTTON; +end; + +function TTBItemViewer.GetAccValue(var Value: WideString): Boolean; +{ Gets the MSAA "value" text of the viewer. Returns True if something was + assigned to Value, or False if the viewer does not possess a "value". } +begin + Result := False; +end; + + +{ TTBView } + +constructor TTBView.Create(AOwner: TComponent; AParentView: TTBView; + AParentItem: TTBCustomItem; AWindow: TWinControl; + AIsToolbar, ACustomizing, AUsePriorityList: Boolean); +begin + {$IFDEF CLR} + { TB2Acc's IAccessible implementations must be called from the same thread + that created the view, so verify that the program has [STAThread] } + CheckThreadingModel(System.Threading.ApartmentState.STA); + {$ENDIF} + inherited Create(AOwner); + FViewers := TList.Create; + FBackgroundColor := clDefault; + FCustomizing := ACustomizing; + FIsPopup := not AIsToolbar; + FIsToolbar := AIsToolbar; + FNewViewersGetHighestPriority := True; + FParentView := AParentView; + FParentItem := AParentItem; + if Assigned(FParentItem) then begin + //FIsToolbar := FIsToolbar or FParentItem.FDisplayAsToolbar; + FParentItem.RegisterNotification(LinkNotification); + FParentItem.FreeNotification(Self); + end; + FUsePriorityList := AUsePriorityList; + FWindow := AWindow; + UpdateCurParentItem; +end; + +destructor TTBView.Destroy; +begin + CloseChildPopups; + if Assigned(FAccObjectInstance) then begin + FAccObjectInstance.ClientIsDestroying; + { Get rid of our own reference to FAccObjectInstance. Normally the + reference count will be now be zero and FAccObjectInstance will be + freed, unless MSAA still holds a reference. } + {$IFNDEF CLR} + FAccObjectInstance._Release; + {$ENDIF} + FAccObjectInstance := nil; + end; + { If parent view is a toolbar, invalidate the open item so that it's + redrawn back in the "up" position } + if Assigned(ParentView) and ParentView.FIsToolbar then begin + Include(ParentView.FState, vsNoAnimation); + if Assigned(ParentView.FOpenViewer) then + ParentView.Invalidate(ParentView.FOpenViewer); + end; + if Assigned(FCurParentItem) then + FCurParentItem.UnregisterNotification(ItemNotification); + if Assigned(FParentItem) then + FParentItem.UnregisterNotification(LinkNotification); + inherited; + FPriorityList.Free; + FreeViewers; + FreeAndNil(FViewers); + { Now that we're destroyed, "focus" the parent view } + if Assigned(FParentView) then + FParentView.NotifyFocusEvent; +end; + +function TTBView.GetAccObject: TTBBaseAccObject; +begin + if FAccObjectInstance = nil then begin + if not InitializeOleAcc then begin + Result := nil; + Exit; + end; + FAccObjectInstance := TTBViewAccObject.Create(Self); + { Strictly as an optimization, take a reference for ourself and keep it + for the lifetime of the view. (Destroy calls _Release.) } + {$IFNDEF CLR} + FAccObjectInstance._AddRef; + {$ENDIF} + end; + Result := FAccObjectInstance; +end; + +function TTBView.HandleWMGetObject(var Message: TMessage): Boolean; +begin + { Note: In a 64-bit build, object identifiers can come in either + sign-extended or zero-extended from 32 to 64 bits. Clip to 32 bits here + to ensure we accept both forms. } + if (ClipToLongint(Message.LParam) = Longint(OBJID_CLIENT)) and InitializeOleAcc then begin + Message.Result := LresultFromObjectFunc( + {$IFNDEF CLR} ITBAccessible {$ELSE} TypeOf(ITBAccessible).GUID {$ENDIF}, + Message.WParam, GetAccObject); + Result := True; + end + else + Result := False; +end; + +procedure TTBView.UpdateCurParentItem; +var + Value: TTBCustomItem; +begin + Value := ItemContainingItems(FParentItem); + if FCurParentItem <> Value then begin + CloseChildPopups; + if Assigned(FCurParentItem) then + FCurParentItem.UnregisterNotification(ItemNotification); + FCurParentItem := Value; + if Assigned(Value) then + Value.RegisterNotification(ItemNotification); + RecreateAllViewers; + if Assigned(Value) and not(csDesigning in Value.ComponentState) then + InitiateActions; + end; +end; + +procedure TTBView.InitiateActions; +var + I: Integer; +begin + { Use a 'while' instead of a 'for' since an InitiateAction implementation + may add/delete items } + I := 0; + while I < FViewers.Count do begin + Viewers[I].Item.InitiateAction; + Inc(I); + end; +end; + +procedure TTBView.Notification(AComponent: TComponent; Operation: TOperation); +begin + inherited; + if Operation = opRemove then begin + if AComponent = FParentItem then begin + FParentItem := nil; + UpdateCurParentItem; + if Assigned(FParentView) then + FParentView.CloseChildPopups; + end + else if AComponent = FOpenViewerWindow then begin + FOpenViewerWindow := nil; + FOpenViewerView := nil; + FOpenViewer := nil; + end + else if AComponent = FChevronParentView then + FChevronParentView := nil; + end +end; + +function TTBView.ContainsView(AView: TTBView): Boolean; +begin + while Assigned(AView) and (AView <> Self) do + AView := AView.FParentView; + Result := Assigned(AView); +end; + +function TTBView.GetRootView: TTBView; +begin + Result := Self; + while Assigned(Result.FParentView) do + Result := Result.FParentView; +end; + +function TTBView.GetParentToolbarView: TTBView; +begin + Result := Self; + while Assigned(Result) and not Result.FIsToolbar do + Result := Result.FParentView; +end; + +function TTBView.GetViewer(Index: Integer): TTBItemViewer; +begin + if (Index < 0) or (Index >= FViewers.Count) then begin + TTBCustomItem.IndexError; + Result := nil; + Exit; + end; + Result := TTBItemViewer(FViewers.List[Index]); +end; + +function TTBView.GetViewerCount: Integer; +begin + Result := FViewers.Count; +end; + +procedure TTBView.FreeViewers; +var + I: Integer; + Viewer: TTBItemViewer; +begin + if Assigned(FViewers) then begin + for I := FViewers.Count-1 downto 0 do begin + Viewer := Viewers[I]; + FViewers.Delete(I); + Viewer.Free; + end; + end; +end; + +procedure TTBView.InvalidatePositions; +begin + if FValidated then begin + FValidated := False; + if Assigned(FWindow) and FWindow.HandleAllocated then + InvalidateRect(FWindow.Handle, nil, True); + end; +end; + +procedure TTBView.ValidatePositions; +begin + if not FValidated then + UpdatePositions; +end; + +procedure TTBView.TryValidatePositions; +begin + if (FUpdating = 0) and + (not Assigned(FParentItem) or not(csLoading in FParentItem.ComponentState)) and + (not Assigned(FParentItem.Owner) or not(csLoading in FParentItem.Owner.ComponentState)) then + ValidatePositions; +end; + +(*procedure TTBView.TryRevalidatePositions; +begin + if FValidated then begin + if FUpdating = 0 then begin + FreePositions; + UpdatePositions; + end + else + InvalidatePositions; + end; +end;*) + +function TTBView.Find(Item: TTBCustomItem): TTBItemViewer; +var + I: Integer; +begin + for I := 0 to FViewers.Count-1 do + if Viewers[I].Item = Item then begin + Result := Viewers[I]; + Exit; + end; + raise ETBItemError.Create(STBViewerNotFound); +end; + +function TTBView.IndexOf(AViewer: TTBItemViewer): Integer; +var + I: Integer; +begin + if Assigned(AViewer) then + for I := 0 to FViewers.Count-1 do + if FViewers.List[I] = AViewer then begin + Result := I; + Exit; + end; + Result := -1; +end; + +procedure TTBView.DeletingViewer(Viewer: TTBItemViewer); +begin + if FSelected = Viewer then + FSelected := nil; + if FOpenViewer = Viewer then + CloseChildPopups; +end; + +procedure TTBView.RecreateItemViewer(const I: Integer); +var + OldViewer, NewViewer: TTBItemViewer; + J: Integer; +begin + OldViewer := Viewers[I]; + DeletingViewer(OldViewer); + NewViewer := OldViewer.Item.GetItemViewerClass(Self).Create(Self, + OldViewer.Item, OldViewer.FGroupLevel); + FViewers[I] := NewViewer; + if Assigned(FPriorityList) then begin + J := FPriorityList.IndexOf(OldViewer); + if J <> -1 then + FPriorityList[J] := NewViewer; + end; + OldViewer.Free; +end; + +function TTBView.InsertItemViewers(const NewIndex: Integer; + const AItem: TTBCustomItem; const AGroupLevel: Integer; + const AddToPriorityList, TopOfPriorityList: Boolean): Integer; +var + NewViewer: TTBItemViewer; + LinkItem: TTBCustomItem; + I: Integer; +begin + if AGroupLevel > MaxGroupLevel then begin + Result := 0; + Exit; + end; + + FViewers.Expand; + NewViewer := AItem.GetItemViewerClass(Self).Create(Self, AItem, + AGroupLevel); + FViewers.Insert(NewIndex, NewViewer); + if AddToPriorityList and FUsePriorityList then begin + if not TopOfPriorityList then + AddToList(FPriorityList, NewViewer) + else + { When new items are inserted programmatically at run-time, place + them at the top of FPriorityList } + AddToFrontOfList(FPriorityList, NewViewer); + end; + Result := 1; + + { If a new group item is being inserted, insert all its child items too } + if not FCustomizing and (tbisEmbeddedGroup in AItem.ItemStyle) then begin + LinkItem := ItemContainingItems(AItem); + for I := 0 to LinkItem.Count-1 do begin + Inc(Result, InsertItemViewers(NewIndex + Result, LinkItem.Items[I], + AGroupLevel + 1, AddToPriorityList, TopOfPriorityList)); + end; + end; +end; + +procedure TTBView.ItemNotification(Ancestor: TTBCustomItem; Relayed: Boolean; + Action: TTBItemChangedAction; Index: Integer; Item: TTBCustomItem); + + procedure ItemInserted; + var + NewLevel, Start, InsertPoint, Last: Integer; + GroupItem, NextItem: TTBCustomItem; + Found, SearchAgain: Boolean; + begin + InvalidatePositions; + NewLevel := 0; + Start := 0; + if Ancestor = FCurParentItem then + InsertPoint := FViewers.Count + else begin + { Ancestor <> FCurParentItem, so apparently an item has been inserted + inside a group item } + repeat + Found := False; + while Start < FViewers.Count do begin + GroupItem := Viewers[Start].Item; + if (tbisEmbeddedGroup in GroupItem.ItemStyle) and (GroupItem = Ancestor) then begin + NewLevel := Viewers[Start].FGroupLevel + 1; + Inc(Start); + Found := True; + Break; + end; + Inc(Start); + end; + if not Found then + { Couldn't find Ancestor; it shouldn't get here } + Exit; + InsertPoint := Start; + SearchAgain := False; + while (InsertPoint < FViewers.Count) and + (Viewers[InsertPoint].FGroupLevel >= NewLevel) do begin + if (Viewers[InsertPoint].Item = Item) and + (Viewers[InsertPoint].FGroupLevel = NewLevel) then begin + { If the item we were going to insert already exists, then there + must be multiple instances of the same group item. This can + happen when are two group items on the same toolbar each + linking to the same submenu item, with the submenu item + containing a group item of its own, and an item is inserted + inside that. } + SearchAgain := True; + Break; + end; + Inc(InsertPoint); + end; + until not SearchAgain; + end; + if InsertPoint = FViewers.Count then begin + { Don't add items after the chevron or MDI buttons item } + Dec(InsertPoint, FInternalViewersAtEnd); + if InsertPoint < 0 then + InsertPoint := 0; { just in case? } + end; + { If the new item wasn't placed at the end, adjust InsertPoint accordingly } + if Index < Item.Parent.Count-1 then begin + Last := InsertPoint; + InsertPoint := Start; + NextItem := Item.Parent.Items[Index+1]; + while (InsertPoint < Last) and + ((Viewers[InsertPoint].Item <> NextItem) or + (Viewers[InsertPoint].FGroupLevel <> NewLevel)) do + Inc(InsertPoint); + end; + InsertItemViewers(InsertPoint, Item, NewLevel, True, + not(csLoading in Item.ComponentState) and FNewViewersGetHighestPriority); + end; + + procedure ItemDeleting; + + procedure DeleteItem(DeleteIndex: Integer); + var + Viewer: TTBItemViewer; + begin + Viewer := Viewers[DeleteIndex]; + DeletingViewer(Viewer); + RemoveFromList(FPriorityList, Viewer); + FreeAndNil(Viewer); + FViewers.Delete(DeleteIndex); + end; + + var + I: Integer; + DeleteLevel: Integer; + begin + InvalidatePositions; + I := 0; + DeleteLevel := 0; + while I < FViewers.Count do begin + if DeleteLevel > 0 then begin + if Viewers[I].FGroupLevel >= DeleteLevel then begin + DeleteItem(I); + Continue; + end + else + DeleteLevel := 0; + end; + if Viewers[I].Item = Item then begin + { Delete the item, and any group item children afterward } + DeleteLevel := Viewers[I].FGroupLevel + 1; + DeleteItem(I); + Continue; + end; + Inc(I); + end; + end; + +var + I: Integer; +begin + case Action of + tbicInserted: ItemInserted; + tbicDeleting: ItemDeleting; + tbicSubitemsChanged: begin + { If Relayed=True, LinkSubitems must have changed on a child group + item. Currently there isn't any optimized way of handling this + situation; just recreate all viewers. } + if Relayed then + RecreateAllViewers; + end; + tbicSubitemsBeginUpdate: BeginUpdate; + tbicSubitemsEndUpdate: EndUpdate; + tbicInvalidate: begin + for I := 0 to FViewers.Count-1 do + if Viewers[I].Item = Item then + Invalidate(Viewers[I]); + end; + tbicInvalidateAndResize: InvalidatePositions; + tbicRecreateItemViewers: begin + InvalidatePositions; + for I := 0 to FViewers.Count-1 do + if Viewers[I].Item = Item then + RecreateItemViewer(I); + end; + tbicSubMenuImagesChanged: ImagesChanged; + else + { Prevent TryValidatePositions from being called below on Actions other than + those listed above. Currently there are no other Actions, but for forward + compatibility, we should ignore unknown Actions completely. } + Exit; + end; + TryValidatePositions; +end; + +procedure TTBView.LinkNotification(Ancestor: TTBCustomItem; Relayed: Boolean; + Action: TTBItemChangedAction; Index: Integer; Item: TTBCustomItem); +{ This notification procedure watches for tbicSubitemsChanged notifications + from FParentItem } +begin + case Action of + tbicSubitemsChanged: begin + { LinkSubitems may have changed on FParentItem, e.g. on the root item + of a toolbar, so see if FCurParentItem needs updating } + UpdateCurParentItem; + end; + tbicSubMenuImagesChanged: begin + { In case the images were inherited from the actual parent instead of + the linked parent... } + if FParentItem <> FCurParentItem then + ImagesChanged; + end; + end; +end; + +procedure TTBView.ImagesChanged; +begin + InvalidatePositions; + TryValidatePositions; + if Assigned(FOpenViewerView) then + FOpenViewerView.ImagesChanged; +end; + +procedure TTBView.GivePriority(AViewer: TTBItemViewer); +{ Move item to top of priority list. Rearranges items if necessary. } +var + I: Integer; +begin + if Assigned(FChevronParentView) then begin + I := AViewer.Index + FChevronParentView.FInternalViewersAtFront; + if I < FChevronParentView.FViewers.Count then { range check just in case } + FChevronParentView.GivePriority(FChevronParentView.Viewers[I]); + Exit; + end; + if Assigned(FPriorityList) then begin + I := FPriorityList.IndexOf(AViewer); + if I <> -1 then begin + FPriorityList.Move(I, 0); + if not FValidated or AViewer.OffEdge then + UpdatePositions; + end; + end; + { Call GivePriority on parent view, so that if an item on a submenu is + clicked, the parent item of the submenu gets priority. } + if Assigned(FParentView) and Assigned(FParentView.FOpenViewer) then + FParentView.GivePriority(FParentView.FOpenViewer); +end; + +function TTBView.HighestPriorityViewer: TTBItemViewer; +{ Returns index of first visible, non-separator item at top of priority list, + or -1 if there are no items found } +var + I: Integer; + J: TTBItemViewer; +begin + ValidatePositions; + Result := nil; + if Assigned(FPriorityList) then begin + for I := 0 to FPriorityList.Count-1 do begin + J := TTBItemViewer(FPriorityList[I]); + if J.Show and not(tbisSeparator in J.Item.ItemStyle) then begin + Result := J; + Break; + end; + end; + end + else begin + for I := 0 to FViewers.Count-1 do begin + J := Viewers[I]; + if J.Show and not(tbisSeparator in J.Item.ItemStyle) then begin + Result := J; + Break; + end; + end; + end; +end; + +procedure TTBView.StartTimer(const ATimer: TTBViewTimerID; + const Interval: Integer); +{ Starts a timer. Stops any previously set timer of the same ID first. + Note: WM_TIMER messages generated by timers set by the method are handled + in PopupMessageLoop. } +begin + StopTimer(ATimer); + if (FWindow is TTBPopupWindow) and FWindow.HandleAllocated then begin + SetTimer(FWindow.Handle, ViewTimerBaseID + Ord(ATimer), Interval, nil); + Include(FActiveTimers, ATimer); + end; +end; + +procedure TTBView.StopAllTimers; +var + I: TTBViewTimerID; +begin + for I := Low(I) to High(I) do + StopTimer(I); +end; + +procedure TTBView.StopTimer(const ATimer: TTBViewTimerID); +begin + if ATimer in FActiveTimers then begin + if (FWindow is TTBPopupWindow) and FWindow.HandleAllocated then + KillTimer(FWindow.Handle, ViewTimerBaseID + Ord(ATimer)); + Exclude(FActiveTimers, ATimer); + end; +end; + +function TTBView.OpenChildPopup(const SelectFirstItem: Boolean): Boolean; +var + Item: TTBCustomItem; +begin + StopTimer(tiClose); + StopTimer(tiOpen); + if FSelected <> FOpenViewer then begin + CloseChildPopups; + if Assigned(FSelected) then begin + Item := FSelected.Item; + if Item.Enabled and (tbisSubmenu in Item.ItemStyle) then + Item.CreatePopup(Self, FSelected, not FIsToolbar, SelectFirstItem, + False, Point(0, 0), tbpaLeft); + end; + end; + Result := Assigned(FOpenViewer); +end; + +procedure TTBView.CloseChildPopups; +begin + if Assigned(FOpenViewerView) then + FOpenViewerView.CloseChildPopups; + StopTimer(tiClose); + FOpenViewerWindow.Free; + FOpenViewerWindow := nil; + FOpenViewerView := nil; + FOpenViewer := nil; +end; + +procedure TTBView.CancelChildPopups; +begin + if FIsToolbar then + Exclude(FState, vsDropDownMenus); + CloseChildPopups; +end; + +function TTBView.ViewerFromPoint(const P: TPoint): TTBItemViewer; +var + I: Integer; +begin + ValidatePositions; + for I := 0 to FViewers.Count-1 do begin + if Viewers[I].Show and + PtInRect(Viewers[I].BoundsRect, P) then begin + Result := Viewers[I]; + Exit; + end; + end; + Result := nil; +end; + +procedure TTBView.NotifyFocusEvent; +{ Notifies Active Accessibility of a change in "focus". Has no effect if the + view or the root view lacks the vsModal state, or if the modal loop is + ending (EndModal* was called). } +var + I, ChildID, J: Integer; +begin + { Note: We don't notify about windows not yet shown (e.g. a popup menu that + is still initializing) because that would probably confuse screen readers. + Also allocating a window handle at this point *might* not be a good idea. } + if (vsModal in FState) and (vsModal in GetRootView.FState) and + not IsModalEnding and + FWindow.HandleAllocated and IsWindowVisible(FWindow.Handle) then begin + if Assigned(FSelected) and FSelected.IsAccessible then + I := IndexOf(FSelected) + else + I := -1; + if (I < 0) and Assigned(FParentView) then begin + { If we have no selected item, report the the selected item on the parent + view as having the "focus". + Note: With standard menus, when you go from having a selection to no + selection on a submenu, it sends two focus events - first with the + client window as having the focus, then with the parent item. I + figure that's probably a bug, so I don't try to emulate that behavior + here. } + FParentView.NotifyFocusEvent; + end + else begin + if I >= 0 then begin + { Convert viewer index into a one-based child index. + (TTBViewAccObject.get_accChild does the inverse.) } + ChildID := 1; + for J := 0 to I-1 do + if Viewers[J].IsAccessible then + Inc(ChildID); + end + else begin + { If there is no (accessible) selection and no parent view, report + the client window itself as being "focused". This is what happens + when a standard context menu has no selection. } + ChildID := CHILDID_SELF; + end; + CallNotifyWinEvent(EVENT_OBJECT_FOCUS, FWindow.Handle, OBJID_CLIENT, ChildID); + end; + end; +end; + +procedure TTBView.SetSelected(Value: TTBItemViewer); +begin + Select(Value, False); +end; + +procedure TTBView.Select(Value: TTBItemViewer; ViaMouse: Boolean); +{ Sets the current selection. + When the selection is changing it will also, if necessary, open/close child + popups. How exactly this works depends on the setting of ViaMouse. If + ViaMouse is True it will delay the opening/closing of popups using timers. } +var + OldSelected: TTBItemViewer; + NewMouseOverSelected: Boolean; + P: TPoint; +begin + OldSelected := FSelected; + if Value <> OldSelected then begin + { If there's a new selection and the parent item on the parent view + isn't currently selected, select it. Also stop any timer running on + the parent view. } + if Assigned(Value) and Assigned(FParentView) and + Assigned(FParentView.FOpenViewer) and + (FParentView.FSelected <> FParentView.FOpenViewer) then begin + FParentView.Selected := FParentView.FOpenViewer; + FParentView.StopTimer(tiClose); + FParentView.StopTimer(tiOpen); + end; + + { Handle automatic closing of child popups } + if vsModal in FState then begin + { If the view is a toolbar, or if the new selection didn't come from + the mouse, close child popups immediately } + if FIsToolbar or not ViaMouse then begin + { Always stop any close timer because CloseChildPopups may not be + called below } + StopTimer(tiClose); + if Value <> FOpenViewer then + { ^ But don't close if selection is returning to the open item. + Needed for the "FParentView.Selected := FParentView.FOpenViewer" + line above to work. } + CloseChildPopups; + end + else begin + { Otherwise, delay-close any child popup } + if Assigned(FOpenViewerView) and not(tiClose in FActiveTimers) then + StartTimer(tiClose, GetMenuShowDelay); + end; + end; + + CancelCapture; + if Assigned(OldSelected) then + OldSelected.Leaving; + FSelected := Value; + FSelectedViaMouse := ViaMouse; + end; + + NewMouseOverSelected := False; + if Assigned(Value) and Assigned(FWindow) then begin + P := GetMessagePosAsPoint; + if FindDragTarget(P, True) = FWindow then begin + P := FWindow.ScreenToClient(P); + NewMouseOverSelected := (ViewerFromPoint(P) = Value); + if NewMouseOverSelected and FCapture and + not Value.IsPtInButtonPart(P.X - Value.BoundsRect.Left, + P.Y - Value.BoundsRect.Top) then + NewMouseOverSelected := False; + end; + end; + + if Value <> OldSelected then begin + FMouseOverSelected := NewMouseOverSelected; + if Assigned(OldSelected) and (tbisRedrawOnSelChange in OldSelected.Item.ItemStyle) then + Invalidate(OldSelected); + if Assigned(Value) then begin + if tbisRedrawOnSelChange in Value.Item.ItemStyle then + Invalidate(Value); + Value.Entering; + end; + NotifyFocusEvent; + + { Handle automatic opening of a child popup } + if vsModal in FState then begin + { If the view is a toolbar, immediately open any child popup } + if FIsToolbar then begin + if Assigned(Value) then begin + if ViaMouse and Assigned(FParentView) then begin + { On chevron popups, always drop down menus when mouse passes + over them, like Office 2000 } + Include(FState, vsDropDownMenus); + end; + if (vsDropDownMenus in FState) and + (ViaMouse or not(tbisNoAutoOpen in Value.Item.ItemStyle)) then + OpenChildPopup(not ViaMouse); + end; + end + else begin + { Otherwise, delay-open any child popup if the selection came from + the mouse } + StopTimer(tiOpen); + if ViaMouse and Assigned(Value) and (tbisSubmenu in Value.Item.ItemStyle) then + StartTimer(tiOpen, GetMenuShowDelay); + end; + end; + end + else if FMouseOverSelected <> NewMouseOverSelected then begin + FMouseOverSelected := NewMouseOverSelected; + if Assigned(Value) and FCapture and (tbisRedrawOnMouseOverChange in Value.Item.ItemStyle) then + Invalidate(Value); + end; +end; + +procedure TTBView.UpdateSelection(const P: TPoint; const AllowNewSelection: Boolean); +{ Called in response to a mouse movement, this method updates the current + selection, updates the vsMouseInWindow view state, and enables/disables + scroll timers. } + + function IsPtInScrollArrow(ADownArrow: Boolean): Boolean; + var + P2: TPoint; + R: TRect; + begin + Result := False; + if (vsModal in FState) and (vsMouseInWindow in FState) and not FCapture and + (P.X <> Low(Integer)) then begin + P2 := FWindow.ScreenToClient(P); + R := FWindow.ClientRect; + if PtInRect(R, P2) then begin + if ADownArrow then + Result := FShowDownArrow and (P2.Y >= R.Bottom - tbMenuScrollArrowHeight) + else + Result := FShowUpArrow and (P2.Y < tbMenuScrollArrowHeight); + end; + end; + end; + +var + NewSelected, ViewerAtPoint: TTBItemViewer; + P2: TPoint; + MouseWasInWindow: Boolean; +begin + ValidatePositions; + + if FCapture then begin + { If we have the capture, don't allow the selection to change. And always + set vsMouseInWindow so that if the mouse is released outside the window, + the "remove the selection" code below will be reached the next time + UpdateSelection is called. } + NewSelected := FSelected; + Include(FState, vsMouseInWindow); + end + else begin + { If modal, default to keeping the existing selection } + if vsModal in FState then + NewSelected := FSelected + else + NewSelected := nil; + + { Is the mouse inside the window? } + MouseWasInWindow := vsMouseInWindow in FState; + if (P.X <> Low(Integer)) and Assigned(FWindow) and (FindDragTarget(P, True) = FWindow) then begin + { If we're a popup window and the mouse is inside, default to no selection } + if FIsPopup then + NewSelected := nil; + Include(FState, vsMouseInWindow); + if AllowNewSelection or Assigned(FSelected) then begin + P2 := FWindow.ScreenToClient(P); + ViewerAtPoint := ViewerFromPoint(P2); + if Assigned(ViewerAtPoint) then + NewSelected := ViewerAtPoint; + end; + end + else begin + Exclude(FState, vsMouseInWindow); + { If we're a popup window and the mouse just moved outside the window + while no submenu was open or a non-submenu-displaying item was + selected, remove the selection } + if FIsPopup and Assigned(NewSelected) and MouseWasInWindow and + (not Assigned(FOpenViewerView) or not(tbisSubmenu in NewSelected.Item.ItemStyle)) then + NewSelected := nil; + end; + end; + + { Now we set the new Selected value } + Select(NewSelected, True); + + { Update scroll arrow timers } + if IsPtInScrollArrow(False) then begin + StopTimer(tiScrollDown); + if not(tiScrollUp in FActiveTimers) then + StartTimer(tiScrollUp, 100); + end + else if IsPtInScrollArrow(True) then begin + StopTimer(tiScrollUp); + if not(tiScrollDown in FActiveTimers) then + StartTimer(tiScrollDown, 100); + end + else begin + StopTimer(tiScrollUp); + StopTimer(tiScrollDown); + end; +end; + +procedure TTBView.RecreateAllViewers; +var + Item: TTBCustomItem; + I: Integer; +begin + { Since the FViewers list is being rebuilt, FOpenViewer and FSelected + will no longer be valid, so ensure they're set to nil. } + CloseChildPopups; + Selected := nil; + + InvalidatePositions; + + FreeAndNil(FPriorityList); + FreeViewers; + FInternalViewersAtFront := 0; + FInternalViewersAtEnd := 0; + + { MDI system menu item } + Item := GetMDISystemMenuItem; + if Assigned(Item) then + Inc(FInternalViewersAtFront, InsertItemViewers(FViewers.Count, Item, 0, + False, False)); + + { Items } + if Assigned(FCurParentItem) then begin + for I := 0 to FCurParentItem.Count-1 do + InsertItemViewers(FViewers.Count, FCurParentItem.Items[I], 0, + True, False); + end; + + { MDI buttons item } + Item := GetMDIButtonsItem; + if Assigned(Item) then begin + for I := 0 to Item.Count-1 do + Inc(FInternalViewersAtEnd, InsertItemViewers(FViewers.Count, + Item.Items[I], 0, False, False)); + end; + + { Chevron item } + Item := GetChevronItem; + if Assigned(Item) then + Inc(FInternalViewersAtEnd, InsertItemViewers(FViewers.Count, Item, 0, + False, False)); +end; + +function TTBView.CalculatePositions(const CanMoveControls: Boolean; + const AOrientation: TTBViewOrientation; + AWrapOffset, AChevronOffset, AChevronSize: Integer; + var ABaseSize, TotalSize: TPoint; + var AWrappedLines: Integer): Boolean; +{ Returns True if the positions have changed } +type + TTempPosition = record + BoundsRect: TRect; + Show, OffEdge, LineSep, Clipped, SameWidth: Boolean; + { Include an Integer field to enforce Integer alignment of the record + (which we don't get by default due to TRect being wrongly declared as + 'packed'). Needed to avoid alignment fault on Delphi.NET 2007 IA-64. } + DummyAlignment: Integer; + end; + TTempPositionArrayItem = record + Pos: TTempPosition; + end; +var + DC: HDC; + LeftX, TopY, CurX, CurY: Integer; + NewPositions: array of TTempPositionArrayItem; + GroupSplit, DidWrap: Boolean; + LineStart, HighestHeightOnLine, HighestWidthOnLine: Integer; + + function GetSizeOfGroup(const StartingIndex: Integer): Integer; + var + I: Integer; + begin + Result := 0; + for I := StartingIndex to FViewers.Count-1 do begin + with NewPositions[I] do begin + if not Pos.Show then + Continue; + if tbisSeparator in Viewers[I].Item.ItemStyle then + Break; + if AOrientation <> tbvoVertical then + Inc(Result, Pos.BoundsRect.Right) + else + Inc(Result, Pos.BoundsRect.Bottom); + end; + end; + end; + + procedure Mirror; + { Reverses the horizontal ordering (i.e. first item becomes last) } + var + I, NewRight: Integer; + begin + for I := 0 to FViewers.Count-1 do + with NewPositions[I] do + if Pos.Show then begin + NewRight := TotalSize.X - Pos.BoundsRect.Left; + Pos.BoundsRect.Left := TotalSize.X - Pos.BoundsRect.Right; + Pos.BoundsRect.Right := NewRight; + end; + end; + + procedure HandleMaxHeight; + { Decreases, if necessary, the height of the view to FMaxHeight, and adjusts + the visibility of the scroll arrows } + var + MaxOffset, I, MaxTop, MaxBottom: Integer; + begin + FShowUpArrow := False; + FShowDownArrow := False; + if (FMaxHeight > 0) and (TotalSize.Y > FMaxHeight) then begin + MaxOffset := TotalSize.Y - FMaxHeight; + if FScrollOffset > MaxOffset then + FScrollOffset := MaxOffset; + if FScrollOffset < 0 then + FScrollOffset := 0; + FShowUpArrow := (FScrollOffset > 0); + FShowDownArrow := (FScrollOffset < MaxOffset); + MaxTop := 0; + if FShowUpArrow then + MaxTop := tbMenuScrollArrowHeight; + MaxBottom := FMaxHeight; + if FShowDownArrow then + Dec(MaxBottom, tbMenuScrollArrowHeight); + for I := 0 to FViewers.Count-1 do begin + with NewPositions[I] do begin + if not IsRectEmpty(Pos.BoundsRect) then begin + OffsetRect(Pos.BoundsRect, 0, -FScrollOffset); + if Pos.Show and + ((Pos.BoundsRect.Top < MaxTop) or + (Pos.BoundsRect.Bottom > MaxBottom)) then begin + Pos.Show := False; + Pos.Clipped := True; + end; + end; + end; + end; + TotalSize.Y := FMaxHeight; + end + else + FScrollOffset := 0; + end; + + procedure FinalizeLine(const LineEnd: Integer; const LastLine: Boolean); + var + I, RightAlignStart: Integer; + Item: TTBCustomItem; + IsButton: Boolean; + Z: Integer; + begin + if LineStart <> -1 then begin + if DidWrap and (FChevronParentView = nil) then begin + { When wrapping on a docked toolbar, extend TotalSize.X/Y to + AWrapOffset so that the toolbar always fills the whole row } + if (AOrientation = tbvoHorizontal) and (TotalSize.X < AWrapOffset) then + TotalSize.X := AWrapOffset + else if (AOrientation = tbvoVertical) and (TotalSize.Y < AWrapOffset) then + TotalSize.Y := AWrapOffset; + end; + RightAlignStart := -1; + for I := LineStart to LineEnd do begin + with NewPositions[I] do begin + if not Pos.Show then + Continue; + Item := Viewers[I].Item; + if (RightAlignStart < 0) and (tbisRightAlign in Item.ItemStyle) then + RightAlignStart := I; + IsButton := FIsToolbar or (tboToolbarSize in Item.FEffectiveOptions); + if FIsToolbar then begin + if LastLine and not DidWrap and (AOrientation <> tbvoFloating) then begin + { In case the toolbar is docked next to a taller/wider toolbar... } + HighestWidthOnLine := TotalSize.X; + HighestHeightOnLine := TotalSize.Y; + end; + { Make separators on toolbars as tall/wide as the tallest/widest item } + if tbisSeparator in Item.ItemStyle then begin + if AOrientation <> tbvoVertical then + Pos.BoundsRect.Bottom := Pos.BoundsRect.Top + HighestHeightOnLine + else + Pos.BoundsRect.Right := Pos.BoundsRect.Left + HighestWidthOnLine; + end + else begin + { Center the item } + if AOrientation <> tbvoVertical then begin + Z := (HighestHeightOnLine - (Pos.BoundsRect.Bottom - Pos.BoundsRect.Top)) div 2; + Inc(Pos.BoundsRect.Top, Z); + Inc(Pos.BoundsRect.Bottom, Z); + end + else begin + Z := (HighestWidthOnLine - (Pos.BoundsRect.Right - Pos.BoundsRect.Left)) div 2; + Inc(Pos.BoundsRect.Left, Z); + Inc(Pos.BoundsRect.Right, Z); + end; + end; + end + else begin + { Make items in a menu as wide as the widest item } + if not IsButton then begin + with Pos.BoundsRect do Right := Left + HighestWidthOnLine; + end; + end; + end; + end; + if RightAlignStart >= 0 then begin + Z := 0; + for I := LineEnd downto RightAlignStart do begin + with NewPositions[I] do begin + if not Pos.Show then + Continue; + if AOrientation <> tbvoVertical then + Z := Min(AWrapOffset, TotalSize.X) - Pos.BoundsRect.Right + else + Z := Min(AWrapOffset, TotalSize.Y) - Pos.BoundsRect.Bottom; + end; + Break; + end; + if Z > 0 then begin + for I := RightAlignStart to LineEnd do begin + with NewPositions[I] do begin + if not Pos.Show then + Continue; + if AOrientation <> tbvoVertical then begin + Inc(Pos.BoundsRect.Left, Z); + Inc(Pos.BoundsRect.Right, Z); + end + else begin + Inc(Pos.BoundsRect.Top, Z); + Inc(Pos.BoundsRect.Bottom, Z); + end; + end; + end; + end; + end; + end; + LineStart := -1; + HighestHeightOnLine := 0; + HighestWidthOnLine := 0; + end; + + procedure PositionItem(const CurIndex: Integer; var Pos: TTempPosition); + var + O, X, Y: Integer; + IsLineSep, Vert: Boolean; + begin + if LineStart = -1 then begin + LineStart := CurIndex; + HighestHeightOnLine := 0; + HighestWidthOnLine := 0; + end; + IsLineSep := False; + Vert := (AOrientation = tbvoVertical); + if not Vert then + O := CurX + else + O := CurY; + if (AWrapOffset > 0) and (O > 0) then begin + if not Vert then + Inc(O, Pos.BoundsRect.Right) + else + Inc(O, Pos.BoundsRect.Bottom); + if (tbisSeparator in Viewers[CurIndex].Item.ItemStyle) and + ((GroupSplit and not(tbisNoLineBreak in Viewers[CurIndex].Item.ItemStyle)) + or (O + GetSizeOfGroup(CurIndex+1) > AWrapOffset)) then begin + DidWrap := True; + Inc(AWrappedLines); + if not Vert then begin + CurX := 0; + Inc(CurY, HighestHeightOnLine); + end + else begin + CurY := 0; + Inc(CurX, HighestWidthOnLine); + end; + FinalizeLine(CurIndex-1, False); + LineStart := CurIndex+1; + if not Vert then begin + Pos.BoundsRect.Right := 0; + Pos.BoundsRect.Bottom := tbLineSpacing; + end + else begin + Pos.BoundsRect.Right := tbLineSpacing; + Pos.BoundsRect.Bottom := 0; + end; + Pos.LineSep := True; + IsLineSep := True; + end + else if O > AWrapOffset then begin + { proceed to next row } + DidWrap := True; + Inc(AWrappedLines); + if not Vert then begin + CurX := LeftX; + Inc(CurY, HighestHeightOnLine); + end + else begin + CurY := TopY; + Inc(CurX, HighestWidthOnLine); + end; + GroupSplit := True; + FinalizeLine(CurIndex-1, False); + LineStart := CurIndex; + end; + end; + if Pos.BoundsRect.Bottom > HighestHeightOnLine then + HighestHeightOnLine := Pos.BoundsRect.Bottom; + if Pos.BoundsRect.Right > HighestWidthOnLine then + HighestWidthOnLine := Pos.BoundsRect.Right; + X := CurX; + Y := CurY; + if X < 0 then X := 0; + if Y < 0 then Y := 0; + OffsetRect(Pos.BoundsRect, X, Y); + if IsLineSep then begin + if not Vert then begin + CurX := LeftX; + Inc(CurY, tbLineSpacing); + end + else begin + CurY := TopY; + Inc(CurX, tbLineSpacing); + end; + GroupSplit := False; + end; + end; + +var + SaveOrientation: TTBViewOrientation; + ChevronItem: TTBCustomItem; + CalcCanvas: TCanvas; + LastWasSep, LastWasButton, IsButton, IsControl: Boolean; + Item: TTBCustomItem; + Ctl: TControl; + ChangedBold: Boolean; + I, HighestSameWidthViewerWidth, Total, J, TotalVisibleItems: Integer; + IsFirst: Boolean; + Viewer: TTBItemViewer; + UseChevron, NonControlsOffEdge, TempViewerCreated: Boolean; + Margins: TRect; +label FoundItemToHide; +begin + SaveOrientation := FOrientation; + AWrappedLines := 1; + ChevronItem := GetChevronItem; + DC := 0; + CalcCanvas := nil; + try + FOrientation := AOrientation; + + CalcCanvas := TCanvas.Create; + DC := GetDC(0); + CalcCanvas.Handle := DC; + CalcCanvas.Font.Assign(GetFont); + + SetLength(NewPositions, FViewers.Count); + + { Figure out which items should be shown } + LastWasSep := True; { set to True initially so it won't show leading seps } + for I := 0 to FViewers.Count-1 do begin + Item := Viewers[I].Item; + IsControl := Item is TTBControlItem; + with NewPositions[I] do begin + { Pos.Show is initially False since SetLength initializes to zero } + if Item = ChevronItem then + Continue; + if Assigned(FChevronParentView) then begin + if IsControl then + Continue; + FChevronParentView.ValidatePositions; + J := I + FChevronParentView.FInternalViewersAtFront; + if J < FChevronParentView.FViewers.Count then + { range check just in case } + Viewer := FChevronParentView.Viewers[J] + else + Viewer := nil; + if (Viewer = nil) or (not Viewer.OffEdge and not(tbisSeparator in Item.ItemStyle)) then + Continue; + end; + if not IsControl then begin + if not(tbisEmbeddedGroup in Item.ItemStyle) or FCustomizing then begin + Pos.Show := Item.Visible; + { Don't display two consecutive separators } + if Pos.Show then begin + if (tbisSeparator in Item.ItemStyle) and LastWasSep then + Pos.Show := False; + LastWasSep := tbisSeparator in Item.ItemStyle; + end; + end; + end + else begin + { Controls can only be rendered on a single Parent, so only + include the control if its parent is currently equal to + FWindow } + Ctl := TTBControlItem(Item).FControl; + if Assigned(Ctl) and Assigned(FWindow) and (Ctl.Parent = FWindow) and + (Ctl.Visible or (csDesigning in Ctl.ComponentState)) then begin + Pos.Show := True; + LastWasSep := False; + end; + end; + end; + end; + + { Hide any trailing separators, so that they aren't included in the + base size } + for I := FViewers.Count-1 downto 0 do begin + with NewPositions[I] do + if Pos.Show then begin + if not(tbisSeparator in Viewers[I].Item.ItemStyle) then + Break; + Pos.Show := False; + end; + end; + + { Calculate sizes of all the items } + HighestSameWidthViewerWidth := 0; + for I := 0 to FViewers.Count-1 do begin + Item := Viewers[I].Item; + IsControl := Item is TTBControlItem; + with NewPositions[I] do begin + { Pos.BoundsRect is currently empty since SetLength initializes to zero } + if not Pos.Show then + Continue; + if not IsControl then begin + ChangedBold := False; + if tboDefault in Item.EffectiveOptions then + with CalcCanvas.Font do + if not(fsBold in Style) then begin + ChangedBold := True; + Style := Style + [fsBold]; + end; + Viewer := Viewers[I]; + TempViewerCreated := False; + if Item.NeedToRecreateViewer(Viewer) then begin + if CanMoveControls then begin + RecreateItemViewer(I); + Viewer := Viewers[I]; + end + else begin + Viewer := Item.GetItemViewerClass(Self).Create(Self, Item, 0); + TempViewerCreated := True; + end; + end; + try + Viewer.CalcSize(CalcCanvas, Pos.BoundsRect.Right, Pos.BoundsRect.Bottom); + if Viewer.UsesSameWidth then begin + Pos.SameWidth := True; + if (Pos.BoundsRect.Right > HighestSameWidthViewerWidth) then + HighestSameWidthViewerWidth := Pos.BoundsRect.Right; + end; + finally + if TempViewerCreated then + Viewer.Free; + end; + if ChangedBold then + with CalcCanvas.Font do + Style := Style - [fsBold]; + end + else begin + Ctl := TTBControlItem(Item).FControl; + Pos.BoundsRect.Right := Ctl.Width; + Pos.BoundsRect.Bottom := Ctl.Height; + end; + end; + end; + + { Increase widths of SameWidth items if necessary. Also calculate + ABaseSize.X (or Y). } + ABaseSize.X := 0; + ABaseSize.Y := 0; + for I := 0 to FViewers.Count-1 do begin + with NewPositions[I] do begin + if Pos.SameWidth and (Pos.BoundsRect.Right < HighestSameWidthViewerWidth) then + Pos.BoundsRect.Right := HighestSameWidthViewerWidth; + if AOrientation <> tbvoVertical then + Inc(ABaseSize.X, Pos.BoundsRect.Right) + else + Inc(ABaseSize.Y, Pos.BoundsRect.Bottom); + end; + end; + + { Hide partially visible items, mark them as 'OffEdge' } + if AOrientation <> tbvoVertical then + Total := ABaseSize.X + else + Total := ABaseSize.Y; + NonControlsOffEdge := False; + UseChevron := Assigned(ChevronItem) and (AChevronOffset > 0) and + (Total > AChevronOffset); + if UseChevron then begin + Dec(AChevronOffset, AChevronSize); + while Total > AChevronOffset do begin + { Count number of items. Stop loop if <= 1 } + TotalVisibleItems := 0; + for I := FViewers.Count-1 downto 0 do begin + if NewPositions[I].Pos.Show and not(tbisSeparator in Viewers[I].Item.ItemStyle) then + Inc(TotalVisibleItems); + end; + if TotalVisibleItems <= 1 then + Break; + { Hide any trailing separators } + for I := FViewers.Count-1 downto 0 do begin + if NewPositions[I].Pos.Show then begin + if not(tbisSeparator in Viewers[I].Item.ItemStyle) then + Break; + NewPositions[I].Pos.Show := False; + if AOrientation <> tbvoVertical then + Dec(Total, NewPositions[I].Pos.BoundsRect.Right) + else + Dec(Total, NewPositions[I].Pos.BoundsRect.Bottom); + goto FoundItemToHide; + end; + end; + { Find an item to hide } + if Assigned(FPriorityList) then + I := FPriorityList.Count-1 + else + I := FViewers.Count-1; + while I >= 0 do begin + if Assigned(FPriorityList) then begin + Viewer := TTBItemViewer(FPriorityList[I]); + J := Viewer.Index; + end + else begin + Viewer := Viewers[I]; + J := I; + end; + if NewPositions[J].Pos.Show and not(tbisSeparator in Viewer.Item.ItemStyle) then begin + NewPositions[J].Pos.Show := False; + NewPositions[J].Pos.OffEdge := True; + if AOrientation <> tbvoVertical then + Dec(Total, NewPositions[J].Pos.BoundsRect.Right) + else + Dec(Total, NewPositions[J].Pos.BoundsRect.Bottom); + if not NonControlsOffEdge and not(Viewer.Item is TTBControlItem) then + NonControlsOffEdge := True; + goto FoundItemToHide; + end; + Dec(I); + end; + Break; { prevent endless loop } + FoundItemToHide: + { Don't show two consecutive separators } + LastWasSep := True; { set to True initially so it won't show leading seps } + for J := 0 to FViewers.Count-1 do begin + Item := Viewers[J].Item; + with NewPositions[J] do begin + if Pos.Show then begin + if (tbisSeparator in Item.ItemStyle) and LastWasSep then begin + Pos.Show := False; + if AOrientation <> tbvoVertical then + Dec(Total, Pos.BoundsRect.Right) + else + Dec(Total, Pos.BoundsRect.Bottom); + end; + LastWasSep := tbisSeparator in Item.ItemStyle; + end; + end; + end; + end; + end; + + { Hide any trailing separators after items were hidden } + for I := FViewers.Count-1 downto 0 do begin + with NewPositions[I] do + if Pos.Show then begin + if not(tbisSeparator in Viewers[I].Item.ItemStyle) then + Break; + Pos.Show := False; + end; + end; + + { Set the ABaseSize.Y (or X) *after* items were hidden } + for I := 0 to FViewers.Count-1 do begin + with NewPositions[I] do + if Pos.Show then begin + if AOrientation <> tbvoVertical then begin + if Pos.BoundsRect.Bottom > ABaseSize.Y then + ABaseSize.Y := Pos.BoundsRect.Bottom; + end + else begin + if Pos.BoundsRect.Right > ABaseSize.X then + ABaseSize.X := Pos.BoundsRect.Right; + end; + end; + end; + + { On menus, set all non-separator items to be as tall as the tallest item } + {if not FIsToolbar then begin + J := 0; + for I := 0 to FViewers.Count-1 do begin + Item := Viewers[I].Item; + with NewPositions[I] do + if Pos.Show and not(tbisSeparator in Item.ItemStyle) and + not(tboToolbarSize in Item.FEffectiveOptions) and + (Pos.BoundsRect.Bottom - Pos.BoundsRect.Top > J) then + J := Pos.BoundsRect.Bottom - Pos.BoundsRect.Top; + end; + for I := 0 to FViewers.Count-1 do begin + Item := Viewers[I].Item; + with NewPositions[I] do + if Pos.Show and not(tbisSeparator in Item.ItemStyle) and + not(tboToolbarSize in Item.FEffectiveOptions) then + Pos.BoundsRect.Bottom := Pos.BoundsRect.Top + J; + end; + end;} + + { Calculate the position of the items } + GetMargins(AOrientation, Margins); + LeftX := Margins.Left; + TopY := Margins.Top; + if AWrapOffset > 0 then begin + Dec(AWrapOffset, Margins.Right); + if AWrapOffset < 1 then AWrapOffset := 1; + end; + CurX := LeftX; + CurY := TopY; + GroupSplit := False; + DidWrap := False; + LastWasButton := FIsToolbar; + LineStart := -1; + for I := 0 to FViewers.Count-1 do begin + Item := Viewers[I].Item; + with NewPositions[I] do begin + if not Pos.Show then + Continue; + IsButton := FIsToolbar or (tboToolbarSize in Item.FEffectiveOptions); + if LastWasButton and not IsButton then begin + { On a menu, if last item was a button and the current item isn't, + proceed to next row } + CurX := LeftX; + CurY := TotalSize.Y; + end; + LastWasButton := IsButton; + PositionItem(I, NewPositions[I].Pos); + if IsButton and (AOrientation <> tbvoVertical) then + Inc(CurX, Pos.BoundsRect.Right - Pos.BoundsRect.Left) + else + Inc(CurY, Pos.BoundsRect.Bottom - Pos.BoundsRect.Top); + if Pos.BoundsRect.Right > TotalSize.X then + TotalSize.X := Pos.BoundsRect.Right; + if Pos.BoundsRect.Bottom > TotalSize.Y then + TotalSize.Y := Pos.BoundsRect.Bottom; + end; + end; + if FViewers.Count <> 0 then + FinalizeLine(FViewers.Count-1, True); + Inc(TotalSize.X, Margins.Right); + Inc(TotalSize.Y, Margins.Bottom); + if AOrientation = tbvoVertical then + Mirror; + HandleMaxHeight; + if CanMoveControls then begin + for I := 0 to FViewers.Count-1 do begin + Item := Viewers[I].Item; + if Item is TTBControlItem then begin + if NewPositions[I].Pos.Show then begin + Ctl := TTBControlItem(Item).FControl; + if not EqualRect(NewPositions[I].Pos.BoundsRect, Ctl.BoundsRect) then + Ctl.BoundsRect := NewPositions[I].Pos.BoundsRect; + end + else if NewPositions[I].Pos.OffEdge or NewPositions[I].Pos.Clipped then begin + { Simulate hiding of OddEdge controls by literally moving them + off the edge. Do the same for Clipped controls. } + Ctl := TTBControlItem(Item).FControl; + Ctl.SetBounds(FWindow.ClientWidth, FWindow.ClientHeight, + Ctl.Width, Ctl.Height); + end; + end; + end; + end; + { Set size of line separators } + if FIsToolbar then + for I := 0 to FViewers.Count-1 do begin + Item := Viewers[I].Item; + with NewPositions[I] do + if Pos.Show and (tbisSeparator in Item.ItemStyle) and + Pos.LineSep then begin + if AOrientation <> tbvoVertical then + Pos.BoundsRect.Right := TotalSize.X + else + Pos.BoundsRect.Bottom := TotalSize.Y; + end; + end; + + { Position the chevron item } + if UseChevron then begin + if CanMoveControls then + ChevronItem.Enabled := NonControlsOffEdge; + NewPositions[FViewers.Count-1].Pos.Show := True; + I := AChevronOffset; + if AOrientation <> tbvoVertical then begin + if I < TotalSize.X then + I := TotalSize.X; + NewPositions[FViewers.Count-1].Pos.BoundsRect := Bounds(I, 0, + AChevronSize, TotalSize.Y); + end + else begin + if I < TotalSize.Y then + I := TotalSize.Y; + NewPositions[FViewers.Count-1].Pos.BoundsRect := Bounds(0, I, + TotalSize.X, AChevronSize); + end; + end; + + { Commit changes } + Result := False; + if CanMoveControls then begin + for I := 0 to FViewers.Count-1 do begin + Viewer := Viewers[I]; + with NewPositions[I] do begin + if not Result and + (not EqualRect(Viewer.BoundsRect, Pos.BoundsRect) or + (Viewer.Show <> Pos.Show) or + ((tbisLineSep in Viewer.State) <> Pos.LineSep)) then + Result := True; + Viewer.FBoundsRect := Pos.BoundsRect; + Viewer.FShow := Pos.Show; + Viewer.FOffEdge := Pos.OffEdge; + Viewer.FClipped := Pos.Clipped; + if Pos.LineSep then + Include(Viewer.State, tbisLineSep) + else + Exclude(Viewer.State, tbisLineSep); + end; + end; + end; + finally + FOrientation := SaveOrientation; + if Assigned(CalcCanvas) then + CalcCanvas.Handle := 0; + if DC <> 0 then ReleaseDC(0, DC); + CalcCanvas.Free; + end; + if (ABaseSize.X = 0) or (ABaseSize.Y = 0) then begin + { If there are no visible items... } + {}{scale this?} + ABaseSize.X := 23; + ABaseSize.Y := 22; + if TotalSize.X < 23 then TotalSize.X := 23; + if TotalSize.Y < 22 then TotalSize.Y := 22; + end; +end; + +procedure TTBView.DoUpdatePositions(var ASize: TPoint); +{ This is called by UpdatePositions } +var + WrappedLines: Integer; +begin + { Don't call InvalidatePositions before CalculatePositions so that + endless recursion doesn't happen if an item's CalcSize uses a method that + calls ValidatePositions } + CalculatePositions(True, FOrientation, FWrapOffset, FChevronOffset, + FChevronSize, FBaseSize, ASize, WrappedLines); + FValidated := True; + { Need to call ValidateRect before AutoSize, otherwise Windows will + erase the client area during a resize } + if FWindow.HandleAllocated then + ValidateRect(FWindow.Handle, nil); + AutoSize(ASize.X, ASize.Y); + if FWindow.HandleAllocated then + DoubleBufferedRepaint(FWindow.Handle); +end; + +function TTBView.UpdatePositions: TPoint; +{ Called whenever the size or orientation of a view changes. When items are + added or removed from the view, InvalidatePositions must be called instead, + otherwise the view may not be redrawn properly. } +begin + Result.X := 0; + Result.Y := 0; + DoUpdatePositions(Result); +end; + +procedure TTBView.AutoSize(AWidth, AHeight: Integer); +begin +end; + +function TTBView.GetChevronItem: TTBCustomItem; +begin + Result := nil; +end; + +procedure TTBView.GetMargins(AOrientation: TTBViewOrientation; + var Margins: TRect); +begin + if AOrientation = tbvoFloating then begin + Margins.Left := 4; + Margins.Top := 2; + Margins.Right := 4; + Margins.Bottom := 1; + end + else begin + Margins.Left := 0; + Margins.Top := 0; + Margins.Right := 0; + Margins.Bottom := 0; + end; +end; + +function TTBView.GetMDIButtonsItem: TTBCustomItem; +begin + Result := nil; +end; + +function TTBView.GetMDISystemMenuItem: TTBCustomItem; +begin + Result := nil; +end; + +function TTBView.GetFont: TFont; +begin + if Assigned(ToolbarFont) then + Result := ToolbarFont + else begin + { ToolbarFont is destroyed during unit finalization, but in rare cases + this method may end up being called from ValidatePositions *after* + unit finalization if Application.Run is never called; see the + "EConvertError" newsgroup thread. We can't return nil because that would + cause an exception in the calling function, so just return the window + font. It's not the *right* font, but it shouldn't matter since the app + is exiting anyway. } + Result := {$IFNDEF CLR}TControlAccess{$ENDIF}(FWindow).Font; + end; +end; + +procedure TTBView.DrawItem(Viewer: TTBItemViewer; DrawTo: TCanvas; + Offscreen: Boolean); +const + COLOR_MENUHILIGHT = 29; + clMenuHighlight = TColor(COLOR_MENUHILIGHT or $80000000); +var + Bmp: TBitmap; + DrawToDC, BmpDC: HDC; + DrawCanvas: TCanvas; + R1, R2, R3: TRect; + IsOpen, IsSelected, IsPushed: Boolean; + ToolbarStyle: Boolean; + UseDisabledShadow: Boolean; + SaveIndex, SaveIndex2: Integer; + WindowOrg: TPoint; + BkColor: TColor; +begin + ValidatePositions; + + if tbisInvalidated in Viewer.State then begin + Offscreen := True; + Exclude(Viewer.State, tbisInvalidated); + end; + + R1 := Viewer.BoundsRect; + if not Viewer.Show or IsRectEmpty(R1) or (Viewer.Item is TTBControlItem) then + Exit; + R2 := R1; + OffsetRect(R2, -R2.Left, -R2.Top); + + IsOpen := FOpenViewer = Viewer; + IsSelected := (FSelected = Viewer); + IsPushed := IsSelected and (IsOpen or (FMouseOverSelected and FCapture)); + ToolbarStyle := Viewer.IsToolbarStyle; + + DrawToDC := DrawTo.Handle; + Bmp := nil; + { Must deselect any currently selected handles before calling SaveDC, because + if they are left selected and DeleteObject gets called on them after the + SaveDC call, it will fail on Win9x/Me, and thus leak GDI resources. } + DrawTo.Refresh; + SaveIndex := SaveDC(DrawToDC); + try + IntersectClipRect(DrawToDC, R1.Left, R1.Top, R1.Right, R1.Bottom); + GetClipBox(DrawToDC, R3); + if IsRectEmpty(R3) then + Exit; + + if not Offscreen then begin + MoveWindowOrg(DrawToDC, R1.Left, R1.Top); + { Tweak the brush origin so that the checked background drawn behind + checked items always looks the same regardless of whether the item + is positioned on an even or odd Left or Top coordinate. } + if GetWindowOrgEx(DrawToDC, WindowOrg) then + SetBrushOrgEx(DrawToDC, -WindowOrg.X, -WindowOrg.Y, nil); + DrawCanvas := DrawTo; + end + else begin + Bmp := TBitmap.Create; + Bmp.Width := R2.Right; + Bmp.Height := R2.Bottom; + DrawCanvas := Bmp.Canvas; + BmpDC := DrawCanvas.Handle; + SaveIndex2 := SaveDC(BmpDC); + SetWindowOrgEx(BmpDC, R1.Left, R1.Top, nil); + FWindow.Perform(WM_ERASEBKGND, WPARAM(BmpDC), 0); + RestoreDC(BmpDC, SaveIndex2); + end; + + { Initialize brush } + if not ToolbarStyle and IsSelected then begin + {$IFNDEF TB2K_USE_STRICT_O2K_MENU_STYLE} + if AreFlatMenusEnabled then + { Windows XP uses a different fill color for selected menu items when + flat menus are enabled } + DrawCanvas.Brush.Color := clMenuHighlight + else + {$ENDIF} + DrawCanvas.Brush.Color := clHighlight; + end + else + DrawCanvas.Brush.Style := bsClear; + + { Initialize font } + DrawCanvas.Font.Assign(GetFont); + if Viewer.Item.Enabled then begin + if not ToolbarStyle and IsSelected then + DrawCanvas.Font.Color := clHighlightText + else begin + if ToolbarStyle then + DrawCanvas.Font.Color := clBtnText + else + DrawCanvas.Font.Color := tbMenuTextColor; + end; + UseDisabledShadow := False; + end + else begin + DrawCanvas.Font.Color := clGrayText; + { Use the disabled shadow if either: + 1. The item is a toolbar-style item. + 2. The item is not selected, and the background color equals the + button-face color. + 3. The gray-text color is the same as the background color. + Note: Windows actually uses dithered text in this case. } + BkColor := ColorToRGB({$IFNDEF CLR}TControlAccess{$ENDIF}(FWindow).Color); + UseDisabledShadow := ToolbarStyle or + (not IsSelected and (BkColor = ColorToRGB(clBtnFace))) or + (ColorToRGB(clGrayText) = BkColor); + end; + + Viewer.Paint(DrawCanvas, R2, IsSelected, IsPushed, UseDisabledShadow); + + if Offscreen then + BitBlt(DrawToDC, R1.Left, R1.Top, Bmp.Width, Bmp.Height, DrawCanvas.Handle, + 0, 0, SRCCOPY); + finally + DrawTo.Refresh; { must do this before a RestoreDC } + RestoreDC(DrawToDC, SaveIndex); + Bmp.Free; + end; +end; + +procedure TTBView.DrawSubitems(ACanvas: TCanvas); +var + ClipRect: TRect; + + procedure DoDraw(const AViewer: TTBItemViewer); + var + Temp: TRect; + begin + { Speed optimization: Only call DrawItem on viewers that intersect the + canvas's clipping rectangle. Without this check, moving the mouse across + a toolbar with thousands of visible items uses 100% of the CPU. } + if AViewer.Show and IntersectRect(Temp, ClipRect, AViewer.BoundsRect) then + DrawItem(AViewer, ACanvas, False) + else begin + { Not going to draw the item. Go ahead and clear the tbisInvalidated + flag if it's set so it won't needlessly double-buffer next time. } + Exclude(AViewer.State, tbisInvalidated); + end; + end; + +var + I: Integer; +begin + ValidatePositions; + ClipRect := ACanvas.ClipRect; + + { Draw non-selected items before drawing the selected item, so that when the + selection is changing there's no brief window in which two items appear + to be selected } + for I := 0 to FViewers.Count-1 do begin + if (vsDrawInOrder in FState) or (Viewers[I] <> FSelected) then + DoDraw(Viewers[I]); + end; + if not(vsDrawInOrder in FState) and Assigned(FSelected) then + DoDraw(FSelected); + + Exclude(FState, vsDrawInOrder); +end; + +procedure TTBView.Invalidate(AViewer: TTBItemViewer); +begin + if not FValidated or not Assigned(FWindow) or not FWindow.HandleAllocated then + Exit; + if AViewer.Show and not IsRectEmpty(AViewer.BoundsRect) and + not(AViewer.Item is TTBControlItem) then begin + Include(AViewer.State, tbisInvalidated); + InvalidateRect(FWindow.Handle, {$IFNDEF CLR}@{$ENDIF} AViewer.BoundsRect, False); + end; +end; + +procedure TTBView.SetAccelsVisibility(AShowAccels: Boolean); +var + I: Integer; + Viewer: TTBItemViewer; +begin + { Always show accels when keyboard cues are enabled } + AShowAccels := AShowAccels or not(vsUseHiddenAccels in FStyle) or + AreKeyboardCuesEnabled; + if AShowAccels <> (vsShowAccels in FState) then begin + if AShowAccels then + Include(FState, vsShowAccels) + else + Exclude(FState, vsShowAccels); + if Assigned(FWindow) and FWindow.HandleAllocated and + IsWindowVisible(FWindow.Handle) then + { ^ the visibility check is just an optimization } + for I := 0 to FViewers.Count-1 do begin + Viewer := Viewers[I]; + if Viewer.CaptionShown and + (FindAccelChar(Viewer.GetCaptionText) <> #0) then + Invalidate(Viewer); + end; + end; +end; + +function TTBView.FirstSelectable: TTBItemViewer; +var + FirstViewer: TTBItemViewer; +begin + Result := NextSelectable(nil, True); + if Assigned(Result) then begin + FirstViewer := Result; + while tbisDontSelectFirst in Result.Item.ItemStyle do begin + Result := NextSelectable(Result, True); + if Result = FirstViewer then + { don't loop endlessly if all items have the tbisDontSelectFirst style } + Break; + end; + end; +end; + +function TTBView.NextSelectable(CurViewer: TTBItemViewer; + GoForward: Boolean): TTBItemViewer; +var + I, J: Integer; +begin + ValidatePositions; + Result := nil; + if FViewers.Count = 0 then Exit; + J := -1; + I := IndexOf(CurViewer); + while True do begin + if GoForward then begin + Inc(I); + if I >= FViewers.Count then I := 0; + end + else begin + Dec(I); + if I < 0 then I := FViewers.Count-1; + end; + if J = -1 then + J := I + else + if I = J then + Exit; + if (Viewers[I].Show or Viewers[I].Clipped) and Viewers[I].Item.Visible and + (tbisSelectable in Viewers[I].Item.ItemStyle) then + Break; + end; + Result := Viewers[I]; +end; + +function TTBView.NextSelectableWithAccel(CurViewer: TTBItemViewer; + Key: Char; RequirePrimaryAccel: Boolean; var IsOnlyItemWithAccel: Boolean): TTBItemViewer; + + function IsAccelItem(const Index: Integer; + const Primary, EnabledItems: Boolean): Boolean; + var + S: String; + LastAccel: Char; + Viewer: TTBItemViewer; + Item: TTBCustomItem; + begin + Result := False; + Viewer := Viewers[Index]; + Item := Viewer.Item; + if (Viewer.Show or Viewer.Clipped) and (tbisSelectable in Item.ItemStyle) and + (Item.Enabled = EnabledItems) and + Item.Visible and Viewer.CaptionShown then begin + S := Viewer.GetCaptionText; + if S <> '' then begin + LastAccel := FindAccelChar(S); + if Primary then begin + if LastAccel <> #0 then + Result := (CharToLower(LastAccel) = CharToLower(Key)); + end + else + if (LastAccel = #0) and (Key <> ' ') then + Result := (CharToLower(S[1]) = CharToLower(Key)); + end; + end; + end; + + function FindAccel(I: Integer; + const Primary, EnabledItems: Boolean): Integer; + var + J: Integer; + begin + Result := -1; + J := -1; + while True do begin + Inc(I); + if I >= FViewers.Count then I := 0; + if J = -1 then + J := I + else + if I = J then + Break; + if IsAccelItem(I, Primary, EnabledItems) then begin + Result := I; + Break; + end; + end; + end; + +var + Start, I: Integer; + Primary, EnabledItems: Boolean; +begin + ValidatePositions; + Result := nil; + IsOnlyItemWithAccel := False; + if FViewers.Count = 0 then Exit; + + Start := IndexOf(CurViewer); + for Primary := True downto False do + if not RequirePrimaryAccel or Primary then + for EnabledItems := True downto False do begin + I := FindAccel(Start, Primary, EnabledItems); + if I <> -1 then begin + Result := Viewers[I]; + IsOnlyItemWithAccel := not EnabledItems or + (FindAccel(I, Primary, EnabledItems) = I); + Exit; + end; + end; +end; + +procedure TTBView.EnterToolbarLoop(Options: TTBEnterToolbarLoopOptions); +var + ModalHandler: TTBModalHandler; +begin + if vsModal in FState then Exit; + ModalHandler := TTBModalHandler.Create(FWindow.Handle); + try + { remove all states except... } + FState := FState * [vsShowAccels]; + try + Include(FState, vsModal); + { Must ensure that DoneAction is reset to tbdaNone *before* calling + NotifyFocusEvent so that the IsModalEnding call it makes won't return + True } + FDoneActionData.DoneAction := tbdaNone; + { Now that the vsModal state has been added, send an MSAA focus event } + if Assigned(Selected) then + NotifyFocusEvent; + ModalHandler.Loop(Self, tbetMouseDown in Options, + tbetExecuteSelected in Options, tbetFromMSAA in Options, False); + finally + { Remove vsModal state from the root view before any TTBView.Destroy + methods get called (as a result of the CloseChildPopups call below), + so that NotifyFocusEvent becomes a no-op } + Exclude(FState, vsModal); + StopAllTimers; + CloseChildPopups; + UpdateSelection(Point(Low(Integer), Low(Integer)), True); + end; + finally + ModalHandler.Free; + end; + SetAccelsVisibility(False); + ProcessDoneAction(FDoneActionData, False); +end; + +procedure TTBView.SetCustomizing(Value: Boolean); +begin + if FCustomizing <> Value then begin + FCustomizing := Value; + RecreateAllViewers; + end; +end; + +procedure TTBView.BeginUpdate; +begin + Inc(FUpdating); +end; + +procedure TTBView.EndUpdate; +begin + Dec(FUpdating); + if FUpdating = 0 then + TryValidatePositions; +end; + +procedure TTBView.GetOffEdgeControlList(const List: TList); +var + I: Integer; + Item: TTBCustomItem; +begin + for I := 0 to FViewers.Count-1 do begin + Item := Viewers[I].Item; + if (Item is TTBControlItem) and Viewers[I].OffEdge and + (TTBControlItem(Item).FControl is TWinControl) then + List.Add(TTBControlItem(Item).FControl); + end; +end; + +procedure TTBView.SetCapture; +begin + FCapture := True; +end; + +procedure TTBView.CancelCapture; +begin + if FCapture then begin + FCapture := False; + LastPos.X := Low(LastPos.X); + if Assigned(FSelected) then + FSelected.LosingCapture; + end; +end; + +procedure TTBView.KeyDown(var Key: Word; Shift: TShiftState); + + procedure SelNextItem(const ParentView: TTBView; const GoForward: Boolean); + begin + ParentView.Selected := ParentView.NextSelectable(ParentView.FSelected, + GoForward); + ParentView.ScrollSelectedIntoView; + end; + + procedure HelpKey; + var + V: TTBView; + ContextID: Integer; + begin + ContextID := 0; + V := Self; + while Assigned(V) do begin + if Assigned(V.FSelected) then begin + ContextID := V.FSelected.Item.HelpContext; + if ContextID <> 0 then Break; + end; + V := V.FParentView; + end; + if ContextID <> 0 then + EndModalWithHelp(ContextID); + end; + +var + ParentTBView: TTBView; +begin + ParentTBView := GetParentToolbarView; + case Key of + VK_TAB: begin + SelNextItem(Self, GetKeyState(VK_SHIFT) >= 0); + end; + VK_RETURN: begin + ExecuteSelected(True); + end; + VK_MENU, VK_F10: begin + EndModal; + end; + VK_ESCAPE: begin + Key := 0; + if FParentView = nil then + EndModal + else + FParentView.CancelChildPopups; + end; + VK_LEFT, VK_RIGHT: begin + if (Self = ParentTBView) and (Orientation = tbvoVertical) then + OpenChildPopup(True) + else if Key = VK_LEFT then begin + if Assigned(ParentTBView) and (ParentTBView.Orientation <> tbvoVertical) then begin + if (Self = ParentTBView) or + (FParentView = ParentTBView) then + SelNextItem(ParentTBView, False) + else + FParentView.CloseChildPopups; + end + else begin + if Assigned(FParentView) then + FParentView.CancelChildPopups; + end; + end + else begin + if ((Self = ParentTBView) or not OpenChildPopup(True)) and + (Assigned(ParentTBView) and (ParentTBView.Orientation <> tbvoVertical)) then begin + { If we're on ParentTBView, or if the selected item can't display + a submenu, proceed to next item on ParentTBView } + SelNextItem(ParentTBView, True); + end; + end; + end; + VK_UP, VK_DOWN: begin + if (Self = ParentTBView) and (Orientation <> tbvoVertical) then + OpenChildPopup(True) + else + SelNextItem(Self, Key = VK_DOWN); + end; + VK_HOME, VK_END: begin + Selected := NextSelectable(nil, Key = VK_HOME); + ScrollSelectedIntoView; + end; + VK_F1: HelpKey; + else + Exit; { don't set Key to 0 for unprocessed keys } + end; + Key := 0; +end; + +function TTBView.IsModalEnding: Boolean; +begin + Result := (GetRootView.FDoneActionData.DoneAction <> tbdaNone); +end; + +procedure TTBView.EndModal; +var + RootView: TTBView; +begin + RootView := GetRootView; + RootView.FDoneActionData.DoneAction := tbdaCancel; +end; + +procedure TTBView.EndModalWithClick(AViewer: TTBItemViewer); +var + RootView: TTBView; +begin + RootView := GetRootView; + RootView.FDoneActionData.ClickItem := AViewer.Item; + RootView.FDoneActionData.Sound := AViewer.FView.FIsPopup; + RootView.FDoneActionData.DoneAction := tbdaClickItem; +end; + +procedure TTBView.EndModalWithHelp(AContextID: Integer); +var + RootView: TTBView; +begin + RootView := GetRootView; + RootView.FDoneActionData.ContextID := AContextID; + RootView.FDoneActionData.DoneAction := tbdaHelpContext; +end; + +procedure TTBView.EndModalWithSystemMenu(AWnd: HWND; AKey: Word); +var + RootView: TTBView; +begin + RootView := GetRootView; + RootView.FDoneActionData.Wnd := AWnd; + RootView.FDoneActionData.Key := AKey; + RootView.FDoneActionData.DoneAction := tbdaOpenSystemMenu; +end; + +procedure TTBView.ExecuteSelected(AGivePriority: Boolean); +{ Normally called after an Enter or accelerator key press on the view, this + method 'executes' or opens the selected item. It ends the modal loop, except + when a submenu is opened. } +var + Item: TTBCustomItem; +begin + if Assigned(FSelected) and FSelected.Item.Enabled then begin + Item := FSelected.Item; + if (tbisCombo in Item.ItemStyle) or not OpenChildPopup(True) then begin + if tbisSelectable in Item.ItemStyle then + FSelected.Execute(AGivePriority) + else + EndModal; + end + end + else + EndModal; + {$IFNDEF CLR} + Exit; asm db 0,'Toolbar2000 (C) 1998-2008 Jordan Russell',0 end; + {$ENDIF} +end; + +procedure TTBView.Scroll(ADown: Boolean); +var + CurPos, NewPos, I: Integer; +begin + ValidatePositions; + if ADown then begin + NewPos := High(NewPos); + CurPos := FMaxHeight - tbMenuScrollArrowHeight; + for I := 0 to FViewers.Count-1 do begin + with Viewers[I] do + if Clipped and not(tbisSeparator in Item.ItemStyle) and + (BoundsRect.Bottom < NewPos) and (BoundsRect.Bottom > CurPos) then + NewPos := BoundsRect.Bottom; + end; + if NewPos = High(NewPos) then + Exit; + Dec(NewPos, FMaxHeight - tbMenuScrollArrowHeight); + end + else begin + NewPos := Low(NewPos); + CurPos := tbMenuScrollArrowHeight; + for I := 0 to FViewers.Count-1 do begin + with Viewers[I] do + if Clipped and not(tbisSeparator in Item.ItemStyle) and + (BoundsRect.Top > NewPos) and (BoundsRect.Top < CurPos) then + NewPos := BoundsRect.Top; + end; + if NewPos = Low(NewPos) then + Exit; + Dec(NewPos, tbMenuScrollArrowHeight); + end; + Inc(FScrollOffset, NewPos); + UpdatePositions; +end; + +procedure TTBView.ScrollSelectedIntoView; +begin + ValidatePositions; + if (FSelected = nil) or not FSelected.Clipped then + Exit; + + if FSelected.BoundsRect.Top < tbMenuScrollArrowHeight then begin + Dec(FScrollOffset, tbMenuScrollArrowHeight - FSelected.BoundsRect.Top); + UpdatePositions; + end + else if FSelected.BoundsRect.Bottom > FMaxHeight - tbMenuScrollArrowHeight then begin + Dec(FScrollOffset, (FMaxHeight - tbMenuScrollArrowHeight) - + FSelected.BoundsRect.Bottom); + UpdatePositions; + end; +end; + +procedure TTBView.SetUsePriorityList(Value: Boolean); +begin + if FUsePriorityList <> Value then begin + FUsePriorityList := Value; + RecreateAllViewers; + end; +end; + +function TTBView.GetCaptureWnd: HWND; +begin + Result := GetRootView.FCaptureWnd; +end; + +procedure TTBView.CancelMode; +var + View: TTBView; +begin + EndModal; + + { Hide all parent/child popup windows. Can't actually destroy them using + CloseChildPopups because this method may be called while inside + TTBEditItemViewer's message loop, and it could result in the active + TTBEditItemViewer instance being destroyed (leading to an AV). } + View := Self; + while Assigned(View.FOpenViewerView) do + View := View.FOpenViewerView; + repeat + View.StopAllTimers; + if View.FWindow is TTBPopupWindow then + View.FWindow.Visible := False; + View := View.FParentView; + until View = nil; + + { Note: This doesn't remove the selection from a top-level toolbar item. + Unfortunately, we can't do 'Selected := nil' because it would destroy + child popups and that must'nt happen for the reason stated above. } +end; + +procedure TTBView.HandleHintShowMessage(var Message: TCMHintShow); + + procedure UpdateInfo(var Info: {$IFDEF JR_D12}Controls.{$ENDIF} THintInfo); + var + V: TTBItemViewer; + begin + Info.HintStr := ''; + V := ViewerFromPoint(Info.CursorPos); + if Assigned(V) then begin + Info.CursorRect := V.BoundsRect; + Info.HintStr := V.GetHintText; + Info.HintData := V; + end; + end; + +{$IFNDEF CLR} +begin + UpdateInfo(Message.HintInfo^); +end; +{$ELSE} +var + Info: THintInfo; +begin + Info := Message.HintInfo; + UpdateInfo(Info); + Message.HintInfo := Info; +end; +{$ENDIF} + + +{ TTBModalHandler } + +constructor TTBModalHandler.Create(AExistingWnd: HWND); + + procedure RemoveFocusIfOnOtherThread; + { This ensures that the message loop will receive key messages when an Adobe + Reader (8.1.2) control embedded in a TWebBrowser is currently focused. + The Reader control is actually hosted in a separate thread (in a separate + process, AcroRd32.exe). When Alt/Alt+[letter] is pressed, Reader calls + GetAncestor(..., GA_ROOT) and forwards the WM_SYSCOMMAND/WM_SYSCHAR + message to that window using SendMessage (not PostMessage, for some + reason). The focus, however, is left on the Reader control. Consequently, + any keystrokes will generate key messages in the Reader thread's queue + instead of ours. To avoid that, call SetFocus(0) to remove the focus if + it's currently on another thread's window. When no window has the focus, + key messages will be posted to the active window, which *should* be a + form owned by the same thread as us. } + var + FocusWnd: HWND; + begin + FocusWnd := GetFocus; + if (FocusWnd <> 0) and + (GetWindowThreadProcessId(FocusWnd, nil) <> GetCurrentThreadId) then begin + FSaveFocusWnd := FocusWnd; + SetFocus(0); + end; + end; + +begin + inherited Create; + LastPos := GetMessagePosAsPoint; + if AExistingWnd <> 0 then + FWnd := AExistingWnd + else begin + FWnd := {$IFDEF ALLOCHWND_CLASSES}Classes.{$ENDIF} AllocateHWnd(WndProc); + FCreatedWnd := True; + end; + RemoveFocusIfOnOtherThread; + { Like standard menus, don't allow other apps to steal the focus during + our modal loop. This also prevents us from losing activation when + "active window tracking" is enabled and the user moves the mouse over + another application's window. } + CallLockSetForegroundWindow(True); + SetCapture(FWnd); + SetCursor(LoadCursor(0, IDC_ARROW)); + CallNotifyWinEvent(EVENT_SYSTEM_MENUSTART, FWnd, OBJID_CLIENT, CHILDID_SELF); + FInited := True; +end; + +destructor TTBModalHandler.Destroy; +begin + CallLockSetForegroundWindow(False); + if FWnd <> 0 then begin + if GetCapture = FWnd then + ReleaseCapture; + if FInited then + CallNotifyWinEvent(EVENT_SYSTEM_MENUEND, FWnd, OBJID_CLIENT, CHILDID_SELF); + if FCreatedWnd then + {$IFDEF ALLOCHWND_CLASSES}Classes.{$ENDIF} DeallocateHWnd(FWnd); + end; + if (FSaveFocusWnd <> 0) and (GetFocus = 0) then + SetFocus(FSaveFocusWnd); + inherited; +end; + +procedure TTBModalHandler.WndProc(var Msg: TMessage); +begin + Msg.Result := DefWindowProc(FWnd, Msg.Msg, Msg.WParam, Msg.LParam); + if (Msg.Msg = WM_CANCELMODE) and Assigned(FRootPopup) then begin + try + { We can receive a WM_CANCELMODE message during a modal loop if a dialog + pops up. Respond by hiding menus to make it look like the modal loop + has returned, even though it really hasn't yet. + Note: Similar code in TTBCustomToolbar.WMCancelMode. } + FRootPopup.View.CancelMode; + except + Application.HandleException(Self); + end; + end; +end; + +procedure TTBModalHandler.Loop(const RootView: TTBView; + const AMouseDown, AExecuteSelected, AFromMSAA, TrackRightButton: Boolean); +var + OriginalActiveWindow: HWND; + + function GetActiveView: TTBView; + begin + Result := RootView; + while Assigned(Result.FOpenViewerView) do + Result := Result.FOpenViewerView; + end; + + function GetCaptureView: TTBView; + begin + Result := RootView; + while Assigned(Result) and not Result.FCapture do + Result := Result.FOpenViewerView; + end; + + procedure UpdateAllSelections(const P: TPoint; const AllowNewSelection: Boolean); + var + View, CapView: TTBView; + begin + View := GetActiveView; + CapView := GetCaptureView; + while Assigned(View) do begin + if (CapView = nil) or (View = CapView) then + View.UpdateSelection(P, AllowNewSelection); + View := View.FParentView; + end; + end; + + function GetSelectedViewer(var AView: TTBView; var AViewer: TTBItemViewer): Boolean; + { Returns True if AViewer <> nil. } + var + View: TTBView; + begin + { Look for a capture item first } + AView := GetCaptureView; + if Assigned(AView) then + AViewer := AView.FSelected + else begin + AView := nil; + AViewer := nil; + View := RootView; + repeat + if Assigned(View.FSelected) and View.FMouseOverSelected then begin + AView := View; + AViewer := View.FSelected; + Break; + end; + if vsMouseInWindow in View.FState then begin + { ...there is no current selection, but the mouse is still in the + window. This can happen if the mouse is over the non-client area + of the toolbar or popup window, or in an area not containing an + item. } + AView := View; + Break; + end; + View := View.FOpenViewerView; + until View = nil; + end; + Result := Assigned(AViewer); + end; + + function ContinueLoop: Boolean; + begin + { Don't continue if the mouse capture is lost, if a (modeless) top-level + window is shown causing the active window to change, or if EndModal* was + called. } + Result := (GetCapture = FWnd) and (GetActiveWindow = OriginalActiveWindow) + and not RootView.IsModalEnding; + end; + + function SendKeyEvent(const View: TTBView; var Key: Word; + const Shift: TShiftState): Boolean; + begin + Result := True; + if Assigned(View.FSelected) then begin + View.FSelected.KeyDown(Key, Shift); + if RootView.IsModalEnding then + Exit; + end; + if Key <> 0 then begin + View.KeyDown(Key, Shift); + if RootView.IsModalEnding then + Exit; + end; + Result := False; + end; + + procedure DoHintMouseMessage(const Ctl: TControl; const P: TPoint); + var + M: TMessage; + begin + {$IFDEF CLR} + M := TMessage.Create; + {$ENDIF} + M.Msg := WM_MOUSEMOVE; + M.WParam := 0; + M.LParam := MAKELPARAM(Word(P.X), Word(P.Y)); + M.Result := 0; + Application.HintMouseMessage(Ctl, M); + end; + + procedure MouseMoved; + var + Cursor: HCURSOR; + View: TTBView; + Viewer: TTBItemViewer; + P: TPoint; + begin + UpdateAllSelections(LastPos, True); + Cursor := 0; + if GetSelectedViewer(View, Viewer) then begin + P := View.FWindow.ScreenToClient(LastPos); + if ((vsAlwaysShowHints in View.FStyle) or + (tboShowHint in Viewer.Item.FEffectiveOptions)) and not View.FCapture then begin + { Display popup hint for the item. Update is called + first to minimize flicker caused by the hiding & + showing of the hint window. } + View.FWindow.Update; + DoHintMouseMessage(View.FWindow, P); + end + else + Application.CancelHint; + Dec(P.X, Viewer.BoundsRect.Left); + Dec(P.Y, Viewer.BoundsRect.Top); + Viewer.GetCursor(P, Cursor); + end + else + Application.CancelHint; + if Cursor = 0 then + Cursor := LoadCursor(0, IDC_ARROW); + SetCursor(Cursor); + if Assigned(Viewer) then + Viewer.MouseMove(P.X, P.Y); + end; + + procedure UpdateAppHint; + var + View: TTBView; + begin + View := RootView; + while Assigned(View.FOpenViewerView) and Assigned(View.FOpenViewerView.FSelected) do + View := View.FOpenViewerView; + if Assigned(View.FSelected) then + Application.Hint := GetLongHint(View.FSelected.Item.Hint) + else + Application.Hint := ''; + end; + + procedure HandleTimer(const View: TTBView; const ID: TTBViewTimerID); + begin + case ID of + tiOpen: begin + { Similar to standard menus, always close child popups, even if + Selected = OpenViewer. + Note: CloseChildPopups and OpenChildPopup will stop the tiClose + and tiOpen timers respectively. } + View.CloseChildPopups; + View.OpenChildPopup(False); + end; + tiClose: begin + { Note: CloseChildPopups stops the tiClose timer. } + View.CloseChildPopups; + end; + tiScrollUp: begin + if View.FShowUpArrow then + View.Scroll(False) + else + View.StopTimer(tiScrollUp); + end; + tiScrollDown: begin + if View.FShowDownArrow then + View.Scroll(True) + else + View.StopTimer(tiScrollDown); + end; + end; + end; + +var + MouseDownOnMenu: Boolean; + Msg: TMsg; + P: TPoint; + Ctl: TControl; + View: TTBView; + ConvertedKey: Char; + IsOnlyItemWithAccel: Boolean; + MouseIsDown: Boolean; + Key: Word; + Shift: TShiftState; + Viewer: TTBItemViewer; +begin + RootView.FDoneActionData.DoneAction := tbdaNone; + RootView.ValidatePositions; + try + try + RootView.FCaptureWnd := FWnd; + MouseDownOnMenu := False; + if AMouseDown then begin + P := RootView.FSelected.ScreenToClient(GetMessagePosAsPoint); + RootView.FSelected.MouseDown([], P.X, P.Y, MouseDownOnMenu); + if RootView.IsModalEnding then + Exit; + MouseDownOnMenu := False; { never set MouseDownOnMenu to True on first click } + end + else if AExecuteSelected then begin + RootView.ExecuteSelected(not AFromMSAA); + if RootView.IsModalEnding then + Exit; + end; + OriginalActiveWindow := GetActiveWindow; + while ContinueLoop do begin + TBUpdateAnimation; + { Examine the next message before popping it out of the queue } + if not PeekMessage(Msg, 0, 0, 0, PM_NOREMOVE) then begin + { No message available; wait for one to arrive } + if TBIsAnimationInProgress then + { While animating, if no message arrives within 1 ms, loop back and + call TBUpdateAnimation again to see if it's ready for a new frame. + Note: We don't use a timer to call TBUpdateAnimation because on + Windows 98, timers only have a resolution of 55 ms in my tests, + too poor for smooth animation. (timeBeginPeriod does not help.) + Sleep and MsgWaitForMultipleObjects, on the other hand, appear to + have a resolution of 5 ms by default. (Better resolution is + possible with a call to timeBeginPeriod, but we don't need it.) + Note: On 2000/XP, timers and Sleep both have a resolution of 10-15 + ms by default. } + MsgWaitForMultipleObjects(0, {$IFNDEF CLR} THandle(nil^) {$ELSE} [] {$ENDIF}, + False, 1, QS_ALLINPUT) + else + WaitMessage; + Continue; + end; + case Msg.message of + WM_LBUTTONDOWN, WM_RBUTTONDOWN: begin + P := Msg.pt; + Ctl := FindDragTarget(P, True); + { Was the mouse not clicked on a popup, or was it clicked on a + popup that is not a child of RootView? + (The latter can happen when in customization mode, for example, + if the user right-clicks a popup menu being customized and + the context menu is displayed.) } + if not(Ctl is TTBPopupWindow) or + not RootView.ContainsView(TTBPopupWindow(Ctl).View) then begin + { If the root view is a popup, or if the root view is a toolbar + and the user clicked outside the toolbar or in its non-client + area (e.g. on its drag handle), exit } + if RootView.FIsPopup or (Ctl <> RootView.FWindow) or + not PtInRect(RootView.FWindow.ClientRect, RootView.FWindow.ScreenToClient(P)) then + Exit + else + if Msg.message = WM_LBUTTONDOWN then begin + { If the user clicked inside a toolbar on anything but an + item, exit } + UpdateAllSelections(P, True); + if (RootView.FSelected = nil) or not RootView.FMouseOverSelected or + (tbisClicksTransparent in RootView.FSelected.Item.ItemStyle) then + Exit; + end; + end; + end; + end; + { Now pop the message out of the queue } + if not PeekMessage(Msg, 0, Msg.message, Msg.message, PM_REMOVE or PM_NOYIELD) then + Continue; + case Msg.message of + $4D: + { This undocumented message is sent to the focused window when + F1 is pressed. Windows handles it by sending a WM_HELP message + to the same window. We don't want this to happen while a menu + is up, so swallow the message. } + ; + WM_CONTEXTMENU: + { Windows still sends WM_CONTEXTMENU messages for "context menu" + keystrokes even if WM_KEYUP messages are never dispatched, + so it must specifically ignore this message } + ; + WM_KEYFIRST..WM_KEYLAST: begin + Application.CancelHint; + MouseIsDown := (GetKeyState(VK_LBUTTON) < 0) or + (TrackRightButton and (GetKeyState(VK_RBUTTON) < 0)); + case Msg.message of + WM_KEYDOWN, WM_SYSKEYDOWN: + begin + if Msg.wParam = VK_PROCESSKEY then + { Don't let IME process the key } + Msg.wParam := WPARAM(ImmGetVirtualKey(Msg.hwnd)); + Key := Word(Msg.wParam); + if not MouseIsDown or (Key = VK_F1) then begin + if SendKeyEvent(GetActiveView, Key, + KeyDataToShiftState(ClipToLongint(Msg.lParam))) then + Exit; + { If it's not handled by a KeyDown method, translate + it into a WM_*CHAR message } + if Key <> 0 then + TranslateMessage(Msg); + end; + end; + WM_CHAR, WM_SYSCHAR: + if not MouseIsDown then begin + Key := Word(Msg.wParam); + View := GetActiveView; + {$IFDEF CLR} + { On .NET, under Windows 9x/Me we must convert the character + code from ANSI->Unicode. (We shouldn't get any double-byte + characters due to our VK_PROCESSKEY handling above.) } + if Marshal.SystemDefaultCharSize = 1 then + ConvertedKey := Encoding.GetEncoding(GetInputLocaleCodePage). + GetChars([Byte(Key)])[0] + else + {$ENDIF} + ConvertedKey := Chr(Key); + Viewer := View.NextSelectableWithAccel(View.FSelected, + ConvertedKey, False, IsOnlyItemWithAccel); + if Viewer = nil then begin + if (Key in [VK_SPACE, Ord('-')]) and + not RootView.FIsPopup and (View = RootView) and + (GetActiveWindow <> 0) then begin + RootView.EndModalWithSystemMenu(GetActiveWindow, Key); + Exit; + end + else + MessageBeep(0); + end + else begin + View.Selected := Viewer; + View.ScrollSelectedIntoView; + if IsOnlyItemWithAccel then + View.ExecuteSelected(True); + end; + end; + end; + end; + WM_TIMER: + begin + Ctl := FindControl(Msg.hwnd); + if Assigned(Ctl) and (Ctl is TTBPopupWindow) and + (Msg.wParam >= ViewTimerBaseID + Ord(Low(TTBViewTimerID))) and + (Msg.wParam <= ViewTimerBaseID + Ord(High(TTBViewTimerID))) then begin + if Assigned(TTBPopupWindow(Ctl).FView) then + HandleTimer(TTBPopupWindow(Ctl).FView, + TTBViewTimerID(Msg.wParam - ViewTimerBaseID)); + end + else + DispatchMessage(Msg); + end; + $118: ; + { ^ Like standard menus, don't dispatch WM_SYSTIMER messages + (the internal Windows message used for things like caret + blink and list box scrolling). } + WM_MOUSEFIRST..WM_MOUSELAST: + case Msg.message of + WM_MOUSEMOVE: begin + if (Msg.pt.X <> LastPos.X) or (Msg.pt.Y <> LastPos.Y) then begin + LastPos := Msg.pt; + MouseMoved; + end; + end; + WM_MOUSEWHEEL: + if GetSelectedViewer(View, Viewer) then begin + P := Viewer.ScreenToClient(Msg.pt); + Viewer.MouseWheel(Smallint(Msg.wParam shr 16), P.X, P.Y); + end; + WM_LBUTTONDOWN, WM_LBUTTONDBLCLK, WM_RBUTTONDOWN: + if (Msg.message <> WM_RBUTTONDOWN) or TrackRightButton then begin + Application.CancelHint; + MouseDownOnMenu := False; + Exclude(RootView.FState, vsIgnoreFirstMouseUp); + UpdateAllSelections(Msg.pt, True); + if GetSelectedViewer(View, Viewer) then begin + if Msg.message <> WM_LBUTTONDBLCLK then + Shift := [] + else + Shift := [ssDouble]; + P := Viewer.ScreenToClient(Msg.pt); + Viewer.MouseDown(Shift, P.X, P.Y, MouseDownOnMenu); + LastPos := GetMessagePosAsPoint; + end; + end; + WM_LBUTTONUP, WM_RBUTTONUP: + if (Msg.message = WM_LBUTTONUP) or TrackRightButton then begin + UpdateAllSelections(Msg.pt, False); + { ^ False is used so that when a popup menu is + displayed with the cursor currently inside it, the item + under the cursor won't be accidentally selected when the + user releases the button. The user must move the mouse at + at least one pixel (generating a WM_MOUSEMOVE message), + and then release the button. } + if not GetSelectedViewer(View, Viewer) then begin + { Mouse was not released over any item. Cancel out of the + loop if it's outside all views, or is inside unused + space on a topmost toolbar } + if not Assigned(View) or + ((View = RootView) and RootView.FIsToolbar) then begin + if not(vsIgnoreFirstMouseUp in RootView.FState) then + Exit + else + Exclude(RootView.FState, vsIgnoreFirstMouseUp); + end; + end + else begin + P := Viewer.ScreenToClient(Msg.pt); + Viewer.MouseUp(P.X, P.Y, MouseDownOnMenu); + end; + end; + end; + else + DispatchMessage(Msg); + end; + if not ContinueLoop then + Exit; + if LastPos.X = Low(LastPos.X) then begin + { The capture was released; generate a fake mouse movement to update + the selection } + LastPos := GetMessagePosAsPoint; + MouseMoved; + end; + UpdateAppHint; + end; + finally + RootView.CancelCapture; + end; + finally + RootView.FCaptureWnd := 0; + Application.Hint := ''; + { Make sure there are no outstanding WM_*CHAR messages } + RemoveMessages(WM_CHAR, WM_DEADCHAR); + RemoveMessages(WM_SYSCHAR, WM_SYSDEADCHAR); + { Nor any outstanding 'send WM_HELP' messages caused by an earlier press + of the F1 key } + RemoveMessages($4D, $4D); + end; +end; + + +{ TTBPopupView } + +procedure TTBPopupView.AutoSize(AWidth, AHeight: Integer); +begin + with FWindow do + SetBounds(Left, Top, AWidth + (PopupMenuWindowNCSize * 2), + AHeight + (PopupMenuWindowNCSize * 2)); +end; + +function TTBPopupView.GetFont: TFont; +begin + Result := (Owner as TTBPopupWindow).Font; +end; + + +{ TTBPopupWindow } + +constructor TTBPopupWindow.CreatePopupWindow(AOwner: TComponent; + const AParentView: TTBView; const AItem: TTBCustomItem; + const ACustomizing: Boolean); +begin + inherited Create(AOwner); + Visible := False; + SetBounds(0, 0, 320, 240); + ControlStyle := ControlStyle - [csCaptureMouse]; + ShowHint := True; + Color := tbMenuBkColor; + FView := GetViewClass.Create(Self, AParentView, AItem, Self, False, + ACustomizing, False); + Include(FView.FState, vsModal); + + { Inherit the font from the parent view, or use the system menu font if + there is no parent view } + if Assigned(AParentView) then + Font.Assign(AParentView.GetFont) + else + Font.Assign(ToolbarFont); + + { Inherit the accelerator visibility state from the parent view. If there + is no parent view (i.e. it's a standalone popup menu), then default to + hiding accelerator keys, but change this in CreateWnd if the last input + came from the keyboard. } + if Assigned(AParentView) then begin + if vsUseHiddenAccels in AParentView.FStyle then + Include(FView.FStyle, vsUseHiddenAccels); + if vsShowAccels in AParentView.FState then + Include(FView.FState, vsShowAccels); + end + else + Include(FView.FStyle, vsUseHiddenAccels); + + if Application.Handle <> 0 then + { Use Application.Handle if possible so that the taskbar button for the app + doesn't pop up when a TTBEditItem on a popup menu is focused } + ParentWindow := Application.Handle + else + { When Application.Handle is zero, use GetDesktopWindow() as the parent + window, not zero, otherwise UpdateControlState won't show the window } + ParentWindow := GetDesktopWindow; +end; + +destructor TTBPopupWindow.Destroy; +begin + Destroying; + { Before destroying the window handle we need to close any child popups so + that pixels behind the popups are properly restored without generating a + WM_PAINT message. } + if Assigned(FView) then + FView.CloseChildPopups; + { Ensure window handle is destroyed *before* FView is freed, since + DestroyWindowHandle calls CallNotifyWinEvent which may result in + FView.HandleWMObject being called } + if HandleAllocated then + DestroyWindowHandle; + FreeAndNil(FView); + inherited; +end; + +function TTBPopupWindow.GetViewClass: TTBViewClass; +begin + Result := TTBPopupView; +end; + +procedure TTBPopupWindow.CreateParams(var Params: TCreateParams); +const + CS_DROPSHADOW = $00020000; +begin + inherited; + with Params do begin + Style := (Style and not (WS_CHILD or WS_GROUP or WS_TABSTOP)) or WS_POPUP; + ExStyle := ExStyle or WS_EX_TOPMOST or WS_EX_TOOLWINDOW; + WindowClass.Style := WindowClass.Style or CS_SAVEBITS; + { Enable drop shadow effect on Windows XP and later } + if IsWindowsXP then + WindowClass.Style := WindowClass.Style or CS_DROPSHADOW; + end; +end; + +procedure TTBPopupWindow.CreateWnd; +const + WM_CHANGEUISTATE = $0127; + WM_QUERYUISTATE = $0129; + UIS_INITIALIZE = 3; + UISF_HIDEACCEL = $2; +var + B: Boolean; +begin + inherited; + { On a top-level popup window, send WM_CHANGEUISTATE & WM_QUERYUISTATE + messages to the window to see if the last input came from the keyboard + and if the accelerator keys should be shown } + if (FView.ParentView = nil) and not FAccelsVisibilitySet then begin + FAccelsVisibilitySet := True; + SendMessage(Handle, WM_CHANGEUISTATE, UIS_INITIALIZE, 0); + B := (SendMessage(Handle, WM_QUERYUISTATE, 0, 0) and UISF_HIDEACCEL = 0); + FView.SetAccelsVisibility(B); + end; +end; + +procedure TTBPopupWindow.DestroyWindowHandle; +begin + { Before destroying the window handle, we must stop any animation, otherwise + the animation thread will use an invalid handle } + TBEndAnimation(WindowHandle); + { Cleanly destroy any timers before the window handle is destroyed } + if Assigned(FView) then + FView.StopAllTimers; + CallNotifyWinEvent(EVENT_SYSTEM_MENUPOPUPEND, WindowHandle, OBJID_CLIENT, + CHILDID_SELF); + inherited; +end; + +procedure TTBPopupWindow.WMGetObject(var Message: TMessage); +begin + if not FView.HandleWMGetObject(Message) then + inherited; +end; + +procedure TTBPopupWindow.CMShowingChanged(var Message: TMessage); +const + ShowFlags: array[Boolean] of UINT = ( + SWP_NOSIZE or SWP_NOMOVE or SWP_NOZORDER or SWP_NOACTIVATE or SWP_HIDEWINDOW, + SWP_NOSIZE or SWP_NOMOVE or SWP_NOZORDER or SWP_NOACTIVATE or SWP_SHOWWINDOW); + SPI_GETMENUFADE = $1012; +var + Blend: Boolean; +begin + { Must override TCustomForm/TForm's CM_SHOWINGCHANGED handler so that the + form doesn't get activated when Visible is set to True. } + + { Handle animation. NOTE: I do not recommend trying to enable animation on + Windows 95 and NT 4.0 because there's a difference in the way the + SetWindowPos works on those versions. See the comment in the + TBStartAnimation function of TB2Anim.pas. } + {$IFNDEF TB2K_NO_ANIMATION} + if ((FView.ParentView = nil) or not(vsNoAnimation in FView.FParentView.FState)) and + Showing and (FView.Selected = nil) and not IsWindowVisible(WindowHandle) and + GetSystemParametersInfoBool(SPI_GETMENUANIMATION, False) then begin + Blend := GetSystemParametersInfoBool(SPI_GETMENUFADE, False); + if Blend or (FAnimationDirection <> []) then begin + TBStartAnimation(WindowHandle, Blend, FAnimationDirection); + Exit; + end; + end; + {$ENDIF} + + { No animation... } + if not Showing then begin + { Call TBEndAnimation to ensure WS_EX_LAYERED style is removed before + hiding, otherwise windows under the popup window aren't repainted + properly. } + TBEndAnimation(WindowHandle); + end; + SetWindowPos(WindowHandle, 0, 0, 0, 0, 0, ShowFlags[Showing]); +end; + +procedure TTBPopupWindow.WMEraseBkgnd(var Message: TWMEraseBkgnd); +begin + { May be necessary in some cases... } + TBEndAnimation(WindowHandle); + inherited; +end; + +procedure TTBPopupWindow.WMPaint(var Message: TWMPaint); +begin + { Must abort animation when a WM_PAINT message is received } + TBEndAnimation(WindowHandle); + inherited; +end; + +procedure TTBPopupWindow.Paint; +begin + FView.DrawSubitems(Canvas); + PaintScrollArrows; +end; + +procedure TTBPopupWindow.PaintScrollArrows; + + procedure DrawArrow(const R: TRect; ADown: Boolean); + var + X, Y: Integer; + P: array[0..2] of TPoint; + begin + X := (R.Left + R.Right) div 2; + Y := (R.Top + R.Bottom) div 2; + Dec(Y); + P[0].X := X-3; + P[0].Y := Y; + P[1].X := X+3; + P[1].Y := Y; + P[2].X := X; + P[2].Y := Y; + if ADown then + Inc(P[2].Y, 3) + else begin + Inc(P[0].Y, 3); + Inc(P[1].Y, 3); + end; + Canvas.Pen.Color := tbMenuTextColor; + Canvas.Brush.Color := tbMenuTextColor; + Canvas.Polygon(P); + end; + +begin + if FView.FShowUpArrow then + DrawArrow(Rect(0, 0, ClientWidth, tbMenuScrollArrowHeight), False); + if FView.FShowDownArrow then + DrawArrow(Bounds(0, ClientHeight - tbMenuScrollArrowHeight, + ClientWidth, tbMenuScrollArrowHeight), True); +end; + +procedure TTBPopupWindow.WMClose(var Message: TWMClose); +begin + { do nothing -- ignore Alt+F4 keypresses } +end; + +procedure TTBPopupWindow.WMNCCalcSize(var Message: TWMNCCalcSize); + + procedure ApplyToRect(var R: TRect); + begin + InflateRect(R, -PopupMenuWindowNCSize, -PopupMenuWindowNCSize); + end; + +{$IFDEF CLR} +var + Params: TNCCalcSizeParams; +{$ENDIF} +begin + {$IFNDEF CLR} + ApplyToRect(Message.CalcSize_Params.rgrc[0]); + {$ELSE} + Params := Message.CalcSize_Params; + ApplyToRect(Params.rgrc0); + Message.CalcSize_Params := Params; + {$ENDIF} + inherited; +end; + +procedure PopupWindowNCPaintProc(Wnd: HWND; DC: HDC; AppData: TObject); +var + R: TRect; + {$IFNDEF TB2K_USE_STRICT_O2K_MENU_STYLE} + Brush: HBRUSH; + {$ENDIF} +begin + GetWindowRect(Wnd, R); OffsetRect(R, -R.Left, -R.Top); + {$IFNDEF TB2K_USE_STRICT_O2K_MENU_STYLE} + if not AreFlatMenusEnabled then begin + {$ENDIF} + DrawEdge(DC, R, EDGE_RAISED, BF_RECT or BF_ADJUST); + FrameRect(DC, R, GetSysColorBrush(COLOR_BTNFACE)); + {$IFNDEF TB2K_USE_STRICT_O2K_MENU_STYLE} + end + else begin + FrameRect(DC, R, GetSysColorBrush(COLOR_BTNSHADOW)); + Brush := CreateSolidBrush(ColorToRGB(TTBPopupWindow(AppData).Color)); + InflateRect(R, -1, -1); + FrameRect(DC, R, Brush); + InflateRect(R, -1, -1); + FrameRect(DC, R, Brush); + DeleteObject(Brush); + end; + {$ENDIF} +end; + +procedure TTBPopupWindow.WMNCPaint(var Message: TMessage); +var + DC: HDC; +begin + DC := GetWindowDC(Handle); + try + SelectNCUpdateRgn(Handle, DC, HRGN(Message.WParam)); + PopupWindowNCPaintProc(Handle, DC, Self); + finally + ReleaseDC(Handle, DC); + end; +end; + +procedure TTBPopupWindow.WMPrint(var Message: TMessage); +begin + HandleWMPrint(Handle, Message, PopupWindowNCPaintProc, Self); +end; + +procedure TTBPopupWindow.WMPrintClient(var Message: + {$IFNDEF CLR} TMessage {$ELSE} TWMPrintClient {$ENDIF}); +begin + HandleWMPrintClient(PaintHandler, Message); +end; + +procedure TTBPopupWindow.CMHintShow(var Message: TCMHintShow); +begin + FView.HandleHintShowMessage(Message); +end; + + +{ TTBItemContainer } + +constructor TTBItemContainer.Create(AOwner: TComponent); +begin + inherited; + FItem := TTBRootItem.Create(Self); + FItem.ParentComponent := Self; +end; + +destructor TTBItemContainer.Destroy; +begin + FItem.Free; + inherited; +end; + +function TTBItemContainer.GetItems: TTBCustomItem; +begin + Result := FItem; +end; + +procedure TTBItemContainer.GetChildren(Proc: TGetChildProc; Root: TComponent); +begin + FItem.GetChildren(Proc, Root); +end; + +function TTBItemContainer.GetImages: TCustomImageList; +begin + Result := FItem.SubMenuImages; +end; + +procedure TTBItemContainer.SetImages(Value: TCustomImageList); +begin + FItem.SubMenuImages := Value; +end; + + +{ TTBPopupMenu } + +constructor TTBPopupMenu.Create(AOwner: TComponent); +begin + inherited; + FItem := GetRootItemClass.Create(Self); + FItem.ParentComponent := Self; + FItem.OnClick := RootItemClick; +end; + +destructor TTBPopupMenu.Destroy; +begin + FItem.Free; + inherited; +end; + +function TTBPopupMenu.GetItems: TTBCustomItem; +begin + Result := FItem; +end; + +procedure TTBPopupMenu.GetChildren(Proc: TGetChildProc; Root: TComponent); +begin + FItem.GetChildren(Proc, Root); +end; + +procedure TTBPopupMenu.SetChildOrder(Child: TComponent; Order: Integer); +begin + FItem.SetChildOrder(Child, Order); +end; + +function TTBPopupMenu.GetRootItemClass: TTBRootItemClass; +begin + Result := TTBRootItem; +end; + +function TTBPopupMenu.GetImages: TCustomImageList; +begin + Result := FItem.SubMenuImages; +end; + +function TTBPopupMenu.GetLinkSubitems: TTBCustomItem; +begin + Result := FItem.LinkSubitems; +end; + +function TTBPopupMenu.GetOptions: TTBItemOptions; +begin + Result := FItem.Options; +end; + +procedure TTBPopupMenu.SetImages(Value: TCustomImageList); +begin + FItem.SubMenuImages := Value; +end; + +procedure TTBPopupMenu.SetLinkSubitems(Value: TTBCustomItem); +begin + FItem.LinkSubitems := Value; +end; + +procedure TTBPopupMenu.SetOptions(Value: TTBItemOptions); +begin + FItem.Options := Value; +end; + +procedure TTBPopupMenu.RootItemClick(Sender: TObject); +begin + if Sender = FItem then + Sender := Self; + DoPopup(Sender); +end; + +{$IFNDEF JR_D5} +procedure TTBPopupMenu.DoPopup(Sender: TObject); +begin + if Assigned(OnPopup) then OnPopup(Sender); +end; +{$ENDIF} + +procedure TTBPopupMenu.Popup(X, Y: Integer); +begin + PopupEx(X, Y, False); +end; + +function TTBPopupMenu.PopupEx(X, Y: Integer; + ReturnClickedItemOnly: Boolean = False): TTBCustomItem; +begin + {$IFDEF JR_D5} + {$IFDEF JR_D9} + SetPopupPoint(Point(X, Y)); + {$ELSE} + PPoint(@PopupPoint)^ := Point(X, Y); + {$ENDIF} + {$ENDIF} + Result := FItem.Popup(X, Y, TrackButton = tbRightButton, + TTBPopupAlignment(Alignment), ReturnClickedItemOnly); +end; + +function TTBPopupMenu.IsShortCut(var Message: TWMKey): Boolean; +begin + Result := FItem.IsShortCut(Message); +end; + + +{ TTBImageList } + +constructor TTBCustomImageList.Create(AOwner: TComponent); +begin + inherited; + FCheckedImagesChangeLink := TChangeLink.Create; + FCheckedImagesChangeLink.OnChange := ImageListChanged; + FDisabledImagesChangeLink := TChangeLink.Create; + FDisabledImagesChangeLink.OnChange := ImageListChanged; + FHotImagesChangeLink := TChangeLink.Create; + FHotImagesChangeLink.OnChange := ImageListChanged; + FImagesBitmap := TBitmap.Create; + FImagesBitmap.OnChange := ImagesBitmapChanged; + FImagesBitmapMaskColor := clFuchsia; +end; + +destructor TTBCustomImageList.Destroy; +begin + FreeAndNil(FImagesBitmap); + FreeAndNil(FHotImagesChangeLink); + FreeAndNil(FDisabledImagesChangeLink); + FreeAndNil(FCheckedImagesChangeLink); + inherited; +end; + +procedure TTBCustomImageList.ImagesBitmapChanged(Sender: TObject); +begin + if not ImagesBitmap.Empty then begin + Clear; + AddMasked(ImagesBitmap, FImagesBitmapMaskColor); + end; +end; + +procedure TTBCustomImageList.ImageListChanged(Sender: TObject); +begin + Change; +end; + +{$IFDEF CLR} +procedure TTBCustomImageList.WriteLeft(Writer: TWriter); +begin + Writer.WriteInteger(DesignInfo shr 16); +end; + +procedure TTBCustomImageList.WriteTop(Writer: TWriter); +begin + Writer.WriteInteger(DesignInfo and $FFFF); +end; +{$ENDIF} + +procedure TTBCustomImageList.DefineProperties(Filer: TFiler); +{$IFNDEF CLR} +type + TProc = procedure(ASelf: TObject; Filer: TFiler); +{$ELSE} +var + Ancestor: TComponent; + AncestorInfo: Longint; + DesignInfo: Longint; +{$ENDIF} +begin + if (Filer is TReader) or FImagesBitmap.Empty then + inherited + else begin + {$IFNDEF CLR} + { Bypass TCustomImageList.DefineProperties when we've got an ImageBitmap } + TProc(@TComponentAccess.DefineProperties)(Self, Filer); + {$ELSE} + { On .NET I'm not aware of any way to bypass an inherited method, so we + have to handle DefineProperties all by ourself. The following code is + copied from TComponentHelper.DefineProperties, with references to + private fields changed and the Read* methods removed. } + AncestorInfo := 0; + DesignInfo := Self.DesignInfo; + Ancestor := TComponent(Filer.Ancestor); + if Ancestor <> nil then + AncestorInfo := Ancestor.DesignInfo; + Filer.DefineProperty('Left', nil, WriteLeft, (DesignInfo and $FFFF) <> + (AncestorInfo and $FFFF)); + Filer.DefineProperty('Top', nil, WriteTop, (DesignInfo shr 16) <> + (AncestorInfo shr 16)); + {$ENDIF} + end; +end; + +procedure TTBCustomImageList.DrawState(Canvas: TCanvas; X, Y, Index: Integer; + Enabled, Selected, Checked: Boolean); +begin + if not Enabled and Assigned(DisabledImages) then + DisabledImages.Draw(Canvas, X, Y, Index) + else if Checked and Assigned(CheckedImages) then + CheckedImages.Draw(Canvas, X, Y, Index, Enabled) + else if Selected and Assigned(HotImages) then + HotImages.Draw(Canvas, X, Y, Index, Enabled) + else + Draw(Canvas, X, Y, Index, Enabled); +end; + +procedure TTBCustomImageList.Notification(AComponent: TComponent; Operation: TOperation); +begin + inherited; + if Operation = opRemove then begin + if AComponent = CheckedImages then CheckedImages := nil; + if AComponent = DisabledImages then DisabledImages := nil; + if AComponent = HotImages then HotImages := nil; + end; +end; + +procedure TTBCustomImageList.ChangeImages(var AImageList: TCustomImageList; + Value: TCustomImageList; AChangeLink: TChangeLink); +begin + if Value = Self then + Value := nil; + if AImageList <> Value then begin + if Assigned(AImageList) then + AImageList.UnregisterChanges(AChangeLink); + AImageList := Value; + if Assigned(Value) then begin + Value.RegisterChanges(AChangeLink); + Value.FreeNotification(Self); + end; + { Don't call Change while loading because it causes the Delphi IDE to + think the form has been modified (?). Also, don't call Change while + destroying since there's no reason to. } + if not(csLoading in ComponentState) and + not(csDestroying in ComponentState) then + Change; + end; +end; + +procedure TTBCustomImageList.SetCheckedImages(Value: TCustomImageList); +begin + ChangeImages(FCheckedImages, Value, FCheckedImagesChangeLink); +end; + +procedure TTBCustomImageList.SetDisabledImages(Value: TCustomImageList); +begin + ChangeImages(FDisabledImages, Value, FDisabledImagesChangeLink); +end; + +procedure TTBCustomImageList.SetHotImages(Value: TCustomImageList); +begin + ChangeImages(FHotImages, Value, FHotImagesChangeLink); +end; + +procedure TTBCustomImageList.SetImagesBitmap(Value: TBitmap); +begin + FImagesBitmap.Assign(Value); +end; + +procedure TTBCustomImageList.SetImagesBitmapMaskColor(Value: TColor); +begin + if FImagesBitmapMaskColor <> Value then begin + FImagesBitmapMaskColor := Value; + ImagesBitmapChanged(nil); + end; +end; + + +{ TTBBaseAccObject } + +{ According to the MSAA docs: + "With Active Accessibility 2.0, servers can return E_NOTIMPL from IDispatch + methods and Active Accessibility will implement the IAccessible interface + for them." + And there was much rejoicing. } + +{$IFNDEF CLR} +function TTBBaseAccObject.GetIDsOfNames(const IID: TGUID; Names: Pointer; + NameCount, LocaleID: Integer; DispIDs: Pointer): HResult; +begin + Result := E_NOTIMPL; +end; + +function TTBBaseAccObject.GetTypeInfo(Index, LocaleID: Integer; + out TypeInfo): HResult; +begin + Result := E_NOTIMPL; +end; + +function TTBBaseAccObject.GetTypeInfoCount(out Count: Integer): HResult; +begin + Result := E_NOTIMPL; +end; + +function TTBBaseAccObject.Invoke(DispID: Integer; const IID: TGUID; + LocaleID: Integer; Flags: Word; var Params; VarResult, ExcepInfo, + ArgErr: Pointer): HResult; +begin + Result := E_NOTIMPL; +end; +{$ENDIF} + + +{ Initialization & finalization } + +procedure TBInitToolbarSystemFont; +var + NonClientMetrics: TNonClientMetrics; +begin + if GetSystemNonClientMetrics(NonClientMetrics) then + ToolbarFont.Handle := CreateFontIndirect(NonClientMetrics.lfMenuFont); +end; + +initialization + ToolbarFont := TFont.Create; + TBInitToolbarSystemFont; +finalization + DestroyClickWnd; + FreeAndNil(ToolbarFont); +end. diff --git a/internal/2.2.2/1/Source/TB2MDI.pas b/internal/2.2.2/1/Source/TB2MDI.pas new file mode 100644 index 0000000..09ec768 --- /dev/null +++ b/internal/2.2.2/1/Source/TB2MDI.pas @@ -0,0 +1,714 @@ +unit TB2MDI; + +{ + Toolbar2000 + Copyright (C) 1998-2008 by Jordan Russell + All rights reserved. + + The contents of this file are subject to the "Toolbar2000 License"; you may + not use or distribute this file except in compliance with the + "Toolbar2000 License". A copy of the "Toolbar2000 License" may be found in + TB2k-LICENSE.txt or at: + http://www.jrsoftware.org/files/tb2k/TB2k-LICENSE.txt + + Alternatively, the contents of this file may be used under the terms of the + GNU General Public License (the "GPL"), in which case the provisions of the + GPL are applicable instead of those in the "Toolbar2000 License". A copy of + the GPL may be found in GPL-LICENSE.txt or at: + http://www.jrsoftware.org/files/tb2k/GPL-LICENSE.txt + If you wish to allow use of your version of this file only under the terms of + the GPL and not to allow others to use your version of this file under the + "Toolbar2000 License", indicate your decision by deleting the provisions + above and replace them with the notice and other provisions required by the + GPL. If you do not delete the provisions above, a recipient may use your + version of this file under either the "Toolbar2000 License" or the GPL. + + $jrsoftware: tb2k/Source/TB2MDI.pas,v 1.15 2008/04/23 21:54:37 jr Exp $ +} + +interface + +{$I TB2Ver.inc} + +uses + Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs, + Menus, TB2Item, TB2Toolbar; + +type + TTBMDIButtonsItem = class; + TTBMDISystemMenuItem = class; + + TTBMDIHandler = class(TComponent) + private + FButtonsItem: TTBMDIButtonsItem; + FSystemMenuItem: TTBMDISystemMenuItem; + FToolbar: TTBCustomToolbar; + procedure SetToolbar(Value: TTBCustomToolbar); + protected + procedure Notification(AComponent: TComponent; Operation: TOperation); override; + public + constructor Create(AOwner: TComponent); override; + destructor Destroy; override; + published + property Toolbar: TTBCustomToolbar read FToolbar write SetToolbar; + end; + + TTBMDIWindowItem = class(TTBCustomItem) + private + FForm: TForm; + FOnUpdate: TNotifyEvent; + FWindowMenu: TMenuItem; + procedure ItemClick(Sender: TObject); + procedure SetForm(AForm: TForm); + protected + procedure EnabledChanged; override; + procedure GetChildren(Proc: TGetChildProc; Root: TComponent); override; + procedure Notification(AComponent: TComponent; Operation: TOperation); override; + public + constructor Create(AOwner: TComponent); override; + procedure InitiateAction; override; + published + property Enabled; + property OnUpdate: TNotifyEvent read FOnUpdate write FOnUpdate; + end; + + TTBMDISystemMenuItem = class(TTBCustomItem) + private + FImageList: TImageList; + procedure CommandClick(Sender: TObject); + protected + function GetItemViewerClass(AView: TTBView): TTBItemViewerClass; override; + public + constructor Create(AOwner: TComponent); override; + procedure Click; override; + end; + + TTBMDISystemMenuItemViewer = class(TTBItemViewer) + protected + procedure CalcSize(const Canvas: TCanvas; var AWidth, AHeight: Integer); + override; + procedure Paint(const Canvas: TCanvas; const ClientAreaRect: TRect; + IsSelected, IsPushed, UseDisabledShadow: Boolean); override; + end; + + TTBMDIButtonType = (tbmbMinimize, tbmbRestore, tbmbClose); + + TTBMDIButtonItem = class(TTBCustomItem) + private + FButtonType: TTBMDIButtonType; + protected + function GetItemViewerClass(AView: TTBView): TTBItemViewerClass; override; + public + constructor Create(AOwner: TComponent); override; + end; + + TTBMDIButtonItemViewer = class(TTBItemViewer) + protected + procedure CalcSize(const Canvas: TCanvas; var AWidth, AHeight: Integer); + override; + procedure Paint(const Canvas: TCanvas; const ClientAreaRect: TRect; + IsSelected, IsPushed, UseDisabledShadow: Boolean); override; + end; + + TTBMDISepItem = class(TTBSeparatorItem) + protected + function GetItemViewerClass(AView: TTBView): TTBItemViewerClass; override; + end; + + TTBMDISepItemViewer = class(TTBSeparatorItemViewer) + protected + procedure CalcSize(const Canvas: TCanvas; var AWidth, AHeight: Integer); + override; + end; + + TTBMDIButtonsItem = class(TTBCustomItem) + private + FMinimizeItem: TTBMDIButtonItem; + FRestoreItem: TTBMDIButtonItem; + FCloseItem: TTBMDIButtonItem; + FSep1, FSep2: TTBMDISepItem; + procedure InvalidateSystemMenuItem; + procedure ItemClick(Sender: TObject); + procedure UpdateState(W: HWND; Maximized: Boolean); + public + constructor Create(AOwner: TComponent); override; + destructor Destroy; override; + end; + +implementation + +uses + {$IFDEF CLR} System.Text, System.Runtime.InteropServices, WinUtils, {$ENDIF} + TB2Common, TB2Consts, CommCtrl; + +type + TTBCustomToolbarAccess = class(TTBCustomToolbar); + +function GetMenuItemStr(const AMenu: HMENU; const APos: Integer): String; +{$IFNDEF CLR} +var + Buf: array[0..1023] of Char; +begin + if GetMenuString(AMenu, APos, Buf, SizeOf(Buf) div SizeOf(Buf[0]), MF_BYPOSITION) > 0 then + Result := Buf + else + Result := ''; +end; +{$ELSE} +var + Buf: StringBuilder; +begin + Buf := StringBuilder.Create(1024); + if GetMenuString(AMenu, APos, Buf, Buf.Capacity, MF_BYPOSITION) > 0 then + Result := Buf.ToString + else + Result := ''; +end; +{$ENDIF} + + +{ TTBMDIHandler } + +constructor TTBMDIHandler.Create(AOwner: TComponent); +begin + inherited; + FSystemMenuItem := TTBMDISystemMenuItem.Create(Self); + FButtonsItem := TTBMDIButtonsItem.Create(Self); +end; + +destructor TTBMDIHandler.Destroy; +begin + Toolbar := nil; + inherited; +end; + +procedure TTBMDIHandler.Notification(AComponent: TComponent; Operation: TOperation); +begin + inherited; + if (AComponent = FToolbar) and (Operation = opRemove) then + Toolbar := nil; +end; + +procedure TTBMDIHandler.SetToolbar(Value: TTBCustomToolbar); +var + Rebuild: Boolean; +begin + if FToolbar <> Value then begin + if Assigned(FToolbar) then begin + Rebuild := False; + if TTBCustomToolbarAccess(FToolbar).FMDIButtonsItem = FButtonsItem then begin + TTBCustomToolbarAccess(FToolbar).FMDIButtonsItem := nil; + Rebuild := True; + end; + if TTBCustomToolbarAccess(FToolbar).FMDISystemMenuItem = FSystemMenuItem then begin + TTBCustomToolbarAccess(FToolbar).FMDISystemMenuItem := nil; + Rebuild := True; + end; + if Rebuild and Assigned(FToolbar.View) then + FToolbar.View.RecreateAllViewers; + end; + FToolbar := Value; + if Assigned(Value) then begin + Value.FreeNotification(Self); + TTBCustomToolbarAccess(Value).FMDIButtonsItem := FButtonsItem; + TTBCustomToolbarAccess(Value).FMDISystemMenuItem := FSystemMenuItem; + Value.View.RecreateAllViewers; + end; + end; +end; + + +{ TTBMDISystemMenuItem } + +constructor TTBMDISystemMenuItem.Create(AOwner: TComponent); +begin + inherited; + ItemStyle := ItemStyle + [tbisSubMenu, tbisDontSelectFirst] - + [tbisRedrawOnSelChange, tbisRedrawOnMouseOverChange]; + Caption := '&-'; + + {$R TB2MDI.res} + FImageList := TImageList.Create(Self); + FImageList.Handle := ImageList_LoadBitmap(HInstance, 'TB2SYSMENUIMAGES', + 16, 0, clSilver); + SubMenuImages := FImageList; +end; + +function TTBMDISystemMenuItem.GetItemViewerClass(AView: TTBView): TTBItemViewerClass; +begin + Result := TTBMDISystemMenuItemViewer; +end; + +procedure TTBMDISystemMenuItem.Click; +var + I: Integer; + Form: TForm; + M: HMENU; + State: UINT; + ID: Word; + Item: TTBCustomItem; +begin + inherited; + Clear; + if Application.MainForm = nil then + Exit; + Form := Application.MainForm.ActiveMDIChild; + if Form = nil then + Exit; + M := GetSystemMenu(Form.Handle, False); + for I := 0 to GetMenuItemCount(M)-1 do begin + State := GetMenuState(M, I, MF_BYPOSITION); + if State and MF_SEPARATOR <> 0 then + Add(TTBSeparatorItem.Create(Self)) + else begin + Item := TTBCustomItem.Create(Self); + if State and MF_GRAYED <> 0 then + Item.Enabled := False; + Item.Caption := GetMenuItemStr(M, I); + ID := Word(GetMenuItemID(M, I)); + Item.Tag := {$IFDEF CLR}TTag{$ENDIF}(ID); + case ID and $FFF0 of + SC_RESTORE: Item.ImageIndex := 3; + SC_MINIMIZE: Item.ImageIndex := 2; + SC_MAXIMIZE: Item.ImageIndex := 1; + SC_CLOSE: begin + Item.ImageIndex := 0; + Item.Options := Item.Options + [tboDefault]; + end; + end; + Item.OnClick := CommandClick; + Add(Item); + end; + end; +end; + +procedure TTBMDISystemMenuItem.CommandClick(Sender: TObject); +var + Form: TForm; +begin + if Assigned(Application.MainForm) then begin + Form := Application.MainForm.ActiveMDIChild; + if Assigned(Form) then + SendMessage(Form.Handle, WM_SYSCOMMAND, Word(TTBCustomItem(Sender).Tag), + LPARAM(GetMessagePos())); + end; +end; + + +{ TTBMDISystemMenuItemViewer } + +procedure TTBMDISystemMenuItemViewer.CalcSize(const Canvas: TCanvas; + var AWidth, AHeight: Integer); +begin + AWidth := GetSystemMetrics(SM_CXSMICON) + 2; + AHeight := GetSystemMetrics(SM_CYSMICON) + 2; +end; + +procedure TTBMDISystemMenuItemViewer.Paint(const Canvas: TCanvas; + const ClientAreaRect: TRect; IsSelected, IsPushed, UseDisabledShadow: Boolean); + + function GetIconHandle: HICON; + var + Form: TForm; + begin + Result := 0; + if Assigned(Application.MainForm) then begin + Form := Application.MainForm.ActiveMDIChild; + if Assigned(Form) then + Result := Form.Icon.Handle; + end; + if Result = 0 then + Result := Application.Icon.Handle; + if Result = 0 then + Result := LoadIcon(0, IDI_APPLICATION); + end; + +var + R: TRect; + TempIcon: HICON; +begin + R := ClientAreaRect; + InflateRect(R, -1, -1); + TempIcon := CopyImage(GetIconHandle, IMAGE_ICON, R.Right - R.Left, + R.Bottom - R.Top, LR_COPYFROMRESOURCE); + DrawIconEx(Canvas.Handle, R.Left, R.Top, TempIcon, 0, 0, 0, 0, DI_NORMAL); + DestroyIcon(TempIcon); +end; + + +{ TTBMDIButtonItem } + +constructor TTBMDIButtonItem.Create(AOwner: TComponent); +begin + inherited; + ItemStyle := ItemStyle - [tbisSelectable, tbisRedrawOnSelChange] + + [tbisRightAlign]; +end; + +function TTBMDIButtonItem.GetItemViewerClass(AView: TTBView): TTBItemViewerClass; +begin + Result := TTBMDIButtonItemViewer; +end; + + +{ TTBMDIButtonItemViewer } + +procedure TTBMDIButtonItemViewer.CalcSize(const Canvas: TCanvas; + var AWidth, AHeight: Integer); +begin + if NewStyleControls then begin + AWidth := GetSystemMetrics(SM_CXMENUSIZE) - 2; + if AWidth < 0 then AWidth := 0; + AHeight := GetSystemMetrics(SM_CYMENUSIZE) - 4; + if AHeight < 0 then AHeight := 0; + end + else begin + AWidth := 16; + AHeight := 14; + end; +end; + +procedure TTBMDIButtonItemViewer.Paint(const Canvas: TCanvas; + const ClientAreaRect: TRect; IsSelected, IsPushed, UseDisabledShadow: Boolean); +const + ButtonTypeFlags: array[TTBMDIButtonType] of UINT = (DFCS_CAPTIONMIN, + DFCS_CAPTIONRESTORE, DFCS_CAPTIONCLOSE); + PushedFlags: array[Boolean] of UINT = (0, DFCS_PUSHED); + EnabledFlags: array[Boolean] of UINT = (DFCS_INACTIVE, 0); +begin + DrawFrameControl(Canvas.Handle, ClientAreaRect, DFC_CAPTION, + ButtonTypeFlags[TTBMDIButtonItem(Item).FButtonType] or + PushedFlags[IsPushed] or EnabledFlags[Item.Enabled]); +end; + + +{ TTBMDISepItem } + +function TTBMDISepItem.GetItemViewerClass(AView: TTBView): TTBItemViewerClass; +begin + Result := TTBMDISepItemViewer; +end; + + +{ TTBMDISepItemViewer } + +procedure TTBMDISepItemViewer.CalcSize(const Canvas: TCanvas; + var AWidth, AHeight: Integer); +begin + if View.Orientation <> tbvoVertical then begin + AWidth := 2; + AHeight := 6; + end + else begin + AWidth := 6; + AHeight := 2; + end; +end; + + +{ TTBMDIButtonsItem } + +var + CBTHookHandle: HHOOK; + MDIButtonsItems: TList; + +function WindowIsMDIChild(W: HWND): Boolean; +var + I: Integer; + MainForm, ChildForm: TForm; +begin + MainForm := Application.MainForm; + if Assigned(MainForm) then + for I := 0 to MainForm.MDIChildCount-1 do begin + ChildForm := MainForm.MDIChildren[I]; + if ChildForm.HandleAllocated and (ChildForm.Handle = W) then begin + Result := True; + Exit; + end; + end; + Result := False; +end; + +function CBTHook(Code: Integer; WParam: WPARAM; LParam: LPARAM): LRESULT; +{$IFNDEF CLR} stdcall; {$ENDIF} +var + Maximizing: Boolean; + WindowPlacement: TWindowPlacement; + I: Integer; +begin + case Code of + HCBT_SETFOCUS: begin + if WindowIsMDIChild(HWND(WParam)) and Assigned(MDIButtonsItems) then begin + for I := 0 to MDIButtonsItems.Count-1 do + TTBMDIButtonsItem(MDIButtonsItems[I]).InvalidateSystemMenuItem; + end; + end; + HCBT_MINMAX: begin + if WindowIsMDIChild(HWND(WParam)) and Assigned(MDIButtonsItems) and + (Word(LParam) in [SW_SHOWNORMAL, SW_SHOWMAXIMIZED, SW_MINIMIZE, SW_RESTORE]) then begin + Maximizing := (Word(LParam) = SW_MAXIMIZE); + if (Word(LParam) = SW_RESTORE) and not IsZoomed(HWND(WParam)) then begin + {$IFNDEF CLR} + WindowPlacement.length := SizeOf(WindowPlacement); + {$ELSE} + WindowPlacement.length := Marshal.SizeOf(TypeOf(TWindowPlacement)); + {$ENDIF} + GetWindowPlacement(HWND(WParam), {$IFNDEF CLR}@{$ENDIF} WindowPlacement); + Maximizing := (WindowPlacement.flags and WPF_RESTORETOMAXIMIZED <> 0); + end; + for I := 0 to MDIButtonsItems.Count-1 do + TTBMDIButtonsItem(MDIButtonsItems[I]).UpdateState(HWND(WParam), + Maximizing); + end; + end; + HCBT_DESTROYWND: begin + if WindowIsMDIChild(HWND(WParam)) and Assigned(MDIButtonsItems) then begin + for I := 0 to MDIButtonsItems.Count-1 do + TTBMDIButtonsItem(MDIButtonsItems[I]).UpdateState(HWND(WParam), + False); + end; + end; + end; + Result := CallNextHookEx(CBTHookHandle, Code, WParam, LParam); +end; + +const + { Note: On .NET, we must keep a reference to the delegate alive for as long + as the hook is installed, otherwise the GC will collect it and the app + will crash. Storing the delegate in a typed constant will do the trick. } + CBTHookDelegate: TFNHookProc = CBTHook; + +constructor TTBMDIButtonsItem.Create(AOwner: TComponent); + + function CreateItem(const AType: TTBMDIButtonType): TTBMDIButtonItem; + begin + Result := TTBMDIButtonItem.Create(Self); + Result.FButtonType := AType; + Result.OnClick := ItemClick; + end; + +begin + inherited; + ItemStyle := ItemStyle + [tbisEmbeddedGroup]; + FMinimizeItem := CreateItem(tbmbMinimize); + FRestoreItem := CreateItem(tbmbRestore); + FCloseItem := CreateItem(tbmbClose); + FSep1 := TTBMDISepItem.Create(Self); + FSep1.Blank := True; + FSep1.ItemStyle := FSep1.ItemStyle + [tbisRightAlign, tbisNoLineBreak]; + FSep2 := TTBMDISepItem.Create(Self); + FSep2.Blank := True; + FSep2.ItemStyle := FSep2.ItemStyle + [tbisRightAlign, tbisNoLineBreak]; + Add(FSep1); + Add(FMinimizeItem); + Add(FRestoreItem); + Add(FSep2); + Add(FCloseItem); + UpdateState(0, False); + if not(csDesigning in ComponentState) then begin + AddToList(MDIButtonsItems, Self); + if CBTHookHandle = 0 then + CBTHookHandle := SetWindowsHookEx(WH_CBT, CBTHookDelegate, 0, GetCurrentThreadId); + end; +end; + +destructor TTBMDIButtonsItem.Destroy; +begin + RemoveFromList(MDIButtonsItems, Self); + if (MDIButtonsItems = nil) and (CBTHookHandle <> 0) then begin + UnhookWindowsHookEx(CBTHookHandle); + CBTHookHandle := 0; + end; + inherited; +end; + +procedure TTBMDIButtonsItem.UpdateState(W: HWND; Maximized: Boolean); +var + HasMaxChild, VisibilityChanged: Boolean; + + procedure UpdateVisibleEnabled(const Item: TTBCustomItem; + const AEnabled: Boolean); + begin + if (Item.Visible <> HasMaxChild) or (Item.Enabled <> AEnabled) then begin + Item.Visible := HasMaxChild; + Item.Enabled := AEnabled; + VisibilityChanged := True; + end; + end; + +var + MainForm, ActiveMDIChild, ChildForm: TForm; + I: Integer; +begin + HasMaxChild := False; + ActiveMDIChild := nil; + if not(csDesigning in ComponentState) then begin + MainForm := Application.MainForm; + if Assigned(MainForm) then begin + for I := 0 to MainForm.MDIChildCount-1 do begin + ChildForm := MainForm.MDIChildren[I]; + if ChildForm.HandleAllocated and + (((ChildForm.Handle = W) and Maximized) or + ((ChildForm.Handle <> W) and IsZoomed(ChildForm.Handle))) then begin + HasMaxChild := True; + Break; + end; + end; + ActiveMDIChild := MainForm.ActiveMDIChild; + end; + end; + + VisibilityChanged := False; + UpdateVisibleEnabled(TTBMDIHandler(Owner).FSystemMenuItem, True); + UpdateVisibleEnabled(FSep1, True); + UpdateVisibleEnabled(FMinimizeItem, (ActiveMDIChild = nil) or + (GetWindowLong(ActiveMDIChild.Handle, GWL_STYLE) and WS_MINIMIZEBOX <> 0)); + UpdateVisibleEnabled(FRestoreItem, True); + UpdateVisibleEnabled(FSep2, True); + UpdateVisibleEnabled(FCloseItem, True); + + if VisibilityChanged and Assigned((Owner as TTBMDIHandler).FToolbar) then begin + TTBMDIHandler(Owner).FToolbar.View.InvalidatePositions; + TTBMDIHandler(Owner).FToolbar.View.TryValidatePositions; + end; +end; + +procedure TTBMDIButtonsItem.ItemClick(Sender: TObject); +var + MainForm, ChildForm: TForm; + Cmd: WPARAM; +begin + MainForm := Application.MainForm; + if Assigned(MainForm) then begin + ChildForm := MainForm.ActiveMDIChild; + if Assigned(ChildForm) then begin + { Send WM_SYSCOMMAND messages so that we get sounds } + if Sender = FRestoreItem then + Cmd := SC_RESTORE + else if Sender = FCloseItem then + Cmd := SC_CLOSE + else + Cmd := SC_MINIMIZE; + SendMessage(ChildForm.Handle, WM_SYSCOMMAND, Cmd, LPARAM(GetMessagePos())); + end; + end; +end; + +procedure TTBMDIButtonsItem.InvalidateSystemMenuItem; +var + View: TTBView; +begin + if Assigned((Owner as TTBMDIHandler).FToolbar) then begin + View := TTBMDIHandler(Owner).FToolbar.View; + View.Invalidate(View.Find(TTBMDIHandler(Owner).FSystemMenuItem)); + end; +end; + + +{ TTBMDIWindowItem } + +constructor TTBMDIWindowItem.Create(AOwner: TComponent); +var + Form: TForm; +begin + inherited; + ItemStyle := ItemStyle + [tbisEmbeddedGroup]; + Caption := STBMDIWindowItemDefCaption; + FWindowMenu := TMenuItem.Create(Self); + + if not(csDesigning in ComponentState) then begin + { Need to set WindowMenu before MDI children are created. Otherwise the + list incorrectly shows the first 9 child windows, even if window 10+ is + active. } + Form := Application.MainForm; + if (Form = nil) and (Screen.FormCount > 0) then + Form := Screen.Forms[0]; + SetForm(Form); + end; +end; + +procedure TTBMDIWindowItem.GetChildren(Proc: TGetChildProc; Root: TComponent); +begin +end; + +procedure TTBMDIWindowItem.Notification(AComponent: TComponent; Operation: TOperation); +begin + inherited; + if (Operation = opRemove) and (AComponent = FForm) then + SetForm(nil); +end; + +procedure TTBMDIWindowItem.SetForm(AForm: TForm); +begin + if FForm <> AForm then begin + if Assigned(FForm) and (FForm.WindowMenu = FWindowMenu) then + FForm.WindowMenu := nil; + FForm := AForm; + if Assigned(FForm) then + FForm.FreeNotification(Self); + end; + if Assigned(FForm) then + FForm.WindowMenu := FWindowMenu; +end; + +procedure TTBMDIWindowItem.EnabledChanged; +var + I: Integer; +begin + inherited; + for I := 0 to Count-1 do + Items[I].Enabled := Enabled; +end; + +procedure TTBMDIWindowItem.InitiateAction; +var + MainForm: TForm; + I: Integer; + M: HMENU; + Item: TTBCustomItem; + ItemCount: Integer; +begin + inherited; + if csDesigning in ComponentState then + Exit; + MainForm := Application.MainForm; + if Assigned(MainForm) then + SetForm(MainForm); + if FForm = nil then + Exit; + if FForm.ClientHandle <> 0 then + { This is needed, otherwise windows selected on the More Windows dialog + don't move back into the list } + SendMessage(FForm.ClientHandle, WM_MDIREFRESHMENU, 0, 0); + M := FWindowMenu.Handle; + ItemCount := GetMenuItemCount(M) - 1; + if ItemCount < 0 then + ItemCount := 0; + while Count < ItemCount do begin + Item := TTBCustomItem.Create(Self); + Item.Enabled := Enabled; + Item.OnClick := ItemClick; + Add(Item); + end; + while Count > ItemCount do + Items[Count-1].Free; + for I := 0 to ItemCount-1 do begin + Item := Items[I]; + Item.Tag := {$IFDEF CLR}TTag{$ENDIF}(Word(GetMenuItemID(M, I+1))); + Item.Caption := GetMenuItemStr(M, I+1); + Item.Checked := GetMenuState(M, I+1, MF_BYPOSITION) and MF_CHECKED <> 0; + end; + if Assigned(FOnUpdate) then + FOnUpdate(Self); +end; + +procedure TTBMDIWindowItem.ItemClick(Sender: TObject); +var + Form: TForm; +begin + Form := Application.MainForm; + if Assigned(Form) then + PostMessage(Form.Handle, WM_COMMAND, Word(TTBCustomItem(Sender).Tag), 0); +end; + +end. diff --git a/internal/2.2.2/1/Source/TB2MDI.res b/internal/2.2.2/1/Source/TB2MDI.res new file mode 100644 index 0000000..4a62035 Binary files /dev/null and b/internal/2.2.2/1/Source/TB2MDI.res differ diff --git a/internal/2.2.2/1/Source/TB2MRU.pas b/internal/2.2.2/1/Source/TB2MRU.pas new file mode 100644 index 0000000..86f0bca --- /dev/null +++ b/internal/2.2.2/1/Source/TB2MRU.pas @@ -0,0 +1,417 @@ +unit TB2MRU; + +{ + Toolbar2000 + Copyright (C) 1998-2006 by Jordan Russell + All rights reserved. + + The contents of this file are subject to the "Toolbar2000 License"; you may + not use or distribute this file except in compliance with the + "Toolbar2000 License". A copy of the "Toolbar2000 License" may be found in + TB2k-LICENSE.txt or at: + http://www.jrsoftware.org/files/tb2k/TB2k-LICENSE.txt + + Alternatively, the contents of this file may be used under the terms of the + GNU General Public License (the "GPL"), in which case the provisions of the + GPL are applicable instead of those in the "Toolbar2000 License". A copy of + the GPL may be found in GPL-LICENSE.txt or at: + http://www.jrsoftware.org/files/tb2k/GPL-LICENSE.txt + If you wish to allow use of your version of this file only under the terms of + the GPL and not to allow others to use your version of this file under the + "Toolbar2000 License", indicate your decision by deleting the provisions + above and replace them with the notice and other provisions required by the + GPL. If you do not delete the provisions above, a recipient may use your + version of this file under either the "Toolbar2000 License" or the GPL. + + $jrsoftware: tb2k/Source/TB2MRU.pas,v 1.24 2006/03/12 23:11:59 jr Exp $ +} + +interface + +{$I TB2Ver.inc} + +uses + Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs, + TB2Item, IniFiles, Registry; + +type + TTBMRUListClickEvent = procedure(Sender: TObject; const Filename: String) of object; + + TTBMRUList = class(TComponent) + private + FAddFullPath: Boolean; + FContainer: TTBCustomItem; + FHidePathExtension: Boolean; + FList: TStrings; + FMaxItems: Integer; + FOnChange: TNotifyEvent; + FOnClick: TTBMRUListClickEvent; + FPrefix: String; + procedure ClickHandler(Sender: TObject); + procedure SetHidePathExtension(Value: Boolean); + procedure SetList(Value: TStrings); + procedure SetMaxItems(Value: Integer); + protected + property Container: TTBCustomItem read FContainer; + function GetItemClass: TTBCustomItemClass; virtual; + procedure SetItemCaptions; virtual; + public + constructor Create(AOwner: TComponent); override; + destructor Destroy; override; + procedure Add(Filename: String); + procedure Remove(const Filename: String); + procedure LoadFromIni(Ini: TCustomIniFile; const Section: String); + procedure LoadFromRegIni(Ini: TRegIniFile; const Section: String); + procedure SaveToIni(Ini: TCustomIniFile; const Section: String); + procedure SaveToRegIni(Ini: TRegIniFile; const Section: String); + published + { MaxItems must be published before Items } + property AddFullPath: Boolean read FAddFullPath write FAddFullPath default True; + property HidePathExtension: Boolean read FHidePathExtension write SetHidePathExtension default True; + property MaxItems: Integer read FMaxItems write SetMaxItems default 4; + property Items: TStrings read FList write SetList; + property OnClick: TTBMRUListClickEvent read FOnClick write FOnClick; + property OnChange: TNotifyEvent read FOnChange write FOnChange; + property Prefix: String read FPrefix write FPrefix; + end; + + TTBMRUListItem = class(TTBCustomItem) + private + FMRUList: TTBMRUList; + procedure SetMRUList(Value: TTBMRUList); + protected + procedure Notification(AComponent: TComponent; Operation: TOperation); override; + public + constructor Create(AOwner: TComponent); override; + published + property MRUList: TTBMRUList read FMRUList write SetMRUList; + //property Caption; + //property LinkSubitems; + end; + +implementation + +uses + {$IFDEF CLR} System.Text, System.IO, {$ENDIF} + TB2Common, TB2Consts, CommDlg; + +procedure ChangeFileNameToTitle(var S: String); +{$IFNDEF CLR} +var + Buf: array[0..MAX_PATH-1] of Char; +begin + if GetFileTitle(PChar(S), Buf, SizeOf(Buf) div SizeOf(Buf[0])) = 0 then + S := Buf; +end; +{$ELSE} +var + Buf: StringBuilder; +begin + Buf := StringBuilder.Create(MAX_PATH); + if GetFileTitle(S, Buf, Buf.Capacity) = 0 then + S := Buf.ToString; +end; +{$ENDIF} + + +{ TTBMRUListStrings } + +type + TTBMRUListStrings = class(TStrings) + private + FInternalList: TStrings; + FMRUList: TTBMRUList; + procedure Changed; + public + constructor Create; + destructor Destroy; override; + procedure Clear; override; + procedure Delete(Index: Integer); override; + function Get(Index: Integer): String; override; + function GetCount: Integer; override; + function IndexOf(const S: String): Integer; override; + procedure Insert(Index: Integer; const S: String); override; + procedure Move(CurIndex, NewIndex: Integer); override; + procedure Put(Index: Integer; const S: String); override; + end; + +constructor TTBMRUListStrings.Create; +begin + inherited; + FInternalList := TStringList.Create; +end; + +destructor TTBMRUListStrings.Destroy; +begin + inherited; + FInternalList.Free; +end; + +procedure TTBMRUListStrings.Changed; +begin + if Assigned(FMRUList.FOnChange) and + not(csLoading in FMRUList.ComponentState) then + FMRUList.FOnChange(FMRUList); +end; + +procedure TTBMRUListStrings.Clear; +var + I: Integer; +begin + for I := FInternalList.Count-1 downto 0 do + Delete(I); +end; + +procedure TTBMRUListStrings.Delete(Index: Integer); +begin + FMRUList.FContainer[Index].Free; + FInternalList.Delete(Index); + FMRUList.SetItemCaptions; + Changed; +end; + +function TTBMRUListStrings.Get(Index: Integer): String; +begin + Result := FInternalList[Index]; +end; + +function TTBMRUListStrings.GetCount: Integer; +begin + Result := FInternalList.Count; +end; + +function TTBMRUListStrings.IndexOf(const S: String): Integer; +begin + { This is identical to TStrings.IndexOf except we use SameFileName. } + for Result := 0 to GetCount - 1 do + {$IFDEF JR_D6} + if SameFileName(Get(Result), S) then Exit; + {$ELSE} + if AnsiCompareFileName(Get(Result), S) = 0 then Exit; + {$ENDIF} + Result := -1; +end; + +procedure TTBMRUListStrings.Insert(Index: Integer; const S: String); +var + Item: TTBCustomItem; +begin + Item := FMRUList.GetItemClass.Create(FMRUList.FContainer); + Item.OnClick := FMRUList.ClickHandler; + FMRUList.FContainer.Insert(Index, Item); + FInternalList.Insert(Index, S); + FMRUList.SetItemCaptions; + Changed; +end; + +procedure TTBMRUListStrings.Move(CurIndex, NewIndex: Integer); +begin + FInternalList.Move(CurIndex, NewIndex); + FMRUList.FContainer.Move(CurIndex, NewIndex); + FMRUList.SetItemCaptions; + Changed; +end; + +procedure TTBMRUListStrings.Put(Index: Integer; const S: String); +begin + FInternalList[Index] := S; + FMRUList.SetItemCaptions; + Changed; +end; + + +{ TTBMRUList } + +constructor TTBMRUList.Create(AOwner: TComponent); +begin + inherited; + FAddFullPath := True; + FHidePathExtension := True; + FMaxItems := 4; + FPrefix := 'MRU'; + FList := TTBMRUListStrings.Create; + TTBMRUListStrings(FList).FMRUList := Self; + FContainer := TTBCustomItem.Create(nil); +end; + +destructor TTBMRUList.Destroy; +begin + FContainer.Free; + FList.Free; + inherited; +end; + +procedure TTBMRUList.Add(Filename: String); +var + I: Integer; +begin + if AddFullPath then + Filename := ExpandFileName(Filename); + { If Filename is already in the MRU list, move it to the top } + I := FList.IndexOf(Filename); + if I <> -1 then begin + if I > 0 then + FList.Move(I, 0); + FList[0] := Filename; { ...in case the capitalization changed } + end + else + FList.Insert(0, Filename); +end; + +procedure TTBMRUList.Remove(const Filename: String); +var + I: Integer; +begin + I := FList.IndexOf(Filename); + if I <> -1 then + FList.Delete(I); +end; + +procedure TTBMRUList.LoadFromIni(Ini: TCustomIniFile; const Section: String); +var + I: Integer; + S: String; +begin + FList.Clear; + for I := 1 to FMaxItems do begin + S := Ini.ReadString(Section, FPrefix + IntToStr(I), ''); + if S <> '' then + FList.Add(S); + end; +end; + +procedure TTBMRUList.LoadFromRegIni(Ini: TRegIniFile; const Section: String); +var + I: Integer; + S: String; +begin + FList.Clear; + for I := 1 to FMaxItems do begin + S := Ini.ReadString(Section, FPrefix + IntToStr(I), ''); + if S <> '' then + FList.Add(S); + end; +end; + +procedure TTBMRUList.SaveToIni(Ini: TCustomIniFile; const Section: String); +var + I: Integer; +begin + for I := 1 to FMaxItems do begin + if I <= FList.Count then + Ini.WriteString(Section, FPrefix + IntToStr(I), FList[I-1]) + else + Ini.DeleteKey(Section, FPrefix + IntToStr(I)); + end; +end; + +procedure TTBMRUList.SaveToRegIni(Ini: TRegIniFile; const Section: String); +var + I: Integer; +begin + for I := 1 to FMaxItems do begin + if I <= FList.Count then + Ini.WriteString(Section, FPrefix + IntToStr(I), FList[I-1]) + else + Ini.DeleteKey(Section, FPrefix + IntToStr(I)); + end; +end; + +procedure TTBMRUList.SetItemCaptions; +var + I, J: Integer; + Key: Char; + S: String; +begin + while FList.Count > FMaxItems do + FList.Delete(FList.Count-1); + for I := 0 to FContainer.Count-1 do begin + Key := #0; + if I < 9 then + Key := Chr(Ord('1') + I) + else begin + { No more numbers; try letters } + J := I - 9; + if J < 26 then + Key := Chr(Ord('A') + J); + end; + S := FList[I]; + if HidePathExtension then + ChangeFileNameToTitle(S); + S := EscapeAmpersands(S); + if Key <> #0 then + FContainer[I].Caption := Format('&%s %s', [Key, S]) + else + FContainer[I].Caption := S; + end; +end; + +procedure TTBMRUList.ClickHandler(Sender: TObject); +var + I: Integer; +begin + I := FContainer.IndexOf(TTBCustomItem(Sender)); + if I <> -1 then begin + if I > 0 then + FList.Move(I, 0); + if Assigned(FOnClick) then + FOnClick(Self, FList[0]); + end; +end; + +procedure TTBMRUList.SetHidePathExtension(Value: Boolean); +begin + if FHidePathExtension <> Value then begin + FHidePathExtension := Value; + SetItemCaptions; + end; +end; + +procedure TTBMRUList.SetList(Value: TStrings); +begin + FList.Assign(Value); +end; + +procedure TTBMRUList.SetMaxItems(Value: Integer); +begin + FMaxItems := Value; + SetItemCaptions; +end; + +function TTBMRUList.GetItemClass: TTBCustomItemClass; +begin + Result := TTBCustomItem; +end; + + +{ TTBMRUListItem } + +constructor TTBMRUListItem.Create(AOwner: TComponent); +begin + inherited; + ItemStyle := ItemStyle + [tbisEmbeddedGroup]; + Caption := STBMRUListItemDefCaption; +end; + +procedure TTBMRUListItem.Notification(AComponent: TComponent; + Operation: TOperation); +begin + inherited; + if (AComponent = FMRUList) and (Operation = opRemove) then + SetMRUList(nil); +end; + +procedure TTBMRUListItem.SetMRUList(Value: TTBMRUList); +begin + if FMRUList <> Value then begin + FMRUList := Value; + if Assigned(FMRUList) then begin + Value.FreeNotification(Self); + LinkSubitems := FMRUList.FContainer; + end + else + LinkSubitems := nil; + end; +end; + +end. diff --git a/internal/2.2.2/1/Source/TB2OleMarshal.pas b/internal/2.2.2/1/Source/TB2OleMarshal.pas new file mode 100644 index 0000000..fdca5c3 --- /dev/null +++ b/internal/2.2.2/1/Source/TB2OleMarshal.pas @@ -0,0 +1,203 @@ +unit TB2OleMarshal; + +{ + Toolbar2000 + Copyright (C) 1998-2008 by Jordan Russell + All rights reserved. + + The contents of this file are subject to the "Toolbar2000 License"; you may + not use or distribute this file except in compliance with the + "Toolbar2000 License". A copy of the "Toolbar2000 License" may be found in + TB2k-LICENSE.txt or at: + http://www.jrsoftware.org/files/tb2k/TB2k-LICENSE.txt + + Alternatively, the contents of this file may be used under the terms of the + GNU General Public License (the "GPL"), in which case the provisions of the + GPL are applicable instead of those in the "Toolbar2000 License". A copy of + the GPL may be found in GPL-LICENSE.txt or at: + http://www.jrsoftware.org/files/tb2k/GPL-LICENSE.txt + If you wish to allow use of your version of this file only under the terms of + the GPL and not to allow others to use your version of this file under the + "Toolbar2000 License", indicate your decision by deleting the provisions + above and replace them with the notice and other provisions required by the + GPL. If you do not delete the provisions above, a recipient may use your + version of this file under either the "Toolbar2000 License" or the GPL. + + $jrsoftware: tb2k/Source/TB2OleMarshal.pas,v 1.4 2008/09/17 18:04:09 jr Exp $ + + This unit implements the TTBStandardOleMarshalObject class, an exact clone of + .NET Framework 2.0's StandardOleMarshalObject class, which isn't available + on the .NET Framework 1.1-based Delphi 2006. + On Delphi 2007, I had planned to switch to StandardOleMarshalObject, but it + turns out there's a bug that causes it raise AV's on x64 & IA-64 (seen as + E_POINTER on the client side). Coincidentally, TTBStandardOleMarshalObject + does not suffer from this bug (even though it was intended to be an exact + clone!). + + The class "replaces the standard common language runtime (CLR) free-threaded + marshaler with the standard OLE STA marshaler." It "prevents calls made into + a hosting object by OLE from entering threads other than the UI thread." + For more information, see: + http://msdn2.microsoft.com/system.runtime.interopservices.standardolemarshalobject.aspx +} + +interface + +{$I TB2Ver.inc} + +uses + System.Runtime.InteropServices, Windows; + +type + { Our declaration for IMarshal } + [ComImport, + GuidAttribute('00000003-0000-0000-C000-000000000046'), + InterfaceTypeAttribute(ComInterfaceType.InterfaceIsIUnknown)] + ITBMarshal = interface + [PreserveSig] + function GetUnmarshalClass([MarshalAs(UnmanagedType.LPStruct)] riid: Guid; + pv: IntPtr; dwDestContext: Longint; pvDestContext: IntPtr; + mshlflags: Longint; out pCid: Guid): HRESULT; + [PreserveSig] + function GetMarshalSizeMax([MarshalAs(UnmanagedType.LPStruct)] riid: Guid; + pv: IntPtr; dwDestContext: Longint; pvDestContext: IntPtr; + mshlflags: Longint; out pSize: Longint): HRESULT; + [PreserveSig] + function MarshalInterface([in, MarshalAs(UnmanagedType.Interface)] pStm: TObject; + [MarshalAs(UnmanagedType.LPStruct)] riid: Guid; pv: IntPtr; + dwDestContext: Longint; pvDestContext: IntPtr; mshlflags: Longint): HRESULT; + [PreserveSig] + function UnmarshalInterface([in, MarshalAs(UnmanagedType.Interface)] pStm: TObject; + [MarshalAs(UnmanagedType.LPStruct)] riid: Guid; out ppv: IntPtr): HRESULT; + [PreserveSig] + function ReleaseMarshalData([in, MarshalAs(UnmanagedType.Interface)] pStm: TObject): HRESULT; + [PreserveSig] + function DisconnectObject(dwReserved: Longint): HRESULT; + end; + + TTBStandardOleMarshalObject = class(System.MarshalByRefObject, ITBMarshal) + private + function GetStdMarshaller(const riid: Guid; const dwDestContext: Longint; + const mshlflags: Longint): IntPtr; + { IMarshal } + function GetUnmarshalClass(riid: Guid; pv: IntPtr; dwDestContext: Longint; + pvDestContext: IntPtr; mshlflags: Longint; out pCid: Guid): HRESULT; + function GetMarshalSizeMax(riid: Guid; pv: IntPtr; dwDestContext: Longint; + pvDestContext: IntPtr; mshlflags: Longint; out pSize: Longint): HRESULT; + function MarshalInterface(pStm: TObject; riid: Guid; pv: IntPtr; + dwDestContext: Longint; pvDestContext: IntPtr; mshlflags: Longint): HRESULT; + function UnmarshalInterface(pStm: TObject; riid: Guid; out ppv: IntPtr): HRESULT; + function ReleaseMarshalData(pStm: TObject): HRESULT; + function DisconnectObject(dwReserved: Longint): HRESULT; + end; + +implementation + +{ Note: According to http://blogs.msdn.com/cbrumme/archive/2003/04/15/51335.aspx + the Marshal.ReleaseComObject(pStm) calls are needed to work around a "quirk + of OLE32 on some versions of the operating system". } + +uses + System.Security; + +const + ole32 = 'ole32.dll'; + +[SuppressUnmanagedCodeSecurity, DllImport(ole32, CharSet = CharSet.Unicode, EntryPoint = 'CoGetMarshalSizeMax')] +function _CoGetMarshalSizeMax(out pulSize: Longint; + [in, MarshalAs(UnmanagedType.LPStruct)] riid: Guid; pUnk: IntPtr; + dwDestContext: Longint; pvDestContext: IntPtr; + mshlflags: Longint): HRESULT; external; +[SuppressUnmanagedCodeSecurity, DllImport(ole32, CharSet = CharSet.Unicode, EntryPoint = 'CoGetStandardMarshal')] +function _CoGetStandardMarshal([in, MarshalAs(UnmanagedType.LPStruct)] iid: Guid; + pUnk: IntPtr; dwDestContext: Longint; pvDestContext: IntPtr; + mshlflags: Longint; out ppMarshal: IntPtr): HRESULT; external; +[SuppressUnmanagedCodeSecurity, DllImport(ole32, CharSet = CharSet.Unicode, EntryPoint = 'CoMarshalInterface')] +function _CoMarshalInterface([in, MarshalAs(UnmanagedType.Interface)] pStm: TObject; + [in, MarshalAs(UnmanagedType.LPStruct)] riid: Guid; pUnk: IntPtr; + dwDestContext: Longint; pvDestContext: IntPtr; + mshlflags: Longint): HRESULT; external; + +function TTBStandardOleMarshalObject.GetStdMarshaller(const riid: Guid; + const dwDestContext: Longint; const mshlflags: Longint): IntPtr; +var + V_1: IntPtr; +begin + Result := nil; + V_1 := Marshal.GetIUnknownForObject(Self); + if V_1 <> nil then begin + try + if _CoGetStandardMarshal(riid, V_1, dwDestContext, nil, mshlflags, Result) = S_OK then + Exit; + finally + Marshal.Release(V_1); + end; + end; + { Note: Localizing this message isn't necessary because a user will never + see it; the .NET runtime will catch it and translate it into a + COR_E_EXCEPTION HRESULT. } + raise InvalidOperationException.Create('TTBStandardOleMarshalObject.GetStdMarshaller failed'); +end; + +function TTBStandardOleMarshalObject.GetUnmarshalClass(riid: Guid; pv: IntPtr; + dwDestContext: Longint; pvDestContext: IntPtr; mshlflags: Longint; + out pCid: Guid): HRESULT; +begin + { StandardOleMarshalObject does "pCid := TypeOf(IStdMarshal).GUID" here, but + we haven't declared IStdMarshal anywhere, so create a fresh Guid } + pCid := Guid.Create('00000017-0000-0000-C000-000000000046'); { CLSID_StdMarshal } + Result := S_OK; +end; + +function TTBStandardOleMarshalObject.GetMarshalSizeMax(riid: Guid; pv: IntPtr; + dwDestContext: Longint; pvDestContext: IntPtr; mshlflags: Longint; + out pSize: Longint): HRESULT; +var + V_0: IntPtr; +begin + V_0 := GetStdMarshaller(riid, dwDestContext, mshlflags); + try + Result := _CoGetMarshalSizeMax(pSize, riid, V_0, dwDestContext, pvDestContext, mshlflags); + finally + Marshal.Release(V_0); + end; +end; + +function TTBStandardOleMarshalObject.MarshalInterface(pStm: TObject; riid: Guid; + pv: IntPtr; dwDestContext: Longint; pvDestContext: IntPtr; + mshlflags: Longint): HRESULT; +var + V_0: IntPtr; +begin + V_0 := GetStdMarshaller(riid, dwDestContext, mshlflags); + try + Result := _CoMarshalInterface(pStm, riid, V_0, dwDestContext, pvDestContext, mshlflags); + finally + Marshal.Release(V_0); + if pStm <> nil then + Marshal.ReleaseComObject(pStm); + end; +end; + +function TTBStandardOleMarshalObject.UnmarshalInterface(pStm: TObject; + riid: Guid; out ppv: IntPtr): HRESULT; +begin + ppv := nil; + if pStm <> nil then + Marshal.ReleaseComObject(pStm); + Result := E_NOTIMPL; +end; + +function TTBStandardOleMarshalObject.ReleaseMarshalData(pStm: TObject): HRESULT; +begin + if pStm <> nil then + Marshal.ReleaseComObject(pStm); + Result := E_NOTIMPL; +end; + +function TTBStandardOleMarshalObject.DisconnectObject(dwReserved: Longint): HRESULT; +begin + Result := E_NOTIMPL; +end; + +end. diff --git a/internal/2.2.2/1/Source/TB2Reg.dcr b/internal/2.2.2/1/Source/TB2Reg.dcr new file mode 100644 index 0000000..ec4d2e1 Binary files /dev/null and b/internal/2.2.2/1/Source/TB2Reg.dcr differ diff --git a/internal/2.2.2/1/Source/TB2Reg.pas b/internal/2.2.2/1/Source/TB2Reg.pas new file mode 100644 index 0000000..3cacb90 --- /dev/null +++ b/internal/2.2.2/1/Source/TB2Reg.pas @@ -0,0 +1,317 @@ +unit TB2Reg; + +{ + Toolbar2000 + Copyright (C) 1998-2008 by Jordan Russell + All rights reserved. + + The contents of this file are subject to the "Toolbar2000 License"; you may + not use or distribute this file except in compliance with the + "Toolbar2000 License". A copy of the "Toolbar2000 License" may be found in + TB2k-LICENSE.txt or at: + http://www.jrsoftware.org/files/tb2k/TB2k-LICENSE.txt + + Alternatively, the contents of this file may be used under the terms of the + GNU General Public License (the "GPL"), in which case the provisions of the + GPL are applicable instead of those in the "Toolbar2000 License". A copy of + the GPL may be found in GPL-LICENSE.txt or at: + http://www.jrsoftware.org/files/tb2k/GPL-LICENSE.txt + If you wish to allow use of your version of this file only under the terms of + the GPL and not to allow others to use your version of this file under the + "Toolbar2000 License", indicate your decision by deleting the provisions + above and replace them with the notice and other provisions required by the + GPL. If you do not delete the provisions above, a recipient may use your + version of this file under either the "Toolbar2000 License" or the GPL. + + $jrsoftware: tb2k/Source/TB2Reg.pas,v 1.32 2008/09/18 19:08:40 jr Exp $ +} + +interface + +{$I TB2Ver.inc} + +uses + Windows, SysUtils, Classes, Graphics, Controls, Dialogs, ActnList, ImgList, + {$IFDEF JR_D6} DesignIntf, DesignEditors, VCLEditors, {$ELSE} DsgnIntf, {$ENDIF} + TB2Toolbar, TB2ToolWindow, TB2Dock, TB2Item, TB2ExtItems, TB2MRU, TB2MDI, + TB2DsgnItemEditor; + +procedure Register; +procedure TBRegisterClasses(const AClasses: array of TPersistentClass); + +implementation + +{$IFDEF CLR} +{ Delphi.NET doesn't use DCR files for component icons } +{$R 'Icons\TTBBackground.bmp'} +{$R 'Icons\TTBBackground16.bmp'} +{$R 'Icons\TTBDock.bmp'} +{$R 'Icons\TTBDock16.bmp'} +{$R 'Icons\TTBImageList.bmp'} +{$R 'Icons\TTBImageList16.bmp'} +{$R 'Icons\TTBItemContainer.bmp'} +{$R 'Icons\TTBItemContainer16.bmp'} +{$R 'Icons\TTBMDIHandler.bmp'} +{$R 'Icons\TTBMDIHandler16.bmp'} +{$R 'Icons\TTBMRUList.bmp'} +{$R 'Icons\TTBMRUList16.bmp'} +{$R 'Icons\TTBPopupMenu.bmp'} +{$R 'Icons\TTBPopupMenu16.bmp'} +{$R 'Icons\TTBToolbar.bmp'} +{$R 'Icons\TTBToolbar16.bmp'} +{$R 'Icons\TTBToolWindow.bmp'} +{$R 'Icons\TTBToolWindow16.bmp'} +{$ENDIF} + +uses + {$IFDEF CLR} WinUtils, {$ENDIF} + ImgEdit; + +{$IFDEF JR_D5} + +{ TTBImageIndexPropertyEditor } + +{ Unfortunately TComponentImageIndexPropertyEditor seems to be gone in + Delphi 6, so we have to use our own image index property editor class } + +type + TTBImageIndexPropertyEditor = class(TIntegerProperty + {$IFDEF JR_D6} , ICustomPropertyListDrawing {$ENDIF}) + public + function GetAttributes: TPropertyAttributes; override; + procedure GetValues(Proc: TGetStrProc); override; + function GetImageListAt(Index: Integer): TCustomImageList; virtual; + + // ICustomPropertyListDrawing + procedure ListMeasureHeight(const Value: string; ACanvas: TCanvas; + var AHeight: Integer); {$IFNDEF JR_D6} override; {$ENDIF} + procedure ListMeasureWidth(const Value: string; ACanvas: TCanvas; + var AWidth: Integer); {$IFNDEF JR_D6} override; {$ENDIF} + procedure ListDrawValue(const Value: string; ACanvas: TCanvas; + const ARect: TRect; ASelected: Boolean); {$IFNDEF JR_D6} override; {$ENDIF} + end; + +function TTBImageIndexPropertyEditor.GetAttributes: TPropertyAttributes; +begin + Result := [paMultiSelect, paValueList, paRevertable]; +end; + +function TTBImageIndexPropertyEditor.GetImageListAt(Index: Integer): TCustomImageList; +begin + Result := nil; +end; + +procedure TTBImageIndexPropertyEditor.GetValues(Proc: TGetStrProc); +var + ImgList: TCustomImageList; + I: Integer; +begin + ImgList := GetImageListAt(0); + if Assigned(ImgList) then + for I := 0 to ImgList.Count-1 do + Proc(IntToStr(I)); +end; + +procedure TTBImageIndexPropertyEditor.ListDrawValue(const Value: string; + ACanvas: TCanvas; const ARect: TRect; ASelected: Boolean); +var + ImgList: TCustomImageList; + X: Integer; +begin + ImgList := GetImageListAt(0); + ACanvas.FillRect(ARect); + X := ARect.Left + 2; + if Assigned(ImgList) then begin + ImgList.Draw(ACanvas, X, ARect.Top + 2, StrToInt(Value)); + Inc(X, ImgList.Width); + end; + ACanvas.TextOut(X + 3, ARect.Top + 1, Value); +end; + +procedure TTBImageIndexPropertyEditor.ListMeasureHeight(const Value: string; + ACanvas: TCanvas; var AHeight: Integer); +var + ImgList: TCustomImageList; +begin + ImgList := GetImageListAt(0); + AHeight := ACanvas.TextHeight(Value) + 2; + if Assigned(ImgList) and (ImgList.Height + 4 > AHeight) then + AHeight := ImgList.Height + 4; +end; + +procedure TTBImageIndexPropertyEditor.ListMeasureWidth(const Value: string; + ACanvas: TCanvas; var AWidth: Integer); +var + ImgList: TCustomImageList; +begin + ImgList := GetImageListAt(0); + AWidth := ACanvas.TextWidth(Value) + 4; + if Assigned(ImgList) then + Inc(AWidth, ImgList.Width); +end; + +{ TTBItemImageIndexPropertyEditor } + +type + TTBItemImageIndexPropertyEditor = class(TTBImageIndexPropertyEditor) + public + function GetImageListAt(Index: Integer): TCustomImageList; override; + end; + +function TTBItemImageIndexPropertyEditor.GetImageListAt(Index: Integer): TCustomImageList; +var + C: TPersistent; + Item: TTBCustomItem; +begin + Result := nil; + { ? I'm guessing that the Index parameter is a component index (one that + would be passed to the GetComponent function). } + C := GetComponent(Index); + if C is TTBCustomItem then begin + Item := TTBCustomItem(C); + repeat + Result := Item.Images; + if Assigned(Result) then + Break; + Item := Item.Parent; + if Item = nil then + Break; + Result := Item.SubMenuImages; + until Assigned(Result); + end; +end; + +{$ENDIF} + +{ TTBImageListEditor } + +type + TTBImageListEditor = class(TComponentEditor) + public + procedure Edit; override; + procedure ExecuteVerb(Index: Integer); override; + function GetVerb(Index: Integer): String; override; + function GetVerbCount: Integer; override; + end; + +procedure TTBImageListEditor.Edit; +var + ImgList: TTBImageList; +begin + ImgList := Component as TTBImageList; + if not ImgList.ImagesBitmap.Empty then begin + if MessageDlg('The image list''s ImagesBitmap property has ' + + 'a bitmap assigned. Because of this, any changes you make in the ' + + 'Image List Editor will not be preserved when the form is saved.'#13#10#13#10 + + 'Do you want to open the editor anyway?', mtWarning, + [mbYes, mbNo], 0) <> mrYes then + Exit; + end; + EditImageList(ImgList); +end; + +procedure TTBImageListEditor.ExecuteVerb(Index: Integer); +begin + if Index = 0 then + Edit; +end; + +function TTBImageListEditor.GetVerbCount: Integer; +begin + Result := 1; +end; + +function TTBImageListEditor.GetVerb(Index: Integer): String; +begin + if Index = 0 then + Result := 'ImageList Editor...' + else + Result := ''; +end; + + +procedure TBRegisterClasses(const AClasses: array of TPersistentClass); +{$IFDEF CLR} +var + I: Integer; + FoundClass: TPersistentClass; +{$ENDIF} +begin + {$IFDEF CLR} + { Hack for Delphi.NET (2006): If you recompile an already-installed package + the IDE doesn't unload the old package before installing the new one. + Therefore, we must search for and unregister any existing classes before + registering new ones, to avoid having two incompatible sets of classes + registered at the same time. + Without this, if we rebuild tb2kdsgn_dn10 (which implicitly reloads + tb2k_dn10) and then attempt to open the Demo project's main form in the + IDE, we get a "Toolbar item cannot be inserted into container of type + TTBToolbar" exception inside TTBCustomItem.SetParentComponent, because + apparently the TTBToolbar class it's trying to use is located in the new + assembly, while the item class is located in the old assembly. + Note: It appears that this issue only affects registered classes; there + is no need for an "UnRegisterComponents" call. } + for I := High(AClasses) downto Low(AClasses) do begin + { Unregister all classes with the same name } + while True do begin + FoundClass := GetClass(AClasses[I].ClassName); + if FoundClass = nil then + Break; + UnRegisterClass(FoundClass); + end; + end; + {$ENDIF} + RegisterClasses(AClasses); +end; + +procedure Register; +begin + { Note: On Delphi.NET 2006, it's possible for this procedure to be called + a second time on the same tb2kdsgn instance. See comments in + TBRegisterItemClass. } + + RegisterComponents('Toolbar2000', [TTBDock, TTBToolbar, TTBToolWindow, + TTBPopupMenu, TTBImageList, TTBItemContainer, TTBBackground, TTBMRUList, + TTBMDIHandler]); + {$IFDEF JR_D4} + RegisterActions('', [TTBEditAction], nil); + {$ENDIF} + RegisterNoIcon([TTBCustomItem]); + TBRegisterClasses([TTBItem, TTBGroupItem, TTBSubmenuItem, TTBSeparatorItem, + TTBEditItem, TTBMRUListItem, TTBControlItem, TTBMDIWindowItem, + TTBVisibilityToggleItem]); + + RegisterComponentEditor(TTBCustomToolbar, TTBItemsEditor); + RegisterComponentEditor(TTBItemContainer, TTBItemsEditor); + RegisterComponentEditor(TTBPopupMenu, TTBItemsEditor); + RegisterComponentEditor(TTBImageList, TTBImageListEditor); + RegisterPropertyEditor(TypeInfo(TTBRootItem), nil, '', TTBItemsPropertyEditor); + {$IFDEF JR_D5} + RegisterPropertyEditor(TypeInfo(TImageIndex), TTBCustomItem, 'ImageIndex', + TTBItemImageIndexPropertyEditor); + {$ENDIF} + {$IFDEF JR_D6} + { TShortCut properties show up like Integer properties in Delphi 6 + without this... } + RegisterPropertyEditor(TypeInfo(TShortCut), TTBCustomItem, '', + TShortCutProperty); + {$ENDIF} + + { Link in images for the toolbar buttons } + {$IFNDEF CLR} + {$R TB2DsgnItemEditor.res} + {$ELSE} + {$R 'Icons\TB2DsgnEditorImages.bmp'} + {$R 'Icons\TTBEditItem.bmp'} + {$R 'Icons\TTBGroupItem.bmp'} + {$R 'Icons\TTBMDIWindowItem.bmp'} + {$R 'Icons\TTBMRUListItem.bmp'} + {$ENDIF} + TBRegisterItemClass(TTBEditItem, 'New &Edit', HInstance); + TBRegisterItemClass(TTBGroupItem, 'New &Group Item', HInstance); + TBRegisterItemClass(TTBMRUListItem, 'New &MRU List Item', HInstance); + TBRegisterItemClass(TTBMDIWindowItem, 'New MDI &Windows List', HInstance); + TBRegisterItemClass(TTBVisibilityToggleItem, 'New &Visibility-Toggle Item', HInstance); +end; + +end. diff --git a/internal/2.2.2/1/Source/TB2ResCursors.res b/internal/2.2.2/1/Source/TB2ResCursors.res new file mode 100644 index 0000000..e09ab15 Binary files /dev/null and b/internal/2.2.2/1/Source/TB2ResCursors.res differ diff --git a/internal/2.2.2/1/Source/TB2ToolWindow.pas b/internal/2.2.2/1/Source/TB2ToolWindow.pas new file mode 100644 index 0000000..90d5592 --- /dev/null +++ b/internal/2.2.2/1/Source/TB2ToolWindow.pas @@ -0,0 +1,258 @@ +unit TB2ToolWindow; + +{ + Toolbar2000 + Copyright (C) 1998-2005 by Jordan Russell + All rights reserved. + + The contents of this file are subject to the "Toolbar2000 License"; you may + not use or distribute this file except in compliance with the + "Toolbar2000 License". A copy of the "Toolbar2000 License" may be found in + TB2k-LICENSE.txt or at: + http://www.jrsoftware.org/files/tb2k/TB2k-LICENSE.txt + + Alternatively, the contents of this file may be used under the terms of the + GNU General Public License (the "GPL"), in which case the provisions of the + GPL are applicable instead of those in the "Toolbar2000 License". A copy of + the GPL may be found in GPL-LICENSE.txt or at: + http://www.jrsoftware.org/files/tb2k/GPL-LICENSE.txt + If you wish to allow use of your version of this file only under the terms of + the GPL and not to allow others to use your version of this file under the + "Toolbar2000 License", indicate your decision by deleting the provisions + above and replace them with the notice and other provisions required by the + GPL. If you do not delete the provisions above, a recipient may use your + version of this file under either the "Toolbar2000 License" or the GPL. + + $jrsoftware: tb2k/Source/TB2ToolWindow.pas,v 1.18 2005/01/06 03:56:50 jr Exp $ +} + +interface + +{$I TB2Ver.inc} + +uses + Windows, Classes, Graphics, Controls, TB2Dock; + +type + { TTBToolWindow } + + TTBToolWindow = class(TTBCustomDockableWindow) + private + FMinClientWidth, FMinClientHeight, FMaxClientWidth, FMaxClientHeight: Integer; + FBarHeight, FBarWidth: Integer; + function CalcSize(ADock: TTBDock): TPoint; + function GetClientAreaWidth: Integer; + procedure SetClientAreaWidth(Value: Integer); + function GetClientAreaHeight: Integer; + procedure SetClientAreaHeight(Value: Integer); + procedure SetClientAreaSize(AWidth, AHeight: Integer); + protected + function DoArrange(CanMoveControls: Boolean; PreviousDockType: TTBDockType; + NewFloating: Boolean; NewDock: TTBDock): TPoint; override; + procedure GetBaseSize(var ASize: TPoint); override; + procedure GetMinMaxSize(var AMinClientWidth, AMinClientHeight, + AMaxClientWidth, AMaxClientHeight: Integer); override; + procedure Paint; override; + procedure SizeChanging(const AWidth, AHeight: Integer); override; + public + constructor Create(AOwner: TComponent); override; + + procedure ReadPositionData(const Data: TTBReadPositionData); override; + procedure WritePositionData(const Data: TTBWritePositionData); override; + published + property ActivateParent; + property Align; + property Anchors; + property BorderStyle; + property Caption; + property Color; + property CloseButton; + property CloseButtonWhenDocked; + property ClientAreaHeight: Integer read GetClientAreaHeight write SetClientAreaHeight; + property ClientAreaWidth: Integer read GetClientAreaWidth write SetClientAreaWidth; + property CurrentDock; + property DefaultDock; + property DockableTo; + property DockMode; + property DockPos; + property DockRow; + property DragHandleStyle; + property FloatingMode; + property Font; + property FullSize; + property HideWhenInactive; + property LastDock; + property MaxClientHeight: Integer read FMaxClientHeight write FMaxClientHeight default 0; + property MaxClientWidth: Integer read FMaxClientWidth write FMaxClientWidth default 0; + property MinClientHeight: Integer read FMinClientHeight write FMinClientHeight default 32; + property MinClientWidth: Integer read FMinClientWidth write FMinClientWidth default 32; + property ParentFont; + property ParentShowHint; + property PopupMenu; + property Resizable; + property ShowCaption; + property ShowHint; + property Stretch; + property SmoothDrag; + property TabOrder; + property UseLastDock; + {}{property Version;} + property Visible; + + property OnClose; + property OnCloseQuery; + {$IFDEF JR_D5} + property OnContextPopup; + {$ENDIF} + property OnDragDrop; + property OnDragOver; + property OnDockChanged; + property OnDockChanging; + property OnDockChangingHidden; + property OnMouseDown; + property OnMouseMove; + property OnMouseUp; + property OnMove; + property OnRecreated; + property OnRecreating; + property OnResize; + property OnVisibleChanged; + end; + +implementation + +const + { Constants for TTBToolWindow-specific registry values. Do not localize! } + rvClientWidth = 'ClientWidth'; + rvClientHeight = 'ClientHeight'; + + +{ TTBToolWindow } + +constructor TTBToolWindow.Create(AOwner: TComponent); +begin + inherited; + FMinClientWidth := 32; + FMinClientHeight := 32; + { Initialize the client size to 32x32 } + SetBounds(Left, Top, 32, 32); +end; + +procedure TTBToolWindow.Paint; +var + R: TRect; +begin + { Draw dotted border in design mode } + if csDesigning in ComponentState then + with Canvas do begin + R := ClientRect; + Pen.Style := psDot; + Pen.Color := clBtnShadow; + Brush.Style := bsClear; + Rectangle(R.Left, R.Top, R.Right, R.Bottom); + Pen.Style := psSolid; + end; +end; + +procedure TTBToolWindow.ReadPositionData(const Data: TTBReadPositionData); +begin + inherited; + { Restore ClientAreaWidth/ClientAreaHeight variables } + if Resizable then + with Data do + SetClientAreaSize(ReadIntProc(Name, rvClientWidth, FBarWidth, ExtraData), + ReadIntProc(Name, rvClientHeight, FBarHeight, ExtraData)); +end; + +procedure TTBToolWindow.WritePositionData(const Data: TTBWritePositionData); +begin + inherited; + { Write values of FBarWidth/FBarHeight } + with Data do begin + WriteIntProc(Name, rvClientWidth, FBarWidth, ExtraData); + WriteIntProc(Name, rvClientHeight, FBarHeight, ExtraData); + end; +end; + +procedure TTBToolWindow.GetMinMaxSize(var AMinClientWidth, AMinClientHeight, + AMaxClientWidth, AMaxClientHeight: Integer); +begin + AMinClientWidth := FMinClientWidth; + AMinClientHeight := FMinClientHeight; + AMaxClientWidth := FMaxClientWidth; + AMaxClientHeight := FMaxClientHeight; +end; + +procedure TTBToolWindow.SizeChanging(const AWidth, AHeight: Integer); +begin + FBarWidth := AWidth; + if Parent <> nil then Dec(FBarWidth, Width - ClientWidth); + FBarHeight := AHeight; + if Parent <> nil then Dec(FBarHeight, Height - ClientHeight); +end; + +function TTBToolWindow.CalcSize(ADock: TTBDock): TPoint; +begin + Result.X := FBarWidth; + Result.Y := FBarHeight; + if Assigned(ADock) and (FullSize or Stretch) then begin + { If docked and stretching, return the minimum size so that the toolbar + can shrink below FBarWidth/FBarHeight } + if not(ADock.Position in [dpLeft, dpRight]) then + Result.X := FMinClientWidth + else + Result.Y := FMinClientHeight; + end; +end; + +procedure TTBToolWindow.GetBaseSize(var ASize: TPoint); +begin + ASize := CalcSize(CurrentDock); +end; + +function TTBToolWindow.DoArrange(CanMoveControls: Boolean; + PreviousDockType: TTBDockType; NewFloating: Boolean; NewDock: TTBDock): TPoint; +begin + Result := CalcSize(NewDock); +end; + +function TTBToolWindow.GetClientAreaWidth: Integer; +begin + if Parent = nil then + Result := Width + else + Result := ClientWidth; +end; + +procedure TTBToolWindow.SetClientAreaWidth(Value: Integer); +begin + SetClientAreaSize(Value, ClientAreaHeight); +end; + +function TTBToolWindow.GetClientAreaHeight: Integer; +begin + if Parent = nil then + Result := Height + else + Result := ClientHeight; +end; + +procedure TTBToolWindow.SetClientAreaHeight(Value: Integer); +begin + SetClientAreaSize(ClientAreaWidth, Value); +end; + +procedure TTBToolWindow.SetClientAreaSize(AWidth, AHeight: Integer); +var + Client: TRect; +begin + if Parent = nil then + SetBounds(Left, Top, AWidth, AHeight) + else begin + Client := GetClientRect; + SetBounds(Left, Top, Width - Client.Right + AWidth, + Height - Client.Bottom + AHeight); + end; +end; + +end. diff --git a/internal/2.2.2/1/Source/TB2Toolbar.pas b/internal/2.2.2/1/Source/TB2Toolbar.pas new file mode 100644 index 0000000..2264fd5 --- /dev/null +++ b/internal/2.2.2/1/Source/TB2Toolbar.pas @@ -0,0 +1,1794 @@ +unit TB2Toolbar; + +{ + Toolbar2000 + Copyright (C) 1998-2008 by Jordan Russell + All rights reserved. + + The contents of this file are subject to the "Toolbar2000 License"; you may + not use or distribute this file except in compliance with the + "Toolbar2000 License". A copy of the "Toolbar2000 License" may be found in + TB2k-LICENSE.txt or at: + http://www.jrsoftware.org/files/tb2k/TB2k-LICENSE.txt + + Alternatively, the contents of this file may be used under the terms of the + GNU General Public License (the "GPL"), in which case the provisions of the + GPL are applicable instead of those in the "Toolbar2000 License". A copy of + the GPL may be found in GPL-LICENSE.txt or at: + http://www.jrsoftware.org/files/tb2k/GPL-LICENSE.txt + If you wish to allow use of your version of this file only under the terms of + the GPL and not to allow others to use your version of this file under the + "Toolbar2000 License", indicate your decision by deleting the provisions + above and replace them with the notice and other provisions required by the + GPL. If you do not delete the provisions above, a recipient may use your + version of this file under either the "Toolbar2000 License" or the GPL. + + $jrsoftware: tb2k/Source/TB2Toolbar.pas,v 1.126 2008/06/23 18:05:47 jr Exp $ +} + +interface + +{$I TB2Ver.inc} + +uses + {$IFDEF JR_D9} Types, {$ENDIF} + Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, ImgList, + Menus, ActnList, + TB2Item, TB2Dock; + +type + TTBCustomToolbar = class; + TTBChevronItem = class; + TTBChevronItemClass = class of TTBChevronItem; + + TTBToolbarViewClass = class of TTBToolbarView; + TTBToolbarView = class(TTBView) + private + FToolbar: TTBCustomToolbar; + protected + procedure AutoSize(AWidth, AHeight: Integer); override; + procedure DoUpdatePositions(var ASize: TPoint); override; + function GetChevronItem: TTBCustomItem; override; + function GetMDIButtonsItem: TTBCustomItem; override; + function GetMDISystemMenuItem: TTBCustomItem; override; + public + constructor Create(AOwner: TComponent; AParentView: TTBView; + AParentItem: TTBCustomItem; AWindow: TWinControl; + AIsToolbar, ACustomizing, AUsePriorityList: Boolean); override; + function GetFont: TFont; override; + procedure InvalidatePositions; override; + end; + + TTBChevronPriorityForNewItems = (tbcpHighest, tbcpLowest); + + TTBCustomToolbar = class(TTBCustomDockableWindow, ITBItems) + private + FBaseSize: TPoint; + FChevronItem: TTBChevronItem; + FChevronMoveItems: Boolean; + FChevronPriorityForNewItems: TTBChevronPriorityForNewItems; + FDisableAlignArrange: Integer; + FFloatingWidth: Integer; + FIgnoreMouseLeave: Boolean; + FItem: TTBRootItem; + FLastWrappedLines: Integer; + FMenuBar: Boolean; + FOnShortCut: TShortCutEvent; + FProcessShortCuts: Boolean; + FMainWindowHookInstalled: Boolean; + FShrinkMode: TTBShrinkMode; + FSizeData: TObject; + FSystemFont: Boolean; + FUpdateActions: Boolean; + + procedure CancelHover; + function CalcChevronOffset(const ADock: TTBDock; + const AOrientation: TTBViewOrientation): Integer; + function CalcWrapOffset(const ADock: TTBDock): Integer; + function CreateWrapper(Index: Integer; Ctl: TControl): TTBControlItem; + function FindWrapper(Ctl: TControl): TTBControlItem; + function GetChevronHint: String; + function GetImages: TCustomImageList; + function GetItems: TTBCustomItem; + function GetLinkSubitems: TTBCustomItem; + function GetOptions: TTBItemOptions; + procedure InstallMainWindowHook; + function IsChevronHintStored: Boolean; + class function MainWindowHook(var Message: TMessage): Boolean; {$IFDEF CLR} static; {$ENDIF} + procedure SetChevronHint(const Value: String); + procedure SetChevronMoveItems(Value: Boolean); + procedure SetChevronPriorityForNewItems(Value: TTBChevronPriorityForNewItems); + procedure SetFloatingWidth(Value: Integer); + procedure SetImages(Value: TCustomImageList); + procedure SetLinkSubitems(Value: TTBCustomItem); + procedure SetMainWindowHook; + procedure SetMenuBar(Value: Boolean); + procedure SetOptions(Value: TTBItemOptions); + procedure SetProcessShortCuts(Value: Boolean); + procedure SetShrinkMode(Value: TTBShrinkMode); + procedure SetSystemFont(Value: Boolean); + procedure UninstallMainWindowHook; + procedure UpdateViewProperties; + + procedure CMColorChanged(var Message: TMessage); message CM_COLORCHANGED; + {$IFNDEF CLR} + procedure CMControlChange(var Message: TCMControlChange); message CM_CONTROLCHANGE; + procedure CMControlListChange(var Message: TCMControlListChange); message CM_CONTROLLISTCHANGE; + {$ENDIF} + procedure CMFontChanged(var Message: TMessage); message CM_FONTCHANGED; + procedure CMDialogChar(var Message: TCMDialogChar); message CM_DIALOGCHAR; + procedure CMDialogKey(var Message: TCMDialogKey); message CM_DIALOGKEY; + procedure CMHintShow(var Message: TCMHintShow); message CM_HINTSHOW; + procedure CMMouseLeave(var Message: TMessage); message CM_MOUSELEAVE; + procedure CMShowHintChanged(var Message: TMessage); message CM_SHOWHINTCHANGED; + procedure CMWinIniChange(var Message: TWMWinIniChange); message CM_WININICHANGE; + procedure WMCancelMode(var Message: TWMCancelMode); message WM_CANCELMODE; + procedure WMGetObject(var Message: TMessage); message WM_GETOBJECT; + procedure WMMouseLeave(var Message: TMessage); message WM_MOUSELEAVE; + procedure WMNCMouseMove(var Message: TWMNCMouseMove); message WM_NCMOUSEMOVE; + {$IFNDEF JR_D5} + procedure WMRButtonUp(var Message: TWMRButtonUp); message WM_RBUTTONUP; + {$ENDIF} + procedure WMSetCursor(var Message: TWMSetCursor); message WM_SETCURSOR; + procedure WMSysCommand(var Message: TWMSysCommand); message WM_SYSCOMMAND; + protected + FMDIButtonsItem: TTBCustomItem; + FMDISystemMenuItem: TTBCustomItem; + FView: TTBToolbarView; + procedure AlignControls(AControl: TControl; var Rect: TRect); override; + procedure BuildPotentialSizesList(SizesList: TList); dynamic; + {$IFDEF CLR} + procedure ControlChange(Inserting: Boolean; Child: TControl); override; + procedure ControlListChange(Inserting: Boolean; Child: TControl); override; + {$ENDIF} + procedure ControlExistsAtPos(const P: TPoint; var ControlExists: Boolean); + override; + function DoArrange(CanMoveControls: Boolean; PreviousDockType: TTBDockType; + NewFloating: Boolean; NewDock: TTBDock): TPoint; override; + {$IFDEF JR_D5} + procedure DoContextPopup(MousePos: TPoint; var Handled: Boolean); override; + {$ENDIF} + procedure GetBaseSize(var ASize: TPoint); override; + procedure GetMinBarSize(var MinimumSize: TPoint); + procedure GetMinShrinkSize(var AMinimumSize: Integer); override; + function GetShrinkMode: TTBShrinkMode; override; + function GetChevronItemClass: TTBChevronItemClass; dynamic; + function GetItemClass: TTBRootItemClass; dynamic; + function GetViewClass: TTBToolbarViewClass; dynamic; + procedure Loaded; override; + procedure MouseDown(Button: TMouseButton; Shift: TShiftState; + X, Y: Integer); override; + procedure MouseMove(Shift: TShiftState; X, Y: Integer); override; + procedure Paint; override; + procedure ResizeBegin(ASizeHandle: TTBSizeHandle); override; + procedure ResizeTrack(var Rect: TRect; const OrigRect: TRect); override; + procedure ResizeTrackAccept; override; + procedure ResizeEnd; override; + procedure SetChildOrder(Child: TComponent; Order: Integer); override; + + property SystemFont: Boolean read FSystemFont write SetSystemFont default True; + property OnShortCut: TShortCutEvent read FOnShortCut write FOnShortCut; + public + constructor Create(AOwner: TComponent); override; + destructor Destroy; override; + procedure BeginUpdate; + procedure EndUpdate; + procedure CreateWrappersForAllControls; + procedure GetChildren(Proc: TGetChildProc; Root: TComponent); override; + procedure GetTabOrderList(List: TList); override; + procedure InitiateAction; override; + function IsShortCut(var Message: TWMKey): Boolean; + function KeyboardOpen(Key: Char; RequirePrimaryAccel: Boolean): Boolean; + procedure ReadPositionData(const Data: TTBReadPositionData); override; + procedure WritePositionData(const Data: TTBWritePositionData); override; + + property ChevronHint: String read GetChevronHint write SetChevronHint stored IsChevronHintStored; + property ChevronMoveItems: Boolean read FChevronMoveItems write SetChevronMoveItems default True; + property ChevronPriorityForNewItems: TTBChevronPriorityForNewItems read FChevronPriorityForNewItems + write SetChevronPriorityForNewItems default tbcpHighest; + property FloatingWidth: Integer read FFloatingWidth write SetFloatingWidth default 0; + property Images: TCustomImageList read GetImages write SetImages; + property Items: TTBRootItem read FItem; + property LinkSubitems: TTBCustomItem read GetLinkSubitems write SetLinkSubitems; + property Options: TTBItemOptions read GetOptions write SetOptions default []; + property MenuBar: Boolean read FMenuBar write SetMenuBar default False; + property ProcessShortCuts: Boolean read FProcessShortCuts write SetProcessShortCuts default False; + property ShrinkMode: TTBShrinkMode read FShrinkMode write SetShrinkMode default tbsmChevron; + property UpdateActions: Boolean read FUpdateActions write FUpdateActions default True; + property View: TTBToolbarView read FView; + published + property Hint stored False; { Hint is set dynamically; don't save it } + end; + + TTBToolbar = class(TTBCustomToolbar) + published + property ActivateParent; + property Align; + property Anchors; + property AutoResize; + property BorderStyle; + property Caption; + property ChevronHint; + property ChevronMoveItems; + property ChevronPriorityForNewItems; + property CloseButton; + property CloseButtonWhenDocked; + property Color; + property CurrentDock; + property DefaultDock; + property DockableTo; + property DockMode; + property DockPos; + property DockRow; + property DragHandleStyle; + property FloatingMode; + property FloatingWidth; + property Font; + property FullSize; + property HideWhenInactive; + property Images; + property Items; + property LastDock; + property LinkSubitems; + property MenuBar; + property Options; + property ParentFont; + property ParentShowHint; + property PopupMenu; + property ProcessShortCuts; + property Resizable; + property ShowCaption; + property ShowHint; + property ShrinkMode; + property SmoothDrag; + property Stretch; + property SystemFont; + property TabOrder; + property UpdateActions; + property UseLastDock; + property Visible; + + property OnClose; + property OnCloseQuery; + {$IFDEF JR_D5} + property OnContextPopup; + {$ENDIF} + property OnDragDrop; + property OnDragOver; + property OnMouseDown; + property OnMouseMove; + property OnMouseUp; + property OnMove; + property OnRecreated; + property OnRecreating; + property OnDockChanged; + property OnDockChanging; + property OnDockChangingHidden; + property OnResize; + property OnShortCut; + property OnVisibleChanged; + end; + +{ TTBChevronItem & TTBChevronItemViewer } + + TTBChevronItem = class(TTBCustomItem) + private + FToolbar: TTBCustomToolbar; + function GetDefaultHint: String; + protected + function GetChevronParentView: TTBView; override; + function GetItemViewerClass(AView: TTBView): TTBItemViewerClass; override; + public + constructor Create(AOwner: TComponent); override; + end; + + TTBChevronItemViewer = class(TTBItemViewer) + protected + procedure Paint(const Canvas: TCanvas; const ClientAreaRect: TRect; + IsSelected, IsPushed, UseDisabledShadow: Boolean); override; + end; + +const + tbChevronSize = 12; + + +implementation + +uses + {$IFDEF CLR} System.Runtime.InteropServices, System.Text, {$ENDIF} + TB2Consts, TB2Common, TB2Hook; + +const + { Constants for TTBCustomToolbar-specific registry values. Do not localize! } + rvFloatRightX = 'FloatRightX'; + DockTypeToOrientation: array[TTBDockType] of TTBViewOrientation = + (tbvoHorizontal, tbvoFloating, tbvoHorizontal, tbvoVertical); + +type + { Used internally by the TTBCustomToolbar.Resize* methods } + TToolbarSizeData = class + public + SizeHandle: TTBSizeHandle; + NewSizes: TList; { List of valid new sizes. Items are casted into TSmallPoints } + OrigWidth, OrigHeight, NCXDiff: Integer; + CurRightX: Integer; + DisableSensCheck, OpSide: Boolean; + DistanceToSmallerSize, DistanceToLargerSize: Integer; + end; + + +procedure HookProc(Code: THookProcCode; Wnd: HWND; WParam: WPARAM; + LParam: LPARAM); +var + Msg: {$IFNDEF CLR} PMsg {$ELSE} TMsg {$ENDIF}; + MainForm: TForm; +begin + { Work around an annoying Windows or VCL bug. If you close all MDI child + windows, the MDI client window gets the focus, and when it has the focus, + pressing Alt+[char] doesn't send a WM_SYSCOMMAND message to the form for + some reason. It seems silly to have to use a hook for this, but I don't + see a better workaround. + Also, route Alt+- to the main form so that when an MDI child form is + maximized, Alt+- brings up the TB2k MDI system menu instead of the + system's. } + if Code = hpGetMessage then begin + {$IFNDEF CLR} + Msg := PMsg(LParam); + {$ELSE} + Msg := TMsg(Marshal.PtrToStructure(IntPtr(LParam), TypeOf(TMsg))); + {$ENDIF} + if (Msg.message = WM_SYSCHAR) and (Msg.hwnd <> 0) then begin + { Note: On Windows NT/2000/XP, even though we install the hook using + SetWindowsHookExW, Msg.wParam may either be an ANSI character or a + Unicode character, due to an apparent bug on these platforms. It is + an ANSI character when the message passes through a separate + SetWindowsHookExA-installed WH_GETMESSAGE hook first, and that hook + calls us via CallNextHookEx. Windows apparently "forgets" to convert + the character from ANSI back to Unicode in this case. + We can't convert the character code because there seems to be no way + to detect whether it is ANSI or Unicode. So we can't really do much + with Msg.wParam, apart from comparing it against character codes that + are the same between ANSI and Unicode, such as '-'. } + MainForm := Application.MainForm; + if Assigned(MainForm) and MainForm.HandleAllocated and (GetCapture = 0) and + ((Msg.hwnd = MainForm.ClientHandle) or + ((Msg.wParam = Ord('-')) and (MainForm.ClientHandle <> 0) and + IsChild(MainForm.ClientHandle, Msg.hwnd))) then begin + { Redirect the message to the main form. + Note: Unfortunately, due to a bug in Windows NT 4.0 (and not + 2000/XP/9x/Me), modifications to the message don't take effect if + another WH_GETMESSAGE hook has been installed above this one. + (The bug is that CallNextHookEx copies lParam^ to a local buffer, but + does not propogate the changes made by the hook back to lParam^ when + it returns.) I don't know of any clean workaround, other than to + ensure other WH_GETMESSAGE hooks are installed *before* + Toolbar2000's. } + Msg.hwnd := MainForm.Handle; + {$IFDEF CLR} + Marshal.StructureToPtr(TObject(Msg), IntPtr(LParam), False); + {$ENDIF} + end; + end; + end; +end; + +constructor TTBChevronItem.Create(AOwner: TComponent); +begin + inherited; + FToolbar := AOwner as TTBCustomToolbar; + ItemStyle := ItemStyle + [tbisSubMenu, tbisNoAutoOpen]; + Hint := GetDefaultHint; + Caption := EscapeAmpersands(GetShortHint(Hint)); +end; + +function TTBChevronItem.GetChevronParentView: TTBView; +begin + Result := FToolbar.FView; +end; + +function TTBChevronItem.GetDefaultHint: String; +begin + Result := STBChevronItemMoreButtonsHint; +end; + +function TTBChevronItem.GetItemViewerClass(AView: TTBView): TTBItemViewerClass; +begin + Result := TTBChevronItemViewer; +end; + +procedure TTBChevronItemViewer.Paint(const Canvas: TCanvas; + const ClientAreaRect: TRect; IsSelected, IsPushed, UseDisabledShadow: Boolean); +const + HorzPattern: array[0..15] of Byte = + ($CC, 0, $66, 0, $33, 0, $66, 0, $CC, 0, 0, 0, 0, 0, 0, 0); + VertPattern: array[0..15] of Byte = + ($88, 0, $D8, 0, $70, 0, $20, 0, $88, 0, $D8, 0, $70, 0, $20, 0); +var + DC: HDC; + R2: TRect; + TempBmp: TBitmap; + + procedure DrawPattern(const Color, Offset: Integer); + begin + SelectObject(DC, GetSysColorBrush(Color)); + BitBlt(DC, R2.Left, R2.Top + Offset, R2.Right - R2.Left, + R2.Bottom - R2.Top, TempBmp.Canvas.Handle, 0, 0, $00E20746 {ROP_DSPDxax}); + end; + +begin + DC := Canvas.Handle; + R2 := ClientAreaRect; + if Item.Enabled then begin + if IsPushed then + DrawEdge(DC, R2, BDR_SUNKENOUTER, BF_RECT) + else if IsSelected and not(csDesigning in Item.ComponentState) then + DrawEdge(DC, R2, BDR_RAISEDINNER, BF_RECT); + end; + + if View.Orientation <> tbvoVertical then begin + R2.Top := 4; + R2.Bottom := R2.Top + 5; + Inc(R2.Left, 2); + R2.Right := R2.Left + 8; + end + else begin + R2.Left := R2.Right - 9; + R2.Right := R2.Left + 5; + Inc(R2.Top, 2); + R2.Bottom := R2.Top + 8; + end; + if IsPushed then + OffsetRect(R2, 1, 1); + TempBmp := TBitmap.Create; + try + if View.Orientation = tbvoVertical then + TempBmp.Handle := CreateMonoBitmap(8, 8, VertPattern) + else + TempBmp.Handle := CreateMonoBitmap(8, 8, HorzPattern); + SetTextColor(DC, clBlack); + SetBkColor(DC, clWhite); + if Item.Enabled then + DrawPattern(COLOR_BTNTEXT, 0) + else begin + DrawPattern(COLOR_BTNHIGHLIGHT, 1); + DrawPattern(COLOR_BTNSHADOW, 0); + end; + finally + TempBmp.Free; + end; +end; + + +{ TTBToolbarView } + +constructor TTBToolbarView.Create(AOwner: TComponent; AParentView: TTBView; + AParentItem: TTBCustomItem; AWindow: TWinControl; + AIsToolbar, ACustomizing, AUsePriorityList: Boolean); +begin + FToolbar := AOwner as TTBCustomToolbar; + inherited; +end; + +procedure TTBToolbarView.AutoSize(AWidth, AHeight: Integer); +begin + FToolbar.FBaseSize := BaseSize; + if FToolbar.IsAutoResized then + FToolbar.ChangeSize(AWidth, AHeight); +end; + +procedure TTBToolbarView.DoUpdatePositions(var ASize: TPoint); +begin + { Reset CurrentSize because it probably won't be valid after positions + are recalculated [2001-06-24] } + FToolbar.CurrentSize := 0; + FToolbar.GetMinBarSize(ASize); + { On FullSize toolbars, increase ASize.X/Y to WrapOffset so that + right-aligned items always appear at the right edge even when the toolbar + isn't wrapping } + if FToolbar.FullSize then begin + if (Orientation = tbvoHorizontal) and (ASize.X < WrapOffset) then + ASize.X := WrapOffset + else if (Orientation = tbvoVertical) and (ASize.Y < WrapOffset) then + ASize.Y := WrapOffset; + end; + { Increment FDisableAlignArrange so that we don't recursively arrange when + CalculatePositions moves controls } + Inc(FToolbar.FDisableAlignArrange); + try + inherited; + finally + Dec(FToolbar.FDisableAlignArrange); + end; +end; + +procedure TTBToolbarView.InvalidatePositions; +begin + { Reset CurrentSize because it probably won't be valid after positions + are recalculated [2001-06-04] } + FToolbar.CurrentSize := 0; + inherited; +end; + +function TTBToolbarView.GetFont: TFont; +begin + if not FToolbar.SystemFont then + Result := FToolbar.Font + else + Result := inherited GetFont; +end; + +function TTBToolbarView.GetChevronItem: TTBCustomItem; +begin + Result := FToolbar.FChevronItem; +end; + +function TTBToolbarView.GetMDIButtonsItem: TTBCustomItem; +begin + Result := FToolbar.FMDIButtonsItem; +end; + +function TTBToolbarView.GetMDISystemMenuItem: TTBCustomItem; +begin + Result := FToolbar.FMDISystemMenuItem; +end; + + +{ TTBCustomToolbar } + +type + {}TTBCustomItemAccess = class(TTBCustomItem); + TTBItemViewerAccess = class(TTBItemViewer); + +constructor TTBCustomToolbar.Create(AOwner: TComponent); +begin + inherited; + ControlStyle := ControlStyle + [csAcceptsControls, csActionClient] - + [csCaptureMouse]; + DockableWindowStyles := DockableWindowStyles - [tbdsResizeEightCorner, + tbdsResizeClipCursor]; + FItem := GetItemClass.Create(Self); + FItem.ParentComponent := Self; + FChevronItem := GetChevronItemClass.Create(Self); + FChevronItem.LinkSubitems := FItem; + FChevronMoveItems := True; + FView := GetViewClass.Create(Self, nil, FItem, Self, True, False, + not(csDesigning in ComponentState)); + FView.BackgroundColor := clBtnFace; + FUpdateActions := True; + FShrinkMode := tbsmChevron; + FSystemFont := True; + Color := clBtnFace; + SetBounds(Left, Top, 23, 22);{} +end; + +destructor TTBCustomToolbar.Destroy; +begin + { Call Destroying to ensure csDestroying is in ComponentState now. Only + needed for Delphi 4 and earlier since Delphi 5 calls Destroying in + TComponent.BeforeDestruction } + Destroying; + UninstallHookProc(Self, HookProc); + UninstallMainWindowHook; + FreeAndNil(FView); + FreeAndNil(FChevronItem); + FreeAndNil(FItem); + inherited; +end; + +function TTBCustomToolbar.GetItems: TTBCustomItem; +begin + Result := FItem; +end; + +function TTBCustomToolbar.GetItemClass: TTBRootItemClass; +begin + Result := TTBRootItem; +end; + +function TTBCustomToolbar.GetViewClass: TTBToolbarViewClass; +begin + Result := TTBToolbarView; +end; + +function TTBCustomToolbar.GetChevronItemClass: TTBChevronItemClass; +begin + Result := TTBChevronItem; +end; + +procedure TTBCustomToolbar.CreateWrappersForAllControls; +{ Create wrappers for any controls that don't already have them } +var + L: TList; + I, J, C: Integer; +begin + if ControlCount = 0 then + Exit; + L := TList.Create; + try + L.Capacity := ControlCount; + for I := 0 to ControlCount-1 do + L.Add(Controls[I]); + C := FItem.Count-1; + for I := 0 to C do + if FItem[I] is TTBControlItem then begin + J := L.IndexOf(TTBControlItem(FItem[I]).Control); + if J <> -1 then + L[J] := nil; + end; + for I := 0 to L.Count-1 do + if Assigned(L[I]) then + CreateWrapper(FItem.Count, TControl(L[I])); + finally + L.Free; + end; +end; + +procedure TTBCustomToolbar.Loaded; +begin + CreateWrappersForAllControls; + inherited; +end; + +procedure TTBCustomToolbar.GetChildren(Proc: TGetChildProc; Root: TComponent); +begin + TTBCustomItemAccess(TTBCustomItem(FItem)).GetChildren(Proc, Root); + inherited; +end; + +procedure TTBCustomToolbar.SetChildOrder(Child: TComponent; Order: Integer); +begin + if Child is TTBCustomItem then + TTBCustomItemAccess(TTBCustomItem(FItem)).SetChildOrder(Child, Order); +end; + +procedure TTBCustomToolbar.AlignControls(AControl: TControl; var Rect: TRect); +{ VCL calls this whenever any child controls in the toolbar are moved, sized, + inserted, etc., and also when the toolbar is resized. } +begin + if FDisableAlignArrange = 0 then + Arrange; +end; + +procedure TTBCustomToolbar.InitiateAction; +begin + inherited; + {}{ also add this to popupmenu(?) } + { Update visible top-level items } + if FUpdateActions then + FView.InitiateActions; +end; + +procedure TTBCustomToolbar.CMColorChanged(var Message: TMessage); +begin + { Synchronize FView.BackgroundColor with the new color } + if Assigned(FView) then + FView.BackgroundColor := Color; + inherited; +end; + +function TTBCustomToolbar.CreateWrapper(Index: Integer; + Ctl: TControl): TTBControlItem; +var + I: Integer; + S: String; +begin + Result := TTBControlItem.Create(Owner); + Result.Control := Ctl; + if (csDesigning in ComponentState) and Assigned(Owner) then begin + { Needs a name for compatibility with form inheritance } + I := 1; + while True do begin + S := Format('TBControlItem%d', [I]); + if Owner.FindComponent(S) = nil then + Break; + Inc(I); + end; + Result.Name := S; + end; + FItem.Insert(Index, Result); +end; + +function TTBCustomToolbar.FindWrapper(Ctl: TControl): TTBControlItem; +var + I: Integer; + Item: TTBCustomItem; +begin + Result := nil; + for I := 0 to FItem.Count-1 do begin + Item := FItem[I]; + if (Item is TTBControlItem) and + (TTBControlItem(Item).Control = Ctl) then begin + Result := TTBControlItem(Item); + Break; + end; + end; +end; + +{$IFNDEF CLR} +procedure TTBCustomToolbar.CMControlChange(var Message: TCMControlChange); +{$ELSE} +procedure TTBCustomToolbar.ControlChange(Inserting: Boolean; Child: TControl); +{$ENDIF} +{ A CM_CONTROLCHANGE handler must be used instead of a CM_CONTROLLISTCHANGE + handler because when a CM_CONTROLLISTCHANGE message is sent it is relayed to + *all* parents. CM_CONTROLCHANGE messages are only sent to the immediate + parent. } + + procedure HandleControlChange(Inserting: Boolean; Child: TControl); + begin + { Don't automatically create TTBControlItem wrappers if the component + is loading or being updated to reflect changes in an ancestor form, + because wrappers will be streamed in } + if Inserting and not(csLoading in ComponentState) and + not(csUpdating in ComponentState) and + (FindWrapper(Child) = nil) then + CreateWrapper(FItem.Count, Child); + end; + +begin + inherited; + {$IFNDEF CLR} + HandleControlChange(Message.Inserting, Message.Control); + {$ELSE} + HandleControlChange(Inserting, Child); + {$ENDIF} +end; + +{$IFNDEF CLR} +procedure TTBCustomToolbar.CMControlListChange(var Message: TCMControlListChange); +{$ELSE} +procedure TTBCustomToolbar.ControlListChange(Inserting: Boolean; Child: TControl); +{$ENDIF} +{ Don't handle deletions inside CM_CONTROLCHANGE because CM_CONTROLCHANGE is + sent *before* a control begins removing itself from its parent. (It used + to handle both insertions and deletions inside CM_CONTROLCHANGE but this + caused AV's.) } + + procedure HandleControlListChange(Inserting: Boolean; Child: TControl); + var + Item: TTBControlItem; + begin + if not Inserting and Assigned(FItem) then begin + while True do begin + Item := FindWrapper(Child); + if Item = nil then Break; + { The control is being removed the control, not necessarily destroyed, + so set DontFreeControl to True } + Item.DontFreeControl := True; + Item.Free; + end; + end; + end; + +begin + inherited; + {$IFNDEF CLR} + HandleControlListChange(Message.Inserting, Message.Control); + {$ELSE} + HandleControlListChange(Inserting, Child); + {$ENDIF} +end; + +procedure TTBCustomToolbar.CMHintShow(var Message: TCMHintShow); +{ Since the items on a toolbar aren't "real" controls, it needs a CM_HINTSHOW + handler for their hints to be displayed. } +begin + FView.HandleHintShowMessage(Message); +end; + +procedure TTBCustomToolbar.CMShowHintChanged(var Message: TMessage); +begin + inherited; + if ShowHint then + FView.Style := FView.Style + [vsAlwaysShowHints] + else + FView.Style := FView.Style - [vsAlwaysShowHints]; +end; + +procedure TTBCustomToolbar.WMGetObject(var Message: TMessage); +begin + if not FView.HandleWMGetObject(Message) then + inherited; +end; + +procedure TTBCustomToolbar.WMSetCursor(var Message: TWMSetCursor); +var + P: TPoint; + Viewer: TTBItemViewer; + Cursor: HCURSOR; +begin + if not(csDesigning in ComponentState) and + (Message.CursorWnd = WindowHandle) and + (Smallint(Message.HitTest) = HTCLIENT) then begin + { Note: This should not change the selection, because we can receive this + message during a modal loop if a user sets "Screen.Cursor := crDefault" + inside a submenu's OnClick handler (which really isn't recommended, as + it won't necessarily restore the cursor we set originally). } + GetCursorPos(P); + P := ScreenToClient(P); + Viewer := FView.ViewerFromPoint(P); + if Assigned(Viewer) then begin + Cursor := 0; + Dec(P.X, Viewer.BoundsRect.Left); + Dec(P.Y, Viewer.BoundsRect.Top); + TTBItemViewerAccess(Viewer).GetCursor(P, Cursor); + if Cursor <> 0 then begin + SetCursor(Cursor); + Message.Result := 1; + Exit; + end; + end; + end; + inherited; +end; + +procedure TTBCustomToolbar.WMSysCommand(var Message: TWMSysCommand); +var + ConvertedKey: Char; +begin + if FMenuBar and CanFocus then + with Message do + if (CmdType and $FFF0 = SC_KEYMENU) and (Key <> VK_SPACE) and + (GetCapture = 0) then begin + {$IFNDEF CLR} + {$IFDEF JR_WIDESTR} + { Under Unicode Win32 VCL, no conversion required } + WideChar(ConvertedKey) := WideChar(Key); + {$ELSE} + if Win32Platform = VER_PLATFORM_WIN32_NT then begin + { On Windows NT 4/2000/XP, Key is a wide character, so we have to + convert it. Pressing Alt+N in a Russian input locale, for example, + results in a Key value of $0442. + This could perhaps be considered a bug in Windows NT since the + character codes in other messages such as WM_SYSCHAR aren't left + in Unicode form. + The conversion isn't done with the system code page, but rather + with the code page of the currently active input locale, like + Windows does when sending WM_(SYS)CHAR messages. } + if WideCharToMultiByte(GetInputLocaleCodePage, 0, @WideChar(Key), 1, + @AnsiChar(ConvertedKey), 1, nil, nil) <> 1 then + Exit; { shouldn't fail, but if it does, we can't continue } + end + else begin + { On Windows 95/98/Me, Key is not a wide character. } + AnsiChar(ConvertedKey) := AnsiChar(Key); + end; + {$ENDIF} + {$ELSE} + if Marshal.SystemDefaultCharSize = 2 then begin + { Strings are Unicode on .NET, so no need to downconvert to ANSI } + ConvertedKey := WideChar(Key); + end + else begin + { On Windows 98/Me, we have to convert ANSI->Unicode, using the + code page of the currently active input locale } + ConvertedKey := Encoding.GetEncoding(GetInputLocaleCodePage). + GetChars([Byte(Key)])[0]; + end; + {$ENDIF} + if not KeyboardOpen(ConvertedKey, False) then begin + if Key = Ord('-') then Exit; + MessageBeep(0); + end; + Result := 1; + end; +end; + +procedure TTBCustomToolbar.Paint; +var + R: TRect; +begin + { Draw dotted border in design mode on undocked toolbars } + if not Docked and (csDesigning in ComponentState) then + with Canvas do begin + R := ClientRect; + Pen.Style := psDot; + Pen.Color := clBtnShadow; + Brush.Style := bsClear; + Rectangle(R.Left, R.Top, R.Right, R.Bottom); + Pen.Style := psSolid; + end; + FView.DrawSubitems(Canvas); +end; + +procedure TTBCustomToolbar.CMDialogKey(var Message: TCMDialogKey); +begin + if not(csDesigning in ComponentState) and + (Message.CharCode = VK_MENU) and FMenuBar and CanFocus then + FView.SetAccelsVisibility(True); + inherited; +end; + +procedure TTBCustomToolbar.CMDialogChar(var Message: TCMDialogChar); +begin + { On toolbars that aren't menu bars, handle CM_DIALOGCHAR instead of + WM_SYSCOMMAND. + Note: We have to check for csDesigning because on Delphi 2005/2006 we get + CM_DIALOG* messages if Alt+[key] is pressed while a form with a toolbar is + open in the embedded designer, and a tab other than Design is currently + selected (e.g., Code). } + if not(csDesigning in ComponentState) and + not FMenuBar and CanFocus and (Message.CharCode <> 0) then + if KeyboardOpen(Chr(Message.CharCode), True) then begin + Message.Result := 1; + Exit; + end; + inherited; +end; + +procedure TTBCustomToolbar.CancelHover; +begin + if not MouseCapture then + FView.UpdateSelection(Point(Low(Integer), Low(Integer)), True); +end; + +procedure TTBCustomToolbar.CMMouseLeave(var Message: TMessage); +begin + CancelHover; + inherited; +end; + +{$IFDEF JR_D5} +procedure TTBCustomToolbar.DoContextPopup(MousePos: TPoint; + var Handled: Boolean); +begin + CancelHover; + inherited; +end; +{$ENDIF} + +{$IFNDEF JR_D5} +{ Delphi 4 and earlier don't have a DoContextPopup method; we instead have to + trap WM_RBUTTONUP to determine if a popup menu (might) be displayed } +procedure TTBCustomToolbar.WMRButtonUp(var Message: TWMRButtonUp); +begin + CancelHover; + inherited; +end; +{$ENDIF} + +procedure TTBCustomToolbar.MouseMove(Shift: TShiftState; X, Y: Integer); +var + P: TPoint; + Item: TTBCustomItem; +begin + if not(csDesigning in ComponentState) then begin + P := ClientToScreen(Point(X, Y)); + FView.UpdateSelection(P, True); + if Assigned(FView.Selected) then begin + Item := FView.Selected.Item; + if not(tboLongHintInMenuOnly in Item.EffectiveOptions) then + Hint := Item.Hint + else + Hint := ''; + end + else + Hint := ''; + end; + { Call TrackMouseEvent to be sure that we are notified when the mouse leaves + the window. We won't get a CM_MOUSELEAVE message if the mouse moves + directly from the toolbar to another application's window } + CallTrackMouseEvent(Handle, TME_LEAVE); + inherited; +end; + +procedure TTBCustomToolbar.WMCancelMode(var Message: TWMCancelMode); +begin + inherited; + { We can receive a WM_CANCELMODE message during a modal loop if a dialog + pops up. Respond by hiding menus to make it look like the modal loop + has returned, even though it really hasn't yet. + Note: Similar code in TTBModalHandler.WndProc. } + if vsModal in FView.State then + FView.CancelMode; +end; + +procedure TTBCustomToolbar.WMMouseLeave(var Message: TMessage); +begin + { A WM_MOUSELEAVE handler is necessary because the control won't get a + CM_MOUSELEAVE message if the user presses Alt+Space. Also, CM_MOUSELEAVE + messages are also not sent if the application is in a + Application.ProcessMessages loop. } + if not FIgnoreMouseLeave then + CancelHover; + inherited; +end; + +procedure TTBCustomToolbar.WMNCMouseMove(var Message: TWMNCMouseMove); +begin + Hint := ''; + CancelHover; + inherited; +end; + +function TTBCustomToolbar.KeyboardOpen(Key: Char; + RequirePrimaryAccel: Boolean): Boolean; +var + I: TTBItemViewer; + IsOnlyItemWithAccel: Boolean; +begin + Result := False; + { Sanity check: Bail out early if re-entered } + if vsModal in FView.State then + Exit; + I := nil; + FView.SetAccelsVisibility(True); + try + if Key = #0 then begin + I := FView.FirstSelectable; + if I = nil then Exit; + FView.Selected := I; + FView.EnterToolbarLoop([]); + end + else begin + I := FView.NextSelectableWithAccel(nil, Key, RequirePrimaryAccel, + IsOnlyItemWithAccel); + if (I = nil) or not I.Item.Enabled then + Exit; + if IsOnlyItemWithAccel then begin + FView.Selected := I; + FView.EnterToolbarLoop([tbetExecuteSelected]); + end + else if FMenuBar then begin + FView.Selected := I; + FView.EnterToolbarLoop([]); + end + else + Exit; + end; + Result := True; + finally + if Assigned(I) then + FView.SetAccelsVisibility(False); + end; +end; + +procedure TTBCustomToolbar.MouseDown(Button: TMouseButton; Shift: TShiftState; + X, Y: Integer); +var + OldParent: TWinControl; + P: TPoint; + Item: TTBCustomItem; +begin + OldParent := Parent; + inherited; + if Parent <> OldParent then + { if the inherited handler (TTBDockableWindow.MouseDown) changed the Parent + (due to the toolbar moving between docks), nothing else should be done } + Exit; + if not(csDesigning in ComponentState) and (Button = mbLeft) then begin + P := ClientToScreen(Point(X, Y)); + FView.UpdateSelection(P, True); + if Assigned(FView.Selected) then begin + Item := FView.Selected.Item; + if not(tbisClicksTransparent in TTBCustomItemAccess(Item).ItemStyle) then begin + FIgnoreMouseLeave := True; + try + FView.EnterToolbarLoop([tbetMouseDown]); + finally + FIgnoreMouseLeave := False; + end; + end; + end; + end; +end; + +procedure TTBCustomToolbar.CMFontChanged(var Message: TMessage); +begin + inherited; + if not FSystemFont then + Arrange; +end; + +function TTBCustomToolbar.GetChevronHint: String; +begin + Result := FChevronItem.Hint; +end; + +procedure TTBCustomToolbar.SetChevronHint(const Value: String); +begin + FChevronItem.Hint := Value; + FChevronItem.Caption := EscapeAmpersands(GetShortHint(Value)); +end; + +procedure TTBCustomToolbar.SetChevronMoveItems(Value: Boolean); +begin + if FChevronMoveItems <> Value then begin + FChevronMoveItems := Value; + FView.UsePriorityList := Value and not(csDesigning in ComponentState); + end; +end; + +procedure TTBCustomToolbar.SetChevronPriorityForNewItems(Value: TTBChevronPriorityForNewItems); +begin + FChevronPriorityForNewItems := Value; + FView.NewViewersGetHighestPriority := (Value = tbcpHighest); +end; + +function TTBCustomToolbar.IsChevronHintStored: Boolean; +begin + Result := (FChevronItem.Hint <> FChevronItem.GetDefaultHint); +end; + +function TTBCustomToolbar.GetImages: TCustomImageList; +begin + Result := FItem.SubMenuImages; +end; + +procedure TTBCustomToolbar.SetImages(Value: TCustomImageList); +begin + FItem.SubMenuImages := Value; +end; + +function TTBCustomToolbar.GetLinkSubitems: TTBCustomItem; +begin + Result := FItem.LinkSubitems; +end; + +procedure TTBCustomToolbar.SetLinkSubitems(Value: TTBCustomItem); +begin + FItem.LinkSubitems := Value; +end; + +procedure TTBCustomToolbar.SetMenuBar(Value: Boolean); +begin + if FMenuBar <> Value then begin + FMenuBar := Value; + if Value then begin + ControlStyle := ControlStyle + [csMenuEvents]; + FView.Style := FView.Style + [vsMenuBar, vsUseHiddenAccels]; + end + else begin + ControlStyle := ControlStyle - [csMenuEvents]; + FView.Style := FView.Style - [vsMenuBar, vsUseHiddenAccels]; + end; + if not(csLoading in ComponentState) then begin + FullSize := Value; + if Value then + ShrinkMode := tbsmWrap + else + ShrinkMode := tbsmChevron; + CloseButton := not Value; + ProcessShortCuts := Value; + end; + if Value and not(csDesigning in ComponentState) then + InstallHookProc(Self, HookProc, [hpGetMessage]) + else + UninstallHookProc(Self, HookProc); + SetMainWindowHook; + end; +end; + +function TTBCustomToolbar.GetOptions: TTBItemOptions; +begin + Result := FItem.Options; +end; + +procedure TTBCustomToolbar.SetOptions(Value: TTBItemOptions); +begin + FItem.Options := Value; +end; + +procedure TTBCustomToolbar.SetProcessShortCuts(Value: Boolean); +begin + if FProcessShortCuts <> Value then begin + FProcessShortCuts := Value; + SetMainWindowHook; + end; +end; + +procedure TTBCustomToolbar.SetSystemFont(Value: Boolean); +begin + if FSystemFont <> Value then begin + FSystemFont := Value; + Arrange; + end; +end; + +procedure TTBCustomToolbar.SetShrinkMode(Value: TTBShrinkMode); +begin + if FShrinkMode <> Value then begin + FShrinkMode := Value; + if Docked then + CurrentDock.ArrangeToolbars + else if not Floating then + Arrange; + end; +end; + +procedure TTBCustomToolbar.SetFloatingWidth(Value: Integer); +begin + if FFloatingWidth <> Value then begin + FFloatingWidth := Value; + if Floating then begin + UpdateViewProperties; + Arrange; + end; + end; +end; + +function TTBCustomToolbar.CalcWrapOffset(const ADock: TTBDock): Integer; +begin + if ADock = nil then + Result := FFloatingWidth + else begin + if FShrinkMode = tbsmWrap then begin + if not(ADock.Position in [dpLeft, dpRight]) then + Result := ADock.Width - ADock.NonClientWidth - NonClientWidth + else + Result := ADock.Height - ADock.NonClientHeight - NonClientHeight; + end + else + Result := 0; + end; +end; + +function TTBCustomToolbar.CalcChevronOffset(const ADock: TTBDock; + const AOrientation: TTBViewOrientation): Integer; +begin + if (FShrinkMode = tbsmChevron) and Docked and (ADock = CurrentDock) then begin + Result := CurrentSize; + { Subtract non-client size } + if AOrientation <> tbvoVertical then + Dec(Result, NonClientWidth) + else + Dec(Result, NonClientHeight); + if Result < 0 then + Result := 0; { in case CurrentSize wasn't properly initialized yet } + end + else + Result := 0; +end; + +procedure TTBCustomToolbar.UpdateViewProperties; +var + DT: TTBDockType; +begin + DT := TBGetDockTypeOf(CurrentDock, Floating); + FView.Orientation := DockTypeToOrientation[DT]; + FView.ChevronSize := tbChevronSize; + if Assigned(CurrentDock) or Floating then begin + FView.ChevronOffset := CalcChevronOffset(CurrentDock, FView.Orientation); + FView.WrapOffset := CalcWrapOffset(CurrentDock); + end + else begin + FView.ChevronOffset := 0; + FView.WrapOffset := 0; + { Only enable chevron/wrapping when the width of the toolbar is fixed } + if not AutoResize or ((akLeft in Anchors) and (akRight in Anchors)) then begin + if FShrinkMode = tbsmChevron then + FView.ChevronOffset := Width - NonClientWidth + else if FShrinkMode = tbsmWrap then + FView.WrapOffset := Width - NonClientWidth; + end; + end; +end; + +{}{DOCKING STUFF} + +procedure TTBCustomToolbar.ReadPositionData(const Data: TTBReadPositionData); +begin + inherited; + with Data do + FloatingWidth := ReadIntProc(Name, rvFloatRightX, 0, ExtraData); +end; + +procedure TTBCustomToolbar.WritePositionData(const Data: TTBWritePositionData); +begin + inherited; + with Data do + WriteIntProc(Name, rvFloatRightX, FFloatingWidth, ExtraData); +end; + +procedure TTBCustomToolbar.GetMinBarSize(var MinimumSize: TPoint); +var + WH: Integer; +begin + MinimumSize.X := 0; + MinimumSize.Y := 0; + if Docked then begin + WH := CurrentDock.GetMinRowSize(EffectiveDockRow, Self); + if not(CurrentDock.Position in [dpLeft, dpRight]) then + MinimumSize.Y := WH + else + MinimumSize.X := WH; + end; +end; + +procedure TTBCustomToolbar.GetBaseSize(var ASize: TPoint); +begin + FView.ValidatePositions; + ASize := FBaseSize; +end; + +function TTBCustomToolbar.DoArrange(CanMoveControls: Boolean; + PreviousDockType: TTBDockType; NewFloating: Boolean; NewDock: TTBDock): TPoint; +var + DT: TTBDockType; + O: TTBViewOrientation; + TempBaseSize: TPoint; +begin + //outputdebugstring (pchar(format('%s.DoArrange(%d)', [Name, Ord(CanMoveControls)]))); + if CanMoveControls then begin + UpdateViewProperties; + Result := FView.UpdatePositions; + end + else begin + DT := TBGetDockTypeOf(NewDock, NewFloating); + O := DockTypeToOrientation[DT]; + Result.X := 0; + Result.Y := 0; + FView.CalculatePositions(False, O, CalcWrapOffset(NewDock), + CalcChevronOffset(NewDock, O), tbChevronSize, TempBaseSize, Result, + FLastWrappedLines); + end; +end; + +procedure TTBCustomToolbar.ControlExistsAtPos(const P: TPoint; + var ControlExists: Boolean); +var + P2: TPoint; +begin + inherited; + if not ControlExists and not(csDesigning in ComponentState) then begin + P2 := ClientToScreen(P); + FView.UpdateSelection(P2, True); + if Assigned(FView.Selected) and + not(tbisClicksTransparent in TTBCustomItemAccess(FView.Selected.Item).ItemStyle) then + ControlExists := True; + end; +end; + +procedure TTBCustomToolbar.BuildPotentialSizesList(SizesList: TList); +var + Margins: TRect; + MinX, SaveWrapX: Integer; + X, PrevWrappedLines: Integer; + S: TPoint; + S2: TSmallPoint; +begin + View.GetMargins(tbvoFloating, Margins); + MinX := Margins.Left + Margins.Right; + SaveWrapX := FFloatingWidth; + try + { Add the widest size to the list } + FFloatingWidth := 0; + S := DoArrange(False, dtNotDocked, True, nil); + SizesList.Add(TListItemType(PointToSmallPoint(S))); + { Calculate and add rest of sizes to the list } + PrevWrappedLines := 1; + X := S.X-1; + while X >= MinX do begin + FFloatingWidth := X; + S := DoArrange(False, dtNotDocked, True, nil); + if S.X > X then { if it refuses to go any smaller } + Break + else + if X = S.X then begin + S2 := PointToSmallPoint(S); + if FLastWrappedLines <> PrevWrappedLines then + SizesList.Add(TListItemType(S2)) + else + SizesList[SizesList.Count-1] := TListItemType(S2); + PrevWrappedLines := FLastWrappedLines; + Dec(X); + end + else + X := S.X; + end; + finally + FFloatingWidth := SaveWrapX; + end; +end; + +function CompareSizesX(Item1, Item2: TListItemType): Integer; +begin + { Sorts in descending order } + Result := TSmallPoint(Item2).X - TSmallPoint(Item1).X; +end; + +function CompareSizesY(Item1, Item2: TListItemType): Integer; +begin + { Sorts in descending order } + Result := TSmallPoint(Item2).Y - TSmallPoint(Item1).Y; +end; + +procedure TTBCustomToolbar.ResizeBegin(ASizeHandle: TTBSizeHandle); +const + MaxDistance = 12; +var + I, NewSize: Integer; + S, N: TSmallPoint; + P: TPoint; +begin + inherited; + + FSizeData := TToolbarSizeData.Create; + + with TToolbarSizeData(FSizeData) do begin + SizeHandle := ASizeHandle; + OrigWidth := Parent.Width; + OrigHeight := Parent.Height; + NCXDiff := ClientToScreen(Point(0, 0)).X - Parent.Left; + CurRightX := FFloatingWidth; + DisableSensCheck := False; + OpSide := False; + + NewSizes := TList.Create; + BuildPotentialSizesList(NewSizes); + for I := 0 to NewSizes.Count-1 do begin + P := SmallPointToPoint(TSmallPoint(NewSizes[I])); + AddFloatingNCAreaToSize(P); + NewSizes[I] := TListItemType(PointToSmallPoint(P)); + end; + if ASizeHandle in [twshTop, twshBottom] then + NewSizes.Sort(CompareSizesY) + else + NewSizes.Sort(CompareSizesX); + + { Calculate distance in pixels to the nearest potential sizes smaller and + larger than the current size, up to a maximum of MaxDistance pixels. } + DistanceToSmallerSize := 0; + DistanceToLargerSize := 0; + for I := 0 to NewSizes.Count-1 do begin + S := TSmallPoint(NewSizes[I]); + if (S.X = OrigWidth) and (S.Y = OrigHeight) then begin + if I > 0 then begin + N := TSmallPoint(NewSizes[I-1]); + if ASizeHandle in [twshLeft, twshRight] then + NewSize := N.X - S.X + else + NewSize := N.Y - S.Y; + if NewSize > MaxDistance then + NewSize := MaxDistance; + DistanceToLargerSize := NewSize; + end; + if I < NewSizes.Count-1 then begin + N := TSmallPoint(NewSizes[I+1]); + if ASizeHandle in [twshLeft, twshRight] then + NewSize := S.X - N.X + else + NewSize := S.Y - N.Y; + if NewSize > MaxDistance then + NewSize := MaxDistance; + DistanceToSmallerSize := NewSize; + end; + Break; + end; + end; + end; +end; + +procedure TTBCustomToolbar.ResizeTrack(var Rect: TRect; const OrigRect: TRect); +var + Pos: TPoint; + NewOpSide: Boolean; + Reverse: Boolean; + I: Integer; + P: TSmallPoint; +begin + inherited; + + with TToolbarSizeData(FSizeData) do begin + Pos.X := Rect.Right - Rect.Left; + Pos.Y := Rect.Bottom - Rect.Top; + + { Like Office, don't change from the original size until the mouse is moved + a reasonable distance left/up or right/down. Without this, dragging the + mouse just one pixel in either direction would cause the toolbar to + change sizes. } + if SizeHandle in [twshLeft, twshRight] then + NewOpSide := Pos.X < OrigWidth + else + NewOpSide := Pos.Y < OrigHeight; + if (not DisableSensCheck) or (OpSide <> NewOpSide) then begin + DisableSensCheck := False; + OpSide := NewOpSide; + if SizeHandle in [twshLeft, twshRight] then begin + if (Pos.X > OrigWidth-DistanceToSmallerSize) and (Pos.X < OrigWidth+DistanceToLargerSize) then + Pos.X := OrigWidth; + end + else begin + if (Pos.Y > OrigHeight-DistanceToSmallerSize) and (Pos.Y < OrigHeight+DistanceToLargerSize) then + Pos.Y := OrigHeight; + end; + end; + + Rect := OrigRect; + + if SizeHandle in [twshLeft, twshRight] then + Reverse := Pos.X > OrigWidth + else + Reverse := Pos.Y > OrigHeight; + if not Reverse then + I := 0 + else + I := NewSizes.Count-1; + while True do begin + P := TSmallPoint(NewSizes[I]); + if SizeHandle in [twshLeft, twshRight] then begin + if (not Reverse and ((I = NewSizes.Count-1) or (Pos.X >= P.X))) or + (Reverse and ((I = 0) or (Pos.X <= P.X))) then begin + if I = 0 then + CurRightX := 0 + else + CurRightX := P.X - NCXDiff*2; + if SizeHandle = twshRight then + Rect.Right := Rect.Left + P.X + else + Rect.Left := Rect.Right - P.X; + Rect.Bottom := Rect.Top + P.Y; + DisableSensCheck := not EqualRect(Rect, OrigRect); + Break; + end; + end + else begin + if (not Reverse and ((I = NewSizes.Count-1) or (Pos.Y >= P.Y))) or + (Reverse and ((I = 0) or (Pos.Y <= P.Y))) then begin + if I = NewSizes.Count-1 then + CurRightX := 0 + else + CurRightX := P.X - NCXDiff*2; + if SizeHandle = twshBottom then + Rect.Bottom := Rect.Top + P.Y + else + Rect.Top := Rect.Bottom - P.Y; + Rect.Right := Rect.Left + P.X; + DisableSensCheck := not EqualRect(Rect, OrigRect); + Break; + end; + end; + if not Reverse then + Inc(I) + else + Dec(I); + end; + end; +end; + +procedure TTBCustomToolbar.ResizeTrackAccept; +begin + inherited; + FloatingWidth := TToolbarSizeData(FSizeData).CurRightX; +end; + +procedure TTBCustomToolbar.ResizeEnd; +begin + inherited; + if Assigned(FSizeData) then begin + with TToolbarSizeData(FSizeData) do + FreeAndNil(NewSizes); + FreeAndNil(FSizeData); + end; +end; + +function TTBCustomToolbar.GetShrinkMode: TTBShrinkMode; +begin + Result := FShrinkMode; +end; + +procedure TTBCustomToolbar.GetMinShrinkSize(var AMinimumSize: Integer); +var + I: TTBItemViewer; +begin + I := FView.HighestPriorityViewer; + if Assigned(I) then begin + if not(CurrentDock.Position in [dpLeft, dpRight]) then + AMinimumSize := I.BoundsRect.Right - I.BoundsRect.Left + else + AMinimumSize := I.BoundsRect.Bottom - I.BoundsRect.Top; + end; + if not(CurrentDock.Position in [dpLeft, dpRight]) then + Inc(AMinimumSize, NonClientWidth) + else + Inc(AMinimumSize, NonClientHeight); + Inc(AMinimumSize, tbChevronSize); +end; + +procedure TTBCustomToolbar.BeginUpdate; +begin + FView.BeginUpdate; +end; + +procedure TTBCustomToolbar.EndUpdate; +begin + FView.EndUpdate; +end; + +procedure TTBCustomToolbar.GetTabOrderList(List: TList); +var + CtlList: TList; + I, J: Integer; + CtlI, CtlJ: TWinControl; +begin + inherited; + { Remove off-edge items and their children from List } + CtlList := TList.Create; + try + FView.GetOffEdgeControlList(CtlList); + for I := 0 to CtlList.Count-1 do begin + CtlI := TWinControl(CtlList[I]); + J := 0; + while J < List.Count do begin + CtlJ := TWinControl(List[J]); + if (CtlJ = CtlI) or CtlI.ContainsControl(CtlJ) then + List.Delete(J) + else + Inc(J); + end; + end; + finally + CtlList.Free; + end; +end; + +procedure TTBCustomToolbar.CMWinIniChange(var Message: TWMWinIniChange); +begin + inherited; + if {$IFNDEF CLR}TMessage{$ENDIF}(Message).WParam = SPI_SETNONCLIENTMETRICS then begin + TBInitToolbarSystemFont; + Arrange; + end; +end; + +function TTBCustomToolbar.IsShortCut(var Message: TWMKey): Boolean; +begin + Result := False; + if Assigned(FOnShortCut) then + FOnShortCut(Message, Result); + Result := Result or FItem.IsShortCut(Message); +end; + +var + HookCount: Integer; + HookList: TList; + +class function TTBCustomToolbar.MainWindowHook(var Message: TMessage): Boolean; + + function GetActiveForm: TCustomForm; + var + Wnd: HWND; + Ctl: TWinControl; + begin + { Note: We don't use Screen.ActiveCustomForm because when an EXE calls a + DLL that shows a modal form, Screen.ActiveCustomForm doesn't change in + the EXE; it remains set to the last form that was active in the EXE. + Use FindControl(GetActiveWindow) instead to avoid this problem; it will + return nil when a form in another module is active. } + Result := nil; + Wnd := GetActiveWindow; + if Wnd <> 0 then begin + Ctl := FindControl(Wnd); + if Assigned(Ctl) and (Ctl is TCustomForm) then + Result := TCustomForm(Ctl); + end; + end; + + function HandleShortCutOnForm(const Form: TCustomForm): Boolean; + var + I: Integer; + Toolbar: TTBCustomToolbar; + {$IFDEF CLR} + KeyMsg: TWMKey; + {$ENDIF} + begin + Result := False; + if Form = nil then + Exit; + for I := 0 to HookList.Count-1 do begin + Toolbar := TTBCustomToolbar(HookList[I]); + if Toolbar.ProcessShortCuts and + (TBGetToolWindowParentForm(Toolbar) = Form) and + IsWindowEnabled(Form.Handle) then begin + {$IFNDEF CLR} + if Toolbar.IsShortCut(TWMKey(Message)) then begin + {$ELSE} + KeyMsg := TWMKey.Create(Message); + if Toolbar.IsShortCut(KeyMsg) then begin + {$ENDIF} + Message.Result := 1; + Result := True; + Exit; + end; + end; + end; + end; + + function TraverseControls(Container: TWinControl): Boolean; + var + I: Integer; + Control: TControl; + begin + Result := False; + if Container.Showing then + for I := 0 to Container.ControlCount - 1 do begin + Control := Container.Controls[I]; + if Control.Visible and Control.Enabled then begin + if (csMenuEvents in Control.ControlStyle) and + ((Control is TTBDock) or (Control is TTBCustomToolbar)) and + (Control.Perform(WM_SYSCOMMAND, TMessage(Message).WParam, + TMessage(Message).LParam) <> 0) or (Control is TWinControl) and + TraverseControls(TWinControl(Control)) then begin + Result := True; + Exit; + end; + end; + end; + end; + +var + ActiveForm: TCustomForm; + ActiveMDIChild: TForm; +begin + Result := False; + if (Message.Msg = CM_APPKEYDOWN) and Assigned(HookList) then begin + { Process shortcuts on toolbars. Search forms in this order: + 1. If the active form is an MDI parent form, the active MDI child form + if it has the focus. + 2. The active form. + 3. The main form. } + ActiveForm := GetActiveForm; + if Assigned(ActiveForm) and (ActiveForm is TForm) and + (TForm(ActiveForm).FormStyle = fsMDIForm) then begin + ActiveMDIChild := TForm(ActiveForm).ActiveMDIChild; + { Don't search the child form if a control on the MDI parent form is + currently focused (i.e. Screen.ActiveCustomForm <> ActiveMDIChild) } + if Assigned(ActiveMDIChild) and + (Screen.ActiveCustomForm = ActiveMDIChild) and + HandleShortCutOnForm(ActiveMDIChild) then begin + Result := True; + Exit; + end; + end; + if HandleShortCutOnForm(ActiveForm) then + Result := True + else begin + if (Application.MainForm <> ActiveForm) and + HandleShortCutOnForm(Application.MainForm) then + Result := True; + end; + end + else if Message.Msg = CM_APPSYSCOMMAND then begin + { Handle "Alt or Alt+[key] pressed on secondary form" case. If there's a + menu bar on the active form we want the keypress to go to it instead of + to the main form (the VCL's default handling). } + ActiveForm := GetActiveForm; + if Assigned(ActiveForm) and IsWindowEnabled(ActiveForm.Handle) and + IsWindowVisible(ActiveForm.Handle) and TraverseControls(ActiveForm) then begin + Message.Result := 1; + Result := True; + end; + end; +end; + +procedure TTBCustomToolbar.SetMainWindowHook; +begin + if (ProcessShortCuts or MenuBar) and not(csDesigning in ComponentState) then + InstallMainWindowHook + else + UninstallMainWindowHook; +end; + +procedure TTBCustomToolbar.InstallMainWindowHook; +begin + if FMainWindowHookInstalled then + Exit; + if HookCount = 0 then + Application.HookMainWindow(MainWindowHook); + Inc(HookCount); + AddToList(HookList, Self); + FMainWindowHookInstalled := True; +end; + +procedure TTBCustomToolbar.UninstallMainWindowHook; +begin + if not FMainWindowHookInstalled then + Exit; + FMainWindowHookInstalled := False; + RemoveFromList(HookList, Self); + Dec(HookCount); + if HookCount = 0 then + Application.UnhookMainWindow(MainWindowHook); +end; + +end. diff --git a/internal/2.2.2/1/Source/TB2Ver.inc b/internal/2.2.2/1/Source/TB2Ver.inc new file mode 100644 index 0000000..f96696b --- /dev/null +++ b/internal/2.2.2/1/Source/TB2Ver.inc @@ -0,0 +1,64 @@ +{ $jrsoftware: tb2k/Source/TB2Ver.inc,v 1.11 2008/09/13 21:06:45 jr Exp $ } + +{ Determine Delphi/C++Builder version } +{$IFNDEF VER90} { if it's not Delphi 2.0 } + {$IFNDEF VER93} { and it's not C++Builder 1.0 } + {$DEFINE JR_D3} { then it must be at least Delphi 3 or C++Builder 3 } + {$IFNDEF VER100} { if it's not Delphi 3.0 } + {$IFNDEF VER120} { Delphi 4/5's command line compiler doesn't like the ObjExportAll directive, so don't include it on Delphi 4/5 } + {$IFNDEF VER130} + {$ObjExportAll On} { <- needed for compatibility with run-time packages in C++Builder 3+ } + {$ENDIF} + {$ENDIF} + {$IFNDEF VER110} { and it's not C++Builder 3.0 } + {$DEFINE JR_D4} { then it must be at least Delphi 4 or C++Builder 4 } + {$IFNDEF VER120} {$IFNDEF VER125} { if it's not Delphi 4 or C++Builder 4 } + {$DEFINE JR_D5} { then it must be at least Delphi 5 or C++Builder 5 } + {$IFNDEF VER130} { if it's not Delphi 5 or C++Builder 5 } + {$DEFINE JR_D6} { then it must be at least Delphi 6 or C++Builder 6 } + {$IFNDEF VER140} { if it's not Delphi 6 or C++Builder 6 } + {$DEFINE JR_D7} { then it must be at least Delphi 7 } + {$IFNDEF VER150} { if it's not Delphi 7 } + {$DEFINE JR_D8} { then it must be at least Delphi 8 } + {$IFNDEF VER160} { if it's not Delphi 8 } + {$DEFINE JR_D9} { then it must be at least Delphi 9 (2005) } + {$IFNDEF VER170} { if it's not Delphi 9 (2005) } + {$DEFINE JR_D10} { then it must be at least Delphi 10 (2006) } + { Delphi 11 (2007) is an odd case: it defines VER180 and VER185 on Win32, and VER190 on .NET } + {$IFDEF VER185} { if it's Win32 Delphi 11 (2007) exactly } + {$DEFINE JR_D11} { then it must be at least Delphi 11 (2007) } + {$ENDIF} + {$IFNDEF VER180} { if it's neither Delphi 10 (2006) nor Win32 Delphi 11 (2007) } + {$DEFINE JR_D11} { then it must be at least Delphi 11 (2007) } + {$IFNDEF VER190} { if it's not .NET Delphi 11 (2007) } + {$DEFINE JR_D12} { then it must be at least Delphi 12 (2009) } + {$ENDIF} + {$ENDIF} + {$ENDIF} + {$ENDIF} + {$ENDIF} + {$ENDIF} + {$ENDIF} + {$ENDIF} {$ENDIF} + {$ENDIF} + {$ENDIF} + {$ENDIF} +{$ENDIF} + +{$IFDEF JR_D6} + {$IF SizeOf(Char) > 1} + {$DEFINE JR_WIDESTR} { defined if String type = WideString } + {$IFEND} + {$IF not Defined(CLR) and (SizeOf(Pointer) <> 4)} + {$MESSAGE WARN 'This version of Toolbar2000 has not been tested on 64-bit Delphi for Win32'} + {$IFEND} +{$ENDIF} + +{$ALIGN ON} +{$BOOLEVAL OFF} +{$LONGSTRINGS ON} +{$TYPEDADDRESS OFF} +{$WRITEABLECONST ON} +{$IFDEF JR_D6} + {$WARN SYMBOL_PLATFORM OFF} +{$ENDIF} diff --git a/internal/2.2.2/1/Source/TB2Version.pas b/internal/2.2.2/1/Source/TB2Version.pas new file mode 100644 index 0000000..f9fb9c9 --- /dev/null +++ b/internal/2.2.2/1/Source/TB2Version.pas @@ -0,0 +1,63 @@ +unit TB2Version; + +{ + Toolbar2000 + Copyright (C) 1998-2008 by Jordan Russell + All rights reserved. + + The contents of this file are subject to the "Toolbar2000 License"; you may + not use or distribute this file except in compliance with the + "Toolbar2000 License". A copy of the "Toolbar2000 License" may be found in + TB2k-LICENSE.txt or at: + http://www.jrsoftware.org/files/tb2k/TB2k-LICENSE.txt + + Alternatively, the contents of this file may be used under the terms of the + GNU General Public License (the "GPL"), in which case the provisions of the + GPL are applicable instead of those in the "Toolbar2000 License". A copy of + the GPL may be found in GPL-LICENSE.txt or at: + http://www.jrsoftware.org/files/tb2k/GPL-LICENSE.txt + If you wish to allow use of your version of this file only under the terms of + the GPL and not to allow others to use your version of this file under the + "Toolbar2000 License", indicate your decision by deleting the provisions + above and replace them with the notice and other provisions required by the + GPL. If you do not delete the provisions above, a recipient may use your + version of this file under either the "Toolbar2000 License" or the GPL. + + $jrsoftware: tb2k/Source/TB2Version.pas,v 1.69 2008/09/13 21:39:24 jr Exp $ +} + +interface + +{$I TB2Ver.inc} + +const + Toolbar2000Version = '2.2.2'; + Toolbar2000VersionPropText = 'Toolbar2000 version ' + Toolbar2000Version + {$IFDEF CLR} + ' (.NET)' {$ENDIF}; + +type + TToolbar2000Version = type string; + +implementation + +const + Sig: {$IFNDEF CLR} PAnsiChar {$ELSE} AnsiString {$ENDIF} = + '- ' + Toolbar2000VersionPropText + + {$IFDEF VER90} '/D2'+ {$ENDIF} {$IFDEF VER93} '/CB1'+ {$ENDIF} + {$IFDEF VER100} '/D3'+ {$ENDIF} {$IFDEF VER110} '/CB3'+ {$ENDIF} + {$IFDEF VER120} '/D4'+ {$ENDIF} {$IFDEF VER125} '/CB4'+ {$ENDIF} + {$IFNDEF BCB} {$IFDEF VER130} '/D5'+ {$ENDIF} {$ELSE} {$IFDEF VER130} '/CB5'+ {$ENDIF} {$ENDIF} + {$IFNDEF BCB} {$IFDEF VER140} '/D6'+ {$ENDIF} {$ELSE} {$IFDEF VER140} '/CB6'+ {$ENDIF} {$ENDIF} + {$IFNDEF BCB} {$IFDEF VER150} '/D7'+ {$ENDIF} {$ELSE} {$IFDEF VER150} '/CB7'+ {$ENDIF} {$ENDIF} + {$IFNDEF BCB} {$IFDEF VER170} '/D9'+ {$ENDIF} {$ELSE} {$IFDEF VER170} '/CB9'+ {$ENDIF} {$ENDIF} + {$IFNDEF VER185} {$IFNDEF BCB} {$IFDEF VER180} '/D10'+ {$ENDIF} {$ELSE} {$IFDEF VER180} '/CB10'+ {$ENDIF} {$ENDIF} {$ENDIF} + {$IFNDEF BCB} {$IFDEF VER185} '/D11'+ {$ENDIF} {$ELSE} {$IFDEF VER185} '/CB11'+ {$ENDIF} {$ENDIF} + {$IFNDEF BCB} {$IFDEF VER190} '/D11'+ {$ENDIF} {$ELSE} {$IFDEF VER190} '/CB11'+ {$ENDIF} {$ENDIF} + {$IFNDEF BCB} {$IFDEF VER200} '/D12'+ {$ENDIF} {$ELSE} {$IFDEF VER200} '/CB12'+ {$ENDIF} {$ENDIF} + ', Copyright (C) 1998-2008 by Jordan Russell -'; + +{$IFNDEF CLR} +initialization + Sig := Sig; +{$ENDIF} +end. diff --git a/internal/2.2.2/1/TB2k-LICENSE.txt b/internal/2.2.2/1/TB2k-LICENSE.txt new file mode 100644 index 0000000..47984b4 --- /dev/null +++ b/internal/2.2.2/1/TB2k-LICENSE.txt @@ -0,0 +1,61 @@ +Toolbar2000 License v3.2 +======================== + +"Author" herein refers to Jordan Russell (the creator of the Toolbar2000 +components). +"Software" refers to all files bearing this notice, as well as any other +files and source code included with Toolbar2000 (typically extracted from a +.zip archive), and all content in them, regardless of whether any +modifications have been made. + +Except where otherwise noted, all of the documentation and Software included +in the Toolbar2000 package is copyrighted by Jordan Russell (the Author). + +Copyright (C) 1998-2008 Jordan Russell. All rights reserved. + +Use and distribution of the software is permitted provided that all of the +following terms are accepted: + +1. The Software is provided "as-is," without any express or implied + warranty. In no event shall the Author be held liable for any damages + arising from the use of the Software. + +2. All redistributions of the Software's files must be in their original, + unmodified form. Distributions of modified versions of the files is not + permitted without express written permission of the Author. + +3. All redistributions of the Software's files must retain all copyright + notices and web site addresses that are currently in place, and must + include this list of conditions without modification. + +4. None of the Software's files may be redistributed for profit or as part + of another software package without express written permission of the + Author. + +5. You are permitted to Compile the Software into any kind of applications. + ("Compile" here refers to the automatic process of translating the + Software's source code into executable machine code by a compiler such + as the one included with Borland's Delphi or C++Builder.) + However, compilation into commercial or shareware applications, or any + applications that you or your organization are profiting from, requires + registration (payment) of the software. Such payment is made to the Author + of the Software (Jordan Russell). + For information on registering, see the Toolbar2000 documentation or this + web page: + http://www.jrsoftware.org/tb2kreg.php + +6. Redistribution of any of the Software's files in object form (including + but not limited to .DCU and .OBJ formats) is strictly prohibited without + express written permission of the Author. + +7. Full backward compatibility in future versions of the Software is not + guaranteed. In no event shall the Author be held liable for any + inconvenience or damages arising from lack of backward compatibility. + +If you do not agree to all of the above terms, you are not permitted to +use the Software in any way, and all copies of it must be deleted from your +system(s). + +Jordan Russell +jr-2008 AT jrsoftware.org +http://www.jrsoftware.org/ diff --git a/internal/2.2.2/1/tb2k.chm b/internal/2.2.2/1/tb2k.chm new file mode 100644 index 0000000..fb55b18 Binary files /dev/null and b/internal/2.2.2/1/tb2k.chm differ diff --git a/internal/2.2.2/1/whatsnew.htm b/internal/2.2.2/1/whatsnew.htm new file mode 100644 index 0000000..1a15e9d --- /dev/null +++ b/internal/2.2.2/1/whatsnew.htm @@ -0,0 +1,419 @@ + + + +Toolbar2000 Revision History + + + + + + + +
Toolbar2000
Revision History
+ +

Copyright © 1998-2008 Jordan Russell. All rights reserved.
+For conditions of distribution and use, see LICENSE.txt. +

+ +

2.2.2 (2008-09-25)

+
    +
  • Added support for Delphi 2009, C++Builder 2009, and Delphi 2007 on .NET.
    • +
  • Fix: When the Caption of a toolbar item was changed to a new value with the same dimensions as the old value, it didn't enable double-buffering when redrawing the toolbar, resulting in some flicker.
    • +
  • Fix: A MenuBar=False toolbar would inappropriately continue to respond to accelerator keys after Visible or Enabled was changed to False on one of its parents.
    • +
  • Fix: When an Adobe Reader control inside a TWebBrowser was focused, menus would not respond to keystrokes.
    • +
  • Internal tweaks and trivial fixes.
    • +
+ +

2.2.1 (2007-06-23)

+
    +
  • Packages for Delphi 2007 (Win32) are now included. (Currently they are identical to the existing Delphi 2006 packages; only the filenames have changed.)
    • +
  • Menu sounds: On Windows Vista, it now passes the SND_SYSTEM flag when calling PlaySound so that the volume is controlled by the "Windows Sounds" mixer control. Also, on all NT platforms, for consistency with native menus it no longer passes the SND_NOSTOP flag.
    • +
  • TTBEditItem: Published the InheritOptions, MaskOptions, and Options properties.
    • +
  • Improved painting performance on toolbars with hundreds or thousands of visible items.
    • +
  • Fix: Added workaround for bug in Windows Vista's DrawCaption API that caused the title bar text on floating toolbars to be drawn at the wrong coordinates when the Aero Glass theme was selected.
    • +
  • Fix: In version 2.2.0 on Delphi 4 and 5 only, an access violation would occur when the focus left a TTBEditItem. This was due to a code generation bug in the Delphi compiler.
    • +
  • Fix: Eliminated small memory leak when toolbars were dragged between docks on different forms (which, by default, isn't allowed).
    • +
  • Fix: On Windows 95/98/Me, right-clicking a floating toolbar's title bar would not display the toolbar's context menu.
    • +
  • Fix: If Toolbar2000 was built with range checking enabled (by default, this compiler option is disabled), it was possible to receive a range check error when navigating nested submenus with the mouse.
    • +
  • Internal tweaks and trivial fixes.
    • +
+ +

2.2.0 (2006-04-17)

+
    +
  • Toolbar2000 now supports VCL.NET projects on Delphi 2006. The behavior of Toolbar2000 under .NET should be 100% consistent with Win32; no changes are required to existing forms and code.
    +Refer to the Support for .NET topic in the help file for more information.
    • +
  • Added new overloaded versions of the TBIniLoadPositions and TBIniSavePositions functions that take already-instantiated TCustomIniFile's.
    • +
  • On Windows 2000 and later, it now uses Tahoma as the font on vertical toolbars when the system menu font is set to Microsoft Sans Serif. It had previously used Arial, but its Unicode coverage was found to be lacking (which matters on .NET, where strings are Unicode).
    • +
  • Fix: Items on floating MenuBar=False toolbars could not be accessed with Alt+[key].
    • +
  • Numerous internal tweaks and trivial fixes.
    • +
+ +
+ +

2.1.8 (2006-01-09)

+
    +
  • Updated the Delphi 2006 package to support C++Builder 2006 as well, and added installation instructions for C++Builder 2006 to the documentation.
    • +
  • For correctness, changed the "usage" setting on the run-time packages from "Designtime and runtime" to "Runtime only".
    • +
  • Enabled compiler optimization on the C++Builder packages. It was inadvertently disabled before; packages created in C++Builder have Pascal optimization turned off by default, and I didn't notice this until now.
    • +
  • Fix: The TB2Common unit wouldn't compile on Delphi 4.
    • +
+ +

2.1.7 (2005-12-17)

+
    +
  • Packages for Delphi 2006 are now included.
    • +
  • Improved performance of the design-time item editor, and fixed the Delphi 2005 issue where the Object Inspector would go back to the Name property each time a new item was added.
    • +
  • When loading/saving positions, it now silently ignores toolbars with no name (Name='') instead of raising an exception.
    • +
+ +

2.1.6 (2005-07-30)

+
    +
  • The captions of floating toolbars are now grayed when their parent forms are inactive (e.g., when a modal dialog is up).
    • +
  • Replaced various global "var"s with "threadvar"s to improve thread safety when Toolbar2000 is used in a browser-embedded ActiveForm. (Note that this can never be 100% safe because the VCL itself has some thread safety issues.)
    • +
  • Fix: When running on an Athlon 64 CPU with the Cool'n'Quiet feature enabled, menus animated at approximately half the expected speed when the CPU utilization was low. (Previously, it used QueryPerformanceCounter to time the animation, but with Cool'n'Quiet enabled, the rate at which the performance counter increments actually varies depending on the current CPU clock frequency. Now it uses GetTickCount instead.)
    • +
  • Fix: In the Delphi 2005 IDE, toolbar editor forms could fall behind the IDE's main form.
    • +
  • Fix: When an EXE contained a Toolbar2000 menu bar, and a modal Delphi form hosted in a DLL was currently active, pressing Alt would open the menu bar in the EXE even though the form containing the menu bar was disabled/inactive.
    • +
  • Fix: Fixed MSAA bug reported in "Accessibility issue with Window-Eyes" thread on newsgroup 2005-06-21.
    • +
  • Internal tweaks and trivial fixes.
    • +
+ +

2.1.5 (2004-12-13)

+
    +
  • Packages for Delphi 2005 are now included.
    • +
  • Added new RadioItem property to TTBCustomItem and descendants. Like the property of the same name on TMenuItem, it causes the item to display a circle instead of a check mark when the item is checked and no other image has been specified.
    • +
  • Like standard menus, it now prevents other applications from stealing the focus while a menu is open. This should make it fully compatible with Tweak UI's X-Mouse option.
    • +
  • If the application displays a modal dialog of its own while a menu is open, the menu will now be hidden.
    • +
  • TTBCustomDockableWindow and descendants: Made Canvas a public property.
    • +
  • Fix "ImageIndex on toolbutton incorrectly overriden by action's imageindex" issue reported on newsgroup 2004-09-02 by Anthony Egerton.
    +(Note: The problem described in the thread isn't Toolbar2000 specific. Standard menus and controls will continue to exhibit the same problem.)
    • +
  • TMainMenu/TPopupMenu converter: Now additionally transfers the AutoCheck, GroupIndex, and RadioItem properties.
    • +
  • Internal tweaks.
    • +
+ +

2.1.4 (2004-02-28)

+
    +
  • Toolbar2000 may now alternatively, at your option, be used and/or distributed under the terms of the GNU General Public License. Please see the updated LICENSE.txt file for more information on the two licensing options.
    +Note that if you choose the GPL license option, your application as a whole must also be licensed under the GPL. Therefore, you cannot choose the GPL license option if your application is proprietary/closed-source.
    • +
  • Reworded point 5 of the Toolbar2000 License for clarity.
    • +
  • Added new ChevronPriorityForNewItems property to TTBToolbar.
    • +
+ +

2.1.3 (2003-11-23)

+
    +
  • Added new tboNoAutoHint value to the Options property. When set, the automatic hint generation feature (introduced in 2.1.1) will be disabled.
    • +
  • On Windows NT/2000/XP, use SetWindowsHookExW instead of SetWindowsHookEx to work around apparent OS bug reported on the newsgroup by George Kyrou 2003-09-23.
    • +
  • Tweak to HookProc in TB2Toolbar.pas to avoid ANSI/Unicode character set issue with hooks on Windows NT/2000/XP.
    • +
  • Fix: When a TTBEditItem was focused, it didn't inherit the font settings from the parent toolbar.
    • +
+ +

2.1.2 (2003-08-10)

+
    +
  • It's now possible to nest "group" items such as TTBGroupItem. Previously, placing one group item inside another did not work.
    • +
  • Tweaked the automatic hint generation introduced in the last version: It now will not generate hints for submenu items unless the submenu item has the DropdownCombo property set to True or the submenu item has no visible caption.
    • +
  • TTBControlItem is no longer explicitly registered. There is a slim chance that this change may affect you if your application initially used one of the very early Toolbar2000 betas. In those early betas, Toolbar2000 did not assign to the Name property of TTBControlItem components it created. If you have unnamed TTBControlItem components on your forms, you must now assign them names, otherwise you might receive a "class not found" error message when running your application.
    • +
  • Fix: TTBEditItem would lose the focus when Alt+[keypad digit] was pressed.
    • +
  • Internal tweaks.
    • +
+ +

2.1.1-beta (2003-07-13)

+
    +
  • Now automatically supplies short hints for items with no short hint assigned to the Hint property. The hint is derived from the item's caption, with accelerator keys and any trailing colon or ellipsis stripped.
    • +
  • Shortcut text is now displayed in the hints of items that don't have associated Actions.
    • +
  • Fix: In TTBMRUList, "&" characters in filenames weren't escaped when assigning item captions.
    • +
  • MSAA-related tweaks: +
      +
    • Escape any "&" characters when assigning text to chevron item's Caption property.
      • +
    • Work around bug in Delphi/C++Builder 4's ShortCutToText function.
      • +
    +
    • +
  • Internal tweaks.
    • +
+ +

2.1.0-beta (2003-07-05)

+
    +
  • Microsoft Active Accessibility support for Toolbar2000's menus and toolbars. This exclusive feature will make your application's user interface more accessible to users who rely on screen readers. For more details, see the MSAA Support topic in the help file.
    • +
  • When new items are inserted programmatically at run-time, they are now placed at the top of the "priority list" instead of at the bottom. This means that new items will now be the last to move onto the chevron menu when all items can't fit on the toolbar.
    • +
  • On popup menus, accelerator keys are now properly hidden if the last input came from the mouse.
    • +
  • On TTBMDIButtonsItem, the biMinimize setting of BorderIcons on MDI child forms is now respected.
    • +
  • As a performance optimization, the default image base of the Delphi design and run-time packages have been changed from $400000 to $3F800000 and $3FC00000 respectively.
    +(The C++Builder packages remain at $400000 due to a design flaw in the C++Builder linker: it strips the image's relocation table whenever the base address is changed from $400000. DLLs must have relocation tables in order to load properly in all cases.)
    • +
  • Fix: When a top-level DropdownCombo=True submenu item is selected using Alt+[accelerator key] the item is now clicked instead of opened.
    • +
  • Fix: When F1 was pressed on a menu item and Toolbar2000 handled it, a WM_HELP message would still reach the parent form.
    • +
  • Fix: A focused TTBEditItem would lose the focus when Alt+Shift was pressed.
    • +
  • Many internal changes, most of them necessary for supporting MSAA as cleanly as possible.
    • +
+ +
+ +

2.0.16 (2003-03-28)

+
    +
  • Added new tboSameWidth value to the Options property. When set along with tboImageAboveCaption on two or more items on the same view, the items will be stretched as necessary so that they all have the width in pixels.
    • +
  • Added ChevronMoveItems property to TTBToolbar. Normally, when an item on a toolbar's chevron popup menu is clicked, the clicked item will move into the visible area of the toolbar in place of the least recently clicked item. Setting this property to False will disable that behavior.
    • +
  • TTBCustomItem.Click now checks the Enabled property before calling any event handlers, like TMenuItem.Click does.
    • +
  • TTBPopupMenu.Popup now sets the PopupPoint property.
    • +
  • Published OnContextPopup event properties on TTBDock, TTBToolbar, and TTBToolWindow.
    • +
  • Fixed issues with Russian characters as accelerator keys on Windows NT/2000/XP.
    • +
  • Internal tweaks and trivial fixes.
    • +
+ +

2.0.15 (2002-09-29)

+
    +
  • Packages for Delphi 7 are now included.
    • +
  • Revised the Toolbar2000 License Agreement.
    • +
  • TTBMRUList: Added new Remove method.
    +TTBMRUListStrings: IndexOf method now uses AnsiCompareFileName instead of AnsiCompareText.
    • +
  • Fix: The issue reported in the "Problem with tb2k in Com Server/ActiveX" thread on the newsgroup has been fixed.
    • +
  • Internal tweaks and trivial fixes.
    • +
+ +

2.0.14 (2002-05-10)

+
    +
  • Added new tboNoRotation value to Options property. When set, the item and its caption will not be rotated 270 degrees when docked vertically.
    • +
  • Added Move Up and Move Down commands to the design-time editor to make it easier to move items.
    • +
  • Chevron popup windows now wrap if they are too wide to fit on the screen.
    • +
  • A toolbar's LastDock property is no longer updated when the toolbar is dragged over but not dropped on a dock.
    • +
  • When arranging toolbars on a dock, row numbers that contain only invisible or undocked toolbars are no longer removed. This way, when the toolbars are shown/docked again, they stay on their row. This was how Toolbar97 worked.
    • +
  • A toolbar's DockRow and DockPos properties got updated if you dragged the toolbar over a dock but didn't drop it on the dock. Now it restores the original DockRow and DockPos settings when a toolbar is not dropped on a dock.
    • +
  • Fix: When arranging toolbars on a dock, there was a case where LimitToOneRow wasn't being checked.
    • +
  • Internal tweaks.
    • +
+ +

2.0.13 (2002-04-06)

+
    +
  • New item class: TTBVisibilityToggleItem. This item class controls the Visible property of a control, such as a TTBToolbar.
    • +
  • On menus, it now uses clGrayText to draw disabled text when the menu background color doesn't equal clBtnFace. (That is how standard menus work.)
    • +
  • On vertically docked toolbars, it now uses a vertical font if one is available so that Asian characters aren't drawn sideways.
    • +
  • Now, if at design time you double click a TTBToolbar or TTBPopupMenu that has its LinkSubitems property assigned, it asks if you want to edit the item specified by LinkSubitems instead.
    • +
  • TTBEditItem: The outermost border is now transparent when the item is not selected.
    • +
  • In the functions that load toolbar positions, it now compares the dock names with case insensitivity.
    • +
  • Added new demo project file for C++Builder 6 - DemoBCB6 - because DemoBCB doesn't seem to compile under C++Builder 6.
    • +
  • Internal tweaks.
    • +
+ +

2.0.12 (2002-03-06)

+
    +
  • Menus now display scroll arrows when they are too tall to fit on the screen.
    • +
  • Packages for C++Builder 6 are now included.
    • +
  • Minor tweaks and documentation updates.
    • +
+ +

2.0.11 (2002-02-23)

+
    +
  • Fix: The new Stretch property introduced in 2.0.10 had some bugs.
    • +
+ +

2.0.10 (2002-02-13)

+
    +
  • Added new Stretch property to TTBToolWindow and TTBToolbar. When True, the toolbar, when docked, will stretch to fill any unused space on the row.
    • +
  • On TTBToolbar, chevrons now display a "More Buttons" hint, like Office 2000. The hint text can be customized by changing the new ChevronHint property, or globally by changing STBChevronItemMoreButtonsHint in TB2Consts.pas.
    • +
  • The OnMove event of TTBToolbar/TTBToolWindow now gets fired when the bar is floating also.
    • +
  • Fix: TTBPopupMenu.OnPopup was being called twice when the popup was displayed - once with the TTBPopupMenu as the Sender, and once with the internal TTBRootItem as the Sender. Now, it's called only once with the TTBPopupMenu as the Sender.
    • +
  • Fix: TTBEditItem: Fixed double-click issue ("TB2k Strange Behaviour").
    • +
  • Internal tweaks.
    • +
+ +

2.0.9 (2002-01-11)

+
    +
  • Added new TTBImageList component. It is an enhanced version of the standard TImageList component, designed for use with the Toolbar2000 components. It adds the ability to use special images for different item states (hot, disabled, checked). It also adds the ability to load the images from a bitmap instead of using TImageList's normal streaming mechanism, which has problems with older COMCTL32.DLL versions.
    • +
  • Added new OnSelect property to TTBCustomItem and descendants. This event lets you trap when the mouse enters or leaves an item.
    • +
  • Added new CharCase and OnBeginEdit properties to TTBEditItem.
    • +
  • Added C++Builder version of the Demo project - DemoBCB.
    • +
  • Minor tweaks and fixes.
    • +
+ +

2.0.8 (2001-12-27)

+
    +
  • Now supports "flat" menu borders on Windows XP.
    • +
  • The background of a selected menu item's image is now filled with clBtnFace. This seems to look better with Windows XP's white menus.
    • +
  • Made chevron popups colored clBtnFace instead of clMenu. This seems to look better on Windows XP with themes enabled.
    • +
  • Fix: Fixed "stack overflow" problem that may have occurred if you had a floating TTBToolWindow and pressed Alt on the keyboard.
    • +
  • Fix: On Delphi 6 the ActionComponent property of an action now gets set properly when the action is fired from a TB2k item.
    • +
  • Removed some Windows NT 3.51 support code since NT 3.51 is now officially unsupported.
    • +
+ +

2.0.7 (2001-12-19)

+
    +
  • Menus now display drop-shadows on Windows XP if they are enabled in the Display Properties.
    • +
  • When a menu is up, keystrokes will no longer get processed by an IME if one was active.
    +Note: The ImmGetVirtualKey function is used, which is not available on Windows NT 3.51. Therefore, NT 3.51 is now officially unsupported. (It never was officially supported anyway.)
    • +
  • TTBToolbar: Added new published FloatingWidth property.
    • +
  • Fix: Accessing menu bars on non-main forms with the keyboard should now work.
    • +
  • Minor fixes.
    • +
+ +

2.0.6 (2001-11-14)

+
    +
  • When a shortcut key is pressed, it now sends OnPopup/OnClick events to the selected item's parents so that they can update the Enabled state of the item if needed.
    • +
  • The OnPopup event of TTBPopupMenu is now fired when one of its items' shortcut keys is pressed.
    • +
  • TTBPopupMenu now processes shortcuts.
    • +
  • Added OnUpdate event to TTBMDIWindowItem.
    • +
  • Minor fixes.
    • +
+ +

2.0.5 (2001-10-09)

+
    +
  • Toolbars that are neither docked nor floating can now wrap or display a chevron (ShrinkMode is no longer ignored). For it to work, you must do at least one of the following: set AutoResize to False, set Align to one of [alTop, alBottom, alClient], or add [akLeft, akRight] to Anchors (which is now a published property).
    • +
  • TTBToolWindow: Published the Align and Anchors properties.
    • +
  • Now allows F1 to be handled while the mouse button is down (an odd quirk of standard menus).
    • +
  • Now always streams out the Width & Height properties of a toolbar that is neither docked nor floating. Needed to properly support anchored toolbars.
    • +
  • Fix: Fixed a GDI resource leak in TB2Item that occurred on Windows 9x/Me due to an undocumented difference/bug in the way SaveDC works.
    • +
  • Fix: Fixed resource leak with TTBMDIHandler: it was trying to free an icon handle with DeleteObject instead of DestroyIcon.
    • +
  • Fix: Made TTBPopupWindow a TCustomControl descendant instead of a TForm descendant. This resolves the issue with the Application window's taskbar button reappearing after the program initially hid it.
    • +
  • Fix: When destroying a toolbar on a dock that had another toolbar on the same dock linked to one of the destroying toolbar's subitems, an AV may have occurred.
    • +
  • Fix: Fixed problem in TTBView.GivePriority.
    • +
+ +

2.0.4 (2001-09-30)

+
    +
  • Added new tboImageAboveCaption value to Options property. When set, the item's caption will be displayed underneath its image, making for an Internet Explorer-like appearance.
    • +
  • Added Options property to TTBPopupMenu.
    • +
  • Fix: It was possible to "click" disabled top-level items by pressing Alt+[accelchar].
    • +
  • Fix: Shortcut keys now work on toolbars that are on frames.
    • +
  • Fixed issue with TActiveForms: OnClick events were always executed in the context of the first thread.
    • +
  • Minor tweaks.
    • +
+ +

2.0.3 (2001-09-13)

+
    +
  • Added AutoCheck property to TTBCustomItem and descendants.
    • +
  • Added Prefix property to TTBMRUList.
    • +
  • Added Enabled property to TTBMDIWindowItem.
    • +
  • Published GroupIndex property on TTBSubmenuItem and TTBEditItem.
    • +
  • TTBView's Selected property is now writable.
    • +
  • Fix: Sealed minor memory leak that occurred when when a TTBMDIHandler component was created, or when the LinkSubItems property of a toolbar was changed.
    • +
  • Fix: Modifying a TTBBackground's bitmap after a dock that used the background was destroyed may have caused an AV.
    • +
  • Fix: Alt+- didn't work unless the two keys were pressed simultaneously.
    • +
  • Fix: Shortcuts didn't work if TTBToolbar.LinkSubitems was set.
    • +
  • Fix: MDI buttons didn't show when FullSize=False and ShrinkMode=tbsmWrap.
    • +
  • Fix: Unwrapped floating toolbars were a pixel too high.
    • +
  • Fix: Hopefully fixed Delphi 6 AV with design-time editor again.
    • +
+ +

2.0.2 (2001-08-19)

+
    +
  • Added new component: TTBMDIHandler, which adds the MDI system menu and minimize/restore/close buttons to a menu bar. See the documentation for details.
    • +
  • Added new item type: TTBMDIWindowItem, which expands to a list of available MDI child windows at run-time. This is intended to be placed at the end of an MDI application's Window menu, following a separator.
    • +
  • The design-time menu converter can now convert TPopupMenu's too.
    • +
  • The Alignment property of TTBPopupMenu is now respected. Also added optional Alignment parameter to the TTBCustomItem.Popup method.
    • +
  • Added TTBCustomItem.Clear method.
    • +
  • Now respects the system's "menu drop alignment" setting when dropping down menus.
    • +
  • Pressing Home or End on a toolbar or menu now moves the selection to the first or last item.
    • +
  • Fix: TTBToolWindow's that had their FullSize properties set to True weren't the correct size when undocked.
    • +
  • Fix: Now doesn't attempt to draw or invalidate TTBControlItem's. Fixes issue with Transparent=True TLabel's.
    • +
  • Fix: Now doesn't display the size-all cursor on DragHandle=dhNone toolbars.
    • +
  • Fix: The keyboard shortcuts for Cut/Copy/Paste in the design-time editor now work again.
    • +
  • Some minor internal tweaks.
    • +
+ +

2.0.1 (2001-08-04)

+
    +
  • Added slide/fade animation support. It is enabled automatically if the user has menu animation enabled in Windows.
    • +
  • On vertical toolbars, the tboDropdownArrow arrows are now drawn rotated and below the text.
    • +
  • Fix: When you have ProcessShortCuts=True toolbars on multiple forms, it now first looks for shortcuts on the active form's toolbars, and then the main form's toolbars. Previously, it looked on all forms' toolbars.
    • +
  • Fix: It wasn't loading item icons correctly after design-time code was moved to the tb2kdsgn package.
    • +
  • Fix: Setting EditOptions on TTBEditAction had no effect.
    • +
  • Some minor internal tweaks.
    • +
+ +

2.0.0 (2001-07-21)

+
    +
  • Revised the Toolbar2000 License Agreement.
    • +
  • Moved design-time units to separate tb2kdsgn_* packages so that tb2k_* may now be used as run-time packages.
    • +
  • Tweaked the component icons.
    • +
+ +
+ +

Beta Releases

+ +

2.0-BETA6 (2001-07-18)

+
    +
  • TTBMRUList: Added AddFullPath and HidePathExtension properties. Both are True by default. See documentation for details.
    • +
  • TTBMRUList: Added OnChange event.
    • +
  • Typing or pressing Enter on the design-time editor's tree view now activates the Object Inspector.
    • +
  • Fix: On Delphi 6, the ShortCut property of TTBCustomItem was showing up like an Integer property in Object Inspector, thanks to some change Borland made. Workaround added.
    • +
  • Fix: Removed call in design-time editor that appeared to cause AV's in certain cases.
    • +
+ +

2.0-BETA5 (2001-07-09)

+
    +
  • Now works around the Windows 2000 problem of delaying on the first PlaySound call by not calling PlaySound at all if there is no sound associated with the event.
    • +
  • Added LoadFromIni, LoadFromRegIni, SaveToIni, SaveToRegIni methods to TTBMRUList.
    • +
  • Updated documentation; added an index.
    • +
  • Updated demo project.
    • +
  • Fix: The change to the Click handling in 2.0-BETA4 broke exception handling.
    • +
  • Fix: The OnResize event was never fired.
    • +
  • A few very minor fixes and tweaks.
    • +
+ +

2.0-BETA4 (2001-07-01)

+
    +
  • Added UpdateActions property to TTBToolbar. Setting it to False can decrease CPU utilization. See the documentation for details.
    • +
  • Now, as with standard menus, when an item is clicked it posts a message to the queue so that the Click handler gets called when control returns to the message loop. This fixes the problem with modal forms not correctly getting the focus when an item is selected from a menu with the keyboard.
    • +
  • Fixed potential AV problem when Escape was pressed.
    • +
  • Improvements to design-time editor: +
      +
    • There's now an empty item at the end of the item list, similar to Delphi's menu editor. You can't (currently) type on this item item, but you can select it and press Insert to add a new item to the end.
      • +
    • You can now hold down Shift while pressing Insert or clicking one of the New buttons to add an item to the end instead of inserting it before the currently selected item.
      • +
    • Added keyboard shortcuts for New Subitem and New Separator.
      • +
    • Now selects root item when list view is focused and no item is selected.
      • +
    • After deleting the items, it now selects the item with the focus.
      • +
    +
    • +
+ +

2.0-BETA3 (2001-06-25)

+
    +
  • Context help (F1) is now supported on menu items.
    • +
  • Added a GroupIndex property to TTBCustomItem due to popular demand. See documentation for details on how it works.
    • +
  • Added a new ImageIndex property editor which is fully compatible with Delphi 6.
    • +
  • It now substitutes Arial for MS Sans Serif & Microsoft Sans Serif when drawing vertical text, instead of letting Windows pick a font.
    • +
  • Remarked out code in TTBDock.ArrangeToolbars that was there to work around a VCL alignment bug*, because it had some undesirable side effects. Now, if you want to avoid the bug, you need to right-click your alClient-aligned controls in the form designer and select "Send to Back." +
    * The VCL alignment bug: if a control is taller or wider than the client height or width of its parent, alClient-aligned controls may appear on top of the control, instead of being hidden from view.
    • +
  • Fix: When toolbars are dragged across a dock that has a background bitmap, they should no longer flicker.
    • +
  • Fix: The menu converter now transfers the Tag property.
    • +
  • Fix: The toolbar-dragging changes in 2.0-BETA2 broke the splitter.
    • +
  • Fix: Work around an annoying Windows or VCL bug. (If you close all MDI child windows, the MDI client window gets the focus, and when it has the focus, pressing Alt+[char] doesn't send a WM_SYSCOMMAND message to the form for some reason.)
    • +
  • Fix: In the design-time item editor, when a new item is created while the tree view has the focus, it now sets the focus to the list view so that the item becomes selected in Object Inspector.
    • +
  • Fix: On TTBDock, LimitToOneRow=True didn't actually limit to one row while dragging.
    • +
  • Various other minor tweaks and fixes.
    • +
+ +

2.0-BETA2 (2001-06-18)

+
    +
  • Delphi 6 is now supported. There is one limitation however: the ImageIndex property editor used by TTBCustomItem descendants had to be disabled because TComponentImageIndexPropertyEditor is gone in Delphi 6! Therefore, on Delphi 6, the dropdown lists of ImageIndex properties may not work correctly, at least for now.
    • +
  • Text on vertical toolbars is now drawn vertically!
    • +
  • Vastly improved the code that handles toolbar dragging. Previously, when you dragged a SmoothDrag=True docked toolbar over other docked toolbars, the toolbar may not have ended up on the row you were expecting. This was because the old code - ported from Toolbar97 - was not designed with smooth dragging in mind. Now it should function almost exactly like Office 2000.
    • +
  • TTBEditItem (and friends): Removed DisplayAsButton property; replaced with EditOptions property. Now, by default, edits on toolbars will automatically change into buttons when the toolbar is docked vertically. Add tboUseEditWhenVertical to EditOptions to disable this.
    • +
  • On wrapped toolbars, menus now pop out to the side which obscures the least amount of items, like Office 2000.
    • +
  • Up/Down/Left/Right arrow keys on vertical toolbars now work like Office 2000.
    • +
  • Fix: Hints on chevron popup's items didn't include shortcuts.
    • +
  • Fix: Deleting an item from a TTBMRUList via Items.Delete() did not refresh the keyboard shortcuts.
    • +
  • Fix: Fixed "Run-time creation of items and chevron" problem reported by Francois Rivierre.
    • +
  • Some very minor tweaks.
    • +
+ +

2.0-BETA1 (2001-06-12)

+
    +
  • Updated the Toolbar2000 License Agreement.
    • +
  • You can now display the version of Toolbar2000 by right-clicking a toolbar and selecting "Version".
    • +
  • Added an improved Demo project.
    • +
  • Made the margins of menu items a bit more like Office and standard menus.
    • +
  • Now includes size of a font's external leading when calculating an menu item's height.
    • +
  • Added workaround an apparent NT 4.0 & 2000 bug that was causing the right side of floating toolbars' non-client area to be painted incorrectly if the toolbar's width was greater than the screen width.
    • +
  • Various tweaks to the display of disabled toolbar & menu items.
    • +
+ + +