From 85c73477c2794a7d173f7aa4e5a4e71000711dc7 Mon Sep 17 00:00:00 2001 From: pyscripter Date: Fri, 4 May 2007 17:36:31 +0000 Subject: [PATCH] Version 1.8.6 --- Install.txt | 6 +- JvDockControlForm.pas | 267 +- JvDockInfo.pas | 12 +- JvDockSupportControl.pas | 3761 ++++++++++++++ JvDockTree.pas | 4497 ++++++++++++++++ JvDockVIDStyle.pas | 4853 +++++++++++++++++ JvDockVSNetStyle.pas | 112 +- JvThreadDialog.pas | 701 +++ PyScripter.bdsproj | 11 +- PyScripter.bdsproj.local | 3 + PyScripter.chw | Bin 0 -> 18134 bytes PyScripter.dpr | 24 +- PyScripter.drc | 2040 ++++++++ PyScripter.res | Bin 28464 -> 28464 bytes PythonEngine.pas | 10106 ++++++++++++++++++++++++++++++++++++ Readme.txt | 21 +- SynHighlighterPython.pas | 5 +- TBXOffice2003Theme.pas | 2154 ++++++++ TBXOffice2007Theme.pas | 2364 +++++++++ TBXUtils.pas | 3218 ++++++++++++ WebCopy.avi | Bin 0 -> 9918 bytes WebCopyAvi.rc | 1 + WebCopyAvi.res | Bin 0 -> 10008 bytes XP_UAC.manifest | 31 + XP_UAC.rc | 1 + XP_UAC.res | Bin 0 -> 1080 bytes cFileSearch.pas | 3 +- cFindInFiles.pas | 4 +- cPyBaseDebugger.pas | 23 +- cPyDebugger.pas | 65 +- cPyRemoteDebugger.pas | 122 +- cPythonSourceScanner.pas | 142 +- cTools.pas | 18 +- dlgAboutPyScripter.dfm | 20 +- dlgAskParam.dfm | 44 +- dlgAskParam.pas | 8 +- dlgCodeTemplates.dfm | 147 +- dlgCodeTemplates.pas | 27 +- dlgCommandLine.dfm | 23 +- dlgCommandLine.pas | 4 +- dlgConfigureTools.dfm | 96 +- dlgConfigureTools.pas | 17 +- dlgConfirmReplace.dfm | Bin 921 -> 1445 bytes dlgConfirmReplace.pas | 10 +- dlgCustomParams.dfm | 144 +- dlgCustomParams.pas | 16 +- dlgCustomShortcuts.dfm | 49 +- dlgCustomShortcuts.pas | 8 +- dlgDirectoryList.dfm | 82 +- dlgDirectoryList.pas | 15 +- dlgExceptionMail.dfm | 83 +- dlgExceptionMail.pas | 13 +- dlgFileTemplates.dfm | 141 +- dlgFileTemplates.pas | 18 +- dlgFindInFiles.dfm | 116 +- dlgFindInFiles.pas | 26 +- dlgFindResultsOptions.dfm | 53 +- dlgFindResultsOptions.pas | 12 +- dlgNewFile.dfm | 25 +- dlgNewFile.pas | 9 +- dlgOptionsEditor.dfm | 30 +- dlgPickList.dfm | 4 - dlgReplaceInFiles.dfm | 39 +- dlgReplaceInFiles.pas | 10 +- dlgReplaceText.dfm | Bin 593 -> 804 bytes dlgReplaceText.pas | 2 +- dlgSearchText.dfm | Bin 1573 -> 2072 bytes dlgSearchText.pas | 20 +- dlgSynEditOptions.dfm | Bin 13549 -> 16076 bytes dlgSynEditOptions.pas | 108 +- dlgSynPageSetup.dfm | Bin 58628 -> 59725 bytes dlgSynPageSetup.pas | 42 +- dlgToDoOptions.dfm | 181 +- dlgToDoOptions.pas | 24 +- dlgToolProperties.dfm | 335 +- dlgToolProperties.pas | 48 +- dlgUnitTestWizard.dfm | 4 +- dmCommands.dfm | 1162 ++++- dmCommands.pas | 268 +- frmBreakPoints.dfm | 8 +- frmBreakPoints.pas | 8 +- frmCallStack.dfm | 8 +- frmCallStack.pas | 18 +- frmCodeExplorer.dfm | 5 +- frmCodeExplorer.pas | 16 +- frmCommandOutput.dfm | 5 +- frmCommandOutput.pas | 18 +- frmEditor.pas | 152 +- frmFileExplorer.dfm | 2 +- frmFileExplorer.pas | 8 +- frmFindResults.dfm | 6 +- frmFindResults.pas | 18 +- frmIDEDockWin.dfm | 4 +- frmIDEDockWin.pas | 34 +- frmMessages.dfm | 8 +- frmMessages.pas | 18 +- frmPyIDEMain.dfm | Bin 41729 -> 44284 bytes frmPyIDEMain.pas | 529 +- frmPythonII.dfm | 124 +- frmPythonII.pas | 302 +- frmRegExpTester.dfm | 53 +- frmRegExpTester.pas | 17 +- frmToDo.dfm | 5 +- frmToDo.pas | 7 +- frmUnitTests.dfm | 7 +- frmUnitTests.pas | 7 +- frmVariables.dfm | 16 +- frmVariables.pas | 7 +- frmWatches.dfm | 9 +- frmWatches.pas | 34 +- uCmdLine.pas | 479 ++ uCommonFunctions.pas | 40 +- uDpiAware.pas | 29 + uEditAppIntfs.pas | 3 + 114 files changed, 38042 insertions(+), 2010 deletions(-) create mode 100644 JvDockSupportControl.pas create mode 100644 JvDockTree.pas create mode 100644 JvDockVIDStyle.pas create mode 100644 JvThreadDialog.pas create mode 100644 PyScripter.chw create mode 100644 PyScripter.drc create mode 100644 PythonEngine.pas create mode 100644 TBXOffice2003Theme.pas create mode 100644 TBXOffice2007Theme.pas create mode 100644 TBXUtils.pas create mode 100644 WebCopy.avi create mode 100644 WebCopyAvi.rc create mode 100644 WebCopyAvi.res create mode 100644 XP_UAC.manifest create mode 100644 XP_UAC.rc create mode 100644 XP_UAC.res create mode 100644 uCmdLine.pas create mode 100644 uDpiAware.pas diff --git a/Install.txt b/Install.txt index 6cce13472..90b7f56e7 100644 --- a/Install.txt +++ b/Install.txt @@ -1 +1,5 @@ -Copy the included files to the PyScripter installation folder overriding existing files. Please note that to use remote debugging you need to install the Python package Rpyc which is available at http://rpyc.sf.net. \ No newline at end of file +Copy the included files to the PyScripter installation folder overriding existing files. +Please note that to use remote debugging you need to install the Python package Rpyc which is available at http://rpyc.sf.net. + +If you upgrade from a version earlier than 1.8.5 you will need to change the PyScripter shortcuts, since now command line +arguments are prefixed by double dash ("--"). \ No newline at end of file diff --git a/JvDockControlForm.pas b/JvDockControlForm.pas index fa33e3f79..86ac4c55d 100644 --- a/JvDockControlForm.pas +++ b/JvDockControlForm.pas @@ -24,7 +24,7 @@ Known Issues: -----------------------------------------------------------------------------} -// $Id: JvDockControlForm.pas 11124 2007-01-04 10:41:24Z obones $ +// $Id: JvDockControlForm.pas 11276 2007-04-24 19:33:37Z remkobonte $ { Changes: @@ -64,6 +64,10 @@ interface JvDockState_Docking = 1; JvDockState_Floating = 2; + {$IFNDEF COMPILER9_UP} + CM_INVALIDATEDOCKHOST = CM_BASE + 70; + {$ENDIF !COMPILER9_UP} + type TJvDockSplitterSize = 0..32767; @@ -668,6 +672,8 @@ TJvDockTabPageControl = class(TJvDockPageControl) function GetParentForm: TJvDockTabHostForm; procedure DockStyleChanged(Sender: TObject); function GetDockStyle: TJvDockObservableStyle; + function GetActiveDockForm: TCustomForm; + function GetDockForm(Index: Integer): TCustomForm; protected procedure AdjustClientRect(var Rect: TRect); override; procedure ReloadDockedControl(const AControlName: string; @@ -694,6 +700,9 @@ TJvDockTabPageControl = class(TJvDockPageControl) procedure DockDrop(Source: TDragDockObject; X, Y: Integer); override; procedure LoadFromStream(Stream: TStream); virtual; procedure SaveToStream(Stream: TStream); virtual; + + property ActiveDockForm: TCustomForm read GetActiveDockForm; + property DockForm[Index: Integer]: TCustomForm read GetDockForm; { ParentForm is the Owner } property ParentForm: TJvDockTabHostForm read GetParentForm; property TabPosition; @@ -761,7 +770,9 @@ TJvDockTabHostForm = class(TJvDockableForm) constructor Create(AOwner: TComponent); override; procedure ShowDockedControl(AControl:TWinControl); virtual; // If aControl is docked in PageControl, change PageControl to that page. NEW! WPostma. procedure UpdateCaption(AControl:TWinControl); virtual; // update tab host's tabs and title bar when page caption changes. + procedure DoDock(NewDockSite: TWinControl; var ARect: TRect); override; + // backwards compatibility: Mantis 4100 function GetActiveDockForm: TForm; property DockClient; { Constructed in TJvDockClient.CreateTabDockClass } @@ -849,7 +860,6 @@ procedure DoFloatAllForm; function GetClientAlignControlArea(AControl: TWinControl; Align: TAlign; Exclude: TControl = nil): Integer; procedure ResetDockClient(Control: TControl; NewTarget: TControl); overload; procedure ResetDockClient(DockClient: TJvDockClient; NewTarget: TControl); overload; -procedure ReshowAllVisibleWindow; { Quick way to do tabbed docking programmatically - Added by Warren } function ManualTabDock(DockSite: TWinControl; Form1, Form2: TForm): TJvDockTabHostForm; @@ -860,13 +870,21 @@ function ManualConjoinDock(DockSite: TWinControl; Form1, Form2: TForm): TJvDockC function DockStateStr(DockState: Integer): string; {return string for a dock state} +procedure BeginDockLoading; +procedure EndDockLoading; +function JvGlobalDockIsLoading: Boolean; + +{$IFNDEF COMPILER9_UP} +procedure InvalidateDockHostSiteOfControl(Control: TControl; FocusLost: Boolean); +{$ENDIF !COMPILER9_UP} + {$IFDEF USEJVCL} {$IFDEF UNITVERSIONING} const UnitVersioning: TUnitVersionInfo = ( - RCSfile: '$URL: https://jvcl.svn.sourceforge.net/svnroot/jvcl/branches/JVCL3_30_PREPARATION/run/JvDockControlForm.pas $'; - Revision: '$Revision: 11124 $'; - Date: '$Date: 2007-01-04 11:41:24 +0100 (jeu., 04 janv. 2007) $'; + RCSfile: '$URL: https://jvcl.svn.sourceforge.net:443/svnroot/jvcl/trunk/jvcl/run/JvDockControlForm.pas $'; + Revision: '$Revision: 11276 $'; + Date: '$Date: 2007-04-24 12:33:37 -0700 (Tue, 24 Apr 2007) $'; LogPath: 'JVCL\run' ); {$ENDIF UNITVERSIONING} @@ -903,10 +921,30 @@ TWinControlAccessProtected = class(TWinControl); DockPageControlHotTrack: Boolean = False; TabDockHostBorderStyle: TFormBorderStyle = bsSizeToolWin; ConjoinDockHostBorderStyle: TFormBorderStyle = bsSizeToolWin; - IsWinXP: Boolean; + + GDockLoadCount: Integer = 0; + GShowingChanged: TList; //=== Local procedures ======================================================= +function IsWinXP_UP: Boolean; +begin + Result := (Win32Platform = VER_PLATFORM_WIN32_NT) and + ((Win32MajorVersion > 5) or + (Win32MajorVersion = 5) and (Win32MinorVersion >= 1)); +end; + +procedure ApplyShowingChanged; +var + I: Integer; +begin + if IsWinXP_UP then + for I := 0 to Screen.FormCount - 1 do + if GShowingChanged.IndexOf(Screen.Forms[I]) >= 0 then + Screen.Forms[i].Perform(CM_SHOWINGCHANGED, 0, 0); + FreeAndNil(GShowingChanged); +end; + procedure UpdateCaption(Source: TWinControl; Exclude: TControl); var I: Integer; @@ -929,6 +967,34 @@ procedure UpdateCaption(Source: TWinControl; Exclude: TControl); end; end; +//=== Global procedures ====================================================== + +procedure BeginDockLoading; +begin + if GDockLoadCount = 0 then + begin + JvDockLockWindow(nil); + end; + Inc(GDockLoadCount); +end; + +procedure EndDockLoading; +begin + Dec(GDockLoadCount); + if GDockLoadCount = 0 then + begin + ApplyShowingChanged; + JvDockUnLockWindow; + end; +end; + +function JvGlobalDockIsLoading: Boolean; +begin + Result := GDockLoadCount > 0; +end; + +{ ahuser: These functions are not call anywhere + function GetActiveControl(AForm: TCustomForm): TWinControl; var AControl: TWinControl; @@ -958,9 +1024,7 @@ function GetHostDockParent(AControl: TWinControl): TWinControl; end; AControl := AControl.Parent; end; -end; - -//=== Global procedures ====================================================== +end;} function ComputeDockingRect(AControl: TControl; var DockRect: TRect; MousePos: TPoint): TAlign; var @@ -1280,6 +1344,29 @@ procedure TJvDockBasicStyle.DoHideDockForm(DockWindow: TWinControl); TJvDockCustomControl(DockWindow.HostDockSite).UpdateCaption(DockWindow); end; +{$IFNDEF COMPILER9_UP} +procedure InvalidateDockHostSiteOfControl(Control: TControl; FocusLost: Boolean); +var + ChildDockSite: TControl; + ParentWalk: TWinControl; +begin + { Invalidate the first dock site we come across; its ui may + need updating to reflect which control has focus. } + if Control = nil then + Exit; + ChildDockSite := Control; + ParentWalk := Control.Parent; + while (ChildDockSite.HostDockSite = nil) and (ParentWalk <> nil) do + begin + ChildDockSite := ParentWalk; + ParentWalk := ParentWalk.Parent; + end; + if ChildDockSite <> nil then + TWinControlAccessProtected(ChildDockSite).SendDockNotification(CM_INVALIDATEDOCKHOST, + Integer(Control), Integer(FocusLost)); +end; +{$ENDIF !COMPILER9_UP} + function IsDockable(Sender: TWinControl; Client: TControl; DropCtl: TControl = nil; DockAlign: TAlign = alNone): Boolean; var @@ -1376,38 +1463,24 @@ function IsDockable(Sender: TWinControl; Client: TControl; DropCtl: TControl = n procedure LoadDockTreeFromAppStorage(AppStorage: TJvCustomAppStorage; AppStoragePath: string = ''); var JvDockInfoTree: TJvDockInfoTree; - Form: TForm; begin AppStorage.BeginUpdate; try HideAllPopupPanel(nil); {This is in JvDockVSNetStyle.pas } - Form := TForm.CreateNew(nil); - // What does this form do, and why is it created only during the loading of the app storage? - Form.BorderStyle := bsNone; - Form.BoundsRect := Rect(0, 0, 0, 0); - Form.Visible := True; - Form.Name := {NOTRANSLATE} 'LoadDockTreeFromAppStorage_Form'; - JvDockInfoTree := TJvDockInfoTree.Create(TJvDockInfoZone); - - JvDockLockWindow(nil); try - JvDockInfoTree.AppStorage := AppStorage; - JvDockInfoTree.AppStoragePath := AppStoragePath; + BeginDockLoading; try - JvGlobalDockIsLoading := True; + JvDockInfoTree.AppStorage := AppStorage; + JvDockInfoTree.AppStoragePath := AppStoragePath; JvDockInfoTree.ReadInfoFromAppStorage; finally - JvGlobalDockIsLoading := False; + EndDockLoading; end; finally -// Form.Release; - Form.Free; - JvDockUnLockWindow; JvDockInfoTree.Free; end; - ReshowAllVisibleWindow; finally AppStorage.EndUpdate; end; @@ -1453,6 +1526,8 @@ procedure LoadDockTreeFromFile(FileName: string); begin HideAllPopupPanel(nil); + { Creating a form with size 0 before locking the desktop supposedly prevents + some screen flicker } Form := TForm.CreateNew(nil); Form.BorderStyle := bsNone; Form.BoundsRect := Rect(0, 0, 0, 0); @@ -1462,20 +1537,17 @@ procedure LoadDockTreeFromFile(FileName: string); JvDockInfoTree := TJvDockInfoTree.Create(TJvDockInfoZone); MemFile := TMemIniFile.Create(FileName); - JvDockLockWindow(nil); + BeginDockLoading; try JvDockInfoTree.DockInfoIni := MemFile; JvGlobalDockIsLoading := True; JvDockInfoTree.ReadInfoFromIni; - JvGlobalDockIsLoading := False; finally -// Form.Release; Form.Free; - JvDockUnLockWindow; + EndDockLoading; JvDockInfoTree.Free; MemFile.Free; end; - ReshowAllVisibleWindow; end; procedure LoadDockTreeFromReg(ARootKey: DWORD; RegPatch: string); @@ -1485,6 +1557,8 @@ procedure LoadDockTreeFromReg(ARootKey: DWORD; RegPatch: string); begin HideAllPopupPanel(nil); + { Creating a form with size 0 before locking the desktop supposedly prevents + some screen flicker } Form := TForm.CreateNew(nil); Form.BorderStyle := bsNone; Form.BoundsRect := Rect(0, 0, 0, 0); @@ -1493,24 +1567,20 @@ procedure LoadDockTreeFromReg(ARootKey: DWORD; RegPatch: string); JvDockInfoTree := TJvDockInfoTree.Create(TJvDockInfoZone); - JvDockLockWindow(nil); + BeginDockLoading; try JvDockInfoTree.DockInfoReg := TRegistry.Create; try - JvGlobalDockIsLoading := True; JvDockInfoTree.DockInfoReg.RootKey := ARootKey; JvDockInfoTree.ReadInfoFromReg(RegPatch); finally JvDockInfoTree.DockInfoReg.Free; - JvGlobalDockIsLoading := False; end; finally - JvDockUnLockWindow; + EndDockLoading; JvDockInfoTree.Free; -// Form.Release; Form.Free; end; - ReshowAllVisibleWindow; end; {$ENDIF USEJVCL} @@ -1652,17 +1722,6 @@ procedure ResetDockClient(Control: TControl; NewTarget: TControl); ResetDockClient(FindDockClient(Control), NewTarget); end; -procedure ReshowAllVisibleWindow; -var - I: Integer; -begin - if IsWinXP then - for I := 0 to Screen.FormCount - 1 do - if Screen.Forms[I].Visible then - Windows.ShowWindow(Screen.Forms[I].Handle, SW_SHOW) - else - Windows.ShowWindow(Screen.Forms[I].Handle, SW_HIDE); -end; {$IFDEF USEJVCL} @@ -2950,8 +3009,10 @@ destructor TJvDockClient.Destroy; procedure TJvDockClient.Activate; begin + {$IFNDEF COMPILER9_UP} if ParentForm.HostDockSite is TJvDockCustomPanel then - TJvDockCustomPanel(ParentForm.HostDockSite).JvDockManager.ActiveControl := ParentForm; + InvalidateDockHostSiteOfControl(ParentForm, False); + {$ENDIF !COMPILER9_UP} end; procedure TJvDockClient.AddDockStyle(ADockStyle: TJvDockBasicStyle); @@ -3113,9 +3174,10 @@ function TJvDockClient.CreateTabHostAndDockControl(Control1, Control2: TControl) procedure TJvDockClient.Deactivate; begin + {$IFNDEF COMPILER9_UP} if ParentForm.HostDockSite is TJvDockCustomPanel then - if TJvDockCustomPanel(ParentForm.HostDockSite).JvDockManager <> nil then - TJvDockCustomPanel(ParentForm.HostDockSite).JvDockManager.ActiveControl := nil; + InvalidateDockHostSiteOfControl(ParentForm, True); + {$ENDIF !COMPILER9_UP} end; procedure TJvDockClient.DoFloatDockClients(PanelAlign: TAlign); @@ -3524,8 +3586,13 @@ procedure TJvDockClient.WindowProc(var Msg: TMessage); begin case Msg.Msg of CM_SHOWINGCHANGED: - if IsWinXP and JvGlobalDockIsLoading then + if IsWinXP_UP and JvGlobalDockIsLoading then + begin + if GShowingChanged = nil then + GShowingChanged := TList.Create; + GShowingChanged.Add(ParentForm); Exit; + end; WM_NCLBUTTONDOWN: begin WMNCLButtonDown(TWMNCHitMessage(Msg)); @@ -3589,12 +3656,9 @@ procedure TJvDockClient.WindowProc(var Msg: TMessage); procedure TJvDockClient.WMActivate(var Msg: TWMActivate); begin - if ParentForm is TJvDockConjoinHostForm then - if Msg.Active = WA_INACTIVE then - TJvDockConjoinPanel(TJvDockConjoinHostForm(ParentForm).Panel).JvDockManager.ActiveControl := nil - else - TJvDockConjoinPanel(TJvDockConjoinHostForm(ParentForm).Panel).JvDockManager.ActiveControl := - GetActiveControl(ParentForm); + {$IFNDEF COMPILER9_UP} + InvalidateDockHostSiteOfControl(ParentForm.ActiveControl, Msg.Active = WA_INACTIVE); + {$ENDIF !COMPILER9_UP} end; procedure TJvDockClient.WMNCLButtonDblClk(var Msg: TWMNCHitMessage); @@ -4567,31 +4631,30 @@ procedure TJvDockServer.WindowProc(var Msg: TMessage); end; procedure TJvDockServer.WMActivate(var Msg: TWMActivate); +{$IFNDEF COMPILER9_UP} var - I: TAlign; Control: TWinControl; +{$ENDIF !COMPILER9_UP} begin + {$IFNDEF COMPILER9_UP} if Msg.Active = WA_INACTIVE then begin - for I := alTop to alRight do - if Assigned(DockPanelWithAlign[I]) then - DockPanelWithAlign[I].JvDockManager.ActiveControl := nil; + Control := ParentForm.ActiveControl; + if Assigned(Control) then + InvalidateDockHostSiteOfControl(Control, True); end else - if AutoFocusDockedForm then begin - Control := GetActiveControl(ParentForm); - if not Assigned(Control) then - Exit; - for I := alTop to alRight do - if Assigned(DockPanelWithAlign[I]) then - if GetHostDockParent(Control) = DockPanelWithAlign[I] then - begin - DockPanelWithAlign[I].JvDockManager.ActiveControl := Control; - if Control.CanFocus then - Control.SetFocus; - end; + Control := ParentForm.ActiveControl; + if Assigned(Control) then + begin + // { ?? } + // if AutoFocusDockedForm and Control.CanFocus then + // Control.SetFocus; + InvalidateDockHostSiteOfControl(Control, False); + end; end; + {$ENDIF !COMPILER9_UP} end; //=== { TJvDockSplitter } ==================================================== @@ -4751,11 +4814,21 @@ constructor TJvDockTabHostForm.Create(AOwner: TComponent); BorderStyle := TabDockHostBorderStyle; end; +procedure TJvDockTabHostForm.DoDock(NewDockSite: TWinControl; var ARect: TRect); +begin + inherited; + if not JvGlobalDockIsLoading and + not Assigned(NewDockSite) and + (GetActiveDockForm <> nil) and + GetParentForm(Self).Visible and + GetActiveDockForm.CanFocus then + GetActiveDockForm.SetFocus; +end; + function TJvDockTabHostForm.GetActiveDockForm: TForm; begin - if PageControl.ActivePage.ControlCount = 1 then - { Dirty cast } - Result := TForm(PageControl.ActivePage.Controls[0]) + if PageControl.ActiveDockForm is TForm then + Result := TForm(PageControl.ActiveDockForm) else Result := nil; end; @@ -4998,6 +5071,32 @@ function TJvDockTabPageControl.DoUnDock(NewTarget: TWinControl; Result := Perform(CM_UNDOCKCLIENT, Integer(NewTarget), Integer(Client)) = 0; end; +function TJvDockTabPageControl.GetActiveDockForm: TCustomForm; +begin + Result := DockForm[ActivePageIndex]; +end; + +function TJvDockTabPageControl.GetDockForm(Index: Integer): TCustomForm; +var + Page: TJvDockTabSheet; +begin + Result := nil; + + if (Index > -1) and (Index < Count) then + begin + Page := Pages[Index]; + if Assigned(Page) and (Page.ControlCount = 1) and (Page.Controls[0] is TCustomForm) then + begin + Result := TCustomForm(Page.Controls[0]); + end + end; +end; + +function TJvDockTabPageControl.GetDockStyle: TJvDockObservableStyle; +begin + Result := FStyleLink.DockStyle; +end; + function TJvDockTabPageControl.GetParentForm: TJvDockTabHostForm; begin if Parent is TJvDockTabHostForm then @@ -5038,6 +5137,7 @@ procedure TJvDockTabPageControl.LoadFromStream(Stream: TStream); AControl.ManualDock(Self, nil, alClient); { DockClients[Index] is always AControl? } DockClients[Index].Visible := Boolean(SheetVisible); + // KV if (Self is TJvDockVSNETTabPageControl) and (Index = Count - 1) then TJvDockVSNETTabSheet(Pages[Index]).OldVisible := Boolean(SheetVisible); Inc(Index); @@ -5102,11 +5202,6 @@ procedure TJvDockTabPageControl.SyncWithStyle; TabPosition := DockStyle.TabServerOption.TabPosition; end; -function TJvDockTabPageControl.GetDockStyle: TJvDockObservableStyle; -begin - Result := FStyleLink.DockStyle; -end; - //=== { TJvGlobalDockManager } =============================================== constructor TJvGlobalDockManager.Create; @@ -5243,17 +5338,11 @@ procedure TJvGlobalDockManager.UnRegisterDockServer( end; procedure InitDockManager; -var - OSVersionInfo: TOSVersionInfo; begin try JvGlobalDockManager.Free; JvGlobalDockManager := nil; JvGlobalDockManager := TJvGlobalDockManager.Create; - - OSVersionInfo.dwOSVersionInfoSize := SizeOf(OSVersionInfo); - GetVersionEx(OSVersionInfo); - IsWinXP := (OSVersionInfo.dwMajorVersion = 5) and (OSVersionInfo.dwMinorVersion = 1); except end; end; diff --git a/JvDockInfo.pas b/JvDockInfo.pas index bfefdabd7..048849429 100644 --- a/JvDockInfo.pas +++ b/JvDockInfo.pas @@ -21,7 +21,7 @@ Known Issues: -----------------------------------------------------------------------------} -// $Id: JvDockInfo.pas 10949 2006-09-29 12:37:30Z obones $ +// $Id: JvDockInfo.pas 11252 2007-04-05 22:12:55Z remkobonte $ unit JvDockInfo; @@ -175,9 +175,9 @@ TJvDockInfoTree = class(TJvDockBaseTree) {$IFDEF UNITVERSIONING} const UnitVersioning: TUnitVersionInfo = ( - RCSfile: '$URL: https://jvcl.svn.sourceforge.net/svnroot/jvcl/branches/JVCL3_30_PREPARATION/run/JvDockInfo.pas $'; - Revision: '$Revision: 10949 $'; - Date: '$Date: 2006-09-29 14:37:30 +0200 (ven., 29 sept. 2006) $'; + RCSfile: '$URL: https://jvcl.svn.sourceforge.net:443/svnroot/jvcl/trunk/jvcl/run/JvDockInfo.pas $'; + Revision: '$Revision: 11252 $'; + Date: '$Date: 2007-04-05 15:12:55 -0700 (Thu, 05 Apr 2007) $'; LogPath: 'JVCL\run' ); {$ENDIF UNITVERSIONING} @@ -1189,7 +1189,9 @@ procedure TJvDockInfoZone.SetDockInfoFromNodeToControl(Control: TControl); TWinControl(Control).EnableAlign; end; end; - Control.Visible := Visible; + // KV to avoid flickering in Vista + //if not ((Control is TForm) and (ParentName <> '')) and Assigned(FindDockClient(Control)) then + Control.Visible := Visible; Control.LRDockWidth := LRDockWidth; Control.TBDockHeight := TBDockHeight; Control.UnDockHeight := UnDockHeight; diff --git a/JvDockSupportControl.pas b/JvDockSupportControl.pas new file mode 100644 index 000000000..c337a7a8d --- /dev/null +++ b/JvDockSupportControl.pas @@ -0,0 +1,3761 @@ +{----------------------------------------------------------------------------- +The contents of this file are subject to the Mozilla Public License +Version 1.1 (the "License"); you may not use this file except in compliance +with the License. You may obtain a copy of the License at +http://www.mozilla.org/MPL/MPL-1.1.html + +Software distributed under the License is distributed on an "AS IS" basis, +WITHOUT WARRANTY OF ANY KIND, either expressed or implied. See the License for +the specific language governing rights and limitations under the License. + +The Original Code is: JvDockSupportControl.pas, released on 2003-12-31. + +The Initial Developer of the Original Code is luxiaoban. +Portions created by luxiaoban are Copyright (C) 2002, 2003 luxiaoban. +All Rights Reserved. + +Contributor(s): + +You may retrieve the latest version of this file at the Project JEDI's JVCL home page, +located at http://jvcl.sourceforge.net + +Known Issues: +-----------------------------------------------------------------------------} +// $Id: JvDockSupportControl.pas 10836 2006-07-23 17:46:20Z jfudickar $ + +unit JvDockSupportControl; + +{$I jvcl.inc} + +interface + +uses + {$IFDEF USEJVCL} + {$IFDEF UNITVERSIONING} + JclUnitVersioning, + {$ENDIF UNITVERSIONING} + {$ENDIF USEJVCL} + Messages, Windows, CommCtrl, Graphics, Controls, Forms, Classes, ExtCtrls, + ComCtrls, ImgList, + {$IFDEF USEJVCL} + JvComponent, JvAppStorage, + {$ENDIF USEJVCL} + JvDockTree; + +type +{$IFDEF DELPHI6_UP} + TJvAlphaBlendedForm = class(TForm) + private + { Private declarations } + protected + procedure CreateParams(var Params: TCreateParams); override; + public + { Public declarations } + end; +{$ENDIF DELPHI6_UP} + + TJvDockDragDockObject = class(TObject) + private + // FDockClient:TObject;{NEW: Opaque reference to TJvDockClient} + FMouseDeltaX: Double; + FMouseDeltaY: Double; + FControl: TControl; + FDragTarget: Pointer; + FDragPos: TPoint; + FDropOnControl: TControl; + FDropAlign: TAlign; + FDragHandle: THandle; + FDragTargetPos: TPoint; + FCancelling: Boolean; + FFloating: Boolean; + FFrameWidth: Integer; + FBrush: TBrush; + FCtrlDown: Boolean; + FDockRect: TRect; + FEraseDockRect: TRect; + procedure SetBrush(const Value: TBrush); + procedure SetDropAlign(const Value: TAlign); + procedure SetDropOnControl(const Value: TControl); + function GetTargetControl: TWinControl; + procedure SetTargetControl(const Value: TWinControl); + protected +{$IFDEF DELPHI6_UP} + AlphaBlendedForm : TJvAlphaBlendedForm; +{$ENDIF DELPHI6_UP} + procedure DefaultDockImage(Erase: Boolean); virtual; + procedure DrawDragRect(DoErase: Boolean); virtual; + procedure GetBrush_PenSize_DrawRect( + var ABrush: TBrush; var PenSize: Integer; var DrawRect: TRect; Erase: Boolean); virtual; + function GetFrameWidth: Integer; virtual; + procedure SetFrameWidth(const Value: Integer); virtual; + procedure MouseMsg(var Msg: TMessage); virtual; + function CanLeave(NewTarget: TWinControl): Boolean; virtual; + public + constructor Create(AControl: TControl); virtual; + destructor Destroy; override; + + procedure AdjustDockRect(const ARect: TRect); virtual; + function Capture: THandle; + function DragFindWindow(const Pos: TPoint): THandle; virtual; + procedure ReleaseCapture(Handle: THandle); + procedure EndDrag(Target: TObject; X, Y: Integer); virtual; + procedure Finished(Target: TObject; X, Y: Integer; Accepted: Boolean); virtual; + function GetDragCursor(Accepted: Boolean; X, Y: Integer): TCursor; virtual; + function GetDragImages: TDragImageList; virtual; + procedure DrawDragDockImage; virtual; + procedure EraseDragDockImage; virtual; + function GetDropCtl: TControl; virtual; + + property MouseDeltaX: Double read FMouseDeltaX write FMouseDeltaX; + property MouseDeltaY: Double read FMouseDeltaY write FMouseDeltaY; + property Control: TControl read FControl write FControl; + property DockRect: TRect read FDockRect write FDockRect; + property DragTarget: Pointer read FDragTarget write FDragTarget; + property DragPos: TPoint read FDragPos write FDragPos; + property DropOnControl: TControl read FDropOnControl write SetDropOnControl; + property DropAlign: TAlign read FDropAlign write SetDropAlign; + property DragHandle: THandle read FDragHandle write FDragHandle; + property DragTargetPos: TPoint read FDragTargetPos write FDragTargetPos; + property EraseDockRect: TRect read FEraseDockRect; + property Cancelling: Boolean read FCancelling write FCancelling; + property Floating: Boolean read FFloating write FFloating; + property FrameWidth: Integer read GetFrameWidth write SetFrameWidth; + property Brush: TBrush read FBrush write SetBrush; + property CtrlDown: Boolean read FCtrlDown write FCtrlDown; + property TargetControl: TWinControl read GetTargetControl write SetTargetControl; + + {DockClient: Opaque reference to TJvDockClient. Nil if none.} + // property DockClient:TObject read FDockClient write FDockClient; + end; + + {$IFDEF USEJVCL} + TJvDockCustomControl = class(TJvCustomControl) + {$ELSE} + TJvDockCustomControl = class(TCustomControl) + {$ENDIF USEJVCL} + private + function GetJvDockManager: IJvDockManager; + protected + procedure WndProc(var Msg: TMessage); override; + procedure CustomStartDock(var Source: TJvDockDragDockObject); virtual; + procedure CustomGetSiteInfo(Source: TJvDockDragDockObject; + Client: TControl; var InfluenceRect: TRect; MousePos: TPoint; + var CanDock: Boolean); virtual; + procedure CustomDockOver(Source: TJvDockDragDockObject; X, Y: Integer; + State: TDragState; var Accept: Boolean); virtual; + procedure CustomPositionDockRect(Source: TJvDockDragDockObject; X, Y: Integer); virtual; + procedure CustomDockDrop(Source: TJvDockDragDockObject; X, Y: Integer); virtual; + procedure CustomEndDock(Target: TObject; X, Y: Integer); virtual; + function CustomUnDock(Source: TJvDockDragDockObject; NewTarget: TWinControl; Client: TControl): Boolean; virtual; + procedure CustomGetDockEdge(Source: TJvDockDragDockObject; MousePos: TPoint; var DropAlign: TAlign); virtual; + public + procedure UpdateCaption(Exclude: TControl); virtual; + property DockManager; + property JvDockManager: IJvDockManager read GetJvDockManager{ write SetJvDockManager}; + end; + + TJvDockCustomPanel = class(TJvDockCustomControl) + protected + function CreateDockManager: IDockManager; override; + public + constructor Create(AOwner: TComponent); override; + destructor Destroy; override; + property DockSite; + end; + + TJvDockCustomTabControl = class; + + TJvDockTabStrings = class(TStrings) + private + FTabControl: TJvDockCustomTabControl; + protected + function Get(Index: Integer): string; override; + function GetCount: Integer; override; + function GetObject(Index: Integer): TObject; override; + procedure Put(Index: Integer; const S: string); override; + procedure PutObject(Index: Integer; AObject: TObject); override; + procedure SetUpdateState(Updating: Boolean); override; + public + procedure Clear; override; + procedure Delete(Index: Integer); override; + procedure Insert(Index: Integer; const S: string); override; + end; + + TJvDockDrawTabEvent = procedure(Control: TJvDockCustomTabControl; TabIndex: Integer; + const Rect: TRect; Active: Boolean) of object; + + TJvDockPageControl = class; + + TJvDockCustomTabControl = class(TJvDockCustomControl) + private + FHotTrack: Boolean; + FImageChangeLink: TChangeLink; + FImages: TCustomImageList; + FMultiLine: Boolean; + FMultiSelect: Boolean; + FOwnerDraw: Boolean; + FRaggedRight: Boolean; + FSaveTabIndex: Integer; + FSaveTabs: TStringList; + FScrollOpposite: Boolean; + FStyle: TTabStyle; + FTabPosition: TTabPosition; + FTabs: TJvDockTabStrings; + FTabSize: TSmallPoint; + FUpdating: Boolean; + FSavedAdjustRect: TRect; + FOnChange: TNotifyEvent; + FOnChanging: TTabChangingEvent; + FOnDrawTab: TJvDockDrawTabEvent; + FOnGetImageIndex: TTabGetImageEvent; + function GetDisplayRect: TRect; + function GetTabIndex: Integer; + function GetTabs: TStrings; + procedure ImageListChange(Sender: TObject); + function InternalSetMultiLine(Value: Boolean): Boolean; + procedure SetMultiLine(Value: Boolean); + procedure SetMultiSelect(Value: Boolean); + procedure SetOwnerDraw(Value: Boolean); + procedure SetRaggedRight(Value: Boolean); + procedure SetScrollOpposite(Value: Boolean); + procedure SetStyle(Value: TTabStyle); + procedure SetTabIndex(Value: Integer); + procedure SetTabs(Value: TStrings); + procedure SetTabWidth(Value: Smallint); + procedure TabsChanged; + procedure UpdateTabSize; + procedure CMFontChanged(var Msg); message CM_FONTCHANGED; + procedure CMSysColorChange(var Msg: TMessage); message CM_SYSCOLORCHANGE; + procedure CMTabStopChanged(var Msg: TMessage); message CM_TABSTOPCHANGED; + procedure CNNotify(var Msg: TWMNotify); message CN_NOTIFY; + procedure CMDialogChar(var Msg: TCMDialogChar); message CM_DIALOGCHAR; + procedure CNDrawItem(var Msg: TWMDrawItem); message CN_DRAWITEM; + procedure TCMAdjustRect(var Msg: TMessage); message TCM_ADJUSTRECT; + procedure WMDestroy(var Msg: TWMDestroy); message WM_DESTROY; + procedure WMNotifyFormat(var Msg: TMessage); message WM_NOTIFYFORMAT; + procedure WMSize(var Msg: TMessage); message WM_SIZE; + protected + procedure AdjustClientRect(var Rect: TRect); override; + function CanChange: Boolean; dynamic; + function CanShowTab(TabIndex: Integer): Boolean; virtual; + procedure Change; dynamic; + procedure CreateParams(var Params: TCreateParams); override; + procedure CreateWnd; override; + procedure DrawTab(TabIndex: Integer; const Rect: TRect; Active: Boolean); virtual; + function GetImageIndex(TabIndex: Integer): Integer; virtual; + procedure Loaded; override; + procedure Notification(AComponent: TComponent; Operation: TOperation); override; + procedure PaintWindow(DC: HDC); override; + procedure SetHotTrack(Value: Boolean); virtual; + procedure SetImages(Value: TCustomImageList); virtual; + procedure SetTabHeight(Value: Smallint); virtual; + procedure SetTabPosition(Value: TTabPosition); virtual; + procedure UpdateTabImages; + property DisplayRect: TRect read GetDisplayRect; + property HotTrack: Boolean read FHotTrack write SetHotTrack default False; + property Images: TCustomImageList read FImages write SetImages; + property MultiLine: Boolean read FMultiLine write SetMultiLine default False; + property MultiSelect: Boolean read FMultiSelect write SetMultiSelect default False; + property OwnerDraw: Boolean read FOwnerDraw write SetOwnerDraw default False; + property RaggedRight: Boolean read FRaggedRight write SetRaggedRight default False; + property ScrollOpposite: Boolean read FScrollOpposite + write SetScrollOpposite default False; + property Style: TTabStyle read FStyle write SetStyle default tsTabs; + property TabHeight: Smallint read FTabSize.Y write SetTabHeight default 0; + property TabIndex: Integer read GetTabIndex write SetTabIndex default -1; + property TabPosition: TTabPosition read FTabPosition write SetTabPosition default tpTop; + property Tabs: TStrings read GetTabs write SetTabs; + property TabWidth: Smallint read FTabSize.X write SetTabWidth default 0; + property OnChange: TNotifyEvent read FOnChange write FOnChange; + property OnChanging: TTabChangingEvent read FOnChanging write FOnChanging; + property OnDrawTab: TJvDockDrawTabEvent read FOnDrawTab write FOnDrawTab; + property OnGetImageIndex: TTabGetImageEvent read FOnGetImageIndex write FOnGetImageIndex; + public + constructor Create(AOwner: TComponent); override; + destructor Destroy; override; + function IndexOfTabAt(X, Y: Integer): Integer; + function GetHitTestInfoAt(X, Y: Integer): THitTests; + function TabRect(Index: Integer): TRect; + function RowCount: Integer; + procedure ScrollTabs(Delta: Integer); + property TabStop default True; + end; + + {$IFDEF USEJVCL} + TJvDockTabSheet = class(TJvWinControl) + {$ELSE} + TJvDockTabSheet = class(TWinControl) + {$ENDIF USEJVCL} + private + FImageIndex: TImageIndex; + FPageControl: TJvDockPageControl; + FTabVisible: Boolean; + FTabShowing: Boolean; + FHighlighted: Boolean; + FOnHide: TNotifyEvent; + FOnShow: TNotifyEvent; + function GetPageIndex: Integer; + function GetTabIndex: Integer; + procedure SetHighlighted(Value: Boolean); + procedure SetImageIndex(Value: TImageIndex); + procedure SetPageIndex(Value: Integer); + procedure SetTabShowing(Value: Boolean); + procedure SetTabVisible(Value: Boolean); + procedure CMTextChanged(var Msg: TMessage); message CM_TEXTCHANGED; + procedure CMShowingChanged(var Msg: TMessage); message CM_SHOWINGCHANGED; + protected + procedure CreateParams(var Params: TCreateParams); override; + procedure SetPageControl(APageControl: TJvDockPageControl); virtual; + procedure ReadState(Reader: TReader); override; + procedure DoHide; dynamic; + procedure DoShow; dynamic; + procedure UpdateTabShowing; dynamic; + public + constructor Create(AOwner: TComponent); override; + destructor Destroy; override; + property PageControl: TJvDockPageControl read FPageControl write SetPageControl; + property TabIndex: Integer read GetTabIndex; + published + property Caption; + property Height stored False; + property Highlighted: Boolean read FHighlighted write SetHighlighted default False; + property ImageIndex: TImageIndex read FImageIndex write SetImageIndex default -1; + property Left stored False; + property PageIndex: Integer read GetPageIndex write SetPageIndex stored False; + property TabVisible: Boolean read FTabVisible write SetTabVisible default True; + property Top stored False; + property Visible stored False; + property Width stored False; + property OnHide: TNotifyEvent read FOnHide write FOnHide; + property OnShow: TNotifyEvent read FOnShow write FOnShow; + end; + + TJvDockTabSheetClass = class of TJvDockTabSheet; + + TJvDockPageControl = class(TJvDockCustomTabControl) + private + FPages: TList; + FActivePage: TJvDockTabSheet; + FNewDockSheet: TJvDockTabSheet; + FUndockingPage: TJvDockTabSheet; + FTabSheetClass: TJvDockTabSheetClass; + procedure ChangeActivePage(Page: TJvDockTabSheet); + procedure DeleteTab(Page: TJvDockTabSheet; Index: Integer); + function GetActivePageIndex: Integer; + function GetPage(Index: Integer): TJvDockTabSheet; + function GetCount: Integer; + procedure InsertPage(Page: TJvDockTabSheet); + procedure InsertTab(Page: TJvDockTabSheet); + procedure MoveTab(CurIndex, NewIndex: Integer); + procedure RemovePage(Page: TJvDockTabSheet); + procedure SetActivePageIndex(const Value: Integer); + procedure UpdateTab(Page: TJvDockTabSheet); + procedure UpdateTabHighlights; + procedure CMDesignHitTest(var Msg: TCMDesignHitTest); message CM_DESIGNHITTEST; + procedure CMDialogKey(var Msg: TCMDialogKey); message CM_DIALOGKEY; + procedure CMDockClient(var Msg: TCMDockClient); message CM_DOCKCLIENT; + procedure CMDockNotification(var Msg: TCMDockNotification); message CM_DOCKNOTIFICATION; + procedure CMUnDockClient(var Msg: TCMUnDockClient); message CM_UNDOCKCLIENT; + procedure WMLButtonDown(var Msg: TWMLButtonDown); message WM_LBUTTONDOWN; + procedure WMLButtonDblClk(var Msg: TWMLButtonDblClk); message WM_LBUTTONDBLCLK; + procedure WMLButtonUp(var Msg: TWMLButtonUp); message WM_LBUTTONUP; + procedure WMRButtonDown(var Msg: TWMRButtonDown); message WM_RBUTTONDOWN; + procedure WMRButtonDblClk(var Msg: TWMRButtonDblClk); message WM_RBUTTONDBLCLK; + procedure WMRButtonUp(var Msg: TWMRButtonUp); message WM_RBUTTONUP; + procedure WMMButtonDown(var Msg: TWMMButtonDown); message WM_MBUTTONDOWN; + procedure WMMButtonDblClk(var Msg: TWMMButtonDblClk); message WM_MBUTTONDBLCLK; + procedure WMMButtonUp(var Msg: TWMMButtonUp); message WM_MBUTTONUP; + protected + function CanShowTab(TabIndex: Integer): Boolean; override; + procedure Change; override; + procedure DoAddDockClient(Client: TControl; const ARect: TRect); override; + procedure DockOver(Source: TDragDockObject; X, Y: Integer; + State: TDragState; var Accept: Boolean); override; + function DoMouseEvent(var Msg: TWMMouse; Control: TControl): TWMNCHitMessage; virtual; + procedure DoRemoveDockClient(Client: TControl); override; + procedure GetChildren(Proc: TGetChildProc; Root: TComponent); override; + function GetDockClientFromMousePos(MousePos: TPoint): TControl; virtual; + function GetImageIndex(TabIndex: Integer): Integer; override; + function GetPageFromDockClient(Client: TControl): TJvDockTabSheet; + procedure GetSiteInfo(Client: TControl; var InfluenceRect: TRect; + MousePos: TPoint; var CanDock: Boolean); override; + procedure Loaded; override; + procedure SetActivePage(Page: TJvDockTabSheet); virtual; + procedure ShowControl(AControl: TControl); override; + procedure UpdateActivePage; virtual; + public + constructor Create(AOwner: TComponent); override; + destructor Destroy; override; + function FindNextPage(CurPage: TJvDockTabSheet; + GoForward, CheckTabVisible: Boolean): TJvDockTabSheet; + procedure SelectNextPage(GoForward: Boolean; CheckTabVisible: Boolean = True); + procedure SetChildOrder(Child: TComponent; Order: Integer); override; + property ActivePage: TJvDockTabSheet read FActivePage write SetActivePage; + property ActivePageIndex: Integer read GetActivePageIndex + write SetActivePageIndex; + property Count: Integer read GetCount; + property Pages[Index: Integer]: TJvDockTabSheet read GetPage; + property PageSheets: TList read FPages; + property TabSheetClass: TJvDockTabSheetClass read FTabSheetClass write FTabSheetClass; + end; + + TJvDockDragOperation = (dopNone, dopDrag, dopDock); + + PSiteInfoRec = ^TSiteInfoRec; + TSiteInfoRec = record + Site: TWinControl; + TopParent: THandle; + end; + + TSiteList = class(TList) + public + procedure AddSite(ASite: TWinControl); + procedure Clear; override; + function Find(ParentWnd: THandle; var Index: Integer): Boolean; + function GetTopSite: TWinControl; + end; + + TJvDockManager = class(TObject) + private + FLoadCount: Integer; + FSaveCount: Integer; + FDragObject: TJvDockDragDockObject; + FDragControl: TControl; + FDragFreeObject: Boolean; + FDragCapture: THandle; + FDragStartPos: TPoint; + FDragSaveCursor: HCURSOR; + FDragThreshold: Integer; + FActiveDrag: TJvDockDragOperation; + FDragImageList: TDragImageList; + FDockSiteList: TList; + FQualifyingSites: TSiteList; + procedure BeginLoad; + procedure EndLoad; + procedure BeginSave; + procedure EndSave; + public + procedure CalcDockSizes(Control: TControl); + constructor Create; virtual; + destructor Destroy; override; + function IsDockLoading: Boolean; + function IsSaving: Boolean; + procedure ShowDockForm(DockWindow: TWinControl); + procedure HideDockForm(DockWindow: TWinControl); + function GetFormVisible(DockWindow: TWinControl): Boolean; + procedure SetTabDockHostBorderStyle(Value: TFormBorderStyle); + procedure SetConjoinDockHostBorderStyle(Value: TFormBorderStyle); + {$IFDEF USEJVCL} + procedure SaveDockTreeToAppStorage(AppStorage: TJvCustomAppStorage; const AppStoragePath: string = ''); + procedure LoadDockTreeFromAppStorage(AppStorage: TJvCustomAppStorage; const AppStoragePath: string = ''); + {$ELSE} + procedure SaveDockTreeToFile(const FileName: string); + procedure LoadDockTreeFromFile(const FileName: string); + procedure SaveDockTreeToReg(RootKey: DWORD; const RegPatch: string); + procedure LoadDockTreeFromReg(RootKey: DWORD; const RegPatch: string); + {$ENDIF USEJVCL} + procedure BeginDrag(Control: TControl; + Immediate: Boolean; Threshold: Integer = -1); virtual; + procedure DragInitControl(Control: TControl; + Immediate: Boolean; Threshold: Integer); virtual; + procedure DragInit(ADragObject: TJvDockDragDockObject; + Immediate: Boolean; Threshold: Integer); virtual; + procedure DragTo(const Pos: TPoint); virtual; + procedure DragDone(Drop: Boolean); virtual; + procedure CancelDrag; virtual; + procedure ResetCursor; virtual; + function DragFindTarget(const Pos: TPoint; var Handle: THandle; + DragKind: TDragKind; Client: TControl): Pointer; virtual; + procedure DoGetSiteInfo(Target, Client: TControl; var InfluenceRect: TRect; + MousePos: TPoint; var CanDock: Boolean); virtual; + function DoDockOver(DragState: TDragState): Boolean; virtual; + procedure DoDockDrop(Source: TJvDockDragDockObject; Pos: TPoint); virtual; + function DoUnDock(Source: TJvDockDragDockObject; Target: TWinControl; Client: TControl): Boolean; virtual; + procedure DoEndDrag(Target: TObject; X, Y: Integer); virtual; + function DragFindWindow(const Pos: TPoint): THandle; virtual; + function GetDockSiteAtPos(MousePos: TPoint; Client: TControl): TWinControl; virtual; + procedure DoGetDockEdge(Target: TControl; MousePos: TPoint; var DropAlign: TAlign); virtual; + procedure RegisterDockSite(Site: TWinControl; DoRegister: Boolean); virtual; + property DragObject: TJvDockDragDockObject read FDragObject write FDragObject; + end; + + {$IFDEF USEJVCL} + TJvDockCustomPanelSplitter = class(TJvCustomControl) + {$ELSE} + TJvDockCustomPanelSplitter = class(TCustomControl) + {$ENDIF USEJVCL} + private + FActiveControl: TWinControl; + FAutoSnap: Boolean; + FBeveled: Boolean; + FBrush: TBrush; + FControl: TControl; + FDownPos: TPoint; + FLineDC: HDC; + FLineVisible: Boolean; + FMinSize: NaturalNumber; + FMaxSize: Integer; + FNewSize: Integer; + FOldKeyDown: TKeyEvent; + FOldSize: Integer; + FPrevBrush: HBRUSH; + FResizeStyle: TResizeStyle; + FSplit: Integer; + FOnCanResize: TCanResizeEvent; + FOnMoved: TNotifyEvent; + FOnPaint: TNotifyEvent; + procedure AllocateLineDC; + procedure CalcSplitSize(X, Y: Integer; var NewSize, Split: Integer); + procedure DrawLine; + procedure FocusKeyDown(Sender: TObject; var Key: Word; Shift: TShiftState); + procedure ReleaseLineDC; + procedure SetBeveled(Value: Boolean); + procedure UpdateControlSize; + procedure UpdateSize(X, Y: Integer); + protected + function CanResize(var NewSize: Integer): Boolean; reintroduce; virtual; + function DoCanResize(var NewSize: Integer): Boolean; virtual; + function FindControl: TControl; virtual; + procedure MouseDown(Button: TMouseButton; Shift: TShiftState; + X, Y: Integer); override; + procedure MouseMove(Shift: TShiftState; X, Y: Integer); override; + procedure MouseUp(Button: TMouseButton; Shift: TShiftState; + X, Y: Integer); override; + procedure Paint; override; + procedure RequestAlign; override; + procedure StopSizing; dynamic; + public + constructor Create(AOwner: TComponent); override; + destructor Destroy; override; + property Canvas; + published + property Align default alLeft; + property AutoSnap: Boolean read FAutoSnap write FAutoSnap default True; + property Beveled: Boolean read FBeveled write SetBeveled default False; + property Color; + property Constraints; + property MinSize: NaturalNumber read FMinSize write FMinSize default 30; + property ParentColor; + property ResizeStyle: TResizeStyle read FResizeStyle write FResizeStyle + default rsPattern; + property Visible; + property OnCanResize: TCanResizeEvent read FOnCanResize write FOnCanResize; + property OnMoved: TNotifyEvent read FOnMoved write FOnMoved; + property OnPaint: TNotifyEvent read FOnPaint write FOnPaint; + end; + +{$IFDEF USEJVCL} +{$IFDEF UNITVERSIONING} +const + UnitVersioning: TUnitVersionInfo = ( + RCSfile: '$URL: https://jvcl.svn.sourceforge.net:443/svnroot/jvcl/trunk/jvcl/run/JvDockSupportControl.pas $'; + Revision: '$Revision: 10836 $'; + Date: '$Date: 2006-07-23 10:46:20 -0700 (Sun, 23 Jul 2006) $'; + LogPath: 'JVCL\run' + ); +{$ENDIF UNITVERSIONING} +{$ENDIF USEJVCL} + +implementation + +uses + ComStrs, Consts, SysUtils, + JvDockGlobals, JvDockControlForm, JvDockSupportProc; + +type + TlbNCButtonProc = procedure(Msg: TWMNCHitMessage; Button: TMouseButton; + MouseStation: TJvDockMouseStation) of object; + + PCheckTargetInfo = ^TCheckTargetInfo; + TCheckTargetInfo = record + ClientWnd: THandle; + TargetWnd: THandle; + CurrentWnd: THandle; + MousePos: TPoint; + Found: Boolean; + end; + + TControlAccessProtected = class(TControl); + TWinControlAccessProtected = class(TWinControl); + +//=== Local procedures ======================================================= + +function ButtonEvent(Page: TJvDockPageControl; Msg: TWMMouse; + Button: TMouseButton; MouseStation: TJvDockMouseStation; Proc: TlbNCButtonProc): TControl; +begin + Result := Page.GetDockClientFromMousePos(SmallPointToPoint(Msg.Pos)); + if (Result <> nil) and Assigned(Proc) then + begin + JvGlobalDockClient := FindDockClient(Result); + Proc(Page.DoMouseEvent(Msg, Page), Button, MouseStation); + end; +end; + +procedure TabControlError(const S: string); +begin + raise EListError.Create(S); +end; + +procedure SetComCtlStyle(Ctl: TWinControl; Value: Integer; UseStyle: Boolean); +var + Style: Integer; +begin + if Ctl.HandleAllocated then + begin + Style := GetWindowLong(Ctl.Handle, GWL_STYLE); + if not UseStyle then + Style := Style and not Value + else + Style := Style or Value; + SetWindowLong(Ctl.Handle, GWL_STYLE, Style); + end; +end; + +function IsBeforeTargetWindow(Window: HWND; Data: Longint): Bool; stdcall; +var + R: TRect; +begin + if Window = PCheckTargetInfo(Data)^.TargetWnd then + Result := False + else + begin + if PCheckTargetInfo(Data)^.CurrentWnd = 0 then + begin + GetWindowRect(Window, R); + if PtInRect(R, PCheckTargetInfo(Data)^.MousePos) then + PCheckTargetInfo(Data)^.CurrentWnd := Window; + end; + if Window = PCheckTargetInfo(Data)^.CurrentWnd then + begin + Result := False; + PCheckTargetInfo(Data)^.Found := True; + end + else + if Window = PCheckTargetInfo(Data)^.ClientWnd then + begin + Result := True; + PCheckTargetInfo(Data)^.CurrentWnd := 0; + end + else + Result := True; + end; +end; + +//=== { TJvDockCustomControl } =============================================== + +procedure TJvDockCustomControl.CustomDockDrop(Source: TJvDockDragDockObject; + X, Y: Integer); +var + DestRect: TRect; + Form: TCustomForm; +begin + DestRect := Source.DockRect; + MapWindowPoints(0, Handle, DestRect, 2); + DisableAlign; + try + Source.Control.Dock(Self, DestRect); + if UseDockManager and (DockManager <> nil) then + DockManager.InsertControl(Source.Control, + Source.DropAlign, Source.DropOnControl); + finally + EnableAlign; + end; + Form := GetParentForm(Self); + if Form <> nil then + Form.BringToFront; + + if Source.Control is TForm then + begin + TForm(Source.Control).ActiveControl := nil; + SetDockSite(TForm(Source.Control), False); + end; +end; + +procedure TJvDockCustomControl.CustomDockOver(Source: TJvDockDragDockObject; + X, Y: Integer; State: TDragState; var Accept: Boolean); +begin + CustomPositionDockRect(Source, X, Y); +end; + +procedure TJvDockCustomControl.CustomEndDock(Target: TObject; X, Y: Integer); +begin +end; + +procedure TJvDockCustomControl.CustomGetDockEdge(Source: TJvDockDragDockObject; + MousePos: TPoint; var DropAlign: TAlign); +begin + DropAlign := GetDockEdge(MousePos); +end; + +procedure TJvDockCustomControl.CustomGetSiteInfo(Source: TJvDockDragDockObject; + Client: TControl; var InfluenceRect: TRect; MousePos: TPoint; var CanDock: Boolean); +begin + GetWindowRect(Handle, InfluenceRect); + InflateRect(InfluenceRect, DefExpandoRect, DefExpandoRect); +end; + +procedure TJvDockCustomControl.CustomPositionDockRect(Source: TJvDockDragDockObject; + X, Y: Integer); +var + NewWidth, NewHeight: Integer; + TempX, TempY: Double; + R: TRect; +begin + with Source do + begin + if (DragTarget = nil) or (not TWinControlAccessProtected(DragTarget).UseDockManager) then + begin + NewWidth := Control.UndockWidth; + NewHeight := Control.UndockHeight; + TempX := DragPos.X - ((NewWidth) * MouseDeltaX); + TempY := DragPos.Y - ((NewHeight) * MouseDeltaY); + with DockRect do + begin + Left := Round(TempX); + Top := Round(TempY); + Right := Left + NewWidth; + Bottom := Top + NewHeight; + end; + AdjustDockRect(DockRect); + end + else + begin + GetWindowRect(TargetControl.Handle, R); + DockRect := R; + if TWinControlAccessProtected(DragTarget).UseDockManager then + if TargetControl is TJvDockCustomPanel then + if TJvDockCustomPanel(DragTarget).JvDockManager <> nil then + begin + R := DockRect; + TJvDockCustomPanel(DragTarget).JvDockManager.PositionDockRect(Control, + DropOnControl, DropAlign, R); + DockRect := R; + end; + end; + end; +end; + +procedure TJvDockCustomControl.CustomStartDock(var Source: TJvDockDragDockObject); +begin +end; + +function TJvDockCustomControl.CustomUnDock(Source: TJvDockDragDockObject; + NewTarget: TWinControl; Client: TControl): Boolean; +begin + Result := (Perform(CM_UNDOCKCLIENT, Integer(NewTarget), Integer(Client)) = 0); +end; + +function TJvDockCustomControl.GetJvDockManager: IJvDockManager; +begin + Result := IJvDockManager(DockManager); +end; + +procedure TJvDockCustomControl.UpdateCaption(Exclude: TControl); +var + I: Integer; + Host: TJvDockableForm; +begin + if Parent is TJvDockableForm then + begin + Host := TJvDockableForm(Parent); + Host.Caption := ''; + + for I := 0 to Host.DockableControl.DockClientCount - 1 do + if Host.DockableControl.DockClients[I].Visible and (Host.DockableControl.DockClients[I] <> Exclude) then + Host.Caption := Host.Caption + TCustomForm(Host.DockableControl.DockClients[I]).Caption + RsDockStringSplitter; + + if Host.HostDockSite is TJvDockTabPageControl then + with TJvDockTabPageControl(Host.HostDockSite) do + if (ActivePage <> nil) and (ActivePage.Controls[0] = Self) then + ActivePage.Caption := Host.Caption; + if Host.HostDockSite is TJvDockCustomControl then + TJvDockCustomControl(Host.HostDockSite).UpdateCaption(nil); + end; +end; + +procedure TJvDockCustomControl.WndProc(var Msg: TMessage); +var + CMUnDockClient: TCMUnDockClient; + DockableForm: TJvDockableForm; +begin + if Msg.Msg = CM_UNDOCKCLIENT then + begin + CMUnDockClient := TCMUnDockClient(Msg); + if CMUnDockClient.Client is TJvDockableForm then + begin + DockableForm := TJvDockableForm(CMUnDockClient.Client); + if DockableForm.FloatingChild <> nil then + begin + if Self is TJvDockTabPageControl then + DockableForm.FloatingChild.ManualDock(Self) + else + begin + DisableAlign; + try + { using a null-rect as parameter for Dock causes align problems } +// DockableForm.FloatingChild.Dock(Self, Rect(0, 0, 0, 0)); + DockableForm.FloatingChild.Dock(Self, Self.BoundsRect); + finally + EnableAlign; + end; + end; + DockableForm.FloatingChild.Visible := True; + if Self is TJvDockCustomPanel then + JvDockManager.ReplaceZoneChild(DockableForm, DockableForm.FloatingChild); + end; + end; + end; + inherited WndProc(Msg); +end; + +//=== { TJvDockCustomPanel } ================================================= + +constructor TJvDockCustomPanel.Create(AOwner: TComponent); +begin + inherited Create(AOwner); + ControlStyle := [csAcceptsControls, csCaptureMouse, csClickEvents, + csSetCaption, csOpaque, csDoubleClicks, csReplicatable]; + Color := clBtnFace; + UseDockManager := True; +end; + +destructor TJvDockCustomPanel.Destroy; +begin + SetDockSite(Self, False); + inherited Destroy; +end; + +function TJvDockCustomPanel.CreateDockManager: IDockManager; +begin + if (DockManager = nil) and DockSite and UseDockManager then + Result := DefaultDockTreeClass.Create(Self, DefaultDockZoneClass, nil) as IJvDockManager + else + Result := DockManager; + DoubleBuffered := DoubleBuffered or (Result <> nil); +end; + +//=== { TJvDockCustomPanelSplitter } ========================================= + +constructor TJvDockCustomPanelSplitter.Create(AOwner: TComponent); +begin + inherited Create(AOwner); + FAutoSnap := True; + Align := alLeft; + Width := 3; + Cursor := crHSplit; + FMinSize := 30; + FResizeStyle := rsPattern; + FOldSize := -1; +end; + +destructor TJvDockCustomPanelSplitter.Destroy; +begin + FBrush.Free; + inherited Destroy; +end; + +procedure TJvDockCustomPanelSplitter.AllocateLineDC; +begin + FLineDC := GetDCEx(Parent.Handle, 0, + DCX_CACHE or DCX_CLIPSIBLINGS or DCX_LOCKWINDOWUPDATE); + if ResizeStyle = rsPattern then + begin + if FBrush = nil then + begin + FBrush := TBrush.Create; + FBrush.Bitmap := AllocPatternBitmap(clBlack, clWhite); + end; + FPrevBrush := SelectObject(FLineDC, FBrush.Handle); + end; +end; + +procedure TJvDockCustomPanelSplitter.CalcSplitSize(X, Y: Integer; var NewSize, Split: Integer); +var + S: Integer; +begin + if Align in [alLeft, alRight] then + Split := X - FDownPos.X + else + Split := Y - FDownPos.Y; + S := 0; + case Align of + alLeft: + S := FControl.Width + Split; + alRight: + S := FControl.Width - Split; + alTop: + S := FControl.Height + Split; + alBottom: + S := FControl.Height - Split; + end; + NewSize := S; + if S < FMinSize then + NewSize := FMinSize + else + if S > FMaxSize then + NewSize := FMaxSize; + if S <> NewSize then + begin + if Align in [alRight, alBottom] then + S := S - NewSize + else + S := NewSize - S; + Inc(Split, S); + end; +end; + +function TJvDockCustomPanelSplitter.CanResize(var NewSize: Integer): Boolean; +begin + Result := True; + if Assigned(FOnCanResize) then + FOnCanResize(Self, NewSize, Result); +end; + +function TJvDockCustomPanelSplitter.DoCanResize(var NewSize: Integer): Boolean; +begin + Result := CanResize(NewSize); + if Result and (NewSize <= MinSize) and FAutoSnap then + NewSize := 0; +end; + +procedure TJvDockCustomPanelSplitter.DrawLine; +var + P: TPoint; +begin + FLineVisible := not FLineVisible; + P := Point(Left, Top); + if Align in [alLeft, alRight] then + P.X := Left + FSplit + else + P.Y := Top + FSplit; + with P do + PatBlt(FLineDC, X, Y, Width, Height, PATINVERT); +end; + +function TJvDockCustomPanelSplitter.FindControl: TControl; +var + P: TPoint; + I: Integer; + R: TRect; +begin + Result := nil; + P := Point(Left, Top); + case Align of + alLeft: + Dec(P.X); + alRight: + Inc(P.X, Width); + alTop: + Dec(P.Y); + alBottom: + Inc(P.Y, Height); + else + Exit; + end; + for I := 0 to Parent.ControlCount - 1 do + begin + Result := Parent.Controls[I]; + if Result.Visible and Result.Enabled then + begin + R := Result.BoundsRect; + if (R.Right - R.Left) = 0 then + if Align in [alTop, alLeft] then + Dec(R.Left) + else + Inc(R.Right); + if (R.Bottom - R.Top) = 0 then + if Align in [alTop, alLeft] then + Dec(R.Top) + else + Inc(R.Bottom); + if PtInRect(R, P) then + Exit; + end; + end; + Result := nil; +end; + +procedure TJvDockCustomPanelSplitter.FocusKeyDown(Sender: TObject; var Key: Word; Shift: TShiftState); +begin + if Key = VK_ESCAPE then + StopSizing + else + if Assigned(FOldKeyDown) then + FOldKeyDown(Sender, Key, Shift); +end; + +procedure TJvDockCustomPanelSplitter.MouseDown(Button: TMouseButton; Shift: TShiftState; + X, Y: Integer); +var + I: Integer; +begin + inherited MouseDown(Button, Shift, X, Y); + if Button = mbLeft then + begin + FControl := FindControl; + FDownPos := Point(X, Y); + if Assigned(FControl) then + begin + if Align in [alLeft, alRight] then + begin + FMaxSize := Parent.ClientWidth - FMinSize; + for I := 0 to Parent.ControlCount - 1 do + with Parent.Controls[I] do + if Visible and (Align in [alLeft, alRight]) then + Dec(FMaxSize, Width); + Inc(FMaxSize, FControl.Width); + end + else + begin + FMaxSize := Parent.ClientHeight - FMinSize; + for I := 0 to Parent.ControlCount - 1 do + with Parent.Controls[I] do + if Align in [alTop, alBottom] then + Dec(FMaxSize, Height); + Inc(FMaxSize, FControl.Height); + end; + UpdateSize(X, Y); + AllocateLineDC; + with ValidParentForm(Self) do + if ActiveControl <> nil then + begin + FActiveControl := ActiveControl; + FOldKeyDown := TWinControlAccessProtected(FActiveControl).OnKeyDown; + TWinControlAccessProtected(FActiveControl).OnKeyDown := FocusKeyDown; + end; + if ResizeStyle in [rsLine, rsPattern] then + DrawLine; + end; + end; +end; + +procedure TJvDockCustomPanelSplitter.MouseMove(Shift: TShiftState; X, Y: Integer); +var + NewSize, Split: Integer; +begin + inherited MouseMove(Shift, X, Y); + if (ssLeft in Shift) and Assigned(FControl) then + begin + CalcSplitSize(X, Y, NewSize, Split); + if DoCanResize(NewSize) and (FNewSize <> NewSize) then + begin + if ResizeStyle in [rsLine, rsPattern] then + DrawLine; + FNewSize := NewSize; + FSplit := Split; + if ResizeStyle = rsUpdate then + UpdateControlSize; + if ResizeStyle in [rsLine, rsPattern] then + DrawLine; + end; + end; +end; + +procedure TJvDockCustomPanelSplitter.MouseUp(Button: TMouseButton; Shift: TShiftState; + X, Y: Integer); +begin + inherited MouseUp(Button, Shift, X, Y); + if Assigned(FControl) then + begin + if ResizeStyle in [rsLine, rsPattern] then + DrawLine; + UpdateControlSize; + StopSizing; + end; +end; + +procedure TJvDockCustomPanelSplitter.Paint; +var + FrameBrush: HBRUSH; + R: TRect; +begin + R := ClientRect; + Canvas.Brush.Color := Color; + Canvas.FillRect(ClientRect); + if Beveled then + begin + if Align in [alLeft, alRight] then + InflateRect(R, -1, 2) + else + InflateRect(R, 2, -1); + OffsetRect(R, 1, 1); + FrameBrush := CreateSolidBrush(ColorToRGB(clBtnHighlight)); + FrameRect(Canvas.Handle, R, FrameBrush); + DeleteObject(FrameBrush); + OffsetRect(R, -2, -2); + FrameBrush := CreateSolidBrush(ColorToRGB(clBtnShadow)); + FrameRect(Canvas.Handle, R, FrameBrush); + DeleteObject(FrameBrush); + end; + + if csDesigning in ComponentState then + with Canvas do + begin + Pen.Style := psDot; + Pen.Mode := pmXor; + Pen.Color := JvDockXorColor; + Brush.Style := bsClear; + Rectangle(0, 0, ClientWidth, ClientHeight); + end; + + if Assigned(FOnPaint) then + FOnPaint(Self); +end; + +procedure TJvDockCustomPanelSplitter.ReleaseLineDC; +begin + if FPrevBrush <> 0 then + SelectObject(FLineDC, FPrevBrush); + ReleaseDC(Parent.Handle, FLineDC); + if FBrush <> nil then + begin + FBrush.Free; + FBrush := nil; + end; +end; + +procedure TJvDockCustomPanelSplitter.RequestAlign; +begin + inherited RequestAlign; + if (Cursor <> crVSplit) and (Cursor <> crHSplit) then + Exit; + if Align in [alBottom, alTop] then + Cursor := crVSplit + else + Cursor := crHSplit; +end; + +procedure TJvDockCustomPanelSplitter.SetBeveled(Value: Boolean); +begin + FBeveled := Value; + Repaint; +end; + +procedure TJvDockCustomPanelSplitter.StopSizing; +begin + if Assigned(FControl) then + begin + if FLineVisible then + DrawLine; + FControl := nil; + ReleaseLineDC; + if Assigned(FActiveControl) then + begin + TWinControlAccessProtected(FActiveControl).OnKeyDown := FOldKeyDown; + FActiveControl := nil; + end; + end; + if Assigned(FOnMoved) then + FOnMoved(Self); +end; + +procedure TJvDockCustomPanelSplitter.UpdateControlSize; +begin + if FNewSize <> FOldSize then + begin + case Align of + alLeft: + FControl.Width := FNewSize; + alTop: + FControl.Height := FNewSize; + alRight: + begin + Parent.DisableAlign; + try + FControl.Left := FControl.Left + (FControl.Width - FNewSize); + FControl.Width := FNewSize; + finally + Parent.EnableAlign; + end; + end; + alBottom: + begin + Parent.DisableAlign; + try + FControl.Top := FControl.Top + (FControl.Height - FNewSize); + FControl.Height := FNewSize; + finally + Parent.EnableAlign; + end; + end; + end; + TControlAccessProtected(FControl).Resize; + Update; + if Assigned(FOnMoved) then + FOnMoved(Self); + FOldSize := FNewSize; + + end; +end; + +procedure TJvDockCustomPanelSplitter.UpdateSize(X, Y: Integer); +begin + CalcSplitSize(X, Y, FNewSize, FSplit); +end; + +//=== { TJvDockCustomTabControl } ============================================ + +constructor TJvDockCustomTabControl.Create(AOwner: TComponent); +begin + inherited Create(AOwner); + Width := 289; + Height := 193; + TabStop := True; + ControlStyle := [csAcceptsControls, csDoubleClicks]; + FTabs := TJvDockTabStrings.Create; + FTabs.FTabControl := Self; + FImageChangeLink := TChangeLink.Create; + FImageChangeLink.OnChange := ImageListChange; +end; + +destructor TJvDockCustomTabControl.Destroy; +begin + FreeAndNil(FTabs); + FreeAndNil(FSaveTabs); + FreeAndNil(FImageChangeLink); + inherited Destroy; +end; + +procedure TJvDockCustomTabControl.AdjustClientRect(var Rect: TRect); +begin + Rect := DisplayRect; + inherited AdjustClientRect(Rect); +end; + +function TJvDockCustomTabControl.CanChange: Boolean; +begin + Result := True; + if Assigned(FOnChanging) then + FOnChanging(Self, Result); +end; + +function TJvDockCustomTabControl.CanShowTab(TabIndex: Integer): Boolean; +begin + Result := True; +end; + +procedure TJvDockCustomTabControl.Change; +begin + if Assigned(FOnChange) then + FOnChange(Self); +end; + +procedure TJvDockCustomTabControl.CMDialogChar(var Msg: TCMDialogChar); +var + I: Integer; +begin + for I := 0 to FTabs.Count - 1 do + if IsAccel(Msg.CharCode, FTabs[I]) and CanShowTab(I) and CanFocus then + begin + Msg.Result := 1; + if CanChange then + begin + TabIndex := I; + Change; + end; + Exit; + end; + inherited; +end; + +procedure TJvDockCustomTabControl.CMFontChanged(var Msg); +begin + inherited; + if HandleAllocated then + Perform(WM_SIZE, 0, 0); +end; + +procedure TJvDockCustomTabControl.CMSysColorChange(var Msg: TMessage); +begin + inherited; + if not (csLoading in ComponentState) then + begin + Msg.Msg := WM_SYSCOLORCHANGE; + DefaultHandler(Msg); + end; +end; + +procedure TJvDockCustomTabControl.CMTabStopChanged(var Msg: TMessage); +begin + if not (csDesigning in ComponentState) then + RecreateWnd; +end; + +procedure TJvDockCustomTabControl.CNDrawItem(var Msg: TWMDrawItem); +var + SaveIndex: Integer; +begin + with Msg.DrawItemStruct^ do + begin + SaveIndex := SaveDC(hDC); + Canvas.Lock; + try + Canvas.Handle := hDC; + Canvas.Font := Font; + Canvas.Brush := Brush; + DrawTab(itemID, rcItem, itemState and ODS_SELECTED <> 0); + finally + Canvas.Handle := 0; + Canvas.Unlock; + RestoreDC(hDC, SaveIndex); + end; + end; + Msg.Result := 1; +end; + +procedure TJvDockCustomTabControl.CNNotify(var Msg: TWMNotify); +begin + with Msg do + case NMHdr^.code of + TCN_SELCHANGE: + Change; + TCN_SELCHANGING: + Result := Ord(not CanChange); + end; +end; + +procedure TJvDockCustomTabControl.CreateParams(var Params: TCreateParams); +const + AlignStyles: array [Boolean, TTabPosition] of DWORD = + ((0, TCS_BOTTOM, TCS_VERTICAL, TCS_VERTICAL or TCS_RIGHT), + (0, TCS_BOTTOM, TCS_VERTICAL or TCS_RIGHT, TCS_VERTICAL)); + TabStyles: array [TTabStyle] of DWORD = + (TCS_TABS, TCS_BUTTONS, TCS_BUTTONS or TCS_FLATBUTTONS); + RRStyles: array [Boolean] of DWORD = + (0, TCS_RAGGEDRIGHT); +begin + InitCommonControl(ICC_TAB_CLASSES); + inherited CreateParams(Params); + CreateSubClass(Params, WC_TABCONTROL); + with Params do + begin + Style := Style or WS_CLIPCHILDREN or + AlignStyles[UseRightToLeftAlignment, FTabPosition] or + TabStyles[FStyle] or RRStyles[FRaggedRight]; + if not TabStop then + Style := Style or TCS_FOCUSNEVER; + if FMultiLine then + Style := Style or TCS_MULTILINE; + if FMultiSelect then + Style := Style or TCS_MULTISELECT; + if FOwnerDraw then + Style := Style or TCS_OWNERDRAWFIXED; + if FTabSize.X <> 0 then + Style := Style or TCS_FIXEDWIDTH; + if FHotTrack and (not (csDesigning in ComponentState)) then + Style := Style or TCS_HOTTRACK; + if FScrollOpposite then + Style := Style or TCS_SCROLLOPPOSITE; + WindowClass.style := WindowClass.style and + not (CS_HREDRAW or CS_VREDRAW) or CS_DBLCLKS; + end; +end; + +procedure TJvDockCustomTabControl.CreateWnd; +begin + inherited CreateWnd; + if (Images <> nil) and Images.HandleAllocated then + Perform(TCM_SETIMAGELIST, 0, Images.Handle); + if Integer(FTabSize) <> 0 then + UpdateTabSize; + if FSaveTabs <> nil then + begin + FTabs.Assign(FSaveTabs); + SetTabIndex(FSaveTabIndex); + FSaveTabs.Free; + FSaveTabs := nil; + end; +end; + +procedure TJvDockCustomTabControl.DrawTab(TabIndex: Integer; const Rect: TRect; + Active: Boolean); +begin + if Assigned(FOnDrawTab) then + FOnDrawTab(Self, TabIndex, Rect, Active) + else + Canvas.FillRect(Rect); +end; + +function TJvDockCustomTabControl.GetDisplayRect: TRect; +begin + Result := ClientRect; + SendMessage(Handle, TCM_ADJUSTRECT, 0, Integer(@Result)); + if TabPosition = tpTop then + Inc(Result.Top, 2); +end; + +function TJvDockCustomTabControl.GetHitTestInfoAt(X, Y: Integer): THitTests; +var + HitTest: TTCHitTestInfo; +begin + Result := []; + if PtInRect(ClientRect, Point(X, Y)) then + with HitTest do + begin + pt.X := X; + pt.Y := Y; + if TabCtrl_HitTest(Handle, @HitTest) <> -1 then + begin + if (flags and TCHT_NOWHERE) <> 0 then + Include(Result, htNowhere); + if (flags and TCHT_ONITEM) = TCHT_ONITEM then + Include(Result, htOnItem) + else + begin + if (flags and TCHT_ONITEM) <> 0 then + Include(Result, htOnItem); + if (flags and TCHT_ONITEMICON) <> 0 then + Include(Result, htOnIcon); + if (flags and TCHT_ONITEMLABEL) <> 0 then + Include(Result, htOnLabel); + end; + end + else + Result := [htNowhere]; + end; +end; + +function TJvDockCustomTabControl.GetImageIndex(TabIndex: Integer): Integer; +begin + Result := TabIndex; + if Assigned(FOnGetImageIndex) then + FOnGetImageIndex(Self, TabIndex, Result); +end; + +function TJvDockCustomTabControl.GetTabIndex: Integer; +begin + Result := SendMessage(Handle, TCM_GETCURSEL, 0, 0); +end; + +function TJvDockCustomTabControl.GetTabs: TStrings; +begin + Result := FTabs; +end; + +procedure TJvDockCustomTabControl.ImageListChange(Sender: TObject); +begin + Perform(TCM_SETIMAGELIST, 0, TCustomImageList(Sender).Handle); +end; + +function TJvDockCustomTabControl.IndexOfTabAt(X, Y: Integer): Integer; +var + HitTest: TTCHitTestInfo; +begin + Result := -1; + if PtInRect(ClientRect, Point(X, Y)) then + with HitTest do + begin + pt.X := X; + pt.Y := Y; + Result := TabCtrl_HitTest(Handle, @HitTest); + end; +end; + +function TJvDockCustomTabControl.InternalSetMultiLine(Value: Boolean): Boolean; +begin + Result := FMultiLine <> Value; + if Result then + begin + if not Value and ((TabPosition = tpLeft) or (TabPosition = tpRight)) then + TabControlError(sTabMustBeMultiLine); + FMultiLine := Value; + if not Value then + FScrollOpposite := False; + end; +end; + +procedure TJvDockCustomTabControl.Loaded; +begin + inherited Loaded; + if Images <> nil then + UpdateTabImages; +end; + +procedure TJvDockCustomTabControl.Notification(AComponent: TComponent; + Operation: TOperation); +begin + inherited Notification(AComponent, Operation); + if (Operation = opRemove) and (AComponent = Images) then + Images := nil; +end; + +procedure TJvDockCustomTabControl.PaintWindow(DC: HDC); +var + Msg: TMessage; +begin + if not OwnerDraw then + begin + Msg.Msg := WM_PAINT; + Msg.WParam := DC; + Msg.LParam := 0; + Msg.Result := 0; + DefaultHandler(Msg); + end; + inherited PaintWindow(DC); +end; + +function TJvDockCustomTabControl.RowCount: Integer; +begin + Result := TabCtrl_GetRowCount(Handle); +end; + +procedure TJvDockCustomTabControl.ScrollTabs(Delta: Integer); +var + Wnd: HWND; + P: TPoint; + Rect: TRect; + I: Integer; +begin + Wnd := FindWindowEx(Handle, 0, 'msctls_updown32', nil); + if Wnd <> 0 then + begin + Windows.GetClientRect(Wnd, Rect); + if Delta < 0 then + P.X := Rect.Left + 2 + else + P.X := Rect.Right - 2; + P.Y := Rect.Top + 2; + for I := 0 to Abs(Delta) - 1 do + begin + SendMessage(Wnd, WM_LBUTTONDOWN, 0, MakeLParam(P.X, P.Y)); + SendMessage(Wnd, WM_LBUTTONUP, 0, MakeLParam(P.X, P.Y)); + end; + end; +end; + +procedure TJvDockCustomTabControl.SetHotTrack(Value: Boolean); +begin + if FHotTrack <> Value then + begin + FHotTrack := Value; + RecreateWnd; + end; +end; + +procedure TJvDockCustomTabControl.SetImages(Value: TCustomImageList); +begin + if Images <> nil then + Images.UnRegisterChanges(FImageChangeLink); + FImages := Value; + if Images <> nil then + begin + Images.RegisterChanges(FImageChangeLink); + Images.FreeNotification(Self); + Perform(TCM_SETIMAGELIST, 0, Images.Handle); + end + else + Perform(TCM_SETIMAGELIST, 0, 0); +end; + +procedure TJvDockCustomTabControl.SetMultiLine(Value: Boolean); +begin + if InternalSetMultiLine(Value) then + RecreateWnd; +end; + +procedure TJvDockCustomTabControl.SetMultiSelect(Value: Boolean); +begin + if FMultiSelect <> Value then + begin + FMultiSelect := Value; + RecreateWnd; + end; +end; + +procedure TJvDockCustomTabControl.SetOwnerDraw(Value: Boolean); +begin + if FOwnerDraw <> Value then + begin + FOwnerDraw := Value; + RecreateWnd; + end; +end; + +procedure TJvDockCustomTabControl.SetRaggedRight(Value: Boolean); +begin + if FRaggedRight <> Value then + begin + FRaggedRight := Value; + SetComCtlStyle(Self, TCS_RAGGEDRIGHT, Value); + end; +end; + +procedure TJvDockCustomTabControl.SetScrollOpposite(Value: Boolean); +begin + if FScrollOpposite <> Value then + begin + FScrollOpposite := Value; + if Value then + FMultiLine := Value; + RecreateWnd; + end; +end; + +procedure TJvDockCustomTabControl.SetStyle(Value: TTabStyle); +begin + if FStyle <> Value then + begin + if (Value <> tsTabs) and (TabPosition <> tpTop) then + raise EInvalidOperation.CreateRes(@SInvalidTabStyle); + FStyle := Value; + RecreateWnd; + end; +end; + +procedure TJvDockCustomTabControl.SetTabHeight(Value: Smallint); +begin + if FTabSize.Y <> Value then + begin + if Value < 0 then + raise EInvalidOperation.CreateResFmt(@SPropertyOutOfRange, [Self.Classname]); + FTabSize.Y := Value; + UpdateTabSize; + end; +end; + +procedure TJvDockCustomTabControl.SetTabIndex(Value: Integer); +begin + SendMessage(Handle, TCM_SETCURSEL, Value, 0); +end; + +procedure TJvDockCustomTabControl.SetTabPosition(Value: TTabPosition); +begin + if FTabPosition <> Value then + begin + if (Value <> tpTop) and (Style <> tsTabs) then + raise EInvalidOperation.CreateRes(@SInvalidTabPosition); + FTabPosition := Value; + if not MultiLine and ((Value = tpLeft) or (Value = tpRight)) then + InternalSetMultiLine(True); + RecreateWnd; + end; +end; + +procedure TJvDockCustomTabControl.SetTabs(Value: TStrings); +begin + FTabs.Assign(Value); +end; + +procedure TJvDockCustomTabControl.SetTabWidth(Value: Smallint); +var + OldValue: Smallint; +begin + if FTabSize.X <> Value then + begin + if Value < 0 then + raise EInvalidOperation.CreateResFmt(@SPropertyOutOfRange, [Self.ClassName]); + OldValue := FTabSize.X; + FTabSize.X := Value; + if (OldValue = 0) or (Value = 0) then + RecreateWnd + else + UpdateTabSize; + end; +end; + +function TJvDockCustomTabControl.TabRect(Index: Integer): TRect; +begin + TabCtrl_GetItemRect(Handle, Index, Result); +end; + +procedure TJvDockCustomTabControl.TabsChanged; +begin + if not FUpdating then + begin + if HandleAllocated then + SendMessage(Handle, WM_SIZE, SIZE_RESTORED, + Word(Width) or Word(Height) shl 16); + Realign; + end; +end; + +procedure TJvDockCustomTabControl.TCMAdjustRect(var Msg: TMessage); +begin + try + inherited; + if (TabPosition <> tpTop) and (Msg.WParam = 0) then + FSavedAdjustRect := PRect(Msg.LParam)^; + except + PRect(Msg.LParam)^ := FSavedAdjustRect; + end; +end; + +procedure TJvDockCustomTabControl.UpdateTabImages; +var + I: Integer; + TCItem: TTCItem; +begin + TCItem.mask := TCIF_IMAGE; + for I := 0 to FTabs.Count - 1 do + begin + TCItem.iImage := GetImageIndex(I); + if SendMessage(Handle, TCM_SETITEM, I, + Longint(@TCItem)) = 0 then + TabControlError(Format(sTabFailSet, [FTabs[I], I])); + end; + TabsChanged; +end; + +procedure TJvDockCustomTabControl.UpdateTabSize; +begin + SendMessage(Handle, TCM_SETITEMSIZE, 0, Integer(FTabSize)); + TabsChanged; +end; + +procedure TJvDockCustomTabControl.WMDestroy(var Msg: TWMDestroy); +var + FocusHandle: HWND; +begin + if (FTabs <> nil) and (FTabs.Count > 0) then + begin + FSaveTabs := TStringList.Create; + FSaveTabs.Assign(FTabs); + FSaveTabIndex := GetTabIndex; + end; + FocusHandle := GetFocus; + if (FocusHandle <> 0) and ((FocusHandle = Handle) or + IsChild(Handle, FocusHandle)) then + Windows.SetFocus(0); + inherited; + WindowHandle := 0; +end; + +procedure TJvDockCustomTabControl.WMNotifyFormat(var Msg: TMessage); +begin + with Msg do + Result := DefWindowProc(Handle, Msg, WParam, LParam); +end; + +procedure TJvDockCustomTabControl.WMSize(var Msg: TMessage); +begin + inherited; + RedrawWindow(Handle, nil, 0, RDW_INVALIDATE or RDW_ERASE); +end; + +{$IFDEF DELPHI6_UP} +//=== { TJvAlphaBlendedForm } ============================================== + +procedure TJvAlphaBlendedForm.CreateParams(var Params: TCreateParams); +begin + inherited; + Params.ExStyle := Params.ExStyle or WS_EX_TRANSPARENT; +end; +{$ENDIF DELPHI6} + +//=== { TJvDockDragDockObject } ============================================== + +constructor TJvDockDragDockObject.Create(AControl: TControl); +begin + inherited Create; + FControl := AControl; + FBrush := TBrush.Create; + FBrush.Bitmap := AllocPatternBitmap(clBlack, clWhite); + FFrameWidth := 4; + FCtrlDown := False; +{$IFDEF DELPHI6_UP} + AlphaBlendedForm := TJvAlphaBlendedForm.CreateNew(nil); + with AlphaBlendedForm do begin + Visible := False; + Color := clHighlight; + AlphaBlend := True; + AlphaBlendValue := 140; + BorderIcons := []; + BorderStyle := bsNone; + FormStyle := fsStayOnTop; + BoundsRect := Rect(0, 0, 0, 0); + end; +{$ENDIF DELPHI6_UP} +end; + +destructor TJvDockDragDockObject.Destroy; +begin + if FBrush <> nil then + begin + FBrush.Free; + FBrush := nil; + end; +{$IFDEF DELPHI6_UP} + AlphaBlendedForm.Free; +{$ENDIF DELPHI6_UP} + inherited Destroy; +end; + +procedure TJvDockDragDockObject.AdjustDockRect(const ARect: TRect); +var + DeltaX, DeltaY: Integer; + R: TRect; + + function AbsMin(Value1, Value2: Integer): Integer; + begin + if Abs(Value1) < Abs(Value2) then + Result := Value1 + else + Result := Value2; + end; + +begin + if (ARect.Left > FDragPos.X) or (ARect.Right < FDragPos.X) then + DeltaX := AbsMin(ARect.Left - FDragPos.X, ARect.Right - FDragPos.X) + else + DeltaX := 0; + if (ARect.Top > FDragPos.Y) or (ARect.Bottom < FDragPos.Y) then + DeltaY := AbsMin(ARect.Top - FDragPos.Y, ARect.Bottom - FDragPos.Y) + else + DeltaY := 0; + if (DeltaX <> 0) or (DeltaY <> 0) then + begin + R := DockRect; + OffsetRect(R, -DeltaX, -DeltaY); + DockRect := R; + end; +end; + +function TJvDockDragDockObject.CanLeave(NewTarget: TWinControl): Boolean; +begin + Result := NewTarget <> TWinControl(FDragTarget); +end; + +function TJvDockDragDockObject.Capture: THandle; +begin + Result := AllocateHWnd(MouseMsg); + SetCapture(Result); +end; + +{$IFDEF DELPHI6_UP} +procedure TJvDockDragDockObject.DefaultDockImage(Erase: Boolean); +Var + DrawRect: TRect; + PenSize: Integer; + ABrush: TBrush; +begin + GetBrush_PenSize_DrawRect(ABrush, PenSize, DrawRect, Erase); + AlphaBlendedForm.Visible := True; + AlphaBlendedForm.BoundsRect := DrawRect; +end; +{$ELSE} +procedure TJvDockDragDockObject.DefaultDockImage(Erase: Boolean); +var + DesktopWindow: HWND; + DC: HDC; + OldBrush: HBRUSH; + DrawRect: TRect; + PenSize: Integer; + Brush: TBrush; +begin + GetBrush_PenSize_DrawRect(Brush, PenSize, DrawRect, Erase); + + DesktopWindow := GetDesktopWindow; + DC := GetDCEx(DesktopWindow, 0, DCX_CACHE or DCX_LOCKWINDOWUPDATE); + try + OldBrush := SelectObject(DC, Brush.Handle); + with DrawRect do + begin + PatBlt(DC, Left + PenSize, Top, Right - Left - PenSize, PenSize, PATINVERT); + PatBlt(DC, Right - PenSize, Top + PenSize, PenSize, Bottom - Top - PenSize, PATINVERT); + PatBlt(DC, Left, Bottom - PenSize, Right - Left - PenSize, PenSize, PATINVERT); + PatBlt(DC, Left, Top, PenSize, Bottom - Top - PenSize, PATINVERT); + end; + SelectObject(DC, OldBrush); + finally + ReleaseDC(DesktopWindow, DC); + end; +end; +{$ENDIF DELPHI6_UP} + +function TJvDockDragDockObject.DragFindWindow(const Pos: TPoint): THandle; +var + WinControl: TWinControl; +begin + WinControl := FindVCLWindow(Pos); + if WinControl <> nil then + Result := WinControl.Handle + else + Result := 0; +end; + +procedure TJvDockDragDockObject.DrawDragDockImage; +begin + DefaultDockImage(False); +end; + +procedure TJvDockDragDockObject.DrawDragRect(DoErase: Boolean); +begin + if not CompareMem(@DockRect, @EraseDockRect, SizeOf(TRect)) then + begin + if DoErase then + EraseDragDockImage; + DrawDragDockImage; + FEraseDockRect := DockRect; + end; +end; + +procedure TJvDockDragDockObject.EndDrag(Target: TObject; X, Y: Integer); +begin + JvGlobalDockManager.DoEndDrag(Target, X, Y); +end; + +procedure TJvDockDragDockObject.EraseDragDockImage; +begin + DefaultDockImage(True); +end; + +procedure TJvDockDragDockObject.Finished(Target: TObject; X, Y: Integer; + Accepted: Boolean); +begin + if not Accepted then + Target := nil; + EndDrag(Target, X, Y); +end; + +procedure TJvDockDragDockObject.GetBrush_PenSize_DrawRect(var ABrush: TBrush; + var PenSize: Integer; var DrawRect: TRect; Erase: Boolean); +begin + ABrush := Brush; + PenSize := FrameWidth; + if Erase then + DrawRect := EraseDockRect + else + DrawRect := DockRect; +end; + +function TJvDockDragDockObject.GetDragCursor(Accepted: Boolean; + X, Y: Integer): TCursor; +begin + Result := crDefault; +end; + +function TJvDockDragDockObject.GetDragImages: TDragImageList; +begin + Result := nil; +end; + +function TJvDockDragDockObject.GetDropCtl: TControl; +var + NextCtl: TControl; + TargetCtl: TWinControl; + CtlIdx: Integer; + + function GetDockClientsIndex: Integer; + begin + for Result := 0 to TWinControlAccessProtected(TargetCtl).DockClientCount - 1 do + if TWinControlAccessProtected(TargetCtl).DockClients[Result] = NextCtl then + Exit; + Result := -1; + end; + +begin + Result := nil; + TargetCtl := DragTarget; + if (TargetCtl = nil) or not TWinControlAccessProtected(TargetCtl).UseDockManager or + (TargetCtl.DockClientCount = 0) or + ((TargetCtl.DockClientCount = 1) and + (TWinControlAccessProtected(TargetCtl).DockClients[0] = Control)) then + Exit; + NextCtl := FindDragTarget(DragPos, False); + while (NextCtl <> nil) and (NextCtl <> TargetCtl) do + begin + CtlIdx := GetDockClientsIndex; + if CtlIdx <> -1 then + begin + Result := TargetCtl.DockClients[CtlIdx]; + Exit; + end + else + NextCtl := NextCtl.Parent; + end; +end; + +function TJvDockDragDockObject.GetFrameWidth: Integer; +begin + Result := FFrameWidth; +end; + +function TJvDockDragDockObject.GetTargetControl: TWinControl; +begin + if FDragTarget <> nil then + Result := TWinControl(FDragTarget) + else + Result := nil; +end; + +procedure TJvDockDragDockObject.MouseMsg(var Msg: TMessage); +var + P: TPoint; + + procedure DoDragDone(DropFlag: Boolean); {NEW! Warren added.} + var + DS: TJvDockServer; + DC: TJvDockClient; + DP: TJvDockPanel; + DF: TForm; + begin + if not Assigned(JvGlobalDockManager) then + Exit; + + if DropFlag and Assigned(FControl) then + begin + // only do this if DropFlag is true and there is a control (usually a form) we are dragging + if not Assigned(TargetControl) then + begin + {$IFDEF JVDOCK_DEBUG} + OutputDebugString('TJvDockDragDockObject.MouseMsg.DoDragDone: User drag finished, TargetControl=nil, user made form floating.'); + {$ENDIF JVDOCK_DEBUG} + + {In this case, we're dragging something off and making it floating. } + {if Assigned(FControl) then + DC := FindDockClient(FControl) + else + DC := nil; + + DP := nil; + DS := nil; + DF := nil; + if Assigned(DC) then begin + if Assigned(DC.OnCheckIsDockable) then begin + DC.OnCheckIsDockable( DC, DF, DS, DP, DropFlag ); + end; + end;} + end + else + if TargetControl is TJvDockPanel then + begin + { In this case, we're about to dock to a TJvDockPanel } + {DP := TargetControl as TJvDockPanel; + DS := DP.DockServer; + DC := FindDockClient(FControl); + if FControl is TForm then + DF := FControl as TForm + else + DF := nil; + if Assigned(DC.OnCheckIsDockable) then begin + DC.OnCheckIsDockable( DC, DF, DS, DP, DropFlag ); + end;} + end + else + if TargetControl is TForm then + begin + { This appears to have something to do with conjoined and tabbed host forms } + DC := FindDockClient(TargetControl); + DP := nil; + DS := nil; + if FControl is TForm then + DF := FControl as TForm + else + DF := nil; + if Assigned(DC.OnCheckIsDockable) then + DC.OnCheckIsDockable(DC, DF, DS, DP, DropFlag); + end + else + begin + {$IFDEF JVDOCK_DEBUG} + // Debug message! + OutputDebugString('TJvDockDragDockObject.MouseMsg.DoDragDone: TargetControl is not an expected type!'); + {$ENDIF JVDOCK_DEBUG} + end; + end; + Assert(Assigned(JvGlobalDockManager)); + Assert(Assigned(JvGlobalDockClient)); + JvGlobalDockManager.DragDone(DropFlag); + {$IFDEF JVDOCK_DEBUG} + OutputDebugString('DoDragDone completed.'); + {$ENDIF JVDOCK_DEBUG} + end; + +begin + try + case Msg.Msg of + WM_MOUSEMOVE: + begin + P := SmallPointToPoint(TWMMouse(Msg).Pos); + ClientToScreen(JvGlobalDockManager.FDragCapture, P); + JvGlobalDockManager.DragTo(P); + end; + WM_CAPTURECHANGED: + DoDragDone(False); //JvGlobalDockManager.DragDone(False); + WM_LBUTTONUP, WM_RBUTTONUP: + if not JvGlobalDockClient.CanFloat then + begin + if (TargetControl = nil) and (JvGlobalDockClient.ParentForm.HostDockSite = nil) then + DoDragDone(True) //JvGlobalDockManager.DragDone(True) + else + DoDragDone(TargetControl <> nil); //JvGlobalDockManager.DragDone(TargetControl <> nil); + end + else + DoDragDone(True); //JvGlobalDockManager.DragDone(True); + CN_KEYUP: + if Msg.WParam = VK_CONTROL then + begin + FCtrlDown := False; + JvGlobalDockManager.DragTo(JvGlobalDockManager.DragObject.DragPos); + end; + CN_KEYDOWN: + case Msg.WParam of + VK_CONTROL: + begin + FCtrlDown := True; + JvGlobalDockManager.DragTo(JvGlobalDockManager.DragObject.DragPos); + end; + VK_ESCAPE: + begin + Msg.Result := 1; + DoDragDone(False); //JvGlobalDockManager.DragDone(False); + end; + end; + end; + except + if JvGlobalDockManager.FDragControl <> nil then + DoDragDone(False); //JvGlobalDockManager.DragDone(False); + raise; + end; +end; + +procedure TJvDockDragDockObject.ReleaseCapture(Handle: THandle); +begin + Windows.ReleaseCapture; + DeallocateHWnd(Handle); +end; + +procedure TJvDockDragDockObject.SetBrush(const Value: TBrush); +begin + FBrush.Assign(Value); +end; + +procedure TJvDockDragDockObject.SetDropAlign(const Value: TAlign); +begin + if FDropAlign <> Value then + FDropAlign := Value; +end; + +procedure TJvDockDragDockObject.SetDropOnControl(const Value: TControl); +begin + FDropOnControl := Value; +end; + +procedure TJvDockDragDockObject.SetFrameWidth(const Value: Integer); +begin + FFrameWidth := Value; +end; + +procedure TJvDockDragDockObject.SetTargetControl(const Value: TWinControl); +begin + FDragTarget := Value; +end; + +//=== { TJvDockManager } ===================================================== + +constructor TJvDockManager.Create; +begin + inherited Create; + FDockSiteList := TList.Create; +end; + +destructor TJvDockManager.Destroy; +begin + FDockSiteList.Free; + inherited Destroy; +end; + +procedure TJvDockManager.BeginDrag(Control: TControl; Immediate: Boolean; Threshold: Integer); +var + P: TPoint; +begin + if TControlAccessProtected(Control).DragKind <> dkDock then + Exit; + + CalcDockSizes(Control); + if (FDragControl = nil) or (FDragControl = Pointer($FFFFFFFF)) then + begin + FDragControl := nil; + if csLButtonDown in Control.ControlState then + begin + GetCursorPos(P); + P := Control.ScreenToClient(P); + Control.Perform(WM_LBUTTONUP, 0, Longint(PointToSmallPoint(P))); + end; + + if Threshold < 0 then + Threshold := Mouse.DragThreshold; + + if FDragControl <> Pointer($FFFFFFFF) then + DragInitControl(Control, Immediate, Threshold); + end; +end; + +procedure TJvDockManager.BeginLoad; +begin + Inc(FLoadCount); + if FLoadCount = 1 then + begin + end; +end; + +procedure TJvDockManager.BeginSave; +begin + Inc(FSaveCount); +end; + +procedure TJvDockManager.CalcDockSizes(Control: TControl); +var + Rect: TRect; +begin + with Control do + if Floating then + begin + UndockHeight := Height; + UndockWidth := Width; + end + else + if HostDockSite is TJvDockCustomPanel then + begin + Rect := TJvDockCustomPanel(HostDockSite).JvDockManager.GetFrameRect(Control); + if HostDockSite.Align in [alTop, alBottom] then + TBDockHeight := Rect.Bottom - Rect.Top + else + if HostDockSite.Align in [alLeft, alRight] then + LRDockWidth := Rect.Right - Rect.Left; + end; +end; + +procedure TJvDockManager.CancelDrag; +begin + if DragObject <> nil then + DragDone(False); + FDragControl := nil; +end; + +procedure TJvDockManager.DoDockDrop(Source: TJvDockDragDockObject; Pos: TPoint); +var + Target: TWinControl; + ADockClient: TJvDockClient; +begin + if Source.DragTarget <> nil then + begin + Target := Source.TargetControl; + with Target.ScreenToClient(Pos) do + if Target is TJvDockCustomControl then + TJvDockCustomControl(Target).CustomDockDrop(Source, X, Y) + else + if Target is TForm then + begin + ADockClient := FindDockClient(Target); + if ADockClient <> nil then + ADockClient.FormDockDrop(Source, X, Y); + end; + end; +end; + +function TJvDockManager.DoDockOver(DragState: TDragState): Boolean; +var + Target: TControl; + ADockClient: TJvDockClient; +begin + Result := True; + if DragObject.DragTarget <> nil then + begin + Target := TControl(DragObject.DragTarget); + with Target.ScreenToClient(DragObject.DragPos) do + if Target is TJvDockCustomControl then + TJvDockCustomControl(Target).CustomDockOver(DragObject, X, Y, DragState, Result) + else + if Target is TForm then + begin + ADockClient := FindDockClient(Target); + if ADockClient <> nil then + ADockClient.FormDockOver(DragObject, X, Y, DragState, Result); + end; + end; +end; + +procedure TJvDockManager.DoEndDrag(Target: TObject; X, Y: Integer); +var + ADockClient: TJvDockClient; +begin + if Target is TJvDockCustomControl then + TJvDockCustomControl(Target).CustomEndDock(Target, X, Y) + else + if Target is TForm then + begin + ADockClient := FindDockClient(TControl(Target)); + if ADockClient <> nil then + ADockClient.FormEndDock(Target, X, Y); + end; +end; + +procedure TJvDockManager.DoGetDockEdge(Target: TControl; MousePos: TPoint; var DropAlign: TAlign); +var + ADockClient: TJvDockClient; +begin + if Target is TJvDockCustomControl then + TJvDockCustomControl(Target).CustomGetDockEdge(DragObject, MousePos, DropAlign) + else + if Target is TForm then + begin + ADockClient := FindDockClient(Target); + if ADockClient <> nil then + ADockClient.FormGetDockEdge(DragObject, MousePos, DropAlign); + end; +end; + +procedure TJvDockManager.DoGetSiteInfo(Target, Client: TControl; + var InfluenceRect: TRect; MousePos: TPoint; var CanDock: Boolean); +var + ADockClient: TJvDockClient; +begin + if Target is TJvDockCustomControl then + TJvDockCustomControl(Target).CustomGetSiteInfo(DragObject, Client, InfluenceRect, MousePos, CanDock) + else + if Target is TForm then + begin + ADockClient := FindDockClient(Target); + if ADockClient <> nil then + ADockClient.FormGetSiteInfo(DragObject, Client, InfluenceRect, MousePos, CanDock); + end + else + CanDock := False; +end; + +function TJvDockManager.DoUnDock(Source: TJvDockDragDockObject; Target: TWinControl; Client: TControl): Boolean; +begin + if Client.HostDockSite is TJvDockCustomControl then + Result := TJvDockCustomControl(Client.HostDockSite).CustomUnDock(Source, Target, Client) + else + Result := False; +end; + +procedure TJvDockManager.DragDone(Drop: Boolean); +var + DragSave: TJvDockDragDockObject; + DockObject: TJvDockDragDockObject; + Accepted: Boolean; + TargetPos: TPoint; + ParentForm: TCustomForm; + + function CheckUndock: Boolean; + begin + Result := DragObject.DragTarget <> nil; + with FDragControl do + if Drop and (FActiveDrag = dopDock) then + if Floating or (HostDockSite = nil) then + Result := True + else + Result := DoUnDock(DragObject, DragObject.DragTarget, FDragControl); + end; + + procedure DoFloatForm(Control: TControl); + var + WasVisible: Boolean; + begin + if Control.FloatingDockSiteClass = Control.ClassType then + begin + WasVisible := Control.Visible; + try + Control.Dock(nil, DragObject.DockRect); + if (Control.Left <> DragObject.DockRect.Left) or (Control.Top <> DragObject.DockRect.Top) then + begin + Control.Left := DragObject.DockRect.Left; + Control.Top := DragObject.DockRect.Top; + end; + finally + if WasVisible then + Control.BringToFront; + end; + end; + end; + +begin + DockObject := nil; + DragSave := nil; + Accepted := False; + if (DragObject = nil) or DragObject.Cancelling then + Exit; + try + DragSave := DragObject; + try + DragObject.Cancelling := True; + DragObject.ReleaseCapture(FDragCapture); + if FActiveDrag = dopDock then + begin + DockObject := DragObject; + DockObject.EraseDragDockImage; + DockObject.Floating := DockObject.DragTarget = nil; + end; + if (DragObject.DragTarget <> nil) and + (TObject(DragObject.DragTarget) is TControl) then + TargetPos := DragObject.DragTargetPos + else + TargetPos := DragObject.DragPos; + + {Check before we undock, then check if the drop is going to be accepted } + + Accepted := {local function:} CheckUndock and {DragDone parameter:} Drop; + + if FActiveDrag = dopDock then + begin + if Accepted and DockObject.Floating then + begin + ParentForm := GetParentForm(DockObject.Control); + if (ParentForm <> nil) and + (ParentForm.ActiveControl = DockObject.Control) then + ParentForm.ActiveControl := nil; + DoFloatForm(FDragControl); + end; + end + else + begin + if FDragImageList <> nil then + FDragImageList.EndDrag + else + Windows.SetCursor(FDragSaveCursor); + end; + FDragControl := nil; + if DragSave.DragTarget <> nil then + begin + if not Accepted then + begin + DragSave.DragPos := Point(0, 0); + TargetPos.X := 0; + TargetPos.Y := 0; + end + else + DoDockDrop(DragSave, DragSave.DragPos); + end; + DragObject := nil; + finally + FQualifyingSites.Free; + FQualifyingSites := nil; + DragSave.Cancelling := False; + DragSave.Finished(DragSave.DragTarget, TargetPos.X, TargetPos.Y, Accepted); + DragObject := nil; + end; + finally + FDragControl := nil; + DragSave.Free; + end; +end; + +function TJvDockManager.DragFindTarget(const Pos: TPoint; var Handle: THandle; + DragKind: TDragKind; Client: TControl): Pointer; +begin + Result := GetDockSiteAtPos(Pos, Client); + if Result <> nil then + Handle := TWinControl(Result).Handle; +end; + +function TJvDockManager.DragFindWindow(const Pos: TPoint): THandle; +begin + Result := DragObject.DragFindWindow(Pos); +end; + +procedure TJvDockManager.DragInit(ADragObject: TJvDockDragDockObject; + Immediate: Boolean; Threshold: Integer); +begin + DragObject := ADragObject; + DragObject.DragTarget := nil; + GetCursorPos(FDragStartPos); + DragObject.DragPos := FDragStartPos; + FDragSaveCursor := Windows.GetCursor; + FDragCapture := DragObject.Capture; + FDragThreshold := Threshold; + with ADragObject, DockRect do + begin + if Right - Left > 0 then + MouseDeltaX := (DragPos.X - Left) / (Right - Left) + else + MouseDeltaX := 0; + if Bottom - Top > 0 then + MouseDeltaY := (DragPos.Y - Top) / (Bottom - Top) + else + MouseDeltaY := 0; + if Immediate then + begin + FActiveDrag := dopDock; + DrawDragDockImage; + end + else + FActiveDrag := dopNone; + end; + FDragImageList := DragObject.GetDragImages; + if FDragImageList <> nil then + with FDragStartPos do + FDragImageList.BeginDrag(GetDesktopWindow, X, Y); + FQualifyingSites := TSiteList.Create; + if FActiveDrag <> dopNone then + DragTo(FDragStartPos); +end; + +procedure TJvDockManager.DragInitControl(Control: TControl; + Immediate: Boolean; Threshold: Integer); +var + ARect: TRect; + DragObj: TJvDockDragDockObject; + + procedure DoStartDock; + begin + if Assigned(JvGlobalDockClient) then + begin + DragObj := DragObject; + JvGlobalDockClient.FormStartDock(DragObj); + DragObject := DragObj; + end; + if DragObject = nil then + begin + DragObject := TJvDockDragDockObject.Create(Control); + FDragFreeObject := True; + end; + end; + +begin + FDragControl := Control; + try + DragObject := nil; + FDragFreeObject := False; + + DoStartDock; + if FDragControl = nil then + Exit; + with DragObject do + begin + if Control.HostDockSite is TJvDockCustomPanel then + ARect := TJvDockCustomPanel(Control.HostDockSite).JvDockManager.GetFrameRectEx(Control) + else + GetWindowRect(TWinControl(Control).Handle, ARect); + DockRect := ARect; + FEraseDockRect := DockRect; + end; + DragInit(DragObject, Immediate, Threshold); + except + FDragControl := nil; + raise; + end; +end; + +{ TJvDockManager.DragTo: WM_MOUSEMOVE Mouse Drag handler. + + The global Dock manager which is of this type, TJvDockManager, handles + the WM_MOUSEMOVE messages sent to TJvDockDragDockObject.MouseMsg. + + In this function we decide what destination (drop object) + we are in by calling DragFindTarget. + + There is a lot of boilerplate code here that isn't used, such + as the ability to draw a drag image (not useful when dragging forms). + +} +procedure TJvDockManager.DragTo(const Pos: TPoint); +var + DragCursor: TCursor; + Target: TControl; + TargetHandle: THandle; + DoErase: Boolean; + TempAlign: TAlign; +begin + if (Abs(FDragStartPos.X - Pos.X) >= FDragThreshold) or + (Abs(FDragStartPos.Y - Pos.Y) >= FDragThreshold) then + begin + Target := DragFindTarget(Pos, TargetHandle, TControlAccessProtected(FDragControl).DragKind, FDragControl); + if (FActiveDrag = dopNone) and (FDragImageList <> nil) then + with FDragStartPos do + FDragImageList.BeginDrag(GetDesktopWindow, X, Y); + DoErase := FActiveDrag <> dopNone; + FActiveDrag := dopDock; + + if DragObject.CanLeave(TWinControl(Target)) then + begin + DoDockOver(dsDragLeave); + if DragObject = nil then + Exit; + DragObject.DragTarget := Target; + DragObject.DragHandle := TargetHandle; + DragObject.DragPos := Pos; + DoDockOver(dsDragEnter); + if DragObject = nil then + Exit; + end; + DragObject.DragPos := Pos; + if DragObject.DragTarget <> nil then + DragObject.DragTargetPos := TControl(DragObject.DragTarget).ScreenToClient(Pos); + DragCursor := DragObject.GetDragCursor(DoDockOver(dsDragMove), Pos.X, Pos.Y); + if FDragImageList <> nil then + begin + if (Target = nil) or (csDisplayDragImage in Target.ControlStyle) then + begin + FDragImageList.DragCursor := DragCursor; + if not FDragImageList.Dragging then + FDragImageList.BeginDrag(GetDesktopWindow, Pos.X, Pos.Y) + else + FDragImageList.DragMove(Pos.X, Pos.Y); + end + else + begin + FDragImageList.EndDrag; + Windows.SetCursor(Screen.Cursors[DragCursor]); + end; + end; + + ResetCursor; + if FActiveDrag = dopDock then + begin + with DragObject do + begin + if Target = nil then + begin + if Assigned(JvGlobalDockClient) then + JvGlobalDockClient.FormPositionDockRect(DragObject); + end + else + begin + DropOnControl := GetDropCtl; + TempAlign := DropAlign; + if DropOnControl = nil then + DoGetDockEdge(TargetControl, DragTargetPos, TempAlign) + else + DoGetDockEdge(DropOnControl, DropOnControl.ScreenToClient(Pos), TempAlign); + DropAlign := TempAlign; + end; + end; + if DragObject <> nil then + DragObject.DrawDragRect(DoErase); + end; + end; +end; + +procedure TJvDockManager.EndLoad; +begin + Dec(FLoadCount); + if FLoadCount <= 0 then + begin + FLoadCount := 0; + end; +end; + +procedure TJvDockManager.EndSave; +begin + Dec(FSaveCount); + if FSaveCount <= 0 then + FSaveCount := 0; +end; + +function TJvDockManager.GetDockSiteAtPos(MousePos: TPoint; + Client: TControl): TWinControl; +var + I: Integer; + R: TRect; + Site: TWinControl; + CanDock, ControlKeyDown: Boolean; + + function ValidDockTarget(Target: TWinControl): Boolean; + var + Info: TCheckTargetInfo; + Control: TWinControl; + R1, R2: TRect; + begin + Result := True; + + Info.CurrentWnd := DragFindWindow(MousePos); + if Info.CurrentWnd = 0 then + Exit; + if GetWindow(Info.CurrentWnd, GW_OWNER) <> Application.Handle then + begin + Control := FindControl(Info.CurrentWnd); + if Control = nil then + Exit; + while Control.Parent <> nil do + Control := Control.Parent; + Info.CurrentWnd := Control.Handle; + end; + + Control := Target; + while Control.Parent <> nil do + Control := Control.Parent; + Info.TargetWnd := Control.Handle; + if Info.CurrentWnd = Info.TargetWnd then + Exit; + + if Client.Parent <> nil then + begin + Control := Client.Parent; + while Control.Parent <> nil do + Control := Control.Parent; + Info.ClientWnd := Control.Handle; + end + else + if Client is TWinControl then + Info.ClientWnd := TWinControl(Client).Handle + else + Info.ClientWnd := 0; + + Info.Found := False; + Info.MousePos := MousePos; + EnumThreadWindows(GetCurrentThreadID, @IsBeforeTargetWindow, Longint(@Info)); + + if Info.Found then + begin + GetWindowRect(Info.CurrentWnd, R1); + DoGetSiteInfo(Target, Client, R2, MousePos, CanDock); + + if (DragObject.Control.HostDockSite <> nil) and + (DragObject.Control.HostDockSite.Handle = Info.CurrentWnd) then + Exit; + if IntersectRect(R1, R1, R2) then + Result := False; + end; + end; + + function IsSiteChildOfClient: Boolean; + begin + if Client is TWinControl then + Result := IsChild(TWinControl(Client).Handle, Site.Handle) + else + Result := False; + end; + +begin + Result := nil; + ControlKeyDown := (GetKeyState(VK_CONTROL) and not $7FFF) <> 0; + if (FDockSiteList = nil) or ControlKeyDown then + Exit; + FQualifyingSites.Clear; + for I := 0 to FDockSiteList.Count - 1 do + begin + Site := TWinControl(FDockSiteList[I]); + if (Site <> Client) and Site.Showing and Site.Enabled and + IsWindowVisible(Site.Handle) and (not IsSiteChildOfClient) then + begin + CanDock := True; + DoGetSiteInfo(Site, Client, R, MousePos, CanDock); + if CanDock and PtInRect(R, MousePos) then + FQualifyingSites.AddSite(Site); + end; + end; + if FQualifyingSites.Count > 0 then + Result := FQualifyingSites.GetTopSite; + if (Result <> nil) and not ValidDockTarget(Result) then + Result := nil; +end; + +function TJvDockManager.GetFormVisible(DockWindow: TWinControl): Boolean; +begin + Result := JvDockControlForm.GetFormVisible(DockWindow); +end; + +procedure TJvDockManager.HideDockForm(DockWindow: TWinControl); +begin + JvDockControlForm.HideDockForm(DockWindow); +end; + +function TJvDockManager.IsDockLoading: Boolean; +begin + Result := FLoadCount > 0; +end; + +function TJvDockManager.IsSaving: Boolean; +begin + Result := FSaveCount > 0; +end; + +{$IFDEF USEJVCL} + +procedure TJvDockManager.LoadDockTreeFromAppStorage(AppStorage: TJvCustomAppStorage; + const AppStoragePath: string = ''); +begin + BeginLoad; + try + JvDockControlForm.LoadDockTreeFromAppStorage(AppStorage, AppStoragePath); + finally + EndLoad; + end; +end; + +{$ELSE} + +procedure TJvDockManager.LoadDockTreeFromFile(const FileName: string); +begin + BeginLoad; + try + JvDockControlForm.LoadDockTreeFromFile(FileName); + finally + EndLoad; + end; +end; + +procedure TJvDockManager.LoadDockTreeFromReg(RootKey: DWORD; const RegPatch: string); +begin + BeginLoad; + try + JvDockControlForm.LoadDockTreeFromReg(RootKey, RegPatch); + finally + EndLoad; + end; +end; + +{$ENDIF USEJVCL} + +procedure TJvDockManager.RegisterDockSite(Site: TWinControl; DoRegister: Boolean); +var + Index: Integer; +begin + if Site <> nil then + begin + if FDockSiteList = nil then + FDockSiteList := TList.Create; + Index := FDockSiteList.IndexOf(Pointer(Site)); + if DoRegister then + begin + if Index = -1 then + FDockSiteList.Add(Pointer(Site)); + end + else + begin + if Index <> -1 then + FDockSiteList.Delete(Index); + end; + end; +end; + +procedure TJvDockManager.ResetCursor; +begin + if (JvGlobalDockClient <> nil) and (JvGlobalDockClient.DockStyle <> nil) then + JvGlobalDockClient.DockStyle.ResetCursor(DragObject); +end; + +{$IFDEF USEJVCL} + +procedure TJvDockManager.SaveDockTreeToAppStorage(AppStorage: TJvCustomAppStorage; + const AppStoragePath: string = ''); +begin + BeginSave; + try + JvDockControlForm.SaveDockTreeToAppStorage(AppStorage, AppStoragePath); + finally + EndSave; + end; +end; + +{$ELSE} + +procedure TJvDockManager.SaveDockTreeToFile(const FileName: string); +begin + BeginSave; + try + JvDockControlForm.SaveDockTreeToFile(FileName); + finally + EndSave; + end; +end; + +procedure TJvDockManager.SaveDockTreeToReg(RootKey: DWORD; const RegPatch: string); +begin + BeginSave; + try + JvDockControlForm.SaveDockTreeToReg(RootKey, RegPatch); + finally + EndSave; + end; +end; + +{$ENDIF USEJVCL} + +procedure TJvDockManager.SetConjoinDockHostBorderStyle(Value: TFormBorderStyle); +begin + JvDockControlForm.SetConjoinDockHostBorderStyle(Value); +end; + +procedure TJvDockManager.SetTabDockHostBorderStyle(Value: TFormBorderStyle); +begin + JvDockControlForm.SetTabDockHostBorderStyle(Value); +end; + +procedure TJvDockManager.ShowDockForm(DockWindow: TWinControl); +begin + JvDockControlForm.ShowDockForm(DockWindow); +end; + +//=== { TJvDockPageControl } ================================================= + +constructor TJvDockPageControl.Create(AOwner: TComponent); +begin + inherited Create(AOwner); + ControlStyle := [csDoubleClicks, csOpaque]; + FPages := TList.Create; + FTabSheetClass := TJvDockTabSheet; +end; + +destructor TJvDockPageControl.Destroy; +var + I: Integer; +begin + for I := 0 to FPages.Count - 1 do + TJvDockTabSheet(FPages[I]).FPageControl := nil; + FPages.Free; + inherited Destroy; +end; + +function TJvDockPageControl.CanShowTab(TabIndex: Integer): Boolean; +begin + Result := TJvDockTabSheet(FPages[TabIndex]).Enabled; +end; + +procedure TJvDockPageControl.Change; +var + Form: TCustomForm; +begin + if TabIndex >= 0 then + UpdateActivePage; + if csDesigning in ComponentState then + begin + Form := GetParentForm(Self); + if (Form <> nil) and (Form.Designer <> nil) then + Form.Designer.Modified; + end; + inherited Change; +end; + +procedure TJvDockPageControl.ChangeActivePage(Page: TJvDockTabSheet); +var + ParentForm: TCustomForm; +begin + if FActivePage <> Page then + begin + ParentForm := GetParentForm(Self); + if (ParentForm <> nil) and (FActivePage <> nil) and + FActivePage.ContainsControl(ParentForm.ActiveControl) then + begin + ParentForm.ActiveControl := FActivePage; + if ParentForm.ActiveControl <> FActivePage then + begin + TabIndex := FActivePage.TabIndex; + Exit; + end; + end; + if Page <> nil then + begin + Page.BringToFront; + Page.Visible := True; + if (ParentForm <> nil) and (FActivePage <> nil) and + (ParentForm.ActiveControl = FActivePage) then + if Page.CanFocus then + ParentForm.ActiveControl := Page + else + ParentForm.ActiveControl := Self; + end; + if FActivePage <> nil then + FActivePage.Visible := False; + FActivePage := Page; + if (ParentForm <> nil) and (FActivePage <> nil) and + (ParentForm.ActiveControl = FActivePage) then + FActivePage.SelectFirst; + end; +end; + +procedure TJvDockPageControl.CMDesignHitTest(var Msg: TCMDesignHitTest); +var + HitIndex: Integer; + HitTestInfo: TTCHitTestInfo; +begin + HitTestInfo.pt := SmallPointToPoint(Msg.Pos); + HitIndex := SendMessage(Handle, TCM_HITTEST, 0, Longint(@HitTestInfo)); + if (HitIndex >= 0) and (HitIndex <> TabIndex) then + Msg.Result := 1; +end; + +procedure TJvDockPageControl.CMDialogKey(var Msg: TCMDialogKey); +begin + if (Focused or Windows.IsChild(Handle, Windows.GetFocus)) and + (Msg.CharCode = VK_TAB) and (GetKeyState(VK_CONTROL) < 0) then + begin + SelectNextPage(GetKeyState(VK_SHIFT) >= 0); + Msg.Result := 1; + end + else + inherited; +end; + +procedure TJvDockPageControl.CMDockClient(var Msg: TCMDockClient); +var + IsVisible: Boolean; + DockCtl: TControl; +begin + Msg.Result := 0; + if FTabSheetClass <> nil then + FNewDockSheet := FTabSheetClass.Create(Self) + else + FNewDockSheet := TJvDockTabSheet.Create(Self); + try + try + DockCtl := Msg.DockSource.Control; + FNewDockSheet.PageControl := Self; + if DockCtl is TCustomForm then + FNewDockSheet.Caption := TCustomForm(DockCtl).Caption; + DockCtl.Dock(Self, Msg.DockSource.DockRect); + except + FNewDockSheet.Free; + raise; + end; + IsVisible := DockCtl.Visible; + FNewDockSheet.TabVisible := IsVisible; + if IsVisible then + ActivePage := FNewDockSheet; + DockCtl.Align := alClient; + finally + FNewDockSheet := nil; + end; +end; + +procedure TJvDockPageControl.CMDockNotification(var Msg: TCMDockNotification); +var + I: Integer; + S: string; + Page: TJvDockTabSheet; +begin + Page := GetPageFromDockClient(Msg.Client); + if Page <> nil then + case Msg.NotifyRec.ClientMsg of + WM_SETTEXT: + begin + S := PChar(Msg.NotifyRec.MsgLParam); + for I := 1 to Length(S) do + if S[I] in [#13, #10] then + begin + SetLength(S, I - 1); + Break; + end; + Page.Caption := S; + end; + CM_VISIBLECHANGED: + Page.TabVisible := Boolean(Msg.NotifyRec.MsgWParam); + end; + inherited; +end; + +procedure TJvDockPageControl.CMUnDockClient(var Msg: TCMUnDockClient); +var + Page: TJvDockTabSheet; +begin + Msg.Result := 0; + Page := GetPageFromDockClient(Msg.Client); + if Page <> nil then + begin + FUndockingPage := Page; + Msg.Client.Align := alNone; + end; + if (VisibleDockClientCount = 1) or (DockClientCount <= 2) then + PostMessage(Parent.Handle, WM_CLOSE, 0, 0); +end; + +procedure TJvDockPageControl.DeleteTab(Page: TJvDockTabSheet; Index: Integer); +var + UpdateIndex: Boolean; +begin + UpdateIndex := Page = ActivePage; + Tabs.Delete(Index); + if UpdateIndex then + begin + if Index >= Tabs.Count then + Index := Tabs.Count - 1; + TabIndex := Index; + end; + UpdateActivePage; +end; + +procedure TJvDockPageControl.DoAddDockClient(Client: TControl; const ARect: TRect); +begin + if FNewDockSheet <> nil then + Client.Parent := FNewDockSheet; +end; + +procedure TJvDockPageControl.DockOver(Source: TDragDockObject; X, Y: Integer; + State: TDragState; var Accept: Boolean); +var + R: TRect; +begin + GetWindowRect(Handle, R); + Source.DockRect := R; + DoDockOver(Source, X, Y, State, Accept); +end; + +function TJvDockPageControl.DoMouseEvent(var Msg: TWMMouse; + Control: TControl): TWMNCHitMessage; +begin + Result := JvDockCreateNCMessage(Control, Msg.Msg + WM_NCMOUSEFIRST - WM_MOUSEFIRST, + HTCAPTION, SmallPointToPoint(Msg.Pos)); +end; + +procedure TJvDockPageControl.DoRemoveDockClient(Client: TControl); +begin + if (FUndockingPage <> nil) and not (csDestroying in ComponentState) then + begin + SelectNextPage(True); + FUndockingPage.Free; + FUndockingPage := nil; + end; +end; + +function TJvDockPageControl.FindNextPage(CurPage: TJvDockTabSheet; + GoForward, CheckTabVisible: Boolean): TJvDockTabSheet; +var + I, StartIndex: Integer; +begin + if FPages.Count <> 0 then + begin + StartIndex := FPages.IndexOf(CurPage); + if StartIndex = -1 then + if GoForward then + StartIndex := FPages.Count - 1 + else + StartIndex := 0; + I := StartIndex; + repeat + if GoForward then + begin + Inc(I); + if I = FPages.Count then + I := 0; + end + else + begin + if I = 0 then + I := FPages.Count; + Dec(I); + end; + Result := FPages[I]; + if not CheckTabVisible or Result.TabVisible then + Exit; + until I = StartIndex; + end; + Result := nil; +end; + +function TJvDockPageControl.GetActivePageIndex: Integer; +begin + if ActivePage <> nil then + Result := ActivePage.GetPageIndex + else + Result := -1; +end; + +procedure TJvDockPageControl.GetChildren(Proc: TGetChildProc; Root: TComponent); +var + I: Integer; +begin + for I := 0 to FPages.Count - 1 do + Proc(TComponent(FPages[I])); +end; + +function TJvDockPageControl.GetCount: Integer; +begin + Result := FPages.Count; +end; + +function TJvDockPageControl.GetDockClientFromMousePos(MousePos: TPoint): TControl; +var + I, HitIndex: Integer; + HitTestInfo: TTCHitTestInfo; + Page: TJvDockTabSheet; +begin + Result := nil; + if DockSite then + begin + HitTestInfo.pt := MousePos; + HitIndex := SendMessage(Handle, TCM_HITTEST, 0, Longint(@HitTestInfo)); + if HitIndex >= 0 then + begin + Page := nil; + for I := 0 to HitIndex do + Page := FindNextPage(Page, True, True); + if (Page <> nil) and (Page.ControlCount > 0) then + begin + Result := Page.Controls[0]; + if Result.HostDockSite <> Self then + Result := nil; + end; + end; + end; +end; + +function TJvDockPageControl.GetImageIndex(TabIndex: Integer): Integer; +var + I, Visible, NotVisible: Integer; +begin + if Assigned(FOnGetImageIndex) then + Result := inherited GetImageIndex(TabIndex) + else + begin + Visible := 0; + NotVisible := 0; + for I := 0 to FPages.Count - 1 do + begin + if not GetPage(I).TabVisible then + Inc(NotVisible) + else + Inc(Visible); + if Visible = TabIndex + 1 then + Break; + end; + Result := GetPage(TabIndex + NotVisible).ImageIndex; + end; +end; + +function TJvDockPageControl.GetPage(Index: Integer): TJvDockTabSheet; +begin + Result := FPages[Index]; +end; + +function TJvDockPageControl.GetPageFromDockClient(Client: TControl): TJvDockTabSheet; +var + I: Integer; +begin + Result := nil; + for I := 0 to Count - 1 do + if (Client.Parent = Pages[I]) and (Client.HostDockSite = Self) then + begin + Result := Pages[I]; + Break; + end; +end; + +procedure TJvDockPageControl.GetSiteInfo(Client: TControl; var InfluenceRect: TRect; + MousePos: TPoint; var CanDock: Boolean); +begin + CanDock := GetPageFromDockClient(Client) = nil; + inherited GetSiteInfo(Client, InfluenceRect, MousePos, CanDock); +end; + +procedure TJvDockPageControl.InsertPage(Page: TJvDockTabSheet); +begin + FPages.Add(Page); + Page.FPageControl := Self; + Page.UpdateTabShowing; +end; + +procedure TJvDockPageControl.InsertTab(Page: TJvDockTabSheet); +begin + Tabs.InsertObject(Page.TabIndex, Page.Caption, Page); + UpdateActivePage; +end; + +procedure TJvDockPageControl.Loaded; +begin + inherited Loaded; + UpdateTabHighlights; +end; + +procedure TJvDockPageControl.MoveTab(CurIndex, NewIndex: Integer); +begin + Tabs.Move(CurIndex, NewIndex); +end; + +procedure TJvDockPageControl.RemovePage(Page: TJvDockTabSheet); +var + NextSheet: TJvDockTabSheet; +begin + NextSheet := FindNextPage(Page, True, not (csDesigning in ComponentState)); + if NextSheet = Page then + NextSheet := nil; + Page.SetTabShowing(False); + Page.FPageControl := nil; + FPages.Remove(Page); + SetActivePage(NextSheet); +end; + +procedure TJvDockPageControl.SelectNextPage(GoForward: Boolean; CheckTabVisible: Boolean = True); +var + Page: TJvDockTabSheet; +begin + Page := FindNextPage(ActivePage, GoForward, CheckTabVisible); + if (Page <> nil) and (Page <> ActivePage) and CanChange then + begin + SetActivePage(Page); + Change; + end; +end; + +procedure TJvDockPageControl.SetActivePage(Page: TJvDockTabSheet); +begin + if (Page <> nil) and (Page.PageControl <> Self) then + Exit; + ChangeActivePage(Page); + if Page = nil then + TabIndex := -1 + else + if Page = FActivePage then + TabIndex := Page.TabIndex; +end; + +procedure TJvDockPageControl.SetActivePageIndex(const Value: Integer); +begin + if (Value > -1) and (Value < Count) then + ActivePage := Pages[Value] + else + ActivePage := nil; +end; + +procedure TJvDockPageControl.SetChildOrder(Child: TComponent; Order: Integer); +begin + TJvDockTabSheet(Child).PageIndex := Order; +end; + +procedure TJvDockPageControl.ShowControl(AControl: TControl); +begin + if (AControl is TJvDockTabSheet) and (TJvDockTabSheet(AControl).PageControl = Self) then + SetActivePage(TJvDockTabSheet(AControl)); + inherited ShowControl(AControl); +end; + +procedure TJvDockPageControl.UpdateActivePage; +begin + if TabIndex >= 0 then + SetActivePage(TJvDockTabSheet(Tabs.Objects[TabIndex])) + else + SetActivePage(nil); +end; + +procedure TJvDockPageControl.UpdateTab(Page: TJvDockTabSheet); +begin + Tabs[Page.TabIndex] := Page.Caption; +end; + +procedure TJvDockPageControl.UpdateTabHighlights; +var + I: Integer; +begin + for I := 0 to Count - 1 do + Pages[I].SetHighlighted(Pages[I].FHighlighted); +end; + +procedure TJvDockPageControl.WMLButtonDblClk(var Msg: TWMLButtonDblClk); +var + DockCtl: TControl; +begin + inherited; + if JvGlobalDockClient <> nil then + DockCtl := ButtonEvent(Self, Msg, mbLeft, msTabPage, JvGlobalDockClient.DoNCButtonDblClk) + else + DockCtl := nil; + if (DockCtl <> nil) and JvGlobalDockClient.CanFloat then + DockCtl.ManualDock(nil, nil, alNone); +end; + +procedure TJvDockPageControl.WMLButtonDown(var Msg: TWMLButtonDown); +var + DockCtl: TControl; +begin + inherited; + if JvGlobalDockClient <> nil then + DockCtl := ButtonEvent(Self, Msg, mbLeft, msTabPage, JvGlobalDockClient.DoNCButtonDown) + else + DockCtl := nil; + if (DockCtl <> nil) and (Style = tsTabs) then + JvGlobalDockManager.BeginDrag(DockCtl, False); +end; + +procedure TJvDockPageControl.WMLButtonUp(var Msg: TWMLButtonUp); +begin + inherited; + if JvGlobalDockClient <> nil then + ButtonEvent(Self, Msg, mbLeft, msTabPage, JvGlobalDockClient.DoNCButtonUp); +end; + +procedure TJvDockPageControl.WMMButtonDblClk(var Msg: TWMMButtonDblClk); +begin + inherited; + if JvGlobalDockClient <> nil then + ButtonEvent(Self, Msg, mbMiddle, msTabPage, JvGlobalDockClient.DoNCButtonDblClk); +end; + +procedure TJvDockPageControl.WMMButtonDown(var Msg: TWMMButtonDown); +begin + inherited; + if JvGlobalDockClient <> nil then + ButtonEvent(Self, Msg, mbMiddle, msTabPage, JvGlobalDockClient.DoNCButtonDown); +end; + +procedure TJvDockPageControl.WMMButtonUp(var Msg: TWMMButtonUp); +begin + inherited; + if JvGlobalDockClient <> nil then + ButtonEvent(Self, Msg, mbMiddle, msTabPage, JvGlobalDockClient.DoNCButtonUp); +end; + +procedure TJvDockPageControl.WMRButtonDblClk(var Msg: TWMRButtonDblClk); +begin + inherited; + if JvGlobalDockClient <> nil then + ButtonEvent(Self, Msg, mbRight, msTabPage, JvGlobalDockClient.DoNCButtonDblClk); +end; + +procedure TJvDockPageControl.WMRButtonDown(var Msg: TWMRButtonDown); +begin + Msg.Msg := WM_LBUTTONDOWN; + inherited; + if JvGlobalDockClient <> nil then + ButtonEvent(Self, Msg, mbRight, msTabPage, JvGlobalDockClient.DoNCButtonDown); +end; + +procedure TJvDockPageControl.WMRButtonUp(var Msg: TWMRButtonUp); +begin + inherited; + if JvGlobalDockClient <> nil then + ButtonEvent(Self, Msg, mbRight, msTabPage, JvGlobalDockClient.DoNCButtonUp); +end; + +//=== { TJvDockTabSheet } ==================================================== + +constructor TJvDockTabSheet.Create(AOwner: TComponent); +begin + inherited Create(AOwner); + Align := alClient; + ControlStyle := ControlStyle + [csAcceptsControls, csNoDesignVisible]; + Visible := False; + FTabVisible := True; + FHighlighted := False; + FImageIndex := -1; +end; + +destructor TJvDockTabSheet.Destroy; +begin + if FPageControl <> nil then + begin + if FPageControl.FUndockingPage = Self then + FPageControl.FUndockingPage := nil; + FPageControl.RemovePage(Self); + end; + inherited Destroy; +end; + +procedure TJvDockTabSheet.CMShowingChanged(var Msg: TMessage); +begin + inherited; + if Showing then + try + DoShow + except + Application.HandleException(Self); + end + else + if not Showing then + try + DoHide; + except + Application.HandleException(Self); + end; +end; + +procedure TJvDockTabSheet.CMTextChanged(var Msg: TMessage); +begin + if FTabShowing then + FPageControl.UpdateTab(Self); +end; + +procedure TJvDockTabSheet.CreateParams(var Params: TCreateParams); +begin + inherited CreateParams(Params); + with Params.WindowClass do + style := style and not (CS_HREDRAW or CS_VREDRAW); +end; + +procedure TJvDockTabSheet.DoHide; +begin + if Assigned(FOnHide) then + FOnHide(Self); +end; + +procedure TJvDockTabSheet.DoShow; +begin + if Assigned(FOnShow) then + FOnShow(Self); +end; + +function TJvDockTabSheet.GetPageIndex: Integer; +begin + if (FPageControl <> nil) and (FPageControl.FPages <> nil) then + Result := FPageControl.FPages.IndexOf(Self) + else + Result := -1; +end; + +function TJvDockTabSheet.GetTabIndex: Integer; +var + I: Integer; +begin + Result := 0; + if not FTabShowing then + Dec(Result) + else + for I := 0 to PageIndex - 1 do + if TJvDockTabSheet(FPageControl.FPages[I]).FTabShowing then + Inc(Result); +end; + +procedure TJvDockTabSheet.ReadState(Reader: TReader); +begin + inherited ReadState(Reader); + if Reader.Parent is TJvDockPageControl then + PageControl := TJvDockPageControl(Reader.Parent); +end; + +procedure TJvDockTabSheet.SetHighlighted(Value: Boolean); +begin + if not (csReading in ComponentState) then + SendMessage(PageControl.Handle, TCM_HIGHLIGHTITEM, TabIndex, + MakeLong(Word(Value), 0)); + FHighlighted := Value; +end; + +procedure TJvDockTabSheet.SetImageIndex(Value: TImageIndex); +begin + if FImageIndex <> Value then + begin + FImageIndex := Value; + if FTabShowing then + FPageControl.UpdateTab(Self); + end; +end; + +procedure TJvDockTabSheet.SetPageControl(APageControl: TJvDockPageControl); +begin + if FPageControl <> APageControl then + begin + if FPageControl <> nil then + FPageControl.RemovePage(Self); + Parent := APageControl; + if APageControl <> nil then + APageControl.InsertPage(Self); + end; +end; + +procedure TJvDockTabSheet.SetPageIndex(Value: Integer); +var + I, MaxPageIndex: Integer; +begin + if (FPageControl <> nil) and (FPageControl.FPages <> nil) then + begin + MaxPageIndex := FPageControl.FPages.Count - 1; + if Value > MaxPageIndex then + raise EListError.CreateResFmt(@SPageIndexError, [Value, MaxPageIndex]); + I := TabIndex; + FPageControl.FPages.Move(PageIndex, Value); + if I >= 0 then + FPageControl.MoveTab(I, TabIndex); + end; +end; + +procedure TJvDockTabSheet.SetTabShowing(Value: Boolean); +var + Index: Integer; +begin + if FTabShowing <> Value then + if Value then + begin + FTabShowing := True; + FPageControl.InsertTab(Self); + end + else + begin + Index := TabIndex; + FTabShowing := False; + FPageControl.DeleteTab(Self, Index); + end; +end; + +procedure TJvDockTabSheet.SetTabVisible(Value: Boolean); +begin + if FTabVisible <> Value then + begin + FTabVisible := Value; + UpdateTabShowing; + end; +end; + +procedure TJvDockTabSheet.UpdateTabShowing; +begin + SetTabShowing((FPageControl <> nil) and FTabVisible); +end; + +//=== { TJvDockTabStrings } ================================================== + +procedure TJvDockTabStrings.Clear; +begin + if SendMessage(FTabControl.Handle, TCM_DELETEALLITEMS, 0, 0) = 0 then + TabControlError(sTabFailClear); + FTabControl.TabsChanged; +end; + +procedure TJvDockTabStrings.Delete(Index: Integer); +begin + if SendMessage(FTabControl.Handle, TCM_DELETEITEM, Index, 0) = 0 then + TabControlError(Format(sTabFailDelete, [Index])); + FTabControl.TabsChanged; +end; + +function TJvDockTabStrings.Get(Index: Integer): string; +const + RTL: array [Boolean] of Longint = (0, TCIF_RTLREADING); +var + TCItem: TTCItem; + Buffer: array [0..4095] of Char; +begin + TCItem.mask := TCIF_TEXT or RTL[FTabControl.UseRightToLeftReading]; + TCItem.pszText := Buffer; + TCItem.cchTextMax := SizeOf(Buffer); + if SendMessage(FTabControl.Handle, TCM_GETITEM, Index, + Longint(@TCItem)) = 0 then + TabControlError(Format(sTabFailRetrieve, [Index])); + Result := Buffer; +end; + +function TJvDockTabStrings.GetCount: Integer; +begin + Result := SendMessage(FTabControl.Handle, TCM_GETITEMCOUNT, 0, 0); +end; + +function TJvDockTabStrings.GetObject(Index: Integer): TObject; +var + TCItem: TTCItem; +begin + TCItem.mask := TCIF_PARAM; + if SendMessage(FTabControl.Handle, TCM_GETITEM, Index, + Longint(@TCItem)) = 0 then + TabControlError(Format(sTabFailGetObject, [Index])); + Result := TObject(TCItem.lParam); +end; + +procedure TJvDockTabStrings.Insert(Index: Integer; const S: string); +const + RTL: array [Boolean] of Longint = (0, TCIF_RTLREADING); +var + TCItem: TTCItem; +begin + TCItem.mask := TCIF_TEXT or RTL[FTabControl.UseRightToLeftReading] or + TCIF_IMAGE; + TCItem.pszText := PChar(S); + TCItem.iImage := FTabControl.GetImageIndex(Index); + if SendMessage(FTabControl.Handle, TCM_INSERTITEM, Index, + Longint(@TCItem)) < 0 then + TabControlError(Format(sTabFailSet, [S, Index])); + FTabControl.TabsChanged; +end; + +procedure TJvDockTabStrings.Put(Index: Integer; const S: string); +const + RTL: array [Boolean] of Longint = (0, TCIF_RTLREADING); +var + TCItem: TTCItem; +begin + TCItem.mask := TCIF_TEXT or RTL[FTabControl.UseRightToLeftReading] or + TCIF_IMAGE; + TCItem.pszText := PChar(S); + TCItem.iImage := FTabControl.GetImageIndex(Index); + if SendMessage(FTabControl.Handle, TCM_SETITEM, Index, + Longint(@TCItem)) = 0 then + TabControlError(Format(sTabFailSet, [S, Index])); + FTabControl.TabsChanged; +end; + +procedure TJvDockTabStrings.PutObject(Index: Integer; AObject: TObject); +var + TCItem: TTCItem; +begin + TCItem.mask := TCIF_PARAM; + TCItem.lParam := Longint(AObject); + if SendMessage(FTabControl.Handle, TCM_SETITEM, Index, + Longint(@TCItem)) = 0 then + TabControlError(Format(sTabFailSetObject, [Index])); +end; + +procedure TJvDockTabStrings.SetUpdateState(Updating: Boolean); +begin + FTabControl.FUpdating := Updating; + SendMessage(FTabControl.Handle, WM_SETREDRAW, Ord(not Updating), 0); + if not Updating then + begin + FTabControl.Invalidate; + FTabControl.TabsChanged; + end; +end; + +//=== { TSiteList } ========================================================== + +procedure TSiteList.AddSite(ASite: TWinControl); +var + SI: PSiteInfoRec; + Index: Integer; + + function GetTopParent: HWND; + var + NextParent: HWND; + begin + NextParent := ASite.Handle; + Result := NextParent; + while NextParent <> 0 do + begin + Result := NextParent; + NextParent := GetParent(NextParent); + end; + end; + +begin + New(SI); + SI.Site := ASite; + SI.TopParent := GetTopParent; + if Find(SI.TopParent, Index) then + Insert(Index, SI) + else + Add(SI); +end; + +procedure TSiteList.Clear; +var + I: Integer; +begin + for I := 0 to Count - 1 do + Dispose(PSiteInfoRec(Items[I])); + inherited Clear; +end; + +function TSiteList.Find(ParentWnd: THandle; var Index: Integer): Boolean; +begin + Index := 0; + Result := False; + while Index < Count do + begin + Result := (PSiteInfoRec(Items[Index]).TopParent = ParentWnd); + if Result then + Exit; + Inc(Index); + end; +end; + +function TSiteList.GetTopSite: TWinControl; +var + Index: Integer; + DesktopWnd, CurrentWnd: HWND; +begin + Result := nil; + if Count = 0 then + Exit + else + if Count = 1 then + Result := PSiteInfoRec(Items[0]).Site + else + begin + DesktopWnd := GetDesktopWindow; + CurrentWnd := GetTopWindow(DesktopWnd); + while (Result = nil) and (CurrentWnd <> 0) do + if Find(CurrentWnd, Index) then + Result := PSiteInfoRec(List[Index])^.Site + else + CurrentWnd := GetNextWindow(CurrentWnd, GW_HWNDNEXT); + end; +end; + +{$IFDEF USEJVCL} +{$IFDEF UNITVERSIONING} +initialization + RegisterUnitVersion(HInstance, UnitVersioning); + +finalization + UnregisterUnitVersion(HInstance); +{$ENDIF UNITVERSIONING} +{$ENDIF USEJVCL} + +end. diff --git a/JvDockTree.pas b/JvDockTree.pas new file mode 100644 index 000000000..e449a0aa1 --- /dev/null +++ b/JvDockTree.pas @@ -0,0 +1,4497 @@ +{----------------------------------------------------------------------------- +The contents of this file are subject to the Mozilla Public License +Version 1.1 (the "License"); you may not use this file except in compliance +with the License. You may obtain a copy of the License at +http://www.mozilla.org/MPL/MPL-1.1.html + +Software distributed under the License is distributed on an "AS IS" basis, +WITHOUT WARRANTY OF ANY KIND, either expressed or implied. See the License for +the specific language governing rights and limitations under the License. + +The Original Code is: JvDockTree.pas, released on 2003-12-31. + +The Initial Developer of the Original Code is luxiaoban. +Portions created by luxiaoban are Copyright (C) 2002,2003 luxiaoban. +All Rights Reserved. + +Contributor(s): + +You may retrieve the latest version of this file at the Project JEDI's JVCL home page, +located at http://jvcl.sourceforge.net + +Known Issues: +-----------------------------------------------------------------------------} +// $Id: JvDockTree.pas 11276 2007-04-24 19:33:37Z remkobonte $ + +unit JvDockTree; + +{$I jvcl.inc} + +{$DEFINE JVDOCK_QUERY} // experimental! + +interface + +uses + {$IFDEF USEJVCL} + {$IFDEF UNITVERSIONING} + JclUnitVersioning, + {$ENDIF UNITVERSIONING} + {$ENDIF USEJVCL} + ComCtrls, + Windows, Messages, Classes, Graphics, Controls, Forms, + {$IFDEF USEJVCL} + JvComponentBase, + {$ENDIF USEJVCL} + JvDockSupportClass; + +type + TJvDockTree = class; + + IJvDockManager = interface(IDockManager) + ['{7B0AACBC-E9BF-42F8-9629-E551067090B2}'] + function GetActiveControl: TControl; + procedure SetActiveControl(const Value: TControl); + function GetGrabberSize: Integer; + procedure SetGrabberSize(const Value: Integer); + function GetDockSplitterWidth: Integer; + procedure SetDockSplitterWidth(const Value: Integer); + function GetBorderWidth: Integer; + procedure SetBorderWidth(const Value: Integer); + function GetDockRect: TRect; + procedure SetDockRect(const Value: TRect); + function GetDockSiteSize: Integer; + procedure SetDockSiteSize(const Value: Integer); + function GetMinSize: Integer; + procedure BeginResizeDockSite; + procedure EndResizeDockSite; + function GetDockEdge(DockRect: TRect; MousePos: TPoint; + var DropAlign: TAlign; Control: TControl): TControl; + function GetHTFlag(MousePos: TPoint): Integer; + procedure GetSiteInfo(Client: TControl; + var InfluenceRect: TRect; MousePos: TPoint; var CanDock: Boolean); + procedure ShowControl(Control: TControl); + procedure HideControl(Control: TControl); + procedure ShowAllControl; + procedure HideAllControl; + procedure ShowSingleControl(Control: TControl); + procedure HideSingleControl(Control: TControl); + procedure ReplaceZoneChild(OldControl, NewControl: TControl); + function HasZoneWithControl(Control: TControl): Boolean; + function GetDockClientLimit(Orient: TDockOrientation; IsMin: Boolean): Integer; + function GetFrameRect(Control: TControl): TRect; + function GetFrameRectEx(Control: TControl): TRect; + {$IFDEF JVDOCK_QUERY} + // Descends the Tree and Finds and return TWinControls docked to a particular parent. + procedure ControlQuery(DockedTo: TWinControl; FoundItems: TList); + {$ENDIF JVDOCK_QUERY} + // backwards compatibility: Mantis 4100 + property ActiveControl: TControl read GetActiveControl write SetActiveControl; + property GrabberSize: Integer read GetGrabberSize write SetGrabberSize; + property SplitterWidth: Integer read GetDockSplitterWidth write SetDockSplitterWidth; + property BorderWidth: Integer read GetBorderWidth write SetBorderWidth; + property DockSiteSize: Integer read GetDockSiteSize write SetDockSiteSize; + property DockRect: TRect read GetDockRect write SetDockRect; + property MinSize: Integer read GetMinSize; + //property AlwaysAdjust: Boolean read GetAlwaysAdjust write SetAlwaysAdjust; + end; + + { Left dock panel with 3 zones; zone 1 contains zone 2 & 3; zone 2 contains + control A; zone 3 contains control B. + Right dock panel with 3 zones; zone 4 contains zone 5 & 6; zone 5 contains + control C; zone 6 contains control D. + + Zone 1 Zone 2 Zone 3 Zone 4 Zone 5 Zone 6 + ----------------------------------------------------------------------------- + Contains Zone 2+3 Control A Control B Zone 5+6 Control C Control D + Orientation Vertical No No Horiz. No No + ZoneLimit x2-x0 x1 x2 x4-x3 y1 y2 + LimitBegin x0 x0 x1 y0 y0 y1 + LimitSize x2-x0 x1-x0 x2-x0 y2-y0 y1-y0 y2-y1 + + y0 + --------------------------/ + | | | | | + | | | | C | + | | | | | y1 + | A | B | |-----|-/ + | | | | | + | | | | D | + | | | | | y2 + |---|---|---------|-----|-/ + \ \ \ \ \ + x0 x1 x2 x3 x4 + } + + TJvDockZone = class(TObject) + private + FChildControl: TWinControl; + FChildZones: TJvDockZone; + FNextSibling: TJvDockZone; + FOrientation: TDockOrientation; + FParentZone: TJvDockZone; + FPrevSibling: TJvDockZone; + FTree: TJvDockTree; { Owner } + FZoneLimit: Integer; + FVisibleSize: Integer; + FVisibled: Boolean; + FControlVisibled: Boolean; + FIsInside: Boolean; + function GetFirstSibling: TJvDockZone; + function GetLastSibling: TJvDockZone; + function GetFirstChild: TJvDockZone; + function GetLastChild: TJvDockZone; + function GetTopLeftArr(Orient: TDockOrientation): Integer; + function GetHeightWidthArr(Orient: TDockOrientation): Integer; + function GetAfterClosestVisibleZone: TJvDockZone; + function GetBeforeClosestVisibleZone: TJvDockZone; + function GetAfterApoapsisVisibleZone: TJvDockZone; + function GetBeforeApoapsisVisibleZone: TJvDockZone; + function GetNextSiblingCount: Integer; + function GetPrevSiblingCount: Integer; + procedure SetVisibled(const Value: Boolean); + procedure SetZoneLimit(const Value: Integer); + function GetVisibleNextSiblingCount: Integer; + function GetVisibleNextSiblingTotal: Integer; + function GetVisiblePrevSiblingCount: Integer; + function GetVisiblePrevSiblingTotal: Integer; + function GetFirstVisibleChildZone: TJvDockZone; + function GetLastVisibleChildZone: TJvDockZone; + procedure SetIsInside(const Value: Boolean); + protected + procedure AdjustZoneLimit(Value: Integer); virtual; + procedure LButtonDblClkMethod; virtual; + function GetChildCount: Integer; + function GetVisibleChildCount: Integer; + function GetChildTotal: Integer; + function GetVisibleChildTotal: Integer; + function GetLimitBegin: Integer; + function GetLimitSize: Integer; + function GetTopLeft(Orient: Integer): Integer; + function GetHeightWidth(Orient: Integer): Integer; + function GetControlName: string; + function GetSplitterLimit(IsMin: Boolean): Integer; virtual; + function DoGetSplitterLimit(Orientation: TDockOrientation; + IsMin: Boolean; var LimitResult: Integer): Integer; virtual; + function SetControlName(const Value: string): Boolean; + procedure DoCustomSetControlName; virtual; + procedure SetChildControlVisible(Client: TControl; AVisible: Boolean); virtual; + public + constructor Create(ATree: TJvDockTree); virtual; + procedure Insert(DockSize: Integer; Hide: Boolean); virtual; + procedure Remove(DockSize: Integer; Hide: Boolean); virtual; + procedure InsertOrRemove(DockSize: Integer; Insert: Boolean; Hide: Boolean); virtual; + procedure ResetChildren(Exclude: TJvDockZone); virtual; + procedure Update; virtual; + function GetFrameRect: TRect; virtual; + procedure SetZoneSize(Size: Integer; Show: Boolean); virtual; + property BeforeClosestVisibleZone: TJvDockZone read GetBeforeClosestVisibleZone; + property AfterClosestVisibleZone: TJvDockZone read GetAfterClosestVisibleZone; + property BeforeApoapsisVisibleZone: TJvDockZone read GetBeforeApoapsisVisibleZone; + property AfterApoapsisVisibleZone: TJvDockZone read GetAfterApoapsisVisibleZone; + property FirstVisibleChildZone: TJvDockZone read GetFirstVisibleChildZone; + property LastVisibleChildZone: TJvDockZone read GetLastVisibleChildZone; + property ChildCount: Integer read GetChildCount; + property ChildTotal: Integer read GetChildTotal; + property ChildZones: TJvDockZone read FChildZones write FChildZones; + property ChildControl: TWinControl read FChildControl write FChildControl; + property FirstChild: TJvDockZone read GetFirstChild; + property FirstSibling: TJvDockZone read GetFirstSibling; + property Height: Integer index Ord(doHorizontal) read GetHeightWidth; + property HeightWidth[Orient: TDockOrientation]: Integer read GetHeightWidthArr; + property LastChild: TJvDockZone read GetLastChild; + property LastSibling: TJvDockZone read GetLastSibling; + property Left: Integer index Ord(doVertical) read GetTopLeft; + property LimitBegin: Integer read GetLimitBegin; + property LimitSize: Integer read GetLimitSize; + property NextSibling: TJvDockZone read FNextSibling write FNextSibling; + property NextSiblingCount: Integer read GetNextSiblingCount; + property Orientation: TDockOrientation read FOrientation write FOrientation; + property ParentZone: TJvDockZone read FParentZone write FParentZone; + property PrevSibling: TJvDockZone read FPrevSibling write FPrevSibling; + property PrevSiblingCount: Integer read GetPrevSiblingCount; + property Top: Integer index Ord(doHorizontal) read GetTopLeft; + property TopLeft[Orient: TDockOrientation]: Integer read GetTopLeftArr; + property Tree: TJvDockTree read FTree; + property VisibleChildCount: Integer read GetVisibleChildCount; + property VisibleChildTotal: Integer read GetVisibleChildTotal; + property VisiblePrevSiblingCount: Integer read GetVisiblePrevSiblingCount; + property VisiblePrevSiblingTotal: Integer read GetVisiblePrevSiblingTotal; + property VisibleNextSiblingCount: Integer read GetVisibleNextSiblingCount; + property VisibleNextSiblingTotal: Integer read GetVisibleNextSiblingTotal; + property VisibleSize: Integer read FVisibleSize write FVisibleSize; + property Width: Integer index Ord(doVertical) read GetHeightWidth; + property ZoneLimit: Integer read FZoneLimit write SetZoneLimit; + property Visibled: Boolean read FVisibled write SetVisibled; + property IsInside: Boolean read FIsInside write SetIsInside; + end; + + TJvDockAdvZone = class(TJvDockZone) + private + FCloseBtnDown: Boolean; + FMouseDown: Boolean; + protected + procedure LButtonDblClkMethod; override; + public + constructor Create(ATree: TJvDockTree); override; + destructor Destroy; override; + procedure Insert(DockSize: Integer; Hide: Boolean); override; + procedure Remove(DockSize: Integer; Hide: Boolean); override; + property CloseBtnDown: Boolean read FCloseBtnDown write FCloseBtnDown; + property MouseDown: Boolean read FMouseDown write FMouseDown; + end; + + TJvDockTreeScanKind = (tskForward, tskMiddle, tskBackward); + TJvDockTreeScanPriority = (tspSibling, tspChild); + TJvDockGrabbersPosition = (gpTop, gpBottom, gpLeft, gpRight); + TJvDockForEachZoneProc = procedure(Zone: TJvDockZone) of object; + TJvDockZoneClass = class of TJvDockZone; + + TJvDockObservableStyle = class; + TJvDockStyleLink = class; + + TJvDockTree = class(TInterfacedObject, IJvDockManager) + private + FDockZoneClass: TJvDockZoneClass; + FBorderWidth: Integer; + FSplitterWidth: Integer; + FBrush: TBrush; + FDockSite: TWinControl; + FPreviousRect: TRect; + FDockRect: TRect; + FOldWndProc: TWndMethod; + FReplacementZone: TJvDockZone; + FResizeCount: Integer; + FScaleBy: Double; + FShiftScaleOrientation: TDockOrientation; + FShiftBy: Integer; + FSizePos: TPoint; + FSizingDC: HDC; + FSizingWnd: THandle; + FSizingZone: TJvDockZone; + FTopZone: TJvDockZone; // <-- Root Node of the tree. What is called Zone in here should really be called TreeNode. + FTopXYLimit: Integer; + FUpdateCount: Integer; + FVersion: Integer; + FOldHTFlag: Integer; + FParentLimit: Integer; + FMinSize: Integer; + FCanvas: TControlCanvas; + FStyleLink: TJvDockStyleLink; + FGrabberSize: Integer; { size of grabber } + FGrabberShowLines: Boolean; {should there be bump-lines to make the grabber look 'grabby'? } + FGrabberBgColor: TColor; // if FGrabberStandardDraw is False, this indicates background color of Grabber. + FGrabberBottomEdgeColor: TColor; // if anything other than clNone, draw a line at bottom edge. + procedure SetTopZone(const Value: TJvDockZone); + procedure SetTopXYLimit(const Value: Integer); + procedure SetDockZoneClass(const Value: TJvDockZoneClass); + function GetDockSplitterWidth: Integer; + function GetBorderWidth: Integer; + procedure SetDockSplitterWidth(const Value: Integer); + procedure SetBorderWidth(const Value: Integer); + function GetDockSiteOrientation: TDockOrientation; + function GetDockSiteSize: Integer; + procedure SetDockSiteSize(const Value: Integer); + procedure SetMinSize(const Value: Integer); + function GetDockSiteBegin: Integer; + procedure SetDockSiteBegin(const Value: Integer); + function GetDockSiteSizeAlternate: Integer; + procedure SetDockSiteSizeAlternate(const Value: Integer); + procedure SetVersion(const Value: Integer); + function GetDockSiteSizeWithOrientation(Orient: TDockOrientation): Integer; + procedure SetDockSiteSizeWithOrientation(Orient: TDockOrientation; const Value: Integer); + function GetDockRect: TRect; + procedure SetDockRect(const Value: TRect); + function GetMinSize: Integer; + function HasZoneWithControl(Control: TControl): Boolean; + procedure DockStyleChanged(Sender: TObject); + function GetDockStyle: TJvDockObservableStyle; + protected + procedure WindowProc(var Msg: TMessage); virtual; + procedure BeginDrag(Control: TControl; + Immediate: Boolean; Threshold: Integer = -1); virtual; + function DoMouseEvent(var Msg: TWMMouse; + var Zone: TJvDockZone; out HTFlag: Integer): TWMNCHitMessage; virtual; + procedure DoMouseMove(var Msg: TWMMouse; + var Zone: TJvDockZone; out HTFlag: Integer); virtual; + function DoLButtonDown(var Msg: TWMMouse; + var Zone: TJvDockZone; out HTFlag: Integer): Boolean; virtual; + procedure DoLButtonUp(var Msg: TWMMouse; + var Zone: TJvDockZone; out HTFlag: Integer); virtual; + procedure DoLButtonDbClk(var Msg: TWMMouse; + var Zone: TJvDockZone; out HTFlag: Integer); virtual; + procedure DoMButtonDown(var Msg: TWMMouse; + var Zone: TJvDockZone; out HTFlag: Integer); virtual; + procedure DoMButtonUp(var Msg: TWMMouse; + var Zone: TJvDockZone; out HTFlag: Integer); virtual; + procedure DoMButtonDbClk(var Msg: TWMMouse; + var Zone: TJvDockZone; out HTFlag: Integer); virtual; + procedure DoRButtonDown(var Msg: TWMMouse; + var Zone: TJvDockZone; out HTFlag: Integer); virtual; + procedure DoRButtonUp(var Msg: TWMMouse; + var Zone: TJvDockZone; out HTFlag: Integer); virtual; + procedure DoRButtonDbClk(var Msg: TWMMouse; + var Zone: TJvDockZone; out HTFlag: Integer); virtual; + procedure DoHideZoneChild(AZone: TJvDockZone); virtual; + procedure DoSetCursor(var Msg: TWMSetCursor; + var Zone: TJvDockZone; out HTFlag: Integer); virtual; + procedure DoHintShow(var Msg: TCMHintShow; + var Zone: TJvDockZone; out HTFlag: Integer); virtual; + procedure DoOtherHint(Zone: TJvDockZone; + HTFlag: Integer; var HintStr: string); virtual; + procedure CustomSaveZone(Stream: TStream; + Zone: TJvDockZone); virtual; + procedure CustomLoadZone(Stream: TStream; + var Zone: TJvDockZone); virtual; + procedure DoSaveZone(Stream: TStream; + Zone: TJvDockZone; Level: Integer); virtual; + procedure DoLoadZone(Stream: TStream); virtual; + procedure AdjustDockRect(Control: TControl; var ARect: TRect); virtual; + procedure BeginResizeDockSite; + procedure BeginUpdate; + procedure CalcSplitterPos; virtual; + procedure ControlVisibilityChanged(Control: TControl; Visible: Boolean); virtual; + function GetDockAlign(Client: TControl; var DropCtl: TControl): TAlign; virtual; + function DoFindZone(const MousePos: TPoint; + out HTFlag: Integer; Zone: TJvDockZone): TJvDockZone; virtual; + procedure DrawSizeSplitter; virtual; + procedure EndResizeDockSite; + procedure EndUpdate; + function FindControlZone(Control: TControl; IncludeHide: Boolean = False): TJvDockZone; virtual; + function FindControlZoneAndLevel(Control: TControl; + var CtlLevel: Integer; IncludeHide: Boolean = False): TJvDockZone; virtual; + procedure ForEachAt(Zone: TJvDockZone; Proc: TJvDockForEachZoneProc; + ScanKind: TJvDockTreeScanKind = tskForward; ScanPriority: TJvDockTreeScanPriority = tspSibling); virtual; + function GetActiveControl: TControl; virtual; + function GetGrabberSize: Integer; virtual; + function GetBorderHTFlag(const MousePos: TPoint; + out HTFlag: Integer; Zone: TJvDockZone): TJvDockZone; virtual; + function GetLeftGrabbersHTFlag(const MousePos: TPoint; + out HTFlag: Integer; Zone: TJvDockZone): TJvDockZone; virtual; + function GetRightGrabbersHTFlag(const MousePos: TPoint; + out HTFlag: Integer; Zone: TJvDockZone): TJvDockZone; virtual; + function GetTopGrabbersHTFlag(const MousePos: TPoint; + out HTFlag: Integer; Zone: TJvDockZone): TJvDockZone; virtual; + function GetBottomGrabbersHTFlag(const MousePos: TPoint; + out HTFlag: Integer; Zone: TJvDockZone): TJvDockZone; virtual; + function GetDockEdge(DockRect: TRect; MousePos: TPoint; + var DropAlign: TAlign; Control: TControl): TControl; virtual; + function GetDockClientLimit(Orient: TDockOrientation; IsMin: Boolean): Integer; virtual; + function GetFrameRect(Control: TControl): TRect; virtual; + function GetFrameRectEx(Control: TControl): TRect; virtual; + function GetSplitterRect(Zone: TJvDockZone): TRect; virtual; + function GetDockGrabbersPosition: TJvDockGrabbersPosition; virtual; + procedure GetControlBounds(Control: TControl; out CtlBounds: TRect); virtual; + function GetSplitterLimit(AZone: TJvDockZone; IsCurrent, IsMin: Boolean): Integer; virtual; + procedure DoGetNextLimit(Zone, AZone: TJvDockZone; var LimitResult: Integer); virtual; + function GetHTFlag(MousePos: TPoint): Integer; virtual; + procedure GetSiteInfo(Client: TControl; + var InfluenceRect: TRect; MousePos: TPoint; var CanDock: Boolean); virtual; + function HitTest(const MousePos: TPoint; out HTFlag: Integer): TControl; virtual; + function InternalHitTest(const MousePos: TPoint; + out HTFlag: Integer): TJvDockZone; virtual; + procedure InsertControl(Control: TControl; InsertAt: TAlign; + DropCtl: TControl); virtual; + procedure InsertNewParent(NewZone, SiblingZone: TJvDockZone; + ParentOrientation: TDockOrientation; InsertLast, Update: Boolean); virtual; + procedure InsertSibling(NewZone, SiblingZone: TJvDockZone; + InsertLast, Update: Boolean); virtual; + procedure LoadFromStream(Stream: TStream); virtual; + procedure SaveToStream(Stream: TStream); virtual; + procedure PaintDockSite; virtual; + procedure DrawDockSiteRect; virtual; + procedure DrawZone(Zone: TJvDockZone); virtual; + procedure DrawZoneGrabber(Zone: TJvDockZone); virtual; + procedure DrawDockGrabber(Control: TWinControl; const ARect: TRect); virtual; + procedure DrawZoneSplitter(Zone: TJvDockZone); virtual; + procedure DrawSplitterRect(const ARect: TRect); virtual; + procedure DrawZoneBorder(Zone: TJvDockZone); virtual; + procedure DrawDockBorder(DockControl: TControl; R1, R2: TRect); virtual; + procedure GetCaptionRect(var Rect: TRect); virtual; + procedure PositionDockRect(Client, DropCtl: TControl; + DropAlign: TAlign; var DockRect: TRect); virtual; + procedure PruneZone(Zone: TJvDockZone); virtual; + procedure RemoveZone(Zone: TJvDockZone; Hide: Boolean = True); virtual; + procedure ScaleZone(Zone: TJvDockZone); virtual; + procedure ScaleChildZone(Zone: TJvDockZone); virtual; + procedure ScaleSiblingZone(Zone: TJvDockZone); virtual; + procedure ShiftZone(Zone: TJvDockZone); virtual; + procedure UpdateZone(Zone: TJvDockZone); virtual; + procedure DrawSplitter(Zone: TJvDockZone); virtual; + procedure RemoveControl(Control: TControl); virtual; + procedure SetActiveControl(const Value: TControl); virtual; + procedure SetGrabberSize(const Value: Integer); virtual; + procedure SetNewBounds(Zone: TJvDockZone); virtual; + procedure SetReplacingControl(Control: TControl); + procedure SplitterMouseDown(OnZone: TJvDockZone; MousePos: TPoint); virtual; + procedure SplitterMouseUp; virtual; + procedure ResetBounds(Force: Boolean); virtual; + procedure WriteControlName(Stream: TStream; const ControlName: string); + procedure ReadControlName(Stream: TStream; var ControlName: string); + procedure ShowControl(Control: TControl); + procedure HideControl(Control: TControl); + procedure ShowAllControl; + procedure HideAllControl; + procedure ShowSingleControl(Control: TControl); + procedure HideSingleControl(Control: TControl); + procedure ReplaceZoneChild(OldControl, NewControl: TControl); + procedure SyncWithStyle; virtual; + property BorderWidth: Integer read GetBorderWidth write SetBorderWidth; + property Canvas: TControlCanvas read FCanvas; + property DockSiteSize: Integer read GetDockSiteSize write SetDockSiteSize; + property DockSiteSizeAlternate: Integer read GetDockSiteSizeAlternate write SetDockSiteSizeAlternate; + property DockSiteBegin: Integer read GetDockSiteBegin write SetDockSiteBegin; + property DockSiteSizeWithOrientation[Orient: TDockOrientation]: Integer + read GetDockSiteSizeWithOrientation write SetDockSiteSizeWithOrientation; + + property GrabberSize: Integer read GetGrabberSize write SetGrabberSize; + property GrabberShowLines: Boolean read FGrabberShowLines write FGrabberShowLines; {should there be bump-lines to make the grabber look 'grabby'? } + property GrabberBgColor: TColor read FGrabberBgColor write FGrabberBgColor; // if FGrabberStandardDraw is False, this indicates background color of Grabber. Set to clNone to skip painting the background. + property GrabberBottomEdgeColor: TColor read FGrabberBottomEdgeColor write FGrabberBottomEdgeColor; // if anything other than clNone, draw a line at bottom edge. + + property GrabbersPosition: TJvDockGrabbersPosition read GetDockGrabbersPosition; + property MinSize: Integer read GetMinSize write SetMinSize; + property DockRect: TRect read GetDockRect write SetDockRect; + property PreviousRect: TRect read FPreviousRect write FPreviousRect; + property ParentLimit: Integer read FParentLimit write FParentLimit; + property ReplacementZone: TJvDockZone read FReplacementZone write FReplacementZone; + property ResizeCount: Integer read FResizeCount write FResizeCount; + property ScaleBy: Double read FScaleBy write FScaleBy; + property ShiftBy: Integer read FShiftBy write FShiftBy; + property ShiftScaleOrientation: TDockOrientation read FShiftScaleOrientation write FShiftScaleOrientation; + property SizePos: TPoint read FSizePos write FSizePos; + property SizingDC: HDC read FSizingDC; + property SizingWnd: THandle read FSizingWnd; + property SizingZone: TJvDockZone read FSizingZone write FSizingZone; + property SplitterWidth: Integer read GetDockSplitterWidth write SetDockSplitterWidth; + property UpdateCount: Integer read FUpdateCount write FUpdateCount; + property Version: Integer read FVersion write SetVersion; + + {$IFDEF JVDOCK_DEBUG} + // internal helper functions used recursively from DebugDump: + procedure _ParentDump(LevelsLeft: Integer; AParent: TWinControl; Indent: string; Strs: TStrings); + procedure _PageControlDump(PageControl: TWinControl; Indent: string; Strs: TStrings); {actually TJvDockTabPageControl} + procedure _ControlDump(AControl: TWinControl; Indent: string; Strs: TStrings); + // This helps us to understand the content of the tree by allowing + // us to build a dump: + procedure DebugDump(var Index: Integer; Indent, Entity: string; TreeZone: TJvDockZone; Strs: TStrings); //virtual; + {$ENDIF JVDOCK_DEBUG} + + {$IFDEF JVDOCK_QUERY} + procedure _ParentQuery( LevelsLeft:Integer; AParent:TWinControl; FoundItems:TList ); + procedure _PageControlQuery(PageControl: TWinControl; FoundItems:TList); {actually TJvDockTabPageControl} + procedure _ControlQuery( AControl:TWinControl; FoundItems:TList); + procedure DoControlQuery(TreeZone: TJvDockZone; FoundItems:TList); //virtual; + {$ENDIF JVDOCK_QUERY} + public + {$IFDEF JVDOCK_DEBUG} + // A top level call for end user to call, which calls + // DebugDump in turn: + procedure Debug(BasePropertyName: string; Strs: TStrings); + {$ENDIF JVDOCK_DEBUG} + {$IFDEF JVDOCK_QUERY} + // Descends the Tree and Finds and return TWinControls docked to a particular parent. + procedure ControlQuery(DockedTo: TWinControl; FoundItems: TList); + {$ENDIF JVDOCK_QUERY} + // (rom) deactivated completely unused + // SplitterCanvas: TControlCanvas; + constructor Create(ADockSite: TWinControl; ADockZoneClass: TJvDockZoneClass; ADockStyle: TJvDockObservableStyle); virtual; + destructor Destroy; override; + procedure AfterConstruction; override; + property DockSite: TWinControl read FDockSite write FDockSite; + property DockSiteOrientation: TDockOrientation read GetDockSiteOrientation; + procedure SetSplitterCursor(CursorIndex: TDockOrientation); virtual; + procedure PaintSite(DC: HDC); virtual; + property TopXYLimit: Integer read FTopXYLimit write SetTopXYLimit; + property TopZone: TJvDockZone read FTopZone write SetTopZone; // ROOT NODE! + procedure UpdateAll; + procedure UpdateChild(Zone: TJvDockZone); + property DockZoneClass: TJvDockZoneClass read FDockZoneClass write SetDockZoneClass; + property DockStyle: TJvDockObservableStyle read GetDockStyle; + end; + + TJvDockTreeClass = class of TJvDockTree; + TJvDockBasicConjoinServerOptionClass = class of TJvDockBasicConjoinServerOption; + TJvDockBasicTabServerOptionClass = class of TJvDockBasicTabServerOption; + + { Maintained by a TJvDockBasicStyle ancestor. That ancestor ensures that + FDockStyle is set (to itself) } + TJvDockBasicServerOption = class(TPersistent) + private + FDockStyle: TJvDockObservableStyle; + FUpdateCount: Integer; + FIsChanged: Boolean; + protected + procedure Changed; virtual; + property DockStyle: TJvDockObservableStyle read FDockStyle; + public + constructor Create(ADockStyle: TJvDockObservableStyle); virtual; + procedure Assign(Source: TPersistent); override; + procedure BeginUpdate; + procedure EndUpdate; + end; + + TJvDockGrabbersSize = 1..MaxInt; + TJvDockSplitterWidth = 1..MaxInt; + + TJvDockBasicConjoinServerOption = class(TJvDockBasicServerOption) + private + FGrabbersSize: TJvDockGrabbersSize; + FSplitterWidth: TJvDockSplitterWidth; + protected + procedure SetGrabbersSize(const Value: TJvDockGrabbersSize); + procedure SetDockSplitterWidth(const Value: TJvDockSplitterWidth); + public + constructor Create(ADockStyle: TJvDockObservableStyle); override; + procedure Assign(Source: TPersistent); override; + published + property GrabbersSize: TJvDockGrabbersSize read FGrabbersSize write SetGrabbersSize default 12; + property SplitterWidth: TJvDockSplitterWidth read FSplitterWidth write SetDockSplitterWidth default 4; + end; + + TJvDockBasicTabServerOption = class(TJvDockBasicServerOption) + private + FTabPosition: TTabPosition; + FHotTrack: Boolean; + protected + procedure SetTabPosition(const Value: TTabPosition); virtual; + procedure SetHotTrack(const Value: Boolean); virtual; + public + constructor Create(ADockStyle: TJvDockObservableStyle); override; + procedure Assign(Source: TPersistent); override; + published + property HotTrack: Boolean read FHotTrack write SetHotTrack default False; + property TabPosition: TTabPosition read FTabPosition write SetTabPosition default tpTop; + end; + + TJvDockStyleLink = class + private + FDockStyle: TJvDockObservableStyle; + FOnStyleChanged: TNotifyEvent; + procedure SetDockStyle(ADockStyle: TJvDockObservableStyle); + public + destructor Destroy; override; + procedure StyleChanged; + property DockStyle: TJvDockObservableStyle read FDockStyle write SetDockStyle; + property OnStyleChanged: TNotifyEvent read FOnStyleChanged write FOnStyleChanged; + end; + + {$IFDEF USEJVCL} + TJvDockObservableStyle = class(TJvComponent) + {$ELSE} + TJvDockObservableStyle = class(TComponent) + {$ENDIF USEJVCL} + private + FConjoinServerOptionClass: TJvDockBasicConjoinServerOptionClass; + FTabServerOptionClass: TJvDockBasicTabServerOptionClass; + FConjoinServerOption: TJvDockBasicConjoinServerOption; + FTabServerOption: TJvDockBasicTabServerOption; + FLinks: TList; + procedure SetConjoinServerOption(Value: TJvDockBasicConjoinServerOption); //virtual; + procedure SetTabServerOption(Value: TJvDockBasicTabServerOption); + protected + procedure CreateServerOption; virtual; + procedure FreeServerOption; virtual; + + procedure AddLink(ALink: TJvDockStyleLink); + procedure RemoveLink(ALink: TJvDockStyleLink); + + procedure Changed; + procedure SendStyleEvent; + public + constructor Create(AOwner: TComponent); override; + destructor Destroy; override; + + procedure AfterConstruction; override; + + property ConjoinServerOptionClass: TJvDockBasicConjoinServerOptionClass read FConjoinServerOptionClass + write FConjoinServerOptionClass; + property TabServerOptionClass: TJvDockBasicTabServerOptionClass read FTabServerOptionClass + write FTabServerOptionClass; + property ConjoinServerOption: TJvDockBasicConjoinServerOption read FConjoinServerOption + write SetConjoinServerOption; + property TabServerOption: TJvDockBasicTabServerOption read FTabServerOption write SetTabServerOption; + end; + +// (rom) made typed const to allow SizeOf +const + TreeStreamEndFlag: Integer = -1; + +{$IFDEF USEJVCL} +{$IFDEF UNITVERSIONING} +const + UnitVersioning: TUnitVersionInfo = ( + RCSfile: '$URL: https://jvcl.svn.sourceforge.net:443/svnroot/jvcl/trunk/jvcl/run/JvDockTree.pas $'; + Revision: '$Revision: 11276 $'; + Date: '$Date: 2007-04-24 12:33:37 -0700 (Tue, 24 Apr 2007) $'; + LogPath: 'JVCL\run' + ); +{$ENDIF UNITVERSIONING} +{$ENDIF USEJVCL} + +implementation + +uses + {$IFDEF JVCLThemesEnabled} + JvThemes, + {$ENDIF JVCLThemesEnabled} + Consts, SysUtils, Math, + JvDockControlForm, JvDockSupportProc, JvDockGlobals, JvDockVSNetStyle, + JvDockAdvTree; + +type + TWinControlAccessProtected = class(TWinControl); + +//=== { TJvDockZone } ======================================================== + +constructor TJvDockZone.Create(ATree: TJvDockTree); +begin + ParentZone := nil; + PrevSibling := nil; + NextSibling := nil; + ChildZones := nil; + ChildControl := nil; + FTree := ATree; + FVisibled := True; +end; + +function TJvDockZone.GetChildCount: Integer; +var + Zone: TJvDockZone; +begin + Result := 0; + Zone := ChildZones; + while Zone <> nil do + begin + Zone := Zone.NextSibling; + Inc(Result); + end; +end; + +function TJvDockZone.GetLimitBegin: Integer; +var + CheckZone: TJvDockZone; +begin + if FTree.FTopZone = Self then + CheckZone := Self + else + CheckZone := FParentZone; + if CheckZone.Orientation = doHorizontal then + Result := Top + else + if CheckZone.Orientation = doVertical then + Result := Left + else + Result := 0; +end; + +function TJvDockZone.GetLimitSize: Integer; +var + CheckZone: TJvDockZone; +begin + if FTree.FTopZone = Self then + CheckZone := Self + else + CheckZone := FParentZone; + if CheckZone.Orientation = doHorizontal then + Result := Height + else + if CheckZone.Orientation = doVertical then + Result := Width + else + Result := Tree.TopXYLimit; +end; + +function TJvDockZone.GetTopLeft(Orient: Integer): Integer; +var + Zone: TJvDockZone; + R: TRect; +begin + Zone := Self; + while Zone <> FTree.FTopZone do + begin + if (Zone.VisiblePrevSiblingCount > 0) and (Zone.ParentZone.Orientation = TDockOrientation(Orient)) then + begin + Result := Zone.BeforeClosestVisibleZone.ZoneLimit; + Exit; + end + else + Zone := Zone.ParentZone; + end; + R := FTree.FDockSite.ClientRect; + TWinControlAccessProtected(FTree.FDockSite).AdjustClientRect(R); + case TDockOrientation(Orient) of + doVertical: + Result := R.Left; + doHorizontal: + Result := R.Top; + else + Result := 0; + end; +end; + +function TJvDockZone.GetHeightWidth(Orient: Integer): Integer; +var + Zone: TJvDockZone; + R: TRect; +begin + if (Self = FTree.FTopZone) or ((FParentZone = FTree.FTopZone) and + (ChildControl <> nil) and (FTree.FTopZone.ChildCount = 1)) then + begin + R := FTree.FDockSite.ClientRect; + TWinControlAccessProtected(FTree.FDockSite).AdjustClientRect(R); + if TDockOrientation(Orient) = doHorizontal then + Result := R.Bottom - R.Top + else + Result := R.Right - R.Left; + end + else + begin + Zone := Self; + while (Zone <> FTree.FTopZone) and (Zone.ParentZone <> nil) do + begin + if Zone.ParentZone.Orientation = TDockOrientation(Orient) then + begin + Result := Zone.ZoneLimit - Zone.LimitBegin; + Exit; + end + else + Zone := Zone.ParentZone; + end; + if FTree.FTopZone.Orientation = TDockOrientation(Orient) then + Result := FTree.TopXYLimit + else + Result := FTree.FTopZone.ZoneLimit; + end; +end; + +procedure TJvDockZone.ResetChildren(Exclude: TJvDockZone); +var + SumLimit: Integer; + NewLimit: Integer; + FirstChildBegin: Integer; + OldPrevLimit: Integer; + ChildNode: TJvDockZone; + PrevNode: TJvDockZone; +begin + case Orientation of + doHorizontal: + NewLimit := Height; + doVertical: + NewLimit := Width; + else + Exit; + end; + + ChildNode := FirstVisibleChildZone; + if ChildNode = nil then + Exit; + + SumLimit := NewLimit; + NewLimit := NewLimit div VisibleChildCount; + + FirstChildBegin := ChildNode.LimitBegin; + + Tree.ShiftScaleOrientation := Orientation; + Tree.ParentLimit := 0; + if ChildNode.ZoneLimit - FirstChildBegin > 0 then + Tree.ScaleBy := NewLimit / (ChildNode.ZoneLimit - FirstChildBegin) + else + Tree.ScaleBy := 1; + if (Tree.ScaleBy <> 1) and (ChildNode.VisibleChildCount > 0) then + Tree.ForEachAt(ChildNode.ChildZones, Tree.ScaleChildZone, tskMiddle, tspChild); + + if ChildNode <> Exclude then + OldPrevLimit := ChildNode.ZoneLimit + else + OldPrevLimit := FirstChildBegin; + + ChildNode.ZoneLimit := FirstChildBegin + NewLimit; + ChildNode.Update; + + PrevNode := ChildNode; + ChildNode := ChildNode.AfterClosestVisibleZone; + + while ChildNode <> nil do + begin + if ChildNode.ZoneLimit - OldPrevLimit > 0 then + Tree.ScaleBy := NewLimit / (ChildNode.ZoneLimit - OldPrevLimit) + else + Tree.ScaleBy := 1; + + Tree.ShiftBy := PrevNode.ZoneLimit - OldPrevLimit; + if (Tree.ShiftBy <> 0) and (ChildNode.VisibleChildCount > 0) then + Tree.ForEachAt(ChildNode.ChildZones, Tree.ShiftZone, tskForward); + + Tree.ParentLimit := PrevNode.ZoneLimit; + + if (Tree.ScaleBy <> 1) and (ChildNode.VisibleChildCount > 0) then + Tree.ForEachAt(ChildNode.ChildZones, Tree.ScaleChildZone, tskForward); + + if ChildNode <> Exclude then + OldPrevLimit := ChildNode.ZoneLimit; + + ChildNode.ZoneLimit := PrevNode.ZoneLimit + NewLimit; + + if ChildNode.AfterClosestVisibleZone = nil then + begin + if NewLimit = 0 then + NewLimit := 1; + ChildNode.ZoneLimit := ChildNode.ZoneLimit + (SumLimit mod NewLimit); + end; + ChildNode.Update; + PrevNode := ChildNode; + ChildNode := ChildNode.AfterClosestVisibleZone; + end; +end; + +function TJvDockZone.GetControlName: string; +begin + Result := ''; + if ChildControl <> nil then + begin + if ChildControl.Name = '' then + raise Exception.CreateRes(@SDockedCtlNeedsName); + Result := ChildControl.Name; + end; +end; + +function TJvDockZone.SetControlName(const Value: string): Boolean; +var + Client: TControl; +begin + Client := nil; + with FTree do + begin + TWinControlAccessProtected(FDockSite).ReloadDockedControl(Value, Client); + Result := Client <> nil; + if Result then + begin + FReplacementZone := Self; + ChildControl := TWinControl(Client); + DoCustomSetControlName; + try + if IsInside then + Client.ManualDock(FDockSite, nil, alNone); + finally + SetChildControlVisible(Client, FControlVisibled); + FReplacementZone := nil; + end; + end; + end; +end; + +procedure TJvDockZone.Update; +var + NewWidth, NewHeight: Integer; + R: TRect; + + function ParentNotLast: Boolean; + var + Parent: TJvDockZone; + begin + Result := False; + Parent := FParentZone; + while Parent <> nil do + begin + if (Parent.VisibleNextSiblingCount > 0) and (Parent.Orientation = ParentZone.Orientation) then + begin + Result := True; + Exit; + end; + Parent := Parent.FParentZone; + end; + end; + +begin + if Visibled and (ChildControl <> nil) and (FTree.FUpdateCount = 0) then + begin + { (rb) It is possible that ChildControl points to a control that is + already destroyed. This can happen when Tree.RemoveControl is not + called for this control. + + This is possible when the host docksite is marked as destroying when + the ChildControl is destroyed (See TControl.Destroy) thus no + CM_UNDOCKCLIENT message is processed. Normally the tree&zones are + destroyed as soon as the host docksite is beginning to destroy; but + a host docksite can be marked earlier as destroying when its parent + is destroying. (This looks like a VCL bug) + + Don't know a good way to catch this but checking whether the host + docksite is destroying before accessing ChildControl is a work-around. + } + if csDestroying in FTree.FDockSite.ComponentState then + Exit; + ChildControl.DockOrientation := FParentZone.Orientation; + NewWidth := Width; + NewHeight := Height; + if ParentNotLast then + if FParentZone.Orientation = doHorizontal then + Dec(NewWidth, FTree.SplitterWidth) + else + Dec(NewHeight, FTree.SplitterWidth); + + if ((NextSibling <> nil) and (VisibleNextSiblingTotal > 0)) or ((FParentZone <> FTree.FTopZone) and + ((FParentZone.Orientation = FTree.FTopZone.Orientation) and + (FZoneLimit < FTree.TopXYLimit)) or + ((FParentZone.Orientation <> FTree.FTopZone.Orientation) and + (FZoneLimit < FTree.FTopZone.ZoneLimit))) then + if FParentZone.Orientation = doHorizontal then + Dec(NewHeight, FTree.SplitterWidth) + else + Dec(NewWidth, FTree.SplitterWidth); + R := Bounds(Left, Top, NewWidth, NewHeight); + FTree.AdjustDockRect(ChildControl, R); + ChildControl.BoundsRect := R; + end; +end; + +function TJvDockZone.GetFrameRect: TRect; +var + ALeft, ATop, ARight, ABottom, BorderWidth: Integer; +begin + ALeft := Left; + ATop := Top; + if NextSibling <> nil then + BorderWidth := Tree.BorderWidth + else + BorderWidth := 0; + ARight := ALeft + Width - BorderWidth; + ABottom := ATop + Height - BorderWidth; + Result := Rect(ALeft, ATop, ARight, ABottom); +end; + +function TJvDockZone.GetFirstSibling: TJvDockZone; +begin + Result := Self; + while Result.PrevSibling <> nil do + Result := Result.PrevSibling; +end; + +function TJvDockZone.GetLastSibling: TJvDockZone; +begin + Result := Self; + while (Result <> nil) and (Result.NextSibling <> nil) do + Result := Result.NextSibling; +end; + +function TJvDockZone.GetFirstChild: TJvDockZone; +begin + Result := ChildZones; +end; + +function TJvDockZone.GetLastChild: TJvDockZone; +begin + Result := ChildZones; + if Result <> nil then + Result := Result.LastSibling; +end; + +function TJvDockZone.GetTopLeftArr(Orient: TDockOrientation): Integer; +begin + case Orient of + doHorizontal: + Result := Top; + doVertical: + Result := Left; + else + Result := 0; + end; +end; + +function TJvDockZone.GetHeightWidthArr(Orient: TDockOrientation): Integer; +begin + case Orient of + doHorizontal: + Result := Height; + doVertical: + Result := Width; + else + Result := 0; + end; +end; + +procedure TJvDockZone.AdjustZoneLimit(Value: Integer); +begin + FZoneLimit := Value; + if PrevSibling <> nil then + PrevSibling.ZoneLimit := PrevSibling.ZoneLimit + Value; +end; + +procedure TJvDockZone.SetZoneSize(Size: Integer; Show: Boolean); +begin + InsertOrRemove(Size, Show, False); +end; + +procedure TJvDockZone.InsertOrRemove(DockSize: Integer; Insert: Boolean; Hide: Boolean); +begin +end; + +procedure TJvDockZone.Insert(DockSize: Integer; Hide: Boolean); +begin + InsertOrRemove(DockSize, True, Hide); + + if (ParentZone <> nil) and (ParentZone.VisibleChildCount = 0) then + ParentZone.Insert(ParentZone.VisibleSize, Hide); + + Visibled := True; + if ParentZone <> nil then + ParentZone.ResetChildren(Self); + + Tree.SetNewBounds(ParentZone); + Tree.UpdateChild(ParentZone); +end; + +procedure TJvDockZone.Remove(DockSize: Integer; Hide: Boolean); +var + Zone: TJvDockZone; +begin + InsertOrRemove(DockSize, False, Hide); + + Visibled := not Hide; + + if (ParentZone <> Tree.TopZone) and (ParentZone.VisibleChildCount = 0) then + ParentZone.Remove(ParentZone.LimitSize, Hide); + + if AfterClosestVisibleZone = nil then + begin + Zone := BeforeClosestVisibleZone; + if Zone <> nil then + begin + Zone.ZoneLimit := ZoneLimit; + Tree.SetNewBounds(Zone); + end; + end; + + ZoneLimit := LimitBegin; +end; + +function TJvDockZone.GetVisibleChildCount: Integer; +var + Zone: TJvDockZone; +begin + Result := 0; + Zone := ChildZones; + while Zone <> nil do + begin + if Zone.Visibled then + Inc(Result); + Zone := Zone.NextSibling; + end; +end; + +function TJvDockZone.GetChildTotal: Integer; + + procedure DoFindChildCount(Zone: TJvDockZone); + begin + if Zone <> nil then + begin + DoFindChildCount(Zone.NextSibling); + DoFindChildCount(Zone.ChildZones); + Inc(Result); + end; + end; + +begin + Result := 0; + DoFindChildCount(ChildZones); +end; + +function TJvDockZone.GetVisibleChildTotal: Integer; + + procedure DoFindVisibleChildCount(Zone: TJvDockZone); + begin + if Zone <> nil then + begin + DoFindVisibleChildCount(Zone.NextSibling); + DoFindVisibleChildCount(Zone.ChildZones); + if Zone.Visibled then + Inc(Result); + end; + end; + +begin + Result := 0; + DoFindVisibleChildCount(ChildZones); +end; + +function TJvDockZone.GetAfterClosestVisibleZone: TJvDockZone; +begin + Result := NextSibling; + while Result <> nil do + begin + if Result.Visibled then + Break; + Result := Result.NextSibling; + end; +end; + +function TJvDockZone.GetBeforeClosestVisibleZone: TJvDockZone; +begin + Result := PrevSibling; + while Result <> nil do + begin + if Result.Visibled then + Break; + Result := Result.PrevSibling; + end; +end; + +function TJvDockZone.GetAfterApoapsisVisibleZone: TJvDockZone; +begin + Result := LastSibling; + if Result <> nil then + Result := Result.BeforeClosestVisibleZone; + if Self = Result then + Result := nil; +end; + +function TJvDockZone.GetBeforeApoapsisVisibleZone: TJvDockZone; +begin + Result := ParentZone.ChildZones; + if Result <> Self then + Result := Result.AfterClosestVisibleZone; + if Self = Result then + Result := nil; +end; + +function TJvDockZone.GetNextSiblingCount: Integer; +var + AZone: TJvDockZone; +begin + Result := 0; + AZone := NextSibling; + while AZone <> nil do + begin + Inc(Result); + AZone := AZone.NextSibling; + end; +end; + +function TJvDockZone.GetPrevSiblingCount: Integer; +var + AZone: TJvDockZone; +begin + Result := 0; + AZone := PrevSibling; + while AZone <> nil do + begin + Inc(Result); + AZone := AZone.PrevSibling; + end; +end; + +procedure TJvDockZone.SetVisibled(const Value: Boolean); +begin + FVisibled := Value; + if (not FVisibled) and (Self <> Tree.TopZone) then + if ParentZone.Orientation = doNoOrient then + VisibleSize := Tree.TopXYLimit + else + VisibleSize := LimitSize; +end; + +function TJvDockZone.GetVisibleNextSiblingCount: Integer; +var + Zone: TJvDockZone; +begin + Result := 0; + Zone := NextSibling; + while Zone <> nil do + begin + if Zone.Visibled then + Inc(Result); + Zone := Zone.NextSibling; + end; +end; + +function TJvDockZone.GetVisibleNextSiblingTotal: Integer; + + procedure DoFindVisibleNextSiblingCount(Zone: TJvDockZone); + begin + if Zone <> nil then + begin + DoFindVisibleNextSiblingCount(Zone.NextSibling); + DoFindVisibleNextSiblingCount(Zone.ChildZones); + if Zone.Visibled then + Inc(Result); + end; + end; + +begin + Result := 0; + DoFindVisibleNextSiblingCount(NextSibling); +end; + +function TJvDockZone.GetVisiblePrevSiblingCount: Integer; +var + Zone: TJvDockZone; +begin + Result := 0; + Zone := PrevSibling; + while Zone <> nil do + begin + if Zone.Visibled then + Inc(Result); + Zone := Zone.PrevSibling; + end; +end; + +function TJvDockZone.GetVisiblePrevSiblingTotal: Integer; + + procedure DoFindVisibleNextSiblingCount(Zone: TJvDockZone); + begin + if (Zone <> nil) and (Zone <> Self) then + begin + DoFindVisibleNextSiblingCount(Zone.NextSibling); + DoFindVisibleNextSiblingCount(Zone.ChildZones); + if Zone.Visibled then + Inc(Result); + end; + end; + +begin + Result := 0; + DoFindVisibleNextSiblingCount(ParentZone); +end; + +procedure TJvDockZone.SetZoneLimit(const Value: Integer); +begin + FZoneLimit := Value; +end; + +function TJvDockZone.GetFirstVisibleChildZone: TJvDockZone; +begin + Result := ChildZones; + while (Result <> nil) and (not Result.Visibled) do + Result := Result.NextSibling; +end; + +function TJvDockZone.GetSplitterLimit(IsMin: Boolean): Integer; +begin + if IsMin then + Result := ZoneLimit + else + Result := LimitBegin; + + if ChildZones <> nil then + ChildZones.DoGetSplitterLimit(ParentZone.Orientation, IsMin, Result); +end; + +function TJvDockZone.DoGetSplitterLimit(Orientation: TDockOrientation; + IsMin: Boolean; var LimitResult: Integer): Integer; +begin + Result := 0; + if (ParentZone <> nil) and (ParentZone.Orientation = Orientation) and Visibled then + if IsMin then + LimitResult := Min(LimitResult, ZoneLimit) + else + if AfterClosestVisibleZone <> nil then + LimitResult := Max(LimitResult, ZoneLimit); + + if NextSibling <> nil then + NextSibling.DoGetSplitterLimit(Orientation, IsMin, LimitResult); + + if ChildZones <> nil then + ChildZones.DoGetSplitterLimit(Orientation, IsMin, LimitResult); +end; + +function TJvDockZone.GetLastVisibleChildZone: TJvDockZone; +var + Zone: TJvDockZone; +begin + Result := nil; + Zone := ChildZones; + while (Zone <> nil) and Zone.Visibled do + begin + Result := Zone; + Zone := Zone.NextSibling; + end; +end; + +procedure TJvDockZone.DoCustomSetControlName; +begin +end; + +procedure TJvDockZone.LButtonDblClkMethod; +begin + if ChildControl <> nil then + ChildControl.ManualDock(nil, nil, alTop); +end; + +procedure TJvDockZone.SetIsInside(const Value: Boolean); +begin + FIsInside := Value; +end; + +procedure TJvDockZone.SetChildControlVisible(Client: TControl; AVisible: Boolean); +begin + if Client <> nil then + Client.Visible := FControlVisibled; +end; + +//=== { TJvDockTree } ======================================================== + +constructor TJvDockTree.Create(ADockSite: TWinControl; + ADockZoneClass: TJvDockZoneClass; ADockStyle: TJvDockObservableStyle); +var + I: Integer; +begin + // (rom) added inherited Create + inherited Create; + // (rom) Canvas now always existent + FCanvas := TControlCanvas.Create; + FStyleLink := TJvDockStyleLink.Create; + { First set DockStyle then OnStyleChanged so no OnStyleChanged is fired; + we do it ourself in AfterContruction } + FStyleLink.DockStyle := ADockStyle; + FStyleLink.OnStyleChanged := DockStyleChanged; + FDockZoneClass := ADockZoneClass; + FBorderWidth := 0; + FSplitterWidth := 4; + FDockSite := ADockSite; + FGrabberSize := 18; {Default Grabber Height} + + FDockSite.ShowHint := True; + FVersion := RsDockBaseDockTreeVersion; + + FMinSize := 12; + FTopZone := FDockZoneClass.Create(Self); + FBrush := TBrush.Create; + FBrush.Bitmap := AllocPatternBitmap(clBlack, clWhite); + + FGrabberBgColor := clBtnFace; // default grabber color. + FGrabberShowLines := True; + FGrabberBottomEdgeColor := clBtnShadow; // Dark gray, usually. + + BeginUpdate; + try + for I := 0 to DockSite.ControlCount - 1 do + InsertControl(DockSite.Controls[I], alLeft, nil); + FTopZone.ResetChildren(nil); + finally + EndUpdate; + end; + if not (csDesigning in DockSite.ComponentState) then + begin + FOldWndProc := FDockSite.WindowProc; + FDockSite.WindowProc := WindowProc; + end; +end; + +destructor TJvDockTree.Destroy; +begin + FStyleLink.Free; + + if Assigned(FOldWndProc) then + FDockSite.WindowProc := FOldWndProc; + PruneZone(FTopZone); + FBrush.Free; + inherited Destroy; + // (rom) free a Canvas always AFTER inherited Destroy + FCanvas.Free; +end; + +{$IFDEF JVDOCK_DEBUG} + +procedure TJvDockTree.Debug(BasePropertyName: string; Strs: TStrings); +var + N: Integer; +begin + Assert(Assigned(Strs)); + Strs.Clear; + N := 0; + DebugDump(N, '', BasePropertyName, TopZone, Strs); + if (Strs.Count = 0) or (N = 0) then + Strs.Add('This tree is empty'); +end; + +//XXX Helper routines for DebugDump: XXX + +procedure TJvDockTree._ParentDump(LevelsLeft: Integer; AParent: TWinControl; Indent: string; Strs: TStrings); +var + DockServer: TJvDockServer; + LClassName, LName: string; + + procedure Write(S: string); + begin + Strs.Add(S); + end; + +begin + if Assigned(AParent) then + begin + LClassName := AParent.ClassName; + LName := AParent.Name; + Write(Indent + ' '); + Write(Indent + ' ' + LClassName + ''); + Write(Indent + ' ' + LName + '@' + IntToHex(Integer(AParent), 8) + ''); + if AParent is TJvDockPanel then + begin + DockServer := TJvDockPanel(AParent).DockServer; + if Assigned(DockServer) then + Write(Indent + ' ' + DockServer.Name + '') + else + Write(Indent + ' TJvDockPanel has no DockServer'); + end; + // recurse down: + if (LevelsLeft > 0) then + if AParent.Parent <> AParent then // don't show controls where they are their own parent! + _ParentDump(LevelsLeft - 1, AParent.Parent, Indent + ' ', Strs); + Write(Indent + ' '); + end; +end; + +procedure TJvDockTree._PageControlDump(PageControl: TWinControl; Indent: string; Strs: TStrings); {actually TJvDockTabPageControl} +var + I, J, Count: Integer; + PageID: string; + LPageControl: TJvDockTabPageControl; + LClassName, LName: string; + + procedure Write(S: string); + begin + Strs.Add(S); + end; + +begin + if Assigned(PageControl) then + begin + LPageControl := PageControl as TJvDockTabPageControl; + LClassName := LPageControl.ClassName; + LName := LPageControl.Name; + Count := LPageControl.Count; + Write(Indent + ' '); + Write(Indent + ' ' + LClassName + ''); + Write(Indent + ' ' + LName + ''); + for I := 0 to Count-1 do + begin + PageID := 'Page' + IntToStr(I + 1); + Write(Indent + ' <' + PageID + '>'); + Write(Indent + ' ' + LPageControl.Pages[I].ClassName + ''); + Write(Indent + ' ' + LPageControl.Pages[I].Name + ''); + Write(Indent + ' ' + LPageControl.Pages[I].Caption + ''); + Write(''); + for J := 0 to LPageControl.Pages[I].ControlCount - 1 do + begin + _ControlDump(LPageControl.Pages[I].Controls[J] as TWinControl, Indent + ' ', Strs); + Write(''); + end; + Write(Indent + ' '); + Write(''); + end; + + Write(Indent + ' '); + Write(''); + end + else + Write(Indent + ' No pagecontrol in the TJvDockTabHostForm.'); +end; + +procedure TJvDockTree._ControlDump(AControl: TWinControl; Indent: string; Strs: TStrings); +var + LClassName, LName: string; + LForm: TForm; + DockClient: TJvDockClient; + + procedure Write(S: string); + begin + Strs.Add(S); + end; + +begin + Write(Indent + ' '); + LClassName := AControl.ClassName; + LName := AControl.Name; + Write(Indent + ' ' + LClassName + ''); + Write(Indent + ' ' + LName + ''); + Write(Indent + ' ' + BoolToStr(AControl.Visible, True) + ''); + Write(Indent + ' ' + BoolToStr(AControl.Enabled, True) + ''); + + if AControl is TForm then + begin + LForm := TForm(AControl); + Write(Indent + ' ' + LForm.Caption + ''); + DockClient := FindDockClient(AControl); + if Assigned(DockClient) then + begin + LClassName := DockClient.ClassName; + LName := DockClient.Name; + Write(Indent + ' '); + Write(Indent + ' ' + LClassName + ''); + Write(Indent + ' ' + LName + ''); + Write(Indent + ' ' + BoolToStr(DockClient.CustomDock, True) + ''); + + // uses DockStateStr - utility function in JvDockControlForm.pas: + Write(Indent + ' ' + DockStateStr(DockClient.DockState) + ''); + + Write(Indent + ' '); + end + else + Write(Indent + ' No dockclient found in this form.'); + if LForm is TJvDockTabHostForm then + _PageControlDump(TJvDockTabHostForm(LForm).PageControl, Indent, Strs); + end; + + { LAST for each control, recursively dump the TWinControl.Parent + tree, but limit to only a few levels + so we can avoid information overload. Oops. Too late. :-) } + _ParentDump(3, AControl.Parent, Indent, Strs); + + Write(Indent + ' '); +end; + +// This helps us to understand the current contents of the tree at runtime, +// by allowing us to build an XML dump of the TJvDockTree. +procedure TJvDockTree.DebugDump(var Index: Integer; Indent, Entity: string; TreeZone: TJvDockZone; Strs: TStrings); //virtual; +var + Zone: TJvDockZone; + WasIndex: Integer; + + procedure Write(S: string); + begin + Strs.Add(S); + end; + +begin + Zone := TreeZone; + + { while loop over siblings at this level...} + while Assigned(Zone) do + begin + WasIndex := Index; + Inc(Index); + + {xml Entity begins } + Write(Indent + '<' + Entity + IntToStr(WasIndex) + '>'); + + {for every tree and tree item inside it that we dump, report actual class name } + Write(Indent + ' ' + Zone.ClassName + ''); + + { Dump controls recursively } + if Assigned(Zone.ChildControl) then + _ControlDump(Zone.ChildControl, Indent, Strs); + + { Dump children recursively } + DebugDump(Index, Indent + ' ', Entity + '.ChildZone', Zone.ChildZones, Strs); + + {xml Entity ends } + Write(Indent + ''); + + {blank line after each Entity ends} + Write(''); + + {dump all siblings at this level immediately after current item } + Zone := Zone.NextSibling; + end; +end; + +{$ENDIF JVDOCK_DEBUG} + +{$IFDEF JVDOCK_QUERY} + +// This helps us to find particular Controls (ie Forms) that are +// docked to a particular dock panel, or are floating, etc. +// +// DockedTo - return only items docked to this parent control, +// or if the parameter DockedTo is NIL, then query for +// floating Forms. These forms must contain a +// JvDockClient that says it is currently in a Floating state. +// +// FoundItems - OUT: TList of results (pointers to TWinControl objects). +// +// +procedure TJvDockTree.ControlQuery(DockedTo: TWinControl; FoundItems: TList); +begin + Assert(Assigned(FoundItems)); + FoundItems.Clear; + // Root tree node is TopZone. The tree is made of nodes called + // Zones and Zones may have Controls. Some of those Controls are Forms + // we might be querying for, and some are parent container forms containing + // a tabbed set of other forms, so we have to check for that and + // go down into those container forms. DoQuery calls itself and other + // helper routines, recursively, and together this set of routines + // descends through the Zones, Controls (Forms), etc, finding all + // the Controls inside those zones. + DoControlQuery(TopZone, FoundItems); +end; + +//XXX Helper routines for DoQuery: XXX + +procedure TJvDockTree._ParentQuery(LevelsLeft: Integer; AParent: TWinControl; FoundItems: TList ); +var + DockServer: TJvDockServer; + LClassName, LName: string; +begin + if Assigned(AParent) then + begin + LClassName := AParent.ClassName; + LName := AParent.Name; + //Write(Indent + ' '); + //Write(Indent + ' ' + LClassName + ''); + //Write(Indent + ' ' + LName + '@' + IntToHex(Integer(AParent), 8) + ''); + if AParent is TJvDockPanel then + begin + DockServer := TJvDockPanel(AParent).DockServer; + if Assigned(DockServer) then + begin + //Write(Indent + ' ' + DockServer.Name + ''); + end + else + begin + //Write(Indent + ' TJvDockPanel has no DockServer'); + end; + end; + // recurse down: + if LevelsLeft > 0 then + if AParent.Parent <> AParent then // don't show controls where they are their own parent! + _ParentQuery(LevelsLeft - 1, AParent.Parent, FoundItems); + //Write(Indent + ' '); + end; +end; + +procedure TJvDockTree._PageControlQuery(PageControl: TWinControl; FoundItems: TList); {actually TJvDockTabPageControl} +var + I, J, Count: Integer; + PageID: string; + LPageControl: TJvDockTabPageControl; + LClassName, LName: string; +begin + if Assigned(PageControl) then + begin + LPageControl := PageControl as TJvDockTabPageControl; + LClassName := LPageControl.ClassName; + LName := LPageControl.Name; + Count := LPageControl.Count; + //Write(Indent + ' '); + //Write(Indent + ' ' + LClassName + ''); + //Write(Indent + ' ' + LName + ''); + for I := 0 to Count - 1 do + begin + PageID := 'Page' + IntToStr(I + 1); + //Write(Indent + ' <' + PageID + '>'); + //Write(Indent + ' ' + LPageControl.Pages[I].ClassName + ''); + //Write(Indent + ' ' + LPageControl.Pages[I].Name + ''); + //Write(Indent + ' ' + LPageControl.Pages[I].Caption + ''); + //Write(''); + for J := 0 to LPageControl.Pages[I].ControlCount - 1 do + _ControlQuery(LPageControl.Pages[I].Controls[J] as TWinControl, FoundItems); + //Write(Indent + ' '); + end; + //Write(Indent + ' '); + //Write(''); + end; +end; + +procedure TJvDockTree._ControlQuery(AControl: TWinControl; FoundItems: TList); +var + LClassName, LName: string; + LForm: TForm; + DockClient: TJvDockClient; +begin + //Write(Indent + ' '); + LClassName := AControl.ClassName; + LName := AControl.Name; + //Write(Indent + ' ' + LClassName + ''); + //Write(Indent + ' ' + LName + ''); + //Write(Indent + ' ' + BoolToStr(AControl.Visible, True) + ''); + //Write(Indent + ' ' + BoolToStr(AControl.Enabled, True) + ''); + + if AControl is TForm then + begin + LForm := TForm(AControl); + //Write(Indent + ' ' + LForm.Caption + ''); + DockClient := FindDockClient(AControl); + if Assigned(DockClient) then + begin + LClassName := DockClient.ClassName; + LName := DockClient.Name; + + // FOUND A CONTROL WHICH IS A FORM AND HAS A JVDOCK CLIENT. + // Add it to FoundItems: + if DockClient.DockState = JvDockState_Docking then + begin + Assert(Assigned(FoundItems)); + FoundItems.Add(AControl); + end; + //Write(Indent + ' '); + //Write(Indent + ' ' + LClassName + ''); + //Write(Indent + ' ' + LName + ''); + //Write(Indent + ' ' + BoolToStr(DockClient.CustomDock, True) + ''); + + // uses DockStateStr - utility function in JvDockControlForm.pas: + //Write(Indent + ' ' + DockStateStr(DockClient.DockState) + ''); + + //Write(Indent + ' '); + end + else + begin + //Write(Indent + ' No dockclient found in this form.'); + end; + if LForm is TJvDockTabHostForm then + _PageControlQuery(TJvDockTabHostForm(LForm).PageControl, FoundItems); + end; + + { LAST for each control, recursively query the TWinControl.Parent + tree, but limit to only a few levels + so we can avoid information overload. Oops. Too late. :-) } + _ParentQuery(3, AControl.Parent, FoundItems); + //Write(Indent + ' '); +end; + +// DoQuery: +// This is a recursive function called from top level function Query(). +// This helps us to find particular Controls, that are docked to a particular +// dock panel, or are floating, etc. +procedure TJvDockTree.DoControlQuery(TreeZone: TJvDockZone; FoundItems: TList); +var + Zone: TJvDockZone; +begin + Zone := TreeZone; + + { while loop over siblings at this level...} + while Assigned(Zone) do + begin + { Dump controls recursively } + if Assigned( Zone.ChildControl) then + _ControlQuery(Zone.ChildControl, FoundItems); + { query children, descends recursively } + DoControlQuery(Zone.ChildZones, FoundItems); + + {query all siblings at this level immediately after current item } + Zone := Zone.NextSibling; + end; +end; + +{$ENDIF JVDOCK_QUERY} + +procedure TJvDockTree.AdjustDockRect(Control: TControl; var ARect: TRect); +begin + InflateRect(ARect, -BorderWidth, -BorderWidth); + case GrabbersPosition of + gpTop: + Inc(ARect.Top, GrabberSize); + gpBottom: + Dec(ARect.Bottom, GrabberSize); + gpLeft: + Inc(ARect.Left, GrabberSize); + gpRight: + Dec(ARect.Right, GrabberSize); + end; +end; + +procedure TJvDockTree.BeginUpdate; +begin + Inc(FUpdateCount); +end; + +procedure TJvDockTree.EndUpdate; +begin + Dec(FUpdateCount); + if FUpdateCount <= 0 then + begin + FUpdateCount := 0; + UpdateAll; + end; +end; + +function TJvDockTree.FindControlZone(Control: TControl; IncludeHide: Boolean): TJvDockZone; +var + CtlZone: TJvDockZone; + + procedure DoFindControlZone(StartZone: TJvDockZone); + begin + if (StartZone.ChildControl = Control) and (StartZone.Visibled or IncludeHide) then + CtlZone := StartZone + else + begin + if (CtlZone = nil) and (StartZone.NextSibling <> nil) then + DoFindControlZone(StartZone.NextSibling); + + if (CtlZone = nil) and (StartZone.ChildZones <> nil) then + DoFindControlZone(StartZone.ChildZones); + end; + end; + +begin + CtlZone := nil; + if (Control <> nil) and (FTopZone <> nil) then + DoFindControlZone(FTopZone); + Result := CtlZone; +end; + +procedure TJvDockTree.ForEachAt(Zone: TJvDockZone; Proc: TJvDockForEachZoneProc; + ScanKind: TJvDockTreeScanKind; ScanPriority: TJvDockTreeScanPriority); + + procedure DoForwardForEach(Zone: TJvDockZone); + begin + Proc(Zone); + if ScanPriority = tspSibling then + begin + if Zone.NextSibling <> nil then + DoForwardForEach(Zone.NextSibling); + + if Zone.ChildZones <> nil then + DoForwardForEach(Zone.ChildZones); + end + else + begin + if Zone.ChildZones <> nil then + DoForwardForEach(Zone.ChildZones); + + if Zone.NextSibling <> nil then + DoForwardForEach(Zone.NextSibling); + end; + end; + + procedure DoMiddleForEach(Zone: TJvDockZone); + begin + if ScanPriority = tspSibling then + begin + if Zone.NextSibling <> nil then + DoMiddleForEach(Zone.NextSibling); + end + else + begin + if Zone.ChildZones <> nil then + DoMiddleForEach(Zone.ChildZones); + end; + + Proc(Zone); + + if ScanPriority = tspSibling then + begin + if Zone.ChildZones <> nil then + DoMiddleForEach(Zone.ChildZones); + end + else + if Zone.NextSibling <> nil then + DoMiddleForEach(Zone.NextSibling); + end; + + procedure DoBackwardForEach(Zone: TJvDockZone); + begin + if ScanPriority = tspSibling then + begin + if Zone.NextSibling <> nil then + DoBackwardForEach(Zone.NextSibling); + + if Zone.ChildZones <> nil then + DoBackwardForEach(Zone.ChildZones); + end + else + begin + if Zone.ChildZones <> nil then + DoForwardForEach(Zone.ChildZones); + + if Zone.NextSibling <> nil then + DoForwardForEach(Zone.NextSibling); + end; + Proc(Zone); + end; + +begin + if Zone = nil then + begin + if FTopZone = nil then + FTopZone := FDockZoneClass.Create(Self); + Zone := FTopZone; + end; + + case ScanKind of + tskForward: + DoForwardForEach(Zone); + tskMiddle: + DoMiddleForEach(Zone); + tskBackward: + DoBackwardForEach(Zone); + end; +end; + +procedure TJvDockTree.GetControlBounds(Control: TControl; out CtlBounds: TRect); +var + Z: TJvDockZone; +begin + Z := FindControlZone(Control); + if Z = nil then + FillChar(CtlBounds, SizeOf(CtlBounds), 0) + else + with Z do + CtlBounds := Bounds(Left, Top, Width, Height); +end; + +function TJvDockTree.HitTest(const MousePos: TPoint; out HTFlag: Integer): TControl; +var + Zone: TJvDockZone; +begin + Zone := InternalHitTest(MousePos, HTFlag); + if Zone <> nil then + Result := Zone.ChildControl + else + Result := nil; +end; + +procedure TJvDockTree.InsertControl(Control: TControl; InsertAt: TAlign; + DropCtl: TControl); +const + {$IFDEF COMPILER6_UP} + Orients: array [TAlign] of TDockOrientation = + (doNoOrient, doHorizontal, doHorizontal, doVertical, doVertical, doNoOrient, doNoOrient); + MakeLast: array [TAlign] of Boolean = + (False, False, True, False, True, False, False); + {$ELSE} + Orients: array [TAlign] of TDockOrientation = + (doNoOrient, doHorizontal, doHorizontal, doVertical, doVertical, doNoOrient); + MakeLast: array [TAlign] of Boolean = + (False, False, True, False, True, False); + {$ENDIF COMPILER6_UP} +var + Sibling: TJvDockZone; + Me: TJvDockZone; + InsertOrientation: TDockOrientation; + CurrentOrientation: TDockOrientation; + NewWidth, NewHeight: Integer; + R: TRect; +begin + if FReplacementZone <> nil then + begin + FReplacementZone.ChildControl := TWinControl(Control); + FReplacementZone.Update; + Exit; + end + else + if FTopZone <> nil then + begin + if FTopZone.ChildZones = nil then + begin + R := FDockSite.ClientRect; + TWinControlAccessProtected(FDockSite).AdjustClientRect(R); + NewWidth := R.Right - R.Left; + NewHeight := R.Bottom - R.Top; + if TWinControlAccessProtected(FDockSite).AutoSize then + begin + if NewWidth = 0 then + NewWidth := Control.UndockWidth; + if NewHeight = 0 then + NewHeight := Control.UndockHeight; + end; + R := Bounds(R.Left, R.Top, NewWidth, NewHeight); + AdjustDockRect(Control, R); + Control.BoundsRect := R; + Me := FDockZoneClass.Create(Self); + FTopZone.ChildZones := Me; + Me.FParentZone := FTopZone; + Me.ChildControl := TWinControl(Control); + end + else + begin + if InsertAt in [alClient, alNone] then + InsertAt := alRight; + + Me := FindControlZone(Control, True); + if Me <> nil then + RemoveZone(Me, False); + + Sibling := FindControlZone(DropCtl); + + InsertOrientation := Orients[InsertAt]; + if FTopZone.ChildCount = 1 then + begin + FTopZone.Orientation := InsertOrientation; + case InsertOrientation of + doHorizontal: + begin + FTopZone.ZoneLimit := FTopZone.ChildZones.Width; + TopXYLimit := FTopZone.ChildZones.Height; + end; + doVertical: + begin + FTopZone.ZoneLimit := FTopZone.ChildZones.Height; + TopXYLimit := FTopZone.ChildZones.Width; + end; + end; + end; + + Me := FDockZoneClass.Create(Self); + Me.ChildControl := TWinControl(Control); + + if Sibling <> nil then + CurrentOrientation := Sibling.FParentZone.Orientation + else + CurrentOrientation := FTopZone.Orientation; + if InsertOrientation = doNoOrient then + InsertOrientation := CurrentOrientation; + + if InsertOrientation = CurrentOrientation then + InsertSibling(Me, Sibling, MakeLast[InsertAt], True) + else + InsertNewParent(Me, Sibling, InsertOrientation, MakeLast[InsertAt], True); + end; + + FDockSite.Invalidate; + end; +end; + +procedure TJvDockTree.InsertNewParent(NewZone, SiblingZone: TJvDockZone; + ParentOrientation: TDockOrientation; InsertLast, Update: Boolean); +var + NewParent: TJvDockZone; +begin + NewParent := FDockZoneClass.Create(Self); + + NewParent.Orientation := ParentOrientation; + if SiblingZone = nil then + begin + NewParent.ZoneLimit := TopXYLimit; + TopXYLimit := FTopZone.ZoneLimit; + ShiftScaleOrientation := ParentOrientation; + ScaleBy := 0.5; + if InsertLast then + begin + FTopZone.Visibled := FTopZone.VisibleChildCount > 0; + NewParent.ChildZones := FTopZone; + FTopZone.ParentZone := NewParent; + FTopZone.NextSibling := NewZone; + NewZone.PrevSibling := FTopZone; + NewZone.ParentZone := NewParent; + FTopZone := NewParent; + ForEachAt(NewParent.ChildZones, ScaleZone, tskForward); + end + else + begin + NewParent.ChildZones := NewZone; + FTopZone.ParentZone := NewParent; + FTopZone.PrevSibling := NewZone; + NewZone.NextSibling := FTopZone; + NewZone.ParentZone := NewParent; + FTopZone := NewParent; + + if ParentOrientation <> FTopZone.Orientation then + NewZone.ZoneLimit := FTopZone.ZoneLimit div 2 + else + NewZone.ZoneLimit := TopXYLimit div 2; + + ForEachAt(NewZone.NextSibling, ScaleZone, tskForward); + if ParentOrientation <> FTopZone.Orientation then + ShiftBy := FTopZone.ZoneLimit div 2 + else + ShiftBy := TopXYLimit div 2; + ForEachAt(NewZone.NextSibling, ShiftZone, tskForward); + end; + ForEachAt(nil, UpdateZone, tskForward); + end + else + begin + NewParent.ZoneLimit := SiblingZone.ZoneLimit; + NewParent.ParentZone := SiblingZone.ParentZone; + NewParent.PrevSibling := SiblingZone.PrevSibling; + if NewParent.PrevSibling <> nil then + NewParent.PrevSibling.NextSibling := NewParent; + NewParent.NextSibling := SiblingZone.NextSibling; + if NewParent.NextSibling <> nil then + NewParent.NextSibling.PrevSibling := NewParent; + if NewParent.ParentZone.ChildZones = SiblingZone then + NewParent.ParentZone.ChildZones := NewParent; + NewZone.ParentZone := NewParent; + SiblingZone.ParentZone := NewParent; + if InsertLast then + begin + NewParent.ChildZones := SiblingZone; + SiblingZone.ZoneLimit := NewParent.ParentZone.ZoneLimit; + SiblingZone.PrevSibling := nil; + SiblingZone.NextSibling := NewZone; + NewZone.PrevSibling := SiblingZone; + end + else + begin + NewParent.ChildZones := NewZone; + SiblingZone.PrevSibling := NewZone; + SiblingZone.NextSibling := nil; + NewZone.NextSibling := SiblingZone; + end; + end; + if Update then + begin + NewParent.ResetChildren(nil); + ForEachAt(nil, UpdateZone, tskForward); + end; +end; + +procedure TJvDockTree.InsertSibling(NewZone, SiblingZone: TJvDockZone; + InsertLast, Update: Boolean); +begin + if (NewZone <> nil) and (SiblingZone <> nil) and + (NewZone.ChildControl = SiblingZone.ChildControl) then + SiblingZone := nil; + if SiblingZone = nil then + begin + SiblingZone := FTopZone.ChildZones; + if InsertLast then + SiblingZone := SiblingZone.LastSibling; + end; + if InsertLast then + begin + NewZone.ParentZone := SiblingZone.ParentZone; + NewZone.PrevSibling := SiblingZone; + NewZone.NextSibling := SiblingZone.NextSibling; + if NewZone.NextSibling <> nil then + NewZone.NextSibling.PrevSibling := NewZone; + SiblingZone.NextSibling := NewZone; + end + else + begin + NewZone.NextSibling := SiblingZone; + NewZone.PrevSibling := SiblingZone.PrevSibling; + if NewZone.PrevSibling <> nil then + NewZone.PrevSibling.NextSibling := NewZone; + SiblingZone.PrevSibling := NewZone; + NewZone.ParentZone := SiblingZone.ParentZone; + if NewZone.ParentZone.ChildZones = SiblingZone then + NewZone.ParentZone.ChildZones := NewZone; + end; + if Update then + begin + SiblingZone.ParentZone.ResetChildren(nil); + UpdateChild(SiblingZone.ParentZone); + end; +end; + +function TJvDockTree.DoFindZone(const MousePos: TPoint; + out HTFlag: Integer; Zone: TJvDockZone): TJvDockZone; +const + HTFlagArr: array [Boolean] of Integer = (HTCLIENT, HTSPLITTER); +begin + Result := nil; + + if (Zone.ParentZone.Orientation = doHorizontal) and + (Zone.NextSibling <> nil) and + ((MousePos.Y <= Zone.FZoneLimit) and + (MousePos.Y >= Zone.FZoneLimit - SplitterWidth)) and + ((MousePos.X <= Zone.ParentZone.FZoneLimit) and + (MousePos.X >= Zone.ParentZone.LimitBegin)) then + begin + HTFlag := HTFlagArr[Zone.VisibleNextSiblingTotal > 0]; + Result := Zone; + end + else + if (Zone.FParentZone.Orientation = doVertical) and + (Zone.NextSibling <> nil) and + ((MousePos.X <= Zone.FZoneLimit) and + (MousePos.X >= Zone.FZoneLimit - SplitterWidth)) and + ((MousePos.Y <= Zone.ParentZone.FZoneLimit) and + (MousePos.Y >= Zone.ParentZone.LimitBegin)) then + begin + HTFlag := HTFlagArr[Zone.VisibleNextSiblingTotal > 0]; + Result := Zone; + end + else + if Zone.ChildControl <> nil then + begin + case GrabbersPosition of + gpTop: + Result := GetTopGrabbersHTFlag(MousePos, HTFlag, Zone); + gpLeft: + Result := GetLeftGrabbersHTFlag(MousePos, HTFlag, Zone); + gpBottom: + Result := GetBottomGrabbersHTFlag(MousePos, HTFlag, Zone); + gpRight: + Result := GetRightGrabbersHTFlag(MousePos, HTFlag, Zone); + end; + + if Result = nil then + Result := GetBorderHTFlag(MousePos, HTFlag, Zone); + end + else + Result := nil; + + if (Result <> nil) and (not Result.Visibled) then + Result := nil; + + if (Result = nil) and (Zone.NextSibling <> nil) then + Result := DoFindZone(MousePos, HTFlag, Zone.NextSibling); + if (Result = nil) and (Zone.ChildZones <> nil) then + Result := DoFindZone(MousePos, HTFlag, Zone.ChildZones); +end; + +function TJvDockTree.InternalHitTest(const MousePos: TPoint; out HTFlag: Integer): TJvDockZone; +var + ResultZone: TJvDockZone; + CtlAtPos: TControl; + + function FindControlAtPos(const Pos: TPoint): TControl; + var + I: Integer; + P: TPoint; + begin + for I := FDockSite.ControlCount - 1 downto 0 do + begin + Result := FDockSite.Controls[I]; + with Result do + begin + if not Result.Visible or + ((Result is TWinControl) and not TWinControl(Result).Showing) then + Continue; + P := Point(Pos.X - Left, Pos.Y - Top); + if PtInRect(ClientRect, P) then + Exit; + end; + end; + Result := nil; + end; + +begin + ResultZone := nil; + HTFlag := HTNOWHERE; + CtlAtPos := FindControlAtPos(MousePos); + if (CtlAtPos <> nil) and (CtlAtPos.HostDockSite = FDockSite) then + begin + ResultZone := FindControlZone(CtlAtPos); + if ResultZone <> nil then + HTFlag := HTCLIENT; + end + else + if (FTopZone <> nil) and (FTopZone.ChildZones <> nil) and + (FTopZone.ChildCount >= 1) and (CtlAtPos = nil) then + ResultZone := DoFindZone(MousePos, HTFlag, FTopZone.ChildZones); + Result := ResultZone; +end; + +procedure TJvDockTree.LoadFromStream(Stream: TStream); +var + I: Integer; +begin + PruneZone(FTopZone); + + Stream.Read(I, SizeOf(I)); + if I <> Version then + Exit; + + BeginUpdate; + try + Stream.Read(FTopXYLimit, SizeOf(FTopXYLimit)); + DoLoadZone(Stream); + finally + EndUpdate; + end; +end; + +procedure TJvDockTree.PaintSite(DC: HDC); +begin + FCanvas.Control := FDockSite; + FCanvas.Lock; + try + FCanvas.Handle := DC; + try + PaintDockSite; + finally + FCanvas.Handle := 0; + end; + finally + FCanvas.Unlock; + end; +end; + +procedure TJvDockTree.PositionDockRect(Client, DropCtl: TControl; + DropAlign: TAlign; var DockRect: TRect); +var + VisibleClients, NewX, NewY, NewWidth, NewHeight: Integer; +begin + VisibleClients := FDockSite.VisibleDockClientCount; + + if (DropCtl = nil) or (DropCtl.DockOrientation = doNoOrient) or + (VisibleClients < 2) then + begin + DockRect := Rect(0, 0, FDockSite.ClientWidth, FDockSite.ClientHeight); + + if VisibleClients > 0 then + with DockRect do + case DropAlign of + alLeft: + Right := Right div 2; + alRight: + Left := Right div 2; + alTop: + Bottom := Bottom div 2; + alBottom: + Top := Bottom div 2; + end; + end + else + begin + NewX := DropCtl.Left; + NewY := DropCtl.Top; + NewWidth := DropCtl.Width; + NewHeight := DropCtl.Height; + if DropAlign in [alLeft, alRight] then + NewWidth := DropCtl.Width div 2 + else + if DropAlign in [alTop, alBottom] then + NewHeight := DropCtl.Height div 2; + case DropAlign of + alRight: + Inc(NewX, NewWidth); + alBottom: + Inc(NewY, NewHeight); + end; + DockRect := Bounds(NewX, NewY, NewWidth, NewHeight); + if DropAlign = alClient then + DockRect := Bounds(NewX, NewY, NewWidth, NewHeight); + end; + MapWindowPoints(FDockSite.Handle, 0, DockRect, 2); +end; + +procedure TJvDockTree.PruneZone(Zone: TJvDockZone); + + procedure DoPrune(Zone: TJvDockZone); + begin + if Zone.NextSibling <> nil then + DoPrune(Zone.NextSibling); + if Zone.ChildZones <> nil then + DoPrune(Zone.ChildZones); + Zone.Free; + end; + +begin + if Zone = nil then + Exit; + + if Zone.ChildZones <> nil then + DoPrune(Zone.ChildZones); + + if Zone.FPrevSibling <> nil then + Zone.FPrevSibling.NextSibling := Zone.NextSibling + else + if Zone.FParentZone <> nil then + Zone.FParentZone.ChildZones := Zone.NextSibling; + if Zone.NextSibling <> nil then + Zone.NextSibling.FPrevSibling := Zone.FPrevSibling; + + if Zone = FTopZone then + FTopZone := nil; + Zone.Free; +end; + +procedure TJvDockTree.RemoveControl(Control: TControl); +var + Z: TJvDockZone; +begin + Z := FindControlZone(Control, True); + if Z <> nil then + begin + if Z = FReplacementZone then + Z.ChildControl := nil + else + begin + if (Z.ParentZone.Orientation <> doNoOrient) and Z.Visibled then + Z.Remove(Z.LimitSize, False); + RemoveZone(Z, False); + SetNewBounds(nil); + UpdateAll; + end; + Control.DockOrientation := doNoOrient; + + FDockSite.Invalidate; + end; +end; + +procedure TJvDockTree.RemoveZone(Zone: TJvDockZone; Hide: Boolean); +var + Sibling, LastChild: TJvDockZone; + VisibleZoneChildCount, ZoneChildCount: Integer; +// (rom) disabled unused +//label +// LOOP; +begin + if not Hide then + begin + if Zone = nil then + raise Exception.Create(SDockTreeRemoveError + SDockZoneNotFound); + if Zone.ChildControl = nil then + raise Exception.Create(SDockTreeRemoveError + SDockZoneHasNoCtl); + VisibleZoneChildCount := Zone.ParentZone.VisibleChildCount; + ZoneChildCount := Zone.ParentZone.ChildCount; + if VisibleZoneChildCount <= 1 then + begin + if Zone.PrevSibling = nil then + begin + Zone.ParentZone.ChildZones := Zone.NextSibling; + if Zone.NextSibling <> nil then + Zone.NextSibling.PrevSibling := nil; + end + else + if Zone.NextSibling = nil then + Zone.PrevSibling.NextSibling := nil + else + begin + Zone.PrevSibling.NextSibling := Zone.NextSibling; + Zone.NextSibling.PrevSibling := Zone.PrevSibling; + end; + end; + if ZoneChildCount = 2 then + begin + if Zone.PrevSibling = nil then + Sibling := Zone.NextSibling + else + Sibling := Zone.PrevSibling; + if Sibling.ChildControl <> nil then + begin + if Zone.ParentZone = FTopZone then + begin + FTopZone.ChildZones := Sibling; + Sibling.PrevSibling := nil; + Sibling.NextSibling := nil; + Sibling.ZoneLimit := FTopZone.LimitSize; + Sibling.Update; + end + else + begin + Zone.ParentZone.Orientation := doNoOrient; + Zone.ParentZone.ChildControl := Sibling.ChildControl; + Zone.ParentZone.ChildZones := nil; + Sibling.Free; + end; + + ForEachAt(Zone.ParentZone, UpdateZone, tskForward); + end + else + begin + if Zone.ParentZone = FTopZone then + begin + Sibling.ZoneLimit := TopXYLimit; + TopXYLimit := FTopZone.ZoneLimit; + FTopZone.Free; + FTopZone := Sibling; + Sibling.NextSibling := nil; + Sibling.PrevSibling := nil; + Sibling.ParentZone := nil; + end + else + begin + Sibling.ChildZones.PrevSibling := Zone.ParentZone.PrevSibling; + if Sibling.ChildZones.PrevSibling = nil then + Zone.ParentZone.ParentZone.ChildZones := Sibling.ChildZones + else + Sibling.ChildZones.PrevSibling.NextSibling := Sibling.ChildZones; + LastChild := Sibling.ChildZones; + LastChild.ParentZone := Zone.ParentZone.ParentZone; + repeat + LastChild := LastChild.NextSibling; + if LastChild <> nil then + LastChild.ParentZone := Zone.ParentZone.ParentZone + else + Break; + until LastChild.NextSibling = nil; + if LastChild <> nil then + begin + LastChild.NextSibling := Zone.ParentZone.NextSibling; + if LastChild.NextSibling <> nil then + LastChild.NextSibling.PrevSibling := LastChild; + ForEachAt(LastChild.ParentZone, UpdateZone, tskForward); + end; + Zone.ParentZone.Free; + Sibling.Free; + end; + end; + end + else + begin + if Zone.PrevSibling = nil then + begin + Zone.ParentZone.ChildZones := Zone.NextSibling; + if Zone.NextSibling <> nil then + begin + Zone.NextSibling.PrevSibling := nil; + Zone.NextSibling.Update; + end; + end + else + begin + Zone.PrevSibling.NextSibling := Zone.NextSibling; + if Zone.NextSibling <> nil then + Zone.NextSibling.PrevSibling := Zone.PrevSibling; + Zone.PrevSibling.ZoneLimit := Zone.ZoneLimit; + Zone.PrevSibling.Update; + end; + ForEachAt(Zone.ParentZone, UpdateZone, tskForward); + end; + //LOOP: + Zone.Free; + end; + SetNewBounds(nil); + UpdateAll; +end; + +procedure TJvDockTree.ResetBounds(Force: Boolean); +var + R: TRect; +begin + if not (csLoading in FDockSite.ComponentState) and + (FTopZone <> nil) and (FDockSite.DockClientCount > 0) then + begin + R := FDockSite.ClientRect; + TWinControlAccessProtected(FDockSite).AdjustClientRect(R); + if Force or (not CompareMem(@R, @FPreviousRect, SizeOf(TRect))) then + begin + FPreviousRect := R; + case FTopZone.Orientation of + doHorizontal: + begin + FTopZone.ZoneLimit := R.Right - R.Left; + if R.Bottom - R.Top > 0 then + TopXYLimit := R.Bottom - R.Top; + end; + doVertical: + begin + FTopZone.ZoneLimit := R.Bottom - R.Top; + if R.Right - R.Left > 0 then + TopXYLimit := R.Right - R.Left; + end; + end; + SetNewBounds(nil); + if FUpdateCount = 0 then + ForEachAt(nil, UpdateZone, tskForward); + end; + end; +end; + +procedure TJvDockTree.ScaleZone(Zone: TJvDockZone); +begin + FParentLimit := 0; + ScaleChildZone(Zone); +end; + +procedure TJvDockTree.SaveToStream(Stream: TStream); +begin + Stream.Write(FVersion, SizeOf(FVersion)); + Stream.Write(FTopXYLimit, SizeOf(FTopXYLimit)); + DoSaveZone(Stream, FTopZone, 0); + Stream.Write(TreeStreamEndFlag, SizeOf(TreeStreamEndFlag)); +end; + +procedure TJvDockTree.SetNewBounds(Zone: TJvDockZone); + + procedure DoSetNewBounds(Zone: TJvDockZone); + begin + if Zone <> nil then + begin + if (Zone.VisibleNextSiblingCount = 0) and (Zone <> FTopZone) then + begin + if Zone.ParentZone = FTopZone then + Zone.ZoneLimit := FTopXYLimit + else + Zone.ZoneLimit := Zone.ParentZone.ParentZone.FZoneLimit; + end; + if Zone.ChildZones <> nil then + DoSetNewBounds(Zone.ChildZones); + if Zone.NextSibling <> nil then + DoSetNewBounds(Zone.NextSibling); + end; + end; + +begin + if JvGlobalDockIsLoading then + Exit; + if Zone = nil then + Zone := FTopZone.ChildZones; + DoSetNewBounds(Zone); + + FDockSite.Invalidate; +end; + +procedure TJvDockTree.SetReplacingControl(Control: TControl); +begin + FReplacementZone := FindControlZone(Control); +end; + +procedure TJvDockTree.ShiftZone(Zone: TJvDockZone); +begin + if (Zone <> nil) and (Zone <> FTopZone) and + (Zone.ParentZone.Orientation = FShiftScaleOrientation) then + begin + Inc(Zone.FZoneLimit, FShiftBy); + if Zone.LimitSize < FMinSize then + Zone.FZoneLimit := Zone.LimitBegin + FMinSize; + end; +end; + +procedure TJvDockTree.SplitterMouseDown(OnZone: TJvDockZone; MousePos: TPoint); +begin + FSizingZone := OnZone; + Mouse.Capture := FDockSite.Handle; + FSizingWnd := FDockSite.Handle; + FSizingDC := GetDCEx(FSizingWnd, 0, DCX_CACHE or DCX_CLIPSIBLINGS or DCX_LOCKWINDOWUPDATE); + FSizePos := MousePos; + DrawSizeSplitter; +end; + +procedure TJvDockTree.SplitterMouseUp; + + procedure SetSiblingZoneSize(PosXY: Integer); + var + AZone: TJvDockZone; + PrevCount, NextCount: Integer; + begin + PrevCount := FSizingZone.PrevSiblingCount; + AZone := FSizingZone.ParentZone.ChildZones; + while (AZone <> nil) and (AZone <> FSizingZone) do + begin + if AZone.ZoneLimit >= PosXY - PrevCount * MinSize + + Integer(AZone.PrevSibling = nil) * (SplitterWidth div 2) then + begin + AZone.ZoneLimit := PosXY - PrevCount * MinSize + + Integer(AZone.PrevSibling = nil) * (SplitterWidth div 2); + Break; + end; + Dec(PrevCount); + AZone := AZone.NextSibling; + end; + + AZone := AZone.NextSibling; + while PrevCount > 0 do + begin + Dec(PrevCount); + AZone.ZoneLimit := AZone.LimitBegin + MinSize; + AZone := AZone.NextSibling; + end; + + NextCount := 1; + AZone := FSizingZone.NextSibling; + while AZone <> nil do + begin + if AZone.ZoneLimit <= PosXY + NextCount * MinSize + + Integer(AZone.NextSibling <> nil) * (SplitterWidth div 2) then + AZone.ZoneLimit := PosXY + NextCount * MinSize + + Integer(AZone.NextSibling <> nil) * (SplitterWidth div 2); + Inc(NextCount); + AZone := AZone.NextSibling; + end; + end; + +begin + Mouse.Capture := 0; + DrawSizeSplitter; + ReleaseDC(FSizingWnd, FSizingDC); + if FSizingZone.ParentZone.Orientation = doHorizontal then + begin + FSizingZone.ZoneLimit := FSizePos.Y + (SplitterWidth div 2); + SetSiblingZoneSize(FSizePos.Y); + end + else + begin + FSizingZone.ZoneLimit := FSizePos.X + (SplitterWidth div 2); + SetSiblingZoneSize(FSizePos.X); + end; + SetNewBounds(FSizingZone.ParentZone); + ForEachAt(FSizingZone.ParentZone, UpdateZone, tskForward); + FSizingZone := nil; +end; + +procedure TJvDockTree.UpdateAll; +begin + if (FUpdateCount = 0) and (FDockSite.DockClientCount > 0) then + ForEachAt(nil, UpdateZone, tskForward); +end; + +procedure TJvDockTree.UpdateZone(Zone: TJvDockZone); +begin + if FUpdateCount = 0 then + Zone.Update; +end; + +procedure TJvDockTree.DrawSizeSplitter; +var + R: TRect; + PrevBrush: HBrush; +begin + if FSizingZone <> nil then + begin + with R do + if FSizingZone.ParentZone.Orientation = doHorizontal then + begin + Left := FSizingZone.Left; + Top := FSizePos.Y - (SplitterWidth div 2); + Right := Left + FSizingZone.Width; + Bottom := Top + SplitterWidth; + end + else + begin + Left := FSizePos.X - (SplitterWidth div 2); + Top := FSizingZone.Top; + Right := Left + SplitterWidth; + Bottom := Top + FSizingZone.Height; + end; + PrevBrush := SelectObject(FSizingDC, FBrush.Handle); + with R do + PatBlt(FSizingDC, Left, Top, Right - Left, Bottom - Top, PATINVERT); + SelectObject(FSizingDC, PrevBrush); + end; +end; + +function TJvDockTree.GetSplitterLimit(AZone: TJvDockZone; IsCurrent, IsMin: Boolean): Integer; +begin + if IsCurrent then + Result := AZone.GetSplitterLimit(False) + else + if AZone.AfterClosestVisibleZone <> nil then + Result := AZone.AfterClosestVisibleZone.GetSplitterLimit(True) + else + Result := AZone.ZoneLimit + AZone.LimitSize; +end; + +procedure TJvDockTree.ControlVisibilityChanged(Control: TControl; + Visible: Boolean); +begin + if Visible then + ShowControl(Control) + else + HideControl(Control); +end; + +procedure TJvDockTree.WindowProc(var Msg: TMessage); +var + TempZone: TJvDockZone; + HitTestValue: Integer; +begin + case Msg.Msg of + CM_DOCKNOTIFICATION: + with TCMDockNotification(Msg) do + if NotifyRec.ClientMsg = CM_VISIBLECHANGED then + ControlVisibilityChanged(Client, Boolean(NotifyRec.MsgWParam)); + WM_MOUSEMOVE: + DoMouseMove(TWMMouse(Msg), TempZone, HitTestValue); + WM_LBUTTONDBLCLK: + DoLButtonDbClk(TWMMouse(Msg), TempZone, HitTestValue); + WM_LBUTTONDOWN: + if DoLButtonDown(TWMMouse(Msg), TempZone, HitTestValue) then + Exit; + WM_LBUTTONUP: + DoLButtonUp(TWMMouse(Msg), TempZone, HitTestValue); + WM_MBUTTONDOWN: + DoMButtonDown(TWMMouse(Msg), TempZone, HitTestValue); + WM_MBUTTONUP: + DoMButtonUp(TWMMouse(Msg), TempZone, HitTestValue); + WM_RBUTTONDOWN: + DoRButtonDown(TWMMouse(Msg), TempZone, HitTestValue); + WM_RBUTTONUP: + DoRButtonUp(TWMMouse(Msg), TempZone, HitTestValue); + WM_SETCURSOR: + begin + DoSetCursor(TWMSetCursor(Msg), TempZone, HitTestValue); + if Msg.Result = 1 then + Exit; + end; + end; + + FOldWndProc(Msg); + if Msg.Msg = CM_HINTSHOW then + DoHintShow(TCMHintShow(Msg), TempZone, HitTestValue); +end; + +procedure TJvDockTree.SetGrabberSize(const Value: Integer); +begin + if FGrabberSize <> Value then + begin + FGrabberSize := Value; + UpdateAll; + DockSite.Invalidate; + end; +end; + +function TJvDockTree.GetDockGrabbersPosition: TJvDockGrabbersPosition; +begin + if DockSite.Align in [alTop, alBottom] then + Result := gpLeft + else + Result := gpTop; +end; + +function TJvDockTree.GetBottomGrabbersHTFlag(const MousePos: TPoint; + out HTFlag: Integer; Zone: TJvDockZone): TJvDockZone; +begin + Result := nil; +end; + +function TJvDockTree.GetBorderHTFlag(const MousePos: TPoint; + out HTFlag: Integer; Zone: TJvDockZone): TJvDockZone; +var + ARect: TRect; +begin + Result := nil; + + ARect := Zone.GetFrameRect; + + if PtInRect(ARect, MousePos) then + begin + InflateRect(ARect, -BorderWidth, -BorderWidth); + if not PtInRect(ARect, MousePos) then + begin + Result := Zone; + HTFlag := HTBORDER; + end; + end; +end; + +function TJvDockTree.GetLeftGrabbersHTFlag(const MousePos: TPoint; + out HTFlag: Integer; Zone: TJvDockZone): TJvDockZone; +begin + if (MousePos.X >= Zone.Left + BorderWidth) and (MousePos.X <= Zone.Left + BorderWidth + GrabberSize) and + (MousePos.Y >= Zone.Top) and (MousePos.Y <= Zone.Top + Zone.Height) then + begin + Result := Zone; + if MousePos.Y < Zone.ChildControl.Top + GrabberSize + 3 then + HTFlag := HTCLOSE + else + HTFlag := HTCAPTION; + end + else + Result := nil; +end; + +function TJvDockTree.GetRightGrabbersHTFlag(const MousePos: TPoint; + out HTFlag: Integer; Zone: TJvDockZone): TJvDockZone; +begin + Result := nil; +end; + +function TJvDockTree.GetTopGrabbersHTFlag(const MousePos: TPoint; + out HTFlag: Integer; Zone: TJvDockZone): TJvDockZone; +begin + if (MousePos.Y >= Zone.Top + BorderWidth) and (MousePos.Y <= Zone.Top + BorderWidth + GrabberSize) and + (MousePos.X >= Zone.Left) and (MousePos.X <= Zone.Left + Zone.Width) then + begin + Result := Zone; + with Zone.ChildControl do + if MousePos.X > Left + Width - GrabberSize - 3 then + HTFlag := HTCLOSE + else + HTFlag := HTCAPTION; + end + else + Result := nil; +end; + +function TJvDockTree.GetActiveControl: TControl; +begin + Result := Screen.ActiveControl; + if not DockSite.ContainsControl(Result) then + Result := nil; +end; + +procedure TJvDockTree.SetActiveControl(const Value: TControl); +begin + {ignore} +end; + +function TJvDockTree.GetGrabberSize: Integer; +begin + Result := FGrabberSize; +end; + +function TJvDockTree.FindControlZoneAndLevel(Control: TControl; + var CtlLevel: Integer; IncludeHide: Boolean): TJvDockZone; +var + CtlZone: TJvDockZone; + + procedure DoFindControlZone(StartZone: TJvDockZone; Level: Integer); + begin + if (StartZone.ChildControl = Control) and (StartZone.Visibled or IncludeHide) then + begin + CtlZone := StartZone; + CtlLevel := Level; + end + else + begin + if (CtlZone = nil) and (StartZone.NextSibling <> nil) then + DoFindControlZone(StartZone.NextSibling, Level); + + if (CtlZone = nil) and (StartZone.ChildZones <> nil) then + DoFindControlZone(StartZone.ChildZones, Level + 1); + if (CtlZone <> nil) and (not CtlZone.Visibled) then + CtlZone := nil; + end; + end; + +begin + CtlZone := nil; + CtlLevel := 0; + if (Control <> nil) and (FTopZone <> nil) then + DoFindControlZone(FTopZone, 0); + Result := CtlZone; +end; + +procedure TJvDockTree.SetDockSplitterWidth(const Value: Integer); +begin + if FSplitterWidth <> Value then + begin + FSplitterWidth := Value; + UpdateAll; + end; +end; + +procedure TJvDockTree.SetTopZone(const Value: TJvDockZone); +begin + FTopZone := Value; +end; + +procedure TJvDockTree.SetTopXYLimit(const Value: Integer); +begin + FTopXYLimit := Value; +end; + +procedure TJvDockTree.DoMouseMove(var Msg: TWMMouse; + var Zone: TJvDockZone; out HTFlag: Integer); +var + Control: TControl; + DockClient: TJvDockClient; +begin + if FSizingZone <> nil then + begin + DrawSizeSplitter; + FSizePos := SmallPointToPoint(Msg.Pos); + CalcSplitterPos; + DrawSizeSplitter; + end; + + Zone := InternalHitTest(SmallPointToPoint(Msg.Pos), HTFlag); + if Zone <> nil then + begin + DockClient := FindDockClient(Zone.ChildControl); + if DockClient <> nil then + DockClient.DoNCMouseMove(JvDockCreateNCMessage(DockSite, + WM_NCMOUSEMOVE, HTFlag, FSizePos), msConjoin); + Control := Zone.ChildControl; + end + else + Control := nil; + if (Control <> nil) and (HTFlag <> FOldHTFlag) then + begin + Application.HideHint; + Application.HintMouseMessage(Control, TMessage(Msg)); + Application.ActivateHint(SmallPointToPoint(Msg.Pos)); + FOldHTFlag := HTFlag; + end; +end; + +function TJvDockTree.DoLButtonDown(var Msg: TWMMouse; + var Zone: TJvDockZone; out HTFlag: Integer): Boolean; +var + P: TPoint; + Mesg: TMsg; +begin + Result := False; + P := SmallPointToPoint(Msg.Pos); + + Zone := InternalHitTest(P, HTFlag); + if Zone <> nil then + begin + if HTFlag = HTSPLITTER then + SplitterMouseDown(Zone, P) + else + if (HTFlag = HTCAPTION) or (HTFlag = HTBORDER) then + begin + JvGlobalDockClient := FindDockClient(Zone.ChildControl); + if JvGlobalDockClient <> nil then + JvGlobalDockClient.DoNCButtonDown(JvDockCreateNCMessage(DockSite, + WM_NCLBUTTONDOWN, HTFlag, P), mbLeft, msConjoin); + + if (not PeekMessage(Mesg, FDockSite.Handle, WM_LBUTTONDBLCLK, + WM_LBUTTONDBLCLK, PM_NOREMOVE)) and + Assigned(Zone.ChildControl) then + if not Zone.ChildControl.ContainsControl(Screen.ActiveControl) and Zone.ChildControl.CanFocus then + Zone.ChildControl.SetFocus; + if (TWinControlAccessProtected(Zone.ChildControl).DragKind = dkDock) and + (TWinControlAccessProtected(Zone.ChildControl).DragMode = dmAutomatic) then + BeginDrag(Zone.ChildControl, True); + Result := True; + end; + end; +end; + +procedure TJvDockTree.DoLButtonUp(var Msg: TWMMouse; + var Zone: TJvDockZone; out HTFlag: Integer); +var + P: TPoint; + DockClient: TJvDockClient; +begin + if FSizingZone = nil then + begin + P := SmallPointToPoint(Msg.Pos); + Zone := InternalHitTest(P, HTFlag); + if Zone <> nil then + if (HTFlag <> HTSPLITTER) and (Zone.ChildControl <> nil) then + begin + DockClient := FindDockClient(Zone.ChildControl); + if DockClient <> nil then + DockClient.DoNCButtonUp(JvDockCreateNCMessage(DockSite, + WM_NCLBUTTONUP, HTFlag, P), mbLeft, msConjoin); + if HTFlag = HTCLOSE then + begin + if (DockClient <> nil) and not DockClient.EnableCloseButton then + Exit; + DoHideZoneChild(Zone); + end; + end; + end + else + SplitterMouseUp; +end; + +procedure TJvDockTree.DoLButtonDbClk(var Msg: TWMMouse; + var Zone: TJvDockZone; out HTFlag: Integer); +var + P: TPoint; +begin + P := SmallPointToPoint(Msg.Pos); + Zone := InternalHitTest(P, HTFlag); + if (Zone <> nil) and (Zone.ChildControl <> nil) and + (HTFlag = HTCAPTION) or (HTFlag = HTBORDER) then + begin + if HTFlag <> HTSPLITTER then + JvGlobalDockClient.DoNCButtonDblClk(JvDockCreateNCMessage(DockSite, + WM_NCLBUTTONUP, HTFlag, P), mbLeft, msConjoin); + if JvGlobalDockClient.CanFloat then + begin + JvGlobalDockManager.CancelDrag; + Zone.LButtonDblClkMethod; + end; + Zone := nil; + end; +end; + +procedure TJvDockTree.DoSetCursor(var Msg: TWMSetCursor; + var Zone: TJvDockZone; out HTFlag: Integer); +var + P: TPoint; +begin + GetCursorPos(P); + P := FDockSite.ScreenToClient(P); + with Msg do + if (Smallint(HitTest) = HTCLIENT) and (CursorWnd = FDockSite.Handle) and + (FDockSite.VisibleDockClientCount > 0) then + begin + Zone := InternalHitTest(P, HTFlag); + if (Zone <> nil) and (HTFlag = HTSPLITTER) then + begin + SetSplitterCursor(Zone.ParentZone.Orientation); + Result := 1; + end; + end; +end; + +procedure TJvDockTree.DoHintShow(var Msg: TCMHintShow; + var Zone: TJvDockZone; out HTFlag: Integer); +var + Control: TWinControl; + R: TRect; + ADockClient: TJvDockClient; + CanShow: Boolean; +begin + with Msg do + begin + if Result = 0 then + begin + Zone := InternalHitTest(HintInfo^.CursorPos, HTFlag); + if Zone <> nil then + Control := Zone.ChildControl + else + Control := nil; + + ADockClient := FindDockClient(Control); + if (ADockClient <> nil) and (not ADockClient.ShowHint) then + Exit; + + if HTFlag = HTSPLITTER then + HintInfo^.HintStr := '' + else + if Control <> nil then + begin + R := GetFrameRect(Control); + if HTFlag = HTCAPTION then + HintInfo^.HintStr := TWinControlAccessProtected(Control).Caption + else + if HTFlag = HTCLOSE then + HintInfo^.HintStr := RsDockJvDockTreeCloseBtnHint + else + DoOtherHint(Zone, HTFlag, HintInfo^.HintStr); + + HintInfo^.CursorRect := R; + + CanShow := True; + if ADockClient <> nil then + ADockClient.DoFormShowHint(HTFlag, HintInfo^.HintStr, CanShow); + if not CanShow then + HintInfo^.HintStr := ''; + end; + end; + end; +end; + +procedure TJvDockTree.SetSplitterCursor(CursorIndex: TDockOrientation); +const + SizeCursors: array [TDockOrientation] of TCursor = + (crDefault, crVSplit, crHSplit); +begin + Windows.SetCursor(Screen.Cursors[SizeCursors[CursorIndex]]); +end; + +procedure TJvDockTree.SetDockZoneClass(const Value: TJvDockZoneClass); +begin + FDockZoneClass := Value; +end; + +procedure TJvDockTree.DoMButtonDown(var Msg: TWMMouse; + var Zone: TJvDockZone; out HTFlag: Integer); +var + Mesg: TWMNCHitMessage; + DockClient: TJvDockClient; +begin + Mesg := DoMouseEvent(Msg, Zone, HTFlag); + if Mesg.Result > 0 then + begin + DockClient := FindDockClient(Zone.ChildControl); + if DockClient <> nil then + DockClient.DoNCButtonDown(Mesg, mbMiddle, msConjoin); + end; +end; + +procedure TJvDockTree.DoMButtonUp(var Msg: TWMMouse; + var Zone: TJvDockZone; out HTFlag: Integer); +var + Mesg: TWMNCHitMessage; + DockClient: TJvDockClient; +begin + Mesg := DoMouseEvent(Msg, Zone, HTFlag); + if Mesg.Result > 0 then + begin + DockClient := FindDockClient(Zone.ChildControl); + if DockClient <> nil then + DockClient.DoNCButtonUp(Mesg, mbMiddle, msConjoin); + end; +end; + +procedure TJvDockTree.DoRButtonDown(var Msg: TWMMouse; + var Zone: TJvDockZone; out HTFlag: Integer); +var + Mesg: TWMNCHitMessage; + DockClient: TJvDockClient; +begin + Mesg := DoMouseEvent(Msg, Zone, HTFlag); + if Mesg.Result > 0 then + begin + DockClient := FindDockClient(Zone.ChildControl); + if DockClient <> nil then + DockClient.DoNCButtonDown(Mesg, mbRight, msConjoin); + end; +end; + +procedure TJvDockTree.DoRButtonUp(var Msg: TWMMouse; + var Zone: TJvDockZone; out HTFlag: Integer); +var + Mesg: TWMNCHitMessage; + DockClient: TJvDockClient; +begin + Mesg := DoMouseEvent(Msg, Zone, HTFlag); + if Mesg.Result > 0 then + begin + DockClient := FindDockClient(Zone.ChildControl); + if DockClient <> nil then + DockClient.DoNCButtonUp(Mesg, mbRight, msConjoin); + end; +end; + +function TJvDockTree.DoMouseEvent(var Msg: TWMMouse; + var Zone: TJvDockZone; out HTFlag: Integer): TWMNCHitMessage; +var + Pt: TPoint; +begin + Result.Result := 0; + Pt := SmallPointToPoint(Msg.Pos); + Zone := InternalHitTest(Pt, HTFlag); + if (Zone <> nil) and (Zone.ChildControl <> nil) and (HTFlag <> HTSPLITTER) then + begin + Result := JvDockCreateNCMessage(DockSite, Msg.Msg + WM_NCMOUSEFIRST - WM_MOUSEFIRST, HTFlag, Pt); + Result.Result := 1; + end; +end; + +procedure TJvDockTree.DoMButtonDbClk(var Msg: TWMMouse; + var Zone: TJvDockZone; out HTFlag: Integer); +var + Pt: TPoint; + DockClient: TJvDockClient; +begin + Pt := SmallPointToPoint(Msg.Pos); + Zone := InternalHitTest(Pt, HTFlag); + if (Zone <> nil) and (Zone.ChildControl <> nil) and (HTFlag = HTCAPTION) then + if HTFlag <> HTSPLITTER then + begin + DockClient := FindDockClient(Zone.ChildControl); + if DockClient <> nil then + DockClient.DoNCButtonDblClk(JvDockCreateNCMessage( + DockSite, WM_NCLBUTTONUP, HTFlag, Pt), mbMiddle, msConjoin); + end; +end; + +procedure TJvDockTree.DoRButtonDbClk(var Msg: TWMMouse; + var Zone: TJvDockZone; out HTFlag: Integer); +var + Pt: TPoint; + DockClient: TJvDockClient; +begin + Pt := SmallPointToPoint(Msg.Pos); + Zone := InternalHitTest(Pt, HTFlag); + if (Zone <> nil) and (Zone.ChildControl <> nil) and (HTFlag = HTCAPTION) then + if HTFlag <> HTSPLITTER then + begin + DockClient := FindDockClient(Zone.ChildControl); + if DockClient <> nil then + DockClient.DoNCButtonDblClk(JvDockCreateNCMessage( + DockSite, WM_NCLBUTTONUP, HTFlag, Pt), mbRight, msConjoin); + end; +end; + +function TJvDockTree.GetFrameRect(Control: TControl): TRect; +var + NLeft, NTop: Integer; +begin + if Control <> nil then + begin + Result := Control.BoundsRect; + NLeft := Result.Left; + NTop := Result.Top; + AdjustDockRect(Control, Result); + Dec(Result.Left, 2 * (Result.Left - Control.Left) + 1); + if Result.Left < 0 then + Result.Left := 0; + Dec(Result.Top, 2 * (Result.Top - Control.Top)); + Dec(Result.Right, 2 * (Result.Right - NLeft - Control.Width)); + Dec(Result.Bottom, 2 * (Result.Bottom - NTop - Control.Height)); + end + else + raise Exception.CreateRes(@RsEDockControlCannotIsNil); +end; + +function TJvDockTree.GetSplitterRect(Zone: TJvDockZone): TRect; +var + A, B, C, D: Integer; +begin + if (Zone <> nil) and Zone.Visibled and (Zone.ParentZone <> nil) and + (Zone.VisibleNextSiblingCount >= 1) and + (Zone.ParentZone.Orientation <> doNoOrient) then + begin + A := Zone.ParentZone.LimitBegin; + B := Zone.ParentZone.ZoneLimit; + C := Zone.ZoneLimit - SplitterWidth; + D := C + 1 * SplitterWidth; + if Zone.ParentZone.Orientation = doHorizontal then + Result := Rect(A, C, B, D) + else + if Zone.ParentZone.Orientation = doVertical then + Result := Rect(C, A, D, B); + end + else + Result := Rect(0, 0, 0, 0); +end; + +procedure TJvDockTree.BeginDrag(Control: TControl; + Immediate: Boolean; Threshold: Integer); +var + DockClient: TJvDockClient; +begin + DockClient := FindDockClient(Control); + if DockClient <> nil then + JvGlobalDockManager.BeginDrag(Control, DockClient.DirectDrag, Threshold); +end; + +function TJvDockTree.GetFrameRectEx(Control: TControl): TRect; +begin + if Control <> nil then + begin + Result := GetFrameRect(Control); + MapWindowPoints(DockSite.Handle, 0, Result, 2); + end; +end; + +procedure TJvDockTree.DrawDockSiteRect; +begin +end; + +procedure TJvDockTree.SetBorderWidth(const Value: Integer); +begin + if FBorderWidth <> Value then + begin + FBorderWidth := Value; + UpdateAll; + DockSite.Invalidate; + end; +end; + +function TJvDockTree.GetBorderWidth: Integer; +begin + Result := FBorderWidth; +end; + +function TJvDockTree.GetDockSplitterWidth: Integer; +begin + Result := FSplitterWidth; +end; + +procedure TJvDockTree.DrawSplitter(Zone: TJvDockZone); +var + R: TRect; +begin + R := GetSplitterRect(Zone); + DrawSplitterRect(R); +end; + +function TJvDockTree.GetDockEdge(DockRect: TRect; MousePos: TPoint; + var DropAlign: TAlign; Control: TControl): TControl; +begin + Result := nil; +end; + +function TJvDockTree.GetDockSiteOrientation: TDockOrientation; +begin + Result := JvDockGetControlOrient(DockSite); +end; + +procedure TJvDockTree.BeginResizeDockSite; +begin + Inc(FResizeCount); +end; + +procedure TJvDockTree.EndResizeDockSite; +begin + Dec(FResizeCount); + if FResizeCount < 0 then + FResizeCount := 0; +end; + +procedure TJvDockTree.ScaleChildZone(Zone: TJvDockZone); +begin + if (Zone <> nil) and (Zone.ParentZone <> nil) and Zone.Visibled and + (Zone.ParentZone.Orientation = ShiftScaleOrientation) then + Zone.ZoneLimit := Integer(Round(Zone.ZoneLimit * ScaleBy + FParentLimit * (1 - ScaleBy))); +end; + +procedure TJvDockTree.ScaleSiblingZone(Zone: TJvDockZone); +begin + ScaleChildZone(Zone); +end; + +function TJvDockTree.GetDockSiteSize: Integer; +begin + case DockSiteOrientation of + doVertical: + Result := DockSite.Width; + doHorizontal: + Result := DockSite.Height; + else + raise Exception.CreateRes(@RsEDockCannotGetValueWithNoOrient); + end; +end; + +procedure TJvDockTree.SetDockSiteSize(const Value: Integer); +begin + DockSite.Parent.DisableAlign; + try + // if we have a docksite aligned to alClient it's unnecessary + // to set the DockSite Size + if DockSite.Align = alClient then + Exit; + + if DockSite.Align in [alRight, alBottom] then + DockSiteBegin := DockSiteBegin - (Value - DockSiteSize); + case DockSiteOrientation of + doVertical: + DockSite.Width := Value; + doHorizontal: + DockSite.Height := Value; + else + raise Exception.CreateRes(@RsEDockCannotSetValueWithNoOrient); + end; + finally + DockSite.Parent.EnableAlign; + end; +end; + +procedure TJvDockTree.SetMinSize(const Value: Integer); +begin + FMinSize := Value; +end; + +function TJvDockTree.GetDockSiteBegin: Integer; +begin + case DockSiteOrientation of + doVertical: + Result := DockSite.Left; + doHorizontal: + Result := DockSite.Top; + else + raise Exception.CreateRes(@RsEDockCannotGetValueWithNoOrient); + end; +end; + +procedure TJvDockTree.SetDockSiteBegin(const Value: Integer); +begin + case DockSiteOrientation of + doVertical: + DockSite.Left := Value; + doHorizontal: + DockSite.Top := Value; + else + raise Exception.CreateRes(@RsEDockCannotSetValueWithNoOrient); + end; +end; + +function TJvDockTree.GetDockSiteSizeAlternate: Integer; +begin + case DockSiteOrientation of + doVertical: + Result := DockSite.Height; + doHorizontal: + Result := DockSite.Width; + else + raise Exception.CreateRes(@RsEDockCannotGetValueWithNoOrient); + end; +end; + +procedure TJvDockTree.SetDockSiteSizeAlternate(const Value: Integer); +begin + case DockSiteOrientation of + doVertical: + DockSite.Height := Value; + doHorizontal: + DockSite.Width := Value; + else + raise Exception.CreateRes(@RsEDockCannotSetValueWithNoOrient); + end; +end; + +procedure TJvDockTree.CalcSplitterPos; +var + MinWidth: Integer; + TestLimit: Integer; +begin + MinWidth := MinSize; + if FSizingZone.ParentZone.Orientation = doHorizontal then + begin + TestLimit := GetSplitterLimit(FSizingZone, True, False) + MinWidth; + if FSizePos.Y <= TestLimit then + FSizePos.Y := TestLimit; + TestLimit := GetSplitterLimit(FSizingZone, False, True) - MinWidth - SplitterWidth; + if FSizePos.Y >= TestLimit then + FSizePos.Y := TestLimit; + end + else + begin + TestLimit := GetSplitterLimit(FSizingZone, True, False) + MinWidth; + if FSizePos.X <= TestLimit then + FSizePos.X := TestLimit; + TestLimit := GetSplitterLimit(FSizingZone, False, True) - MinWidth - SplitterWidth; + if FSizePos.X >= TestLimit then + FSizePos.X := TestLimit; + end; +end; + +procedure TJvDockTree.SetVersion(const Value: Integer); +begin + FVersion := Value; +end; + +procedure TJvDockTree.DoSaveZone(Stream: TStream; + Zone: TJvDockZone; Level: Integer); +begin + with Stream do + begin + Write(Level, SizeOf(Level)); + CustomSaveZone(Stream, Zone); + end; + + if Zone.ChildZones <> nil then + DoSaveZone(Stream, Zone.ChildZones, Level + 1); + if Zone.NextSibling <> nil then + DoSaveZone(Stream, Zone.NextSibling, Level); +end; + +procedure TJvDockTree.WriteControlName(Stream: TStream; const ControlName: string); +var + NameLen: Integer; +begin + NameLen := Length(ControlName); + Stream.Write(NameLen, SizeOf(NameLen)); + if NameLen > 0 then + Stream.Write(Pointer(ControlName)^, NameLen); +end; + +procedure TJvDockTree.DoLoadZone(Stream: TStream); +var + Level, LastLevel, I: Integer; + Zone, LastZone, NextZone: TJvDockZone; +begin + LastLevel := 0; + LastZone := nil; + while True do + begin + with Stream do + begin + if Read(Level, SizeOf(Level)) <> SizeOf(Level) then + Break; + if Level = TreeStreamEndFlag then + Break; + Zone := FDockZoneClass.Create(Self); + CustomLoadZone(Stream, Zone); + if Zone = nil then + Continue; + end; + if Level = 0 then + FTopZone := Zone + else + if Level = LastLevel then + begin + LastZone.NextSibling := Zone; + Zone.FPrevSibling := LastZone; + Zone.FParentZone := LastZone.FParentZone; + end + else + if Level > LastLevel then + begin + LastZone.ChildZones := Zone; + Zone.FParentZone := LastZone; + end + else + if Level < LastLevel then + begin + NextZone := LastZone; + for I := 1 to LastLevel - Level do + if NextZone <> nil then + NextZone := NextZone.FParentZone; + if NextZone <> nil then + NextZone.NextSibling := Zone; + if (Zone <> nil) and (NextZone <> nil) then + begin + Zone.FPrevSibling := NextZone; + Zone.FParentZone := NextZone.FParentZone; + end; + end; + LastLevel := Level; + LastZone := Zone; + end; +end; + +procedure TJvDockTree.ReadControlName(Stream: TStream; + var ControlName: string); +var + Size: Integer; +begin + ControlName := ''; + Size := 0; + Stream.Read(Size, SizeOf(Size)); + if Size > 0 then + begin + SetLength(ControlName, Size); + Stream.Read(Pointer(ControlName)^, Size); + end; +end; + +procedure TJvDockTree.CustomLoadZone(Stream: TStream; var Zone: TJvDockZone); +var + CompName: string; +begin + with Stream do + begin + Read(Zone.FOrientation, SizeOf(Zone.Orientation)); + Read(Zone.FZoneLimit, SizeOf(Zone.FZoneLimit)); + Read(Zone.FVisibled, SizeOf(Zone.Visibled)); + Read(Zone.FControlVisibled, SizeOf(Zone.FControlVisibled)); + Read(Zone.FVisibleSize, SizeOf(Zone.VisibleSize)); + Read(Zone.FIsInside, SizeOf(Zone.FIsInside)); + ReadControlName(Stream, CompName); + if CompName <> '' then + if not Zone.SetControlName(CompName) then + begin + Zone.Free; + Zone := nil; + end; + end; +end; + +procedure TJvDockTree.CustomSaveZone(Stream: TStream; Zone: TJvDockZone); +var + AVisible: Boolean; +begin + with Stream do + begin + Write(Zone.Orientation, SizeOf(Zone.Orientation)); + Write(Zone.ZoneLimit, SizeOf(Zone.ZoneLimit)); + + if Zone.ChildControl <> nil then + AVisible := Zone.ChildControl.Visible; + Write(Zone.Visibled, SizeOf(Zone.Visibled)); + + AVisible := False; + if Zone.ChildControl <> nil then + AVisible := Zone.ChildControl.Visible; + Write(AVisible, SizeOf(AVisible)); + + Write(Zone.VisibleSize, SizeOf(Zone.VisibleSize)); + + Zone.IsInside := True; + if (Zone.ChildControl <> nil) and (Zone.ChildControl.HostDockSite <> DockSite) and + not (DockSite is TJvDockVSPopupPanel) then + Zone.IsInside := False; + Write(Zone.IsInside, SizeOf(Zone.IsInside)); + + WriteControlName(Stream, Zone.GetControlName); + end; +end; + +procedure TJvDockTree.SetDockSiteSizeWithOrientation(Orient: TDockOrientation; + const Value: Integer); +begin + case Orient of + doVertical: + DockSite.Width := Value; + doHorizontal: + DockSite.Height := Value; + else + raise Exception.CreateRes(@RsEDockCannotSetValueWithNoOrient); + end; +end; + +procedure TJvDockTree.DoOtherHint(Zone: TJvDockZone; + HTFlag: Integer; var HintStr: string); +begin +end; + +function TJvDockTree.GetHTFlag(MousePos: TPoint): Integer; +var + Zone: TJvDockZone; +begin + Zone := InternalHitTest(MousePos, Result); + if Zone = nil then + Result := HTNONE; +end; + +procedure TJvDockTree.GetSiteInfo(Client: TControl; + var InfluenceRect: TRect; MousePos: TPoint; var CanDock: Boolean); +begin + GetWindowRect(DockSite.Handle, InfluenceRect); + InflateRect(InfluenceRect, DefExpandoRect, DefExpandoRect); +end; + +function TJvDockTree.GetDockRect: TRect; +begin + Result := FDockRect; +end; + +procedure TJvDockTree.SetDockRect(const Value: TRect); +begin + FDockRect := Value; +end; + +function TJvDockTree.GetDockAlign(Client: TControl; var DropCtl: TControl): TAlign; +var + CRect, DRect: TRect; +begin + Result := alRight; + if DropCtl <> nil then + begin + CRect := Client.BoundsRect; + DRect := DropCtl.BoundsRect; + if (CRect.Top <= DRect.Top) and (CRect.Bottom < DRect.Bottom) and + (CRect.Right >= DRect.Right) then + Result := alTop + else + if (CRect.Left <= DRect.Left) and (CRect.Right < DRect.Right) and + (CRect.Bottom >= DRect.Bottom) then + Result := alLeft + else + if CRect.Top >= ((DRect.Top + DRect.Bottom) div 2) then + Result := alBottom; + end; +end; + +procedure TJvDockTree.HideControl(Control: TControl); +var + Z: TJvDockZone; +begin + if ReplacementZone <> nil then + Exit; + Z := FindControlZone(Control); + if Z <> nil then + begin + if Z = FReplacementZone then + Z.ChildControl := nil + else + begin + if TopZone.VisibleChildTotal = 1 then + Z.Remove(TopXYLimit, True) + else + Z.Remove(Z.LimitSize, True); + end; + Control.DockOrientation := doNoOrient; + SetNewBounds(nil); + UpdateAll; + + FDockSite.Invalidate; + end; +end; + +procedure TJvDockTree.ShowControl(Control: TControl); +var + Z: TJvDockZone; +begin + if ReplacementZone <> nil then + Exit; + Z := FindControlZone(Control, True); + if Z <> nil then + Z.Insert(Z.VisibleSize, False); + + SetNewBounds(nil); + UpdateAll; + DockSite.Invalidate; +end; + +procedure TJvDockTree.DoGetNextLimit(Zone, AZone: TJvDockZone; var LimitResult: Integer); +begin + if (Zone <> AZone) and + (Zone.ParentZone.Orientation = AZone.ParentZone.Orientation) and + (Zone.ZoneLimit > AZone.FZoneLimit) and ((Zone.ChildControl = nil) or + ((Zone.ChildControl <> nil) and (Zone.ChildControl.Visible))) then + LimitResult := Min(LimitResult, Zone.ZoneLimit); + if Zone.NextSibling <> nil then + DoGetNextLimit(Zone.NextSibling, AZone, LimitResult); + + if Zone.ChildZones <> nil then + DoGetNextLimit(Zone.ChildZones, AZone, LimitResult); +end; + +procedure TJvDockTree.UpdateChild(Zone: TJvDockZone); +begin + if (FUpdateCount = 0) and (FDockSite.DockClientCount > 0) then + ForEachAt(Zone, UpdateZone, tskForward); +end; + +function TJvDockTree.GetDockClientLimit(Orient: TDockOrientation; IsMin: Boolean): Integer; +var + Zone: TJvDockZone; +begin + Result := 0; + if TopZone.ChildCount = 1 then + Result := Integer(not IsMin) * DockSiteSizeWithOrientation[Orient] + else + begin + if IsMin then + begin + if TopZone.Orientation = Orient then + Zone := TopZone.LastVisibleChildZone + else + Zone := TopZone; + if Zone <> nil then + Result := Zone.LimitBegin; + end + else + begin + if TopZone.Orientation = Orient then + Zone := TopZone.FirstVisibleChildZone + else + Zone := TopZone; + if Zone <> nil then + Result := Zone.ZoneLimit; + end; + + TopZone.DoGetSplitterLimit(Orient, IsMin, Result); + end; +end; + +function TJvDockTree.GetDockSiteSizeWithOrientation(Orient: TDockOrientation): Integer; +begin + case Orient of + doVertical: + Result := DockSite.Width; + doHorizontal: + Result := DockSite.Height; + else + raise Exception.CreateRes(@RsEDockCannotGetValueWithNoOrient); + end; +end; + +function TJvDockTree.GetMinSize: Integer; +begin + Result := FMinSize; +end; + +procedure TJvDockTree.GetCaptionRect(var Rect: TRect); +begin + Rect.Left := 0; + Rect.Top := 0; + Rect.Right := 0; + Rect.Bottom := 0; +end; + +procedure TJvDockTree.HideAllControl; + + procedure DoHideAllControl(AZone: TJvDockZone); + begin + if AZone <> nil then + begin + DoHideAllControl(AZone.NextSibling); + DoHideAllControl(AZone.ChildZones); + if (AZone.ChildControl <> nil) and (AZone.Visibled) then + AZone.Remove(AZone.LimitSize, True); + end; + end; + +begin + if ReplacementZone <> nil then + Exit; + DoHideAllControl(TopZone.ChildZones); + SetNewBounds(nil); + UpdateAll; + DockSite.Invalidate; +end; + +procedure TJvDockTree.HideSingleControl(Control: TControl); + + procedure DoHideSingleControl(AZone: TJvDockZone); + begin + if AZone <> nil then + begin + DoHideSingleControl(AZone.NextSibling); + DoHideSingleControl(AZone.ChildZones); + if AZone.ChildControl <> nil then + if AZone.ChildControl = Control then + begin + if AZone.ChildControl.Visible then + begin + AZone.Remove(AZone.LimitSize, True); + AZone.ChildControl.Visible := False; + end; + end + else + begin + AZone.Insert(AZone.VisibleSize, False); + AZone.ChildControl.Visible := True; + end; + end; + end; + +begin + if ReplacementZone <> nil then + Exit; + if Control <> nil then + begin + DoHideSingleControl(TopZone.ChildZones); + SetNewBounds(nil); + UpdateAll; + DockSite.Invalidate; + end; +end; + +procedure TJvDockTree.ShowAllControl; + + procedure DoShowAllControl(AZone: TJvDockZone); + begin + if AZone <> nil then + begin + DoShowAllControl(AZone.NextSibling); + DoShowAllControl(AZone.ChildZones); + if (AZone.ChildControl <> nil) and not AZone.Visibled then + AZone.Insert(AZone.VisibleSize, True); + end; + end; + +begin + if ReplacementZone <> nil then + Exit; + DoShowAllControl(TopZone.ChildZones); + SetNewBounds(nil); + UpdateAll; + DockSite.Invalidate; +end; + +procedure TJvDockTree.ShowSingleControl(Control: TControl); + + procedure DoShowSingleControl(AZone: TJvDockZone); + begin + if AZone <> nil then + begin + DoShowSingleControl(AZone.NextSibling); + DoShowSingleControl(AZone.ChildZones); + if AZone.ChildControl <> nil then + if AZone.ChildControl = Control then + begin + if not AZone.ChildControl.Visible then + begin + AZone.Insert(AZone.VisibleSize, False); + AZone.ChildControl.Visible := True; + end; + end + else + begin + AZone.Remove(AZone.LimitSize, True); + AZone.ChildControl.Visible := False; + end; + end; + end; + +begin + if ReplacementZone <> nil then + Exit; + if Control <> nil then + begin + DoShowSingleControl(TopZone.ChildZones); + SetNewBounds(nil); + UpdateAll; + DockSite.Invalidate; + end; +end; + +procedure TJvDockTree.DrawDockBorder(DockControl: TControl; R1, R2: TRect); +begin +end; + +procedure TJvDockTree.DrawDockGrabber(Control: TWinControl; + const ARect: TRect); + + procedure DrawCloseButton(Left, Top: Integer); + var + ADockClient: TJvDockClient; + {$IFDEF JVCLThemesEnabled} + Details: TThemedElementDetails; + CurrentThemeType: TThemedWindow; + {$ENDIF JVCLThemesEnabled} + begin + ADockClient := FindDockClient(Control); + if (ADockClient <> nil) and not ADockClient.EnableCloseButton then + Exit; + // MF + {$IFDEF JVCLThemesEnabled} + if ThemeServices.ThemesAvailable and ThemeServices.ThemesEnabled then + begin + if GrabberSize < 14 then + CurrentThemeType := twSmallCloseButtonNormal + else + CurrentThemeType := twCloseButtonNormal; + Details := ThemeServices.GetElementDetails(CurrentThemeType); + ThemeServices.DrawElement(Canvas.Handle, Details, Rect(Left, Top, + Left + GrabberSize - 2, Top + GrabberSize - 2)); + end + else + {$ENDIF JVCLThemesEnabled} + {This is the grabber's Close button if one should be drawn. } + DrawFrameControl(Canvas.Handle, Rect(Left, Top, Left + GrabberSize - 2, + Top + GrabberSize - 2), DFC_CAPTION, DFCS_CAPTIONCLOSE); + end; + + procedure DrawGrabberLine(Left, Top, Right, Bottom: Integer); + begin + with Canvas do + begin + Pen.Color := clBtnHighlight; + MoveTo(Right, Top); + LineTo(Left, Top); + LineTo(Left, Bottom); + Pen.Color := clBtnShadow; + LineTo(Right, Bottom); + LineTo(Right, Top - 1); + end; + end; + +begin + with ARect do + case GrabbersPosition of + gpLeft: + begin + if FGrabberBgColor <> clNone then + begin { draw only if color is given } + Canvas.Brush.Color := FGrabberBgColor; + Canvas.Brush.Style := bsSolid; + if FGrabberBottomEdgeColor<>clNone then + begin + Canvas.Pen.Color := FGrabberBottomEdgeColor; + Canvas.Pen.Style := psSolid; + end + else + Canvas.Pen.Style := psClear; + + Canvas.Rectangle(Left, Top, Left+GrabberSize, Bottom); + end; + + DrawCloseButton(Left + BorderWidth + BorderWidth + 1, Top + BorderWidth + BorderWidth + 1); + if FGrabberShowLines then + begin + DrawGrabberLine(Left + BorderWidth + 3, Top + GrabberSize + BorderWidth + 1, + Left + BorderWidth + 5, Bottom + BorderWidth - 2); + DrawGrabberLine(Left + BorderWidth + 6, Top + GrabberSize + BorderWidth + 1, + Left + BorderWidth + 8, Bottom + BorderWidth - 2); + end; + + if FGrabberBottomEdgeColor<>clNone then + begin + Canvas.Pen.Color := FGrabberBottomEdgeColor; + Canvas.Pen.Style := psSolid; + Canvas.MoveTo(Left + GrabberSize, Top); + Canvas.LineTo(Left + GrabberSize, Bottom); + end; + end; + gpTop: + begin + if FGrabberBgColor <> clNone then + begin { draw only if color is given } + Canvas.Brush.Color := FGrabberBgColor; + Canvas.Brush.Style := bsSolid; + if FGrabberBottomEdgeColor <> clNone then + begin + Canvas.Pen.Color := FGrabberBottomEdgeColor; + Canvas.Pen.Style := psSolid; + end + else + Canvas.Pen.Style := psClear; + Canvas.Rectangle(Left, Top, Right, Top + GrabberSize + 2); + end; + + DrawCloseButton(Right - GrabberSize + BorderWidth + 1, Top + BorderWidth + 1); + if FGrabberShowLines then + begin + DrawGrabberLine(Left + BorderWidth + 4, Top + BorderWidth + BorderWidth + 3, + Right - GrabberSize + BorderWidth - 4, Top + BorderWidth + 5); + DrawGrabberLine(Left + BorderWidth + 4, Top + BorderWidth + BorderWidth + 6, + Right - GrabberSize + BorderWidth - 4, Top + BorderWidth + 8); + end; + + if FGrabberBottomEdgeColor <> clNone then + begin + Canvas.Pen.Color := FGrabberBottomEdgeColor; + Canvas.Pen.Style := psSolid; + Canvas.MoveTo(Left, Top + GrabberSize - 1); + Canvas.LineTo(Right, Top + GrabberSize - 1); + end; + end; + end; +end; + +procedure TJvDockTree.DrawSplitterRect(const ARect: TRect); +begin + Canvas.Brush.Color := TWinControlAccessProtected(DockSite).Color; + Canvas.FillRect(ARect); +end; + +procedure TJvDockTree.DrawZone(Zone: TJvDockZone); +begin + DrawZoneBorder(Zone); + DrawZoneGrabber(Zone); + DrawZoneSplitter(Zone); + DrawDockSiteRect; +end; + +procedure TJvDockTree.DrawZoneBorder(Zone: TJvDockZone); +begin +end; + +procedure TJvDockTree.DrawZoneGrabber(Zone: TJvDockZone); +var + ChildControl: TWinControl; + R: TRect; +begin + if Zone = nil then + Exit; + ChildControl := Zone.ChildControl; + if (ChildControl <> nil) and ChildControl.Visible and + (ChildControl.HostDockSite = DockSite) then + begin + R := GetFrameRect(ChildControl); + DrawDockGrabber(ChildControl, R); + end; +end; + +procedure TJvDockTree.DrawZoneSplitter(Zone: TJvDockZone); +var + R: TRect; +begin + R := GetSplitterRect(Zone); + if (R.Left <> 0) or (R.Right <> 0) then + DrawSplitterRect(R); +end; + +procedure TJvDockTree.PaintDockSite; +begin + ForEachAt(nil, DrawZone, tskBackward); +end; + +function TJvDockTree.HasZoneWithControl(Control: TControl): Boolean; +begin + Result := FindControlZone(Control, True) <> nil; +end; + +procedure TJvDockTree.ReplaceZoneChild(OldControl, NewControl: TControl); +var + Zone: TJvDockZone; +begin + Zone := FindControlZone(OldControl, True); + if Zone <> nil then + begin + Zone.ChildControl := TWinControl(NewControl); + UpdateAll; + end; +end; + +procedure TJvDockTree.DoHideZoneChild(AZone: TJvDockZone); +var + AForm: TCustomForm; +begin + if (AZone <> nil) and (AZone.ChildControl <> nil) then + if AZone.ChildControl.InheritsFrom(TCustomForm) then + begin + AForm := TCustomForm(AZone.ChildControl); + AForm.Close; + end + else + AZone.ChildControl.Visible := False; +end; + +procedure TJvDockTree.DockStyleChanged(Sender: TObject); +begin + BeginUpdate; + try + SyncWithStyle; + finally + EndUpdate; + end; +end; + +procedure TJvDockTree.SyncWithStyle; +begin + GrabberSize := DockStyle.ConjoinServerOption.GrabbersSize; + SplitterWidth := DockStyle.ConjoinServerOption.SplitterWidth; +end; + +function TJvDockTree.GetDockStyle: TJvDockObservableStyle; +begin + Result := FStyleLink.DockStyle; +end; + +procedure TJvDockTree.AfterConstruction; +begin + inherited AfterConstruction; + FStyleLink.StyleChanged; +end; + +//=== { TJvDockAdvZone } ===================================================== + +constructor TJvDockAdvZone.Create(ATree: TJvDockTree); +begin + inherited Create(ATree); + FCloseBtnDown := False; + FMouseDown := False; +end; + +destructor TJvDockAdvZone.Destroy; +begin + if Self = TJvDockAdvTree(Tree).CloseButtonZone then + TJvDockAdvTree(Tree).CloseButtonZone := nil; + inherited Destroy; +end; + +procedure TJvDockAdvZone.Insert(DockSize: Integer; Hide: Boolean); +begin + InsertOrRemove(DockSize, True, Hide); +end; + +procedure TJvDockAdvZone.LButtonDblClkMethod; +begin + if JvGlobalDockClient <> nil then + JvGlobalDockClient.RestoreChild; +end; + +procedure TJvDockAdvZone.Remove(DockSize: Integer; Hide: Boolean); +begin + InsertOrRemove(DockSize, False, Hide); +end; + +// TJvDockAdvTree has been moved into its own unit because of compiler issues. +// -Wpostma. + +//=== { TJvDockObservableStyle } ============================================= + +procedure TJvDockObservableStyle.AddLink(ALink: TJvDockStyleLink); +begin + FLinks.Add(ALink); +end; + +procedure TJvDockObservableStyle.AfterConstruction; +begin + inherited AfterConstruction; + CreateServerOption; +end; + +procedure TJvDockObservableStyle.Changed; +begin + SendStyleEvent; +end; + +constructor TJvDockObservableStyle.Create(AOwner: TComponent); +begin + inherited Create(AOwner); + + FConjoinServerOptionClass := TJvDockBasicConjoinServerOption; + FTabServerOptionClass := TJvDockBasicTabServerOption; + FLinks := TList.Create; +end; + +procedure TJvDockObservableStyle.CreateServerOption; +begin + if FConjoinServerOption = nil then + FConjoinServerOption := ConjoinServerOptionClass.Create(Self); + if FTabServerOption = nil then + FTabServerOption := TabServerOptionClass.Create(Self); +end; + +destructor TJvDockObservableStyle.Destroy; +begin + FreeServerOption; + while FLinks.Count > 0 do + TJvDockStyleLink(FLinks[0]).DockStyle := nil; + FreeAndNil(FLinks); + inherited Destroy; +end; + +procedure TJvDockObservableStyle.FreeServerOption; +begin + FConjoinServerOption.Free; + FConjoinServerOption := nil; + FTabServerOption.Free; + FTabServerOption := nil; +end; + +procedure TJvDockObservableStyle.RemoveLink(ALink: TJvDockStyleLink); +begin + FLinks.Remove(ALink); +end; + +procedure TJvDockObservableStyle.SendStyleEvent; +var + I: Integer; +begin + for I := 0 to FLinks.Count - 1 do + TJvDockStyleLink(FLinks[I]).StyleChanged; +end; + +procedure TJvDockObservableStyle.SetConjoinServerOption( + Value: TJvDockBasicConjoinServerOption); +begin + FConjoinServerOption.Assign(Value); +end; + +procedure TJvDockObservableStyle.SetTabServerOption( + Value: TJvDockBasicTabServerOption); +begin + FTabServerOption.Assign(Value); +end; + +//=== { TJvDockBasicConjoinServerOption } ==================================== + +constructor TJvDockBasicConjoinServerOption.Create(ADockStyle: TJvDockObservableStyle); +begin + inherited Create(ADockStyle); + FGrabbersSize := 12; + FSplitterWidth := 4; +end; + +procedure TJvDockBasicConjoinServerOption.Assign(Source: TPersistent); +begin + if Source is TJvDockBasicConjoinServerOption then + begin + BeginUpdate; + try + GrabbersSize := TJvDockBasicConjoinServerOption(Source).FGrabbersSize; + SplitterWidth := TJvDockBasicConjoinServerOption(Source).FSplitterWidth; + finally + EndUpdate; + end; + end + else + inherited Assign(Source); +end; + +procedure TJvDockBasicConjoinServerOption.SetDockSplitterWidth(const Value: TJvDockSplitterWidth); +begin + if FSplitterWidth <> Value then + begin + FSplitterWidth := Value; + Changed; + end; +end; + +procedure TJvDockBasicConjoinServerOption.SetGrabbersSize(const Value: TJvDockGrabbersSize); +begin + if FGrabbersSize <> Value then + begin + FGrabbersSize := Value; + Changed; + end; +end; + +//=== { TJvDockBasicServerOption } =========================================== + +constructor TJvDockBasicServerOption.Create(ADockStyle: TJvDockObservableStyle); +begin + // (rom) added inherited Create + inherited Create; + FDockStyle := ADockStyle; +end; + +procedure TJvDockBasicServerOption.Assign(Source: TPersistent); +begin + if Source is TJvDockBasicServerOption then + begin + // TODO + end + else + inherited Assign(Source); +end; + +procedure TJvDockBasicServerOption.BeginUpdate; +begin + Inc(FUpdateCount); +end; + +procedure TJvDockBasicServerOption.Changed; +begin + if FUpdateCount = 0 then + begin + FIsChanged := False; + DockStyle.Changed; + end + else + FIsChanged := True; +end; + +procedure TJvDockBasicServerOption.EndUpdate; +begin + Dec(FUpdateCount); + if (FUpdateCount = 0) and FIsChanged then + Changed; +end; + +//=== { TJvDockBasicTabServerOption } ======================================== + +constructor TJvDockBasicTabServerOption.Create(ADockStyle: TJvDockObservableStyle); +begin + inherited Create(ADockStyle); + FHotTrack := False; + FTabPosition := tpTop; +end; + +procedure TJvDockBasicTabServerOption.Assign(Source: TPersistent); +begin + if Source is TJvDockBasicTabServerOption then + begin + BeginUpdate; + try + TabPosition := TJvDockBasicTabServerOption(Source).TabPosition; + HotTrack := TJvDockBasicTabServerOption(Source).HotTrack; + finally + EndUpdate; + end; + end + else + inherited Assign(Source); +end; + +procedure TJvDockBasicTabServerOption.SetHotTrack(const Value: Boolean); +begin + if FHotTrack <> Value then + begin + FHotTrack := Value; + Changed; + end; +end; + +procedure TJvDockBasicTabServerOption.SetTabPosition(const Value: TTabPosition); +begin + if FTabPosition <> Value then + begin + FTabPosition := Value; + Changed; + end; +end; + +//=== { TJvDockStyleLink } =================================================== + +destructor TJvDockStyleLink.Destroy; +begin + DockStyle := nil; + inherited Destroy; +end; + +procedure TJvDockStyleLink.SetDockStyle(ADockStyle: TJvDockObservableStyle); +begin + if ADockStyle <> FDockStyle then + begin + if FDockStyle <> nil then + FDockStyle.RemoveLink(Self); + FDockStyle := ADockStyle; + if FDockStyle <> nil then + begin + FDockStyle.AddLink(Self); + StyleChanged; + + { Note: Most controls that use the style link, set the DockStyle property + in the contructor. This will trigger an OnStyleChanged event, upon which + the control will sync with the DockStyle. This may be a problem if the + control is overriden: + + for example in the TJvDockTree case: + + (1) TJvDockVSNETTree.Create, inherited Create is called, thus: + TJvDockVIDTree.Create, inherited Create is called, thus: + TJvDockAdvTree.Create, inherited Create is called, thus: + TJvDockTree.Create, properties are set to default + (2) TJvDockTree.FStyleLink.DockStyle is set thus + TJvDockVIDTree.SyncWithStyle is called; properties are set + TJvDockTree.SyncStyle is called; properties are set + (3) TJvDockAdvTree.Create continues, properties are set to default + TJvDockVIDTree.Create continues, properties are set to default + TJvDockVSNETTree.Create continues, properties are set to default + + Thus /after/ the SyncWithStyle call the values that are set to the + TJvDock**ConjoinServerOption values are overwritten with the values in + the ancestor Tree constructors. + + In most cases this is solved by using AfterConstruction, thus + + (1) TJvDockVSNETTree.Create, inherited Create is called, thus: + TJvDockVIDTree.Create, inherited Create is called, thus: + TJvDockAdvTree.Create, inherited Create is called, thus: + TJvDockTree.Create, properties are set to default + (3) TJvDockAdvTree.Create continues, properties are set to default + TJvDockVIDTree.Create continues, properties are set to default + TJvDockVSNETTree.Create continues, properties are set to default + TJvDockTree.AfterConstruction is called thus: + (2) TJvDockTree.FStyleLink.StyleChanged is called thus: + TJvDockVIDTree.SyncWithStyle is called; properties are set + TJvDockTree.SyncStyle is called; properties are set + } + end; + end; +end; + +procedure TJvDockStyleLink.StyleChanged; +begin + if Assigned(FDockStyle) and Assigned(FOnStyleChanged) then + FOnStyleChanged(Self); +end; + +{$IFDEF USEJVCL} +{$IFDEF UNITVERSIONING} +initialization + RegisterUnitVersion(HInstance, UnitVersioning); + +finalization + UnregisterUnitVersion(HInstance); +{$ENDIF UNITVERSIONING} +{$ENDIF USEJVCL} + +end. + diff --git a/JvDockVIDStyle.pas b/JvDockVIDStyle.pas new file mode 100644 index 000000000..d152a0bb6 --- /dev/null +++ b/JvDockVIDStyle.pas @@ -0,0 +1,4853 @@ +{----------------------------------------------------------------------------- +The contents of this file are subject to the Mozilla Public License +Version 1.1 (the "License"); you may not use this file except in compliance +with the License. You may obtain a copy of the License at +http://www.mozilla.org/MPL/MPL-1.1.html + +Software distributed under the License is distributed on an "AS IS" basis, +WITHOUT WARRANTY OF ANY KIND, either expressed or implied. See the License for +the specific language governing rights and limitations under the License. + +The Original Code is: JvDockVIDStyle.pas, released on 2003-12-31. + +The Initial Developer of the Original Code is luxiaoban. +Portions created by luxiaoban are Copyright (C) 2002,2003 luxiaoban. +All Rights Reserved. + +Contributor(s): + +You may retrieve the latest version of this file at the Project JEDI's JVCL home page, +located at http://jvcl.sourceforge.net + +Known Issues: +-----------------------------------------------------------------------------} +// $Id: JvDockVIDStyle.pas 11274 2007-04-24 19:09:06Z remkobonte $ + +unit JvDockVIDStyle; + +{$I jvcl.inc} + +interface + +uses + {$IFDEF USEJVCL} + {$IFDEF UNITVERSIONING} + JclUnitVersioning, + {$ENDIF UNITVERSIONING} + {$ENDIF USEJVCL} + Windows, Messages, Classes, Graphics, Controls, ComCtrls, ImgList, + JvDockControlForm, JvDockSupportControl, JvDockTree, JvDockAdvTree, + JvDockGlobals; + +type + TJvDockVIDConjoinServerOption = class(TJvDockBasicConjoinServerOption) + private + FTextEllipsis: Boolean; + FTextAlignment: TAlignment; + FInactiveTitleEndColor: TColor; + FInactiveTitleStartColor: TColor; + FInactiveTitleVerticalGradient: Boolean; + FActiveTitleEndColor: TColor; + FActiveTitleStartColor: TColor; + FActiveTitleVerticalGradient: Boolean; + FActiveDockGrabber: Boolean; + FSystemInfo: Boolean; + FActiveFont: TFont; + FInactiveFont: TFont; + procedure SetActiveTitleEndColor(const Value: TColor); + procedure SetActiveTitleStartColor(const Value: TColor); + procedure SetInactiveTitleEndColor(const Value: TColor); + procedure SetInactiveTitleStartColor(const Value: TColor); + procedure SetTextAlignment(const Value: TAlignment); + procedure SetTextEllipsis(const Value: Boolean); + procedure SetSystemInfo(const Value: Boolean); + procedure SetActiveFont(Value: TFont); + procedure SetInactiveFont(Value: TFont); + procedure SetActiveTitleVerticalGradient(const Value: Boolean); + procedure SetInactiveTitleVerticalGradient(const Value: Boolean); + procedure SetActiveDockGrabber(const Value: Boolean); + protected + procedure FontChanged(Sender: TObject); + function IsNotSystemInfo: Boolean; + procedure SettingChange(Sender: TObject); + procedure Changed; override; + procedure UpdateDefaultSystemCaptionInfo; virtual; + procedure SetDefaultSystemCaptionInfo; + public + constructor Create(ADockStyle: TJvDockObservableStyle); override; + destructor Destroy; override; + procedure Assign(Source: TPersistent); override; + published + property ActiveFont: TFont read FActiveFont write SetActiveFont stored IsNotSystemInfo; + property InactiveFont: TFont read FInactiveFont write SetInactiveFont stored IsNotSystemInfo; + property TextAlignment: TAlignment read FTextAlignment write SetTextAlignment default taLeftJustify; + property ActiveTitleStartColor: TColor read FActiveTitleStartColor write SetActiveTitleStartColor stored + IsNotSystemInfo; + property ActiveTitleEndColor: TColor read FActiveTitleEndColor write SetActiveTitleEndColor stored + IsNotSystemInfo; + property ActiveTitleVerticalGradient: Boolean read FActiveTitleVerticalGradient write + SetActiveTitleVerticalGradient default False; + property ActiveDockGrabber: Boolean read FActiveDockGrabber write SetActiveDockGrabber default False; + property InactiveTitleStartColor: TColor read FInactiveTitleStartColor write SetInactiveTitleStartColor stored + IsNotSystemInfo; + property InactiveTitleEndColor: TColor read FInactiveTitleEndColor write SetInactiveTitleEndColor stored + IsNotSystemInfo; + property InactiveTitleVerticalGradient: Boolean read FInactiveTitleVerticalGradient write + SetInactiveTitleVerticalGradient default False; + property TextEllipsis: Boolean read FTextEllipsis write SetTextEllipsis default True; + property SystemInfo: Boolean read FSystemInfo write SetSystemInfo default True; + property GrabbersSize default VIDDefaultDockGrabbersSize; + property SplitterWidth default VIDDefaultDockSplitterWidth; + end; + + TJvDockVIDTabServerOption = class(TJvDockBasicTabServerOption) + private + FActiveFont: TFont; + FActiveSheetColor: TColor; + FHotTrackColor: TColor; + FInactiveFont: TFont; + FInactiveSheetColor: TColor; + FShowTabImages: Boolean; + { NEW! if true, shows invididual close buttons on tabs. If false, you get the old VID behaviour. } + FShowCloseButtonOnTabs: Boolean; + {NEW! default is true, which is the old VID Style behaviour. False is a new behaviour added by Warren. } + FShowCloseButtonOnGrabber: Boolean; + procedure SetActiveFont(Value: TFont); + procedure SetActiveSheetColor(const Value: TColor); + procedure SetHotTrackColor(const Value: TColor); + procedure SetInactiveFont(Value: TFont); + procedure SetInactiveSheetColor(const Value: TColor); + procedure SetShowTabImages(const Value: Boolean); + procedure SetShowCloseButtonOnGrabber(const Value: Boolean); + procedure SetShowCloseButtonOnTabs(const Value: Boolean); + protected + procedure FontChanged(Sender: TObject); + public + constructor Create(ADockStyle: TJvDockObservableStyle); override; + destructor Destroy; override; + procedure Assign(Source: TPersistent); override; + procedure SetTabPosition(const Value: TTabPosition); override; + published + property ActiveSheetColor: TColor read FActiveSheetColor write SetActiveSheetColor default clBtnFace; + property InactiveSheetColor: TColor read FInactiveSheetColor write SetInactiveSheetColor default clBtnShadow; + property ActiveFont: TFont read FActiveFont write SetActiveFont; + property InactiveFont: TFont read FInactiveFont write SetInactiveFont; + property HotTrackColor: TColor read FHotTrackColor write SetHotTrackColor default clBlue; + property ShowTabImages: Boolean read FShowTabImages write SetShowTabImages default False; + property TabPosition default tpBottom; + { NEW! If true, shows invididual close buttons on tabs. + If false, you get the old VID behaviour. } + property ShowCloseButtonOnTabs: Boolean read FShowCloseButtonOnTabs write SetShowCloseButtonOnTabs; + {NEW! Default is true, which is the old VID Style behaviour. + False is a new behaviour added by Warren. } + property ShowCloseButtonOnGrabber: Boolean read FShowCloseButtonOnGrabber write + SetShowCloseButtonOnGrabber default True; + end; + + TJvDockSystemInfoChange = procedure(Value: Boolean) of object; + + TJvDockVIDStyle = class(TJvDockAdvStyle) + private + FAlwaysShowGrabber: Boolean; + FSystemInfoChange: TJvDockSystemInfoChange; + procedure SetAlwaysShowGrabber(const Value: Boolean); + protected + function DockClientWindowProc(DockClient: TJvDockClient; var Msg: TMessage): Boolean; override; + procedure FormDockDrop(DockClient: TJvDockClient; + Source: TJvDockDragDockObject; X, Y: Integer); override; + procedure FormGetSiteInfo(Source: TJvDockDragDockObject; DockClient: TJvDockClient; + Client: TControl; var InfluenceRect: TRect; MousePos: TPoint; + var CanDock: Boolean); override; + procedure FormDockOver(DockClient: TJvDockClient; Source: TJvDockDragDockObject; X, Y: Integer; + State: TDragState; var Accept: Boolean); override; + procedure FormStartDock(DockClient: TJvDockClient; + var Source: TJvDockDragDockObject); override; + procedure FormGetDockEdge(DockClient: TJvDockClient; Source: TJvDockDragDockObject; + MousePos: TPoint; var DropAlign: TAlign); override; + + procedure DoSystemInfoChange(Value: Boolean); + public + constructor Create(AOwner: TComponent); override; + {$IFNDEF USEJVCL} + function GetControlName: string; override; + {$ENDIF !USEJVCL} + procedure SetDockBaseControl(IsCreate: Boolean; DockBaseControl: TJvDockBaseControl); override; + published + property AlwaysShowGrabber: Boolean read FAlwaysShowGrabber write SetAlwaysShowGrabber; {NEW} + property SystemInfoChange: TJvDockSystemInfoChange read FSystemInfoChange write FSystemInfoChange; + property ConjoinServerOption; + property TabServerOption; + end; + + TJvDockVIDSplitter = class(TJvDockSplitter); + + TJvDockVIDPanel = class(TJvDockAdvPanel) + protected + procedure CustomGetSiteInfo(Source: TJvDockDragDockObject; + Client: TControl; var InfluenceRect: TRect; MousePos: TPoint; + var CanDock: Boolean); override; + procedure CustomStartDock(var Source: TJvDockDragDockObject); override; + procedure CustomDockDrop(Source: TJvDockDragDockObject; X, Y: Integer); override; + procedure CustomDockOver(Source: TJvDockDragDockObject; X, Y: Integer; + State: TDragState; var Accept: Boolean); override; + procedure CustomGetDockEdge(Source: TJvDockDragDockObject; MousePos: TPoint; + var DropAlign: TAlign); override; + public + procedure DockDrop(Source: TDragDockObject; X, Y: Integer); override; + procedure UpdateCaption(Exclude: TControl); override; + end; + + TJvDockVIDConjoinPanel = class(TJvDockAdvConjoinPanel) + protected + procedure CustomGetSiteInfo(Source: TJvDockDragDockObject; + Client: TControl; var InfluenceRect: TRect; MousePos: TPoint; + var CanDock: Boolean); override; + procedure CustomDockOver(Source: TJvDockDragDockObject; X, Y: Integer; + State: TDragState; var Accept: Boolean); override; + procedure CustomGetDockEdge(Source: TJvDockDragDockObject; MousePos: TPoint; var DropAlign: TAlign); override; + function CustomUnDock(Source: TJvDockDragDockObject; NewTarget: TWinControl; Client: TControl): Boolean; override; + procedure CustomDockDrop(Source: TJvDockDragDockObject; X, Y: Integer); override; + public + procedure UpdateCaption(Exclude: TControl); override; + procedure DockDrop(Source: TDragDockObject; X, Y: Integer); override; + end; + + TJvDockVIDZone = class(TJvDockAdvZone) + protected + function GetSplitterLimit(IsMin: Boolean): Integer; override; + public + destructor Destroy; override; + procedure Insert(DockSize: Integer; Hide: Boolean); override; + procedure Remove(DockSize: Integer; Hide: Boolean); override; + end; + + TJvDockVIDTree = class(TJvDockAdvTree) + private + FDropOnZone: TJvDockZone; + FLockDropDockSizeCount: Integer; + FCaptionLeftOffset: Integer; + FCaptionRightOffset: Integer; + FShowCloseButtonOnGrabber: Boolean; + FAlwaysShowGrabber: Boolean; + procedure LockDropDockSize; + procedure UnlockDropDockSize; + procedure SetCaptionLeftOffset(const Value: Integer); + procedure SetCaptionRightOffset(const Value: Integer); + procedure SetShowCloseButtonOnGrabber(const Value: Boolean); + procedure SetAlwaysShowGrabber(const Value: Boolean); + procedure InvalidateDockSite(const Client: TControl); + protected + procedure InsertControlFromConjoinHost(Control: TControl; + InsertAt: TAlign; DropCtl: TControl); virtual; + procedure IgnoreZoneInfor(Stream: TMemoryStream); virtual; + + { [ERROR] Method 'AdjustDockRect' not found in base class. + if you get this error here, it is a Delphi compiler issue. } + + procedure AdjustDockRect(Control: TControl; var ARect: TRect); override; + procedure WindowProc(var Msg: TMessage); override; + procedure SplitterMouseUp; override; + function GetTopGrabbersHTFlag(const MousePos: TPoint; + out HTFlag: Integer; Zone: TJvDockZone): TJvDockZone; override; + function GetDockGrabbersPosition: TJvDockGrabbersPosition; override; + procedure GetSiteInfo(Client: TControl; + var InfluenceRect: TRect; MousePos: TPoint; var CanDock: Boolean); override; + procedure InsertControl(Control: TControl; InsertAt: TAlign; + DropCtl: TControl); override; + procedure InsertSibling(NewZone, SiblingZone: TJvDockZone; + InsertLast, Update: Boolean); override; + procedure InsertNewParent(NewZone, SiblingZone: TJvDockZone; + ParentOrientation: TDockOrientation; InsertLast, Update: Boolean); override; + procedure DrawDockGrabber(Control: TWinControl; const ARect: TRect); override; + procedure DrawSplitterRect(const ARect: TRect); override; + procedure PaintDockGrabberRect(Canvas: TCanvas; Control: TWinControl; + const ARect: TRect; PaintAlways: Boolean = False); virtual; + procedure DrawCloseButton(Canvas: TCanvas; Zone: TJvDockZone; + Left, Top: Integer); virtual; + procedure ResetBounds(Force: Boolean); override; + procedure DrawDockSiteRect; override; + procedure PositionDockRect(Client, DropCtl: TControl; DropAlign: TAlign; + var DockRect: TRect); override; + function GetDockEdge(DockRect: TRect; MousePos: TPoint; + var DropAlign: TAlign; Control: TControl): TControl; override; + procedure RemoveZone(Zone: TJvDockZone; Hide: Boolean = True); override; + procedure GetCaptionRect(var Rect: TRect); override; + procedure SyncWithStyle; override; + property CaptionLeftOffset: Integer read FCaptionLeftOffset write SetCaptionLeftOffset; + property CaptionRightOffset: Integer read FCaptionRightOffset write SetCaptionRightOffset; + public + constructor Create(DockSite: TWinControl; DockZoneClass: TJvDockZoneClass; + ADockStyle: TJvDockObservableStyle); override; + property ShowCloseButtonOnGrabber: Boolean read FShowCloseButtonOnGrabber write SetShowCloseButtonOnGrabber; + property AlwaysShowGrabber: Boolean read FAlwaysShowGrabber write SetAlwaysShowGrabber; + end; + + TJvDockVIDTabPageControl = class; + + TJvDockVIDTabSheet = class(TJvDockTabSheet) + private + FTabWidth: Integer; + FShowTabWidth: Integer; + FIsSourceDockClient: Boolean; + procedure SetTabWidth(const Value: Integer); + procedure WMSetText(var Msg: TMessage); message WM_SETTEXT; + procedure SetSheetSort(const CaptionStr: string); + protected + procedure SetPageControl(APageControl: TJvDockPageControl); override; + property TabWidth: Integer read FTabWidth write SetTabWidth; + property ShowTabWidth: Integer read FShowTabWidth; + procedure Loaded; override; + procedure UpdateTabShowing; override; + public + constructor Create(AOwner: TComponent); override; + destructor Destroy; override; + published + property BorderWidth; + property Caption; + property DragMode; + property Enabled; + property Font; + property Height stored False; + property Highlighted; + property ImageIndex; + property Left stored False; + property Constraints; + property PageIndex; + property ParentFont; + property ParentShowHint; + property PopupMenu; + property ShowHint; + property TabVisible; + property Top stored False; + property Visible stored False; + property Width stored False; + property OnContextPopup; + property OnDragDrop; + property OnDragOver; + property OnEndDrag; + property OnEnter; + property OnExit; + property OnHide; + property OnMouseDown; + property OnMouseMove; + property OnMouseUp; + property OnResize; + property OnShow; + property OnStartDrag; + end; + + TJvDockTabPanel = class(TCustomControl) + private + FDockPanel: TJvDockPanel; // If docked to a dock panel, this is it. nil is floating. + FPage: TJvDockVIDTabPageControl; + FActiveSheetColor: TColor; + FHotTrackColor: TColor; + FActiveFont: TFont; + FInactiveFont: TFont; + FTabLeftOffset: Integer; + FTabRightOffset: Integer; + FTabTopOffset: Integer; + FTabBottomOffset: Integer; + FCaptionLeftOffset: Integer; + FCaptionRightOffset: Integer; + FCaptionTopOffset: Integer; + FTabSplitterWidth: Integer; + FTabHeight: Integer; + FSortList: TList; + FSelectSheet: TJvDockVIDTabSheet; + FTempPages: TList; + FSelectHotIndex: Integer; + FShowTabImages: Boolean; + procedure SetPage(const Value: TJvDockVIDTabPageControl); + function GetTotalTabWidth: Integer; + procedure SetTotalTabWidth(const Value: Integer); + function GetMinTabWidth: TJvDockTabSheet; + function GetMaxTabWidth: TJvDockTabSheet; + procedure SetTabBottomOffset(const Value: Integer); + procedure SetTabLeftOffset(const Value: Integer); + procedure SetTabRightOffset(const Value: Integer); + procedure SetTabTopOffset(const Value: Integer); + procedure SetCaptionLeftOffset(const Value: Integer); + procedure SetCaptionRightOffset(const Value: Integer); + procedure SetCaptionTopOffset(const Value: Integer); + procedure SetTabSplitterWidth(const Value: Integer); + function GetSorts(Index: Integer): TJvDockVIDTabSheet; + function GetPanelHeight: Integer; + function GetPanelWidth: Integer; + procedure SetPanelHeight(const Value: Integer); + function FindSheetWithPos(cX, cY, cTopOffset, cBottomOffset: Integer): Integer; + function GetDockClientFromPageIndex(Index: Integer): TControl; + procedure CMMouseLeave(var Msg: TMessage); message CM_MOUSELEAVE; + procedure SetShowTabImages(const Value: Boolean); + procedure SetTabHeight(const Value: Integer); + protected + procedure Paint; override; + procedure MouseDown(Button: TMouseButton; Shift: TShiftState; + X, Y: Integer); override; + procedure MouseMove(Shift: TShiftState; X, Y: Integer); override; + procedure MouseUp(Button: TMouseButton; Shift: TShiftState; + X, Y: Integer); override; + function GetPageIndexFromMousePos(X, Y: Integer): Integer; virtual; + procedure SetShowTabWidth; + property TotalTabWidth: Integer read GetTotalTabWidth write SetTotalTabWidth; + property MinTabWidth: TJvDockTabSheet read GetMinTabWidth; + property MaxTabWidth: TJvDockTabSheet read GetMaxTabWidth; + property TabLeftOffset: Integer read FTabLeftOffset write SetTabLeftOffset default 5; + property TabRightOffset: Integer read FTabRightOffset write SetTabRightOffset default 5; + property TabTopOffset: Integer read FTabTopOffset write SetTabTopOffset default 2; + property TabBottomOffset: Integer read FTabBottomOffset write SetTabBottomOffset default 3; + property TabSplitterWidth: Integer read FTabSplitterWidth write SetTabSplitterWidth default 2; + property CaptionTopOffset: Integer read FCaptionTopOffset write SetCaptionTopOffset default 0; + property CaptionLeftOffset: Integer read FCaptionLeftOffset write SetCaptionLeftOffset default 5; + property CaptionRightOffset: Integer read FCaptionRightOffset write SetCaptionRightOffset default 5; + property Sorts[Index: Integer]: TJvDockVIDTabSheet read GetSorts; + property PanelHeight: Integer read GetPanelHeight write SetPanelHeight; + property PanelWidth: Integer read GetPanelWidth; + property TabHeight: Integer read FTabHeight write SetTabHeight; + public + constructor Create(AOwner: TComponent); override; + destructor Destroy; override; + procedure Resize; override; + procedure DeleteSorts(Sheet: TJvDockVIDTabSheet); + property Page: TJvDockVIDTabPageControl read FPage write SetPage; + property SelectSheet: TJvDockVIDTabSheet read FSelectSheet write FSelectSheet; + property ShowTabImages: Boolean read FShowTabImages write SetShowTabImages; + {NEW! If docked to a TJvDockPanel, this is it. if not (nil) then it is floating.} + property DockPanel: TJvDockPanel read FDockPanel write FDockPanel; + end; + + TJvDockTabPanelClass = class of TJvDockTabPanel; + + TJvDockVIDTabPageControl = class(TJvDockAdvTabPageControl) + private + FTabPanelClass: TJvDockTabPanelClass; + FPanel: TJvDockTabPanel; + FTempSheet: TJvDockVIDTabSheet; + FTabImageList: TCustomImageList; + procedure SetActiveSheetColor(const Value: TColor); + procedure SetInactiveSheetColor(const Value: TColor); + procedure SetTabBottomOffset(const Value: Integer); + procedure SetTabLeftOffset(const Value: Integer); + procedure SetTabRightOffset(const Value: Integer); + procedure SetTabTopOffset(const Value: Integer); + procedure SetActiveFont(Value: TFont); + procedure SetInactiveFont(Value: TFont); + procedure SetHotTrackColor(const Value: TColor); + function GetTabBottomOffset: Integer; + function GetTabLeftOffset: Integer; + function GetTabRightOffset: Integer; + function GetTabTopOffset: Integer; + function GetInactiveSheetColor: TColor; + function GetActiveSheetColor: TColor; + function GetActiveFont: TFont; + function GetInactiveFont: TFont; + function GetVisibleSheetCount: Integer; + function GetHotTrackColor: TColor; + function GetShowTabImages: Boolean; + procedure SetShowTabImages(const Value: Boolean); + function GetPage(Index: Integer): TJvDockVIDTabSheet; + function GetActiveVIDPage: TJvDockVIDTabSheet; + procedure SetActiveVIDPage(const Value: TJvDockVIDTabSheet); + procedure CMDockNotification(var Msg: TCMDockNotification); message CM_DOCKNOTIFICATION; + protected + procedure AdjustClientRect(var Rect: TRect); override; + procedure CreatePanel; virtual; + procedure Change; override; + procedure DoRemoveDockClient(Client: TControl); override; + + procedure CustomDockOver(Source: TJvDockDragDockObject; X, Y: Integer; State: TDragState; + var Accept: Boolean); override; + procedure CustomGetSiteInfo(Source: TJvDockDragDockObject; Client: TControl; var InfluenceRect: TRect; + MousePos: TPoint; var CanDock: Boolean); override; + procedure CustomDockDrop(Source: TJvDockDragDockObject; X, Y: Integer); override; + procedure CustomGetDockEdge(Source: TJvDockDragDockObject; MousePos: TPoint; var DropAlign: TAlign); override; + function CustomUnDock(Source: TJvDockDragDockObject; NewTarget: TWinControl; Client: TControl): Boolean; override; + procedure DrawTab(TabIndex: Integer; const Rect: TRect; Active: Boolean); override; + procedure CreateParams(var Params: TCreateParams); override; + function GetDockClientFromMousePos(MousePos: TPoint): TControl; override; + procedure Paint; override; + procedure SetActivePage(Page: TJvDockTabSheet); override; + procedure SetTabHeight(Value: Smallint); override; + procedure SetTabPosition(Value: TTabPosition); override; + procedure CreateWnd; override; + procedure Loaded; override; + procedure SetHotTrack(Value: Boolean); override; + procedure SetImages(Value: TCustomImageList); override; + procedure SyncWithStyle; override; + property TabPanelClass: TJvDockTabPanelClass read FTabPanelClass write FTabPanelClass; + public + constructor Create(AOwner: TComponent); override; + procedure AfterConstruction; override; + property ActiveVIDPage: TJvDockVIDTabSheet read GetActiveVIDPage write SetActiveVIDPage; + destructor Destroy; override; + procedure DockDrop(Source: TDragDockObject; X, Y: Integer); override; + function DoUnDock(NewTarget: TWinControl; Client: TControl): Boolean; override; + + procedure UpdateCaption(Exclude: TControl); override; + procedure Resize; override; + property Pages[Index: Integer]: TJvDockVIDTabSheet read GetPage; + property Panel: TJvDockTabPanel read FPanel; + property TempSheet: TJvDockVIDTabSheet read FTempSheet write FTempSheet; + property VisibleSheetCount: Integer read GetVisibleSheetCount; + published + property ActiveSheetColor: TColor read GetActiveSheetColor write SetActiveSheetColor; + property InactiveSheetColor: TColor read GetInactiveSheetColor write SetInactiveSheetColor; + property TabLeftOffset: Integer read GetTabLeftOffset write SetTabLeftOffset default 5; + property TabRightOffset: Integer read GetTabRightOffset write SetTabRightOffset default 5; + property TabTopOffset: Integer read GetTabTopOffset write SetTabTopOffset default 2; + property TabBottomOffset: Integer read GetTabBottomOffset write SetTabBottomOffset default 3; + property ActiveFont: TFont read GetActiveFont write SetActiveFont; + property InactiveFont: TFont read GetInactiveFont write SetInactiveFont; + property HotTrackColor: TColor read GetHotTrackColor write SetHotTrackColor; + property ShowTabImages: Boolean read GetShowTabImages write SetShowTabImages; + property ActivePage; + property Align; + property Anchors; + property BiDiMode; + property Constraints; + property DockSite; + property DragCursor; + property DragKind; + property DragMode; + property Enabled; + property Font; + property HotTrack; + property Images; + property MultiLine; + property OwnerDraw; + property ParentBiDiMode; + property ParentFont; + property ParentShowHint; + property PopupMenu; + property RaggedRight; + property ScrollOpposite; + property ShowHint; + property Style; + property TabHeight; + property TabIndex; + property TabOrder; + property TabPosition; + property TabStop; + property TabWidth; + property Visible; + property OnChange; + property OnChanging; + property OnContextPopup; + property OnDockDrop; + property OnDockOver; + property OnDragDrop; + property OnDragOver; + property OnDrawTab; + property OnEndDock; + property OnEndDrag; + property OnEnter; + property OnExit; + property OnGetImageIndex; + property OnGetSiteInfo; + property OnMouseDown; + property OnMouseMove; + property OnMouseUp; + property OnResize; + property OnStartDock; + property OnStartDrag; + property OnUnDock; + end; + + TJvDockVIDDragDockObject = class(TJvDockDragDockObject) + private + FOldDropAlign: TAlign; + FCurrState: TDragState; + FOldState: TDragState; + FOldTarget: Pointer; + FSourceDockClientList: TList; + FDropTabControl: TJvDockVIDTabPageControl; + FIsTabDockOver: Boolean; + FErase: Boolean; + function GetSourceDockClient(Index: Integer): TControl; + function GetSourceDockClientCount: Integer; + procedure SetOldState(const Value: TDragState); + procedure SetCurrState(const Value: TDragState); + protected +{$IFDEF DELPHI6_UP} + AlphaBlendedTab : TJvAlphaBlendedForm; +{$ENDIF DELPHI6_UP} + procedure GetBrush_PenSize_DrawRect(var ABrush: TBrush; var PenSize: Integer; + var DrawRect: TRect; Erase: Boolean); override; + procedure MouseMsg(var Msg: TMessage); override; + procedure DefaultDockImage(Erase: Boolean); override; + function CanLeave(NewTarget: TWinControl): Boolean; override; + public + constructor Create(AControl: TControl); override; + destructor Destroy; override; + function DragFindWindow(const Pos: TPoint): THandle; override; + function GetDropCtl: TControl; override; + property SourceDockClients[Index: Integer]: TControl read GetSourceDockClient; + property SourceDockClientCount: Integer read GetSourceDockClientCount; + property CurrState: TDragState read FCurrState write SetCurrState; + property OldState: TDragState read FOldState write SetOldState; + end; + +procedure PaintGradientBackground(Canvas: TCanvas; ARect: TRect; StartColor, EndColor: TColor; + Vertical: Boolean = False); + +{$IFDEF USEJVCL} +{$IFDEF UNITVERSIONING} +const + UnitVersioning: TUnitVersionInfo = ( + RCSfile: '$URL: https://jvcl.svn.sourceforge.net:443/svnroot/jvcl/trunk/jvcl/run/JvDockVIDStyle.pas $'; + Revision: '$Revision: 11274 $'; + Date: '$Date: 2007-04-24 12:09:06 -0700 (Tue, 24 Apr 2007) $'; + LogPath: 'JVCL\run' + ); +{$ENDIF UNITVERSIONING} +{$ENDIF USEJVCL} + +implementation + +uses + {$IFDEF JVCLThemesEnabled} + JvThemes, + {$ENDIF JVCLThemesEnabled} + SysUtils, Math, Forms, + JvDockSupportProc; + +type + TJvTempWinControl = class(TWinControl); + +var + gi_DockRect: TRect; + +{ (rb) Compare to PaintGradientBackground in JvDockVIDVCStyle.pas } +procedure PaintGradientBackground(Canvas: TCanvas; ARect: TRect; + StartColor, EndColor: TColor; Vertical: Boolean = False); +const + D = 256; +var + X, Y, C1, C2, R1, G1, B1, W, H: Integer; + DR, DG, DB, DH, DW: Real; + + procedure InitRGBValues(C1, C2: Integer); + begin + R1 := GetRValue(C1); + G1 := GetGValue(C1); + B1 := GetBValue(C1); + DR := (GetRValue(C2) - R1) / D; + DG := (GetGValue(C2) - G1) / D; + DB := (GetBValue(C2) - B1) / D; + end; + +begin + with Canvas do + begin + Lock; + try + Brush.Style := bsSolid; + + { !! GetRValue etc. assume that the input param is a RGB value thus + NO system color, such as clWindowText etc. } + C1 := ColorToRGB(StartColor); + C2 := ColorToRGB(EndColor); + + if C1 <> C2 then + begin + InitRGBValues(C1, C2); + + if not Vertical then + begin + DH := (ARect.Right - ARect.Left) / D; + for X := 0 to 255 do + begin + Brush.Color := RGB(R1 + Round(DR * X), G1 + Round(DG * X), + B1 + Round(DB * X)); + with ARect do + begin + if Right <= Left + Round((X + 1) * DH) then + W := Right + else + W := Left + Round((X + 1) * DH); + FillRect(Rect(Left + Round(X * DH), Top, W, Bottom)); + end; + end; + end + else + begin + DW := (ARect.Bottom - ARect.Top) / D; + for Y := 0 to 255 do + begin + Brush.Color := RGB(R1 + Round(DR * Y), G1 + Round(DG * Y), + B1 + Round(DB * Y)); + with ARect do + begin + if Bottom <= Top + Round((Y + 1) * DW) then + H := Bottom + else + H := Top + Round((Y + 1) * DW); + FillRect(Rect(Left, Top + Round(Y * DW), Right, H)); + end; + end; + end; + end + else + begin + Brush.Color := StartColor; + FillRect(ARect); + end; + finally + Unlock; + end; + end; +end; + +procedure AssignList(FromList, ToList: TList); +var + I: Integer; +begin + ToList.Clear; + for I := 0 to FromList.Count - 1 do + ToList.Add(FromList[I]); +end; + +function ComputeVIDDockingRect(Target, Control: TControl; var DockRect: TRect; MousePos: TPoint): TAlign; +var + DockTopRect: TRect; + DockLeftRect: TRect; + DockBottomRect: TRect; + DockRightRect: TRect; + DockCenterRect: TRect; + DockTabRect: TRect; +begin + Result := alNone; + if Target = nil then + Exit; + + with Target do + begin + DockLeftRect.TopLeft := Point(0, 0); + DockLeftRect.BottomRight := Point(ClientWidth div 5, ClientHeight); + + DockTopRect.TopLeft := Point(ClientWidth div 5, 0); + DockTopRect.BottomRight := Point(ClientWidth div 5 * 4, ClientHeight div 5); + + DockRightRect.TopLeft := Point(ClientWidth div 5 * 4, 0); + DockRightRect.BottomRight := Point(ClientWidth, ClientHeight); + + if Target is TJvDockCustomTabControl then + begin + DockBottomRect.TopLeft := Point(ClientWidth div 5, ClientWidth div 5 * 4); + DockBottomRect.BottomRight := Point(ClientWidth div 5 * 4, ClientHeight - JvDockGetSysCaptionHeight); + end + else + begin + DockBottomRect.TopLeft := Point(0, ClientHeight div 5 * 4); + DockBottomRect.BottomRight := Point(ClientWidth, ClientHeight); + end; + + DockCenterRect.TopLeft := Point(0, -JvDockGetSysCaptionHeight); + DockCenterRect.BottomRight := Point(ClientWidth, 0); + + if Target is TJvDockCustomTabControl then + begin + DockTabRect.TopLeft := Point(0, ClientHeight - JvDockGetSysCaptionHeight); + DockTabRect.BottomRight := Point(ClientWidth, ClientHeight); + end + else + DockTabRect := Rect(0, 0, 0, 0); + + if PtInRect(DockCenterRect, MousePos) or + PtInRect(DockTabRect, MousePos) then + begin + Result := alClient; + DockRect := DockCenterRect; + DockRect.BottomRight := Point(ClientWidth, ClientHeight); + end + else + if PtInRect(DockLeftRect, MousePos) then + begin + Result := alLeft; + DockRect := DockLeftRect; + DockRect.Right := Min(ClientWidth div 2, Control.ClientWidth); + end + else + if PtInRect(DockTopRect, MousePos) then + begin + Result := alTop; + DockRect := DockTopRect; + DockRect.Left := 0; + DockRect.Right := ClientWidth; + DockRect.Bottom := Min(ClientHeight div 2, Control.ClientHeight); + end + else + if PtInRect(DockRightRect, MousePos) then + begin + Result := alRight; + DockRect := DockRightRect; + DockRect.Left := Max(ClientWidth div 2, ClientWidth - Control.ClientWidth); + end + else + if PtInRect(DockBottomRect, MousePos) then + begin + Result := alBottom; + DockRect := DockBottomRect; + DockRect.Top := Max(ClientHeight div 2, ClientHeight - Control.ClientHeight); + end; + if Result = alNone then + Exit; + + DockRect.TopLeft := ClientToScreen(DockRect.TopLeft); + DockRect.BottomRight := ClientToScreen(DockRect.BottomRight); + end; +end; + +(* (ahuser) not used - make Delphi 5 happy +procedure SetTabControlPreview(VIDSource: TJvDockVIDDragDockObject; + TabControl: TJvDockVIDTabPageControl; + State: TDragState; DropAlign: TAlign); + +var + I: Integer; + Index: Integer; +begin + if TabControl <> nil then + begin + if DropAlign = alClient then + begin + + if TabControl.FTempSheet = nil then + begin + + for I := VIDSource.SourceDockClientCount - 1 downto 0 do + begin + + TabControl.FTempSheet := TJvDockVIDTabSheet.Create(TabControl); + TabControl.FTempSheet.PageControl := TabControl; + + TabControl.FTempSheet.Caption := TJvTempWinControl(VIDSource.SourceDockClients[I]).Caption; + Index := TabControl.FTabImageList.AddIcon(TForm(VIDSource.SourceDockClients[I]).Icon); + if Index <> -1 then + TabControl.FTempSheet.ImageIndex := Index; + + TabControl.FTempSheet.FIsSourceDockClient := True; + end; + + TabControl.ActivePage := TabControl.FTempSheet; + TabControl.Panel.SelectSheet := TabControl.FTempSheet; + + {$IFDEF COMPILER6_UP} + TabControl.Panel.FTempPages.Assign(TabControl.PageSheets); + {$ELSE} + AssignList(TabControl.PageSheets, TabControl.Panel.FTempPages); + {$ENDIF COMPILER6_UP} + + TabControl.ActivePage.Invalidate; + + end; + end; + + if ((State = dsDragLeave) or (VIDSource.DropAlign <> alClient)) and (TabControl.FTempSheet <> nil) then + begin + + for I := TabControl.PageCount - 1 downto 0 do + begin + if TJvDockVIDTabSheet(TabControl.Pages[I]).FIsSourceDockClient then + begin + + Index := TabControl.Panel.FTempPages.IndexOf(TabControl.Pages[I]); + + if Index >= 0 then + begin + TabControl.Panel.FTempPages.Delete(Index); + if TabControl.FTabImageList.Count > Index then + TabControl.FTabImageList.Delete(Index); + end; + + TabControl.Pages[I].Free; + end; + end; + + TabControl.FTempSheet := nil; + + end; + + TabControl.ParentForm.Caption := TabControl.ActivePage.Caption; + + if TabControl.ParentForm.HostDockSite is TJvDockCustomPanel then + TabControl.ParentForm.HostDockSite.Invalidate; + end; +end; +*) + +//=== { TJvDockVIDStyle } ==================================================== + +constructor TJvDockVIDStyle.Create(AOwner: TComponent); +begin + inherited Create(AOwner); + DockPanelClass := TJvDockVIDPanel; + DockSplitterClass := TJvDockVIDSplitter; + ConjoinPanelClass := TJvDockVIDConjoinPanel; + TabDockClass := TJvDockVIDTabPageControl; + DockPanelTreeClass := TJvDockVIDTree; + DockPanelZoneClass := TJvDockVIDZone; + ConjoinPanelTreeClass := TJvDockVIDTree; + ConjoinPanelZoneClass := TJvDockVIDZone; + ConjoinServerOptionClass := TJvDockVIDConjoinServerOption; + TabServerOptionClass := TJvDockVIDTabServerOption; +end; + +procedure TJvDockVIDStyle.FormDockOver(DockClient: TJvDockClient; Source: TJvDockDragDockObject; X, Y: Integer; + State: TDragState; var Accept: Boolean); +var + ARect: TRect; +begin + with DockClient do + begin + Accept := EnableDock and EachOtherDock and + IsDockable(ParentForm, Source.Control, Source.DropOnControl, Source.DropAlign); + if State = dsDragMove then + begin + Source.DropAlign := ComputeVIDDockingRect(ParentForm, Source.Control, ARect, Point(X, Y)); + if Accept and (Source.DropAlign <> alNone) then + begin + if Source.DropAlign = alClient then + Inc(ARect.Top, JvDockGetSysCaptionHeightAndBorderWidth + 1); + Source.DockRect := ARect; + end; + gi_DockRect := ARect; + end + else + if State = dsDragLeave then + Source.DropAlign := alNone; + if Source is TJvDockVIDDragDockObject then + begin + TJvDockVIDDragDockObject(Source).OldState := TJvDockVIDDragDockObject(Source).CurrState; + TJvDockVIDDragDockObject(Source).CurrState := State; + end; + end; +end; + +procedure TJvDockVIDStyle.FormGetSiteInfo(Source: TJvDockDragDockObject; DockClient: TJvDockClient; + Client: TControl; var InfluenceRect: TRect; MousePos: TPoint; + var CanDock: Boolean); +const + DefExpandoRect = 20; +var + CH_BW: Integer; + ARect: TRect; +begin + with DockClient do + begin + CanDock := IsDockable(ParentForm, Client, Source.DropOnControl, Source.DropAlign); + if CanDock then + begin + GetWindowRect(ParentForm.Handle, InfluenceRect); + if ParentForm.HostDockSite is TJvDockCustomPanel then + Dec(InfluenceRect.Top, TJvDockCustomPanel(ParentForm.HostDockSite).JvDockManager.GrabberSize); + if PtInRect(InfluenceRect, MousePos) then + begin + ARect := InfluenceRect; + InflateRect(ARect, -DefExpandoRect, -DefExpandoRect); + CH_BW := JvDockGetSysCaptionHeightAndBorderWidth; + Inc(ARect.Top, CH_BW + 1); + if PtInRect(ARect, MousePos) then + begin + InfluenceRect := Rect(0, 0, 0, 0); + CanDock := False; + end; + end; + end; + end; +end; + +procedure TJvDockVIDStyle.FormDockDrop(DockClient: TJvDockClient; + Source: TJvDockDragDockObject; X, Y: Integer); +var + ARect, DRect: TRect; + DockType: TAlign; + Host: TJvDockableForm; + APanelDock: TWinControl; + VIDSource: TJvDockVIDDragDockObject; + I: Integer; +begin + if Source is TJvDockVIDDragDockObject then + begin + TJvDockVIDDragDockObject(Source).CurrState := dsDragEnter; + TJvDockVIDDragDockObject(Source).OldState := dsDragEnter; + end; + + if IsDockable(DockClient.ParentForm, Source.Control, Source.DropOnControl, Source.DropAlign) then + begin + Host := nil; + JvDockLockWindow(nil); + try + with DockClient do + begin + DockType := ComputeVIDDockingRect(DockClient.ParentForm, Source.Control, ARect, Point(X, Y)); + if ParentForm.HostDockSite is TJvDockPanel then + begin + if DockType = alClient then + begin + if Source.Control is TJvDockTabHostForm then + begin + APanelDock := ParentForm.HostDockSite; + ARect := ParentForm.BoundsRect; + ParentForm.ManualDock(TJvDockTabHostForm(Source.Control).PageControl, nil, alClient); + TJvDockTabHostForm(Source.Control).PageControl.ActivePage.PageIndex := 0; + Source.Control.BoundsRect := ARect; + Source.Control.ManualDock(APanelDock, nil, alClient); + if ParentForm.FormStyle = fsStayOnTop then + TForm(Source.Control).FormStyle := fsStayOnTop; + end + else + begin + APanelDock := ParentForm.HostDockSite; + DRect.TopLeft := ParentForm.HostDockSite.ClientToScreen(Point(0, 0)); + Host := CreateTabHostAndDockControl(ParentForm, Source.Control); + SetDockSite(ParentForm, False); + SetDockSite(TWinControl(Source.Control), False); + Host.Top := DRect.Top; + Host.Left := DRect.Left; + Host.Visible := True; + Host.ManualDock(APanelDock, nil, alClient); + end; + end + else + begin + DRect := ParentForm.HostDockSite.BoundsRect; + Source.Control.ManualDock(ParentForm.HostDockSite, nil, DockType); + ParentForm.HostDockSite.BoundsRect := DRect; + SetDockSite(TWinControl(Source.Control), False); + end; + Exit; + end; + + if DockType = alClient then + begin + if Source.Control is TJvDockTabHostForm then + begin + APanelDock := ParentForm.HostDockSite; + ARect := ParentForm.BoundsRect; + ParentForm.ManualDock(TJvDockTabHostForm(Source.Control).PageControl, nil, alClient); + TJvDockTabHostForm(Source.Control).PageControl.ActivePage.PageIndex := 0; + Source.Control.BoundsRect := ARect; + Source.Control.ManualDock(APanelDock, nil, alClient); + if ParentForm.FormStyle = fsStayOnTop then + TForm(Source.Control).FormStyle := fsStayOnTop; + Exit; + end + else + begin + if Source is TJvDockVIDDragDockObject then + begin + VIDSource := TJvDockVIDDragDockObject(Source); + DoFloatForm(Source.Control); + FreeAllDockableForm; + for I := 0 to VIDSource.SourceDockClientCount - 1 do + begin + VIDSource.Control := VIDSource.SourceDockClients[I]; + if Host = nil then + Host := DockClient.CreateTabHostAndDockControl(DockClient.ParentForm, Source.Control) + else + Source.Control.ManualDock(TJvDockTabHostForm(Host).PageControl, nil, alClient); + end; + Host.Visible := True; + //KV + if not JvGlobalDockIsLoading and + (TJvDockTabHostForm(Host).GetActiveDockForm <> nil) and + GetParentForm(Host).Visible and + TJvDockTabHostForm(Host).GetActiveDockForm.CanFocus then + TJvDockTabHostForm(Host).GetActiveDockForm.SetFocus; + end; + end; + end + else + if DockType <> alNone then + begin + Host := CreateConjoinHostAndDockControl(ParentForm, Source.Control, DockType); + SetDockSite(ParentForm, False); + SetDockSite(TWinControl(Source.Control), False); + Host.Visible := True; + end; + + if Host <> nil then + begin + Host.LRDockWidth := Source.Control.LRDockWidth; + Host.TBDockHeight := Source.Control.TBDockHeight; + end; + end; + finally + JvDockUnLockWindow; + end; + end; +end; + +procedure TJvDockVIDStyle.SetDockBaseControl(IsCreate: Boolean; + DockBaseControl: TJvDockBaseControl); +var + ADockClient: TJvDockClient; +begin + if DockBaseControl is TJvDockClient then + begin + ADockClient := TJvDockClient(DockBaseControl); + if IsCreate then + ADockClient.DirectDrag := False; + end; +end; + +procedure TJvDockVIDStyle.FormStartDock(DockClient: TJvDockClient; + var Source: TJvDockDragDockObject); +begin + inherited FormStartDock(DockClient, Source); + Source := TJvDockVIDDragDockObject.Create(DockClient.ParentForm); +{allows DockClient.OnCheckIsDockable event to fire once before docking, to block or allow drag/drop to this site. } +// Source.DockClient := DockClient; +end; + +procedure TJvDockVIDStyle.FormGetDockEdge(DockClient: TJvDockClient; + Source: TJvDockDragDockObject; MousePos: TPoint; var DropAlign: TAlign); +var + ARect: TRect; +begin + DropAlign := ComputeVIDDockingRect(DockClient.ParentForm, Source.Control, ARect, MousePos); +end; + +function TJvDockVIDStyle.DockClientWindowProc(DockClient: TJvDockClient; + var Msg: TMessage): Boolean; +begin + Result := inherited DockClientWindowProc(DockClient, Msg); +end; + +procedure TJvDockVIDStyle.DoSystemInfoChange(Value: Boolean); +begin + if Assigned(FSystemInfoChange) then + FSystemInfoChange(Value); +end; + +procedure TJvDockVIDStyle.SetAlwaysShowGrabber(const Value: Boolean); +begin + if Value <> FAlwaysShowGrabber then + begin + FAlwaysShowGrabber := Value; + Changed; + end; +end; + +//=== { TJvDockVIDPanel } ==================================================== + +procedure TJvDockVIDPanel.CustomDockDrop(Source: TJvDockDragDockObject; X, Y: Integer); +begin + if Source.Control is TJvDockableForm then + ShowDockPanel(True, Source.Control); + if not ((Source.Control.HostDockSite <> nil) and + (Source.DropOnControl = Source.Control.HostDockSite.Parent) and + (Source.DropAlign = alClient)) then + begin + inherited CustomDockDrop(Source, X, Y); + {$IFNDEF COMPILER9_UP} + InvalidateDockHostSiteOfControl(Source.Control, False); + {$ENDIF !COMPILER9_UP} + if (Source.Control is TWinControl) and TWinControl(Source.Control).CanFocus then + TWinControl(Source.Control).SetFocus; + //KV + if (ControlCount > 0) and Assigned(Controls[0]) and (Controls[0] is TJvDockTabHostForm) then begin + with TJvDockTabHostForm(Controls[0]) do + if (GetActiveDockForm <> nil) and GetActiveDockForm.CanFocus then + GetActiveDockForm.SetFocus; + end; + end; +end; + +procedure TJvDockVIDPanel.CustomDockOver(Source: TJvDockDragDockObject; + X, Y: Integer; State: TDragState; var Accept: Boolean); +var + DropAlign: TAlign; +begin + inherited CustomDockOver(Source, X, Y, State, Accept); + if Accept and (Source is TJvDockVIDDragDockObject) then + if State = dsDragMove then + begin + DropAlign := Source.DropAlign; + JvDockManager.GetDockEdge(Source.DockRect, Source.DragPos, DropAlign, Source.Control); + end; +end; + +procedure TJvDockVIDPanel.CustomGetDockEdge(Source: TJvDockDragDockObject; + MousePos: TPoint; var DropAlign: TAlign); +begin +end; + +procedure TJvDockVIDPanel.CustomGetSiteInfo(Source: TJvDockDragDockObject; + Client: TControl; var InfluenceRect: TRect; MousePos: TPoint; + var CanDock: Boolean); +begin + if VisibleDockClientCount = 0 then + inherited CustomGetSiteInfo(Source, Client, InfluenceRect, MousePos, CanDock) + else + begin + CanDock := IsDockable(Self, Client, Source.DropOnControl, Source.DropAlign); + if CanDock then + JvDockManager.GetSiteInfo(Client, InfluenceRect, MousePos, CanDock); + end; +end; + +procedure TJvDockVIDPanel.CustomStartDock(var Source: TJvDockDragDockObject); +begin + Source := TJvDockVIDDragDockObject.Create(Self); +end; + +procedure TJvDockVIDPanel.DockDrop(Source: TDragDockObject; X, Y: Integer); +begin + inherited DockDrop(Source, X, Y); +end; + +procedure TJvDockVIDPanel.UpdateCaption(Exclude: TControl); +begin + inherited UpdateCaption(Exclude); + Invalidate; +end; + +//=== { TJvDockVIDTree } ===================================================== + +constructor TJvDockVIDTree.Create(DockSite: TWinControl; + DockZoneClass: TJvDockZoneClass; ADockStyle: TJvDockObservableStyle); +begin + inherited Create(DockSite, DockZoneClass, ADockStyle); + FDropOnZone := nil; + + ButtonHeight := 11; + ButtonWidth := 13; + LeftOffset := 4; + RightOffset := 4; + TopOffset := 4; + BottomOffset := 3; + ButtonSplitter := 2; + BorderWidth := 0; + MinSize := 20; + CaptionLeftOffset := 0; + CaptionRightOffset := 0; +end; + +function TJvDockVIDTree.GetDockGrabbersPosition: TJvDockGrabbersPosition; +begin + Result := gpTop; +end; + +function TJvDockVIDTree.GetTopGrabbersHTFlag(const MousePos: TPoint; + out HTFlag: Integer; Zone: TJvDockZone): TJvDockZone; +begin + if (MousePos.Y >= Zone.Top) and (MousePos.Y <= Zone.Top + GrabberSize) and + (MousePos.X >= Zone.Left) and (MousePos.X <= Zone.Left + Zone.Width) then + begin + Result := Zone; + with Zone.ChildControl do + begin + if PtInRect(Rect( + Left + Width - ButtonWidth - RightOffset, + Top - GrabberSize + TopOffset, + Left + Width - RightOffset, + Top - GrabberSize + TopOffset + ButtonHeight), MousePos) then + HTFlag := HTCLOSE + else + HTFlag := HTCAPTION; + end; + end + else + Result := nil; +end; + +procedure TJvDockVIDTree.InsertControl(Control: TControl; InsertAt: TAlign; + DropCtl: TControl); +var + I: Integer; + Host: TJvDockTabHostForm; + ChildCount: Integer; + VIDSource: TJvDockVIDDragDockObject; + TempControl: TControl; + ARect: TRect; + AZone: TJvDockZone; + + function CreateDockPageControl(Client: TControl): TJvDockTabHostForm; + var + Zone: TJvDockZone; + TempCtl: TControl; + TempPanel: TJvDockConjoinPanel; + DockClient: TJvDockClient; + APoint: TPoint; + begin + {$IFDEF JVDOCK_DEBUG} + OutputDebugString('TJvDockVIDTree.InsertControl.CreateDockPageControl'); + {$ENDIF JVDOCK_DEBUG} + Result := nil; + Zone := FindControlZone(DropCtl); + DockClient := FindDockClient(DropCtl); + if (DockClient <> nil) and (Zone <> nil) then + begin + TempCtl := DropCtl; + + if Zone.ParentZone.Orientation = doHorizontal then + begin + if Zone.PrevSibling = nil then + begin + if Zone.NextSibling <> nil then + DropCtl := Zone.NextSibling.ChildControl; + InsertAt := alTop; + end + else + begin + DropCtl := Zone.PrevSibling.ChildControl; + InsertAt := alBottom; + end; + end + else + if Zone.ParentZone.Orientation = doVertical then + begin + if Zone.PrevSibling = nil then + begin + if Zone.NextSibling <> nil then + DropCtl := Zone.NextSibling.ChildControl; + InsertAt := alLeft; + end + else + begin + DropCtl := Zone.PrevSibling.ChildControl; + InsertAt := alRight; + end; + end; + + if TempCtl.HostDockSite is TJvDockConjoinPanel then + TempPanel := TJvDockConjoinPanel(TempCtl.HostDockSite) + else + TempPanel := nil; + + Result := DockClient.CreateTabHostAndDockControl(TempCtl, Client); + if TempPanel <> nil then + + TempPanel.ParentForm.UnDockControl := Result; + + SetDockSite(TWinControl(TempCtl), False); + SetDockSite(TWinControl(Client), False); + + if DockSite.Align = alBottom then + APoint := Point(0, -TempCtl.TBDockHeight) + else + if DockSite.Align = alRight then + APoint := Point(-TempCtl.LRDockWidth, 0) + else + APoint := Point(0, 0); + APoint := DockSite.ClientToScreen(APoint); + Result.Left := APoint.X; + Result.Top := APoint.Y; + Result.UndockWidth := TempCtl.UndockWidth; + Result.UndockHeight := TempCtl.UndockHeight; + Result.LRDockWidth := TempCtl.LRDockWidth; + Result.TBDockHeight := TempCtl.TBDockHeight + GrabberSize; + + Result.Visible := True; + end; + end; + +begin + {$IFDEF JVDOCK_DEBUG} + OutputDebugString('TJvDockVIDTree.InsertControl'); + {$ENDIF JVDOCK_DEBUG} + if not JvGlobalDockIsLoading then + JvDockLockWindow(nil); + try + VIDSource := nil; + if Control is TJvDockableForm then + begin + if InsertAt in [alClient] then + begin + if DropCtl is TJvDockTabHostForm then + begin + try + VIDSource := TJvDockVIDDragDockObject.Create(Control); + DoFloatForm(Control); + FreeAllDockableForm; + for I := VIDSource.SourceDockClientCount - 1 downto 0 do + begin + TempControl := VIDSource.SourceDockClients[I]; + TempControl.ManualDock(TJvDockTabHostForm(DropCtl).PageControl); + if TempControl is TForm then + begin + TForm(TempControl).ActiveControl := nil; + SetDockSite(TForm(TempControl), False); + end; + end; + finally + VIDSource.Free; + JvGlobalDockManager.DragObject.Control := nil; + end; + end + else + begin + if (DockSite is TJvDockCustomPanel) and (DockSite.VisibleDockClientCount > 1) and (DropCtl <> nil) then + begin + try + VIDSource := TJvDockVIDDragDockObject.Create(Control); + DoFloatForm(Control); + FreeAllDockableForm; + + Host := CreateDockPageControl(VIDSource.SourceDockClients[0]); + if Host <> nil then + begin + for I := VIDSource.SourceDockClientCount - 1 downto 1 do + begin + TempControl := VIDSource.SourceDockClients[I]; + TempControl.ManualDock(Host.PageControl); + if TempControl is TForm then + begin + TForm(TempControl).ActiveControl := nil; + SetDockSite(TForm(TempControl), False); + end; + end; + + Host.ManualDock(DockSite, nil, InsertAt); + end; + finally + VIDSource.Free; + JvGlobalDockManager.DragObject.Control := nil; + end; + end + else + inherited InsertControl(Control, InsertAt, DropCtl); + end; + end + else + if Control is TJvDockConjoinHostForm then + begin + TJvTempWinControl(TJvDockableForm(Control).DockableControl).DockManager.ResetBounds(True); + InsertControlFromConjoinHost(Control, InsertAt, DropCtl); + end + else + inherited InsertControl(Control, InsertAt, DropCtl); + end + else + begin + if InsertAt in [alLeft, alTop] then + DropDockSize := DropDockSize + SplitterWidth div 2; + if InsertAt in [alClient] then + begin + if DropCtl is TJvDockTabHostForm then + Control.ManualDock(TJvDockTabHostForm(DropCtl).PageControl, nil, alClient) + else + if TopZone.ChildZones <> nil then + begin + ChildCount := TopZone.ChildCount; + if DropCtl <> nil then + begin + ARect := DropCtl.BoundsRect; + AZone := FindControlZone(DropCtl); + + if DropCtl.DockOrientation = doHorizontal then + begin + if ((AZone <> nil) and (AZone.ZoneLimit <> DockSite.Height)) then + ARect.Bottom := ARect.Bottom + SplitterWidth; + end + else + begin + if ((AZone <> nil) and (AZone.ZoneLimit <> DockSite.Width)) then + ARect.Right := ARect.Right + SplitterWidth; + end; + DockRect := ARect; + end + else + DockRect := Rect(0, 0, TopZone.Width, TopZone.Height); + + Host := CreateDockPageControl(Control); + if Host <> nil then + if (ChildCount >= 2) or (DockSite is TJvDockPanel) then + begin + if InsertAt in [alLeft, alRight] then + DropDockSize := DockRect.Right - DockRect.Left + else + DropDockSize := DockRect.Bottom - DockRect.Top + GrabberSize; + + LockDropDockSize; + Host.ManualDock(DockSite, DropCtl, InsertAt); + + UnlockDropDockSize; + end + else + Host.BoundsRect := DockSite.Parent.BoundsRect; + end + else + inherited InsertControl(Control, InsertAt, DropCtl); + end + else + inherited InsertControl(Control, InsertAt, DropCtl); + + { (rb) no idea what gi_DockRect should be doing, but prevent it is used + before it is set (by checking whether it is empty). Using it when the rect + is empty causes align problems } + if not IsRectEmpty(gi_DockRect) then + DockRect := gi_DockRect; + end; + ForEachAt(nil, UpdateZone); + finally + if not JvGlobalDockIsLoading then + JvDockUnLockWindow; + end; +end; + +procedure TJvDockVIDTree.InsertControlFromConjoinHost(Control: TControl; + InsertAt: TAlign; DropCtl: TControl); +const + {$IFDEF COMPILER6_UP} + OrientArray: array [TAlign] of TDockOrientation = + (doNoOrient, doHorizontal, doHorizontal, doVertical, doVertical, doNoOrient, doNoOrient); + MakeLast: array [TAlign] of Boolean = + (False, False, True, False, True, False, False); + ReverseAt: array [TAlign] of TAlign = + (alClient, alBottom, alTop, alRight, alLeft, alNone, alCustom); + {$ELSE} + OrientArray: array [TAlign] of TDockOrientation = + (doNoOrient, doHorizontal, doHorizontal, doVertical, doVertical, doNoOrient); + MakeLast: array [TAlign] of Boolean = + (False, False, True, False, True, False); + ReverseAt: array [TAlign] of TAlign = + (alClient, alBottom, alTop, alRight, alLeft, alNone); + {$ENDIF COMPILER6_UP} +var + Stream: TMemoryStream; + TopOrientation: TDockOrientation; + InsertOrientation: TDockOrientation; + CurrentOrientation: TDockOrientation; + ZoneLimit: Integer; + Level, LastLevel, I: Integer; + Zone, NextZone: TJvDockZone; + DropCtlZone, LastZone: TJvDockZone; + OffsetXYLimitArr: array [TDockOrientation] of Integer; + ControlXYLimitArr: array [TDockOrientation] of Integer; + + procedure ReadZone(SetZone: Boolean); + var + I: Integer; + begin + with Stream do + begin + Read(Level, SizeOf(Level)); + if Level = TreeStreamEndFlag then + Exit; + Zone := DockZoneClass.Create(Self); + CustomLoadZone(Stream, Zone); + ZoneLimit := Zone.ZoneLimit; + end; + if SetZone then + begin + if Level = LastLevel then + begin + Zone.NextSibling := LastZone.NextSibling; + if LastZone.NextSibling <> nil then + LastZone.NextSibling.PrevSibling := Zone; + LastZone.NextSibling := Zone; + Zone.PrevSibling := LastZone; + Zone.ParentZone := LastZone.ParentZone; + end + else + if Level > LastLevel then + begin + LastZone.ChildZones := Zone; + Zone.ParentZone := LastZone; + InsertOrientation := LastZone.Orientation; + end + else + if Level < LastLevel then + begin + NextZone := LastZone; + for I := 1 to LastLevel - Level do + NextZone := NextZone.ParentZone; + Zone.NextSibling := NextZone.NextSibling; + if NextZone.NextSibling <> nil then + NextZone.NextSibling.PrevSibling := Zone; + NextZone.NextSibling := Zone; + Zone.PrevSibling := NextZone; + Zone.ParentZone := NextZone.ParentZone; + InsertOrientation := Zone.ParentZone.Orientation; + end; + Zone.ZoneLimit := OffsetXYLimitArr[InsertOrientation] + ZoneLimit; + end; + LastLevel := Level; + LastZone := Zone; + end; + +begin + ControlXYLimitArr[doNoOrient] := 0; + ControlXYLimitArr[doHorizontal] := DockRect.Bottom - DockRect.Top; + ControlXYLimitArr[doVertical] := DockRect.Right - DockRect.Left; + + Stream := TMemoryStream.Create; + if Control is TJvDockConjoinHostForm then + TJvDockConjoinHostForm(Control).Panel.JvDockManager.SaveToStream(Stream); + Stream.Position := 0; + + BeginUpdate; + try + Stream.Read(I, SizeOf(I)); + Stream.Position := Stream.Position + 8; + Stream.Read(TopOrientation, SizeOf(TopOrientation)); + Stream.Read(ZoneLimit, SizeOf(ZoneLimit)); + IgnoreZoneInfor(Stream); + if (DropCtl = nil) and (TopZone.ChildCount = 1) then + DropCtl := TopZone.ChildZones.ChildControl; + DropCtlZone := FindControlZone(DropCtl); + if InsertAt in [alClient, alNone] then + InsertAt := alRight; + InsertOrientation := OrientArray[InsertAt]; + if TopZone.ChildCount = 0 then + begin + TopZone.Orientation := TopOrientation; + InsertOrientation := TopOrientation; + end + else + if TopZone.ChildCount = 1 then + begin + TopZone.Orientation := InsertOrientation; + case InsertOrientation of + doHorizontal: + begin + TopZone.ZoneLimit := TopZone.ChildZones.Width; + TopXYLimit := TopZone.ChildZones.Height; + end; + doVertical: + begin + TopZone.ZoneLimit := TopZone.ChildZones.Height; + TopXYLimit := TopZone.ChildZones.Width; + end; + end; + end; + + if DropCtlZone <> nil then + CurrentOrientation := DropCtlZone.ParentZone.Orientation + else + CurrentOrientation := TopZone.Orientation; + + if InsertOrientation = doHorizontal then + DropDockSize := DockRect.Bottom - DockRect.Top + else + if InsertOrientation = doVertical then + DropDockSize := DockRect.Right - DockRect.Left + else + DropDockSize := 0; + + OffsetXYLimitArr[doNoOrient] := 0; + if DropCtlZone <> nil then + begin + OffsetXYLimitArr[doHorizontal] := DropCtlZone.TopLeft[doHorizontal] + + Integer(MakeLast[InsertAt]) * (DropCtlZone.HeightWidth[doHorizontal] - ControlXYLimitArr[doHorizontal]); + if (FDropOnZone <> nil) and (InsertOrientation = doHorizontal) then + OffsetXYLimitArr[doHorizontal] := FDropOnZone.ZoneLimit - Round((FDropOnZone.ZoneLimit - + FDropOnZone.ParentZone.ChildZones.LimitBegin) * (DropDockSize + BorderWidth) / + (FDropOnZone.ParentZone.Height)); + OffsetXYLimitArr[doVertical] := DropCtlZone.TopLeft[doVertical] + + Integer(MakeLast[InsertAt]) * (DropCtlZone.HeightWidth[doVertical] - ControlXYLimitArr[doVertical]); + if (FDropOnZone <> nil) and (InsertOrientation = doVertical) then + OffsetXYLimitArr[doVertical] := FDropOnZone.ZoneLimit - Round((FDropOnZone.ZoneLimit - + FDropOnZone.ParentZone.ChildZones.LimitBegin) * (DropDockSize + BorderWidth) / + (FDropOnZone.ParentZone.Width)); + end + else + begin + if TopZone.VisibleChildCount = 0 then + begin + OffsetXYLimitArr[doHorizontal] := 0; + OffsetXYLimitArr[doVertical] := 0; + end + else + begin + OffsetXYLimitArr[doHorizontal] := Integer(MakeLast[InsertAt]) * ControlXYLimitArr[doHorizontal]; + OffsetXYLimitArr[doVertical] := Integer(MakeLast[InsertAt]) * ControlXYLimitArr[doVertical]; + end; + end; + + if TopOrientation <> InsertOrientation then + begin + LastZone := DockZoneClass.Create(Self); + if InsertOrientation <> CurrentOrientation then + InsertNewParent(LastZone, DropCtlZone, InsertOrientation, MakeLast[InsertAt], True) + else + InsertSibling(LastZone, DropCtlZone, MakeLast[InsertAt], True); + LastZone.Orientation := TopOrientation; + LastLevel := 0; + end + else + begin + LastLevel := 1; + if TopZone.ChildCount > 0 then + begin + ReadZone(False); + if InsertOrientation <> CurrentOrientation then + InsertNewParent(LastZone, DropCtlZone, InsertOrientation, MakeLast[InsertAt], True) + else + InsertSibling(LastZone, DropCtlZone, MakeLast[InsertAt], True); + LastZone.ZoneLimit := ZoneLimit + OffsetXYLimitArr[InsertOrientation]; + end + else + begin + LastLevel := 0; + LastZone := TopZone; + end; + end; + + OffsetXYLimitArr[doHorizontal] := LastZone.TopLeft[doHorizontal]; + OffsetXYLimitArr[doVertical] := LastZone.TopLeft[doVertical]; + + while True do + begin + ReadZone(True); + if Level = TreeStreamEndFlag then + Break; + end; + finally + Stream.Free; + EndUpdate; + end; + SetNewBounds(nil); +end; + +procedure TJvDockVIDTree.DrawDockGrabber(Control: TWinControl; const ARect: TRect); +const + TextAlignment: array [TAlignment] of UINT = + (DT_LEFT, DT_RIGHT, DT_CENTER); +var + Option: TJvDockVIDConjoinServerOption; + DrawRect: TRect; + uFormat: UINT; + IsActive: Boolean; +begin + Assert(Assigned(Control)); + + case GrabbersPosition of + gpTop: + with ARect do + if Assigned(DockStyle) and (DockStyle.ConjoinServerOption is TJvDockVIDConjoinServerOption) then + begin + Option := TJvDockVIDConjoinServerOption(DockStyle.ConjoinServerOption); + + IsActive := Assigned(Screen.ActiveControl) and Screen.ActiveControl.Focused and + Control.ContainsControl(Screen.ActiveControl); + DrawRect := ARect; + + Inc(DrawRect.Top, 2); + DrawRect.Bottom := DrawRect.Top + GrabberSize - 3; + if IsActive then + PaintGradientBackground(Canvas, DrawRect, Option.ActiveTitleStartColor, + Option.ActiveTitleEndColor, Option.ActiveTitleVerticalGradient) + else + PaintGradientBackground(Canvas, DrawRect, Option.InactiveTitleStartColor, + Option.InactiveTitleEndColor, Option.InactiveTitleVerticalGradient); + Canvas.Brush.Style := bsClear; // body already painted + PaintDockGrabberRect(Canvas, Control, DrawRect, Option.ActiveDockGrabber); + + if IsActive then + Canvas.Font.Assign(Option.ActiveFont) + else + Canvas.Font.Assign(Option.InactiveFont); + Canvas.Brush.Style := bsClear; + GetCaptionRect(DrawRect); + uFormat := DT_VCENTER or DT_SINGLELINE or + (Cardinal(Ord(Option.TextEllipsis)) * DT_END_ELLIPSIS) or TextAlignment[Option.TextAlignment]; + { DIRTY cast } + DrawText(Canvas.Handle, PChar(TForm(Control).Caption), -1, DrawRect, uFormat); + if ShowCloseButtonOnGrabber or not (Control is TJvDockTabHostForm) then + DrawCloseButton(Canvas, FindControlZone(Control), Right - RightOffset - ButtonWidth, Top + TopOffset); + end; + {$IFDEF JVDOCK_DEBUG} + gpBottom: + OutputDebugString('GrabbersPosition = gpBottom - Not supported'); + gpRight: + OutputDebugString('GrabbersPosition = gpRight - Not supported'); + gpLeft: + OutputDebugString('GrabbersPosition=gpLeft - Not supported'); + {$ENDIF JVDOCK_DEBUG} + end; +end; + +procedure TJvDockVIDTree.ResetBounds(Force: Boolean); +var + R: TRect; +begin + if not (csLoading in DockSite.ComponentState) and + (TopZone <> nil) and (DockSite.DockClientCount > 0) then + begin + R := DockSite.ClientRect; + if DockSite is TJvDockConjoinPanel then + begin + if R.Right = R.Left then + Inc(R.Right, DockSite.Parent.UndockWidth); + if R.Bottom = R.Top then + Inc(R.Bottom, DockSite.Parent.UndockHeight); + end; + if Force or (not CompareMem(@R, @PreviousRect, SizeOf(TRect))) then + begin + case TopZone.Orientation of + doHorizontal: + begin + if R.Right - R.Left > 0 then + TopZone.ZoneLimit := R.Right - R.Left; + if R.Bottom - R.Top > 0 then + TopXYLimit := R.Bottom - R.Top; + end; + doVertical: + begin + if R.Bottom - R.Top > 0 then + TopZone.ZoneLimit := R.Bottom - R.Top; + if R.Right - R.Left > 0 then + TopXYLimit := R.Right - R.Left; + end; + end; + if DockSite.DockClientCount > 0 then + begin + if not JvGlobalDockIsLoading then + begin + if (R.Bottom - R.Top > 0) and (PreviousRect.Bottom - PreviousRect.Top > 0) then + ScaleBy := (R.Bottom - R.Top) / (PreviousRect.Bottom - PreviousRect.Top) + else + ScaleBy := 1; + + ShiftScaleOrientation := doHorizontal; + + if (UpdateCount = 0) and (ScaleBy <> 1) then + ForEachAt(nil, ScaleZone, tskForward); + + if (R.Right - R.Left > 0) and (PreviousRect.Right - PreviousRect.Left > 0) then + ScaleBy := (R.Right - R.Left) / (PreviousRect.Right - PreviousRect.Left) + else + ScaleBy := 1; + + ShiftScaleOrientation := doVertical; + + if (UpdateCount = 0) and (ScaleBy <> 1) then + ForEachAt(nil, ScaleZone, tskForward); + end; + + SetNewBounds(nil); + if UpdateCount = 0 then + ForEachAt(nil, UpdateZone, tskForward); + + PreviousRect := R; + end; + end; + end; +end; + +procedure TJvDockVIDTree.DrawSplitterRect(const ARect: TRect); +begin + inherited DrawSplitterRect(ARect); +end; + +procedure TJvDockVIDTree.WindowProc(var Msg: TMessage); +var + Align: TAlign; +begin + if Msg.Msg = CM_DOCKNOTIFICATION then + begin + with TCMDockNotification(Msg) do + begin + if NotifyRec.ClientMsg = CM_INVALIDATEDOCKHOST then + InvalidateDockSite(TControl(NotifyRec.MsgWParam)) + else + inherited; + end; + end + else + if Msg.Msg = CM_DOCKCLIENT then + begin + { (rb) no idea what gi_DockRect should be doing, but prevent it is used + before it is set (by checking whether it is empty). Using it when the rect + is empty causes align problems } + if not IsRectEmpty(gi_DockRect) then + begin + Align := TCMDockClient(Msg).DockSource.DropAlign; + TCMDockClient(Msg).DockSource.DockRect := gi_DockRect; + GetDockEdge(gi_DockRect, TCMDockClient(Msg).DockSource.DragPos, Align, TCMDockClient(Msg).DockSource.Control); + end; + end; + inherited WindowProc(Msg); +end; + +procedure TJvDockVIDTree.SplitterMouseUp; +var + OldLimit: Integer; + Zone: TJvDockZone; +begin + Mouse.Capture := 0; + DrawSizeSplitter; + ReleaseDC(SizingWnd, SizingDC); + + OldLimit := SizingZone.ZoneLimit; + + ShiftScaleOrientation := SizingZone.ParentZone.Orientation; + if SizingZone.ParentZone.Orientation = doHorizontal then + SizingZone.ZoneLimit := SizePos.Y + (SplitterWidth div 2) + else + SizingZone.ZoneLimit := SizePos.X + (SplitterWidth div 2); + + ParentLimit := SizingZone.LimitBegin; + if OldLimit - ParentLimit > 0 then + ScaleBy := (SizingZone.ZoneLimit - ParentLimit) / (OldLimit - ParentLimit) + else + ScaleBy := 1; + + if SizingZone.ChildZones <> nil then + ForEachAt(SizingZone.ChildZones, ScaleChildZone, tskForward); + + Zone := SizingZone; + while (Zone.NextSibling <> nil) and (not Zone.NextSibling.Visibled) do + begin + Zone.NextSibling.ZoneLimit := SizingZone.ZoneLimit; + Zone := Zone.NextSibling; + end; + + if SizingZone.NextSibling <> nil then + begin + if SizingZone.NextSibling.ZoneLimit - OldLimit > 0 then + ScaleBy := (SizingZone.NextSibling.ZoneLimit - SizingZone.ZoneLimit) / (SizingZone.NextSibling.ZoneLimit - + OldLimit) + else + ScaleBy := 1; + ParentLimit := SizingZone.NextSibling.ZoneLimit; + + if SizingZone.NextSibling.ChildZones <> nil then + ForEachAt(SizingZone.NextSibling.ChildZones, ScaleSiblingZone, tskForward); + end; + + SetNewBounds(SizingZone.ParentZone); + ForEachAt(SizingZone.ParentZone, UpdateZone, tskForward); + SizingZone := nil; +end; + +procedure TJvDockVIDTree.DrawDockSiteRect; +begin +end; + +procedure TJvDockVIDTree.InsertSibling(NewZone, SiblingZone: TJvDockZone; + InsertLast, Update: Boolean); +begin + if FDropOnZone <> nil then + SiblingZone := FDropOnZone; + inherited InsertSibling(NewZone, SiblingZone, InsertLast, Update); +end; + +procedure TJvDockVIDTree.PositionDockRect(Client, DropCtl: TControl; + DropAlign: TAlign; var DockRect: TRect); +label + LBDropCtlExist; +var + VisibleClients, NewX, NewY, NewWidth, NewHeight: Integer; + Zone: TJvDockZone; + HTFlag: Integer; + MousePos: TPoint; + Scale: Double; + CtrlRect: TRect; + + procedure DockOverSplitter; + begin + NewX := Zone.ParentZone.Left; + NewY := Zone.ParentZone.Top; + NewWidth := Zone.ParentZone.Width; + NewHeight := Zone.ParentZone.Height; + case Zone.ParentZone.Orientation of + doHorizontal: + begin + Scale := (Zone.ZoneLimit - Zone.ParentZone.ChildZones.LimitBegin) / NewHeight; + NewHeight := Min(NewHeight div 2, Client.ClientHeight); + NewY := Zone.ZoneLimit - Round(NewHeight * Scale); + end; + doVertical: + begin + Scale := (Zone.ZoneLimit - Zone.ParentZone.ChildZones.LimitBegin) / NewWidth; + NewWidth := Min(NewWidth div 2, Client.ClientWidth); + NewX := Zone.ZoneLimit - Round(NewWidth * Scale); + end; + end; + DockRect := Bounds(NewX, NewY, NewWidth, NewHeight); + if Zone.Visibled then + begin + if Zone.ParentZone.Orientation = doHorizontal then + JvGlobalDockManager.DragObject.DropAlign := alBottom + else + if Zone.ParentZone.Orientation = doVertical then + JvGlobalDockManager.DragObject.DropAlign := alRight; + JvGlobalDockManager.DragObject.DropOnControl := Zone.ChildControl; + FDropOnZone := Zone; + end; + end; + +begin + if DropAlign = alNone then + DropAlign := alClient; + VisibleClients := DockSite.VisibleDockClientCount; + FDropOnZone := nil; + + if JvGlobalDockManager.DragObject <> nil then + MousePos := JvGlobalDockManager.DragObject.DragPos + else + MousePos := Client.ScreenToClient(Mouse.CursorPos); + + MapWindowPoints(0, DockSite.Handle, MousePos, 2); + Zone := InternalHitTest(MousePos, HTFlag); + if Zone <> nil then + if Zone.ChildControl <> nil then + if (HTFlag = HTCAPTION) or (HTFlag = HTCLOSE) then + begin + DockRect := Zone.ChildControl.BoundsRect; + JvGlobalDockManager.DragObject.DropAlign := alClient; + if Zone.ChildControl is TJvDockTabHostForm then + begin + if JvGlobalDockManager.DragObject is TJvDockVIDDragDockObject then + TJvDockVIDDragDockObject(JvGlobalDockManager.DragObject).FDropTabControl := + TJvDockVIDTabPageControl(TJvDockTabHostForm(Zone.ChildControl).PageControl); + end + else + begin + if JvGlobalDockManager.DragObject is TJvDockVIDDragDockObject then + TJvDockVIDDragDockObject(JvGlobalDockManager.DragObject).FDropTabControl := nil; + end; + end; + + if DropCtl = nil then + begin + if Zone <> nil then + begin + if Zone.ChildControl <> nil then + begin + if (HTFlag = HTCAPTION) or (HTFlag = HTCLOSE) then + JvGlobalDockManager.DragObject.DropOnControl := Zone.ChildControl + else + if HTFlag = HTCLIENT then + begin + DropCtl := Zone.ChildControl; + goto LBDropCtlExist; + end + else + if HTFlag = HTSPLITTER then + DockOverSplitter; + end + else + if HTFlag = HTSPLITTER then + begin + DockOverSplitter; + end + else + Exit; + end + else + begin + DockRect := Rect(0, 0, DockSite.ClientWidth, DockSite.ClientHeight); + + if VisibleClients > 0 then + with DockRect do + case DropAlign of + alLeft: + Right := Right div 2; + alRight: + Left := Right div 2; + alTop: + Bottom := Bottom div 2; + alBottom: + Top := Bottom div 2; + end; + end; + end + else + begin + + LBDropCtlExist: + Zone := FindControlZone(DropCtl); + CtrlRect := DockRect; + MapWindowPoints(0, DockSite.Handle, CtrlRect, 2); + if Zone <> nil then + begin + if Zone.ParentZone.Orientation = doVertical then + begin + if (DropAlign = alRight) and (Zone.NextSibling <> nil) then + begin + DockOverSplitter; + MapWindowPoints(DockSite.Handle, 0, DockRect, 2); + Exit; + end + else + if (DropAlign = alLeft) and (Zone.PrevSibling <> nil) then + begin + Zone := Zone.PrevSibling; + DockOverSplitter; + MapWindowPoints(DockSite.Handle, 0, DockRect, 2); + Exit; + end + else + begin + if DropAlign in [alLeft, alRight] then + CtrlRect := Bounds(Zone.ParentZone.Left, Zone.ParentZone.Top, Zone.ParentZone.Width, Zone.ParentZone.Height) + else + if DropAlign in [alTop, alBottom, alClient] then + begin + CtrlRect := DropCtl.BoundsRect; + Dec(CtrlRect.Top, GrabberSize); + end; + OffsetRect(CtrlRect, 0, GrabberSize); + end; + end + else + if Zone.ParentZone.Orientation = doHorizontal then + begin + if (DropAlign = alBottom) and (Zone.NextSibling <> nil) then + begin + DockOverSplitter; + MapWindowPoints(DockSite.Handle, 0, DockRect, 2); + Exit; + end + else + if (DropAlign = alTop) and (Zone.PrevSibling <> nil) then + begin + Zone := Zone.PrevSibling; + DockOverSplitter; + MapWindowPoints(DockSite.Handle, 0, DockRect, 2); + Exit; + end + else + begin + if DropAlign in [alTop, alBottom] then + CtrlRect := Bounds(Zone.ParentZone.Left, Zone.ParentZone.Top, Zone.ParentZone.Width, Zone.ParentZone.Height) + else + if DropAlign in [alLeft, alRight, alClient] then + begin + CtrlRect := DropCtl.BoundsRect; + Dec(CtrlRect.Top, GrabberSize); + end; + OffsetRect(CtrlRect, 0, GrabberSize); + end; + end + else + begin + CtrlRect := DropCtl.BoundsRect; + Dec(CtrlRect.Top, GrabberSize); + OffsetRect(CtrlRect, 0, GrabberSize); + end; + + NewX := CtrlRect.Left; + NewY := CtrlRect.Top - GrabberSize; + NewWidth := CtrlRect.Right - CtrlRect.Left; + NewHeight := CtrlRect.Bottom - CtrlRect.Top; + if DropAlign in [alLeft, alRight] then + NewWidth := Min(Client.UndockWidth, NewWidth div 2) + else + if DropAlign in [alTop, alBottom] then + NewHeight := Min(Client.UndockHeight, NewHeight div 2); + case DropAlign of + alRight: + Inc(NewX, CtrlRect.Right - CtrlRect.Left - NewWidth); + alBottom: + Inc(NewY, CtrlRect.Bottom - CtrlRect.Top - NewHeight); + end; + DockRect := Bounds(NewX, NewY, NewWidth, NewHeight); + if DropAlign = alClient then + DockRect := Bounds(NewX, NewY, NewWidth, NewHeight); + if DropAlign = alNone then + begin + end; + end; + end; + MapWindowPoints(DockSite.Handle, 0, DockRect, 2); +end; + +function TJvDockVIDTree.GetDockEdge(DockRect: TRect; MousePos: TPoint; + var DropAlign: TAlign; Control: TControl): TControl; +begin + Result := inherited GetDockEdge(DockRect, MousePos, DropAlign, Control); + if FLockDropDockSizeCount = 0 then + begin + if DropAlign in [alLeft, alRight] then + DropDockSize := DockRect.Right - DockRect.Left + else + if DropAlign in [alTop, alBottom] then + DropDockSize := DockRect.Bottom - DockRect.Top + else + DropDockSize := 0; + Self.DockRect := DockRect; + end; +end; + +procedure TJvDockVIDTree.InsertNewParent(NewZone, SiblingZone: TJvDockZone; + ParentOrientation: TDockOrientation; InsertLast, Update: Boolean); +begin + if FDropOnZone <> nil then + begin + SiblingZone := FDropOnZone; + InsertSibling(NewZone, SiblingZone, InsertLast, Update); + end + else + inherited InsertNewParent(NewZone, SiblingZone, ParentOrientation, + InsertLast, Update); +end; + +procedure TJvDockVIDTree.RemoveZone(Zone: TJvDockZone; Hide: Boolean); +begin + if (FDropOnZone <> nil) and + ((FDropOnZone.NextSibling = Zone) or (FDropOnZone = Zone)) then + FDropOnZone := nil; + inherited RemoveZone(Zone, Hide); +end; + +procedure TJvDockVIDTree.GetSiteInfo(Client: TControl; + var InfluenceRect: TRect; MousePos: TPoint; var CanDock: Boolean); +var + Zone: TJvDockZone; + HTFlag: Integer; + Pos: TPoint; + Align: TAlign; +begin + Pos := DockSite.ScreenToClient(MousePos); + Zone := InternalHitTest(Pos, HTFlag); + if Zone <> nil then + begin + if HTFlag = HTSPLITTER then + begin + InfluenceRect := GetSplitterRect(Zone); + MapWindowPoints(DockSite.Handle, 0, InfluenceRect, 2); + end + else + begin + Pos := MousePos; + if Zone.ChildControl <> nil then + Pos := Zone.ChildControl.ScreenToClient(MousePos); + Align := ComputeVIDDockingRect(Zone.ChildControl, Client, InfluenceRect, Pos); + if (Align = alNone) or (Client = Zone.ChildControl) then + begin + InfluenceRect := Rect(0, 0, 0, 0); + CanDock := False; + end + else + begin + if Zone.ParentZone.Orientation = doVertical then + begin + if (Align = alRight) and (Zone.NextSibling <> nil) and (Zone.NextSibling.Visibled) then + begin + InfluenceRect := GetSplitterRect(Zone); + InflateRect(InfluenceRect, DefExpandoRect, 0); + end + else + if (Align = alLeft) and (Zone.PrevSibling <> nil) and (Zone.PrevSibling.Visibled) then + begin + InfluenceRect := GetSplitterRect(Zone.PrevSibling); + InflateRect(InfluenceRect, DefExpandoRect, 0); + end + else + Exit; + end + else + if Zone.ParentZone.Orientation = doHorizontal then + begin + if (Align = alBottom) and (Zone.NextSibling <> nil) and (Zone.NextSibling.Visibled) then + begin + InfluenceRect := GetSplitterRect(Zone); + InflateRect(InfluenceRect, 0, DefExpandoRect); + end + else + if (Align = alTop) and (Zone.PrevSibling <> nil) and (Zone.PrevSibling.Visibled) then + begin + InfluenceRect := GetSplitterRect(Zone.PrevSibling); + InflateRect(InfluenceRect, 0, DefExpandoRect); + end + else + Exit; + end + else + Exit; + end; + MapWindowPoints(DockSite.Handle, 0, InfluenceRect, 2); + end; + end + else + begin + InfluenceRect := Rect(0, 0, 0, 0); + CanDock := False; + end; +end; + +procedure TJvDockVIDTree.LockDropDockSize; +begin + Inc(FLockDropDockSizeCount); +end; + +procedure TJvDockVIDTree.UnlockDropDockSize; +begin + Dec(FLockDropDockSizeCount); + if FLockDropDockSizeCount < 0 then + FLockDropDockSizeCount := 0; +end; + +procedure TJvDockVIDTree.PaintDockGrabberRect(Canvas: TCanvas; + Control: TWinControl; const ARect: TRect; PaintAlways: Boolean = False); +begin +end; + +procedure TJvDockVIDTree.SetCaptionLeftOffset(const Value: Integer); +begin + FCaptionLeftOffset := Value; +end; + +procedure TJvDockVIDTree.SetCaptionRightOffset(const Value: Integer); +begin + FCaptionRightOffset := Value; +end; + +procedure TJvDockVIDTree.DrawCloseButton(Canvas: TCanvas; Zone: TJvDockZone; Left, Top: Integer); +var + AZone: TJvDockAdvZone; + ADockClient: TJvDockClient; + {$IFDEF JVCLThemesEnabled} + Details: TThemedElementDetails; + CurrentThemeType: TThemedWindow; + {$ENDIF JVCLThemesEnabled} +begin + AZone := TJvDockAdvZone(Zone); + if AZone <> nil then + begin + ADockClient := FindDockClient(Zone.ChildControl); + if (ADockClient <> nil) and not ADockClient.EnableCloseButton then + Exit; + {$IFDEF JVCLThemesEnabled} + if ThemeServices.ThemesAvailable and ThemeServices.ThemesEnabled then + begin + if GrabberSize <= 18 then + begin + CurrentThemeType := twSmallCloseButtonNormal; + if AZone.CloseBtnDown then + CurrentThemeType := twSmallCloseButtonPushed; + end + else + begin + CurrentThemeType := twCloseButtonNormal; + if AZone.CloseBtnDown then + CurrentThemeType := twCloseButtonPushed; + end; + Details := ThemeServices.GetElementDetails(CurrentThemeType); + ThemeServices.DrawElement(Canvas.Handle, Details, Rect(Left, Top, Left + ButtonWidth, Top + ButtonHeight)); + end + else + {$ENDIF JVCLThemesEnabled} + DrawFrameControl(Canvas.Handle, Rect(Left, Top, Left + ButtonWidth, + Top + ButtonHeight), DFC_CAPTION, DFCS_CAPTIONCLOSE or Integer(AZone.CloseBtnDown) * DFCS_PUSHED) + end; +end; + +procedure TJvDockVIDTree.GetCaptionRect(var Rect: TRect); +begin + Inc(Rect.Left, 2 + CaptionLeftOffset); + Inc(Rect.Top, 1); + Dec(Rect.Right, ButtonWidth + CaptionRightOffset - 1); + Dec(Rect.Bottom, 2); +end; + +{ Adjust docking area rectangle to compensante for Grabber control } +procedure TJvDockVIDTree.AdjustDockRect(Control: TControl; var ARect: TRect); +begin + if AlwaysShowGrabber or (DockSite.Align <> alClient) or (TopZone.VisibleChildTotal > 1) then + inherited AdjustDockRect(Control, ARect); +end; + +procedure TJvDockVIDTree.IgnoreZoneInfor(Stream: TMemoryStream); +var + CompName: string; +begin + Stream.Position := Stream.Position + 6; + ReadControlName(Stream, CompName); +end; + +procedure TJvDockVIDTree.SyncWithStyle; +begin + inherited SyncWithStyle; + + if DockStyle is TJvDockVIDStyle then + AlwaysShowGrabber := TJvDockVIDStyle(DockStyle).AlwaysShowGrabber; + + if DockStyle.TabServerOption is TJvDockVIDTabServerOption then + begin + ShowCloseButtonOnGrabber := TJvDockVIDTabServerOption(DockStyle.TabServerOption).ShowCloseButtonOnGrabber; + end; + + { Not all properties are copied (See TJvDockVIDTree.DrawDockGrabber) so we + must invalidate the DockSite so it gets repainted. } + DockSite.Invalidate; +end; + +procedure TJvDockVIDTree.SetShowCloseButtonOnGrabber(const Value: Boolean); +begin + if Value <> FShowCloseButtonOnGrabber then + begin + FShowCloseButtonOnGrabber := Value; + UpdateAll; + DockSite.Invalidate; + end; +end; + +procedure TJvDockVIDTree.SetAlwaysShowGrabber(const Value: Boolean); +begin + if Value <> FAlwaysShowGrabber then + begin + FAlwaysShowGrabber := Value; + UpdateAll; + DockSite.Invalidate; + end; +end; + +//=== { TJvDockVIDConjoinPanel } ============================================= + +procedure TJvDockVIDConjoinPanel.CustomDockDrop(Source: TJvDockDragDockObject; + X, Y: Integer); +begin + if not ((Source.Control.HostDockSite <> nil) and + (Source.DropOnControl = Source.Control.HostDockSite.Parent) and + (Source.DropAlign = alClient)) then + begin + inherited CustomDockDrop(Source, X, Y); + ParentForm.Caption := ''; + {$IFNDEF COMPILER9_UP} + InvalidateDockHostSiteOfControl(Source.Control, False); + {$ENDIF !COMPILER9_UP} + if (Source.Control is TWinControl) and Source.Control.Visible and + TWinControl(Source.Control).CanFocus then + TWinControl(Source.Control).SetFocus; + end; +end; + +procedure TJvDockVIDConjoinPanel.CustomDockOver(Source: TJvDockDragDockObject; X, + Y: Integer; State: TDragState; var Accept: Boolean); +var + DropAlign: TAlign; +begin + inherited CustomDockOver(Source, X, Y, State, Accept); + if Accept and (Source is TJvDockVIDDragDockObject) then + if State = dsDragMove then + begin + DropAlign := Source.DropAlign; + JvDockManager.GetDockEdge(Source.EraseDockRect, Source.DragPos, DropAlign, Source.Control); + end; +end; + +procedure TJvDockVIDConjoinPanel.CustomGetDockEdge(Source: TJvDockDragDockObject; + MousePos: TPoint; var DropAlign: TAlign); +begin +end; + +procedure TJvDockVIDConjoinPanel.CustomGetSiteInfo(Source: TJvDockDragDockObject; Client: TControl; + var InfluenceRect: TRect; MousePos: TPoint; var CanDock: Boolean); +begin + JvDockManager.GetSiteInfo(Client, InfluenceRect, MousePos, CanDock); + CanDock := IsDockable(Self, Client, Source.DropOnControl, Source.DropAlign); +end; + +function TJvDockVIDConjoinPanel.CustomUnDock(Source: TJvDockDragDockObject; NewTarget: TWinControl; + Client: TControl): Boolean; +begin + Result := inherited CustomUnDock(Source, NewTarget, Client); +end; + +procedure TJvDockVIDConjoinPanel.DockDrop(Source: TDragDockObject; + X, Y: Integer); +begin + inherited DockDrop(Source, X, Y); +end; + +procedure TJvDockVIDConjoinPanel.UpdateCaption(Exclude: TControl); +begin + if VisibleDockClientCount > 1 then + ParentForm.Caption := '' + else + inherited UpdateCaption(Exclude); + Invalidate; +end; + +// TJvDockVIDTabPageControl ================================================== +function TJvDockVIDTabPageControl.DoUnDock(NewTarget: TWinControl; Client: TControl): Boolean; +begin + Result := inherited DoUnDock(NewTarget, Client); + if Assigned(ParentForm) then + ParentForm.Caption := ActivePage.Caption; +end; + +constructor TJvDockVIDTabPageControl.Create(AOwner: TComponent); +begin + inherited Create(AOwner); + FPanel := nil; + TabWidth := 1; + MultiLine := True; + TabSheetClass := TJvDockVIDTabSheet; + TabPanelClass := TJvDockTabPanel; + FTempSheet := nil; + TabPosition := tpTop; // Warren changed! was tpBottom; + FTabImageList := nil; + Images := nil; + + if AOwner is TJvDockTabHostForm then + begin + FTabImageList := TCustomImageList.Create(AOwner); + Images := FTabImageList; + end; +end; + +destructor TJvDockVIDTabPageControl.Destroy; +begin + if FTabImageList <> nil then + begin + FTabImageList.Free; + FTabImageList := nil; + end; + if FPanel <> nil then + begin + FPanel.Free; + FPanel := nil; + end; + inherited Destroy; +end; + +procedure TJvDockVIDTabPageControl.AfterConstruction; +begin + // we must create the panel before the inherited call, because + // TJvDockTabPageControl.AfterConstruction calls SyncWithStyle which needs + // a panel. + CreatePanel; + inherited AfterConstruction; +end; + +procedure TJvDockVIDTabPageControl.Loaded; +begin + inherited Loaded; + CreatePanel; +end; + +procedure TJvDockVIDTabPageControl.CreatePanel; +begin + if FPanel = nil then + begin + FPanel := TabPanelClass.Create(Self); + FPanel.Page := Self; + FPanel.Parent := Self; + FPanel.TabLeftOffset := 5; + FPanel.TabRightOffset := 5; + FPanel.TabTopOffset := 3; + FPanel.TabBottomOffset := 3; + ActiveSheetColor := clBtnFace; + InactiveSheetColor := clBtnShadow; + end; + Resize; +end; + +procedure TJvDockVIDTabPageControl.CreateWnd; +begin + inherited CreateWnd; +end; + +procedure TJvDockVIDTabPageControl.CMDockNotification( + var Msg: TCMDockNotification); +begin + if Msg.Msg = CM_DOCKNOTIFICATION then + begin + with TCMDockNotification(Msg) do + begin + if NotifyRec.ClientMsg = CM_INVALIDATEDOCKHOST then + {$IFDEF COMPILER9_UP} + Self.InvalidateDockHostSite(Boolean(NotifyRec.MsgLParam)) + {$ELSE} + InvalidateDockHostSiteOfControl(Self, Boolean(NotifyRec.MsgLParam)) + {$ENDIF COMPILER9_UP} + else + inherited; + end; + end + else + inherited; +end; + +procedure TJvDockVIDTabPageControl.CustomDockDrop(Source: TJvDockDragDockObject; + X, Y: Integer); +var + ARect: TRect; + I: Integer; + VIDSource: TJvDockVIDDragDockObject; + DockClient: TJvDockClient; + Host: TJvDockConjoinHostForm; + Index: Integer; +begin + if Source.DropAlign in [alClient, alNone] then + begin + if Source is TJvDockVIDDragDockObject then + begin + BeginDockLoading; + try + DoFloatForm(Source.Control); + FreeAllDockableForm; + VIDSource := TJvDockVIDDragDockObject(Source); + + for I := 0 to VIDSource.SourceDockClientCount - 1 do + begin + Source.Control := VIDSource.SourceDockClients[I]; + inherited CustomDockDrop(Source, X, Y); + if Source.Control is TCustomForm then + if FTabImageList <> nil then + begin + Index := FTabImageList.AddIcon(TForm(Source.Control).Icon); + if Index <> -1 then + ActivePage.ImageIndex := Index; + end; + end; + finally + EndDockLoading; + JvGlobalDockManager.DragObject.Control := nil; + end; + end; + end + else + begin + DockClient := FindDockClient(ParentForm); + if DockClient <> nil then + begin + ARect := ParentForm.BoundsRect; + Host := DockClient.CreateConjoinHostAndDockControl(ParentForm, Source.Control, Source.DropAlign); + Host.BoundsRect := ARect; + SetDockSite(ParentForm, False); + SetDockSite(TWinControl(Source.Control), False); + Host.Visible := True; + end; + end; + FPanel.SelectSheet := nil; + ParentForm.Caption := ActivePage.Caption; + //KV + with ActivePage do + if not JvGlobalDockIsLoading and (ControlCount > 0) and Assigned(Controls[0]) then begin + if Visible and (Controls[0] <> nil) and (Controls[0] as TWinControl).CanFocus then + (Controls[0] as TWinControl).SetFocus; + end; +end; + +procedure TJvDockVIDTabPageControl.CustomDockOver(Source: TJvDockDragDockObject; + X, Y: Integer; State: TDragState; var Accept: Boolean); +var + ARect: TRect; +begin + Accept := IsDockable(Self, Source.Control, Source.DropOnControl, Source.DropAlign); + if Accept then + begin + if ParentForm.HostDockSite = nil then + begin + Source.DropAlign := ComputeVIDDockingRect(Self, Source.Control, ARect, Point(X, Y)); + if Source.DropAlign = alClient then + ARect.Top := ARect.Top + JvDockGetSysCaptionHeight; + + if Accept and (Source.DropAlign <> alNone) then + begin + Source.DockRect := ARect; + gi_DockRect := ARect; + end; + end + else + begin + if ParentForm.HostDockSite is TJvDockCustomPanel then + begin + ARect := Source.DockRect; + TJvDockCustomPanel(ParentForm.HostDockSite).JvDockManager.PositionDockRect(Source.Control, Source.DropOnControl, + Source.DropAlign, ARect); + Source.DockRect := ARect; + end; + end; + end; +end; + +procedure TJvDockVIDTabPageControl.CustomGetSiteInfo(Source: TJvDockDragDockObject; Client: TControl; + var InfluenceRect: TRect; MousePos: TPoint; var CanDock: Boolean); +const + DefExpandoRect = 20; +var + CH_BW: Integer; + ARect: TRect; +begin + CanDock := IsDockable(Self, Client, Source.DropOnControl, Source.DropAlign); + if ParentForm.HostDockSite <> nil then + CanDock := False; + if CanDock then + begin + GetWindowRect(Parent.Handle, InfluenceRect); + if PtInRect(InfluenceRect, MousePos) then + begin + ARect := InfluenceRect; + InflateRect(ARect, -DefExpandoRect, -DefExpandoRect); + + CH_BW := JvDockGetSysCaptionHeightAndBorderWidth; + Inc(ARect.Top, CH_BW + 1); + Dec(ARect.Bottom, TabHeight); + if PtInRect(ARect, MousePos) then + InfluenceRect := Rect(0, 0, 0, 0); + end; + end; +end; + +procedure TJvDockVIDTabPageControl.DoRemoveDockClient(Client: TControl); +begin + inherited DoRemoveDockClient(Client); + if Assigned(ParentForm) then + ParentForm.Caption := ActivePage.Caption; {bugfix FEB 14, 2005 - WPostma.} +end; + +procedure TJvDockVIDTabPageControl.Change; +begin + Assert(Assigned(ParentForm)); + inherited Change; + + { During closing/undocking of a form, + ActivePage is actually going to be wrong. + See above in DoRemoveDockClient for where we fix + this problem. } + ParentForm.Caption := ActivePage.Caption; + + if ParentForm.HostDockSite is TJvDockCustomPanel then + begin + // if ParentForm.Visible and ParentForm.CanFocus then + // ParentForm.SetFocus; + ParentForm.HostDockSite.Invalidate; + end; + // if (ActivePage <> nil) and (ActivePage.Visible) and (ActivePage.CanFocus) then + // if ParentForm.Visible and ParentForm.CanFocus then + // ActivePage.SetFocus; +end; + +procedure TJvDockVIDTabPageControl.AdjustClientRect(var Rect: TRect); +begin + Rect := ClientRect; + if (Parent is TJvDockTabHostForm) and (VisibleDockClientCount = 1) then + Exit; + case TabPosition of + tpTop: + Inc(Rect.Top, Panel.FTabHeight - 1); + tpBottom: + Dec(Rect.Bottom, Panel.FTabHeight - 1); + tpLeft: + Inc(Rect.Left, Panel.FTabHeight - 1); + tpRight: + Dec(Rect.Right, Panel.FTabHeight - 1); + end; +end; + +procedure TJvDockVIDTabPageControl.CreateParams(var Params: TCreateParams); +begin + inherited CreateParams(Params); +end; + +procedure TJvDockVIDTabPageControl.DrawTab(TabIndex: Integer; + const Rect: TRect; Active: Boolean); +begin + inherited DrawTab(TabIndex, Rect, Active); +end; + +function TJvDockVIDTabPageControl.GetActiveFont: TFont; +begin + Result := FPanel.FActiveFont; +end; + +function TJvDockVIDTabPageControl.GetActiveSheetColor: TColor; +begin + Result := FPanel.FActiveSheetColor; +end; + +function TJvDockVIDTabPageControl.GetInactiveFont: TFont; +begin + Result := FPanel.FInactiveFont; +end; + +function TJvDockVIDTabPageControl.GetInactiveSheetColor: TColor; +begin + Result := FPanel.Color; +end; + +function TJvDockVIDTabPageControl.GetTabBottomOffset: Integer; +begin + Result := FPanel.TabBottomOffset; +end; + +function TJvDockVIDTabPageControl.GetTabLeftOffset: Integer; +begin + Result := FPanel.TabLeftOffset; +end; + +function TJvDockVIDTabPageControl.GetTabRightOffset: Integer; +begin + Result := FPanel.TabRightOffset; +end; + +function TJvDockVIDTabPageControl.GetTabTopOffset: Integer; +begin + Result := FPanel.TabTopOffset; +end; + +procedure TJvDockVIDTabPageControl.Paint; +begin + inherited Paint; +end; + +procedure TJvDockVIDTabPageControl.Resize; +begin + inherited Resize; + if FPanel = nil then + Exit; + case TabPosition of + tpLeft: + begin + FPanel.Left := 0; + FPanel.Width := Panel.FTabHeight; + FPanel.Top := 0; + FPanel.Height := Height; + end; + tpRight: + begin + FPanel.Left := Width - Panel.FTabHeight; + FPanel.Top := 0; + FPanel.Width := Panel.FTabHeight; + FPanel.Height := Height; + end; + tpTop: + begin + FPanel.Left := 0; + FPanel.Top := 0; + FPanel.Width := Width; + FPanel.Height := Panel.FTabHeight; + end; + tpBottom: + begin + FPanel.Left := 0; + FPanel.Top := Height - Panel.FTabHeight; + FPanel.Width := Width; + FPanel.Height := Panel.FTabHeight; + end; + end; +end; + +procedure TJvDockVIDTabPageControl.SetActiveFont(Value: TFont); +begin + FPanel.FActiveFont.Assign(Value); + if ActivePage <> nil then + TJvDockVIDTabSheet(ActivePage).SetSheetSort(ActivePage.Caption); + FPanel.Invalidate; +end; + +procedure TJvDockVIDTabPageControl.SetActiveSheetColor(const Value: TColor); +begin + FPanel.FActiveSheetColor := Value; + FPanel.Invalidate; +end; + +procedure TJvDockVIDTabPageControl.SetInactiveFont(Value: TFont); +var + I: Integer; +begin + FPanel.FInactiveFont.Assign(Value); + for I := 0 to Count - 1 do + if Pages[I] <> ActivePage then + TJvDockVIDTabSheet(Pages[I]).SetSheetSort(Pages[I].Caption); + FPanel.Invalidate; +end; + +procedure TJvDockVIDTabPageControl.SetInactiveSheetColor(const Value: TColor); +begin + if FPanel.Color <> Value then + begin + FPanel.Color := Value; + FPanel.Invalidate; + end; +end; + +procedure TJvDockVIDTabPageControl.SetTabBottomOffset(const Value: Integer); +begin + if FPanel.TabBottomOffset <> Value then + begin + FPanel.TabBottomOffset := Value; + FPanel.Invalidate; + end; +end; + +procedure TJvDockVIDTabPageControl.SetTabHeight(Value: Smallint); +begin + inherited SetTabHeight(Value); + if Panel.FTabHeight <> Value then + begin + Panel.FTabHeight := Value; + FPanel.Invalidate; + end; +end; + +procedure TJvDockVIDTabPageControl.SetTabLeftOffset(const Value: Integer); +begin + if FPanel.TabLeftOffset <> Value then + begin + FPanel.TabLeftOffset := Value; + FPanel.Invalidate; + end; +end; + +procedure TJvDockVIDTabPageControl.SetTabPosition(Value: TTabPosition); +begin + Assert(Value in [tpTop, tpBottom], RsEDockCannotSetTabPosition); + inherited SetTabPosition(Value); + Resize; +end; + +procedure TJvDockVIDTabPageControl.SetTabRightOffset(const Value: Integer); +begin + if FPanel.TabRightOffset <> Value then + begin + FPanel.TabRightOffset := Value; + FPanel.Invalidate; + end; +end; + +procedure TJvDockVIDTabPageControl.SetTabTopOffset(const Value: Integer); +begin + if FPanel.TabTopOffset <> Value then + begin + FPanel.TabTopOffset := Value; + FPanel.Invalidate; + end; +end; + +procedure TJvDockVIDTabPageControl.SetActivePage(Page: TJvDockTabSheet); +begin + inherited SetActivePage(Page); + FPanel.Invalidate; +end; + +procedure TJvDockVIDTabPageControl.DockDrop(Source: TDragDockObject; + X, Y: Integer); +var + Index: Integer; + NewPage: TJvDockTabSheet; +begin + inherited DockDrop(Source, X, Y); + FPanel.SelectSheet := nil; + if ActivePage <> nil then + ParentForm.Caption := ActivePage.Caption; + if Source.Control is TCustomForm then + begin + if Source.Control.Parent is TJvDockTabSheet then + NewPage := TJvDockTabSheet(Source.Control.Parent) + else + NewPage := nil; + if Source.Control.Visible and Assigned(NewPage) then + ActivePage := NewPage; + if FTabImageList <> nil then + begin + Index := FTabImageList.AddIcon(TForm(Source.Control).Icon); + if (Index <> -1) and Assigned(NewPage) then + NewPage.ImageIndex := Index; + end; + end; +end; + +function TJvDockVIDTabPageControl.GetDockClientFromMousePos(MousePos: TPoint): TControl; +var + PageIndex: Integer; +begin + Result := nil; + case TabPosition of + tpTop: + PageIndex := Panel.FindSheetWithPos(MousePos.X, MousePos.Y, 0, Panel.Height - TabBottomOffset); + tpBottom: + PageIndex := Panel.FindSheetWithPos(MousePos.X, MousePos.Y, TabBottomOffset, Panel.Height); + tpLeft: + PageIndex := Panel.FindSheetWithPos(MousePos.Y, MousePos.X, 0, Panel.Height - TabBottomOffset); + tpRight: + PageIndex := Panel.FindSheetWithPos(MousePos.Y, MousePos.X, TabBottomOffset, Panel.Height); + else + PageIndex := -1; + end; + if PageIndex >= 0 then + begin + Result := Pages[PageIndex].Controls[0]; + if Result.HostDockSite <> Self then + Result := nil; + end; +end; + +procedure TJvDockVIDTabPageControl.CustomGetDockEdge(Source: TJvDockDragDockObject; + MousePos: TPoint; var DropAlign: TAlign); +var + ARect: TRect; +begin + DropAlign := ComputeVIDDockingRect(Self, Source.Control, ARect, MousePos); +end; + +function TJvDockVIDTabPageControl.GetVisibleSheetCount: Integer; +var + I: Integer; +begin + Result := 0; + for I := 0 to Count - 1 do + if Pages[I].TabVisible then + Inc(Result); +end; + +procedure TJvDockVIDTabPageControl.UpdateCaption(Exclude: TControl); +begin + ParentForm.Caption := ActivePage.Caption; + if Parent <> nil then + begin + Parent.Invalidate; + if Parent.HostDockSite <> nil then + Parent.HostDockSite.Invalidate; + end; +end; + +procedure TJvDockVIDTabPageControl.SetHotTrack(Value: Boolean); +begin + inherited SetHotTrack(Value); +end; + +procedure TJvDockVIDTabPageControl.SetImages(Value: TCustomImageList); +begin + inherited SetImages(Value); + if Panel <> nil then + begin + Panel.ShowTabImages := Value <> nil; + Panel.Invalidate; + end; +end; + +function TJvDockVIDTabPageControl.GetHotTrackColor: TColor; +begin + Result := Panel.FHotTrackColor; +end; + +procedure TJvDockVIDTabPageControl.SetHotTrackColor(const Value: TColor); +begin + if Panel.FHotTrackColor <> Value then + begin + Panel.FHotTrackColor := Value; + Panel.Invalidate; + end; +end; + +function TJvDockVIDTabPageControl.GetShowTabImages: Boolean; +begin + Result := FPanel.FShowTabImages; +end; + +procedure TJvDockVIDTabPageControl.SetShowTabImages(const Value: Boolean); +begin + FPanel.ShowTabImages := Value; +end; + +function TJvDockVIDTabPageControl.CustomUnDock(Source: TJvDockDragDockObject; + NewTarget: TWinControl; Client: TControl): Boolean; +var + CurrPage: TJvDockTabSheet; + I: Integer; +begin + if not ((Source.Control.HostDockSite <> nil) and + (Source.DropOnControl = Source.Control.HostDockSite.Parent) and + (Source.DropAlign = alClient)) then + begin + CurrPage := GetPageFromDockClient(Client); + if CurrPage <> nil then + begin + //if (FTabImageList <> nil) and ShowTabImages and + // (FTabImageList.Count > CurrPage.ImageIndex) then + //prevent AV + if Assigned(FTabImageList) then + if ShowTabImages and + (FTabImageList.Count > CurrPage.ImageIndex) and + (CurrPage.ImageIndex >= 0) then + begin + FTabImageList.Delete(CurrPage.ImageIndex); + for I := 0 to Count - 1 do + if Pages[I].ImageIndex > CurrPage.ImageIndex then + Pages[I].ImageIndex := Pages[I].ImageIndex - 1; + end; + end; + Result := inherited CustomUnDock(Source, NewTarget, Client); + end + else + Result := True; +end; + +function TJvDockVIDTabPageControl.GetPage(Index: Integer): TJvDockVIDTabSheet; +begin + Result := TJvDockVIDTabSheet(inherited Pages[Index]); +end; + +function TJvDockVIDTabPageControl.GetActiveVIDPage: TJvDockVIDTabSheet; +begin + Result := TJvDockVIDTabSheet(inherited ActivePage); +end; + +procedure TJvDockVIDTabPageControl.SetActiveVIDPage(const Value: TJvDockVIDTabSheet); +begin + ActivePage := Value; +end; + +procedure TJvDockVIDTabPageControl.SyncWithStyle; +var + VIDTabServerOption: TJvDockVIDTabServerOption; +begin + inherited SyncWithStyle; + // panel must be created + if FPanel = nil then + Exit; + if DockStyle.TabServerOption is TJvDockVIDTabServerOption then + begin + VIDTabServerOption := TJvDockVIDTabServerOption(DockStyle.TabServerOption); + + ActiveFont := VIDTabServerOption.ActiveFont; + ActiveSheetColor := VIDTabServerOption.ActiveSheetColor; + HotTrackColor := VIDTabServerOption.HotTrackColor; + InactiveFont := VIDTabServerOption.InactiveFont; + InactiveSheetColor := VIDTabServerOption.InactiveSheetColor; + ShowTabImages := VIDTabServerOption.ShowTabImages; + TabPosition := VIDTabServerOption.TabPosition; + end; +end; + +//=== { TJvDockTabPanel } ==================================================== + +constructor TJvDockTabPanel.Create(AOwner: TComponent); +begin + {$IFDEF JVDOCK_DEBUG} + OutputDebugString('JvDockVIDStyle.pas: TJvDockTabPanel.Create'); + {$ENDIF JVDOCK_DEBUG} + inherited Create(AOwner); + Page := nil; + FCaptionTopOffset := 0; + FCaptionLeftOffset := 5; + FCaptionRightOffset := 5; + FTabBottomOffset := 3; + FTabSplitterWidth := 3; + FTabHeight := 22; + FSortList := TList.Create; + FActiveFont := TFont.Create; + FActiveFont.Color := clBlack; + FInactiveFont := TFont.Create; + FInactiveFont.Color := clWhite; + FHotTrackColor := clBlue; + FTempPages := TList.Create; + FSelectHotIndex := -1; + FShowTabImages := False; + FSelectSheet := nil; +end; + +destructor TJvDockTabPanel.Destroy; +begin + FActiveFont.Free; + FInactiveFont.Free; + FSortList.Free; + FTempPages.Free; + inherited Destroy; +end; + +procedure TJvDockTabPanel.DeleteSorts(Sheet: TJvDockVIDTabSheet); +var + SheetIndex: Integer; +begin + SheetIndex := FSortList.IndexOf(Sheet); + if SheetIndex >= 0 then + FSortList.Delete(SheetIndex); + if Sheet <> nil then + Sheet.TabVisible := False; + SetShowTabWidth; + Page.Invalidate; +end; + +function TJvDockTabPanel.FindSheetWithPos(cX, cY, cTopOffset, cBottomOffset: Integer): Integer; +var + I: Integer; + CompleteWidth, CurrTabWidth: Integer; + Pages: TList; +begin + Result := -1; + if (cY > cBottomOffset) or (cY < cTopOffset) then + Exit; + CompleteWidth := 0; + if FSelectSheet = nil then + Pages := Page.PageSheets + else + Pages := FTempPages; + for I := 0 to Pages.Count - 1 do + begin + if not TJvDockVIDTabSheet(Pages[I]).TabVisible then + Continue; + CurrTabWidth := TJvDockVIDTabSheet(Pages[I]).ShowTabWidth; + if (cX >= FTabLeftOffset + CompleteWidth) and (cX <= FTabLeftOffset + CurrTabWidth + CompleteWidth + + FTabSplitterWidth) then + begin + Result := I; + Exit; + end; + Inc(CompleteWidth, CurrTabWidth + FTabSplitterWidth); + end; +end; + +function TJvDockTabPanel.GetPageIndexFromMousePos(X, Y: Integer): Integer; +begin + Result := -1; + case Page.TabPosition of + tpTop: + Result := FindSheetWithPos(X, Y, 0, Height - TabBottomOffset); + tpBottom: + Result := FindSheetWithPos(X, Y, TabBottomOffset, Height); + tpLeft: + Result := FindSheetWithPos(Y, X, 0, Height - TabBottomOffset); + tpRight: + Result := FindSheetWithPos(Y, X, TabBottomOffset, Height); + end; +end; + +function TJvDockTabPanel.GetMaxTabWidth: TJvDockTabSheet; +var + I: Integer; + MaxWidth, CurrWidth: Integer; +begin + Result := nil; + MaxWidth := 0; + if Page = nil then + Exit; + for I := 0 to Page.Count - 1 do + begin + CurrWidth := Canvas.TextWidth(Page.Tabs[I]); + if MaxWidth < CurrWidth then + begin + Result := Page.Pages[I]; + MaxWidth := CurrWidth; + end; + end; +end; + +function TJvDockTabPanel.GetMinTabWidth: TJvDockTabSheet; +var + I: Integer; + MinWidth, CurrWidth: Integer; +begin + Result := nil; + MinWidth := 0; + for I := 0 to Page.Count - 1 do + begin + CurrWidth := Canvas.TextWidth(Page.Tabs[I]); + if MinWidth > CurrWidth then + begin + Result := Page.Pages[I]; + MinWidth := CurrWidth; + end; + end; +end; + +function TJvDockTabPanel.GetPanelHeight: Integer; +begin + case Page.TabPosition of + tpLeft, tpRight: + Result := Width; + tpTop, tpBottom: + Result := Height; + else + Result := 0; + end; +end; + +function TJvDockTabPanel.GetPanelWidth: Integer; +begin + case Page.TabPosition of + tpLeft, tpRight: + Result := Height; + tpTop, tpBottom: + Result := Width; + else + Result := 0; + end; +end; + +function TJvDockTabPanel.GetSorts(Index: Integer): TJvDockVIDTabSheet; +begin + Result := FSortList[Index]; +end; + +function TJvDockTabPanel.GetTotalTabWidth: Integer; +var + I: Integer; +begin + Result := 0; + if FSortList = nil then + Exit; + for I := 0 to FSortList.Count - 1 do + Inc(Result, Sorts[I].TabWidth + Integer(I <> FSortList.Count - 1) * FTabSplitterWidth); +end; + +procedure TJvDockTabPanel.MouseDown(Button: TMouseButton; Shift: TShiftState; + X, Y: Integer); +var + Ctrl: TControl; + Index: Integer; + Msg: TWMMouse; + Sheet: TJvDockVIDTabSheet; + AParentForm: TCustomForm; +begin + inherited MouseDown(Button, Shift, X, Y); + if Page = nil then + Exit; + + Index := GetPageIndexFromMousePos(X, Y); + if Index >= 0 then + begin + if Index <> Page.ActivePageIndex then + begin + Sheet := Page.ActiveVIDPage; + Page.ActivePageIndex := Index; + Sheet.SetSheetSort(Sheet.Caption); + Page.ActiveVIDPage.SetSheetSort(Page.ActiveVIDPage.Caption); + Page.Change; + Invalidate; + end; + if Assigned(Page.ActivePage) and Page.ActivePage.CanFocus then + begin + AParentForm := GetParentForm(Page); + if Assigned(AParentForm) then begin + Page.SelectFirst; + AParentForm.SetFocus; + end; + end; + + if Button = mbLeft then + begin + FSelectSheet := TJvDockVIDTabSheet(Page.ActivePage); + {$IFDEF COMPILER6_UP} + FTempPages.Assign(Page.PageSheets); + {$ELSE} + AssignList(Page.PageSheets, FTempPages); + {$ENDIF COMPILER6_UP} + end; + + Ctrl := GetDockClientFromPageIndex(Index); + if Ctrl <> nil then + begin + JvGlobalDockClient := FindDockClient(Ctrl); + if JvGlobalDockClient <> nil then + begin + Msg.Msg := WM_NCLBUTTONDOWN + Integer(Button) * 3 + Integer(ssDouble in Shift) * 2; + Msg.Pos.x := X; + Msg.Pos.y := Y; + if not (ssDouble in Shift) then + JvGlobalDockClient.DoNCButtonDown(Page.DoMouseEvent(Msg, Page), Button, msTabPage) + else + begin + JvGlobalDockClient.DoNCButtonDblClk(Page.DoMouseEvent(Msg, Page), Button, msTabPage); + if (Button = mbLeft) and JvGlobalDockClient.CanFloat then + Ctrl.ManualDock(nil, nil, alNone); + end; + end; + end; + end; +end; + +procedure TJvDockTabPanel.MouseMove(Shift: TShiftState; X, Y: Integer); +var + Index: Integer; + Ctrl: TControl; + ARect: TRect; +begin + inherited MouseMove(Shift, X, Y); + Index := GetPageIndexFromMousePos(X, Y); + if Page.HotTrack and (Index <> FSelectHotIndex) then + begin + FSelectHotIndex := Index; + Invalidate; + end; + + if Assigned(FSelectSheet) then + begin + Index := GetPageIndexFromMousePos(X, Y); + if Index >= 0 then + begin + if (Index <> Page.ActivePageIndex) and (Page.Count > Index) then + begin + FSelectSheet.PageIndex := Index; + Invalidate; + end; + end + else + begin + case Page.TabPosition of + tpTop: + ARect := Rect(0, 0, Width, Height - FTabBottomOffset); + tpBottom: + ARect := Rect(0, FTabBottomOffset, Width, Height); + tpLeft: + ARect := Rect(0, 0, Width - FTabBottomOffset, Height); + tpRight: + ARect := Rect(FTabBottomOffset, 0, Width, Height); + else + ARect := Rect(0, 0, 0, 0); + end; + if PtInRect(ARect, Point(X, Y)) then + Exit; + if Page.FTempSheet = nil then + begin + Ctrl := GetDockClientFromPageIndex(FSelectSheet.PageIndex); + if Ctrl <> nil then + JvGlobalDockManager.BeginDrag(Ctrl, False, 1); + end; + end; + end; +end; + +procedure TJvDockTabPanel.MouseUp(Button: TMouseButton; Shift: TShiftState; + X, Y: Integer); +var + Ctrl: TControl; + Index: Integer; + Msg: TWMMouse; +begin + {$IFDEF JVDOCK_DEBUG} + OutputDebugString('JvDockVIDStyle.pas: TJvDockTabPanel.MouseUp'); + {$ENDIF JVDOCK_DEBUG} + + inherited MouseUp(Button, Shift, X, Y); + FSelectSheet := nil; + if Page = nil then + Exit; + + Index := GetPageIndexFromMousePos(X, Y); + Ctrl := GetDockClientFromPageIndex(Index); + if Ctrl <> nil then + begin + JvGlobalDockClient := FindDockClient(Ctrl); + if JvGlobalDockClient <> nil then + begin + Msg.Msg := WM_NCLBUTTONUP + Integer(Button) * 3 + Integer(ssDouble in Shift) * 2; + Msg.Pos := PointToSmallPoint(Page.ScreenToClient(ClientToScreen(Point(X, Y)))); + if not (ssDouble in Shift) then + JvGlobalDockClient.DoNCButtonUp(Page.DoMouseEvent(Msg, Page), Button, msTabPage); + end; + end; +end; + +{ TJvDockTabPanel.Paint,etc. + TODO-LIST-ITEM: + --------------- + VID style has a bit of a problem with what to do in + case of a lot of tabs. It keeps making the text shorter via + text drawn with ellipsis but doesn't EVER display the left/right + buttons that allow you to scroll through a long list of tabs. + To fix this is non-trivial. -WPostma. + } +procedure TJvDockTabPanel.Paint; +var + ARect: TRect; + CurrTabWidth: Integer; + I, CompleteWidth: Integer; + ImageWidth: Integer; + CaptionString: string; +begin + inherited Paint; + if Page = nil then + Exit; + + if (Page.Images <> nil) and (Page.ShowTabImages) then + ImageWidth := Page.Images.Width + else + ImageWidth := 0; + + Canvas.Brush.Color := Page.ActiveSheetColor; + case Page.TabPosition of + tpLeft: + Canvas.FillRect(Rect(PanelHeight - FTabBottomOffset, 0, PanelHeight, PanelWidth)); + tpRight: + Canvas.FillRect(Rect(0, 0, FTabBottomOffset, PanelWidth)); + tpTop: + Canvas.FillRect(Rect(0, PanelHeight - FTabBottomOffset, PanelWidth, PanelHeight)); + tpBottom: + Canvas.FillRect(Rect(0, 0, PanelWidth, FTabBottomOffset)); + end; + + case Page.TabPosition of + tpTop, tpLeft: + Canvas.Pen.Color := clWhite; + tpBottom, tpRight: + Canvas.Pen.Color := clBlack; + end; + + case Page.TabPosition of + tpLeft: + begin + Canvas.MoveTo(PanelHeight - FTabBottomOffset, 0); + Canvas.LineTo(PanelHeight - FTabBottomOffset, PanelWidth); + end; + tpRight: + begin + Canvas.MoveTo(FTabBottomOffset, 0); + Canvas.LineTo(FTabBottomOffset, PanelWidth); + end; + tpTop: + begin + Canvas.MoveTo(0, PanelHeight - FTabBottomOffset); + Canvas.LineTo(PanelWidth, PanelHeight - FTabBottomOffset); + end; + tpBottom: + begin + Canvas.MoveTo(0, FTabBottomOffset); + Canvas.LineTo(PanelWidth, FTabBottomOffset); + end; + end; + + CompleteWidth := 0; + + Canvas.Brush.Style := bsClear; + + for I := 0 to Page.Count - 1 do + begin + if not Page.Pages[I].TabVisible then + Continue; + + CurrTabWidth := TJvDockVIDTabSheet(Page.Pages[I]).ShowTabWidth; + + if Page.ActivePageIndex = I then + begin + Canvas.Brush.Color := Page.ActiveSheetColor; + case Page.TabPosition of + tpLeft: + Canvas.FillRect(Rect(FTabTopOffset, CompleteWidth + FTabLeftOffset, + PanelHeight, CompleteWidth + FTabLeftOffset + CurrTabWidth)); + tpRight: + Canvas.FillRect(Rect(FTabBottomOffset, CompleteWidth + FTabLeftOffset, + PanelHeight - FTabTopOffset, CompleteWidth + FTabLeftOffset + CurrTabWidth)); + tpTop: + Canvas.FillRect(Rect(CompleteWidth + FTabLeftOffset, FTabTopOffset, + CompleteWidth + FTabLeftOffset + CurrTabWidth, PanelHeight)); + tpBottom: + Canvas.FillRect(Rect(CompleteWidth + FTabLeftOffset, FTabBottomOffset, + CompleteWidth + FTabLeftOffset + CurrTabWidth, PanelHeight - FTabTopOffset)); + end; + + Canvas.Pen.Color := clWhite; + case Page.TabPosition of + tpLeft: + begin + Canvas.MoveTo(PanelHeight - FTabBottomOffset, CompleteWidth + FTabLeftOffset); + Canvas.LineTo(FTabTopOffset, CompleteWidth + FTabLeftOffset); + Canvas.LineTo(FTabTopOffset, CompleteWidth + FTabLeftOffset + CurrTabWidth); + Canvas.Pen.Color := clBlack; + Canvas.LineTo(PanelHeight - FTabBottomOffset, CompleteWidth + FTabLeftOffset + CurrTabWidth); + end; + tpRight: + begin + Canvas.MoveTo(FTabTopOffset, CompleteWidth + FTabLeftOffset); + Canvas.LineTo(PanelHeight - FTabBottomOffset, CompleteWidth + FTabLeftOffset); + Canvas.Pen.Color := clBlack; + Canvas.LineTo(PanelHeight - FTabBottomOffset, CompleteWidth + FTabLeftOffset + CurrTabWidth); + Canvas.LineTo(FTabTopOffset, CompleteWidth + FTabLeftOffset + CurrTabWidth); + end; + tpTop: + begin + Canvas.MoveTo(CompleteWidth + FTabLeftOffset, PanelHeight - FTabBottomOffset); + Canvas.LineTo(CompleteWidth + FTabLeftOffset, FTabTopOffset); + Canvas.LineTo(CompleteWidth + FTabLeftOffset + CurrTabWidth, FTabTopOffset); + Canvas.Pen.Color := clBlack; + Canvas.LineTo(CompleteWidth + FTabLeftOffset + CurrTabWidth, PanelHeight - FTabTopOffset); + end; + tpBottom: + begin + Canvas.MoveTo(CompleteWidth + FTabLeftOffset, FTabBottomOffset); + Canvas.LineTo(CompleteWidth + FTabLeftOffset, PanelHeight - FTabTopOffset); + Canvas.Pen.Color := clBlack; + Canvas.LineTo(CompleteWidth + FTabLeftOffset + CurrTabWidth, PanelHeight - FTabTopOffset); + Canvas.LineTo(CompleteWidth + FTabLeftOffset + CurrTabWidth, FTabBottomOffset); + end; + end; + + Canvas.Font.Assign(FActiveFont); + end + else + begin + if (I < Page.ActivePageIndex - 1) or (I > Page.ActivePageIndex) then + begin + Canvas.Pen.Color := Page.InactiveFont.Color; + case Page.TabPosition of + tpLeft, tpRight: + begin + Canvas.MoveTo(PanelHeight - FTabBottomOffset - 3, CompleteWidth + FTabLeftOffset + CurrTabWidth); + Canvas.LineTo(FTabTopOffset + 2, CompleteWidth + FTabLeftOffset + CurrTabWidth); + end; + tpTop, tpBottom: + begin + Canvas.MoveTo(CompleteWidth + FTabLeftOffset + CurrTabWidth, PanelHeight - FTabBottomOffset - 3); + Canvas.LineTo(CompleteWidth + FTabLeftOffset + CurrTabWidth, FTabTopOffset + 2); + end; + end; + end; + Canvas.Brush.Color := Page.InactiveSheetColor; + Canvas.Font.Assign(FInactiveFont); + end; + + if FSelectHotIndex = I then + Canvas.Font.Color := FHotTrackColor; + + case Page.TabPosition of + tpLeft: + ARect := Rect(FTabTopOffset + FCaptionTopOffset + 1, + CompleteWidth + FTabLeftOffset + FCaptionLeftOffset, + PanelHeight, + CompleteWidth + FTabLeftOffset + CurrTabWidth - FCaptionRightOffset); + + tpRight: + ARect := Rect(FTabBottomOffset + FCaptionTopOffset + 1, + CompleteWidth + FTabLeftOffset + FCaptionLeftOffset, + PanelHeight, + CompleteWidth + FTabLeftOffset + CurrTabWidth - FCaptionRightOffset); + + tpTop: + ARect := Rect(CompleteWidth + FTabLeftOffset + FCaptionLeftOffset + + Integer(FShowTabImages) * (ImageWidth + FCaptionLeftOffset), + FTabTopOffset + FCaptionTopOffset + 1, + CompleteWidth + FTabLeftOffset + CurrTabWidth - FCaptionRightOffset, + PanelHeight); + + tpBottom: + ARect := Rect(CompleteWidth + FTabLeftOffset + FCaptionLeftOffset + + Integer(FShowTabImages) * (ImageWidth + FCaptionLeftOffset), + FTabBottomOffset + FCaptionTopOffset + 1, + CompleteWidth + FTabLeftOffset + CurrTabWidth - FCaptionRightOffset, + PanelHeight); + end; + + CaptionString := Page.Pages[I].Caption; + DrawText(Canvas.Handle, PChar(CaptionString), Length(CaptionString), + ARect, DT_LEFT or DT_SINGLELINE or DT_END_ELLIPSIS); + + if FShowTabImages and (Page.Images <> nil) and (CurrTabWidth > ImageWidth + 2 * FCaptionLeftOffset) then + Page.Images.Draw(Canvas, CompleteWidth + FTabLeftOffset + FCaptionLeftOffset, + FTabBottomOffset + FCaptionTopOffset + 1, Page.Pages[I].ImageIndex, True); + + Inc(CompleteWidth, CurrTabWidth + FTabSplitterWidth); + end; + + Canvas.Brush.Color := Page.ActiveSheetColor; + ARect := ClientRect; + Canvas.FrameRect(ARect); +end; + +procedure TJvDockTabPanel.Resize; +begin + inherited Resize; + SetShowTabWidth; +end; + +procedure TJvDockTabPanel.SetCaptionLeftOffset(const Value: Integer); +begin + if FCaptionLeftOffset <> Value then + begin + FCaptionLeftOffset := Value; + Invalidate; + end; +end; + +procedure TJvDockTabPanel.SetCaptionRightOffset(const Value: Integer); +begin + if FCaptionRightOffset <> Value then + begin + FCaptionRightOffset := Value; + Invalidate; + end; +end; + +procedure TJvDockTabPanel.SetCaptionTopOffset(const Value: Integer); +begin + if FCaptionTopOffset <> Value then + begin + FCaptionTopOffset := Value; + Invalidate; + end; +end; + +procedure TJvDockTabPanel.SetPage(const Value: TJvDockVIDTabPageControl); +begin + FPage := Value; +end; + +procedure TJvDockTabPanel.SetPanelHeight(const Value: Integer); +begin + if PanelHeight <> Value then + begin + case Page.TabPosition of + tpLeft, tpRight: + Width := Value; + tpTop, tpBottom: + Height := Value; + end; + SetShowTabWidth; + end; +end; + +procedure TJvDockTabPanel.SetTabBottomOffset(const Value: Integer); +begin + if FTabBottomOffset <> Value then + begin + FTabBottomOffset := Value; + Invalidate; + end; +end; + +procedure TJvDockTabPanel.SetTabLeftOffset(const Value: Integer); +begin + if FTabLeftOffset <> Value then + begin + FTabLeftOffset := Value; + Invalidate; + end; +end; + +procedure TJvDockTabPanel.SetTabRightOffset(const Value: Integer); +begin + if FTabRightOffset <> Value then + begin + FTabRightOffset := Value; + Invalidate; + end; +end; + +procedure TJvDockTabPanel.SetTabSplitterWidth(const Value: Integer); +begin + if FTabSplitterWidth <> Value then + begin + FTabSplitterWidth := Value; + Invalidate; + end; +end; + +procedure TJvDockTabPanel.SetTabTopOffset(const Value: Integer); +begin + if FTabTopOffset <> Value then + begin + FTabTopOffset := Value; + Invalidate; + end; +end; + +procedure TJvDockTabPanel.SetTotalTabWidth(const Value: Integer); +begin +end; + +function TJvDockTabPanel.GetDockClientFromPageIndex(Index: Integer): TControl; +begin + Result := nil; + if Index >= 0 then + if Page.Pages[Index].ControlCount = 1 then + begin + Result := Page.Pages[Index].Controls[0]; + if Result.HostDockSite <> Page then + Result := nil; + end; +end; + +procedure TJvDockTabPanel.SetShowTabWidth; +var + I, J, TempWidth: Integer; + PanelWidth, VisibleCount: Integer; + ImageWidth: Integer; +begin + if Page = nil then + Exit; + if FSortList = nil then + Exit; + PanelWidth := 0; + case Page.TabPosition of + tpTop, tpBottom: + PanelWidth := Width; + tpLeft, tpRight: + PanelWidth := Height; + end; + + TempWidth := PanelWidth - FCaptionLeftOffset - FCaptionRightOffset; + if Page.ShowTabImages then + ImageWidth := Page.Images.Width + FCaptionLeftOffset + else + ImageWidth := 0; + VisibleCount := Page.VisibleSheetCount; + J := 0; + for I := 0 to FSortList.Count - 1 do + begin + if not Sorts[I].TabVisible then + Continue; + if (VisibleCount - J) * (Sorts[I].TabWidth + FTabSplitterWidth + ImageWidth) > TempWidth then + Sorts[I].FShowTabWidth := TempWidth div (VisibleCount - J) - FTabSplitterWidth + else + Sorts[I].FShowTabWidth := Sorts[I].TabWidth + ImageWidth; + Dec(TempWidth, Sorts[I].FShowTabWidth + FTabSplitterWidth); + Inc(J); + end; +end; + +procedure TJvDockTabPanel.CMMouseLeave(var Msg: TMessage); +begin + inherited; + if FSelectHotIndex <> -1 then + begin + FSelectHotIndex := -1; + Invalidate; + end; +end; + +procedure TJvDockTabPanel.SetShowTabImages(const Value: Boolean); +begin + if FShowTabImages <> Value then + begin + FShowTabImages := Value; + SetShowTabWidth; + Invalidate; + end; +end; + +procedure TJvDockTabPanel.SetTabHeight(const Value: Integer); +begin + FTabHeight := Value; + Height := FTabHeight + FTabTopOffset + FTabBottomOffset; +end; + +//=== { TJvDockVIDTabSheet } ================================================= + +constructor TJvDockVIDTabSheet.Create(AOwner: TComponent); +begin + inherited Create(AOwner); + FIsSourceDockClient := False; +end; + +destructor TJvDockVIDTabSheet.Destroy; +begin + if (PageControl is TJvDockVIDTabPageControl) and (PageControl <> nil) then + TJvDockVIDTabPageControl(PageControl).Panel.DeleteSorts(Self); + inherited Destroy; +end; + +procedure TJvDockVIDTabSheet.Loaded; +begin + inherited Loaded; + SetSheetSort(Caption); +end; + +procedure TJvDockVIDTabSheet.SetPageControl(APageControl: TJvDockPageControl); +begin + inherited SetPageControl(APageControl); +end; + +procedure TJvDockVIDTabSheet.SetSheetSort(const CaptionStr: string); +var + TabPanel: TJvDockTabPanel; + TempWidth: Integer; + + procedure DoSetSheetSort; + var + I: Integer; + begin + TJvDockVIDTabPageControl(PageControl).Panel.FSortList.Remove(Self); + for I := 0 to TJvDockVIDTabPageControl(PageControl).Panel.FSortList.Count - 1 do + if TJvDockVIDTabPageControl(PageControl).Panel.Sorts[I].TabWidth > TempWidth then + begin + TJvDockVIDTabPageControl(PageControl).Panel.FSortList.Insert(I, Self); + Exit; + end; + TJvDockVIDTabPageControl(PageControl).Panel.FSortList.Add(Self); + end; + +begin + if (PageControl is TJvDockVIDTabPageControl) and (PageControl <> nil) then + begin + TabPanel := TJvDockVIDTabPageControl(PageControl).Panel; + if PageControl.ActivePage = Self then + TabPanel.Canvas.Font.Assign(TabPanel.Page.ActiveFont) + else + TabPanel.Canvas.Font.Assign(TabPanel.Page.InactiveFont); + TempWidth := TabPanel.Canvas.TextWidth( + CaptionStr) + TabPanel.CaptionLeftOffset + TabPanel.CaptionRightOffset; + if TempWidth <> FTabWidth then + begin + DoSetSheetSort; + FTabWidth := TempWidth; + TabPanel.SetShowTabWidth; + TabPanel.Invalidate; + end; + end; +end; + +procedure TJvDockVIDTabSheet.SetTabWidth(const Value: Integer); +begin + FTabWidth := Value; +end; + +procedure TJvDockVIDTabSheet.UpdateTabShowing; +begin + inherited UpdateTabShowing; + TJvDockVIDTabPageControl(PageControl).Panel.SetShowTabWidth; +end; + +procedure TJvDockVIDTabSheet.WMSetText(var Msg: TMessage); +begin + inherited; + SetSheetSort(PChar(Msg.LParam)); +end; + +{$IFNDEF USEJVCL} +function TJvDockVIDStyle.GetControlName: string; +begin + Result := Format(RsDockLikeVIDStyle, [inherited GetControlName]); +end; +{$ENDIF !USEJVCL} + +//=== { TJvDockVIDDragDockObject } =========================================== + +constructor TJvDockVIDDragDockObject.Create(AControl: TControl); + + procedure DoGetSourceDockClients(Control: TControl); + var + I: Integer; + DockableControl: TWinControl; + begin + if Control is TJvDockableForm then + begin + DockableControl := TJvDockableForm(Control).DockableControl; + for I := 0 to DockableControl.DockClientCount - 1 do + DoGetSourceDockClients(DockableControl.DockClients[I]); + end + else + FSourceDockClientList.Add(Control); + end; + +begin + inherited Create(AControl); + FSourceDockClientList := TList.Create; + DoGetSourceDockClients(AControl); + FDropTabControl := nil; + FIsTabDockOver := False; + CurrState := dsDragEnter; + OldState := CurrState; +{$IFDEF DELPHI6_UP} + AlphaBlendedTab := TJvAlphaBlendedForm.CreateNew(nil); + with AlphaBlendedTab do begin + Visible := False; + Color := clHighlight; + AlphaBlend := True; + AlphaBlendValue := 140; + BorderIcons := []; + BorderStyle := bsNone; + FormStyle := fsStayOnTop; + BoundsRect := Rect(0, 0, 0, 0); + end; +{$ENDIF DELPHI6_UP} +end; + +destructor TJvDockVIDDragDockObject.Destroy; +begin + FDropTabControl := nil; + FSourceDockClientList.Free; +{$IFDEF DELPHI6_UP} + AlphaBlendedTab.Free; +{$ENDIF DELPHI6_UP} + inherited Destroy; +end; + +procedure TJvDockVIDDragDockObject.GetBrush_PenSize_DrawRect(var ABrush: TBrush; + var PenSize: Integer; var DrawRect: TRect; Erase: Boolean); +begin + if DragTarget = nil then + DropAlign := alNone; + inherited GetBrush_PenSize_DrawRect(ABrush, PenSize, DrawRect, Erase); + FIsTabDockOver := ((FOldDropAlign = alClient) and FErase) or + ((DropAlign = alClient) and not FErase); + FOldDropAlign := DropAlign; + FOldTarget := DragTarget; +end; + +// (rom) unused writeable const option removed + +{$IFDEF DELPHI6_UP} +procedure TJvDockVIDDragDockObject.DefaultDockImage(Erase: Boolean); +Var + DrawRect: TRect; + TabControlRect : TRect; + TabRect : TRect; + PenSize: Integer; + ABrush: TBrush; + ShowTab : Boolean; + LeftOffset : integer; + BottomOffset: Integer; + MaxTabWidth: Integer; +begin + FErase := Erase; + GetBrush_PenSize_DrawRect(ABrush, PenSize, DrawRect, Erase); + if Erase then Exit; // No need to erase + + ShowTab := False; + if FIsTabDockOver and Assigned(fDropTabControl) then begin + TabControlRect := FDropTabControl.BoundsRect; + TabControlRect := Rect(FDropTabControl.ClientToScreen(TabControlRect.TopLeft), + FDropTabControl.ClientToScreen(TabControlRect.BottomRight)); + // This is to make sure the TabControlRect is included in the DrawRect + if PtInRect(DrawRect, TabControlRect.TopLeft) and + PtInRect(DrawRect, Point(TabControlRect.BottomRight.X -1, + TabControlRect.BottomRight.Y -1)) + then + ShowTab := True; + end; + + if not ShowTab then begin + AlphaBlendedForm.Visible := True; + AlphaBlendedForm.BoundsRect := DrawRect; + AlphaBlendedTab.Visible := False; + AlphaBlendedTab.BoundsRect := Rect(0, 0, 0, 0); + end else begin + LeftOffset := FDropTabControl.TabLeftOffset; + BottomOffset := FDropTabControl.Panel.TabHeight; + if FDropTabControl.Panel.Page.Count > 0 then + MaxTabWidth := FDropTabControl.Panel.Sorts[0].TabWidth + else + MaxTabWidth := 30; + + if TabControlRect.Right - TabControlRect.Left < LeftOffset + 2 * MaxTabWidth then + MaxTabWidth := (TabControlRect.Right - TabControlRect.Left - LeftOffset) div 2; + + if TabControlRect.Bottom - TabControlRect.Top < 2 * BottomOffset then + BottomOffset := Max((TabControlRect.Bottom - TabControlRect.Top) div 2, 0); + + Assert(fDropTabControl.TabPosition in [tpBottom, tpTop], + RsEDockCannotSetTabPosition); + + TabRect := TabControlRect; + if fDropTabControl.TabPosition = tpBottom then begin + Dec(TabControlRect.Bottom, BottomOffset); + AlphaBlendedForm.Visible := True; + AlphaBlendedForm.BoundsRect := TabControlRect; + TabRect := Bounds(TabRect.Left + LeftOffset, TabRect.Bottom - BottomOffset, + MaxTabWidth, BottomOffset); + AlphaBlendedTab.Visible := True; + AlphaBlendedTab.BoundsRect := TabRect; + end else begin + Inc(TabControlRect.Top, BottomOffset); + AlphaBlendedForm.Visible := True; + AlphaBlendedForm.BoundsRect := TabControlRect; + TabRect := Bounds(TabRect.Left + LeftOffset, TabRect.Top, + MaxTabWidth, BottomOffset); + AlphaBlendedTab.Visible := True; + AlphaBlendedTab.BoundsRect := TabRect; + end; + end; +end; + +{$ELSE} +procedure TJvDockVIDDragDockObject.DefaultDockImage(Erase: Boolean); +const + LeftOffset = 4; +var + DesktopWindow: HWND; + DC: HDC; + OldBrush: HBrush; + DrawRect: TRect; + PenSize: Integer; + ABrush: TBrush; + ButtomOffset: Integer; + MaxTabWidth: Integer; + + procedure DoDrawDefaultImage; + begin + with DrawRect do + begin + PatBlt(DC, Left + PenSize, Top, Right - Left - PenSize, PenSize, PATINVERT); + PatBlt(DC, Right - PenSize, Top + PenSize, PenSize, Bottom - Top - PenSize, PATINVERT); + PatBlt(DC, Left, Bottom - PenSize, Right - Left - PenSize, PenSize, PATINVERT); + PatBlt(DC, Left, Top, PenSize, Bottom - Top - PenSize, PATINVERT); + end; + end; + + procedure DoDrawTabImage; + begin + with DrawRect do + begin + ButtomOffset := 15; + MaxTabWidth := 30; + + PatBlt(DC, Left + PenSize, Top, Right - Left - PenSize, PenSize, PATINVERT); + PatBlt(DC, Right - PenSize, Top + PenSize, PenSize, Bottom - Top - 2 * PenSize - ButtomOffset, PATINVERT); + + if DrawRect.Right - DrawRect.Left - 2 * PenSize < LeftOffset + 2 * PenSize + 2 * MaxTabWidth then + MaxTabWidth := (DrawRect.Right - DrawRect.Left - 4 * PenSize - LeftOffset) div 2; + + if DrawRect.Bottom - DrawRect.Top - 2 * PenSize < 2 * ButtomOffset then + ButtomOffset := Max((DrawRect.Bottom - DrawRect.Top - 2 * PenSize) div 2, 0); + + PatBlt(DC, Left, Bottom - PenSize - ButtomOffset, 2 * PenSize + LeftOffset, PenSize, PATINVERT); + PatBlt(DC, Left + PenSize + LeftOffset, Bottom - ButtomOffset, PenSize, ButtomOffset, PATINVERT); + PatBlt(DC, Left + 2 * PenSize + LeftOffset, Bottom - PenSize, MaxTabWidth, PenSize, PATINVERT); + PatBlt(DC, Left + 2 * PenSize + LeftOffset + MaxTabWidth, Bottom - PenSize - ButtomOffset, PenSize, PenSize + + ButtomOffset, PATINVERT); + PatBlt(DC, Left + 3 * PenSize + LeftOffset + MaxTabWidth, Bottom - PenSize - ButtomOffset, Right - Left - 3 * + PenSize - LeftOffset - MaxTabWidth, PenSize, PATINVERT); + + PatBlt(DC, Left, Top, PenSize, Bottom - Top - PenSize - ButtomOffset, PATINVERT); + end; + end; + +begin + FErase := Erase; + GetBrush_PenSize_DrawRect(ABrush, PenSize, DrawRect, Erase); + + DesktopWindow := GetDesktopWindow; + DC := GetDCEx(DesktopWindow, 0, DCX_CACHE or DCX_LOCKWINDOWUPDATE); + try + OldBrush := SelectObject(DC, ABrush.Handle); + if not FIsTabDockOver then + DoDrawDefaultImage + else + DoDrawTabImage; + SelectObject(DC, OldBrush); + finally + ReleaseDC(DesktopWindow, DC); + end; +end; +{$ENDIF DELPHI6_UP} +function TJvDockVIDDragDockObject.DragFindWindow(const Pos: TPoint): THandle; +begin + Result := 0; +end; + +function TJvDockVIDDragDockObject.GetDropCtl: TControl; +var + ARect: TRect; + I: Integer; +begin + Result := inherited GetDropCtl; + if (Result = nil) and (TargetControl is TJvDockCustomPanel) then + for I := 0 to TargetControl.DockClientCount - 1 do + if TargetControl.DockClients[I].Visible then + begin + ARect := TJvDockCustomPanel(DragTarget).JvDockManager.GetFrameRectEx(TargetControl.DockClients[I]); + if PtInRect(ARect, DragPos) then + begin + Result := TargetControl.DockClients[I]; + Exit; + end; + end; +end; + +function TJvDockVIDDragDockObject.GetSourceDockClient(Index: Integer): TControl; +begin + Result := TControl(FSourceDockClientList[Index]); +end; + +function TJvDockVIDDragDockObject.GetSourceDockClientCount: Integer; +begin + Result := FSourceDockClientList.Count; +end; + +procedure TJvDockVIDDragDockObject.MouseMsg(var Msg: TMessage); +var + APos: TPoint; + Page: TJvDockVIDTabPageControl; +begin + inherited MouseMsg(Msg); + + // Warren added assertions: + Assert(Assigned(JvGlobalDockClient)); + Assert(Assigned(JvGlobalDockManager)); + + case Msg.Msg of + WM_CAPTURECHANGED: + begin + // Warren added Assertions: + Assert(Assigned(JvGlobalDockClient.ParentForm)); + // Assert(Assigned(JvGlobalDockClient.ParentForm.HostDockSite)); + + if Assigned( JvGlobalDockClient.ParentForm.HostDockSite) and + (JvGlobalDockClient.ParentForm.HostDockSite is TJvDockVIDTabPageControl) then + TJvDockVIDTabPageControl(JvGlobalDockClient.ParentForm.HostDockSite).Panel.MouseUp(mbLeft, [], 0, 0) + else + if TWinControl(JvGlobalDockManager.DragObject.DragTarget) is TJvDockVIDTabPageControl then + TJvDockVIDTabPageControl(JvGlobalDockManager.DragObject.TargetControl).Panel.MouseUp(mbLeft, [], 0, 0); + + end; + WM_MOUSEMOVE: + if JvGlobalDockManager.DragObject.TargetControl is TJvDockVIDTabPageControl then + begin + Page := TJvDockVIDTabPageControl(JvGlobalDockManager.DragObject.TargetControl); + if Page.FTempSheet <> nil then + begin + APos := Point(TWMMouse(Msg).XPos, TWMMouse(Msg).YPos); + APos := Page.Panel.ScreenToClient(APos); + Page.Panel.MouseMove([], APos.X, APos.Y); + end; + end; + end; +end; + +procedure TJvDockVIDDragDockObject.SetOldState(const Value: TDragState); +begin + FOldState := Value; +end; + +procedure TJvDockVIDDragDockObject.SetCurrState(const Value: TDragState); +begin + FCurrState := Value; +end; + +function TJvDockVIDDragDockObject.CanLeave(NewTarget: TWinControl): Boolean; +begin + Result := inherited CanLeave(NewTarget); +end; + +//=== { TJvDockVIDZone } ===================================================== + +destructor TJvDockVIDZone.Destroy; +begin + inherited Destroy; +end; + +function TJvDockVIDZone.GetSplitterLimit(IsMin: Boolean): Integer; +begin + if IsMin then + Result := ZoneLimit + else + Result := LimitBegin; +end; + +procedure TJvDockVIDZone.Insert(DockSize: Integer; Hide: Boolean); +var + PrevShift: Integer; + NextShift: Integer; + TempSize: Integer; + BorderSize: Integer; + BeforeVisibleZone: TJvDockZone; + AfterVisibleZone: TJvDockZone; + BeginSize: Integer; +begin + if (ParentZone <> nil) and (ParentZone.VisibleChildCount = 0) then + ParentZone.Insert(ParentZone.VisibleSize, Hide); + + if (ParentZone = nil) or ((ParentZone = Tree.TopZone) and (ParentZone.ChildCount <= 1)) then + begin + Visibled := True; + Exit; + end; + + if (ParentZone <> nil) and (ParentZone.ChildZones <> nil) then + BeginSize := ParentZone.ChildZones.LimitBegin + else + BeginSize := 0; + + BeforeVisibleZone := BeforeClosestVisibleZone; + AfterVisibleZone := AfterClosestVisibleZone; + + BorderSize := TJvDockVIDTree(Tree).BorderWidth * Integer(AfterClosestVisibleZone <> nil) div 2; + TempSize := ParentZone.HeightWidth[ParentZone.Orientation] + BorderSize; + Visibled := False; + + if DockSize >= TempSize - (ParentZone.VisibleChildCount) * TJvDockVIDTree(Tree).MinSize then + DockSize := (TempSize - (ParentZone.VisibleChildCount) * TJvDockVIDTree(Tree).MinSize) div 2; + + if DockSize < TJvDockVIDTree(Tree).MinSize then + DockSize := TempSize div 2; + + if (BeforeVisibleZone = nil) and (AfterVisibleZone = nil) then + begin + PrevShift := 0; + NextShift := 0; + ZoneLimit := TempSize + BeginSize; + end + else + if BeforeVisibleZone = nil then + begin + PrevShift := 0; + NextShift := DockSize + BorderSize; + ZoneLimit := DockSize + LimitBegin + BorderSize; + if ParentZone.VisibleChildCount = 1 then + AfterVisibleZone.ZoneLimit := TempSize + BeginSize; + end + else + if AfterVisibleZone = nil then + begin + PrevShift := DockSize + BorderSize; + NextShift := 0; + if (ParentZone.VisibleChildCount = 1) and (ParentZone = Tree.TopZone) then + BeforeVisibleZone.ZoneLimit := Tree.TopXYLimit - PrevShift + else + BeforeVisibleZone.ZoneLimit := BeforeVisibleZone.ZoneLimit - PrevShift; + ZoneLimit := TempSize + BeginSize; + end + else + begin + PrevShift := Round((BeforeVisibleZone.ZoneLimit - BeginSize) * (DockSize + BorderSize) / TempSize); + NextShift := DockSize - PrevShift; + if (ParentZone.VisibleChildCount = 1) and (ParentZone = Tree.TopZone) then + BeforeVisibleZone.ZoneLimit := Tree.TopXYLimit - PrevShift + else + BeforeVisibleZone.ZoneLimit := BeforeVisibleZone.ZoneLimit - PrevShift; + ZoneLimit := BeforeVisibleZone.ZoneLimit + DockSize; + end; + + if PrevShift <> 0 then + begin + with TJvDockVIDTree(Tree) do + begin + ReplacementZone := BeforeVisibleZone; + try + if (BeforeVisibleZone.ZoneLimit - BeginSize) * (BeforeVisibleZone.ZoneLimit - BeginSize + PrevShift) <> 0 then + ScaleBy := (BeforeVisibleZone.ZoneLimit - BeginSize) / (BeforeVisibleZone.ZoneLimit - BeginSize + PrevShift) + else + ScaleBy := 1; + ParentLimit := BeginSize; + ShiftScaleOrientation := ParentZone.Orientation; + if ScaleBy <> 1 then + ForEachAt(ParentZone.ChildZones, ScaleChildZone, tskMiddle, tspChild); + finally + ReplacementZone := nil; + end; + end; + + if BeforeVisibleZone.LimitSize < TJvDockVIDTree(Tree).MinSize then + BeforeVisibleZone.ZoneLimit := BeforeVisibleZone.LimitBegin + TJvDockVIDTree(Tree).MinSize; + end; + + if NextShift <> 0 then + with TJvDockVIDTree(Tree) do + begin + if (TempSize + BeginSize - LimitBegin - NextShift) * (TempSize + BeginSize - LimitBegin) <> 0 then + ScaleBy := (TempSize + BeginSize - LimitBegin - NextShift) / (TempSize + BeginSize - LimitBegin) + else + ScaleBy := 1; + ParentLimit := TempSize + BeginSize; + ShiftScaleOrientation := ParentZone.Orientation; + if ScaleBy <> 1 then + ForEachAt(AfterVisibleZone, ScaleSiblingZone, tskForward); + end; + Visibled := True; +end; + +procedure TJvDockVIDZone.Remove(DockSize: Integer; Hide: Boolean); +var + PrevShift: Integer; + NextShift: Integer; + TempSize: Integer; + BorderSize: Integer; + BeforeVisibleZone: TJvDockZone; + AfterVisibleZone: TJvDockZone; + BeginSize: Integer; +begin + if (ParentZone <> nil) and (ParentZone.VisibleChildCount = 1) and (ParentZone <> Tree.TopZone) then + ParentZone.Remove(ParentZone.LimitSize, Hide); + + if (ParentZone = nil) or ((ParentZone = Tree.TopZone) and (ParentZone.ChildCount <= 1)) then + begin + Visibled := False; + Exit; + end; + + if (ParentZone <> nil) and (ParentZone.ChildZones <> nil) then + BeginSize := ParentZone.ChildZones.LimitBegin + else + BeginSize := 0; + + BeforeVisibleZone := BeforeClosestVisibleZone; + AfterVisibleZone := AfterClosestVisibleZone; + + BorderSize := TJvDockVIDTree(Tree).BorderWidth * Integer(AfterClosestVisibleZone <> nil) div 2; + TempSize := ParentZone.HeightWidth[ParentZone.Orientation] + BorderSize; + + if DockSize > TempSize - (ParentZone.VisibleChildCount - 1) * TJvDockVIDTree(Tree).MinSize then + DockSize := TempSize - (ParentZone.VisibleChildCount - 1) * TJvDockVIDTree(Tree).MinSize; + if DockSize = 0 then + DockSize := TempSize div 2; + + Visibled := False; + if (BeforeVisibleZone = nil) and (AfterVisibleZone = nil) then + Exit; + + if BeforeVisibleZone = nil then + begin + PrevShift := 0; + NextShift := -DockSize + BorderSize; + ZoneLimit := -DockSize + BorderSize + BeginSize; + end + else + if AfterVisibleZone = nil then + begin + PrevShift := -DockSize + BorderSize; + NextShift := 0; + BeforeVisibleZone.ZoneLimit := BeforeVisibleZone.ZoneLimit - PrevShift; + ZoneLimit := TempSize + BeginSize; + end + else + begin + PrevShift := -Round((BeforeVisibleZone.ZoneLimit - BeginSize) * (DockSize + BorderSize) / (TempSize - (DockSize + + BorderSize))); + NextShift := -DockSize - PrevShift; + BeforeVisibleZone.ZoneLimit := BeforeVisibleZone.ZoneLimit - PrevShift; + ZoneLimit := BeforeVisibleZone.ZoneLimit; + end; + + if PrevShift <> 0 then + begin + with TJvDockVIDTree(Tree) do + begin + ReplacementZone := BeforeVisibleZone; + try + if (BeforeVisibleZone.ZoneLimit - BeginSize) * (BeforeVisibleZone.ZoneLimit - BeginSize + PrevShift) <> 0 then + ScaleBy := (BeforeVisibleZone.ZoneLimit - BeginSize) / (BeforeVisibleZone.ZoneLimit - BeginSize + PrevShift) + else + ScaleBy := 1; + ParentLimit := BeginSize; + ShiftScaleOrientation := ParentZone.Orientation; + if ScaleBy <> 1 then + ForEachAt(ParentZone.ChildZones, ScaleChildZone, tskMiddle, tspChild); + finally + ReplacementZone := nil; + end; + end; + + if BeforeVisibleZone.LimitSize < TJvDockVIDTree(Tree).MinSize then + BeforeVisibleZone.ZoneLimit := BeforeVisibleZone.LimitBegin + TJvDockVIDTree(Tree).MinSize; + end; + + if NextShift <> 0 then + with TJvDockVIDTree(Tree) do + begin + if (TempSize + BeginSize - LimitBegin) * (TempSize + BeginSize - LimitBegin + NextShift) <> 0 then + ScaleBy := (TempSize + BeginSize - LimitBegin) / (TempSize + BeginSize - LimitBegin + NextShift) + else + ScaleBy := 1; + ParentLimit := TempSize + BeginSize; + ShiftScaleOrientation := ParentZone.Orientation; + if ScaleBy <> 1 then + ForEachAt(AfterVisibleZone, ScaleSiblingZone, tskForward); + end; +end; + +//=== { TJvDockVIDTabServerOption } ========================================== + +constructor TJvDockVIDTabServerOption.Create(ADockStyle: TJvDockObservableStyle); +begin + inherited Create(ADockStyle); + TabPosition := tpBottom; + FActiveFont := TFont.Create; + FActiveFont.OnChange := FontChanged; + FActiveSheetColor := clBtnFace; + FHotTrackColor := clBlue; + FInactiveFont := TFont.Create; + FInactiveFont.Color := clWhite; + FInactiveFont.OnChange := FontChanged; + FInactiveSheetColor := clBtnShadow; + FShowTabImages := False; + FShowCloseButtonOnGrabber := True; + FShowCloseButtonOnTabs := False; +end; + +destructor TJvDockVIDTabServerOption.Destroy; +begin + FActiveFont.Free; + FInactiveFont.Free; + inherited Destroy; +end; + +procedure TJvDockVIDTabServerOption.Assign(Source: TPersistent); +var + Src: TJvDockVIDTabServerOption; +begin + if Source is TJvDockVIDTabServerOption then + begin + BeginUpdate; + try + Src := TJvDockVIDTabServerOption(Source); + + ActiveFont := Src.ActiveFont; + ActiveSheetColor := Src.ActiveSheetColor; + HotTrackColor := Src.HotTrackColor; + InactiveFont := Src.InactiveFont; + InactiveSheetColor := Src.InactiveSheetColor; + ShowTabImages := Src.ShowTabImages; + + inherited Assign(Source); + finally + EndUpdate; + end; + end + else + inherited Assign(Source); +end; + +procedure TJvDockVIDTabServerOption.FontChanged(Sender: TObject); +begin + Changed; +end; + +procedure TJvDockVIDTabServerOption.SetActiveFont(Value: TFont); +begin + FActiveFont.Assign(Value); +end; + +procedure TJvDockVIDTabServerOption.SetActiveSheetColor(const Value: TColor); +begin + if FActiveSheetColor <> Value then + begin + FActiveSheetColor := Value; + Changed; + end; +end; + +procedure TJvDockVIDTabServerOption.SetHotTrackColor(const Value: TColor); +begin + if FHotTrackColor <> Value then + begin + FHotTrackColor := Value; + Changed; + end; +end; + +procedure TJvDockVIDTabServerOption.SetInactiveFont(Value: TFont); +begin + FInactiveFont.Assign(Value); +end; + +procedure TJvDockVIDTabServerOption.SetInactiveSheetColor(const Value: TColor); +begin + if FInactiveSheetColor <> Value then + begin + FInactiveSheetColor := Value; + Changed; + end; +end; + +procedure TJvDockVIDTabServerOption.SetShowTabImages(const Value: Boolean); +begin + if FShowTabImages <> Value then + begin + FShowTabImages := Value; + Changed; + end; +end; + +procedure TJvDockVIDTabServerOption.SetTabPosition(const Value: TTabPosition); +begin +// if Value = tpBottom then + inherited SetTabPosition(Value) +// else // TabPosition property must be tpBottom. +// raise Exception.CreateRes(@RsEDockTabPositionMustBetpBottom); +end; + +procedure TJvDockVIDTabServerOption.SetShowCloseButtonOnGrabber( + const Value: Boolean); +begin + if FShowCloseButtonOnGrabber <> Value then + begin + FShowCloseButtonOnGrabber := Value; + Changed; + end; +end; + +procedure TJvDockVIDTabServerOption.SetShowCloseButtonOnTabs( + const Value: Boolean); +begin + if FShowCloseButtonOnTabs <> Value then + begin + FShowCloseButtonOnTabs := Value; + Changed; + end; +end; + +//=== { TJvDockVIDConjoinServerOption } ====================================== + +constructor TJvDockVIDConjoinServerOption.Create(ADockStyle: TJvDockObservableStyle); +begin + inherited Create(ADockStyle); + GrabbersSize := VIDDefaultDockGrabbersSize; + SplitterWidth := VIDDefaultDockSplitterWidth; + FActiveFont := TFont.Create; + FActiveFont.OnChange := FontChanged; + FInactiveFont := TFont.Create; + FInactiveFont.OnChange := FontChanged; + SystemInfo := True; +end; + +destructor TJvDockVIDConjoinServerOption.Destroy; +begin + { Make sure we unregister, can be called more than once } + UnRegisterSettingChangeClient(Self); + FActiveFont.Free; + FInactiveFont.Free; + inherited Destroy; +end; + +procedure TJvDockVIDConjoinServerOption.Assign(Source: TPersistent); +var + Src: TJvDockVIDConjoinServerOption; +begin + if Source is TJvDockVIDConjoinServerOption then + begin + BeginUpdate; + try + Src := TJvDockVIDConjoinServerOption(Source); + + TextEllipsis := Src.TextEllipsis; + TextAlignment := Src.TextAlignment; + InactiveTitleEndColor := Src.InactiveTitleEndColor; + InactiveTitleStartColor := Src.InactiveTitleStartColor; + InactiveTitleVerticalGradient := Src.InactiveTitleVerticalGradient; + ActiveTitleEndColor := Src.ActiveTitleEndColor; + ActiveTitleStartColor := Src.ActiveTitleStartColor; + ActiveTitleVerticalGradient := Src.ActiveTitleVerticalGradient; + ActiveDockGrabber := Src.ActiveDockGrabber; + ActiveFont := Src.ActiveFont; + InactiveFont := Src.InactiveFont; + SystemInfo := Src.SystemInfo; + + inherited Assign(Source); + finally + EndUpdate; + end; + end + else + inherited Assign(Source); +end; + +procedure TJvDockVIDConjoinServerOption.SetActiveTitleEndColor(const Value: TColor); +begin + if Value <> FActiveTitleEndColor then + begin + FActiveTitleEndColor := Value; + // setting SystemInfo to False does not trigger a Changed call + SystemInfo := False; + Changed; + end; +end; + +procedure TJvDockVIDConjoinServerOption.SetActiveTitleStartColor(const Value: TColor); +begin + if Value <> FActiveTitleStartColor then + begin + FActiveTitleStartColor := Value; + SystemInfo := False; + Changed; + end; +end; + +procedure TJvDockVIDConjoinServerOption.SetActiveTitleVerticalGradient(const Value: Boolean); +begin + if Value <> FActiveTitleVerticalGradient then + begin + FActiveTitleVerticalGradient := Value; + SystemInfo := False; + Changed; + end; +end; + +procedure TJvDockVIDConjoinServerOption.SetActiveDockGrabber( + const Value: Boolean); +begin + if Value <> FActiveDockGrabber then + begin + FActiveDockGrabber := Value; + SystemInfo := False; + Changed; + end; +end; + +procedure TJvDockVIDConjoinServerOption.SetInactiveTitleEndColor(const Value: TColor); +begin + if Value <> FInactiveTitleEndColor then + begin + FInactiveTitleEndColor := Value; + SystemInfo := False; + Changed; + end; +end; + +procedure TJvDockVIDConjoinServerOption.SetInactiveTitleStartColor(const Value: TColor); +begin + if Value <> FInactiveTitleStartColor then + begin + FInactiveTitleStartColor := Value; + SystemInfo := False; + Changed; + end; +end; + +procedure TJvDockVIDConjoinServerOption.SetInactiveTitleVerticalGradient(const Value: Boolean); +begin + if Value <> FInactiveTitleVerticalGradient then + begin + FInactiveTitleVerticalGradient := Value; + SystemInfo := False; + Changed; + end; +end; + +procedure TJvDockVIDConjoinServerOption.SetSystemInfo(const Value: Boolean); +begin + if Value <> FSystemInfo then + begin + if FSystemInfo then + UnRegisterSettingChangeClient(Self); + FSystemInfo := Value; + if FSystemInfo then + begin + RegisterSettingChangeClient(Self, SettingChange); + SetDefaultSystemCaptionInfo; + // If necessary Changed is called via SetDefaultSystemCaptionInfo + end; + end; +end; + +procedure TJvDockVIDConjoinServerOption.SetTextAlignment( + const Value: TAlignment); +begin + if Value <> FTextAlignment then + begin + FTextAlignment := Value; + SystemInfo := False; + Changed; + end; +end; + +procedure TJvDockVIDConjoinServerOption.SetTextEllipsis(const Value: Boolean); +begin + if Value <> FTextEllipsis then + begin + FTextEllipsis := Value; + SystemInfo := False; + Changed; + end; +end; + +procedure TJvDockVIDConjoinServerOption.SetDefaultSystemCaptionInfo; +var + Saved: Boolean; +begin + Saved := SystemInfo; + BeginUpdate; + FSystemInfo := False; + try + UpdateDefaultSystemCaptionInfo; + finally + FSystemInfo := Saved; + EndUpdate; + end; +end; + +procedure TJvDockVIDConjoinServerOption.UpdateDefaultSystemCaptionInfo; +begin + ActiveTitleStartColor := JvDockGetActiveTitleBeginColor; + ActiveTitleEndColor := JvDockGetActiveTitleEndColor; + ActiveTitleVerticalGradient := False; + InactiveTitleStartColor := JvDockGetInactiveTitleBeginColor; + InactiveTitleEndColor := JvDockGetInactiveTitleEndColor; + InactiveTitleVerticalGradient := False; + ActiveDockGrabber := False; + TextAlignment := taLeftJustify; + TextEllipsis := True; + ActiveFont := JvDockGetTitleFont; + ActiveFont.Style := FActiveFont.Style + [fsBold]; + InactiveFont := FActiveFont; + ActiveFont.Color := JvDockGetActiveTitleFontColor; + InactiveFont.Color := JvDockGetInactiveTitleFontColor; + GrabbersSize := VIDDefaultDockGrabbersSize; + SplitterWidth := VIDDefaultDockSplitterWidth; +end; + +procedure TJvDockVIDConjoinServerOption.SetActiveFont(Value: TFont); +begin + FActiveFont.Assign(Value); +end; + +procedure TJvDockVIDConjoinServerOption.SetInactiveFont(Value: TFont); +begin + FInactiveFont.Assign(Value); +end; + +procedure TJvDockVIDConjoinServerOption.Changed; +begin + inherited Changed; + SystemInfo := SystemInfo and (GrabbersSize = VIDDefaultDockGrabbersSize) and + (SplitterWidth = VIDDefaultDockSplitterWidth); + TJvDockVIDStyle(DockStyle).DoSystemInfoChange(SystemInfo); +end; + +function TJvDockVIDConjoinServerOption.IsNotSystemInfo: Boolean; +begin + Result := not SystemInfo; +end; + +procedure TJvDockVIDConjoinServerOption.FontChanged(Sender: TObject); +begin + // setting SystemInfo to False does not trigger a Changed call + SystemInfo := False; + Changed; +end; + +procedure TJvDockVIDConjoinServerOption.SettingChange(Sender: TObject); +begin + { ?? } + {DockStyle.ParentForm.Caption := '';} + if SystemInfo then + SetDefaultSystemCaptionInfo; +end; + +{$IFNDEF COMPILER9_UP} +function GetRealParentForm(Control: TControl): TCustomForm; +begin + while not (Control is TCustomForm) and (Control.Parent <> nil) do + Control := Control.Parent; + if Control is TCustomForm then + Result := TCustomForm(Control) + else + Result := nil; +end; +{$ENDIF !COMPILER9_UP} + +{$IFNDEF COMPILER9_UP} +type + TWinControlAccessProtected = class(TWinControl); +{$ENDIF !COMPILER9_UP} + +function GetDockManager(Control: TWinControl; out ADockManager: IDockManager): Boolean; +begin + ADockManager := nil; + {$IFDEF COMPILER9_UP} + with Control do + if UseDockManager then + ADockManager := DockManager; + {$ELSE} + with TWinControlAccessProtected(Control) do + if UseDockManager then + ADockManager := DockManager; + {$ENDIF COMPILER9_UP} + Result := Assigned(ADockManager); +end; + +procedure TJvDockVIDTree.InvalidateDockSite(const Client: TControl); +var + ParentForm: TCustomForm; + Rect: TRect; + ADockManager: IDockManager; +begin + {$IFDEF COMPILER9_UP} + ParentForm := GetParentForm(Client, False); + {$ELSE} + ParentForm := GetRealParentForm(Client); + {$ENDIF COMPILER9_UP} + { Just invalidate the parent form's rect in the HostDockSite + so that we can "follow focus" on docked items. } + if (ParentForm <> nil) and (ParentForm.HostDockSite <> nil) then + begin + if GetDockManager(ParentForm.HostDockSite, ADockManager) then + begin + ADockManager.GetControlBounds(ParentForm, Rect); + InvalidateRect(ParentForm.HostDockSite.Handle, @Rect, False); + end; + end; +end; + +{$IFDEF USEJVCL} +{$IFDEF UNITVERSIONING} +initialization + RegisterUnitVersion(HInstance, UnitVersioning); + +finalization + UnregisterUnitVersion(HInstance); +{$ENDIF UNITVERSIONING} +{$ENDIF USEJVCL} + +end. + diff --git a/JvDockVSNetStyle.pas b/JvDockVSNetStyle.pas index d5e7d2dae..62faf4b51 100644 --- a/JvDockVSNetStyle.pas +++ b/JvDockVSNetStyle.pas @@ -21,7 +21,7 @@ Known Issues: -----------------------------------------------------------------------------} -// $Id: JvDockVSNetStyle.pas 11029 2006-11-23 12:09:20Z obones $ +// $Id: JvDockVSNetStyle.pas 11252 2007-04-05 22:12:55Z remkobonte $ unit JvDockVSNetStyle; @@ -273,7 +273,6 @@ TJvDockVSChannelClass = class of TJvDockVSChannel; TJvDockVSNetStyle = class(TJvDockVIDStyle) private - FMouseleaved: Boolean; { Is the mouse over *any* of the forms with this style } FTimer: TTimer; FDockServers: TList; FCurrentTimer: Integer; @@ -414,8 +413,8 @@ TJvDockVSNETTree = class(TJvDockVIDTree) procedure DoHideZoneChild(AZone: TJvDockZone); override; function GetTopGrabbersHTFlag(const MousePos: TPoint; out HTFlag: Integer; Zone: TJvDockZone): TJvDockZone; override; - procedure DrawDockGrabber(Control: TControl; const ARect: TRect); override; - procedure PaintDockGrabberRect(Canvas: TCanvas; Control: TControl; + procedure DrawDockGrabber(Control: TWinControl; const ARect: TRect); override; + procedure PaintDockGrabberRect(Canvas: TCanvas; Control: TWinControl; const ARect: TRect; PaintAlways: Boolean = False); override; procedure DrawCloseButton(Canvas: TCanvas; Zone: TJvDockZone; Left, Top: Integer); override; @@ -542,9 +541,9 @@ function RetrieveChannel(HostDockSite: TWinControl): TJvDockVSChannel; {$IFDEF UNITVERSIONING} const UnitVersioning: TUnitVersionInfo = ( - RCSfile: '$URL: https://jvcl.svn.sourceforge.net/svnroot/jvcl/branches/JVCL3_30_PREPARATION/run/JvDockVSNetStyle.pas $'; - Revision: '$Revision: 11029 $'; - Date: '$Date: 2006-11-23 13:09:20 +0100 (jeu., 23 nov. 2006) $'; + RCSfile: '$URL: https://jvcl.svn.sourceforge.net:443/svnroot/jvcl/trunk/jvcl/run/JvDockVSNetStyle.pas $'; + Revision: '$Revision: 11252 $'; + Date: '$Date: 2007-04-05 15:12:55 -0700 (Thu, 05 Apr 2007) $'; LogPath: 'JVCL\run' ); {$ENDIF UNITVERSIONING} @@ -553,7 +552,7 @@ function RetrieveChannel(HostDockSite: TWinControl): TJvDockVSChannel; implementation uses - SysUtils, Math, {AppEvnts,} + SysUtils, Math, {AppEvnts,} JvJVCLUtils, JvDockSupportProc; type @@ -870,39 +869,32 @@ procedure TJvDockVSBlock.AddDockControl(Control: TWinControl); var NewPane: TJvDockVSPane; - Form : TCustomForm; + Form: TCustomForm; + APageControl: TJvDockTabPageControl; begin PaneWidth := GetPaneWidth; if Control is TJvDockTabHostForm then begin FBlockType := btTabBlock; - with TJvDockTabHostForm(Control) do + APageControl := TJvDockTabHostForm(Control).PageControl; + FirstIndex := VSPaneCount; + { Mantis 3989: (Kiriakos) PageControl.DockClients does NOT have to be in the + same order as PageControl.Pages; for example, if we reorder the pages. } + for I := 0 to APageControl.Count - 1 do begin - FirstIndex := VSPaneCount; -// for I := 0 to PageControl.DockClientCount - 1 do -// begin -// AddPane(PageControl.DockClients[I], PaneWidth); -// TJvDockVSNETTabSheet(PageControl.Pages[I]).OldVisible := PageControl.DockClients[I].Visible; -// if PageControl.Pages[I] <> PageControl.ActivePage then -// PageControl.DockClients[I].Visible := False; -// end; - for I := 0 to PageControl.Count - 1 do + Form := APageControl.DockForm[I]; + if Assigned(Form) then begin - if (PageControl.Pages[I].ControlCount > 0) and - (PageControl.Pages[I].Controls[0] is TCustomForm) then - begin - Form := TCustomForm(PageControl.Pages[I].Controls[0]); - NewPane := AddPane(Form, PaneWidth); - TJvDockVSNETTabSheet(PageControl.Pages[I]).OldVisible := Form.Visible; - if PageControl.Pages[I] <> PageControl.ActivePage then - Form.Visible := False - else if Assigned(NewPane) then - ActivePane := NewPane; - end; + NewPane := AddPane(Form, PaneWidth); + TJvDockVSNETTabSheet(APageControl.Pages[I]).OldVisible := Form.Visible; + if APageControl.Pages[I] <> APageControl.ActivePage then + Form.Visible := False + else if Assigned(NewPane) then + ActivePane := NewPane; end; - if not Assigned(ActivePane) then - UpdateActivePane(FirstIndex); end; + if not Assigned(ActivePane) then + UpdateActivePane(FirstIndex); end else begin @@ -968,7 +960,7 @@ function TJvDockVSBlock.AddPane(AControl: TControl; const AWidth: Integer): TJvD end; { Add the form icon } - if not Assigned(TCustomFormAccess(AControl).Icon) + if not Assigned(TCustomFormAccess(AControl).Icon) {$IFDEF COMPILER6_UP}or not TCustomFormAccess(AControl).Icon.HandleAllocated{$ENDIF COMPILER6_UP} then begin Icon := TIcon.Create; @@ -1178,7 +1170,12 @@ procedure TJvDockVSChannel.AfterConstruction; procedure TJvDockVSChannel.AutoFocusActiveDockForm; begin if DockServer.AutoFocusDockedForm and Assigned(ActiveDockForm) and ActiveDockForm.CanFocus then + begin ActiveDockForm.SetFocus; + {$IFNDEF COMPILER9_UP} + InvalidateDockHostSiteOfControl(ActiveDockForm, False); + {$ENDIF !COMPILER9_UP} + end; end; procedure TJvDockVSChannel.CMMouseLeave(var Msg: TMessage); @@ -1451,7 +1448,7 @@ procedure TJvDockVSChannel.MouseMove(Shift: TShiftState; X, Y: Integer); inherited MouseMove(Shift, X, Y); NewDelayPane := PaneAtPos(Point(X, Y)); - if Assigned(NewDelayPane) and (NewDelayPane <> PopupPane) then + if Assigned(NewDelayPane) and (NewDelayPane <> PopupPane) and IsForegroundTask then begin // Create the timer object if not existing if FAnimationDelayTimer = nil then @@ -2239,7 +2236,6 @@ procedure TJvDockVSNETPanel.Resize; constructor TJvDockVSNetStyle.Create(AOwner: TComponent); begin inherited Create(AOwner); - FMouseleaved := True; DockPanelClass := TJvDockVSNETPanel; DockSplitterClass := TJvDockVSNETSplitter; ConjoinPanelClass := TJvDockVSNETConjoinPanel; @@ -2313,22 +2309,9 @@ function TJvDockVSNetStyle.DockClientWindowProc(DockClient: TJvDockClient; var Msg: TMessage): Boolean; var Channel: TJvDockVSChannel; - FormRect: TRect; - MPosTp: TPoint; begin Result := inherited DockClientWindowProc(DockClient, Msg); case Msg.Msg of - CM_MOUSEENTER: - begin - FMouseleaved := False; - end; - CM_MOUSELEAVE: //Fix bug on AutoHide --Dejoy. - begin - GetCursorPos(MPosTp); - GetWindowRect(DockClient.ParentForm.Handle, FormRect); - if not PtInRect(FormRect, MPosTp) then - FMouseleaved := True; - end; CM_ENTER, CM_EXIT: begin Channel := RetrieveChannel(DockClient.ParentForm.HostDockSite); @@ -2650,14 +2633,10 @@ procedure TJvDockVSNetStyle.Timer(Sender: TObject); Exit; end; - if not FMouseleaved then - Exit; - Dec(FCurrentTimer, 100); if FCurrentTimer > 0 then Exit; - if FCurrentTimer < 0 then - DestroyTimer; + DestroyTimer; for I := 0 to FDockServers.Count - 1 do begin @@ -2823,7 +2802,7 @@ procedure TJvDockVSNETTree.DoHideZoneChild(AZone: TJvDockZone); begin if AZone.ChildControl is TJvDockTabHostForm then begin - Form := TJvDockTabHostForm(AZone.ChildControl).GetActiveDockForm; + Form := TJvDockTabHostForm(AZone.ChildControl).PageControl.ActiveDockForm; if Form <> nil then begin ADockClient := FindDockClient(Form); @@ -2930,6 +2909,7 @@ procedure TJvDockVSNETTree.DrawAutoHideButton(Zone: TJvDockZone; Left, Top: Inte AZone: TJvDockVSNETZone; ColorArr: array [1..2] of TColor; ADockClient: TJvDockClient; + IsActive: Boolean; begin if Zone <> nil then begin @@ -2938,12 +2918,14 @@ procedure TJvDockVSNETTree.DrawAutoHideButton(Zone: TJvDockZone; Left, Top: Inte Left := Left + ButtonWidth; // move the auto hide button to the Close Button's location AZone := TJvDockVSNETZone(Zone); + IsActive := Assigned(Screen.ActiveControl) and Screen.ActiveControl.Focused and + AZone.ChildControl.ContainsControl(Screen.ActiveControl); if AZone.AutoHideBtnState <> bsNormal then begin if AZone.AutoHideBtnState = bsUp then begin ColorArr[1] := clBlack; - if GetActiveControl = AZone.ChildControl then + if IsActive then ColorArr[2] := clBtnFace else ColorArr[2] := clWhite; @@ -2969,7 +2951,7 @@ procedure TJvDockVSNETTree.DrawAutoHideButton(Zone: TJvDockZone; Left, Top: Inte Inc(Top); end; - if AZone.ChildControl = GetActiveControl then + if IsActive then Canvas.Pen.Color := clWhite else Canvas.Pen.Color := clBlack; @@ -3011,6 +2993,7 @@ procedure TJvDockVSNETTree.DrawCloseButton(Canvas: TCanvas; ColorArr: array [1..2] of TColor; ADockClient: TJvDockClient; AForm: TCustomForm; + IsActive: Boolean; begin if Zone <> nil then begin @@ -3019,7 +3002,7 @@ procedure TJvDockVSNETTree.DrawCloseButton(Canvas: TCanvas; Exit; if Zone.ChildControl is TJvDockTabHostForm then begin - AForm := TJvDockTabHostForm(Zone.ChildControl).GetActiveDockForm; + AForm := TJvDockTabHostForm(Zone.ChildControl).PageControl.ActiveDockForm; if AForm <> nil then begin ADockClient := FindDockClient(AForm); @@ -3028,6 +3011,8 @@ procedure TJvDockVSNETTree.DrawCloseButton(Canvas: TCanvas; end; end; AZone := TJvDockVSNETZone(Zone); + IsActive := Assigned(Screen.ActiveControl) and Screen.ActiveControl.Focused and + AZone.ChildControl.ContainsControl(Screen.ActiveControl); DrawRect.Left := Left + 6; DrawRect.Right := DrawRect.Left + 7; @@ -3039,7 +3024,7 @@ procedure TJvDockVSNETTree.DrawCloseButton(Canvas: TCanvas; if AZone.CloseBtnState = bsUp then begin ColorArr[1] := clBlack; - if GetActiveControl = AZone.ChildControl then + if IsActive then ColorArr[2] := clBtnFace else ColorArr[2] := clWhite; @@ -3062,7 +3047,7 @@ procedure TJvDockVSNETTree.DrawCloseButton(Canvas: TCanvas; if AZone.CloseBtnState = bsDown then OffsetRect(DrawRect, 1, 1); - if AZone.ChildControl = GetActiveControl then + if IsActive then Canvas.Pen.Color := clWhite else Canvas.Pen.Color := clBlack; @@ -3073,7 +3058,7 @@ procedure TJvDockVSNETTree.DrawCloseButton(Canvas: TCanvas; end; end; -procedure TJvDockVSNETTree.DrawDockGrabber(Control: TControl; const ARect: TRect); +procedure TJvDockVSNETTree.DrawDockGrabber(Control: TWinControl; const ARect: TRect); begin inherited DrawDockGrabber(Control, ARect); if DockSite.Align <> alClient then @@ -3139,12 +3124,15 @@ procedure TJvDockVSNETTree.IgnoreZoneInfor(Stream: TMemoryStream); end; procedure TJvDockVSNETTree.PaintDockGrabberRect(Canvas: TCanvas; - Control: TControl; const ARect: TRect; PaintAlways: Boolean = False); + Control: TWinControl; const ARect: TRect; PaintAlways: Boolean = False); var DrawRect: TRect; + IsActive: Boolean; begin inherited PaintDockGrabberRect(Canvas, Control, ARect); - if (GetActiveControl <> Control) or PaintAlways then + IsActive := Assigned(Screen.ActiveControl) and Screen.ActiveControl.Focused and + Control.ContainsControl(Screen.ActiveControl); + if not IsActive or PaintAlways then begin Canvas.Pen.Color := clGray; DrawRect := ARect; diff --git a/JvThreadDialog.pas b/JvThreadDialog.pas new file mode 100644 index 000000000..f5463a159 --- /dev/null +++ b/JvThreadDialog.pas @@ -0,0 +1,701 @@ +{----------------------------------------------------------------------------- +The contents of this file are subject to the Mozilla Public License +Version 1.1 (the "License"); you may not use this file except in compliance +with the License. You may obtain a copy of the License at +http://www.mozilla.org/MPL/MPL-1.1.html + +Software distributed under the License is distributed on an "AS IS" basis, +WITHOUT WARRANTY OF ANY KIND, either expressed or implied. See the License for +the specific language governing rights and limitations under the License. + +The Original Code is: JvThreadDialog.PAS, released on 2004-12-06. + +The Initial Developer of the Original Code is Jens Fudickar [jens dott fudickar att oratool dott de] +All Rights Reserved. + +Contributor(s): Jens Fudickar [jens dott fudickar att oratool dott de]. + +You may retrieve the latest version of this file at the Project JEDI's JVCL home page, +located at http://jvcl.sourceforge.net + +Known Issues: +-----------------------------------------------------------------------------} +// $Id: JvThreadDialog.pas 11056 2006-11-29 10:47:33Z marquardt $ + +unit JvThreadDialog; + +{$I jvcl.inc} + +interface + +uses + {$IFDEF UNITVERSIONING} + JclUnitVersioning, + {$ENDIF UNITVERSIONING} + SysUtils, Classes, Forms, Buttons, StdCtrls, + {$IFDEF MSWINDOWS} + Windows, Controls, ComCtrls, ExtCtrls, + {$ENDIF MSWINDOWS} + {$IFDEF UNIX} + QWindows, QControls, QExtCtrls, + {$ENDIF UNIX} + JvTypes, JvComponentBase, JvThread, JvDynControlEngine; + +type + TJvThreadBaseDialogOptions = class(TJvCustomThreadDialogOptions) + private + FCancelButtonCaption: string; + FCaption: string; + FEnableCancelButton: Boolean; + FInfoText: string; + FInfoTextAlignment: TAlignment; + FShowCancelButton: Boolean; + FShowElapsedTime: Boolean; + protected + procedure SetCancelButtonCaption(Value: string); + procedure SetCaption(Value: string); + procedure SetEnableCancelButton(Value: Boolean); + procedure SetInfoText(Value: string); + procedure SetShowCancelButton(Value: Boolean); + procedure SetShowElapsedTime(Value: Boolean); + public + constructor Create(AOwner: TJvCustomThreadDialog); override; + published + property CancelButtonCaption: string read FCancelButtonCaption + write SetCancelButtonCaption; + property Caption: string read FCaption write SetCaption; + property EnableCancelButton: Boolean read FEnableCancelButton write SetEnableCancelButton default True; + property InfoText: string read FInfoText write SetInfoText; + property InfoTextAlignment: TAlignment read FInfoTextAlignment write FInfoTextAlignment default taLeftJustify; + property ShowCancelButton: Boolean read FShowCancelButton write SetShowCancelButton default True; + property ShowElapsedTime: Boolean read FShowElapsedTime write SetShowElapsedTime default True; + end; + + TJvThreadAnimateDialogOptions = class(TJvThreadBaseDialogOptions) + private + FCommonAVI: TCommonAVI; + FFileName: string; + FResName: string; + published + property CommonAVI: TCommonAVI read FCommonAVI write FCommonAVI; + property FileName: string read FFileName write FFileName; + property ResName: string read FResName write FResName; + end; + + TJvThreadAnimateDialog = class(TJvCustomThreadDialog) + protected + function CreateDialogOptions: TJvCustomThreadDialogOptions; override; + function GetDialogOptions: TJvThreadAnimateDialogOptions; + procedure SetDialogOptions(Value: TJvThreadAnimateDialogOptions); + public + function CreateThreadDialogForm(ConnectedThread: TJvThread): TJvCustomThreadDialogForm; override; + published + property DialogOptions: TJvThreadAnimateDialogOptions read GetDialogOptions write SetDialogOptions; + property OnPressCancel; + end; + + TJvThreadSimpleDialogOptions = class(TJvThreadBaseDialogOptions) + private + FShowProgressBar: Boolean; + procedure SetShowProgressBar(const Value: Boolean); + public + constructor Create(AOwner: TJvCustomThreadDialog); override; + published + property ShowProgressBar: Boolean read FShowProgressBar write SetShowProgressBar default False; + end; + + TJvThreadSimpleDialog = class(TJvCustomThreadDialog) + private + function GetDialogOptions: TJvThreadSimpleDialogOptions; + procedure SetDialogOptions(Value: TJvThreadSimpleDialogOptions); + protected + function CreateDialogOptions: TJvCustomThreadDialogOptions; override; + public + function CreateThreadDialogForm(ConnectedThread: TJvThread): TJvCustomThreadDialogForm; override; + published + property DialogOptions: TJvThreadSimpleDialogOptions read GetDialogOptions write SetDialogOptions; + property OnPressCancel; + end; + + TJvDynControlEngineThreadDialogForm = class(TJvCustomThreadDialogForm) + private + function GetDynControlEngine: TJvDynControlEngine; + protected + property DynControlEngine: TJvDynControlEngine read GetDynControlEngine; + end; + + TJvThreadSimpleDialogForm = class(TJvDynControlEngineThreadDialogForm) + private + FCancelBtn: TButton; + FCancelButtonPanel: TWinControl; + FCounter: Integer; + FDefaultBorderWidth: Integer; + FInfoText: TControl; + FInfoTextPanel: TWinControl; + FMainPanel: TWinControl; + FProgressbar: TWinControl; + FProgressbarPanel: TWinControl; + FStartTime: TDateTime; + FTimeText: TControl; + FTimeTextPanel: TWinControl; + function GetDialogOptions: TJvThreadSimpleDialogOptions; + procedure SetDialogOptions(Value: TJvThreadSimpleDialogOptions); + protected + procedure CreateFormControls; + procedure CreateTextPanel(AOwner: TComponent; AParent: TWinControl; var Panel: TWinControl; + var Text: TControl; TextAlignment: TAlignment; const BaseName: string); + procedure InitializeFormContents; override; + procedure SetFormData; + procedure SetFormHeightWidth; + procedure UpdateFormContents; override; + public + property DialogOptions: TJvThreadSimpleDialogOptions read GetDialogOptions write SetDialogOptions; + end; + + TJvThreadAnimateDialogForm = class(TJvDynControlEngineThreadDialogForm) + private + FAnimate: TAnimate; + FAnimatePanel: TWinControl; + FCancelBtn: TButton; + FCancelButtonPanel: TWinControl; + FDefaultBorderWidth: Integer; + FInfoText: TControl; + FInfoTextPanel: TWinControl; + FMainPanel: TWinControl; + FStartTime: TDateTime; + FTimeText: TControl; + FTimeTextPanel: TWinControl; + function GetDialogOptions: TJvThreadAnimateDialogOptions; + procedure SetDialogOptions(Value: TJvThreadAnimateDialogOptions); + protected + procedure CreateFormControls; + procedure CreateTextPanel(AOwner: TComponent; AParent: TWinControl; var Panel: TWinControl; + var Text: TControl; TextAlignment: TAlignment; const BaseName: string); + procedure InitializeFormContents; override; + procedure SetFormData; + procedure SetFormHeightWidth; + procedure UpdateFormContents; override; + public + property DialogOptions: TJvThreadAnimateDialogOptions read GetDialogOptions write SetDialogOptions; + end; + +{$IFDEF UNITVERSIONING} +const + UnitVersioning: TUnitVersionInfo = ( + RCSfile: '$URL: https://jvcl.svn.sourceforge.net/svnroot/jvcl/branches/JVCL3_30_PREPARATION/run/JvThreadDialog.pas $'; + Revision: '$Revision: 11056 $'; + Date: '$Date: 2006-11-29 11:47:33 +0100 (mer., 29 nov. 2006) $'; + LogPath: 'JVCL\run' + ); +{$ENDIF UNITVERSIONING} + +implementation + +uses + Dialogs, Graphics, + JvResources, JvDynControlEngineIntf; + +function Max(a, b: Integer): Integer; +begin + if a > b then + Result := a + else + Result := b; +end; + +//=== { TJvThreadBaseDialogOptions } ========================================= + +constructor TJvThreadBaseDialogOptions.Create(AOwner: TJvCustomThreadDialog); +begin + inherited Create(AOwner); + FEnableCancelButton := True; + FShowCancelButton := True; + FShowElapsedTime := True; + FCancelButtonCaption := RsButtonCancelCaption; + FInfoTextAlignment := taLeftJustify; +end; + +procedure TJvThreadBaseDialogOptions.SetCancelButtonCaption(Value: string); +begin + FCancelButtonCaption := Value; +end; + +procedure TJvThreadBaseDialogOptions.SetCaption(Value: string); +begin + FCaption := Value; +end; + +procedure TJvThreadBaseDialogOptions.SetEnableCancelButton(Value: Boolean); +begin + FEnableCancelButton := Value; +end; + +procedure TJvThreadBaseDialogOptions.SetInfoText(Value: string); +begin + FInfoText := Value; +end; + +procedure TJvThreadBaseDialogOptions.SetShowCancelButton(Value: Boolean); +begin + FShowCancelButton := Value; +end; + +procedure TJvThreadBaseDialogOptions.SetShowElapsedTime(Value: Boolean); +begin + FShowElapsedTime := Value; +end; + +//=== { TJvThreadSimpleDialog } ============================================== + +function TJvThreadSimpleDialog.CreateDialogOptions: TJvCustomThreadDialogOptions; +begin + Result := TJvThreadSimpleDialogOptions.Create(Self); +end; + +function TJvThreadSimpleDialog.CreateThreadDialogForm(ConnectedThread: TJvThread): TJvCustomThreadDialogForm; +var + ThreadDialogForm: TJvThreadSimpleDialogForm; +begin + if DialogOptions.ShowDialog then + begin + ThreadDialogForm := TJvThreadSimpleDialogForm.CreateNewFormStyle(ConnectedThread, + DialogOptions.FormStyle); + ThreadDialogForm.DialogOptions := DialogOptions; + ThreadDialogForm.OnPressCancel := OnPressCancel; + ThreadDialogForm.CreateFormControls; + Result := ThreadDialogForm; + end + else + Result := nil; +end; + +function TJvThreadSimpleDialog.GetDialogOptions: TJvThreadSimpleDialogOptions; +begin + Result := TJvThreadSimpleDialogOptions(inherited DialogOptions); +end; + +procedure TJvThreadSimpleDialog.SetDialogOptions(Value: TJvThreadSimpleDialogOptions); +begin + inherited DialogOptions.Assign(Value); +end; + +//=== { TJvThreadAnimateDialog } ============================================= + +function TJvThreadAnimateDialog.CreateDialogOptions: TJvCustomThreadDialogOptions; +begin + Result := TJvThreadAnimateDialogOptions.Create(Self); +end; + +function TJvThreadAnimateDialog.CreateThreadDialogForm(ConnectedThread: TJvThread): +TJvCustomThreadDialogForm; +var + ThreadDialogForm: TJvThreadAnimateDialogForm; +begin + if DialogOptions.ShowDialog then + begin + ThreadDialogForm := TJvThreadAnimateDialogForm.CreateNewFormStyle(ConnectedThread, + DialogOptions.FormStyle); + ThreadDialogForm.DialogOptions := DialogOptions; + ThreadDialogForm.OnPressCancel := OnPressCancel; + ThreadDialogForm.CreateFormControls; + Result := ThreadDialogForm; + end + else + Result := nil; +end; + +function TJvThreadAnimateDialog.GetDialogOptions: TJvThreadAnimateDialogOptions; +begin + Result := TJvThreadAnimateDialogOptions(inherited DialogOptions); +end; + +procedure TJvThreadAnimateDialog.SetDialogOptions(Value: TJvThreadAnimateDialogOptions); +begin + inherited DialogOptions.Assign(Value); +end; + +//=== { TJvThreadSimpleDialogOptions } ======================================= + +constructor TJvThreadSimpleDialogOptions.Create(AOwner: TJvCustomThreadDialog); +begin + inherited Create(AOwner); + FShowProgressBar := False; +end; + +procedure TJvThreadSimpleDialogOptions.SetShowProgressBar(const Value: Boolean); +begin + FShowProgressBar := Value; +end; + +procedure TJvThreadSimpleDialogForm.CreateTextPanel(AOwner: TComponent; + AParent: TWinControl; var Panel: TWinControl; var Text: TControl; + TextAlignment: TAlignment; const BaseName: string); +var + ITmpPanel: IJvDynControlPanel; + ITmpAlignment: IJvDynControlAlignment; +begin + Panel := DynControlEngine.CreatePanelControl(AOwner, AParent, + BaseName + 'Panel', '', alTop); + if not Supports(Panel, IJvDynControlPanel, ITmpPanel) then + raise EIntfCastError.CreateRes(@RsEIntfCastError); + with ITmpPanel do + ControlSetBorder(bvNone, bvNone, 0, bsNone, FDefaultBorderWidth); + Text := DynControlEngine.CreateLabelControl(AOwner, Panel, BaseName + 'StaticText', '', nil); + Text.Top := FDefaultBorderWidth; + Text.Left := FDefaultBorderWidth; + if Supports(Text, IJvDynControlAlignment, ITmpAlignment) then + ITmpAlignment.ControlSetAlignment(TextAlignment); +end; + +procedure TJvThreadSimpleDialogForm.CreateFormControls; +var + ITmpPanel: IJvDynControlPanel; + ITmpAlign: IJvDynControlAlign; +begin + FDefaultBorderWidth := 3; + FMainPanel := DynControlEngine.CreatePanelControl(Self, Self, + 'MainPanel', '', alClient); + if not Supports(FMainPanel, IJvDynControlPanel, ITmpPanel) then + raise EIntfCastError.CreateRes(@RsEIntfCastError); + with ITmpPanel do + ControlSetBorder(bvNone, bvNone, 0, bsNone, FDefaultBorderWidth); + + CreateTextPanel(Self, FMainPanel, FInfoTextPanel, FInfoText, + DialogOptions.InfoTextAlignment, 'Info'); + CreateTextPanel(Self, FMainPanel, FTimeTextPanel, FTimeText, taCenter, 'Time'); + + FProgressbarPanel := DynControlEngine.CreatePanelControl(Self, + FMainPanel, 'ProgressbarPanel', '', alTop); + if not Supports(FProgressbarPanel, IJvDynControlPanel, ITmpPanel) then + raise EIntfCastError.CreateRes(@RsEIntfCastError); + with ITmpPanel do + ControlSetBorder(bvNone, bvNone, 0, bsNone, FDefaultBorderWidth); + FProgressbar := DynControlEngine.CreateProgressbarControl(Self, FProgressbarPanel, + 'Progressbar'); + if Supports(FProgressbar, IJvDynControlAlign, ITmpAlign) then + ITmpAlign.ControlSetAlign(alClient); + FProgressbarPanel.Height := FProgressbar.Height + FDefaultBorderWidth*2; + + FCancelButtonPanel := DynControlEngine.CreatePanelControl(Self, + FMainPanel, 'ButtonPanel', '', alTop); + FCancelBtn := DynControlEngine.CreateButton(Self, FCancelButtonPanel, + 'CancelBtn', RsButtonCancelCaption, '', DefaultCancelBtnClick, + True, True); + with FCancelBtn do + begin + Anchors := [akTop]; + Top := FDefaultBorderWidth; + FCancelButtonPanel.Height := FCancelBtn.Height + FDefaultBorderWidth*2; + end; + + BorderIcons := []; + BorderStyle := bsDialog; + Caption := ' '; + ClientHeight := 88; + ClientWidth := 268; + FormStyle := DialogOptions.FormStyle; + {$IFDEF COMPILER7_UP} + Position := poOwnerFormCenter; + {$ELSE} + Position := poScreenCenter; + {$ENDIF COMPILER7_UP} + + SetFormData; +end; + +procedure TJvThreadSimpleDialogForm.InitializeFormContents; +begin + inherited InitializeFormContents; + SetFormHeightWidth; + FStartTime := Now; + FCounter := 0; +end; + +procedure TJvThreadSimpleDialogForm.SetFormData; +var + ITmpControl: IJvDynControl; +begin + if Assigned(DialogOptions) then + begin + if Supports(FInfoText, IJvDynControl, ITmpControl) then + ITmpControl.ControlSetCaption(DialogOptions.FInfoText); + Caption := DialogOptions.Caption; + FTimeTextPanel.Visible := DialogOptions.ShowElapsedTime; + FCancelBtn.Enabled := DialogOptions.EnableCancelButton; + FCancelButtonPanel.Visible := DialogOptions.ShowCancelButton; + FProgressbarPanel.Visible := DialogOptions.ShowProgressBar; + end; +end; + +procedure TJvThreadSimpleDialogForm.SetFormHeightWidth; +var + H, W: Integer; + ITmpAutoSize: IJvDynControlAutoSize; +begin + if Supports(FInfoText, IJvDynControlAutoSize, ITmpAutoSize) then + begin + ITmpAutoSize.ControlSetAutoSize(True); + ITmpAutoSize.ControlSetAutoSize(False); + end; + if Supports(FTimeText, IJvDynControlAutoSize, ITmpAutoSize) then + begin + ITmpAutoSize.ControlSetAutoSize(True); + ITmpAutoSize.ControlSetAutoSize(False); + end; + W := FInfoText.Width + 80; + if W < 250 then + W := 250; + ClientWidth := W; + FCancelBtn.Left := (FCancelButtonPanel.Width - FCancelBtn.Width) div 2; + FInfoText.Width := FInfoTextPanel.Width-FDefaultBorderWidth*2; + FInfoTextPanel.Height := FInfoText.Height+FDefaultBorderWidth*2; + FTimeText.Width := FTimeTextPanel.Width-FDefaultBorderWidth*2; + FTimeTextPanel.Height := FTimeText.Height+FDefaultBorderWidth*2; + FProgressbar.Width := FProgressbarPanel.Width-FDefaultBorderWidth*2; + H := FInfoTextPanel.Height; + if FTimeTextPanel.Visible then + H := H + FTimeTextPanel.Height; + if FProgressbarPanel.Visible then + H := H + FProgressbarPanel.Height; + if FCancelButtonPanel.Visible then + H := H + FCancelButtonPanel.Height; + H := H + FDefaultBorderWidth*2; + if ClientHeight <> H then + ClientHeight := H; +end; + +procedure TJvThreadSimpleDialogForm.UpdateFormContents; +var + ITmpControl: IJvDynControl; + ITmpProgressbar : IJvDynControlProgressbar; +begin + inherited UpdateFormContents; + FCounter := FCounter + 1; + if Supports(FTimeText, IJvDynControl, ITmpControl) then + ITmpControl.ControlSetCaption(FormatDateTime('hh:nn:ss', Now - FStartTime)); + if Supports(FProgressbar, IJvDynControlProgressbar, ITmpProgressbar) then + ITmpProgressbar.ControlSetPosition((FCounter*10) mod 100); + case FCounter mod 4 of + 0: + Caption := DialogOptions.Caption + ' | '; + 1: + Caption := DialogOptions.Caption + ' / '; + 2: + Caption := DialogOptions.Caption + ' --'; + 3: + Caption := DialogOptions.Caption + ' \ '; + end; +end; + +function TJvThreadSimpleDialogForm.GetDialogOptions: TJvThreadSimpleDialogOptions; +begin + Result := TJvThreadSimpleDialogOptions(inherited DialogOptions); +end; + +procedure TJvThreadSimpleDialogForm.SetDialogOptions(Value: + TJvThreadSimpleDialogOptions); +begin + inherited DialogOptions := Value; +end; + +procedure TJvThreadAnimateDialogForm.CreateFormControls; +var + ITmpPanel: IJvDynControlPanel; +begin + FDefaultBorderWidth:=3; + FMainPanel := DynControlEngine.CreatePanelControl(Self, Self, + 'MainPanel', '', alClient); + if not Supports(FMainPanel, IJvDynControlPanel, ITmpPanel) then + raise EIntfCastError.CreateRes(@RsEIntfCastError); + with ITmpPanel do + ControlSetBorder(bvNone, bvNone, 0, bsNone, FDefaultBorderWidth); + + CreateTextPanel(Self, FMainPanel, FInfoTextPanel, FInfoText, + DialogOptions.InfoTextAlignment, 'Info'); + + FAnimatePanel := DynControlEngine.CreatePanelControl(Self, FMainPanel, + 'AnimatePanel', '', alTop); + if not Supports(FAnimatePanel, IJvDynControlPanel, ITmpPanel) then + raise EIntfCastError.CreateRes(@RsEIntfCastError); + with ITmpPanel do + ControlSetBorder(bvNone, bvNone, 0, bsNone, FDefaultBorderWidth); + + FAnimate := TAnimate.Create(Self); + with FAnimate do + begin + Parent := FAnimatePanel; + Top := FDefaultBorderWidth; + Left := FDefaultBorderWidth; + AutoSize := True; + CommonAVI := TJvThreadAnimateDialogOptions(DialogOptions).CommonAVI; + FileName := TJvThreadAnimateDialogOptions(DialogOptions).FileName; + ResName := TJvThreadAnimateDialogOptions(DialogOptions).ResName; + FAnimatePanel.Height := Height + FDefaultBorderWidth*2; + end; + + CreateTextPanel(Self, FMainPanel, FTimeTextPanel, FTimeText, taCenter, 'Time'); + + FCancelButtonPanel := DynControlEngine.CreatePanelControl(Self, + FMainPanel, 'ButtonPanel', '', alTop); + FCancelBtn := DynControlEngine.CreateButton(Self, FCancelButtonPanel, + 'CancelBtn', RsButtonCancelCaption, '', DefaultCancelBtnClick, + True, True); + with FCancelBtn do + begin + Anchors := [akTop]; + Top := FDefaultBorderWidth; + FCancelButtonPanel.Height := FCancelBtn.Height + FDefaultBorderWidth*2; + end; + + BorderIcons := []; + BorderStyle := bsDialog; + Caption := ' '; + FormStyle := DialogOptions.FormStyle; + {$IFDEF COMPILER7_UP} + Position := poOwnerFormCenter; + {$ELSE} + Position := poScreenCenter; + {$ENDIF COMPILER7_UP} + SetFormData; +end; + +procedure TJvThreadAnimateDialogForm.CreateTextPanel(AOwner: TComponent; + AParent: TWinControl; var Panel: TWinControl; var Text: TControl; + TextAlignment: TAlignment; const BaseName: string); +var + ITmpPanel: IJvDynControlPanel; + ITmpAlignment: IJvDynControlAlignment; +begin + Panel := DynControlEngine.CreatePanelControl(AOwner, AParent, + BaseName + 'Panel', '', alTop); + if not Supports(Panel, IJvDynControlPanel, ITmpPanel) then + raise EIntfCastError.CreateRes(@RsEIntfCastError); + with ITmpPanel do + ControlSetBorder(bvNone, bvNone, 0, bsNone, 3); + Text := DynControlEngine.CreateLabelControl(AOwner, + Panel, BaseName + 'StaticText', '', nil); + Text.Top := FDefaultBorderWidth; + Text.Left := FDefaultBorderWidth; + if Supports(Text, IJvDynControlAlignment, ITmpAlignment) then + ITmpAlignment.ControlSetAlignment(TextAlignment); +end; + +procedure TJvThreadAnimateDialogForm.InitializeFormContents; +begin + inherited InitializeFormContents; + SetFormHeightWidth; + FStartTime := Now; + FAnimate.Active := True; +end; + +procedure TJvThreadAnimateDialogForm.SetFormData; +var + ITmpControl: IJvDynControl; +begin + if Assigned(DialogOptions) then + begin + if Supports(FInfoText, IJvDynControl, ITmpControl) then + ITmpControl.ControlSetCaption(DialogOptions.FInfoText); + if Supports(FTimeText, IJvDynControl, ITmpControl) then + ITmpControl.ControlSetCaption(FormatDateTime('hh:nn:ss', 0)); + Caption := DialogOptions.Caption; + FInfoTextPanel.Visible := DialogOptions.InfoText <> ''; + FAnimatePanel.Visible := FileExists(FAnimate.FileName) or + (FAnimate.CommonAVI <> aviNone) or (FAnimate.ResName <> ''); + FTimeTextPanel.Visible := DialogOptions.ShowElapsedTime; + FCancelBtn.Enabled := DialogOptions.EnableCancelButton; + FCancelButtonPanel.Visible := DialogOptions.ShowCancelButton; + end; +end; + +procedure TJvThreadAnimateDialogForm.SetFormHeightWidth; +var + H, W: Integer; + ITmpAutoSize: IJvDynControlAutoSize; +begin + H := 0; + W := 200; + if Supports(FInfoText, IJvDynControlAutoSize, ITmpAutoSize) then + begin + ITmpAutoSize.ControlSetAutoSize(True); + ITmpAutoSize.ControlSetAutoSize(False); + end; + if Supports(FTimeText, IJvDynControlAutoSize, ITmpAutoSize) then + begin + ITmpAutoSize.ControlSetAutoSize(True); + ITmpAutoSize.ControlSetAutoSize(False); + end; + + if FInfoTextPanel.Visible then + W := Max(FInfoText.Width + 80, W); + if FAnimatePanel.Visible then + W := Max(W, FAnimate.Width + 20); + + ClientWidth := W; + + FCancelBtn.Left := (FCancelButtonPanel.Width - FCancelBtn.Width) div 2; + FAnimate.Left := (FAnimatePanel.Width - FAnimate.Width) div 2; + FInfoText.Width := FInfoTextPanel.Width-FDefaultBorderWidth*2; + FInfoTextPanel.Height := FInfoText.Height+FDefaultBorderWidth*2; + FTimeText.Width := FTimeTextPanel.Width-FDefaultBorderWidth*2; + FTimeTextPanel.Height := FTimeText.Height+FDefaultBorderWidth*2; + + if FInfoTextPanel.Visible then + begin + FInfoTextPanel.Top := h; + H := H + FInfoTextPanel.Height; + end; + if FAnimatePanel.Visible then + begin + FAnimatePanel.Top := h; + H := H + FAnimatePanel.Height; + end; + if FTimeTextPanel.Visible then + begin + FTimeTextPanel.Top := h; + H := H + FTimeTextPanel.Height; + end; + if FCancelButtonPanel.Visible then + begin + FCancelButtonPanel.Top := h; + H := H + FCancelButtonPanel.Height; + end; + H := H + 6; + ClientHeight := H; +end; + +procedure TJvThreadAnimateDialogForm.UpdateFormContents; +var + ITmpControl: IJvDynControl; +begin + inherited UpdateFormContents; + if Supports(FTimeText, IJvDynControl, ITmpControl) then + ITmpControl.ControlSetCaption(FormatDateTime('hh:nn:ss', Now - FStartTime)); +end; + +function TJvThreadAnimateDialogForm.GetDialogOptions: TJvThreadAnimateDialogOptions; +begin + Result := TJvThreadAnimateDialogOptions(inherited DialogOptions); +end; + +procedure TJvThreadAnimateDialogForm.SetDialogOptions(Value: + TJvThreadAnimateDialogOptions); +begin + inherited DialogOptions := Value; +end; + +function TJvDynControlEngineThreadDialogForm.GetDynControlEngine: TJvDynControlEngine; +begin + Result := DefaultDynControlEngine; +end; + +{$IFDEF UNITVERSIONING} +initialization + RegisterUnitVersion(HInstance, UnitVersioning); + +finalization + UnregisterUnitVersion(HInstance); +{$ENDIF UNITVERSIONING} + +end. + diff --git a/PyScripter.bdsproj b/PyScripter.bdsproj index 62b293da3..c71561bd3 100644 --- a/PyScripter.bdsproj +++ b/PyScripter.bdsproj @@ -123,7 +123,7 @@ - + C:\Delphi\components\jvcl\run vcl;rtl;vcldb;dbrtl;vclx;xmlrtl;vclie;inetdbbde;inet;inetdbxpress;IndySystem;IndyCore;dclOfficeXP;VclSmp;soaprtl;dsnap;IndyProtocols;inetdb;bdertl;vcldbx;vclactnband;vclshlctrls;teeui;teedb;tee;DJcl;JvStdCtrlsD9R;JvAppFrmD9R;JvCoreD9R;JvBandsD9R;JvDlgsD9R;JvCmpD9R;JvCtrlsD9R;JvCustomD9R;JvDockingD9R;JvHMID9R;JvInspectorD9R;JvPageCompsD9R;JvPluginD9R;JvSystemD9R;JvValidatorsD9R;Python_bds3;SynEdit_R2005;tb2k_d9;tbx_d9;VirtualTreesD9;VirtualShellToolsD9;FreeComp9;DJclVcl;mbTBXJvLibD9D;JvRuntimeDesignD9R PYTHON23 @@ -149,7 +149,7 @@ False 1 8 - 0 + 6 0 False False @@ -162,7 +162,7 @@ - 1.8.0.0 + 1.8.6.0 @@ -175,8 +175,9 @@ $00000000 - - + + Intraweb 8.0 Design Package for Borland Development Studio 2006 + OpenWire Project (Design Time) Borland C++Builder Internet Explorer 5 Components Package diff --git a/PyScripter.bdsproj.local b/PyScripter.bdsproj.local index d2dbc9ca0..b3b4fc988 100644 --- a/PyScripter.bdsproj.local +++ b/PyScripter.bdsproj.local @@ -39,5 +39,8 @@ 2007/01/17 03:05:22.374.pas,C:\Sandbox\P4D\PythonForDelphi\PythonIDE\JvCreateProcess.pas= 2007/01/17 03:07:20.314.pas,C:\Sandbox\P4D\PythonForDelphi\PythonIDE\JvThread.pas= 2007/01/17 03:10:47.602.pas,C:\Sandbox\P4D\PythonForDelphi\PythonIDE\JvTabBar.pas= + 2007/03/05 11:09:46.672.pas,C:\Sandbox\P4D\PythonForDelphi\PythonIDE\JvDockVIDVCStyle.pas= + 2007/03/06 02:23:34.218.pas,C:\Sandbox\P4D\PythonForDelphi\PythonIDE\JvDockVIDVCStyle.pas= + 2007/05/03 08:01:05.583.pas,C:\Sandbox\P4D\PythonForDelphi\PythonIDE\Unit1.pas=C:\Sandbox\P4D\PythonForDelphi\PythonIDE\uDpiAware.pas diff --git a/PyScripter.chw b/PyScripter.chw new file mode 100644 index 0000000000000000000000000000000000000000..4b5a3e77725ceb24920a1023ac9e1b7082e066f9 GIT binary patch literal 18134 zcmeHOTWnlM8UF3KjT2mmLlPRR38%rNO&fRZ#Kd+Q5YDbmOnupUHy4U%db~c~Y_m6= zJ-L{)5-}1&fIy-TNadnFAaN0u0Es^I0afsTP?3lPLRHm1fB>l#;(-U+s%q2kn=|8_ zvwO1Zswxj?W;J_m|M&kh-^~2~Kga8td~SM^h&+PIa^yz`Pj2ZI+4fe~V?Vuet^Wso z^3?D5{qtY_P1lboX_0Y#T-zU>BjkArsMa2sW17A26i+JbQvE9{R(hifUZvXJ2al`-oWQ!vkvR=(uK>rwEU!!uOXhXzb2Nk z_W`iAmL5m3^D*p{Tt=Jgs5KQQ{kT!p%U#;)=VQnd>nz0~v~`b0oQomyXdmNo8SDf& zPwL?Tjl2*+7UBj}o6Ia(({dGP=14DtkFsi+mw=kk+P{^6n!PFNs78G+0cC7CYR36! zLq&~(2R4)XXXfoslrGM>W!U9hix;wZi?;iWlDz<#0Haia{1+92Nh8gi;W+v5k!7wM1leeKhxhUV$@w59(f2vszwm(!|wP#Jya-W%=aqjXBnQskyE(uC9YwEX2P{BkE&Tz1kdq8 z{U6hI`f-tgL;)OfwCO82qr>rNXKO@j*b5C)dgLAWDC*#hj}}_|pq9TkBF}XiFLby2 zAxZCWH!9Zb?1ju0)UBu=KxO@D}wpWM^JA^CF29ANpY*7^wa0jZ*XmL&RxWn176Ji@O{J0d<$)w zEUpfH4*C^NMArNt?TshA=vBgcCGTWu=Cf{R;16E*5pWnO8A0J&ATOzJ;-&bxt$)p|7Qn zH+wo}SDjKH@r}Vo>^Ap2YU!K0 z?G?0;zShCW-q_V7wUexqH^bR?l?LVx?cyYT2kriNUAn4Spr^i(NjA5YuVc7>iH?-n z%lrzua%e3XFJOe)*{A=a{og3eyNe8eR2ceq+95}LQxLv0F#DnAc9SKuerWe4=*Xju z+)K62MM^W`n<(*$lCEJza(~pxV=>Os#(y;`%&6P3K`&0kCTuPFhM!)c^X&Y%Mr{L% z<4qLj3}gPJen{ zuL;w)@JIx6LLScpne+zD#{Vd1WXi^WzC*L||Nk%kKen0i;=S$t-%H*QT31c5UzP#O zfMvikU>UFs{O=gxAK9=Y5d2+F0-daWO zccpOAml`~AB3}y1-ke*PtG5qqNewO>|Ln|sE-!zWAKjT6Jbiky(Wn(lZcw`D&6cX? z8^rBNe2`sS$WAThKPPKPd-^HyfVX<7<}a_qcD39*o?o1rl5ccBH>+&L0GY}BqxoSqn&nn;hOA5YCx8-ZIb zcRs(;MuOf$yxj-&^r@5$`1el literal 0 HcmV?d00001 diff --git a/PyScripter.dpr b/PyScripter.dpr index d996bc363..39cd2541b 100644 --- a/PyScripter.dpr +++ b/PyScripter.dpr @@ -8,12 +8,11 @@ program PyScripter; -{%TogetherDiagram 'ModelSupport\default.txaPackage'} -{%TogetherDiagram 'ModelSupport_PyScripter\default.txaPackage'} {%ToDo 'PyScripter.todo'} uses - //FastMM4, + uCmdLine in 'uCmdLine.pas', + uDpiAware in 'uDpiAware.pas', Windows, Forms, frmPyIDEMain in 'frmPyIDEMain.pas' {PyIDEMainForm}, @@ -79,17 +78,28 @@ uses JvProgramVersionCheck in 'JvProgramVersionCheck.pas', cPyBaseDebugger in 'cPyBaseDebugger.pas', cPyRemoteDebugger in 'cPyRemoteDebugger.pas', - JvDockVSNetStyle in 'JvDockVSNetStyle.pas', - JvDockControlForm in 'JvDockControlForm.pas', cFileTemplates in 'cFileTemplates.pas', dlgCodeTemplates in 'dlgCodeTemplates.pas' {CodeTemplates}, dlgNewFile in 'dlgNewFile.pas' {NewFileDialog}, - JvDockInfo in 'JvDockInfo.pas', SynEdit in 'SynEdit.pas', JvAppInst in 'JvAppInst.pas', - SynEditKeyCmds in 'SynEditKeyCmds.pas'; + SynEditKeyCmds in 'SynEditKeyCmds.pas', + PythonEngine in 'PythonEngine.pas', + TBXOffice2003Theme in 'TBXOffice2003Theme.pas', + TBXOffice2007Theme in 'TBXOffice2007Theme.pas', + TBXUtils in 'TBXUtils.pas', + JvThreadDialog in 'JvThreadDialog.pas', + JvDockVSNetStyle in 'JvDockVSNetStyle.pas', + JvDockControlForm in 'JvDockControlForm.pas', + JvDockSupportControl in 'JvDockSupportControl.pas', + JvDockTree in 'JvDockTree.pas', + JvDockInfo in 'JvDockInfo.pas', + JvDockVIDStyle in 'JvDockVIDStyle.pas'; {$R *.RES} +{$R WebCopyAvi.RES} +{$R XP_UAC.RES} + {$SetPEFlags IMAGE_FILE_RELOCS_STRIPPED} diff --git a/PyScripter.drc b/PyScripter.drc new file mode 100644 index 000000000..20e067d87 --- /dev/null +++ b/PyScripter.drc @@ -0,0 +1,2040 @@ +/* VER180 + Generated by the Borland Delphi Pascal Compiler + because -GD or --drc was supplied to the compiler. + + This file contains compiler-generated resources that + were bound to the executable. + If this file is empty, then no compiler-generated + resources were bound to the produced executable. +*/ + +#define dlgExceptionMail_RsActiveControl 64512 +#define dlgExceptionMail_RsThread 64513 +#define dlgExceptionMail_RsMissingVersionInfo 64514 +#define dlgExceptionMail_RsSendBugReportAddress 64515 +#define dlgExceptionMail_RsSendBugReportSubject 64516 +#define frmCommandOutput_SPrintTimeOut 64528 +#define frmPyIDEMain_SModified 64529 +#define frmFunctionList_SAllString 64530 +#define frmFunctionList_SNoneString 64531 +#define frmFunctionList_SParseStatistics 64532 +#define frmFunctionList_SInvalidIndex 64533 +#define WinHelpViewer_hNoKeyword 64534 +#define dmCommands_S_ERROR_NO_ERROR_STRING 64535 +#define dlgExceptionMail_RsAppError 64536 +#define dlgExceptionMail_RsExceptionClass 64537 +#define dlgExceptionMail_RsExceptionAddr 64538 +#define dlgExceptionMail_RsStackList 64539 +#define dlgExceptionMail_RsModulesList 64540 +#define dlgExceptionMail_RsOSVersion 64541 +#define dlgExceptionMail_RsProcessor 64542 +#define dlgExceptionMail_RsScreenRes 64543 +#define frmToDo_SDoneTodoDesignation 64544 +#define cParameters_SEnterParameterCaption 64545 +#define cParameters_SEnterParameterText 64546 +#define cParameters_SParamCircularReference 64547 +#define cParameters_SParameterNotFound 64548 +#define cParameters_SModifierNotFound 64549 +#define cParameters_SObjectNotFound 64550 +#define cParameters_SPropertyNotFound 64551 +#define cParameters_SInvalidParameterFormat 64552 +#define cParameters_SInvalidConditionFormat 64553 +#define cParameters_SDuplicateModifier 64554 +#define frmCommandOutput_sProcessTerminated 64555 +#define frmCommandOutput_SDirNotFound 64556 +#define frmCommandOutput_SProcessRunning 64557 +#define frmCommandOutput_SPrintCommandLine 64558 +#define frmCommandOutput_SPrintWorkingDir 64559 +#define frmFindResults_SMatches 64560 +#define frmFindResults_SMatchContextNotAvail 64561 +#define frmFindResults_SAllAlphaNumericChars 64562 +#define frmFindResults_SProcessing 64563 +#define frmFindResults_SFileChangedAbort 64564 +#define frmFindResults_SFileSkipped 64565 +#define frmFindResults_SCouldNotBackup 64566 +#define cFindInFiles_SNoFileOpen 64567 +#define cFindInFiles_SSpecifiedDirectoryDoesNotExist 64568 +#define dlgToDoOptions_SLeadingDollarNotAllowed 64569 +#define dlgToDoOptions_SEmptyTokenTextError 64570 +#define frmToDo_SHigh 64571 +#define frmToDo_SNormal 64572 +#define frmToDo_SLow 64573 +#define frmToDo_SDone 64574 +#define frmToDo_STodoItems 64575 +#define OleConst_sNoRunningObject 64576 +#define dlgConfirmReplace_SAskReplaceText 64577 +#define frmEditor_SInsert 64578 +#define frmEditor_SOverwrite 64579 +#define frmEditor_SReadOnly 64580 +#define frmEditor_SNonameFileTitle 64581 +#define frmEditor_SNonamePythonFileTitle 64582 +#define frmEditor_SAskSaveChanges 64583 +#define cFileSearch_SLineLengthError 64584 +#define dlgFindInFiles_SSpecifiedDirectoryDoesNotExist 64585 +#define dlgReplaceInFiles_SGrepResultsNotActive 64586 +#define frmFindResults_SGrepReplaceStats 64587 +#define frmFindResults_SItemMatch 64588 +#define frmFindResults_SReplaceLine 64589 +#define frmFindResults_SGrepActive 64590 +#define frmFindResults_SGrepSearchStats 64591 +#define StringResources_SModuleProxyCodeHint 64592 +#define StringResources_SPackageProxyCodeHint 64593 +#define StringResources_SModuleImportCodeHint 64594 +#define StringResources_SRegError 64595 +#define StringResources_SEmptyList 64596 +#define StringResources_SNewFolder 64597 +#define StringResources_SCommandLineMsg 64598 +#define StringResources_SEngineActive 64599 +#define OleConst_SCannotActivate 64600 +#define OleConst_SNoWindowHandle 64601 +#define OleConst_SLinkProperties 64602 +#define OleConst_SInvalidLinkSource 64603 +#define OleConst_SCannotBreakLink 64604 +#define OleConst_SPropDlgCaption 64605 +#define OleConst_SInvalidLicense 64606 +#define OleConst_SNotLicensed 64607 +#define StringResources_SNamespaceFormat 64608 +#define StringResources_SFilePosInfoCodeHint 64609 +#define StringResources_SDefinedInModuleCodeHint 64610 +#define StringResources_SParsedClassCodeHint 64611 +#define StringResources_SInheritsFromCodeHint 64612 +#define StringResources_SParsedFunctionCodeHint 64613 +#define StringResources_SParsedMethodCodeHint 64614 +#define StringResources_SFunctionParameterCodeHint 64615 +#define StringResources_SLocalVariableCodeHint 64616 +#define StringResources_SGlobalVariableCodeHint 64617 +#define StringResources_SClassVariableCodeHint 64618 +#define StringResources_SInstanceVariableCodeHint 64619 +#define StringResources_SImportedVariableCodeHint 64620 +#define StringResources_SVariableTypeCodeHint 64621 +#define StringResources_SParsedModuleCodeHint 64622 +#define StringResources_SParsedPackageCodeHint 64623 +#define JvDockGlobals_RsDockVSNETDockTreeAutoHideBtnHint 64624 +#define JvDockGlobals_RsEDockControlCannotIsNil 64625 +#define JvDockGlobals_RsEDockCannotGetValueWithNoOrient 64626 +#define JvDockGlobals_RsEDockCannotSetValueWithNoOrient 64627 +#define JvDockGlobals_RsEDockCannotLayAnother 64628 +#define JvDockGlobals_RsEDockCannotSetTabPosition 64629 +#define JvDockGlobals_RsDockCannotFindWindow 64630 +#define StringResources_SInternalError 64631 +#define StringResources_SNotFound 64632 +#define StringResources_SNotAvailable 64633 +#define StringResources_SNotImplented 64634 +#define StringResources_SFilterAllFiles 64635 +#define StringResources_SVariablesDocNotSelected 64636 +#define StringResources_SVariablesDocSelected 64637 +#define StringResources_SDebuggerHintFormat 64638 +#define StringResources_SNoParameters 64639 +#define VirtualTrees_SCorruptStream2 64640 +#define VirtualTrees_SClipboardFailed 64641 +#define VirtualTrees_SCannotSetUserData 64642 +#define DBConsts_SBcdOverflow 64643 +#define DBConsts_SInvalidBcdValue 64644 +#define DBConsts_SCouldNotParseTimeStamp 64645 +#define DBConsts_SInvalidSqlTimeStamp 64646 +#define TntLXUtils_SFileOpAborted 64647 +#define ObjAuto_sTypeMisMatch 64648 +#define ObjAuto_sInvalidDispID 64649 +#define ObjAuto_sParamRequired 64650 +#define ObjAuto_sMethodOver 64651 +#define ObjAuto_sTooManyParams 64652 +#define JvDockGlobals_RsDockStringSplitter 64653 +#define JvDockGlobals_RsDockJvDockInfoSplitter 64654 +#define JvDockGlobals_RsDockJvDockTreeCloseBtnHint 64655 +#define JvResources_RsClInfoBk 64656 +#define JvResources_RsGradientActiveCaption 64657 +#define JvResources_RsGradientInactiveCaption 64658 +#define JvResources_RsHotLight 64659 +#define JvResources_RsMenuBar 64660 +#define JvResources_RsMenuHighlight 64661 +#define JvResources_RsFileNotFoundFmt 64662 +#define JvResources_RsEGrabberNotStopped 64663 +#define JvResources_RsJediAgent 64664 +#define JvResources_RsDefaultOutputFileName 64665 +#define VirtualTrees_SEditLinkIsNil 64666 +#define VirtualTrees_SWrongMoveError 64667 +#define VirtualTrees_SWrongStreamFormat 64668 +#define VirtualTrees_SWrongStreamVersion 64669 +#define VirtualTrees_SStreamTooSmall 64670 +#define VirtualTrees_SCorruptStream1 64671 +#define JvResources_RsClWindowText 64672 +#define JvResources_RsClCaptionText 64673 +#define JvResources_RsClActiveBorder 64674 +#define JvResources_RsClInactiveBorder 64675 +#define JvResources_RsClAppWorkSpace 64676 +#define JvResources_RsClHighlight 64677 +#define JvResources_RsClHighlightText 64678 +#define JvResources_RsClBtnFace 64679 +#define JvResources_RsClBtnShadow 64680 +#define JvResources_RsClGrayText 64681 +#define JvResources_RsClBtnText 64682 +#define JvResources_RsClInactiveCaptionText 64683 +#define JvResources_RsClBtnHighlight 64684 +#define JvResources_RsCl3DDkShadow 64685 +#define JvResources_RsCl3DLight 64686 +#define JvResources_RsClInfoText 64687 +#define JvResources_RsClGray25 64688 +#define JvResources_RsClRose 64689 +#define JvResources_RsClTan 64690 +#define JvResources_RsClLightYellow 64691 +#define JvResources_RsClLightGreen 64692 +#define JvResources_RsClLightTurquoise 64693 +#define JvResources_RsClPaleBlue 64694 +#define JvResources_RsClLavender 64695 +#define JvResources_RsClScrollBar 64696 +#define JvResources_RsClBackground 64697 +#define JvResources_RsClActiveCaption 64698 +#define JvResources_RsClInactiveCaption 64699 +#define JvResources_RsClMenu 64700 +#define JvResources_RsClWindow 64701 +#define JvResources_RsClWindowFrame 64702 +#define JvResources_RsClMenuText 64703 +#define JvResources_RsClGray80 64704 +#define JvResources_RsClDarkRed 64705 +#define JvResources_RsClOrange 64706 +#define JvResources_RsClDarkYellow 64707 +#define JvResources_RsClBlueGray 64708 +#define JvResources_RsClGray50 64709 +#define JvResources_RsClLightOrange 64710 +#define JvResources_RsClSeaGreen 64711 +#define JvResources_RsClLightBlue 64712 +#define JvResources_RsClViolet 64713 +#define JvResources_RsClGray40 64714 +#define JvResources_RsClPink 64715 +#define JvResources_RsClGold 64716 +#define JvResources_RsClBrightGreen 64717 +#define JvResources_RsClTurquoise 64718 +#define JvResources_RsClPlum 64719 +#define JvResources_RsClLime 64720 +#define JvResources_RsClYellow 64721 +#define JvResources_RsClBlue 64722 +#define JvResources_RsClFuchsia 64723 +#define JvResources_RsClAqua 64724 +#define JvResources_RsClWhite 64725 +#define JvResources_RsClMoneyGreen 64726 +#define JvResources_RsClSkyBlue 64727 +#define JvResources_RsClCream 64728 +#define JvResources_RsClMedGray 64729 +#define JvResources_RsClBrown 64730 +#define JvResources_RsClOliveGreen 64731 +#define JvResources_RsClDarkGreen 64732 +#define JvResources_RsClDarkTeal 64733 +#define JvResources_RsClDarkBlue 64734 +#define JvResources_RsClIndigo 64735 +#define JvResources_RsJvPropertyStoreEnterMutexTimeout 64736 +#define JvResources_RsRTFFilter 64737 +#define JvResources_RsTextFilter 64738 +#define JvResources_RsEOutOfRangeFloat 64739 +#define JvResources_RsENoItemFoundWithName 64740 +#define JvResources_RsENotATJvThread 64741 +#define JvResources_RsClBlack 64742 +#define JvResources_RsClMaroon 64743 +#define JvResources_RsClGreen 64744 +#define JvResources_RsClOlive 64745 +#define JvResources_RsClNavy 64746 +#define JvResources_RsClPurple 64747 +#define JvResources_RsClTeal 64748 +#define JvResources_RsClGray 64749 +#define JvResources_RsClSilver 64750 +#define JvResources_RsClRed 64751 +#define JvResources_RsPVCDialogCaption 64752 +#define JvResources_RsPVCDialogExecuteButton 64753 +#define JvResources_RsPVCNewVersionAvailable 64754 +#define JvResources_RsPVCChooseWhichVersion 64755 +#define JvResources_RsPVCChooseOperation 64756 +#define JvResources_RsPVCOperationIgnore 64757 +#define JvResources_RsPVCOperationDownloadOnly 64758 +#define JvResources_RsPVCOperationDownloadInstall 64759 +#define JvResources_RsPVCWhatNewInS 64760 +#define JvResources_RsPVCChangesBetween 64761 +#define JvResources_RsPVCFileDownloadNotSuccessful 64762 +#define JvResources_RsPVCDownloadSuccessfulInstallManually 64763 +#define JvResources_RsPVCErrorStartingSetup 64764 +#define JvResources_RsPVCDownloadSuccessfullInstallNow 64765 +#define JvResources_RsPVInfoButtonCaption 64766 +#define JvResources_RsJvPropertyStoreMutexStorePropertiesProcedureName 64767 +#define JvResources_RsHistorySaveCaption 64768 +#define JvResources_RsHistoryClearCaption 64769 +#define JvResources_RsENoParametersDefined 64770 +#define JvResources_RsEAddObjectWrongObjectType 64771 +#define JvResources_RsEAddObjectSearchNameNotDefined 64772 +#define JvResources_RsEAddObjectDuplicateSearchNamesNotAllowed 64773 +#define JvResources_RsPVDefaultVersioninfoFileName 64774 +#define JvResources_RsPVTempFileNameExtension 64775 +#define JvResources_RsPVSiceB 64776 +#define JvResources_RsPVSiceKB 64777 +#define JvResources_RsPVSiceMB 64778 +#define JvResources_RsPVSiceGB 64779 +#define JvResources_RsPVCReleaseTypeAlpha 64780 +#define JvResources_RsPVCReleaseTypeBeta 64781 +#define JvResources_RsPVCReleaseTypeProduction 64782 +#define JvResources_RsPVCDownloading 64783 +#define JvResources_RsEUnsupportedState 64784 +#define JvResources_RsENoMoreWords 64785 +#define JvResources_RsEUnsupported 64786 +#define JvResources_RsECannotBeInstantiated 64787 +#define JvResources_RsETNodeGetNodeTypeUnknownClass 64788 +#define JvResources_RsENoMoreNodesToReturn 64789 +#define JvResources_RsENoMoreRecordsToReturn 64790 +#define JvResources_RsEWordInfoIndexOutOfBounds 64791 +#define JvResources_RsErrParameterMustBeEntered 64792 +#define JvResources_RsHistorySelectPath 64793 +#define JvResources_RsDialogCaption 64794 +#define JvResources_RsCancelButton 64795 +#define JvResources_RsHistoryLoadButton 64796 +#define JvResources_RsHistorySaveButton 64797 +#define JvResources_RsHistoryClearButton 64798 +#define JvResources_RsHistoryLoadCaption 64799 +#define JvResources_RsEDOrDDRequired 64800 +#define JvResources_RsEMOrMMRequired 64801 +#define JvResources_RsEYYOrYYYYRequired 64802 +#define JvResources_RsEInstanceAlreadyExists 64803 +#define JvResources_RsENameAlreadyExistsForInstance 64804 +#define JvResources_RsEInstanceNonexistent 64805 +#define JvResources_RsEMethodAlreadyExists 64806 +#define JvResources_RsENameAlreadyExistsForMethod 64807 +#define JvResources_RsEJvAssertSetTopIndex 64808 +#define JvResources_RsEJvAssertInspectorPainter 64809 +#define JvResources_RsEJvAssertDataParent 64810 +#define JvResources_RsEJvAssertParent 64811 +#define JvResources_RsEJvAssertPropInfo 64812 +#define JvResources_RsEJvAssertClassInfo 64813 +#define JvResources_RsEOwnerLinkError 64814 +#define JvResources_RsENoMoreElementsToReturn 64815 +#define JvResources_RsEJvInspDataNotAssigned 64816 +#define JvResources_RsEJvInspDataNoValue 64817 +#define JvResources_RsEJvInspDataStrTooLong 64818 +#define JvResources_RsEJvInspNoGenReg 64819 +#define JvResources_RsEJvInspPaintNotActive 64820 +#define JvResources_RsEJvInspPaintOnlyUsedOnce 64821 +#define JvResources_RsEInspectorInternalError 64822 +#define JvResources_RsESpecifierBeforeSeparator 64823 +#define JvResources_RsEDOrDDOnlyOnce 64824 +#define JvResources_RsEMOrMMOnlyOnce 64825 +#define JvResources_RsEYYOrYYYYOnlyOnce 64826 +#define JvResources_RsEOnlyDOrDDAllowed 64827 +#define JvResources_RsEOnlyMOrMMAllowed 64828 +#define JvResources_RsEOnlyYYOrYYYYAllowed 64829 +#define JvResources_RsEOnlyTwoSeparators 64830 +#define JvResources_RsEOnlyDMYSAllowed 64831 +#define JvResources_RsENoRegisteredControlClass 64832 +#define JvResources_RsENoFocusControl 64833 +#define JvResources_RsJvInspItemValueException 64834 +#define JvResources_RsJvInspItemUnInitialized 64835 +#define JvResources_RsJvInspItemUnassigned 64836 +#define JvResources_RsJvInspItemNoValue 64837 +#define JvResources_RsStringListEditorCaption 64838 +#define JvResources_RsXLinesCaption 64839 +#define JvResources_RsOneLineCaption 64840 +#define JvResources_RsEJvInspItemHasParent 64841 +#define JvResources_RsEJvInspItemNotAChild 64842 +#define JvResources_RsEJvInspItemColNotFound 64843 +#define JvResources_RsEJvInspItemItemIsNotCol 64844 +#define JvResources_RsEJvInspItemInvalidPropValue 64845 +#define JvResources_RsEJvInspDataNoAccessAs 64846 +#define JvResources_RsEJvInspDataNotInit 64847 +#define JvResources_RsEFmtInvalidPathAtIndex 64848 +#define JvResources_RsENotifyErrorFmt 64849 +#define JvResources_RsEProcessIsRunning 64850 +#define JvResources_RsEProcessNotRunning 64851 +#define JvResources_RsCntdownText 64852 +#define JvResources_RsCntdownMinText 64853 +#define JvResources_RsCntdownMinsText 64854 +#define JvResources_RsCntdownSecText 64855 +#define JvResources_RsCntdownSecsText 64856 +#define JvResources_RsEDSAAccessBool 64857 +#define JvResources_RsEDSAAccessFloat 64858 +#define JvResources_RsEDSAAccessInt64 64859 +#define JvResources_RsEDSAAccessInt 64860 +#define JvResources_RsEDSAAccessString 64861 +#define JvResources_RsEIntfCastError 64862 +#define JvResources_RsEUnsupportedControlClass 64863 +#define JvResources_RsDeleteSettings 64864 +#define JvResources_RsLoadCaption 64865 +#define JvResources_RsSaveCaption 64866 +#define JvResources_RsDeleteCaption 64867 +#define JvResources_RsEDynControlEngineNotDefined 64868 +#define JvResources_RsEDynAppStorageNotDefined 64869 +#define JvResources_RsEShellNotCompatible 64870 +#define JvResources_RsFileNameChange 64871 +#define JvResources_RsDirectoryNameChange 64872 +#define JvResources_RsAttributesChange 64873 +#define JvResources_RsSizeChange 64874 +#define JvResources_RsWriteChange 64875 +#define JvResources_RsSecurityChange 64876 +#define JvResources_RsEFmtCannotChangeName 64877 +#define JvResources_RsEFmtInvalidPath 64878 +#define JvResources_RsEFmtMaxCountExceeded 64879 +#define JvResources_RsUndoItem 64880 +#define JvResources_RsCutItem 64881 +#define JvResources_RsCopyItem 64882 +#define JvResources_RsPasteItem 64883 +#define JvResources_RsDeleteItem 64884 +#define JvResources_RsSelectAllItem 64885 +#define JvResources_RsNoName 64886 +#define JvResources_RsEReadValueFailed 64887 +#define JvResources_RsRootValueReplaceFmt 64888 +#define JvResources_RsEInvalidType 64889 +#define JvResources_RsEUnknownBaseType 64890 +#define JvResources_RsEInvalidPath 64891 +#define JvResources_RsENotAUniqueRootPath 64892 +#define JvResources_RsECircularReferenceOfStorages 64893 +#define JvResources_RsLoadSettings 64894 +#define JvResources_RsSaveSettings 64895 +#define JclResources_RsProductTypeDatacenterServer 64896 +#define JclResources_RsProductTypeEnterprise 64897 +#define JclResources_RsProductTypeWebEdition 64898 +#define JclResources_RsCannotWriteRefStream 64899 +#define JclResources_RsHasNotTD32Info 64900 +#define JclResources_RsELibraryNotFound 64901 +#define JclResources_RsEFunctionNotFound 64902 +#define JclSysInfo_RsUnknownAMDModel 64903 +#define VarPyth_SMultiDimensionalPropsNotSupported 64904 +#define VarPyth_SCantConvertArg 64905 +#define VarPyth_SCantConvertKeyToPythonObject 64906 +#define VarPyth_SCantConvertValueToPythonObject 64907 +#define VarPyth_SCantCreateNewSequenceObject 64908 +#define VarPyth_SExpectedPythonVariant 64909 +#define JvResources_RsButtonOKCaption 64910 +#define JvResources_RsButtonCancelCaption 64911 +#define JclResources_RsOSVersionWin98SE 64912 +#define JclResources_RsOSVersionWinME 64913 +#define JclResources_RsOSVersionWinNT3 64914 +#define JclResources_RsOSVersionWinNT4 64915 +#define JclResources_RsOSVersionWin2000 64916 +#define JclResources_RsOSVersionWinXP 64917 +#define JclResources_RsOSVersionWin2003 64918 +#define JclResources_RsOSVersionWin2003R2 64919 +#define JclResources_RsOSVersionWinXP64 64920 +#define JclResources_RsOSVersionWinVista 64921 +#define JclResources_RsOSVersionWinLonghorn 64922 +#define JclResources_RsProductTypeWorkStation 64923 +#define JclResources_RsProductTypeServer 64924 +#define JclResources_RsProductTypeAdvancedServer 64925 +#define JclResources_RsProductTypePersonal 64926 +#define JclResources_RsProductTypeProfessional 64927 +#define JclResources_RsIntelCacheDescr7D 64928 +#define JclResources_RsIntelCacheDescr7F 64929 +#define JclResources_RsIntelCacheDescr82 64930 +#define JclResources_RsIntelCacheDescr83 64931 +#define JclResources_RsIntelCacheDescr84 64932 +#define JclResources_RsIntelCacheDescr85 64933 +#define JclResources_RsIntelCacheDescr86 64934 +#define JclResources_RsIntelCacheDescr87 64935 +#define JclResources_RsIntelCacheDescrB0 64936 +#define JclResources_RsIntelCacheDescrB3 64937 +#define JclResources_RsIntelCacheDescrB4 64938 +#define JclResources_RsIntelCacheDescrF0 64939 +#define JclResources_RsIntelCacheDescrF1 64940 +#define JclResources_RsOSVersionWin95 64941 +#define JclResources_RsOSVersionWin95OSR2 64942 +#define JclResources_RsOSVersionWin98 64943 +#define JclResources_RsIntelCacheDescr57 64944 +#define JclResources_RsIntelCacheDescr5B 64945 +#define JclResources_RsIntelCacheDescr5C 64946 +#define JclResources_RsIntelCacheDescr5D 64947 +#define JclResources_RsIntelCacheDescr60 64948 +#define JclResources_RsIntelCacheDescr66 64949 +#define JclResources_RsIntelCacheDescr67 64950 +#define JclResources_RsIntelCacheDescr68 64951 +#define JclResources_RsIntelCacheDescr70 64952 +#define JclResources_RsIntelCacheDescr71 64953 +#define JclResources_RsIntelCacheDescr72 64954 +#define JclResources_RsIntelCacheDescr78 64955 +#define JclResources_RsIntelCacheDescr79 64956 +#define JclResources_RsIntelCacheDescr7A 64957 +#define JclResources_RsIntelCacheDescr7B 64958 +#define JclResources_RsIntelCacheDescr7C 64959 +#define JclResources_RsIntelCacheDescr29 64960 +#define JclResources_RsIntelCacheDescr2C 64961 +#define JclResources_RsIntelCacheDescr30 64962 +#define JclResources_RsIntelCacheDescr40 64963 +#define JclResources_RsIntelCacheDescr41 64964 +#define JclResources_RsIntelCacheDescr42 64965 +#define JclResources_RsIntelCacheDescr43 64966 +#define JclResources_RsIntelCacheDescr44 64967 +#define JclResources_RsIntelCacheDescr45 64968 +#define JclResources_RsIntelCacheDescr46 64969 +#define JclResources_RsIntelCacheDescr47 64970 +#define JclResources_RsIntelCacheDescr49 64971 +#define JclResources_RsIntelCacheDescr50 64972 +#define JclResources_RsIntelCacheDescr51 64973 +#define JclResources_RsIntelCacheDescr52 64974 +#define JclResources_RsIntelCacheDescr56 64975 +#define JclResources_RsSynchCreateEvent 64976 +#define JclResources_RsSynchCreateMutex 64977 +#define JclResources_RsIntelCacheDescr00 64978 +#define JclResources_RsIntelCacheDescr01 64979 +#define JclResources_RsIntelCacheDescr02 64980 +#define JclResources_RsIntelCacheDescr03 64981 +#define JclResources_RsIntelCacheDescr04 64982 +#define JclResources_RsIntelCacheDescr05 64983 +#define JclResources_RsIntelCacheDescr06 64984 +#define JclResources_RsIntelCacheDescr08 64985 +#define JclResources_RsIntelCacheDescr0A 64986 +#define JclResources_RsIntelCacheDescr0B 64987 +#define JclResources_RsIntelCacheDescr0C 64988 +#define JclResources_RsIntelCacheDescr22 64989 +#define JclResources_RsIntelCacheDescr23 64990 +#define JclResources_RsIntelCacheDescr25 64991 +#define JclResources_RsRTTIPropCount 64992 +#define JclResources_RsRTTIUnitName 64993 +#define JclResources_RsRTTIBasedOn 64994 +#define JclResources_RsRTTIFloatType 64995 +#define JclResources_RsRTTIMethodKind 64996 +#define JclResources_RsRTTIParamCount 64997 +#define JclResources_RsRTTIReturnType 64998 +#define JclResources_RsRTTIMaxLen 64999 +#define JclResources_RsRTTIElSize 65000 +#define JclResources_RsRTTIElType 65001 +#define JclResources_RsRTTIElNeedCleanup 65002 +#define JclResources_RsRTTIVarType 65003 +#define JclResources_RsDeclarationFormat 65004 +#define JclResources_RsBlankSearchString 65005 +#define JclResources_RsInvalidEmptyStringItem 65006 +#define JclResources_RsArgumentOutOfRange 65007 +#define JclResources_RsRTTIField 65008 +#define JclResources_RsRTTIStaticMethod 65009 +#define JclResources_RsRTTIVirtualMethod 65010 +#define JclResources_RsRTTIIndex 65011 +#define JclResources_RsRTTIDefault 65012 +#define JclResources_RsRTTIName 65013 +#define JclResources_RsRTTIType 65014 +#define JclResources_RsRTTIFlags 65015 +#define JclResources_RsRTTIGUID 65016 +#define JclResources_RsRTTITypeKind 65017 +#define JclResources_RsRTTIOrdinalType 65018 +#define JclResources_RsRTTIMinValue 65019 +#define JclResources_RsRTTIMaxValue 65020 +#define JclResources_RsRTTINameList 65021 +#define JclResources_RsRTTIClassName 65022 +#define JclResources_RsRTTIParent 65023 +#define JclResources_RsHKCCShort 65024 +#define JclResources_RsHKDDShort 65025 +#define JclResources_RsRTTIValueOutOfRange 65026 +#define JclResources_RsRTTIUnknownIdentifier 65027 +#define JclResources_RsRTTIVar 65028 +#define JclResources_RsRTTIConst 65029 +#define JclResources_RsRTTIArrayOf 65030 +#define JclResources_RsRTTIOut 65031 +#define JclResources_RsRTTIOrdinal 65032 +#define JclResources_RsRTTITrue 65033 +#define JclResources_RsRTTIFalse 65034 +#define JclResources_RsRTTITypeError 65035 +#define JclResources_RsRTTITypeInfoAt 65036 +#define JclResources_RsRTTIPropRead 65037 +#define JclResources_RsRTTIPropWrite 65038 +#define JclResources_RsRTTIPropStored 65039 +#define JclResources_RsUnableToOpenKeyRead 65040 +#define JclResources_RsUnableToAccessValue 65041 +#define JclResources_RsWrongDataType 65042 +#define JclResources_RsInconsistentPath 65043 +#define JclResources_RsHKCRLong 65044 +#define JclResources_RsHKCULong 65045 +#define JclResources_RsHKLMLong 65046 +#define JclResources_RsHKUSLong 65047 +#define JclResources_RsHKPDLong 65048 +#define JclResources_RsHKCCLong 65049 +#define JclResources_RsHKDDLong 65050 +#define JclResources_RsHKCRShort 65051 +#define JclResources_RsHKCUShort 65052 +#define JclResources_RsHKLMShort 65053 +#define JclResources_RsHKUSShort 65054 +#define JclResources_RsHKPDShort 65055 +#define JclResources_RsMapiErrTYPE_NOT_SUPPORTED 65056 +#define JclResources_RsMapiErrAMBIGUOUS_RECIPIENT 65057 +#define JclResources_RsMapiErrMESSAGE_IN_USE 65058 +#define JclResources_RsMapiErrNETWORK_FAILURE 65059 +#define JclResources_RsMapiErrINVALID_EDITFIELDS 65060 +#define JclResources_RsMapiErrINVALID_RECIPS 65061 +#define JclResources_RsMapiErrNOT_SUPPORTED 65062 +#define JclResources_RsMapiMailORIG 65063 +#define JclResources_RsMapiMailTO 65064 +#define JclResources_RsMapiMailCC 65065 +#define JclResources_RsMapiMailBCC 65066 +#define JclResources_RsPeReadOnlyStream 65067 +#define JclResources_RsPeCantOpen 65068 +#define JclResources_RsPeNotPE 65069 +#define JclResources_RsPeNotResDir 65070 +#define JclResources_RsPeSectionNotFound 65071 +#define JclResources_RsMapiErrLOGIN_FAILURE 65072 +#define JclResources_RsMapiErrDISK_FULL 65073 +#define JclResources_RsMapiErrINSUFFICIENT_MEMORY 65074 +#define JclResources_RsMapiErrACCESS_DENIED 65075 +#define JclResources_RsMapiErrTOO_MANY_SESSIONS 65076 +#define JclResources_RsMapiErrTOO_MANY_FILES 65077 +#define JclResources_RsMapiErrTOO_MANY_RECIPIENTS 65078 +#define JclResources_RsMapiErrATTACHMENT_NOT_FOUND 65079 +#define JclResources_RsMapiErrATTACHMENT_OPEN_FAILURE 65080 +#define JclResources_RsMapiErrATTACHMENT_WRITE_FAILURE 65081 +#define JclResources_RsMapiErrUNKNOWN_RECIPIENT 65082 +#define JclResources_RsMapiErrBAD_RECIPTYPE 65083 +#define JclResources_RsMapiErrNO_MESSAGES 65084 +#define JclResources_RsMapiErrINVALID_MESSAGE 65085 +#define JclResources_RsMapiErrTEXT_TOO_LARGE 65086 +#define JclResources_RsMapiErrINVALID_SESSION 65087 +#define ComConst_SVarNotObject 65088 +#define ComConst_STooManyParams 65089 +#define ComConst_SDCOMNotInstalled 65090 +#define JclResources_RsWin32Prefix 65091 +#define JclResources_RsCannotCreateDir 65092 +#define JclResources_RsFileUtilsNoVersionInfo 65093 +#define JclResources_RsCreateFileMapping 65094 +#define JclResources_RsCreateFileMappingView 65095 +#define JclResources_RsViewNeedsMapping 65096 +#define JclResources_RsFailedToObtainSize 65097 +#define JclResources_RsDefaultFileTypeName 65098 +#define JclResources_RsMapiError 65099 +#define JclResources_RsMapiMissingExport 65100 +#define JclResources_RsMapiMailNoClient 65101 +#define JclResources_RsMapiErrUSER_ABORT 65102 +#define JclResources_RsMapiErrFAILURE 65103 +#define ComStrs_sRichEditInsertError 65104 +#define ComStrs_sRichEditLoadFail 65105 +#define ComStrs_sRichEditSaveFail 65106 +#define ComStrs_sPageIndexError 65107 +#define ComStrs_sInvalidComCtl32 65108 +#define ComStrs_sDateTimeMax 65109 +#define ComStrs_sDateTimeMin 65110 +#define ComStrs_sNeedAllowNone 65111 +#define ComStrs_sFailSetCalDateTime 65112 +#define ComStrs_sFailSetCalMaxSelRange 65113 +#define ComStrs_sFailSetCalMinMaxRange 65114 +#define ComStrs_sFailsetCalSelRange 65115 +#define TntSystem_SBufferOverflow 65116 +#define TntSystem_SInvalidUTF7 65117 +#define ComConst_SOleError 65118 +#define ComConst_SNoMethod 65119 +#define TB2Consts_STBToolbarItemReinserted 65120 +#define TB2Consts_STBChevronItemMoreButtonsHint 65121 +#define TB2Consts_STBMRUListItemDefCaption 65122 +#define TB2Consts_STBDockParentNotAllowed 65123 +#define TB2Consts_STBDockCannotChangePosition 65124 +#define TB2Consts_STBToolwinDockedToNameNotSet 65125 +#define ComStrs_sTabFailClear 65126 +#define ComStrs_sTabFailDelete 65127 +#define ComStrs_sTabFailRetrieve 65128 +#define ComStrs_sTabFailGetObject 65129 +#define ComStrs_sTabFailSet 65130 +#define ComStrs_sTabFailSetObject 65131 +#define ComStrs_sTabMustBeMultiLine 65132 +#define ComStrs_sInvalidIndex 65133 +#define ComStrs_sInsertError 65134 +#define ComStrs_sInvalidOwner 65135 +#define SynHighlighterPython_SYNS_FunctionName 65136 +#define SynHighlighterPython_SYNS_ClassName 65137 +#define SynHighlighterPython_SYNS_FriendlyCommentedCode 65138 +#define SynHighlighterPython_SYNS_FriendlyFunctionName 65139 +#define SynHighlighterPython_SYNS_FriendlyClassName 65140 +#define SynHighlighterPython_SYNS_AttrBanner 65141 +#define SynHighlighterPython_SYNS_FriendlyAttrBanner 65142 +#define SynHighlighterPython_SYNS_AttrOutput 65143 +#define SynHighlighterPython_SYNS_FriendlyAttrOutput 65144 +#define SynHighlighterPython_SYNS_AttrTraceback 65145 +#define SynHighlighterPython_SYNS_FriendlyAttrTraceback 65146 +#define SynHighlighterPython_SYNS_AttrPrompt 65147 +#define SynHighlighterPython_SYNS_FriendlyAttrPrompt 65148 +#define SynHighlighterPython_SYNS_LangPythonInterpreter 65149 +#define SynHighlighterPython_SYNS_FriendlyLangPythonInterpreter 65150 +#define TB2Consts_STBToolbarIndexOutOfBounds 65151 +#define SynEditStrConst_SYNS_PreviewScrollInfoFmt 65152 +#define SynEditStrConst_SYNS_EDuplicateShortcut 65153 +#define SynEditStrConst_SYNS_FilterHTML 65154 +#define SynEditStrConst_SYNS_FilterPython 65155 +#define SynEditStrConst_SYNS_FilterINI 65156 +#define SynEditStrConst_SYNS_FilterCSS 65157 +#define SynEditStrConst_SYNS_FilterXML 65158 +#define SynEditStrConst_SYNS_FriendlyLangHTML 65159 +#define SynEditStrConst_SYNS_FriendlyLangPython 65160 +#define SynEditStrConst_SYNS_FriendlyLangINI 65161 +#define SynEditStrConst_SYNS_FriendlyLangCSS 65162 +#define SynEditStrConst_SYNS_FriendlyLangXML 65163 +#define SynEditStrConst_SYNS_FriendlyLangUnknown 65164 +#define SynEditTextBuffer_SListIndexOutOfBounds 65165 +#define SynEditTextBuffer_SInvalidCapacity 65166 +#define SynHighlighterPython_SYNS_CommentedCode 65167 +#define SynEditStrConst_SYNS_FriendlyAttrProcessingInstr 65168 +#define SynEditStrConst_SYNS_FriendlyAttrProperty 65169 +#define SynEditStrConst_SYNS_FriendlyAttrReservedWord 65170 +#define SynEditStrConst_SYNS_FriendlyAttrSection 65171 +#define SynEditStrConst_SYNS_FriendlyAttrSpace 65172 +#define SynEditStrConst_SYNS_FriendlyAttrString 65173 +#define SynEditStrConst_SYNS_FriendlyAttrSymbol 65174 +#define SynEditStrConst_SYNS_FriendlyAttrSyntaxError 65175 +#define SynEditStrConst_SYNS_FriendlyAttrSystem 65176 +#define SynEditStrConst_SYNS_FriendlyAttrText 65177 +#define SynEditStrConst_SYNS_FriendlyAttrUndefinedProperty 65178 +#define SynEditStrConst_SYNS_FriendlyAttrUnknownWord 65179 +#define SynEditStrConst_SYNS_FriendlyAttrValue 65180 +#define SynEditStrConst_SYNS_FriendlyAttrWhitespace 65181 +#define SynEditStrConst_SYNS_ScrollInfoFmt 65182 +#define SynEditStrConst_SYNS_ScrollInfoFmtTop 65183 +#define SynEditStrConst_SYNS_FriendlyAttrColor 65184 +#define SynEditStrConst_SYNS_FriendlyAttrComment 65185 +#define SynEditStrConst_SYNS_FriendlyAttrDOCTYPESection 65186 +#define SynEditStrConst_SYNS_FriendlyAttrDocumentation 65187 +#define SynEditStrConst_SYNS_FriendlyAttrElementName 65188 +#define SynEditStrConst_SYNS_FriendlyAttrEntityReference 65189 +#define SynEditStrConst_SYNS_FriendlyAttrEscapeAmpersand 65190 +#define SynEditStrConst_SYNS_FriendlyAttrFloat 65191 +#define SynEditStrConst_SYNS_FriendlyAttrHexadecimal 65192 +#define SynEditStrConst_SYNS_FriendlyAttrIdentifier 65193 +#define SynEditStrConst_SYNS_FriendlyAttrKey 65194 +#define SynEditStrConst_SYNS_FriendlyAttrNamespaceAttrName 65195 +#define SynEditStrConst_SYNS_FriendlyAttrNamespaceAttrValue 65196 +#define SynEditStrConst_SYNS_FriendlyAttrNonReservedKeyword 65197 +#define SynEditStrConst_SYNS_FriendlyAttrNumber 65198 +#define SynEditStrConst_SYNS_FriendlyAttrOctal 65199 +#define ExtCtrls_clNameInfoBk 65200 +#define ExtCtrls_clNameInfoText 65201 +#define ExtCtrls_clNameMenu 65202 +#define ExtCtrls_clNameMenuBar 65203 +#define ExtCtrls_clNameMenuHighlight 65204 +#define ExtCtrls_clNameMenuText 65205 +#define ExtCtrls_clNameNone 65206 +#define ExtCtrls_clNameScrollBar 65207 +#define ExtCtrls_clName3DDkShadow 65208 +#define ExtCtrls_clName3DLight 65209 +#define ExtCtrls_clNameWindow 65210 +#define ExtCtrls_clNameWindowFrame 65211 +#define ExtCtrls_clNameWindowText 65212 +#define SynEditStrConst_SYNS_FriendlyAttrAttributeName 65213 +#define SynEditStrConst_SYNS_FriendlyAttrAttributeValue 65214 +#define SynEditStrConst_SYNS_FriendlyAttrCDATASection 65215 +#define ExtCtrls_clNameBackground 65216 +#define ExtCtrls_clNameBtnFace 65217 +#define ExtCtrls_clNameBtnHighlight 65218 +#define ExtCtrls_clNameBtnShadow 65219 +#define ExtCtrls_clNameBtnText 65220 +#define ExtCtrls_clNameCaptionText 65221 +#define ExtCtrls_clNameDefault 65222 +#define ExtCtrls_clNameGradientActiveCaption 65223 +#define ExtCtrls_clNameGradientInactiveCaption 65224 +#define ExtCtrls_clNameGrayText 65225 +#define ExtCtrls_clNameHighlight 65226 +#define ExtCtrls_clNameHighlightText 65227 +#define ExtCtrls_clNameHotLight 65228 +#define ExtCtrls_clNameInactiveBorder 65229 +#define ExtCtrls_clNameInactiveCaption 65230 +#define ExtCtrls_clNameInactiveCaptionText 65231 +#define ExtCtrls_clNameGray 65232 +#define ExtCtrls_clNameSilver 65233 +#define ExtCtrls_clNameRed 65234 +#define ExtCtrls_clNameLime 65235 +#define ExtCtrls_clNameYellow 65236 +#define ExtCtrls_clNameBlue 65237 +#define ExtCtrls_clNameFuchsia 65238 +#define ExtCtrls_clNameAqua 65239 +#define ExtCtrls_clNameWhite 65240 +#define ExtCtrls_clNameMoneyGreen 65241 +#define ExtCtrls_clNameSkyBlue 65242 +#define ExtCtrls_clNameCream 65243 +#define ExtCtrls_clNameMedGray 65244 +#define ExtCtrls_clNameActiveBorder 65245 +#define ExtCtrls_clNameActiveCaption 65246 +#define ExtCtrls_clNameAppWorkSpace 65247 +#define Consts_SListBoxMustBeVirtual 65248 +#define Consts_SNoGetItemEventHandler 65249 +#define Consts_SANSIEncoding 65250 +#define Consts_SASCIIEncoding 65251 +#define Consts_SUnicodeEncoding 65252 +#define Consts_SBigEndianEncoding 65253 +#define Consts_SUTF8Encoding 65254 +#define Consts_SUTF7Encoding 65255 +#define Consts_SPageControlNotSet 65256 +#define ExtCtrls_clNameBlack 65257 +#define ExtCtrls_clNameMaroon 65258 +#define ExtCtrls_clNameGreen 65259 +#define ExtCtrls_clNameOlive 65260 +#define ExtCtrls_clNameNavy 65261 +#define ExtCtrls_clNamePurple 65262 +#define ExtCtrls_clNameTeal 65263 +#define Consts_SInvalidPrinterOp 65264 +#define Consts_SNoDefaultPrinter 65265 +#define Consts_SDuplicateMenus 65266 +#define Consts_SPictureLabel 65267 +#define Consts_SPictureDesc 65268 +#define Consts_SPreviewLabel 65269 +#define Consts_SCannotOpenAVI 65270 +#define Consts_SDockedCtlNeedsName 65271 +#define Consts_SDockTreeRemoveError 65272 +#define Consts_SDockZoneNotFound 65273 +#define Consts_SDockZoneHasNoCtl 65274 +#define Consts_SDockZoneVersionConflict 65275 +#define Consts_SColorBoxCustomCaption 65276 +#define Consts_SMultiSelectRequired 65277 +#define Consts_SSeparator 65278 +#define Consts_SErrorSettingCount 65279 +#define Consts_SmkcAlt 65280 +#define Consts_srNone 65281 +#define Consts_SOutOfRange 65282 +#define Consts_sAllFilter 65283 +#define Consts_SInsertLineError 65284 +#define Consts_SConfirmCreateDir 65285 +#define Consts_SSelectDirCap 65286 +#define Consts_SDirNameCap 65287 +#define Consts_SDrivesCap 65288 +#define Consts_SDirsCap 65289 +#define Consts_SFilesCap 65290 +#define Consts_SNetworkCap 65291 +#define Consts_SInvalidClipFmt 65292 +#define Consts_SIconToClipboard 65293 +#define Consts_SCannotOpenClipboard 65294 +#define Consts_SInvalidMemoSize 65295 +#define Consts_SmkcTab 65296 +#define Consts_SmkcEsc 65297 +#define Consts_SmkcEnter 65298 +#define Consts_SmkcSpace 65299 +#define Consts_SmkcPgUp 65300 +#define Consts_SmkcPgDn 65301 +#define Consts_SmkcEnd 65302 +#define Consts_SmkcHome 65303 +#define Consts_SmkcLeft 65304 +#define Consts_SmkcUp 65305 +#define Consts_SmkcRight 65306 +#define Consts_SmkcDown 65307 +#define Consts_SmkcIns 65308 +#define Consts_SmkcDel 65309 +#define Consts_SmkcShift 65310 +#define Consts_SmkcCtrl 65311 +#define Consts_SMsgDlgWarning 65312 +#define Consts_SMsgDlgError 65313 +#define Consts_SMsgDlgInformation 65314 +#define Consts_SMsgDlgConfirm 65315 +#define Consts_SMsgDlgYes 65316 +#define Consts_SMsgDlgNo 65317 +#define Consts_SMsgDlgOK 65318 +#define Consts_SMsgDlgCancel 65319 +#define Consts_SMsgDlgHelp 65320 +#define Consts_SMsgDlgAbort 65321 +#define Consts_SMsgDlgRetry 65322 +#define Consts_SMsgDlgIgnore 65323 +#define Consts_SMsgDlgAll 65324 +#define Consts_SMsgDlgNoToAll 65325 +#define Consts_SMsgDlgYesToAll 65326 +#define Consts_SmkcBkSp 65327 +#define Consts_SCancelButton 65328 +#define Consts_SYesButton 65329 +#define Consts_SNoButton 65330 +#define Consts_SHelpButton 65331 +#define Consts_SCloseButton 65332 +#define Consts_SIgnoreButton 65333 +#define Consts_SRetryButton 65334 +#define Consts_SAbortButton 65335 +#define Consts_SAllButton 65336 +#define Consts_SCannotDragForm 65337 +#define Consts_SVMetafiles 65338 +#define Consts_SVEnhMetafiles 65339 +#define Consts_SVIcons 65340 +#define Consts_SVBitmaps 65341 +#define Consts_SMaskErr 65342 +#define Consts_SMaskEditErr 65343 +#define Consts_SVisibleChanged 65344 +#define Consts_SCannotShowModal 65345 +#define Consts_SScrollBarRange 65346 +#define Consts_SPropertyOutOfRange 65347 +#define Consts_SMenuIndexError 65348 +#define Consts_SMenuReinserted 65349 +#define Consts_SMenuNotFound 65350 +#define Consts_SNoTimers 65351 +#define Consts_SNotPrinting 65352 +#define Consts_SPrinting 65353 +#define Consts_SInvalidPrinter 65354 +#define Consts_SDeviceOnPort 65355 +#define Consts_SGroupIndexTooLow 65356 +#define Consts_SNoMDIForm 65357 +#define Consts_SControlParentSetToSelf 65358 +#define Consts_SOKButton 65359 +#define Consts_SUnknownExtension 65360 +#define Consts_SUnknownClipboardFormat 65361 +#define Consts_SOutOfResources 65362 +#define Consts_SNoCanvasHandle 65363 +#define Consts_SInvalidImageSize 65364 +#define Consts_SInvalidImageList 65365 +#define Consts_SReplaceImage 65366 +#define Consts_SImageIndexError 65367 +#define Consts_SImageReadFail 65368 +#define Consts_SImageWriteFail 65369 +#define Consts_SWindowDCError 65370 +#define Consts_SWindowClass 65371 +#define Consts_SCannotFocus 65372 +#define Consts_SParentRequired 65373 +#define Consts_SParentGivenNotAParent 65374 +#define Consts_SMDIChildNotVisible 65375 +#define HelpIntfs_hNoTableOfContents 65376 +#define HelpIntfs_hNothingFound 65377 +#define HelpIntfs_hNoContext 65378 +#define HelpIntfs_hNoContextFound 65379 +#define HelpIntfs_hNoTopics 65380 +#define Consts_SCantWriteResourceStreamError 65381 +#define Consts_SInvalidTabPosition 65382 +#define Consts_SInvalidTabStyle 65383 +#define Consts_SInvalidBitmap 65384 +#define Consts_SInvalidIcon 65385 +#define Consts_SInvalidMetafile 65386 +#define Consts_SInvalidPixelFormat 65387 +#define Consts_SInvalidImage 65388 +#define Consts_SScanLine 65389 +#define Consts_SChangeIconSize 65390 +#define Consts_SOleGraphic 65391 +#define RTLConsts_SListCountError 65392 +#define RTLConsts_SListIndexError 65393 +#define RTLConsts_SMemoryStreamError 65394 +#define RTLConsts_SPropertyException 65395 +#define RTLConsts_SReadError 65396 +#define RTLConsts_SReadOnlyProperty 65397 +#define RTLConsts_SRegGetDataFailed 65398 +#define RTLConsts_SRegSetDataFailed 65399 +#define RTLConsts_SResNotFound 65400 +#define RTLConsts_SSeekNotImplemented 65401 +#define RTLConsts_SSortedListError 65402 +#define RTLConsts_SUnknownGroup 65403 +#define RTLConsts_SUnknownProperty 65404 +#define RTLConsts_SWriteError 65405 +#define RTLConsts_SThreadCreateError 65406 +#define RTLConsts_SThreadError 65407 +#define RTLConsts_SDuplicateItem 65408 +#define RTLConsts_SDuplicateName 65409 +#define RTLConsts_SDuplicateString 65410 +#define RTLConsts_SFCreateErrorEx 65411 +#define RTLConsts_SFOpenErrorEx 65412 +#define RTLConsts_SIniFileWriteError 65413 +#define RTLConsts_SInvalidFileName 65414 +#define RTLConsts_SInvalidImage 65415 +#define RTLConsts_SInvalidName 65416 +#define RTLConsts_SInvalidProperty 65417 +#define RTLConsts_SInvalidPropertyElement 65418 +#define RTLConsts_SInvalidPropertyPath 65419 +#define RTLConsts_SInvalidPropertyType 65420 +#define RTLConsts_SInvalidPropertyValue 65421 +#define RTLConsts_SInvalidRegType 65422 +#define RTLConsts_SListCapacityError 65423 +#define SysConst_SShortDayNameSat 65424 +#define SysConst_SLongDayNameSun 65425 +#define SysConst_SLongDayNameMon 65426 +#define SysConst_SLongDayNameTue 65427 +#define SysConst_SLongDayNameWed 65428 +#define SysConst_SLongDayNameThu 65429 +#define SysConst_SLongDayNameFri 65430 +#define SysConst_SLongDayNameSat 65431 +#define SysConst_SCannotCreateDir 65432 +#define RTLConsts_SAncestorNotFound 65433 +#define RTLConsts_SAssignError 65434 +#define RTLConsts_SBitsIndexError 65435 +#define RTLConsts_SCantWriteResourceStreamError 65436 +#define RTLConsts_SCheckSynchronizeError 65437 +#define RTLConsts_SClassNotFound 65438 +#define RTLConsts_SDuplicateClass 65439 +#define SysConst_SLongMonthNameMar 65440 +#define SysConst_SLongMonthNameApr 65441 +#define SysConst_SLongMonthNameMay 65442 +#define SysConst_SLongMonthNameJun 65443 +#define SysConst_SLongMonthNameJul 65444 +#define SysConst_SLongMonthNameAug 65445 +#define SysConst_SLongMonthNameSep 65446 +#define SysConst_SLongMonthNameOct 65447 +#define SysConst_SLongMonthNameNov 65448 +#define SysConst_SLongMonthNameDec 65449 +#define SysConst_SShortDayNameSun 65450 +#define SysConst_SShortDayNameMon 65451 +#define SysConst_SShortDayNameTue 65452 +#define SysConst_SShortDayNameWed 65453 +#define SysConst_SShortDayNameThu 65454 +#define SysConst_SShortDayNameFri 65455 +#define SysConst_SOSError 65456 +#define SysConst_SUnkOSError 65457 +#define SysConst_SShortMonthNameJan 65458 +#define SysConst_SShortMonthNameFeb 65459 +#define SysConst_SShortMonthNameMar 65460 +#define SysConst_SShortMonthNameApr 65461 +#define SysConst_SShortMonthNameMay 65462 +#define SysConst_SShortMonthNameJun 65463 +#define SysConst_SShortMonthNameJul 65464 +#define SysConst_SShortMonthNameAug 65465 +#define SysConst_SShortMonthNameSep 65466 +#define SysConst_SShortMonthNameOct 65467 +#define SysConst_SShortMonthNameNov 65468 +#define SysConst_SShortMonthNameDec 65469 +#define SysConst_SLongMonthNameJan 65470 +#define SysConst_SLongMonthNameFeb 65471 +#define SysConst_SVarTypeNotUsableWithPrefix 65472 +#define SysConst_SVarTypeTooManyCustom 65473 +#define SysConst_SVarTypeCouldNotConvert 65474 +#define SysConst_SVarTypeConvertOverflow 65475 +#define SysConst_SVarOverflow 65476 +#define SysConst_SVarInvalid 65477 +#define SysConst_SVarBadType 65478 +#define SysConst_SVarNotImplemented 65479 +#define SysConst_SVarUnexpected 65480 +#define SysConst_SExternalException 65481 +#define SysConst_SAssertionFailed 65482 +#define SysConst_SIntfCastError 65483 +#define SysConst_SSafecallException 65484 +#define SysConst_SAssertError 65485 +#define SysConst_SAbstractError 65486 +#define SysConst_SModuleAccessViolation 65487 +#define SysConst_SExceptTitle 65488 +#define SysConst_SInvalidFormat 65489 +#define SysConst_SArgumentMissing 65490 +#define SysConst_SDispatchError 65491 +#define SysConst_SReadAccess 65492 +#define SysConst_SWriteAccess 65493 +#define SysConst_SFormatTooLong 65494 +#define SysConst_SVarArrayCreate 65495 +#define SysConst_SVarArrayBounds 65496 +#define SysConst_SVarArrayLocked 65497 +#define SysConst_SInvalidVarCast 65498 +#define SysConst_SInvalidVarOp 65499 +#define SysConst_SInvalidVarNullOp 65500 +#define SysConst_SInvalidVarOpWithHResultWithPrefix 65501 +#define SysConst_SVarTypeOutOfRangeWithPrefix 65502 +#define SysConst_SVarTypeAlreadyUsedWithPrefix 65503 +#define SysConst_SDivByZero 65504 +#define SysConst_SRangeError 65505 +#define SysConst_SIntOverflow 65506 +#define SysConst_SInvalidOp 65507 +#define SysConst_SZeroDivide 65508 +#define SysConst_SOverflow 65509 +#define SysConst_SUnderflow 65510 +#define SysConst_SInvalidPointer 65511 +#define SysConst_SInvalidCast 65512 +#define SysConst_SAccessViolationArg3 65513 +#define SysConst_SAccessViolationNoArg 65514 +#define SysConst_SStackOverflow 65515 +#define SysConst_SControlC 65516 +#define SysConst_SPrivilege 65517 +#define SysConst_SOperationAborted 65518 +#define SysConst_SException 65519 +#define SysConst_SInvalidInteger 65520 +#define SysConst_SInvalidFloat 65521 +#define SysConst_SInvalidDate 65522 +#define SysConst_SInvalidTime 65523 +#define SysConst_SInvalidDateTime 65524 +#define SysConst_STimeEncodeError 65525 +#define SysConst_SDateEncodeError 65526 +#define SysConst_SOutOfMemory 65527 +#define SysConst_SInOutError 65528 +#define SysConst_SFileNotFound 65529 +#define SysConst_SInvalidFilename 65530 +#define SysConst_STooManyOpenFiles 65531 +#define SysConst_SAccessDenied 65532 +#define SysConst_SEndOfFile 65533 +#define SysConst_SDiskFull 65534 +#define SysConst_SInvalidInput 65535 +STRINGTABLE +BEGIN + dlgExceptionMail_RsActiveControl, "Active Controls hierarchy:" + dlgExceptionMail_RsThread, "Thread: %s" + dlgExceptionMail_RsMissingVersionInfo, "(no version info)" + dlgExceptionMail_RsSendBugReportAddress, "pyscripter@gmail.com" + dlgExceptionMail_RsSendBugReportSubject, "PyScripter Bug Report" + frmCommandOutput_SPrintTimeOut, "Timeout: %d ms" + frmPyIDEMain_SModified, "Modified" + frmFunctionList_SAllString, "" + frmFunctionList_SNoneString, "" + frmFunctionList_SParseStatistics, "Module processed in %g seconds" + frmFunctionList_SInvalidIndex, "Invalid index number" + WinHelpViewer_hNoKeyword, "No help keyword specified." + dmCommands_S_ERROR_NO_ERROR_STRING, "Unspecified WinInet error" + dlgExceptionMail_RsAppError, "%s - application error" + dlgExceptionMail_RsExceptionClass, "Exception class: %s" + dlgExceptionMail_RsExceptionAddr, "Exception address: %p" + dlgExceptionMail_RsStackList, "Stack list, generated %s" + dlgExceptionMail_RsModulesList, "List of loaded modules:" + dlgExceptionMail_RsOSVersion, "System : %s %s, Version: %d.%d, Build: %x, \"%s\"" + dlgExceptionMail_RsProcessor, "Processor: %s, %s, %d MHz %s%s" + dlgExceptionMail_RsScreenRes, "Display : %dx%d pixels, %d bpp" + frmToDo_SDoneTodoDesignation, "Done" + cParameters_SEnterParameterCaption, "Parameter replacement" + cParameters_SEnterParameterText, "Enter parameter value" + cParameters_SParamCircularReference, "Parameter \"%s\" is referenced circulary" + cParameters_SParameterNotFound, "Parameter with name \"%s\" is not found" + cParameters_SModifierNotFound, "Modifier with name \"%s\" is not found" + cParameters_SObjectNotFound, "Object with name \"%s\" is not found" + cParameters_SPropertyNotFound, "Object \"%s\" does not have registered property with name \"%s\"" + cParameters_SInvalidParameterFormat, "\"%s\" is not valid parameter format" + cParameters_SInvalidConditionFormat, "Invalid condition format" + cParameters_SDuplicateModifier, "Duplicate Modifier \"%s\"" + frmCommandOutput_sProcessTerminated, "Process \"%s\" terminated, ExitCode: %.8x" + frmCommandOutput_SDirNotFound, "Directory \"%s\" does not exists" + frmCommandOutput_SProcessRunning, "One Process is still running, stop it first." + frmCommandOutput_SPrintCommandLine, "Commandline: %s" + frmCommandOutput_SPrintWorkingDir, "Workingdirectory: " + frmFindResults_SMatches, "%d matches" + frmFindResults_SMatchContextNotAvail, "Unable to load match context lines" + frmFindResults_SAllAlphaNumericChars, "ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz1234567890" + frmFindResults_SProcessing, "Processing %s" + frmFindResults_SFileChangedAbort, "%s\r\nhas changed since it was searched. Replacement aborted.\r\nExpected: %s\r\nFound: %s" + frmFindResults_SFileSkipped, "The following file will be skipped: " + frmFindResults_SCouldNotBackup, "Could not backup file \"%s\" and will skip it" + cFindInFiles_SNoFileOpen, "No editor is currently active" + cFindInFiles_SSpecifiedDirectoryDoesNotExist, "The search directory %s does not exist" + dlgToDoOptions_SLeadingDollarNotAllowed, "A leading \"$\" character is not allowed in tokens, as this can conflict with Object Pascal compiler options.\r\n\r\nPlease choose a different token." + dlgToDoOptions_SEmptyTokenTextError, "You cannot insert a token that only consists of white space." + frmToDo_SHigh, "High" + frmToDo_SNormal, "Normal" + frmToDo_SLow, "Low" + frmToDo_SDone, "Done" + frmToDo_STodoItems, "To Do Items" + OleConst_sNoRunningObject, "Unable to retrieve a pointer to a running object registered with OLE for %s/%s" + dlgConfirmReplace_SAskReplaceText, "Replace this occurence of \"%s\"?" + frmEditor_SInsert, "Insert" + frmEditor_SOverwrite, "Overwrite" + frmEditor_SReadOnly, "Read Only" + frmEditor_SNonameFileTitle, "Untitled" + frmEditor_SNonamePythonFileTitle, "module" + frmEditor_SAskSaveChanges, "The text in the \"%s\" file has changed.\r\n\r\nDo you want to save the modifications?" + cFileSearch_SLineLengthError, "File Search detected a line longer than %d characters in:\r\n%s.\r\nLikely, this is an unsupported binary file type." + dlgFindInFiles_SSpecifiedDirectoryDoesNotExist, "The search directory %s does not exist" + dlgReplaceInFiles_SGrepResultsNotActive, "The Find in Files Results window is not active" + frmFindResults_SGrepReplaceStats, "Replaced %d occurrence(s) in %.2f seconds" + frmFindResults_SItemMatch, "%5d matches" + frmFindResults_SReplaceLine, "\r\nOn line: " + frmFindResults_SGrepActive, "A Grep search is currently active; either abort it or wait until it is finished." + frmFindResults_SGrepSearchStats, "Searched %d files in %.2f seconds" + StringResources_SModuleProxyCodeHint, "Module %s" + StringResources_SPackageProxyCodeHint, "Package %s" + StringResources_SModuleImportCodeHint, "Imported module %s" + StringResources_SRegError, "Regular Expression Error:" + StringResources_SEmptyList, "(Empty List)" + StringResources_SNewFolder, "New Folder" + StringResources_SCommandLineMsg, "Command Line : %s\r\n" + StringResources_SEngineActive, "*** %s Python engine%s is active ***" + OleConst_SCannotActivate, "OLE control activation failed" + OleConst_SNoWindowHandle, "Could not obtain OLE control window handle" + OleConst_SLinkProperties, "Link Properties" + OleConst_SInvalidLinkSource, "Cannot link to an invalid source." + OleConst_SCannotBreakLink, "Break link operation is not supported." + OleConst_SPropDlgCaption, "%s Properties" + OleConst_SInvalidLicense, "License information for %s is invalid" + OleConst_SNotLicensed, "License information for %s not found. You cannot use this control in design mode" + StringResources_SNamespaceFormat, "Frame(Function: \"%s\" of module: \"%s\" at line %d)" + StringResources_SFilePosInfoCodeHint, "
Defined in module %s (%d)" + StringResources_SDefinedInModuleCodeHint, "
Defined in module %s" + StringResources_SParsedClassCodeHint, "class %s%s" + StringResources_SInheritsFromCodeHint, "
Inherits from: %s" + StringResources_SParsedFunctionCodeHint, "function %s(%s)%s" + StringResources_SParsedMethodCodeHint, "Method %s.%s(%s)%s" + StringResources_SFunctionParameterCodeHint, "Function Parameter %s of function %s%s" + StringResources_SLocalVariableCodeHint, "Local variable %s of function %s%s" + StringResources_SGlobalVariableCodeHint, "Global variable %s of module %s%s" + StringResources_SClassVariableCodeHint, "Class variable %s of class %s%s" + StringResources_SInstanceVariableCodeHint, "Instance variable %s of class %s%s" + StringResources_SImportedVariableCodeHint, "Imported variable %s from module %s%s" + StringResources_SVariableTypeCodeHint, "
Type: %s" + StringResources_SParsedModuleCodeHint, "Module %s" + StringResources_SParsedPackageCodeHint, "Package %s" + JvDockGlobals_RsDockVSNETDockTreeAutoHideBtnHint, "Auto Hide" + JvDockGlobals_RsEDockControlCannotIsNil, "Control can not be nil" + JvDockGlobals_RsEDockCannotGetValueWithNoOrient, "Cannot get data of control that has no dock orientation" + JvDockGlobals_RsEDockCannotSetValueWithNoOrient, "Cannot set data of control that has no dock orientation" + JvDockGlobals_RsEDockCannotLayAnother, "Only one %s allowed on each form. Cannot add another %s" + JvDockGlobals_RsEDockCannotSetTabPosition, "Cannot set TabPosition property to tpLeft or tpRight" + JvDockGlobals_RsDockCannotFindWindow, "Cannot find window" + StringResources_SInternalError, "Internal Error in %s" + StringResources_SNotFound, "\"%s\" not found" + StringResources_SNotAvailable, "n/a" + StringResources_SNotImplented, "Not implemented" + StringResources_SFilterAllFiles, "All files|*.*|" + StringResources_SVariablesDocNotSelected, "Namespace: %s" + StringResources_SVariablesDocSelected, "Namespace: %s
Name: %s
Type: %s
Value:
%s
Docstring:
%s" + StringResources_SDebuggerHintFormat, "Name: %s
Type: %s
Value:
%s
" + StringResources_SNoParameters, "** No/Unknown parameters **" + VirtualTrees_SCorruptStream2, "Stream data corrupt. Unexpected data after node's end position." + VirtualTrees_SClipboardFailed, "Clipboard operation failed." + VirtualTrees_SCannotSetUserData, "Cannot set initial user data because there is not enough user data space allocated." + DBConsts_SBcdOverflow, "BCD overflow" + DBConsts_SInvalidBcdValue, "%s is not a valid BCD value" + DBConsts_SCouldNotParseTimeStamp, "Could not parse SQL TimeStamp string" + DBConsts_SInvalidSqlTimeStamp, "Invalid SQL date/time values" + TntLXUtils_SFileOpAborted, "The file operation was aborted." + ObjAuto_sTypeMisMatch, "Type mismatch in parameter %d for method %s" + ObjAuto_sInvalidDispID, "Invalid DispID for parameter %d in method %s" + ObjAuto_sParamRequired, "Parameter %d required for method %s" + ObjAuto_sMethodOver, "Method definition for %s has over %d parameters" + ObjAuto_sTooManyParams, "Too many parameters for method %s" + JvDockGlobals_RsDockStringSplitter, " " + JvDockGlobals_RsDockJvDockInfoSplitter, "@" + JvDockGlobals_RsDockJvDockTreeCloseBtnHint, "Close" + JvResources_RsClInfoBk, "Tooltip background" + JvResources_RsGradientActiveCaption, "Gradient Active Caption" + JvResources_RsGradientInactiveCaption, "Gradient Inactive Caption" + JvResources_RsHotLight, "Hot Light" + JvResources_RsMenuBar, "Menu Bar" + JvResources_RsMenuHighlight, "Menu Highlight" + JvResources_RsFileNotFoundFmt, "File \"%s\" not found" + JvResources_RsEGrabberNotStopped, "The grabber is not stopped, you cannot change its URL." + JvResources_RsJediAgent, "JEDI-VCL" + JvResources_RsDefaultOutputFileName, "output.txt" + VirtualTrees_SEditLinkIsNil, "Edit link must not be nil." + VirtualTrees_SWrongMoveError, "Target node cannot be a child node of the node to be moved." + VirtualTrees_SWrongStreamFormat, "Unable to load tree structure, the format is wrong." + VirtualTrees_SWrongStreamVersion, "Unable to load tree structure, the version is unknown." + VirtualTrees_SStreamTooSmall, "Unable to load tree structure, not enough data available." + VirtualTrees_SCorruptStream1, "Stream data corrupt. A node's anchor chunk is missing." + JvResources_RsClWindowText, "Window text" + JvResources_RsClCaptionText, "Active window title bar text" + JvResources_RsClActiveBorder, "Active window border" + JvResources_RsClInactiveBorder, "Inactive window border" + JvResources_RsClAppWorkSpace, "Application workspace" + JvResources_RsClHighlight, "Selection background" + JvResources_RsClHighlightText, "Selection text" + JvResources_RsClBtnFace, "Button face" + JvResources_RsClBtnShadow, "Button shadow" + JvResources_RsClGrayText, "Dimmed text" + JvResources_RsClBtnText, "Button text" + JvResources_RsClInactiveCaptionText, "Inactive window title bar text" + JvResources_RsClBtnHighlight, "Button highlight" + JvResources_RsCl3DDkShadow, "Dark shadow 3D elements" + JvResources_RsCl3DLight, "Highlight 3D elements" + JvResources_RsClInfoText, "Tooltip text" + JvResources_RsClGray25, "Gray 25%" + JvResources_RsClRose, "Rose" + JvResources_RsClTan, "Tan" + JvResources_RsClLightYellow, "Light Yellow" + JvResources_RsClLightGreen, "Light Green" + JvResources_RsClLightTurquoise, "Light Turquoise" + JvResources_RsClPaleBlue, "Pale Blue" + JvResources_RsClLavender, "Lavender" + JvResources_RsClScrollBar, "Scrollbar" + JvResources_RsClBackground, "Desktop background" + JvResources_RsClActiveCaption, "Active window title bar" + JvResources_RsClInactiveCaption, "Inactive window title bar" + JvResources_RsClMenu, "Menu background" + JvResources_RsClWindow, "Window background" + JvResources_RsClWindowFrame, "Window frame" + JvResources_RsClMenuText, "Menu text" + JvResources_RsClGray80, "Gray 80%" + JvResources_RsClDarkRed, "Dark Red" + JvResources_RsClOrange, "Orange" + JvResources_RsClDarkYellow, "Dark Yellow" + JvResources_RsClBlueGray, "Blue Gray" + JvResources_RsClGray50, "Gray 50%" + JvResources_RsClLightOrange, "Light Orange" + JvResources_RsClSeaGreen, "Sea Green" + JvResources_RsClLightBlue, "Light Blue" + JvResources_RsClViolet, "Violet" + JvResources_RsClGray40, "Gray 40%" + JvResources_RsClPink, "Pink" + JvResources_RsClGold, "Gold" + JvResources_RsClBrightGreen, "Bright Green" + JvResources_RsClTurquoise, "Turquoise" + JvResources_RsClPlum, "Plum" + JvResources_RsClLime, "Lime" + JvResources_RsClYellow, "Yellow" + JvResources_RsClBlue, "Blue" + JvResources_RsClFuchsia, "Fuchsia" + JvResources_RsClAqua, "Aqua" + JvResources_RsClWhite, "White" + JvResources_RsClMoneyGreen, "Money green" + JvResources_RsClSkyBlue, "Sky blue" + JvResources_RsClCream, "Cream" + JvResources_RsClMedGray, "Medium gray" + JvResources_RsClBrown, "Brown" + JvResources_RsClOliveGreen, "Olive Green" + JvResources_RsClDarkGreen, "Dark Green" + JvResources_RsClDarkTeal, "Dark Teal" + JvResources_RsClDarkBlue, "Dark Blue" + JvResources_RsClIndigo, "Indigo" + JvResources_RsJvPropertyStoreEnterMutexTimeout, "TJvCustomPropertyStore.StoreProperties: Mutex Timeout" + JvResources_RsRTFFilter, "Rich Text Format (*.rtf)|*.rtf" + JvResources_RsTextFilter, "Plain text (*.txt)|*.txt" + JvResources_RsEOutOfRangeFloat, "Value must be between %0:g and %1:g" + JvResources_RsENoItemFoundWithName, "No item found with name \"%s\"" + JvResources_RsENotATJvThread, "TJvCustomThreadDialogForm.SetConnectedThread: A thread must be a TJvThread-Component" + JvResources_RsClBlack, "Black" + JvResources_RsClMaroon, "Maroon" + JvResources_RsClGreen, "Green" + JvResources_RsClOlive, "Olive green" + JvResources_RsClNavy, "Navy blue" + JvResources_RsClPurple, "Purple" + JvResources_RsClTeal, "Teal" + JvResources_RsClGray, "Gray" + JvResources_RsClSilver, "Silver" + JvResources_RsClRed, "Red" + JvResources_RsPVCDialogCaption, "%s Upgrade Check" + JvResources_RsPVCDialogExecuteButton, "&Execute" + JvResources_RsPVCNewVersionAvailable, "A new version (%0:s) of %1:s is available!" + JvResources_RsPVCChooseWhichVersion, "Which &version do you want to install?" + JvResources_RsPVCChooseOperation, "&Choose Operation" + JvResources_RsPVCOperationIgnore, "I&gnore" + JvResources_RsPVCOperationDownloadOnly, "Download/Copy &Only" + JvResources_RsPVCOperationDownloadInstall, "Download/Copy and &Install" + JvResources_RsPVCWhatNewInS, "What's new in %s" + JvResources_RsPVCChangesBetween, "Changes between %0:s and %1:s" + JvResources_RsPVCFileDownloadNotSuccessful, "The file download was not successful!\r\nPlease try again manually." + JvResources_RsPVCDownloadSuccessfulInstallManually, "The file download was successful.\r\nInstall manually from: %s" + JvResources_RsPVCErrorStartingSetup, "Error starting the setup process." + JvResources_RsPVCDownloadSuccessfullInstallNow, "The file download was successful.\r\nDo you want to close and install?" + JvResources_RsPVInfoButtonCaption, "Info" + JvResources_RsJvPropertyStoreMutexStorePropertiesProcedureName, "TJvCustomPropertyStore.StoreProperties:" + JvResources_RsHistorySaveCaption, "Save Parameter Settings" + JvResources_RsHistoryClearCaption, "Manage Parameter Settings" + JvResources_RsENoParametersDefined, "TJvParameterList.ShowParameterDialog: No Parameters defined" + JvResources_RsEAddObjectWrongObjectType, "TJvParameterList.AddObject: Wrong object type" + JvResources_RsEAddObjectSearchNameNotDefined, "TJvParameterList.AddObject: SearchName not defined" + JvResources_RsEAddObjectDuplicateSearchNamesNotAllowed, "TJvParameterList.AddObject: Duplicate SearchNames (\"%s\") not allowed" + JvResources_RsPVDefaultVersioninfoFileName, "versioninfo.ini" + JvResources_RsPVTempFileNameExtension, ".temp" + JvResources_RsPVSiceB, "%6f B" + JvResources_RsPVSiceKB, "%6.2f KB" + JvResources_RsPVSiceMB, "%6.2f MB" + JvResources_RsPVSiceGB, "%6.2f GB" + JvResources_RsPVCReleaseTypeAlpha, "Alpha" + JvResources_RsPVCReleaseTypeBeta, "Beta" + JvResources_RsPVCReleaseTypeProduction, "Production" + JvResources_RsPVCDownloading, "Downloading ..." + JvResources_RsEUnsupportedState, "TDefaultParser.ParseNode: Unsupported state" + JvResources_RsENoMoreWords, "TWordEnumerator.GetNext: No more words to return" + JvResources_RsEUnsupported, "TTextHandler.EmptyBuffer: Unsupported TParentTextElement descendant encountered" + JvResources_RsECannotBeInstantiated, "This class cannot be instantiated" + JvResources_RsETNodeGetNodeTypeUnknownClass, "TNode.GetNodeType: Unknown class" + JvResources_RsENoMoreNodesToReturn, "No more nodes to return" + JvResources_RsENoMoreRecordsToReturn, "No more records to return" + JvResources_RsEWordInfoIndexOutOfBounds, "TStringNode.GetWordInfo: Index out of bounds" + JvResources_RsErrParameterMustBeEntered, "Parameter \"%s\" must be entered!" + JvResources_RsHistorySelectPath, "History" + JvResources_RsDialogCaption, "" + JvResources_RsCancelButton, "&Cancel" + JvResources_RsHistoryLoadButton, "&Load" + JvResources_RsHistorySaveButton, "&Save" + JvResources_RsHistoryClearButton, "Cl&ear" + JvResources_RsHistoryLoadCaption, "Load Parameter Settings" + JvResources_RsEDOrDDRequired, "'d' or 'dd' are required" + JvResources_RsEMOrMMRequired, "'m' or 'mm' are required" + JvResources_RsEYYOrYYYYRequired, "'yy' or 'yyyy' are required" + JvResources_RsEInstanceAlreadyExists, "Instance already exists with another name" + JvResources_RsENameAlreadyExistsForInstance, "Name already exists for another instance" + JvResources_RsEInstanceNonexistent, "Instance does not exist" + JvResources_RsEMethodAlreadyExists, "Method already exists with another name" + JvResources_RsENameAlreadyExistsForMethod, "Name already exists for another method" + JvResources_RsEJvAssertSetTopIndex, "TJvCustomInspector.SetTopIndex: unexpected MaxIdx <= -1" + JvResources_RsEJvAssertInspectorPainter, "TJvInspectorCustomCompoundItem.DivideRect: unexpected Inspector.Painter = nil" + JvResources_RsEJvAssertDataParent, "TJvInspectorSetMemberData.New: unexpected ADataParent = nil" + JvResources_RsEJvAssertParent, "TJvInspectorSetMemberData.New: unexpected AParent = nil" + JvResources_RsEJvAssertPropInfo, "TJvInspectorPropData.New: unexpected PropInfo = nil" + JvResources_RsEJvAssertClassInfo, "TJvInspectorPropData.New: unexpected ClassInfo = nil" + JvResources_RsEOwnerLinkError, "Cannot link to owner control" + JvResources_RsENoMoreElementsToReturn, "TElementEnumerator.GetNextElement: No more elements to return" + JvResources_RsEJvInspDataNotAssigned, "Data not assigned" + JvResources_RsEJvInspDataNoValue, "Data has no value" + JvResources_RsEJvInspDataStrTooLong, "String too long" + JvResources_RsEJvInspNoGenReg, "Unable to create generic item registration list" + JvResources_RsEJvInspPaintNotActive, "Painter is not the active painter of the specified inspector" + JvResources_RsEJvInspPaintOnlyUsedOnce, "Inspector painter can only be linked to one inspector" + JvResources_RsEInspectorInternalError, "Internal error: two data instances pointing to the same data are registered" + JvResources_RsESpecifierBeforeSeparator, "A specifier should be placed before and after a separator" + JvResources_RsEDOrDDOnlyOnce, "'d' or 'dd' should appear only once" + JvResources_RsEMOrMMOnlyOnce, "'m' or 'mm' should appear only once" + JvResources_RsEYYOrYYYYOnlyOnce, "'yy' or 'yyyy' should appear only once" + JvResources_RsEOnlyDOrDDAllowed, "Only 'd' or 'dd' are allowed" + JvResources_RsEOnlyMOrMMAllowed, "Only 'm' or 'mm' are allowed" + JvResources_RsEOnlyYYOrYYYYAllowed, "Only 'yy' or 'yyyy' are allowed" + JvResources_RsEOnlyTwoSeparators, "Only two separators are allowed" + JvResources_RsEOnlyDMYSAllowed, "Only 'd', 'm', 'y' and '%s' are allowed" + JvResources_RsENoRegisteredControlClass, "TJvDynControlEngine.CreateControl: No Registered ControlClass \"%s\"" + JvResources_RsENoFocusControl, "TJvDynControlEngine.CreateLabelControlPanel: AFocusControl must be assigned" + JvResources_RsJvInspItemValueException, "Exception " + JvResources_RsJvInspItemUnInitialized, "(uninitialized)" + JvResources_RsJvInspItemUnassigned, "(unassigned)" + JvResources_RsJvInspItemNoValue, "(no value)" + JvResources_RsStringListEditorCaption, "String list editor" + JvResources_RsXLinesCaption, " lines" + JvResources_RsOneLineCaption, "1 line" + JvResources_RsEJvInspItemHasParent, "Item already assigned to another parent" + JvResources_RsEJvInspItemNotAChild, "Specified Item is not a child of this item" + JvResources_RsEJvInspItemColNotFound, "Specified column does not belong to this compound item" + JvResources_RsEJvInspItemItemIsNotCol, "Specified item is not a column of this compound item" + JvResources_RsEJvInspItemInvalidPropValue, "Invalid property value %s" + JvResources_RsEJvInspDataNoAccessAs, "Data cannot be accessed as %s" + JvResources_RsEJvInspDataNotInit, "Data not initialized" + JvResources_RsEFmtInvalidPathAtIndex, "Invalid or empty path (\"%0:s\") at index %1:d" + JvResources_RsENotifyErrorFmt, "%0:s:\r\n%1:s" + JvResources_RsEProcessIsRunning, "Cannot perform this operation when process is running" + JvResources_RsEProcessNotRunning, "Process is not running" + JvResources_RsCntdownText, "This dialog is closing in %s." + JvResources_RsCntdownMinText, "minute" + JvResources_RsCntdownMinsText, "minutes" + JvResources_RsCntdownSecText, "second" + JvResources_RsCntdownSecsText, "seconds" + JvResources_RsEDSAAccessBool, "Boolean" + JvResources_RsEDSAAccessFloat, "Float" + JvResources_RsEDSAAccessInt64, "Int64" + JvResources_RsEDSAAccessInt, "Integer" + JvResources_RsEDSAAccessString, "string" + JvResources_RsEIntfCastError, "component does not support interface" + JvResources_RsEUnsupportedControlClass, "TJvDynControlEngine.RegisterControl: Unsupported ControlClass \"%s\"" + JvResources_RsDeleteSettings, "Delete Settings" + JvResources_RsLoadCaption, "&Load" + JvResources_RsSaveCaption, "&Save" + JvResources_RsDeleteCaption, "&Delete" + JvResources_RsEDynControlEngineNotDefined, "TJvAppStorageSelectList.CreateDialog: DynControlEngine not defined!" + JvResources_RsEDynAppStorageNotDefined, "TJvAppStorageSelectList.GetSelectListPath: No AppStorage assigned" + JvResources_RsEShellNotCompatible, "Shell not compatible with BrowseForFolder" + JvResources_RsFileNameChange, "Filename Change" + JvResources_RsDirectoryNameChange, "Directory Name Change" + JvResources_RsAttributesChange, "Attributes Change" + JvResources_RsSizeChange, "Size Change" + JvResources_RsWriteChange, "Write Change" + JvResources_RsSecurityChange, "Security Change" + JvResources_RsEFmtCannotChangeName, "Cannot change %s when active" + JvResources_RsEFmtInvalidPath, "Invalid or empty path (%s)" + JvResources_RsEFmtMaxCountExceeded, "Maximum of %d items exceeded" + JvResources_RsUndoItem, "&Undo" + JvResources_RsCutItem, "Cu&t" + JvResources_RsCopyItem, "&Copy" + JvResources_RsPasteItem, "&Paste" + JvResources_RsDeleteItem, "&Delete" + JvResources_RsSelectAllItem, "Select &All" + JvResources_RsNoName, "(unnamed)" + JvResources_RsEReadValueFailed, "TJvAppIniFileStorage.ReadValue: Section undefined" + JvResources_RsRootValueReplaceFmt, "The Default Root Value \"%0:s\" has been replaced with \"%1:s\".\r\nPlease change the value in the FileVersionInfo Project Properties." + JvResources_RsEInvalidType, "Invalid type" + JvResources_RsEUnknownBaseType, "Unknown base type for given set" + JvResources_RsEInvalidPath, "Invalid path" + JvResources_RsENotAUniqueRootPath, "'%s' is not a unique root path" + JvResources_RsECircularReferenceOfStorages, "Circular reference of storages" + JvResources_RsLoadSettings, "Load Settings" + JvResources_RsSaveSettings, "Save Settings" + JclResources_RsProductTypeDatacenterServer, "Datacenter Server" + JclResources_RsProductTypeEnterprise, "Enterprise" + JclResources_RsProductTypeWebEdition, "Web Edition" + JclResources_RsCannotWriteRefStream, "Can not write to a read-only memory stream" + JclResources_RsHasNotTD32Info, "File [%s] has not TD32 debug information!" + JclResources_RsELibraryNotFound, "Library not found: %s" + JclResources_RsEFunctionNotFound, "Function not found: %s.%s" + JclSysInfo_RsUnknownAMDModel, "Unknown AMD (Model %d)" + VarPyth_SMultiDimensionalPropsNotSupported, "Multi-dimensional sequences or mappings are not supported in Python" + VarPyth_SCantConvertArg, "Can't convert argument #%d of %s into a Python object" + VarPyth_SCantConvertKeyToPythonObject, "Can't convert Key into a Python object" + VarPyth_SCantConvertValueToPythonObject, "Can't convert Value into a Python object" + VarPyth_SCantCreateNewSequenceObject, "Can't create a new sequence object" + VarPyth_SExpectedPythonVariant, "Expected a Python variant" + JvResources_RsButtonOKCaption, "&OK" + JvResources_RsButtonCancelCaption, "Cancel" + JclResources_RsOSVersionWin98SE, "Windows 98 SE" + JclResources_RsOSVersionWinME, "Windows ME" + JclResources_RsOSVersionWinNT3, "Windows NT 3.%u" + JclResources_RsOSVersionWinNT4, "Windows NT 4.%u" + JclResources_RsOSVersionWin2000, "Windows 2000" + JclResources_RsOSVersionWinXP, "Windows XP" + JclResources_RsOSVersionWin2003, "Windows Server 2003" + JclResources_RsOSVersionWin2003R2, "Windows Server 2003 \"R2\"" + JclResources_RsOSVersionWinXP64, "Windows XP x64" + JclResources_RsOSVersionWinVista, "Windows Vista" + JclResources_RsOSVersionWinLonghorn, "Windows Server \"Longhorn\"" + JclResources_RsProductTypeWorkStation, "Workstation" + JclResources_RsProductTypeServer, "Server" + JclResources_RsProductTypeAdvancedServer, "Advanced Server" + JclResources_RsProductTypePersonal, "Home Edition" + JclResources_RsProductTypeProfessional, "Professional" + JclResources_RsIntelCacheDescr7D, "2nd-level cache: 2 MBytes, 8-way set associative, 64 byte line size" + JclResources_RsIntelCacheDescr7F, "2nd-level cache: 512 KBytes, 2-way set associative, 64 byte line size" + JclResources_RsIntelCacheDescr82, "2nd-level cache: 256 KBytes, 8-way associative, 32 byte line size" + JclResources_RsIntelCacheDescr83, "2nd-level cache: 512 KBytes, 8-way associative, 32 byte line size" + JclResources_RsIntelCacheDescr84, "2nd-level cache: 1 MBytes, 8-way associative, 32 byte line size" + JclResources_RsIntelCacheDescr85, "2nd-level cache: 2 MBytes, 8-way associative, 32 byte line size" + JclResources_RsIntelCacheDescr86, "2nd-level cache: 512 KByte, 4-way set associative, 64 byte line size" + JclResources_RsIntelCacheDescr87, "2nd-level cache: 1 MByte, 8-way set associative, 64 byte line size" + JclResources_RsIntelCacheDescrB0, "Instruction TLB: 4 KByte pages, 4-way set associative, 128 entries" + JclResources_RsIntelCacheDescrB3, "Data TLB: 4 KByte pages, 4-way set associative, 128 entries" + JclResources_RsIntelCacheDescrB4, "Data TLB1: 4 KByte pages, 4-way set associative, 256 entries" + JclResources_RsIntelCacheDescrF0, "64-Byte Prefetching" + JclResources_RsIntelCacheDescrF1, "128-Byte Prefetching" + JclResources_RsOSVersionWin95, "Windows 95" + JclResources_RsOSVersionWin95OSR2, "Windows 95 OSR2" + JclResources_RsOSVersionWin98, "Windows 98" + JclResources_RsIntelCacheDescr57, "Data TLB0: 4 KByte pages, 4-way associative, 16 entries" + JclResources_RsIntelCacheDescr5B, "Data TLB: 4 KByte and 4 MByte pages, 64 Entries" + JclResources_RsIntelCacheDescr5C, "Data TLB: 4 KByte and 4 MByte pages, 128 Entries" + JclResources_RsIntelCacheDescr5D, "Data TLB: 4 KByte and 4 MByte pages, 256 Entries" + JclResources_RsIntelCacheDescr60, "1st-level data cache: 16 KByte, 8-way set associative, 64 byte line size" + JclResources_RsIntelCacheDescr66, "1st-level data cache: 8 KBytes, 4-way set associative, 64 byte line size" + JclResources_RsIntelCacheDescr67, "1st-level data cache: 16 KBytes, 4-way set associative, 64 byte line size" + JclResources_RsIntelCacheDescr68, "1st-level data cache: 32 KBytes, 4-way set associative, 64 byte line size" + JclResources_RsIntelCacheDescr70, "Trace cache: 12 K-µOps, 8-way set associative" + JclResources_RsIntelCacheDescr71, "Trace cache: 16 K-µOps, 8-way set associative" + JclResources_RsIntelCacheDescr72, "Trace cache: 32 K-µOps, 8-way set associative" + JclResources_RsIntelCacheDescr78, "2nd-level cache: 1 MBytes, 4-way set associative, 64 bytes line size" + JclResources_RsIntelCacheDescr79, "2nd-level cache: 128 KBytes, 8-way set associative, 64 bytes line size, 2 lines per sector" + JclResources_RsIntelCacheDescr7A, "2nd-level cache: 256 KBytes, 8-way set associative, 64 bytes line size, 2 lines per sector" + JclResources_RsIntelCacheDescr7B, "2nd-level cache: 512 KBytes, 8-way set associative, 64 bytes line size, 2 lines per sector" + JclResources_RsIntelCacheDescr7C, "2nd-level cache: 1 MBytes, 8-way set associative, 64 bytes line size, 2 lines per sector" + JclResources_RsIntelCacheDescr29, "3rd level cache: 4 MBytes, 8-way set associative, 64 byte line size, 2 lines per sector" + JclResources_RsIntelCacheDescr2C, "1st level data cache: 32 KBytes, 8-way set associative, 64 byte line size" + JclResources_RsIntelCacheDescr30, "1st level instruction cache: 32 KBytes, 8-way set associative, 64 byte line size" + JclResources_RsIntelCacheDescr40, "No 2nd-level cache or, if processor contains a valid 2nd-level cache, no 3rd-level cache" + JclResources_RsIntelCacheDescr41, "2nd-level cache: 128 KBytes, 4-way set associative, 32 byte line size" + JclResources_RsIntelCacheDescr42, "2nd-level cache: 256 KBytes, 4-way set associative, 32 byte line size" + JclResources_RsIntelCacheDescr43, "2nd-level cache: 512 KBytes, 4-way set associative, 32 byte line size" + JclResources_RsIntelCacheDescr44, "2nd-level cache: 1 MBytes, 4-way set associative, 32 byte line size" + JclResources_RsIntelCacheDescr45, "2nd-level cache: 2 MBytes, 4-way set associative, 32 byte line size" + JclResources_RsIntelCacheDescr46, "3rd-level cache: 4 MBytes, 4-way set associative, 64 byte line size" + JclResources_RsIntelCacheDescr47, "3rd-level cache: 8 MBytes, 4-way set associative, 64 byte line size" + JclResources_RsIntelCacheDescr49, "2nd-level cache: 4 MBytes, 16-way set associative, 64 byte line size" + JclResources_RsIntelCacheDescr50, "Instruction TLB: 4 KByte and 2 MByte or 4 MByte pages, 64 Entries" + JclResources_RsIntelCacheDescr51, "Instruction TLB: 4 KByte and 2 MByte or 4 MByte pages, 128 Entries" + JclResources_RsIntelCacheDescr52, "Instruction TLB: 4 KByte and 2 MByte or 4 MByte pages, 256 Entries" + JclResources_RsIntelCacheDescr56, "Data TLB0: 4 MByte pages, 4-way set associative, 16 entries" + JclResources_RsSynchCreateEvent, "Failed to create event" + JclResources_RsSynchCreateMutex, "Failed to create mutex" + JclResources_RsIntelCacheDescr00, "Null descriptor" + JclResources_RsIntelCacheDescr01, "Instruction TLB: 4 KByte pages, 4-way set associative, 32 entries" + JclResources_RsIntelCacheDescr02, "Instruction TLB: 4 MByte pages, 4-way set associative, 2 entries" + JclResources_RsIntelCacheDescr03, "Data TLB: 4 KByte pages, 4-way set associative, 64 entries" + JclResources_RsIntelCacheDescr04, "Data TLB: 4 MByte pages, 4-way set associative, 8 entries" + JclResources_RsIntelCacheDescr05, "Data TLB1: 4 MByte pages, 4-way set associative, 32 entries" + JclResources_RsIntelCacheDescr06, "1st level instruction cache: 8 KBytes, 4-way set associative, 32 byte line size" + JclResources_RsIntelCacheDescr08, "1st level instruction cache: 16 KBytes, 4-way set associative, 32 byte line size" + JclResources_RsIntelCacheDescr0A, "1st level data cache: 8 KBytes, 2-way set associative, 32 byte line size" + JclResources_RsIntelCacheDescr0B, "Instruction TLB: 4 MByte pages, 4-way set associative, 4 entries" + JclResources_RsIntelCacheDescr0C, "1st level data cache: 16 KBytes, 4-way set associative, 32 byte line size" + JclResources_RsIntelCacheDescr22, "3rd level cache: 512 KBytes, 4-way set associative, 64 byte line size, 2 lines per sector" + JclResources_RsIntelCacheDescr23, "3rd level cache: 1 MBytes, 8-way set associative, 64 byte line size, 2 lines per sector" + JclResources_RsIntelCacheDescr25, "3rd level cache: 2 MBytes, 8-way set associative, 64 byte line size, 2 lines per sector" + JclResources_RsRTTIPropCount, "Property count: " + JclResources_RsRTTIUnitName, "Unit name: " + JclResources_RsRTTIBasedOn, "Based on: " + JclResources_RsRTTIFloatType, "Float type: " + JclResources_RsRTTIMethodKind, "Method kind: " + JclResources_RsRTTIParamCount, "Parameter count: " + JclResources_RsRTTIReturnType, "Return type: " + JclResources_RsRTTIMaxLen, "Max length: " + JclResources_RsRTTIElSize, "Element size: " + JclResources_RsRTTIElType, "Element type: " + JclResources_RsRTTIElNeedCleanup, "Elements need clean up: " + JclResources_RsRTTIVarType, "Variant type: " + JclResources_RsDeclarationFormat, "// Declaration for '%s' not supported." + JclResources_RsBlankSearchString, "Search string cannot be blank" + JclResources_RsInvalidEmptyStringItem, "String list passed to StringsToMultiSz cannot contain empty strings." + JclResources_RsArgumentOutOfRange, "Argument out of range" + JclResources_RsRTTIField, "field" + JclResources_RsRTTIStaticMethod, "static method" + JclResources_RsRTTIVirtualMethod, "virtual method" + JclResources_RsRTTIIndex, "index" + JclResources_RsRTTIDefault, "default" + JclResources_RsRTTIName, "Name: " + JclResources_RsRTTIType, "Type: " + JclResources_RsRTTIFlags, "Flags: " + JclResources_RsRTTIGUID, "GUID: " + JclResources_RsRTTITypeKind, "Type kind: " + JclResources_RsRTTIOrdinalType, "Ordinal type: " + JclResources_RsRTTIMinValue, "Min value: " + JclResources_RsRTTIMaxValue, "Max value: " + JclResources_RsRTTINameList, "Names: " + JclResources_RsRTTIClassName, "Class name: " + JclResources_RsRTTIParent, "Parent: " + JclResources_RsHKCCShort, "HKCC" + JclResources_RsHKDDShort, "HKDD" + JclResources_RsRTTIValueOutOfRange, "Value out of range (%s)." + JclResources_RsRTTIUnknownIdentifier, "Unknown identifier '%s'." + JclResources_RsRTTIVar, "var " + JclResources_RsRTTIConst, "const " + JclResources_RsRTTIArrayOf, "array of " + JclResources_RsRTTIOut, "out " + JclResources_RsRTTIOrdinal, "ordinal=" + JclResources_RsRTTITrue, "True" + JclResources_RsRTTIFalse, "False" + JclResources_RsRTTITypeError, "???" + JclResources_RsRTTITypeInfoAt, "Type info: %p" + JclResources_RsRTTIPropRead, "read" + JclResources_RsRTTIPropWrite, "write" + JclResources_RsRTTIPropStored, "stored" + JclResources_RsUnableToOpenKeyRead, "Unable to open key \"%s\\%s\" for read" + JclResources_RsUnableToAccessValue, "Unable to open key \"%s\\%s\" and access value \"%s\"" + JclResources_RsWrongDataType, "\"%s\\%s\\%s\" is of wrong kind or size" + JclResources_RsInconsistentPath, "\"%s\" does not match RootKey" + JclResources_RsHKCRLong, "HKEY_CLASSES_ROOT" + JclResources_RsHKCULong, "HKEY_CURRENT_USER" + JclResources_RsHKLMLong, "HKEY_LOCAL_MACHINE" + JclResources_RsHKUSLong, "HKEY_USERS" + JclResources_RsHKPDLong, "HKEY_PERFORMANCE_DATA" + JclResources_RsHKCCLong, "HKEY_CURRENT_CONFIG" + JclResources_RsHKDDLong, "HKEY_DYN_DATA" + JclResources_RsHKCRShort, "HKCR" + JclResources_RsHKCUShort, "HKCU" + JclResources_RsHKLMShort, "HKLM" + JclResources_RsHKUSShort, "HKUS" + JclResources_RsHKPDShort, "HKPD" + JclResources_RsMapiErrTYPE_NOT_SUPPORTED, "Type not supported" + JclResources_RsMapiErrAMBIGUOUS_RECIPIENT, "A recipient was specified ambiguously" + JclResources_RsMapiErrMESSAGE_IN_USE, "Message in use" + JclResources_RsMapiErrNETWORK_FAILURE, "Network failure" + JclResources_RsMapiErrINVALID_EDITFIELDS, "Invalid edit fields" + JclResources_RsMapiErrINVALID_RECIPS, "Invalid recipients" + JclResources_RsMapiErrNOT_SUPPORTED, "Not supported" + JclResources_RsMapiMailORIG, "From" + JclResources_RsMapiMailTO, "To" + JclResources_RsMapiMailCC, "Cc" + JclResources_RsMapiMailBCC, "Bcc" + JclResources_RsPeReadOnlyStream, "Stream is read-only" + JclResources_RsPeCantOpen, "Cannot open file \"%s\"" + JclResources_RsPeNotPE, "This is not a PE format" + JclResources_RsPeNotResDir, "Not a resource directory" + JclResources_RsPeSectionNotFound, "Section \"%s\" not found" + JclResources_RsMapiErrLOGIN_FAILURE, "MAPI login failure" + JclResources_RsMapiErrDISK_FULL, "Disk full" + JclResources_RsMapiErrINSUFFICIENT_MEMORY, "Insufficient memory" + JclResources_RsMapiErrACCESS_DENIED, "Access denied" + JclResources_RsMapiErrTOO_MANY_SESSIONS, "Too many sessions" + JclResources_RsMapiErrTOO_MANY_FILES, "Too many files were specified" + JclResources_RsMapiErrTOO_MANY_RECIPIENTS, "Too many recipients were specified" + JclResources_RsMapiErrATTACHMENT_NOT_FOUND, "A specified attachment was not found" + JclResources_RsMapiErrATTACHMENT_OPEN_FAILURE, "Attachment open failure" + JclResources_RsMapiErrATTACHMENT_WRITE_FAILURE, "Attachment write failure" + JclResources_RsMapiErrUNKNOWN_RECIPIENT, "Unknown recipient" + JclResources_RsMapiErrBAD_RECIPTYPE, "Bad recipient type" + JclResources_RsMapiErrNO_MESSAGES, "No messages" + JclResources_RsMapiErrINVALID_MESSAGE, "Invalid message" + JclResources_RsMapiErrTEXT_TOO_LARGE, "Text too large" + JclResources_RsMapiErrINVALID_SESSION, "Invalid session" + ComConst_SVarNotObject, "Variant does not reference an automation object" + ComConst_STooManyParams, "Dispatch methods do not support more than 64 parameters" + ComConst_SDCOMNotInstalled, "DCOM not installed" + JclResources_RsWin32Prefix, "Win32: %s (%u)" + JclResources_RsCannotCreateDir, "Unable to create directory" + JclResources_RsFileUtilsNoVersionInfo, "File contains no version information" + JclResources_RsCreateFileMapping, "Failed to create FileMapping" + JclResources_RsCreateFileMappingView, "Failed to create FileMappingView" + JclResources_RsViewNeedsMapping, "FileMap argument of TJclFileMappingView constructor cannot be nil" + JclResources_RsFailedToObtainSize, "Failed to obtain size of file" + JclResources_RsDefaultFileTypeName, " File" + JclResources_RsMapiError, "MAPI Error: (%d) \"%s\"" + JclResources_RsMapiMissingExport, "Function \"%s\" is not exported by client" + JclResources_RsMapiMailNoClient, "No Simple MAPI client installed, cannot send the message" + JclResources_RsMapiErrUSER_ABORT, "User abort" + JclResources_RsMapiErrFAILURE, "General MAPI failure" + ComStrs_sRichEditInsertError, "RichEdit line insertion error" + ComStrs_sRichEditLoadFail, "Failed to Load Stream" + ComStrs_sRichEditSaveFail, "Failed to Save Stream" + ComStrs_sPageIndexError, "%d is an invalid PageIndex value. PageIndex must be between 0 and %d" + ComStrs_sInvalidComCtl32, "This control requires version 4.70 or greater of COMCTL32.DLL" + ComStrs_sDateTimeMax, "Date exceeds maximum of %s" + ComStrs_sDateTimeMin, "Date is less than minimum of %s" + ComStrs_sNeedAllowNone, "You must be in ShowCheckbox mode to set to this date" + ComStrs_sFailSetCalDateTime, "Failed to set calendar date or time" + ComStrs_sFailSetCalMaxSelRange, "Failed to set maximum selection range" + ComStrs_sFailSetCalMinMaxRange, "Failed to set calendar min/max range" + ComStrs_sFailsetCalSelRange, "Failed to set calendar selected range" + TntSystem_SBufferOverflow, "Buffer overflow" + TntSystem_SInvalidUTF7, "Invalid UTF7" + ComConst_SOleError, "OLE error %.8x" + ComConst_SNoMethod, "Method '%s' not supported by automation object" + TB2Consts_STBToolbarItemReinserted, "Toolbar item already inserted" + TB2Consts_STBChevronItemMoreButtonsHint, "More Buttons|" + TB2Consts_STBMRUListItemDefCaption, "(MRU List)" + TB2Consts_STBDockParentNotAllowed, "A TTBDock control cannot be placed inside a tool window or another TTBDock" + TB2Consts_STBDockCannotChangePosition, "Cannot change Position of a TTBDock if it already contains controls" + TB2Consts_STBToolwinDockedToNameNotSet, "Cannot save dockable window's position because DockedTo's Name property not set" + ComStrs_sTabFailClear, "Failed to clear tab control" + ComStrs_sTabFailDelete, "Failed to delete tab at index %d" + ComStrs_sTabFailRetrieve, "Failed to retrieve tab at index %d" + ComStrs_sTabFailGetObject, "Failed to get object at index %d" + ComStrs_sTabFailSet, "Failed to set tab \"%s\" at index %d" + ComStrs_sTabFailSetObject, "Failed to set object at index %d" + ComStrs_sTabMustBeMultiLine, "MultiLine must be True when TabPosition is tpLeft or tpRight" + ComStrs_sInvalidIndex, "Invalid index" + ComStrs_sInsertError, "Unable to insert an item" + ComStrs_sInvalidOwner, "Invalid owner" + SynHighlighterPython_SYNS_FunctionName, "Function Name" + SynHighlighterPython_SYNS_ClassName, "Class Name" + SynHighlighterPython_SYNS_FriendlyCommentedCode, "Commented Code" + SynHighlighterPython_SYNS_FriendlyFunctionName, "Function Name" + SynHighlighterPython_SYNS_FriendlyClassName, "Class Name" + SynHighlighterPython_SYNS_AttrBanner, "Banner" + SynHighlighterPython_SYNS_FriendlyAttrBanner, "Banner" + SynHighlighterPython_SYNS_AttrOutput, "Output" + SynHighlighterPython_SYNS_FriendlyAttrOutput, "Output" + SynHighlighterPython_SYNS_AttrTraceback, "Traceback" + SynHighlighterPython_SYNS_FriendlyAttrTraceback, "Traceback" + SynHighlighterPython_SYNS_AttrPrompt, "Prompt" + SynHighlighterPython_SYNS_FriendlyAttrPrompt, "Prompt" + SynHighlighterPython_SYNS_LangPythonInterpreter, "Python Interpreter" + SynHighlighterPython_SYNS_FriendlyLangPythonInterpreter, "Python Interpreter" + TB2Consts_STBToolbarIndexOutOfBounds, "Toolbar item index out of range" + SynEditStrConst_SYNS_PreviewScrollInfoFmt, "Page: %d" + SynEditStrConst_SYNS_EDuplicateShortcut, "Shortcut already exists" + SynEditStrConst_SYNS_FilterHTML, "HTML Documents (*.htm;*.html)|*.htm;*.html" + SynEditStrConst_SYNS_FilterPython, "Python Files (*.py)|*.py" + SynEditStrConst_SYNS_FilterINI, "INI Files (*.ini)|*.ini" + SynEditStrConst_SYNS_FilterCSS, "Cascading Stylesheets (*.css)|*.css" + SynEditStrConst_SYNS_FilterXML, "XML Files (*.xml;*.xsd;*.xsl;*.xslt;*.dtd)|*.xml;*.xsd;*.xsl;*.xslt;*.dtd" + SynEditStrConst_SYNS_FriendlyLangHTML, "HTML" + SynEditStrConst_SYNS_FriendlyLangPython, "Python" + SynEditStrConst_SYNS_FriendlyLangINI, "INI" + SynEditStrConst_SYNS_FriendlyLangCSS, "Cascading Style Sheet" + SynEditStrConst_SYNS_FriendlyLangXML, "XML" + SynEditStrConst_SYNS_FriendlyLangUnknown, "" + SynEditTextBuffer_SListIndexOutOfBounds, "Invalid stringlist index %d" + SynEditTextBuffer_SInvalidCapacity, "Stringlist capacity cannot be smaller than count" + SynHighlighterPython_SYNS_CommentedCode, "Commented Code" + SynEditStrConst_SYNS_FriendlyAttrProcessingInstr, "Processing Instruction" + SynEditStrConst_SYNS_FriendlyAttrProperty, "Property" + SynEditStrConst_SYNS_FriendlyAttrReservedWord, "Reserved Word" + SynEditStrConst_SYNS_FriendlyAttrSection, "Section" + SynEditStrConst_SYNS_FriendlyAttrSpace, "Space" + SynEditStrConst_SYNS_FriendlyAttrString, "String" + SynEditStrConst_SYNS_FriendlyAttrSymbol, "Symbol" + SynEditStrConst_SYNS_FriendlyAttrSyntaxError, "Syntax Error" + SynEditStrConst_SYNS_FriendlyAttrSystem, "System Functions and Variables" + SynEditStrConst_SYNS_FriendlyAttrText, "Text" + SynEditStrConst_SYNS_FriendlyAttrUndefinedProperty, "Undefined Property" + SynEditStrConst_SYNS_FriendlyAttrUnknownWord, "Unknown Word" + SynEditStrConst_SYNS_FriendlyAttrValue, "Value" + SynEditStrConst_SYNS_FriendlyAttrWhitespace, "Whitespace" + SynEditStrConst_SYNS_ScrollInfoFmt, "%d - %d" + SynEditStrConst_SYNS_ScrollInfoFmtTop, "Top Line: %d" + SynEditStrConst_SYNS_FriendlyAttrColor, "Color Value" + SynEditStrConst_SYNS_FriendlyAttrComment, "Comment" + SynEditStrConst_SYNS_FriendlyAttrDOCTYPESection, "DOCTYPE Section" + SynEditStrConst_SYNS_FriendlyAttrDocumentation, "Documentation" + SynEditStrConst_SYNS_FriendlyAttrElementName, "Element Name" + SynEditStrConst_SYNS_FriendlyAttrEntityReference, "Entity Reference" + SynEditStrConst_SYNS_FriendlyAttrEscapeAmpersand, "Escape Ampersand" + SynEditStrConst_SYNS_FriendlyAttrFloat, "Float" + SynEditStrConst_SYNS_FriendlyAttrHexadecimal, "Hexadecimal" + SynEditStrConst_SYNS_FriendlyAttrIdentifier, "Identifier" + SynEditStrConst_SYNS_FriendlyAttrKey, "Key" + SynEditStrConst_SYNS_FriendlyAttrNamespaceAttrName, "Namespace Attribute Name" + SynEditStrConst_SYNS_FriendlyAttrNamespaceAttrValue, "Namespace Attribute Value" + SynEditStrConst_SYNS_FriendlyAttrNonReservedKeyword, "Non-reserved Keyword" + SynEditStrConst_SYNS_FriendlyAttrNumber, "Number" + SynEditStrConst_SYNS_FriendlyAttrOctal, "Octal" + ExtCtrls_clNameInfoBk, "Info Background" + ExtCtrls_clNameInfoText, "Info Text" + ExtCtrls_clNameMenu, "Menu Background" + ExtCtrls_clNameMenuBar, "Menu Bar" + ExtCtrls_clNameMenuHighlight, "Menu Highlight" + ExtCtrls_clNameMenuText, "Menu Text" + ExtCtrls_clNameNone, "None" + ExtCtrls_clNameScrollBar, "Scroll Bar" + ExtCtrls_clName3DDkShadow, "3D Dark Shadow" + ExtCtrls_clName3DLight, "3D Light" + ExtCtrls_clNameWindow, "Window Background" + ExtCtrls_clNameWindowFrame, "Window Frame" + ExtCtrls_clNameWindowText, "Window Text" + SynEditStrConst_SYNS_FriendlyAttrAttributeName, "Attribute Name" + SynEditStrConst_SYNS_FriendlyAttrAttributeValue, "Attribute Value" + SynEditStrConst_SYNS_FriendlyAttrCDATASection, "CDATA Section" + ExtCtrls_clNameBackground, "Background" + ExtCtrls_clNameBtnFace, "Button Face" + ExtCtrls_clNameBtnHighlight, "Button Highlight" + ExtCtrls_clNameBtnShadow, "Button Shadow" + ExtCtrls_clNameBtnText, "Button Text" + ExtCtrls_clNameCaptionText, "Caption Text" + ExtCtrls_clNameDefault, "Default" + ExtCtrls_clNameGradientActiveCaption, "Gradient Active Caption" + ExtCtrls_clNameGradientInactiveCaption, "Gradient Inactive Caption" + ExtCtrls_clNameGrayText, "Gray Text" + ExtCtrls_clNameHighlight, "Highlight Background" + ExtCtrls_clNameHighlightText, "Highlight Text" + ExtCtrls_clNameHotLight, "Hot Light" + ExtCtrls_clNameInactiveBorder, "Inactive Border" + ExtCtrls_clNameInactiveCaption, "Inactive Caption" + ExtCtrls_clNameInactiveCaptionText, "Inactive Caption Text" + ExtCtrls_clNameGray, "Gray" + ExtCtrls_clNameSilver, "Silver" + ExtCtrls_clNameRed, "Red" + ExtCtrls_clNameLime, "Lime" + ExtCtrls_clNameYellow, "Yellow" + ExtCtrls_clNameBlue, "Blue" + ExtCtrls_clNameFuchsia, "Fuchsia" + ExtCtrls_clNameAqua, "Aqua" + ExtCtrls_clNameWhite, "White" + ExtCtrls_clNameMoneyGreen, "Money Green" + ExtCtrls_clNameSkyBlue, "Sky Blue" + ExtCtrls_clNameCream, "Cream" + ExtCtrls_clNameMedGray, "Medium Gray" + ExtCtrls_clNameActiveBorder, "Active Border" + ExtCtrls_clNameActiveCaption, "Active Caption" + ExtCtrls_clNameAppWorkSpace, "Application Workspace" + Consts_SListBoxMustBeVirtual, "Listbox (%s) style must be virtual in order to set Count" + Consts_SNoGetItemEventHandler, "No OnGetItem event handler assigned" + Consts_SANSIEncoding, "ANSI" + Consts_SASCIIEncoding, "ASCII" + Consts_SUnicodeEncoding, "Unicode" + Consts_SBigEndianEncoding, "Big Endian Unicode" + Consts_SUTF8Encoding, "UTF-8" + Consts_SUTF7Encoding, "UTF-7" + Consts_SPageControlNotSet, "PageControl must first be assigned" + ExtCtrls_clNameBlack, "Black" + ExtCtrls_clNameMaroon, "Maroon" + ExtCtrls_clNameGreen, "Green" + ExtCtrls_clNameOlive, "Olive" + ExtCtrls_clNameNavy, "Navy" + ExtCtrls_clNamePurple, "Purple" + ExtCtrls_clNameTeal, "Teal" + Consts_SInvalidPrinterOp, "Operation not supported on selected printer" + Consts_SNoDefaultPrinter, "There is no default printer currently selected" + Consts_SDuplicateMenus, "Menu '%s' is already being used by another form" + Consts_SPictureLabel, "Picture:" + Consts_SPictureDesc, " (%dx%d)" + Consts_SPreviewLabel, "Preview" + Consts_SCannotOpenAVI, "Cannot open AVI" + Consts_SDockedCtlNeedsName, "Docked control must have a name" + Consts_SDockTreeRemoveError, "Error removing control from dock tree" + Consts_SDockZoneNotFound, " - Dock zone not found" + Consts_SDockZoneHasNoCtl, " - Dock zone has no control" + Consts_SDockZoneVersionConflict, "Error loading dock zone from the stream. Expecting version %d, but found %d." + Consts_SColorBoxCustomCaption, "Custom..." + Consts_SMultiSelectRequired, "Multiselect mode must be on for this feature" + Consts_SSeparator, "Separator" + Consts_SErrorSettingCount, "Error setting %s.Count" + Consts_SmkcAlt, "Alt+" + Consts_srNone, "(None)" + Consts_SOutOfRange, "Value must be between %d and %d" + Consts_sAllFilter, "All" + Consts_SInsertLineError, "Unable to insert a line" + Consts_SConfirmCreateDir, "The specified directory does not exist. Create it?" + Consts_SSelectDirCap, "Select Directory" + Consts_SDirNameCap, "Directory &Name:" + Consts_SDrivesCap, "D&rives:" + Consts_SDirsCap, "&Directories:" + Consts_SFilesCap, "&Files: (*.*)" + Consts_SNetworkCap, "Ne&twork..." + Consts_SInvalidClipFmt, "Invalid clipboard format" + Consts_SIconToClipboard, "Clipboard does not support Icons" + Consts_SCannotOpenClipboard, "Cannot open clipboard" + Consts_SInvalidMemoSize, "Text exceeds memo capacity" + Consts_SmkcTab, "Tab" + Consts_SmkcEsc, "Esc" + Consts_SmkcEnter, "Enter" + Consts_SmkcSpace, "Space" + Consts_SmkcPgUp, "PgUp" + Consts_SmkcPgDn, "PgDn" + Consts_SmkcEnd, "End" + Consts_SmkcHome, "Home" + Consts_SmkcLeft, "Left" + Consts_SmkcUp, "Up" + Consts_SmkcRight, "Right" + Consts_SmkcDown, "Down" + Consts_SmkcIns, "Ins" + Consts_SmkcDel, "Del" + Consts_SmkcShift, "Shift+" + Consts_SmkcCtrl, "Ctrl+" + Consts_SMsgDlgWarning, "Warning" + Consts_SMsgDlgError, "Error" + Consts_SMsgDlgInformation, "Information" + Consts_SMsgDlgConfirm, "Confirm" + Consts_SMsgDlgYes, "&Yes" + Consts_SMsgDlgNo, "&No" + Consts_SMsgDlgOK, "OK" + Consts_SMsgDlgCancel, "Cancel" + Consts_SMsgDlgHelp, "&Help" + Consts_SMsgDlgAbort, "&Abort" + Consts_SMsgDlgRetry, "&Retry" + Consts_SMsgDlgIgnore, "&Ignore" + Consts_SMsgDlgAll, "&All" + Consts_SMsgDlgNoToAll, "N&o to All" + Consts_SMsgDlgYesToAll, "Yes to &All" + Consts_SmkcBkSp, "BkSp" + Consts_SCancelButton, "Cancel" + Consts_SYesButton, "&Yes" + Consts_SNoButton, "&No" + Consts_SHelpButton, "&Help" + Consts_SCloseButton, "&Close" + Consts_SIgnoreButton, "&Ignore" + Consts_SRetryButton, "&Retry" + Consts_SAbortButton, "Abort" + Consts_SAllButton, "&All" + Consts_SCannotDragForm, "Cannot drag a form" + Consts_SVMetafiles, "Metafiles" + Consts_SVEnhMetafiles, "Enhanced Metafiles" + Consts_SVIcons, "Icons" + Consts_SVBitmaps, "Bitmaps" + Consts_SMaskErr, "Invalid input value" + Consts_SMaskEditErr, "Invalid input value. Use escape key to abandon changes" + Consts_SVisibleChanged, "Cannot change Visible in OnShow or OnHide" + Consts_SCannotShowModal, "Cannot make a visible window modal" + Consts_SScrollBarRange, "Scrollbar property out of range" + Consts_SPropertyOutOfRange, "%s property out of range" + Consts_SMenuIndexError, "Menu index out of range" + Consts_SMenuReinserted, "Menu inserted twice" + Consts_SMenuNotFound, "Sub-menu is not in menu" + Consts_SNoTimers, "Not enough timers available" + Consts_SNotPrinting, "Printer is not currently printing" + Consts_SPrinting, "Printing in progress" + Consts_SInvalidPrinter, "Printer selected is not valid" + Consts_SDeviceOnPort, "%s on %s" + Consts_SGroupIndexTooLow, "GroupIndex cannot be less than a previous menu item's GroupIndex" + Consts_SNoMDIForm, "Cannot create form. No MDI forms are currently active" + Consts_SControlParentSetToSelf, "A control cannot have itself as its parent" + Consts_SOKButton, "OK" + Consts_SUnknownExtension, "Unknown picture file extension (.%s)" + Consts_SUnknownClipboardFormat, "Unsupported clipboard format" + Consts_SOutOfResources, "Out of system resources" + Consts_SNoCanvasHandle, "Canvas does not allow drawing" + Consts_SInvalidImageSize, "Invalid image size" + Consts_SInvalidImageList, "Invalid ImageList" + Consts_SReplaceImage, "Unable to Replace Image" + Consts_SImageIndexError, "Invalid ImageList Index" + Consts_SImageReadFail, "Failed to read ImageList data from stream" + Consts_SImageWriteFail, "Failed to write ImageList data to stream" + Consts_SWindowDCError, "Error creating window device context" + Consts_SWindowClass, "Error creating window class" + Consts_SCannotFocus, "Cannot focus a disabled or invisible window" + Consts_SParentRequired, "Control '%s' has no parent window" + Consts_SParentGivenNotAParent, "Parent given is not a parent of '%s'" + Consts_SMDIChildNotVisible, "Cannot hide an MDI Child Form" + HelpIntfs_hNoTableOfContents, "Unable to find a Table of Contents" + HelpIntfs_hNothingFound, "No help found for %s" + HelpIntfs_hNoContext, "No context-sensitive help installed" + HelpIntfs_hNoContextFound, "No help found for context" + HelpIntfs_hNoTopics, "No topic-based help system installed" + Consts_SCantWriteResourceStreamError, "Can't write to a read-only resource stream" + Consts_SInvalidTabPosition, "Tab position incompatible with current tab style" + Consts_SInvalidTabStyle, "Tab style incompatible with current tab position" + Consts_SInvalidBitmap, "Bitmap image is not valid" + Consts_SInvalidIcon, "Icon image is not valid" + Consts_SInvalidMetafile, "Metafile is not valid" + Consts_SInvalidPixelFormat, "Invalid pixel format" + Consts_SInvalidImage, "Invalid image" + Consts_SScanLine, "Scan line index out of range" + Consts_SChangeIconSize, "Cannot change the size of an icon" + Consts_SOleGraphic, "Invalid operation on TOleGraphic" + RTLConsts_SListCountError, "List count out of bounds (%d)" + RTLConsts_SListIndexError, "List index out of bounds (%d)" + RTLConsts_SMemoryStreamError, "Out of memory while expanding memory stream" + RTLConsts_SPropertyException, "Error reading %s%s%s: %s" + RTLConsts_SReadError, "Stream read error" + RTLConsts_SReadOnlyProperty, "Property is read-only" + RTLConsts_SRegGetDataFailed, "Failed to get data for '%s'" + RTLConsts_SRegSetDataFailed, "Failed to set data for '%s'" + RTLConsts_SResNotFound, "Resource %s not found" + RTLConsts_SSeekNotImplemented, "%s.Seek not implemented" + RTLConsts_SSortedListError, "Operation not allowed on sorted list" + RTLConsts_SUnknownGroup, "%s not in a class registration group" + RTLConsts_SUnknownProperty, "Property %s does not exist" + RTLConsts_SWriteError, "Stream write error" + RTLConsts_SThreadCreateError, "Thread creation error: %s" + RTLConsts_SThreadError, "Thread Error: %s (%d)" + RTLConsts_SDuplicateItem, "List does not allow duplicates ($0%x)" + RTLConsts_SDuplicateName, "A component named %s already exists" + RTLConsts_SDuplicateString, "String list does not allow duplicates" + RTLConsts_SFCreateErrorEx, "Cannot create file \"%s\". %s" + RTLConsts_SFOpenErrorEx, "Cannot open file \"%s\". %s" + RTLConsts_SIniFileWriteError, "Unable to write to %s" + RTLConsts_SInvalidFileName, "Invalid file name - %s" + RTLConsts_SInvalidImage, "Invalid stream format" + RTLConsts_SInvalidName, "''%s'' is not a valid component name" + RTLConsts_SInvalidProperty, "Invalid property value" + RTLConsts_SInvalidPropertyElement, "Invalid property element: %s" + RTLConsts_SInvalidPropertyPath, "Invalid property path" + RTLConsts_SInvalidPropertyType, "Invalid property type: %s" + RTLConsts_SInvalidPropertyValue, "Invalid property value" + RTLConsts_SInvalidRegType, "Invalid data type for '%s'" + RTLConsts_SListCapacityError, "List capacity out of bounds (%d)" + SysConst_SShortDayNameSat, "Sat" + SysConst_SLongDayNameSun, "Sunday" + SysConst_SLongDayNameMon, "Monday" + SysConst_SLongDayNameTue, "Tuesday" + SysConst_SLongDayNameWed, "Wednesday" + SysConst_SLongDayNameThu, "Thursday" + SysConst_SLongDayNameFri, "Friday" + SysConst_SLongDayNameSat, "Saturday" + SysConst_SCannotCreateDir, "Unable to create directory" + RTLConsts_SAncestorNotFound, "Ancestor for '%s' not found" + RTLConsts_SAssignError, "Cannot assign a %s to a %s" + RTLConsts_SBitsIndexError, "Bits index out of range" + RTLConsts_SCantWriteResourceStreamError, "Can't write to a read-only resource stream" + RTLConsts_SCheckSynchronizeError, "CheckSynchronize called from thread $%x, which is NOT the main thread" + RTLConsts_SClassNotFound, "Class %s not found" + RTLConsts_SDuplicateClass, "A class named %s already exists" + SysConst_SLongMonthNameMar, "March" + SysConst_SLongMonthNameApr, "April" + SysConst_SLongMonthNameMay, "May" + SysConst_SLongMonthNameJun, "June" + SysConst_SLongMonthNameJul, "July" + SysConst_SLongMonthNameAug, "August" + SysConst_SLongMonthNameSep, "September" + SysConst_SLongMonthNameOct, "October" + SysConst_SLongMonthNameNov, "November" + SysConst_SLongMonthNameDec, "December" + SysConst_SShortDayNameSun, "Sun" + SysConst_SShortDayNameMon, "Mon" + SysConst_SShortDayNameTue, "Tue" + SysConst_SShortDayNameWed, "Wed" + SysConst_SShortDayNameThu, "Thu" + SysConst_SShortDayNameFri, "Fri" + SysConst_SOSError, "System Error. Code: %d.\r\n%s" + SysConst_SUnkOSError, "A call to an OS function failed" + SysConst_SShortMonthNameJan, "Jan" + SysConst_SShortMonthNameFeb, "Feb" + SysConst_SShortMonthNameMar, "Mar" + SysConst_SShortMonthNameApr, "Apr" + SysConst_SShortMonthNameMay, "May" + SysConst_SShortMonthNameJun, "Jun" + SysConst_SShortMonthNameJul, "Jul" + SysConst_SShortMonthNameAug, "Aug" + SysConst_SShortMonthNameSep, "Sep" + SysConst_SShortMonthNameOct, "Oct" + SysConst_SShortMonthNameNov, "Nov" + SysConst_SShortMonthNameDec, "Dec" + SysConst_SLongMonthNameJan, "January" + SysConst_SLongMonthNameFeb, "February" + SysConst_SVarTypeNotUsableWithPrefix, "Custom variant type (%s%.4x) is not usable" + SysConst_SVarTypeTooManyCustom, "Too many custom variant types have been registered" + SysConst_SVarTypeCouldNotConvert, "Could not convert variant of type (%s) into type (%s)" + SysConst_SVarTypeConvertOverflow, "Overflow while converting variant of type (%s) into type (%s)" + SysConst_SVarOverflow, "Variant overflow" + SysConst_SVarInvalid, "Invalid argument" + SysConst_SVarBadType, "Invalid variant type" + SysConst_SVarNotImplemented, "Operation not supported" + SysConst_SVarUnexpected, "Unexpected variant error" + SysConst_SExternalException, "External exception %x" + SysConst_SAssertionFailed, "Assertion failed" + SysConst_SIntfCastError, "Interface not supported" + SysConst_SSafecallException, "Exception in safecall method" + SysConst_SAssertError, "%s (%s, line %d)" + SysConst_SAbstractError, "Abstract Error" + SysConst_SModuleAccessViolation, "Access violation at address %p in module '%s'. %s of address %p" + SysConst_SExceptTitle, "Application Error" + SysConst_SInvalidFormat, "Format '%s' invalid or incompatible with argument" + SysConst_SArgumentMissing, "No argument for format '%s'" + SysConst_SDispatchError, "Variant method calls not supported" + SysConst_SReadAccess, "Read" + SysConst_SWriteAccess, "Write" + SysConst_SFormatTooLong, "Format string too long" + SysConst_SVarArrayCreate, "Error creating variant or safe array" + SysConst_SVarArrayBounds, "Variant or safe array index out of bounds" + SysConst_SVarArrayLocked, "Variant or safe array is locked" + SysConst_SInvalidVarCast, "Invalid variant type conversion" + SysConst_SInvalidVarOp, "Invalid variant operation" + SysConst_SInvalidVarNullOp, "Invalid NULL variant operation" + SysConst_SInvalidVarOpWithHResultWithPrefix, "Invalid variant operation (%s%.8x)\n%s" + SysConst_SVarTypeOutOfRangeWithPrefix, "Custom variant type (%s%.4x) is out of range" + SysConst_SVarTypeAlreadyUsedWithPrefix, "Custom variant type (%s%.4x) already used by %s" + SysConst_SDivByZero, "Division by zero" + SysConst_SRangeError, "Range check error" + SysConst_SIntOverflow, "Integer overflow" + SysConst_SInvalidOp, "Invalid floating point operation" + SysConst_SZeroDivide, "Floating point division by zero" + SysConst_SOverflow, "Floating point overflow" + SysConst_SUnderflow, "Floating point underflow" + SysConst_SInvalidPointer, "Invalid pointer operation" + SysConst_SInvalidCast, "Invalid class typecast" + SysConst_SAccessViolationArg3, "Access violation at address %p. %s of address %p" + SysConst_SAccessViolationNoArg, "Access violation" + SysConst_SStackOverflow, "Stack overflow" + SysConst_SControlC, "Control-C hit" + SysConst_SPrivilege, "Privileged instruction" + SysConst_SOperationAborted, "Operation aborted" + SysConst_SException, "Exception %s in module %s at %p.\r\n%s%s\r\n" + SysConst_SInvalidInteger, "'%s' is not a valid integer value" + SysConst_SInvalidFloat, "'%s' is not a valid floating point value" + SysConst_SInvalidDate, "'%s' is not a valid date" + SysConst_SInvalidTime, "'%s' is not a valid time" + SysConst_SInvalidDateTime, "'%s' is not a valid date and time" + SysConst_STimeEncodeError, "Invalid argument to time encode" + SysConst_SDateEncodeError, "Invalid argument to date encode" + SysConst_SOutOfMemory, "Out of memory" + SysConst_SInOutError, "I/O error %d" + SysConst_SFileNotFound, "File not found" + SysConst_SInvalidFilename, "Invalid filename" + SysConst_STooManyOpenFiles, "Too many open files" + SysConst_SAccessDenied, "File access denied" + SysConst_SEndOfFile, "Read beyond end of file" + SysConst_SDiskFull, "Disk full" + SysConst_SInvalidInput, "Invalid numeric input" +END + diff --git a/PyScripter.res b/PyScripter.res index 9a77ab4ddd59c487971726c3338a824d10bdf8b3..8de110313a1460fb4c5194eca67f6da3ae6f2528 100644 GIT binary patch delta 30 kcmdmRk8uMKeahivW8h$5WME)moBTWHBBR;nv$@HP0IgRFo&W#< delta 30 jcmdmRk8uMKeahivVBlb2WB`K6zjH1!8f-qBo6HCRtaA#C diff --git a/PythonEngine.pas b/PythonEngine.pas new file mode 100644 index 000000000..d5ee46fc9 --- /dev/null +++ b/PythonEngine.pas @@ -0,0 +1,10106 @@ +(**************************************************************************) +(* *) +(* Module: Unit 'PythonEngine' Copyright (c) 1997 *) +(* *) +(* Version: 3.0 Dr. Dietmar Budelsky *) +(* Sub-Version: 0.32 dbudelsky@web.de *) +(* Germany *) +(* *) +(* Morgan Martinet *) +(* 4723 rue Brebeuf *) +(* H2J 3L2 MONTREAL (QC) *) +(* CANADA *) +(* e-mail: p4d@mmm-experts.com *) +(* *) +(* look at our page at: http://mmm-experts.com/ *) +(* and our Wiki at: http://py4d.pbwiki.com/ *) +(**************************************************************************) +(* Functionality: Delphi Components that provide an interface to the *) +(* Python language (see python.txt for more infos on *) +(* Python itself). *) +(* *) +(**************************************************************************) +(* Contributors: *) +(* Grzegorz Makarewicz (mak@mikroplan.com.pl) *) +(* Andrew Robinson (andy@hps1.demon.co.uk) *) +(* Mark Watts(mark_watts@hotmail.com) *) +(* Olivier Deckmyn (olivier.deckmyn@mail.dotcom.fr) *) +(* Sigve Tjora (public@tjora.no) *) +(* Mark Derricutt (mark@talios.com) *) +(* Igor E. Poteryaev (jah@mail.ru) *) +(* Yuri Filimonov (fil65@mail.ru) *) +(* Stefan Hoffmeister (Stefan.Hoffmeister@Econos.de) *) +(* Michiel du Toit (micdutoit@hsbfn.com) - Lazarus Port *) +(* Chris Nicolai (nicolaitanes@gmail.com) *) +(**************************************************************************) +(* This source code is distributed with no WARRANTY, for no reason or use.*) +(* Everyone is allowed to use and change this code free for his own tasks *) +(* and projects, as long as this header and its copyright text is intact. *) +(* For changed versions of this code, which are public distributed the *) +(* following additional conditions have to be fullfilled: *) +(* 1) The header has to contain a comment on the change and the author of *) +(* it. *) +(* 2) A copy of the changed source has to be sent to the above E-Mail *) +(* address or my then valid address, if this is possible to the *) +(* author. *) +(* The second condition has the target to maintain an up to date central *) +(* version of the component. If this condition is not acceptable for *) +(* confidential or legal reasons, everyone is free to derive a component *) +(* or to generate a diff file to my or other original sources. *) +(* Dr. Dietmar Budelsky, 1997-11-17 *) +(**************************************************************************) + +unit PythonEngine; + +{ TODO -oMMM : implement tp_as_buffer slot } +{ TODO -oMMM : implement Attribute descriptor and subclassing stuff } + +{$I Definition.Inc} + +interface + +uses +{$IFDEF MSWINDOWS} + Windows, +{$ENDIF} +{$IFDEF LINUX} + Types, + Libc, +{$ENDIF} + Classes, + SysUtils, +{$IFDEF HAS_SYNCOBJS_UNIT} + SyncObjs, +{$ENDIF} +{$IFDEF DELPHI6_OR_HIGHER} + Variants, +{$ELSE} + {$IFDEF FPC} + Variants, + {$ENDIF} +{$ENDIF} +{$IFDEF DELPHI2005_OR_HIGHER} + WideStrings, +{$ELSE} + TinyWideStrings, +{$ENDIF} + MethodCallBack; + +//####################################################### +//## ## +//## PYTHON specific constants ## +//## ## +//####################################################### + +type + TPythonVersionProp = packed record + DllName : String; + RegVersion : String; + APIVersion : Integer; + CanUseLatest : Boolean; + end; +const +{$IFDEF MSWINDOWS} + PYTHON_KNOWN_VERSIONS: array[1..9] of TPythonVersionProp = + ( (DllName: 'python14.dll'; RegVersion: '1.4'; APIVersion: 1006; CanUseLatest: False), + (DllName: 'python15.dll'; RegVersion: '1.5'; APIVersion: 1007; CanUseLatest: False), + (DllName: 'python16.dll'; RegVersion: '1.6'; APIVersion: 1008; CanUseLatest: False), + (DllName: 'python20.dll'; RegVersion: '2.0'; APIVersion: 1009; CanUseLatest: True), + (DllName: 'python21.dll'; RegVersion: '2.1'; APIVersion: 1010; CanUseLatest: True), + (DllName: 'python22.dll'; RegVersion: '2.2'; APIVersion: 1011; CanUseLatest: True), + (DllName: 'python23.dll'; RegVersion: '2.3'; APIVersion: 1012; CanUseLatest: True), + (DllName: 'python24.dll'; RegVersion: '2.4'; APIVersion: 1012; CanUseLatest: True), + (DllName: 'python25.dll'; RegVersion: '2.5'; APIVersion: 1013; CanUseLatest: True) ); +{$ENDIF} +{$IFDEF LINUX} + PYTHON_KNOWN_VERSIONS: array[1..9] of TPythonVersionProp = + ( (DllName: 'libpython1.4.so'; RegVersion: '1.4'; APIVersion: 1006; CanUseLatest: False), + (DllName: 'libpython1.5.so'; RegVersion: '1.5'; APIVersion: 1007; CanUseLatest: False), + (DllName: 'libpython1.6.so'; RegVersion: '1.6'; APIVersion: 1008; CanUseLatest: False), + (DllName: 'libpython2.0.so'; RegVersion: '2.0'; APIVersion: 1009; CanUseLatest: True), + (DllName: 'libpython2.1.so'; RegVersion: '2.1'; APIVersion: 1010; CanUseLatest: True), + (DllName: 'libpython2.2.so'; RegVersion: '2.2'; APIVersion: 1011; CanUseLatest: True), + (DllName: 'libpython2.3.so'; RegVersion: '2.3'; APIVersion: 1012; CanUseLatest: True), + (DllName: 'libpython2.4.so'; RegVersion: '2.4'; APIVersion: 1012; CanUseLatest: True), + (DllName: 'libpython2.5.so'; RegVersion: '2.5'; APIVersion: 1013; CanUseLatest: True) ); +{$ENDIF} +{$IFDEF PYTHON14} + COMPILED_FOR_PYTHON_VERSION_INDEX = 1; +{$ENDIF} +{$IFDEF PYTHON15} + COMPILED_FOR_PYTHON_VERSION_INDEX = 2; +{$ENDIF} +{$IFDEF PYTHON16} + COMPILED_FOR_PYTHON_VERSION_INDEX = 3; +{$ENDIF} +{$IFDEF PYTHON20} + COMPILED_FOR_PYTHON_VERSION_INDEX = 4; +{$ENDIF} +{$IFDEF PYTHON21} + COMPILED_FOR_PYTHON_VERSION_INDEX = 5; +{$ENDIF} +{$IFDEF PYTHON22} + COMPILED_FOR_PYTHON_VERSION_INDEX = 6; +{$ENDIF} +{$IFDEF PYTHON23} + COMPILED_FOR_PYTHON_VERSION_INDEX = 7; +{$ENDIF} +{$IFDEF PYTHON24} + COMPILED_FOR_PYTHON_VERSION_INDEX = 8; +{$ENDIF} +{$IFDEF PYTHON25} + COMPILED_FOR_PYTHON_VERSION_INDEX = 9; +{$ENDIF} + + PYT_METHOD_BUFFER_INCREASE = 10; + PYT_MEMBER_BUFFER_INCREASE = 10; + PYT_GETSET_BUFFER_INCREASE = 10; + + METH_VARARGS = $0001; + METH_KEYWORDS = $0002; + + // Masks for the co_flags field of PyCodeObject + CO_OPTIMIZED = $0001; + CO_NEWLOCALS = $0002; + CO_VARARGS = $0004; + CO_VARKEYWORDS = $0008; + + // Rich comparison opcodes introduced in version 2.1 + Py_LT = 0; + Py_LE = 1; + Py_EQ = 2; + Py_NE = 3; + Py_GT = 4; + Py_GE = 5; +type + // Delphi equivalent used by TPyObject + TRichComparisonOpcode = (pyLT, pyLE, pyEQ, pyNE, pyGT, pyGE); +const +{Type flags (tp_flags) introduced in version 2.0 + +These flags are used to extend the type structure in a backwards-compatible +fashion. Extensions can use the flags to indicate (and test) when a given +type structure contains a new feature. The Python core will use these when +introducing new functionality between major revisions (to avoid mid-version +changes in the PYTHON_API_VERSION). + +Arbitration of the flag bit positions will need to be coordinated among +all extension writers who publically release their extensions (this will +be fewer than you might expect!).. + +Python 1.5.2 introduced the bf_getcharbuffer slot into PyBufferProcs. + +Type definitions should use Py_TPFLAGS_DEFAULT for their tp_flags value. + +Code can use PyType_HasFeature(type_ob, flag_value) to test whether the +given type object has a specified feature. +} + +// PyBufferProcs contains bf_getcharbuffer + Py_TPFLAGS_HAVE_GETCHARBUFFER = (1 shl 0); + +// PySequenceMethods contains sq_contains + Py_TPFLAGS_HAVE_SEQUENCE_IN = (1 shl 1); + +// Objects which participate in garbage collection (see objimp.h) + Py_TPFLAGS_GC = (1 shl 2); + +// PySequenceMethods and PyNumberMethods contain in-place operators + Py_TPFLAGS_HAVE_INPLACEOPS = (1 shl 3); + +// PyNumberMethods do their own coercion */ + Py_TPFLAGS_CHECKTYPES = (1 shl 4); + + Py_TPFLAGS_HAVE_RICHCOMPARE = (1 shl 5); + +// Objects which are weakly referencable if their tp_weaklistoffset is >0 +// XXX Should this have the same value as Py_TPFLAGS_HAVE_RICHCOMPARE? +// These both indicate a feature that appeared in the same alpha release. + + Py_TPFLAGS_HAVE_WEAKREFS = (1 shl 6); + +{$IFDEF PYTHON22_OR_HIGHER} +// tp_iter is defined + Py_TPFLAGS_HAVE_ITER = (1 shl 7); + +// New members introduced by Python 2.2 exist + Py_TPFLAGS_HAVE_CLASS = (1 shl 8); + +// Set if the type object is dynamically allocated + Py_TPFLAGS_HEAPTYPE = (1 shl 9); + +// Set if the type allows subclassing + Py_TPFLAGS_BASETYPE = (1 shl 10); + +// Set if the type is 'ready' -- fully initialized + Py_TPFLAGS_READY = (1 shl 12); + +// Set while the type is being 'readied', to prevent recursive ready calls + Py_TPFLAGS_READYING = (1 shl 13); + +// Objects support garbage collection (see objimp.h) + Py_TPFLAGS_HAVE_GC = (1 shl 14); +{$ENDIF} + + Py_TPFLAGS_DEFAULT = Py_TPFLAGS_HAVE_GETCHARBUFFER + or Py_TPFLAGS_HAVE_SEQUENCE_IN + or Py_TPFLAGS_HAVE_INPLACEOPS + or Py_TPFLAGS_HAVE_RICHCOMPARE + or Py_TPFLAGS_HAVE_WEAKREFS +{$IFDEF PYTHON22_OR_HIGHER} + or Py_TPFLAGS_HAVE_ITER + or Py_TPFLAGS_HAVE_CLASS +{$ENDIF} + ; + +// See function PyType_HasFeature below for testing the flags. + +// Delphi equivalent used by TPythonType +type + TPFlag = (tpfHaveGetCharBuffer, tpfHaveSequenceIn, tpfGC, tpfHaveInplaceOps, + tpfCheckTypes, tpfHaveRichCompare, tpfHaveWeakRefs +{$IFDEF PYTHON22_OR_HIGHER} + ,tpfHaveIter, tpfHaveClass, tpfHeapType, tpfBaseType, tpfReady, tpfReadying, tpfHaveGC +{$ENDIF} + ); + TPFlags = set of TPFlag; +const + TPFLAGS_DEFAULT = [tpfHaveGetCharBuffer, tpfHaveSequenceIn, tpfHaveInplaceOps, + tpfHaveRichCompare, tpfHaveWeakRefs +{$IFDEF PYTHON22_OR_HIGHER} + , tpfHaveIter, tpfHaveClass +{$ENDIF} + ]; +//------- Python opcodes ----------// +Const +{$IFDEF PYTHON20_OR_HIGHER} + single_input = 256; + file_input = 257; + eval_input = 258; + funcdef = 259; + parameters = 260; + varargslist = 261; + fpdef = 262; + fplist = 263; + stmt = 264; + simple_stmt = 265; + small_stmt = 266; + expr_stmt = 267; + augassign = 268; + print_stmt = 269; + del_stmt = 270; + pass_stmt = 271; + flow_stmt = 272; + break_stmt = 273; + continue_stmt = 274; + return_stmt = 275; + raise_stmt = 276; + import_stmt = 277; + import_as_name = 278; + dotted_as_name = 279; + dotted_name = 280; + global_stmt = 281; + exec_stmt = 282; + assert_stmt = 283; + compound_stmt = 284; + if_stmt = 285; + while_stmt = 286; + for_stmt = 287; + try_stmt = 288; + except_clause = 289; + suite = 290; + test = 291; + and_test = 291; + not_test = 293; + comparison = 294; + comp_op = 295; + expr = 296; + xor_expr = 297; + and_expr = 298; + shift_expr = 299; + arith_expr = 300; + term = 301; + factor = 302; + power = 303; + atom = 304; + listmaker = 305; + lambdef = 306; + trailer = 307; + subscriptlist = 308; + subscript = 309; + sliceop = 310; + exprlist = 311; + testlist = 312; + dictmaker = 313; + classdef = 314; + arglist = 315; + argument = 316; + list_iter = 317; + list_for = 318; + list_if = 319; +{$ENDIF} +{$IFDEF PYTHON15} + single_input = 256; + file_input = 257; + eval_input = 258; + funcdef = 259; + parameters = 260; + varargslist = 261; + fpdef = 262; + fplist = 263; + stmt = 264; + simple_stmt = 265; + small_stmt = 266; + expr_stmt = 267; + print_stmt = 268; + del_stmt = 269; + pass_stmt = 270; + flow_stmt = 271; + break_stmt = 272; + continue_stmt = 273; + return_stmt = 274; + raise_stmt = 275; + import_stmt = 276; + dotted_name = 277; + global_stmt = 278; + exec_stmt = 279; + compound_stmt = 280; + if_stmt = 281; + while_stmt = 282; + for_stmt = 283; + try_stmt = 284; + except_clause = 285; + suite = 286; + test = 287; + and_test = 288; + not_test = 289; + comparison = 290; + comp_op = 291; + expr = 292; + xor_expr = 293; + and_expr = 294; + shift_expr = 295; + arith_expr = 296; + term = 297; + factor = 298; + power = 299; + atom = 300; + lambdef = 301; + trailer = 302; + subscriptlist = 303; + subscript = 304; + sliceop = 305; + exprlist = 306; + testlist = 307; + dictmaker = 308; + classdef = 309; + arglist = 310; + argument = 311; +{$ENDIF} + +{$IFDEF PYTHON22_OR_HIGHER} + // structmember.h +const +//* Types */ + T_SHORT = 0; + T_INT = 1; + T_LONG = 2; + T_FLOAT = 3; + T_DOUBLE = 4; + T_STRING = 5; + T_OBJECT = 6; +//* XXX the ordering here is weird for binary compatibility */ + T_CHAR = 7; //* 1-character string */ + T_BYTE = 8; //* 8-bit signed int */ +//* unsigned variants: */ + T_UBYTE = 9; + T_USHORT = 10; + T_UINT = 11; + T_ULONG = 12; + +//* Added by Jack: strings contained in the structure */ + T_STRING_INPLACE= 13; + + T_OBJECT_EX = 16;{* Like T_OBJECT, but raises AttributeError + when the value is NULL, instead of + converting to None. *} + +//* Flags */ + READONLY = 1; + RO = READONLY; //* Shorthand */ + READ_RESTRICTED = 2; + WRITE_RESTRICTED = 4; + RESTRICTED = (READ_RESTRICTED or WRITE_RESTRICTED); +type + TPyMemberType = (mtShort, mtInt, mtLong, mtFloat, mtDouble, mtString, mtObject, + mtChar, mtByte, mtUByte, mtUShort, mtUInt, mtULong, + mtStringInplace, mtObjectEx); + TPyMemberFlag = (mfDefault, mfReadOnly, mfReadRestricted, mfWriteRestricted, mfRestricted); +{$ENDIF} + +//####################################################### +//## ## +//## Non-Python specific constants ## +//## ## +//####################################################### + +const + ErrInit = -300; + CR = #13; + LF = #10; + TAB = #09; + CRLF = CR+LF; + + + +//####################################################### +//## ## +//## Global declarations, nothing Python specific ## +//## ## +//####################################################### + +type + TPChar = array[0..16000] of PChar; + PPChar = ^TPChar; + PInt = ^Integer; + PDouble = ^Double; + PFloat = ^Real; + PLong = ^LongInt; + PShort = ^ShortInt; + PString = ^PChar; + + +//####################################################### +//## ## +//## Python specific interface ## +//## ## +//####################################################### + +type + PP_frozen = ^P_frozen; + P_frozen = ^_frozen; + PPyObject = ^PyObject; + PPPyObject = ^PPyObject; + PPPPyObject = ^PPPyObject; + PPyIntObject = ^PyIntObject; + PPyTypeObject = ^PyTypeObject; + PPySliceObject = ^PySliceObject; + + AtExitProc = procedure; + + PyCFunction = function( self, args:PPyObject): PPyObject; cdecl; + PyCFunctionWithKW = function( self, args, keywords:PPyObject): PPyObject; cdecl; + + unaryfunc = function( ob1 : PPyObject): PPyObject; cdecl; + binaryfunc = function( ob1,ob2 : PPyObject): PPyObject; cdecl; + ternaryfunc = function( ob1,ob2,ob3 : PPyObject): PPyObject; cdecl; + inquiry = function( ob1 : PPyObject): integer; cdecl; + coercion = function( ob1,ob2 : PPPyObject): integer; cdecl; + intargfunc = function( ob1 : PPyObject; i: integer): PPyObject; cdecl; + intintargfunc = function( ob1 : PPyObject; i1, i2: integer): + PPyObject; cdecl; + intobjargproc = function( ob1 : PPyObject; i: integer; ob2 : PPyObject): + integer; cdecl; + intintobjargproc = function( ob1: PPyObject; i1, i2: integer; + ob2: PPyObject): integer; cdecl; + objobjargproc = function( ob1,ob2,ob3 : PPyObject): integer; cdecl; + + pydestructor = procedure(ob: PPyObject); cdecl; + printfunc = function( ob: PPyObject; var f: file; i: integer): integer; cdecl; + getattrfunc = function( ob1: PPyObject; name: PChar): PPyObject; cdecl; + setattrfunc = function( ob1: PPyObject; name: PChar; ob2: PPyObject): integer; cdecl; + cmpfunc = function( ob1,ob2: PPyObject): integer; cdecl; + reprfunc = function( ob: PPyObject): PPyObject; cdecl; + hashfunc = function( ob: PPyObject): LongInt; cdecl; + getattrofunc = function( ob1,ob2: PPyObject): PPyObject; cdecl; + setattrofunc = function( ob1,ob2,ob3: PPyObject): integer; cdecl; + +{$IFDEF PYTHON20_OR_HIGHER} +/// jah 29-sep-2000 : updated for python 2.0 +/// added from object.h + getreadbufferproc = function ( ob1: PPyObject; i: integer; ptr: Pointer): integer; cdecl; + getwritebufferproc= function ( ob1: PPyObject; i: integer; ptr: Pointer): integer; cdecl; + getsegcountproc = function ( ob1: PPyObject; i: integer): integer; cdecl; + getcharbufferproc = function ( ob1: PPyObject; i: integer; const pstr: PChar): integer; cdecl; + objobjproc = function ( ob1, ob2: PPyObject): integer; cdecl; + visitproc = function ( ob1: PPyObject; ptr: Pointer): integer; cdecl; + traverseproc = function ( ob1: PPyObject; proc: visitproc; ptr: Pointer): integer; cdecl; +{$ENDIF} + +{$IFDEF PYTHON21_OR_HIGHER} + richcmpfunc = function ( ob1, ob2 : PPyObject; i : Integer) : PPyObject; cdecl; +{$ENDIF} +{$IFDEF PYTHON22_OR_HIGHER} + getiterfunc = function ( ob1 : PPyObject) : PPyObject; cdecl; + iternextfunc = function ( ob1 : PPyObject) : PPyObject; cdecl; + descrgetfunc = function ( ob1, ob2, ob3 : PPyObject) : PPyObject; cdecl; + descrsetfunc = function ( ob1, ob2, ob3 : PPyObject) : Integer; cdecl; + initproc = function ( self, args, kwds : PPyObject) : Integer; cdecl; + newfunc = function ( subtype: PPyTypeObject; args, kwds : PPyObject) : PPyObject; cdecl; + allocfunc = function ( self: PPyTypeObject; nitems : integer) : PPyObject; cdecl; +{$ENDIF} + + PyNumberMethods = packed record + nb_add : binaryfunc; + nb_substract : binaryfunc; + nb_multiply : binaryfunc; + nb_divide : binaryfunc; + nb_remainder : binaryfunc; + nb_divmod : binaryfunc; + nb_power : ternaryfunc; + nb_negative : unaryfunc; + nb_positive : unaryfunc; + nb_absolute : unaryfunc; + nb_nonzero : inquiry; + nb_invert : unaryfunc; + nb_lshift : binaryfunc; + nb_rshift : binaryfunc; + nb_and : binaryfunc; + nb_xor : binaryfunc; + nb_or : binaryfunc; + nb_coerce : coercion; + nb_int : unaryfunc; + nb_long : unaryfunc; + nb_float : unaryfunc; + nb_oct : unaryfunc; + nb_hex : unaryfunc; +{$IFDEF PYTHON20_OR_HIGHER} +/// jah 29-sep-2000 : updated for python 2.0 +/// added from .h + nb_inplace_add : binaryfunc; + nb_inplace_subtract : binaryfunc; + nb_inplace_multiply : binaryfunc; + nb_inplace_divide : binaryfunc; + nb_inplace_remainder : binaryfunc; + nb_inplace_power : ternaryfunc; + nb_inplace_lshift : binaryfunc; + nb_inplace_rshift : binaryfunc; + nb_inplace_and : binaryfunc; + nb_inplace_xor : binaryfunc; + nb_inplace_or : binaryfunc; +{$ENDIF} +{$IFDEF PYTHON22_OR_HIGHER} + // Added in release 2.2 + // The following require the Py_TPFLAGS_HAVE_CLASS flag + nb_floor_divide : binaryfunc; + nb_true_divide : binaryfunc; + nb_inplace_floor_divide : binaryfunc; + nb_inplace_true_divide : binaryfunc; +{$ENDIF} + end; + PPyNumberMethods = ^PyNumberMethods; + + PySequenceMethods = packed record + sq_length : inquiry; + sq_concat : binaryfunc; + sq_repeat : intargfunc; + sq_item : intargfunc; + sq_slice : intintargfunc; + sq_ass_item : intobjargproc; + sq_ass_slice : intintobjargproc; +{$IFDEF PYTHON20_OR_HIGHER} +/// jah 29-sep-2000 : updated for python 2.0 +/// added from .h + sq_contains : objobjproc; + sq_inplace_concat : binaryfunc; + sq_inplace_repeat : intargfunc; +{$ENDIF} + end; + PPySequenceMethods = ^PySequenceMethods; + + PyMappingMethods = packed record + mp_length : inquiry; + mp_subscript : binaryfunc; + mp_ass_subscript : objobjargproc; + end; + PPyMappingMethods = ^PyMappingMethods; + +{$IFDEF PYTHON20_OR_HIGHER} +/// jah 29-sep-2000 : updated for python 2.0 +/// added from .h + PyBufferProcs = packed record + bf_getreadbuffer : getreadbufferproc; + bf_getwritebuffer : getwritebufferproc; + bf_getsegcount : getsegcountproc; + bf_getcharbuffer : getcharbufferproc; + end; + PPyBufferProcs = ^PyBufferProcs; +{$ENDIF} + + Py_complex = packed record + real : double; + imag : double; + end; + + PyObject = packed record + ob_refcnt: Integer; + ob_type: PPyTypeObject; + end; + + PyIntObject = packed record + ob_refcnt : Integer; + ob_type : PPyTypeObject; + ob_ival : LongInt; + end; + + _frozen = packed record + name : PChar; + code : PByte; + size : Integer; + end; + + PySliceObject = packed record + ob_refcnt: Integer; + ob_type: PPyTypeObject; + start, stop, step: PPyObject; + end; + + PPyMethodDef = ^PyMethodDef; + PyMethodDef = packed record + ml_name: PChar; + ml_meth: PyCFunction; + ml_flags: Integer; + ml_doc: PChar; + end; + +{$IFDEF PYTHON22_OR_HIGHER} + // structmember.h + PPyMemberDef = ^PyMemberDef; + PyMemberDef = packed record + name : PChar; + _type : integer; + offset : integer; + flags : integer; + doc : PChar; + end; + + // descrobject.h + + // Descriptors + + getter = function ( obj : PPyObject; context : Pointer) : PPyObject; cdecl; + setter = function ( obj, value : PPyObject; context : Pointer) : integer; cdecl; + + PPyGetSetDef = ^PyGetSetDef; + PyGetSetDef = packed record + name : PChar; + get : getter; + _set : setter; + doc : PChar; + closure : Pointer; + end; + + wrapperfunc = function (self, args: PPyObject; wrapped : Pointer) : PPyObject; cdecl; + + pwrapperbase = ^wrapperbase; + wrapperbase = packed record + name : PChar; + wrapper : wrapperfunc; + doc : PChar; + end; + + // Various kinds of descriptor objects + + {#define PyDescr_COMMON \ + PyObject_HEAD \ + PyTypeObject *d_type; \ + PyObject *d_name + } + + PPyDescrObject = ^PyDescrObject; + PyDescrObject = packed record + // Start of the Head of an object + ob_refcnt : Integer; + ob_type : PPyTypeObject; + // End of the Head of an object + d_type : PPyTypeObject; + d_name : PPyObject; + end; + + PPyMethodDescrObject = ^PyMethodDescrObject; + PyMethodDescrObject = packed record + // Start of PyDescr_COMMON + // Start of the Head of an object + ob_refcnt : Integer; + ob_type : PPyTypeObject; + // End of the Head of an object + d_type : PPyTypeObject; + d_name : PPyObject; + // End of PyDescr_COMMON + d_method : PPyMethodDef; + end; + + PPyMemberDescrObject = ^PyMemberDescrObject; + PyMemberDescrObject = packed record + // Start of PyDescr_COMMON + // Start of the Head of an object + ob_refcnt : Integer; + ob_type : PPyTypeObject; + // End of the Head of an object + d_type : PPyTypeObject; + d_name : PPyObject; + // End of PyDescr_COMMON + d_member : PPyMemberDef; + end; + + PPyGetSetDescrObject = ^PyGetSetDescrObject; + PyGetSetDescrObject = packed record + // Start of PyDescr_COMMON + // Start of the Head of an object + ob_refcnt : Integer; + ob_type : PPyTypeObject; + // End of the Head of an object + d_type : PPyTypeObject; + d_name : PPyObject; + // End of PyDescr_COMMON + d_getset : PPyGetSetDef; + end; + + PPyWrapperDescrObject = ^PyWrapperDescrObject; + PyWrapperDescrObject = packed record + // Start of PyDescr_COMMON + // Start of the Head of an object + ob_refcnt : Integer; + ob_type : PPyTypeObject; + // End of the Head of an object + d_type : PPyTypeObject; + d_name : PPyObject; + // End of PyDescr_COMMON + d_base : pwrapperbase; + d_wrapped : Pointer; // This can be any function pointer + end; + +{$ENDIF} + + // object.h + PyTypeObject = packed record + ob_refcnt: Integer; + ob_type: PPyTypeObject; + ob_size: Integer; // Number of items in variable part + tp_name: PChar; // For printing + tp_basicsize, tp_itemsize: Integer; // For allocation + + // Methods to implement standard operations + + tp_dealloc: pydestructor; + tp_print: printfunc; + tp_getattr: getattrfunc; + tp_setattr: setattrfunc; + tp_compare: cmpfunc; + tp_repr: reprfunc; + + // Method suites for standard classes + + tp_as_number: PPyNumberMethods; + tp_as_sequence: PPySequenceMethods; + tp_as_mapping: PPyMappingMethods; + + // More standard operations (here for binary compatibility) + + tp_hash: hashfunc; + tp_call: ternaryfunc; + tp_str: reprfunc; + tp_getattro: getattrofunc; + tp_setattro: setattrofunc; + +{$IFDEF PYTHON20_OR_HIGHER} +/// jah 29-sep-2000 : updated for python 2.0 + + // Functions to access object as input/output buffer + tp_as_buffer: PPyBufferProcs; + // Flags to define presence of optional/expanded features + tp_flags: LongInt; + + tp_doc: PChar; // Documentation string + + // call function for all accessible objects + tp_traverse: traverseproc; + + // delete references to contained objects + tp_clear: inquiry; +{$ENDIF} +{$IFDEF PYTHON21_OR_HIGHER} + // rich comparisons + tp_richcompare: richcmpfunc; + + // weak reference enabler + tp_weaklistoffset: Longint; +{$ENDIF} +{$IFDEF PYTHON22_OR_HIGHER} + // Iterators + tp_iter : getiterfunc; + tp_iternext : iternextfunc; + + // Attribute descriptor and subclassing stuff + tp_methods : PPyMethodDef; + tp_members : PPyMemberDef; + tp_getset : PPyGetSetDef; + tp_base : PPyTypeObject; + tp_dict : PPyObject; + tp_descr_get : descrgetfunc; + tp_descr_set : descrsetfunc; + tp_dictoffset : longint; + tp_init : initproc; + tp_alloc : allocfunc; + tp_new : newfunc; + tp_free : pydestructor; // Low-level free-memory routine + tp_is_gc : inquiry; // For PyObject_IS_GC + tp_bases : PPyObject; + tp_mro : PPyObject; // method resolution order + tp_cache : PPyObject; + tp_subclasses : PPyObject; + tp_weaklist : PPyObject; +{$ENDIF} +{$IFDEF PYTHON20} + //More spares + tp_xxx7: LongInt; + tp_xxx8: LongInt; +{$ENDIF} +{$IFDEF PYTHON15} + //More spares + tp_xxx7: LongInt; + tp_xxx8: LongInt; +{$ENDIF} + end; + + PPyMethodChain = ^PyMethodChain; + PyMethodChain = packed record + methods: PPyMethodDef; + link: PPyMethodChain; + end; + + PPyClassObject = ^PyClassObject; + PyClassObject = packed record + // Start of the Head of an object + ob_refcnt : Integer; + ob_type : PPyTypeObject; + // End of the Head of an object + cl_bases : PPyObject; // A tuple of class objects + cl_dict : PPyObject; // A dictionary + cl_name : PPyObject; // A string + // The following three are functions or NULL + cl_getattr : PPyObject; + cl_setattr : PPyObject; + cl_delattr : PPyObject; + end; + + PPyInstanceObject = ^PyInstanceObject; + PyInstanceObject = packed record + // Start of the Head of an object + ob_refcnt : Integer; + ob_type : PPyTypeObject; + // End of the Head of an object + in_class : PPyClassObject; // The class object + in_dict : PPyObject; // A dictionary + end; + +{ Instance method objects are used for two purposes: + (a) as bound instance methods (returned by instancename.methodname) + (b) as unbound methods (returned by ClassName.methodname) + In case (b), im_self is NULL +} + + PPyMethodObject = ^PyMethodObject; + PyMethodObject = packed record + // Start of the Head of an object + ob_refcnt : Integer; + ob_type : PPyTypeObject; + // End of the Head of an object + im_func : PPyObject; // The function implementing the method + im_self : PPyObject; // The instance it is bound to, or NULL + im_class : PPyObject; // The class that defined the method + end; + + + // Bytecode object, compile.h + PPyCodeObject = ^PyCodeObject; + PyCodeObject = packed record + ob_refcnt : Integer; + ob_type : PPyTypeObject; + co_argcount : Integer; // #arguments, except *args + co_nlocals : Integer; // #local variables + co_stacksize : Integer; // #entries needed for evaluation stack + co_flags : Integer; // CO_..., see below + co_code : PPyObject; // instruction opcodes (it hides a PyStringObject) + co_consts : PPyObject; // list (constants used) + co_names : PPyObject; // list of strings (names used) + co_varnames : PPyObject; // tuple of strings (local variable names) +{$IFDEF PYTHON21_OR_HIGHER} + co_freevars : PPyObject; // tuple of strings (free variable names) + co_cellvars : PPyObject; // tuple of strings (cell variable names) +{$ENDIF} + // The rest doesn't count for hash/cmp + co_filename : PPyObject; // string (where it was loaded from) + co_name : PPyObject; // string (name, for reference) + co_firstlineno : Integer; // first source line number + co_lnotab : PPyObject; // string (encoding addr<->lineno mapping) + end; + + + // from pystate.h + PPyInterpreterState = ^PyInterpreterState; + PPyThreadState = ^PyThreadState; + PPyFrameObject = ^PyFrameObject; + + // Interpreter environments + PyInterpreterState = packed record + next : PPyInterpreterState; + tstate_head : PPyThreadState; + + modules : PPyObject; + sysdict : PPyObject; + builtins : PPyObject; + + checkinterval : integer; + end; + + // Thread specific information + PyThreadState = packed record + next : PPyThreadState; + interp : PPyInterpreterState; + + frame : PPyFrameObject; + recursion_depth: integer; + ticker : integer; + tracing : integer; + +{$IFDEF PYTHON23_OR_HIGHER} + sys_profilefn : Pointer; // c-functions for profile/trace + sys_tracefn : Pointer; +{$ENDIF} + sys_profilefunc: PPyObject; + sys_tracefunc : PPyObject; + + curexc_type : PPyObject; + curexc_value : PPyObject; + curexc_traceback: PPyObject; + + exc_type : PPyObject; + exc_value : PPyObject; + exc_traceback : PPyObject; + + dict : PPyObject; +{$IFDEF PYTHON23_OR_HIGHER} + tick_counter :Integer; + gilstate_counter :Integer; + + async_exc :PPyObject; { Asynchronous exception to raise } + thread_id :LongInt; { Thread id where this tstate was created } + + { XXX signal handlers should also be here } +{$ENDIF} + end; + + // from frameobject.h + + PPyTryBlock = ^PyTryBlock; + PyTryBlock = packed record + b_type : Integer; // what kind of block this is + b_handler : Integer; // where to jump to find handler + b_level : Integer; // value stack level to pop to + end; + + CO_MAXBLOCKS = 0..19; + PyFrameObject = packed record + // Start of the VAR_HEAD of an object. + ob_refcnt : Integer; + ob_type : PPyTypeObject; +{$IFDEF PYTHON22_OR_HIGHER} + ob_size : Integer; // Number of items in variable part +{$ENDIF} + // End of the Head of an object + f_back : PPyFrameObject; // previous frame, or NULL + f_code : PPyCodeObject; // code segment + f_builtins : PPyObject; // builtin symbol table (PyDictObject) + f_globals : PPyObject; // global symbol table (PyDictObject) + f_locals : PPyObject; // local symbol table (PyDictObject) + f_valuestack : PPPyObject; // points after the last local +{$IFDEF PYTHON22_OR_HIGHER} + (* Next free slot in f_valuestack. Frame creation sets to f_valuestack. + Frame evaluation usually NULLs it, but a frame that yields sets it + to the current stack top. *) + f_stacktop : PPPyObject; +{$ENDIF} + f_trace : PPyObject; // Trace function + f_exc_type, f_exc_value, f_exc_traceback: PPyObject; + f_tstate : PPyThreadState; + f_lasti : Integer; // Last instruction if called + f_lineno : Integer; // Current line number + f_restricted : Integer; // Flag set if restricted operations + // in this scope + f_iblock : Integer; // index in f_blockstack + f_blockstack : array[CO_MAXBLOCKS] of PyTryBlock; // for try and loop blocks + f_nlocals : Integer; // number of locals +{$IFDEF PYTHON22_OR_HIGHER} + f_ncells : Integer; + f_nfreevars : Integer; +{$ENDIF} + f_stacksize : Integer; // size of value stack + f_localsplus : array[0..0] of PPyObject; // locals+stack, dynamically sized + end; + + // From traceback.c + PPyTraceBackObject = ^PyTraceBackObject; + PyTraceBackObject = packed record + // Start of the Head of an object + ob_refcnt : Integer; + ob_type : PPyTypeObject; + // End of the Head of an object + tb_next : PPyTraceBackObject; + tb_frame : PPyFrameObject; + tb_lasti : Integer; + tb_lineno : Integer; + end; + + // Parse tree node interface + + PNode = ^node; + node = packed record + n_type : smallint; + n_str : PChar; + n_lineno : smallint; + n_nchildren : smallint; + n_child : PNode; + end; + + // From weakrefobject.h + + PPyWeakReference = ^PyWeakReference; + PyWeakReference = packed record + // Start of the Head of an object + ob_refcnt : Integer; + ob_type : PPyTypeObject; + // End of the Head of an object + wr_object : PPyObject; + wr_callback : PPyObject; + hash : longint; + wr_prev : PPyWeakReference; + wr_next : PPyWeakReference; + end; + + // from datetime.h + + +{* Fields are packed into successive bytes, each viewed as unsigned and + * big-endian, unless otherwise noted: + * + * byte offset + * 0 year 2 bytes, 1-9999 + * 2 month 1 byte, 1-12 + * 3 day 1 byte, 1-31 + * 4 hour 1 byte, 0-23 + * 5 minute 1 byte, 0-59 + * 6 second 1 byte, 0-59 + * 7 usecond 3 bytes, 0-999999 + * 10 + *} + +const + { # of bytes for year, month, and day. } + _PyDateTime_DATE_DATASIZE = 4; + + { # of bytes for hour, minute, second, and usecond. } + _PyDateTime_TIME_DATASIZE = 6; + + { # of bytes for year, month, day, hour, minute, second, and usecond. } + _PyDateTime_DATETIME_DATASIZE = 10; +type + PyDateTime_Delta = packed record + // Start of the Head of an object + ob_refcnt : Integer; + ob_type : PPyTypeObject; + // End of the Head of an object + hashcode : Integer; // -1 when unknown + days : Integer; // -MAX_DELTA_DAYS <= days <= MAX_DELTA_DAYS + seconds : Integer; // 0 <= seconds < 24*3600 is invariant + microseconds: Integer; // 0 <= microseconds < 1000000 is invariant + end; + PPyDateTime_Delta = ^PyDateTime_Delta; + + PyDateTime_TZInfo = packed record // a pure abstract base clase + // Start of the Head of an object + ob_refcnt : Integer; + ob_type : PPyTypeObject; + // End of the Head of an object + end; + PPyDateTime_TZInfo = ^PyDateTime_TZInfo; + +{ +/* The datetime and time types have hashcodes, and an optional tzinfo member, + * present if and only if hastzinfo is true. + */ +#define _PyTZINFO_HEAD \ + PyObject_HEAD \ + long hashcode; \ + char hastzinfo; /* boolean flag */ +} + +{* No _PyDateTime_BaseTZInfo is allocated; it's just to have something + * convenient to cast to, when getting at the hastzinfo member of objects + * starting with _PyTZINFO_HEAD. + *} + _PyDateTime_BaseTZInfo = packed record + // Start of _PyTZINFO_HEAD + // Start of the Head of an object + ob_refcnt : Integer; + ob_type : PPyTypeObject; + // End of the Head of an object + hashcode : Integer; + hastzinfo : Char; // boolean flag + // End of _PyTZINFO_HEAD + end; + _PPyDateTime_BaseTZInfo = ^_PyDateTime_BaseTZInfo; + +{* All time objects are of PyDateTime_TimeType, but that can be allocated + * in two ways, with or without a tzinfo member. Without is the same as + * tzinfo == None, but consumes less memory. _PyDateTime_BaseTime is an + * internal struct used to allocate the right amount of space for the + * "without" case. + *} +{#define _PyDateTime_TIMEHEAD \ + _PyTZINFO_HEAD \ + unsigned char data[_PyDateTime_TIME_DATASIZE]; +} + + _PyDateTime_BaseTime = packed record // hastzinfo false + // Start of _PyDateTime_TIMEHEAD + // Start of _PyTZINFO_HEAD + // Start of the Head of an object + ob_refcnt : Integer; + ob_type : PPyTypeObject; + // End of the Head of an object + hashcode : Integer; + hastzinfo : Char; // boolean flag + // End of _PyTZINFO_HEAD + data : array[0..Pred(_PyDateTime_TIME_DATASIZE)] of Byte; + // End of _PyDateTime_TIMEHEAD + end; + _PPyDateTime_BaseTime = ^_PyDateTime_BaseTime; + + PyDateTime_Time = packed record // hastzinfo true + // Start of _PyDateTime_TIMEHEAD + // Start of _PyTZINFO_HEAD + // Start of the Head of an object + ob_refcnt : Integer; + ob_type : PPyTypeObject; + // End of the Head of an object + hashcode : Integer; + hastzinfo : Char; // boolean flag + // End of _PyTZINFO_HEAD + data : array[0..Pred(_PyDateTime_TIME_DATASIZE)] of Byte; + // End of _PyDateTime_TIMEHEAD + tzinfo : PPyObject; + end; + PPyDateTime_Time = ^PyDateTime_Time; + + + +{* All datetime objects are of PyDateTime_DateTimeType, but that can be + * allocated in two ways too, just like for time objects above. In addition, + * the plain date type is a base class for datetime, so it must also have + * a hastzinfo member (although it's unused there). + *} + PyDateTime_Date = packed record + // Start of _PyTZINFO_HEAD + // Start of the Head of an object + ob_refcnt : Integer; + ob_type : PPyTypeObject; + // End of the Head of an object + hashcode : Integer; + hastzinfo : Char; // boolean flag + // End of _PyTZINFO_HEAD + data : array[0..Pred(_PyDateTime_DATE_DATASIZE)] of Byte; + end; + PPyDateTime_Date = ^PyDateTime_Date; + + { +#define _PyDateTime_DATETIMEHEAD \ + _PyTZINFO_HEAD \ + unsigned char data[_PyDateTime_DATETIME_DATASIZE]; +} + + _PyDateTime_BaseDateTime = packed record // hastzinfo false + // Start of _PyTZINFO_HEAD + // Start of the Head of an object + ob_refcnt : Integer; + ob_type : PPyTypeObject; + // End of the Head of an object + hashcode : Integer; + hastzinfo : Char; // boolean flag + // End of _PyTZINFO_HEAD + data : array[0..Pred(_PyDateTime_DATETIME_DATASIZE)] of Byte; + end; + _PPyDateTime_BaseDateTime = ^_PyDateTime_BaseDateTime; + + PyDateTime_DateTime = packed record // hastzinfo true + // Start of _PyDateTime_DATETIMEHEAD + // Start of _PyTZINFO_HEAD + // Start of the Head of an object + ob_refcnt : Integer; + ob_type : PPyTypeObject; + // End of the Head of an object + hashcode : Integer; + hastzinfo : Char; // boolean flag + // End of _PyTZINFO_HEAD + data : array[0..Pred(_PyDateTime_DATETIME_DATASIZE)] of Byte; + // End of _PyDateTime_DATETIMEHEAD + tzinfo : PPyObject; + end; + PPyDateTime_DateTime = ^PyDateTime_DateTime; + + +//####################################################### +//## ## +//## New exception classes ## +//## ## +//####################################################### + + // Components' exceptions + EDLLLoadError = class(Exception); + EDLLImportError = class(Exception) + public + WrongFunc : String; + ErrorCode : Integer; + end; + + // Python's exceptions + EPythonError = class(Exception) + public + EName : String; + EValue : String; + end; + EPyExecError = class(EPythonError); + + + // Standard exception classes of Python + +{$IFDEF PYTHON20_OR_HIGHER} +/// jah 29-sep-2000 : updated for python 2.0 +/// base classes updated according python documentation + +{ Hierarchy of Python exceptions, Python 2.3, copied from \Python\exceptions.c + +Exception\n\ + |\n\ + +-- SystemExit\n\ + +-- StopIteration\n\ + +-- StandardError\n\ + | |\n\ + | +-- KeyboardInterrupt\n\ + | +-- ImportError\n\ + | +-- EnvironmentError\n\ + | | |\n\ + | | +-- IOError\n\ + | | +-- OSError\n\ + | | |\n\ + | | +-- WindowsError\n\ + | | +-- VMSError\n\ + | |\n\ + | +-- EOFError\n\ + | +-- RuntimeError\n\ + | | |\n\ + | | +-- NotImplementedError\n\ + | |\n\ + | +-- NameError\n\ + | | |\n\ + | | +-- UnboundLocalError\n\ + | |\n\ + | +-- AttributeError\n\ + | +-- SyntaxError\n\ + | | |\n\ + | | +-- IndentationError\n\ + | | |\n\ + | | +-- TabError\n\ + | |\n\ + | +-- TypeError\n\ + | +-- AssertionError\n\ + | +-- LookupError\n\ + | | |\n\ + | | +-- IndexError\n\ + | | +-- KeyError\n\ + | |\n\ + | +-- ArithmeticError\n\ + | | |\n\ + | | +-- OverflowError\n\ + | | +-- ZeroDivisionError\n\ + | | +-- FloatingPointError\n\ + | |\n\ + | +-- ValueError\n\ + | | |\n\ + | | +-- UnicodeError\n\ + | | |\n\ + | | +-- UnicodeEncodeError\n\ + | | +-- UnicodeDecodeError\n\ + | | +-- UnicodeTranslateError\n\ + | |\n\ + | +-- ReferenceError\n\ + | +-- SystemError\n\ + | +-- MemoryError\n\ + |\n\ + +---Warning\n\ + |\n\ + +-- UserWarning\n\ + +-- DeprecationWarning\n\ + +-- PendingDeprecationWarning\n\ + +-- SyntaxWarning\n\ + +-- RuntimeWarning\n\ + +-- FutureWarning" +} + EPyException = class (EPythonError); + EPyStandardError = class (EPyException); + EPyArithmeticError = class (EPyStandardError); + EPyLookupError = class (EPyStandardError); + EPyAssertionError = class (EPyStandardError); + EPyAttributeError = class (EPyStandardError); + EPyEOFError = class (EPyStandardError); + EPyFloatingPointError = class (EPyArithmeticError); + EPyEnvironmentError = class (EPyStandardError); + EPyIOError = class (EPyEnvironmentError); + EPyOSError = class (EPyEnvironmentError); + EPyImportError = class (EPyStandardError); + EPyIndexError = class (EPyLookupError); + EPyKeyError = class (EPyLookupError); + EPyKeyboardInterrupt = class (EPyStandardError); + EPyMemoryError = class (EPyStandardError); + EPyNameError = class (EPyStandardError); + EPyOverflowError = class (EPyArithmeticError); + EPyRuntimeError = class (EPyStandardError); + EPyNotImplementedError = class (EPyRuntimeError); + EPySyntaxError = class (EPyStandardError) + public + EFileName: string; + ELineStr: string; + ELineNumber: Integer; + EOffset: Integer; + end; + EPyIndentationError = class (EPySyntaxError); + EPyTabError = class (EPyIndentationError); + EPySystemError = class (EPyStandardError); + EPySystemExit = class (EPyException); + EPyTypeError = class (EPyStandardError); + EPyUnboundLocalError = class (EPyNameError); + EPyValueError = class (EPyStandardError); + EPyUnicodeError = class (EPyValueError); +{$IFDEF PYTHON23_OR_HIGHER} + UnicodeEncodeError = class (EPyUnicodeError); + UnicodeDecodeError = class (EPyUnicodeError); + UnicodeTranslateError = class (EPyUnicodeError); +{$ENDIF} + EPyZeroDivisionError = class (EPyArithmeticError); + EPyStopIteration = class(EPyException); + EPyWarning = class (EPyException); + EPyUserWarning = class (EPyWarning); + EPyDeprecationWarning = class (EPyWarning); +{$IFDEF PYTHON23_OR_HIGHER} + PendingDeprecationWarning = class (EPyWarning); + FutureWarning = class (EPyWarning); +{$ENDIF} + EPySyntaxWarning = class (EPyWarning); + EPyRuntimeWarning = class (EPyWarning); + EPyReferenceError = class (EPyStandardError); + {$IFDEF MSWINDOWS} + EPyWindowsError = class (EPyOSError); + {$ENDIF} +{$ENDIF} +{$IFDEF PYTHON15} + EPyException = class (EPythonError); + EPyStandardError = class (EPyException); + + EPyAttributeError = class (EPythonError); + EPyEOFError = class (EPyException); + EPyIOError = class (EPyException); + EPyImportError = class (EPyException); + EPyKeyboardInterrupt = class (EPyException); + EPyMemoryError = class (EPyException); + EPyNameError = class (EPyException); + EPyRuntimeError = class (EPyException); + EPySystemError = class (EPyException); + EPySystemExit = class (EPyException); + EPyTypeError = class (EPyException); + EPyValueError = class (EPyException); + EPySyntaxError = class (EPyException) + public + EFileName: string; + ELineStr: string; + ELineNumber: Integer; + EOffset: Integer; + end; + + EPyArithmeticError = class (EPyStandardError); + EPyOverflowError = class (EPyArithmeticError); + EPyZeroDivisionError = class (EPyArithmeticError); + EPyFloatingPointError = class (EPyArithmeticError); + + EPyLookupError = class (EPyStandardError); + EPyIndexError = class (EPyLookupError); + EPyKeyError = class (EPyLookupError); +{$ENDIF} + + +{$IFNDEF HAS_SYNCOBJS_UNIT} + {$IFDEF MSWINDOWS} + TCriticalSection = class + protected + FSection: TRTLCriticalSection; + public + constructor Create; + destructor Destroy; override; + procedure Acquire; + procedure Release; + procedure Enter; + procedure Leave; + end; + {$ENDIF} +{$ENDIF} + +//####################################################### +//## ## +//## Components ## +//## ## +//####################################################### + +//------------------------------------------------------- +//-- -- +//-- class: TPythonInputOutput -- +//-- Works as a console for Python outputs -- +//-- It's a virtual Base class -- +//------------------------------------------------------- + +const + kMaxLines = 1000; + kMaxLineLength = 256; + +type + TSendDataEvent = procedure (Sender: TObject; const Data : String ) of object; + TReceiveDataEvent = procedure (Sender: TObject; var Data : String ) of object; +{$IFDEF UNICODE_SUPPORT} + TSendUniDataEvent = procedure (Sender: TObject; const Data : WideString ) of object; + TReceiveUniDataEvent = procedure (Sender: TObject; var Data : WideString ) of object; + IOChar = WideChar; + IOString = WideString; + TIOStringList = TWideStringList; +{$ELSE} + IOChar = Char; + IOString = String; + TIOStringList = TStringList; +{$ENDIF} + + TPythonInputOutput = class(TComponent) + private + { Déclarations privées } + protected + { Déclarations protégées } + FMaxLines : Integer; + FLine_Buffer : IOString; + FLinesPerThread : TIOStringList; + FLock : TCriticalSection; + FQueue : TIOStringList; + FDelayWrites : Boolean; + FMaxLineLength : Integer; + FOnSendData : TSendDataEvent; + FOnReceiveData : TReceiveDataEvent; + FOnSendUniData : TSendUniDataEvent; + FOnReceiveUniData: TReceiveUniDataEvent; + FUnicodeIO : Boolean; + FRawOutput : Boolean; + + procedure Lock; + procedure Unlock; + procedure AddWrite( const str : IOString ); + // Virtual methods for handling the input/output of text + procedure SendData( const Data : String ); virtual; + function ReceiveData : String; virtual; +{$IFDEF UNICODE_SUPPORT} + procedure SendUniData( const Data : WideString ); virtual; + function ReceiveUniData : WideString; virtual; +{$ENDIF} + procedure AddPendingWrite; virtual; + function GetCurrentThreadSlotIdx : Integer; + function GetCurrentThreadLine : IOString; + procedure UpdateCurrentThreadLine; + + public + { Déclarations publiques } + constructor Create( AOwner : TComponent ); override; + destructor Destroy; override; + + procedure Write( const str : IOString ); + procedure WriteLine( const str : IOString ); + + published + { Déclarations publiées } + property MaxLines : Integer read FMaxLines write FMaxLines default kMaxLines; + property MaxLineLength : Integer read FMaxLineLength write FMaxLineLength default kMaxLineLength; + property DelayWrites : Boolean read FDelayWrites write FDelayWrites default False; + property OnSendData : TSendDataEvent read FOnSendData write FOnSendData; + property OnReceiveData : TReceiveDataEvent read FOnReceiveData write FOnReceiveData; +{$IFDEF UNICODE_SUPPORT} + property OnSendUniData : TSendUniDataEvent read FOnSendUniData write FOnSendUniData; + property OnReceiveUniData : TReceiveUniDataEvent read FOnReceiveUniData write FOnReceiveUniData; + property UnicodeIO: Boolean read FUnicodeIO write FUnicodeIO; + property RawOutput: Boolean read FRawOutput write FRawOutput; +{$ENDIF} + end; + +//------------------------------------------------------- +//-- -- +//-- Base class: TDynamicDll -- +//-- -- +//------------------------------------------------------- + +type + TDynamicDll = class(TComponent) + private + function IsAPIVersionStored: Boolean; + function IsDllNameStored: Boolean; + function IsRegVersionStored: Boolean; + procedure SetDllName(const Value: String); + protected + FDllName : String; + FDllPath : String; + FAPIVersion : Integer; + FRegVersion : String; + FAutoLoad : Boolean; + FAutoUnload : Boolean; + FFatalMsgDlg : Boolean; + FFatalAbort : Boolean; + FDLLHandle : THandle; + FUseLastKnownVersion: Boolean; + FOnBeforeLoad : TNotifyEvent; + FOnAfterLoad : TNotifyEvent; + FOnBeforeUnload : TNotifyEvent; + + function Import(const funcname: String; canFail : Boolean = True): Pointer; + procedure Loaded; override; + procedure BeforeLoad; virtual; + procedure AfterLoad; virtual; + procedure BeforeUnload; virtual; + function GetQuitMessage : String; virtual; + procedure DoOpenDll(const aDllName : String); virtual; + function GetDllPath : String; + + public + // Constructors & Destructors + constructor Create(AOwner: TComponent); override; + destructor Destroy; override; + + // Public methods + procedure OpenDll(const aDllName : String); + function IsHandleValid : Boolean; + procedure LoadDll; + procedure UnloadDll; + procedure Quit; + + // Public properties + published + property AutoLoad : Boolean read FAutoLoad write FAutoLoad default True; + property AutoUnload : Boolean read FAutoUnload write FAutoUnload default True; + property DllName : String read FDllName write SetDllName stored IsDllNameStored; + property DllPath : String read FDllPath write FDllPath; + property APIVersion : Integer read FAPIVersion write FAPIVersion stored IsAPIVersionStored; + property RegVersion : String read FRegVersion write FRegVersion stored IsRegVersionStored; + property FatalAbort : Boolean read FFatalAbort write FFatalAbort default True; + property FatalMsgDlg : Boolean read FFatalMsgDlg write FFatalMsgDlg default True; + property UseLastKnownVersion: Boolean read FUseLastKnownVersion write FUseLastKnownVersion default True; + property OnAfterLoad : TNotifyEvent read FOnAfterLoad write FOnAfterLoad; + property OnBeforeLoad : TNotifyEvent read FOnBeforeLoad write FOnBeforeLoad; + property OnBeforeUnload : TNotifyEvent read FOnBeforeUnload write FOnBeforeUnload; + end; + +//------------------------------------------------------- +//-- -- +//-- class: TPythonInterface derived from TDynamicDll-- +//-- This class maps the functions imported -- +//-- from the Python Dll, and adds some -- +//-- Delphi implementations. -- +//------------------------------------------------------- + +type + TPythonInterface=class(TDynamicDll) + private + DLL_PyArg_Parse: function( args: PPyObject; format: PChar {;....}) : + Integer; cdecl; + DLL_PyArg_ParseTuple: + function( args: PPyObject; format: PChar {;...}): + Integer; cdecl; + DLL_Py_BuildValue: + function( format: PChar {;...}): PPyObject; cdecl; + DLL_PyCode_Addr2Line: + function ( co: PPyCodeObject; addrq : Integer ) : Integer; cdecl; + DLL_Py_GetBuildInfo: + function : PChar; cdecl; + DLL_PyImport_ExecCodeModule: + function ( const name : String; codeobject : PPyObject) : PPyObject; cdecl; + + protected + FInitialized: Boolean; + FFinalizing: Boolean; + function GetInitialized: Boolean; + + procedure AfterLoad; override; + function GetQuitMessage : String; override; + procedure CheckPython; + function GetUnicodeTypeSuffix : String; + + public + // define Python flags. See file pyDebug.h + Py_DebugFlag: PInt; + Py_VerboseFlag: PInt; + Py_InteractiveFlag: PInt; + Py_OptimizeFlag: PInt; + Py_NoSiteFlag: PInt; + Py_UseClassExceptionsFlag: PInt; + Py_FrozenFlag: PInt; + Py_TabcheckFlag: PInt; +{$IFDEF PYTHON20_OR_HIGHER} + Py_UnicodeFlag: PInt; +{$ENDIF} +{$IFDEF PYTHON22_OR_HIGHER} + Py_IgnoreEnvironmentFlag: PInt; + Py_DivisionWarningFlag: PInt; +{$ENDIF} + //_PySys_TraceFunc: PPPyObject; + //_PySys_ProfileFunc: PPPPyObject; + + PyImport_FrozenModules: PP_frozen; + + Py_None: PPyObject; + Py_Ellipsis: PPyObject; + Py_False: PPyIntObject; + Py_True: PPyIntObject; +{$IFDEF PYTHON21_OR_HIGHER} + Py_NotImplemented: PPyObject; +{$ENDIF} + + PyExc_AttributeError: PPPyObject; + PyExc_EOFError: PPPyObject; + PyExc_IOError: PPPyObject; + PyExc_ImportError: PPPyObject; + PyExc_IndexError: PPPyObject; + PyExc_KeyError: PPPyObject; + PyExc_KeyboardInterrupt: PPPyObject; + PyExc_MemoryError: PPPyObject; + PyExc_NameError: PPPyObject; + PyExc_OverflowError: PPPyObject; + PyExc_RuntimeError: PPPyObject; + PyExc_SyntaxError: PPPyObject; + PyExc_SystemError: PPPyObject; + PyExc_SystemExit: PPPyObject; + PyExc_TypeError: PPPyObject; + PyExc_ValueError: PPPyObject; + PyExc_ZeroDivisionError: PPPyObject; + PyExc_ArithmeticError: PPPyObject; + PyExc_Exception: PPPyObject; + PyExc_FloatingPointError: PPPyObject; + PyExc_LookupError: PPPyObject; + PyExc_StandardError: PPPyObject; +{$IFDEF PYTHON20_OR_HIGHER} + PyExc_AssertionError: PPPyObject; + PyExc_EnvironmentError: PPPyObject; + PyExc_IndentationError: PPPyObject; + PyExc_MemoryErrorInst: PPPyObject; + PyExc_NotImplementedError: PPPyObject; + PyExc_OSError: PPPyObject; + PyExc_TabError: PPPyObject; + PyExc_UnboundLocalError: PPPyObject; + PyExc_UnicodeError: PPPyObject; + {$IFDEF MSWINDOWS} + PyExc_WindowsError: PPPyObject; + {$ENDIF} +{$ENDIF} +{$IFDEF PYTHON21_OR_HIGHER} + PyExc_Warning: PPPyObject; + PyExc_DeprecationWarning: PPPyObject; + PyExc_RuntimeWarning: PPPyObject; + PyExc_SyntaxWarning: PPPyObject; + PyExc_UserWarning: PPPyObject; +{$ENDIF} +{$IFDEF PYTHON22_OR_HIGHER} + PyExc_ReferenceError: PPPyObject; + PyExc_StopIteration: PPPyObject; +{$ENDIF} +{$IFDEF PYTHON23_OR_HIGHER} + PyExc_FutureWarning: PPPyObject; + PyExc_PendingDeprecationWarning: PPPyObject; + PyExc_UnicodeDecodeError: PPPyObject; + PyExc_UnicodeEncodeError: PPPyObject; + PyExc_UnicodeTranslateError: PPPyObject; +{$ENDIF} + + PyType_Type: PPyTypeObject; + PyCFunction_Type: PPyTypeObject; + PyCObject_Type: PPyTypeObject; + PyClass_Type: PPyTypeObject; + PyCode_Type: PPyTypeObject; + PyComplex_Type: PPyTypeObject; + PyDict_Type: PPyTypeObject; + PyFile_Type: PPyTypeObject; + PyFloat_Type: PPyTypeObject; + PyFrame_Type: PPyTypeObject; + PyFunction_Type: PPyTypeObject; + PyInstance_Type: PPyTypeObject; + PyInt_Type: PPyTypeObject; + PyList_Type: PPyTypeObject; + PyLong_Type: PPyTypeObject; + PyMethod_Type: PPyTypeObject; + PyModule_Type: PPyTypeObject; + PyObject_Type: PPyTypeObject; + PyRange_Type: PPyTypeObject; + PySlice_Type: PPyTypeObject; + PyString_Type: PPyTypeObject; + PyTuple_Type: PPyTypeObject; +{$IFDEF PYTHON20_OR_HIGHER} + PyBaseObject_Type: PPyTypeObject; + PyBuffer_Type: PPyTypeObject; + PyCallIter_Type: PPyTypeObject; + PyCell_Type: PPyTypeObject; + PyClassMethod_Type: PPyTypeObject; + PyProperty_Type: PPyTypeObject; + PySeqIter_Type: PPyTypeObject; + PyStaticMethod_Type: PPyTypeObject; + PySuper_Type: PPyTypeObject; + {$IFNDEF PYTHON25_OR_HIGHER} + PySymtableEntry_Type: PPyTypeObject; + {$ENDIF} + PyTraceBack_Type: PPyTypeObject; + PyUnicode_Type: PPyTypeObject; + PyWrapperDescr_Type: PPyTypeObject; +{$ENDIF} +{$IFDEF PYTHON22_OR_HIGHER} + _PyWeakref_RefType: PPyTypeObject; + _PyWeakref_ProxyType: PPyTypeObject; + _PyWeakref_CallableProxyType: PPyTypeObject; +{$ENDIF} +{$IFDEF PYTHON23_OR_HIGHER} + PyBaseString_Type: PPyTypeObject; + PyBool_Type: PPyTypeObject; + PyEnum_Type: PPyTypeObject; +{$ENDIF} + + //PyArg_GetObject: function(args : PPyObject; nargs, i: integer; p_a: PPPyObject): integer; cdecl; + //PyArg_GetLong: function(args : PPyObject; nargs, i: integer; p_a: PLong): integer; cdecl; + //PyArg_GetShort: function(args : PPyObject; nargs, i: integer; p_a: PShort): integer; cdecl; + //PyArg_GetFloat: function(args : PPyObject; nargs, i: integer; p_a: PFloat): integer; cdecl; + //PyArg_GetString: function(args : PPyObject; nargs, i: integer; p_a: PString): integer; cdecl; + //PyArgs_VaParse: function (args : PPyObject; format: PChar; va_list: array of const): integer; cdecl; + // Does not work! + // Py_VaBuildValue: function (format: PChar; va_list: array of const): PPyObject; cdecl; + //PyBuiltin_Init: procedure; cdecl; + + PyComplex_FromCComplex: function(c: Py_complex):PPyObject; cdecl; + PyComplex_FromDoubles: function(realv,imag : double):PPyObject; cdecl; + PyComplex_RealAsDouble: function(op : PPyObject ): double; cdecl; + PyComplex_ImagAsDouble: function(op : PPyObject ): double; cdecl; + PyComplex_AsCComplex: function(op : PPyObject ): Py_complex; cdecl; + PyCFunction_GetFunction: function(ob : PPyObject): Pointer; cdecl; + PyCFunction_GetSelf: function(ob : PPyObject): PPyObject; cdecl; + PyCallable_Check: function(ob : PPyObject): integer; cdecl; + PyCObject_FromVoidPtr: function(cobj, destruct : Pointer): PPyObject; cdecl; + PyCObject_AsVoidPtr: function(ob : PPyObject): Pointer; cdecl; + PyClass_New: function (ob1,ob2,ob3 : PPyObject): PPyObject; cdecl; + PyClass_IsSubclass: function (ob1, ob2 : PPyObject): integer cdecl; + + Py_InitModule4: function( name: PChar; methods: PPyMethodDef; doc: PChar; + passthrough: PPyObject; Api_Version: Integer):PPyObject; cdecl; + PyErr_BadArgument: function: integer; cdecl; + PyErr_BadInternalCall: procedure; cdecl; + PyErr_CheckSignals: function: integer; cdecl; + PyErr_Clear: procedure; cdecl; + PyErr_Fetch: procedure( errtype, errvalue, errtraceback: PPPyObject); cdecl; + PyErr_NoMemory: function: PPyObject; cdecl; + PyErr_Occurred: function: PPyObject; cdecl; + PyErr_Print: procedure; cdecl; + PyErr_Restore: procedure (errtype, errvalue, errtraceback: PPyObject); cdecl; + PyErr_SetFromErrno: function (ob : PPyObject):PPyObject; cdecl; + PyErr_SetNone: procedure(value: PPyObject); cdecl; + PyErr_SetObject: procedure (ob1, ob2 : PPyObject); cdecl; + PyErr_SetString: procedure( ErrorObject: PPyObject; text: PChar); cdecl; + PyImport_GetModuleDict: function: PPyObject; cdecl; + PyInt_FromLong: function( x: LongInt):PPyObject; cdecl; + Py_Initialize: procedure; cdecl; + Py_Exit: procedure( RetVal: Integer); cdecl; + PyEval_GetBuiltins: function: PPyObject; cdecl; + PyDict_Copy: function(mp: PPyObject):PPyObject; cdecl; + PyDict_GetItem: function(mp, key : PPyObject):PPyObject; cdecl; + PyDict_SetItem: function(mp, key, item :PPyObject ):integer; cdecl; + PyDict_DelItem: function(mp, key : PPyObject ):integer; cdecl; + PyDict_Clear: procedure(mp : PPyObject); cdecl; + PyDict_Next: function(mp : PPyObject; pos: PInt; key, value: PPPyObject):integer; cdecl; + PyDict_Keys: function(mp: PPyObject):PPyObject; cdecl; + PyDict_Values: function(mp: PPyObject):PPyObject; cdecl; + PyDict_Items: function(mp: PPyObject):PPyObject; cdecl; + PyDict_Size: function(mp: PPyObject):integer; cdecl; + PyDict_DelItemString: function(dp : PPyObject;key : PChar ):integer; cdecl; + PyDict_New: function: PPyObject; cdecl; + PyDict_GetItemString: function( dp: PPyObject; key: PChar): PPyObject; cdecl; + PyDict_SetItemString: function( dp: PPyObject; key: PChar; item: PPyObject): + Integer; cdecl; +{$IFDEF PYTHON22_OR_HIGHER} + PyDictProxy_New: function (obj : PPyObject) : PPyObject; cdecl; +{$ENDIF} + PyModule_GetDict: function( module:PPyObject): PPyObject; cdecl; + PyObject_Str: function( v: PPyObject): PPyObject; cdecl; + PyRun_String: function( str: PChar; start: Integer; globals: PPyObject; + locals: PPyObject): PPyObject; cdecl; + PyRun_SimpleString: function( str: PChar): Integer; cdecl; + PyString_AsString: function( ob: PPyObject): PChar; cdecl; + PyString_FromString: function( str: PChar): PPyObject; cdecl; + PySys_SetArgv: procedure( argc: Integer; argv: PPChar); cdecl; + +{+ means, Grzegorz or me has tested his non object version of this function} +{+} PyCFunction_New: function(md:PPyMethodDef;ob:PPyObject):PPyObject; cdecl; +{+} PyEval_CallObject: function(callable_obj, args:PPyObject):PPyObject; cdecl; +{-} PyEval_CallObjectWithKeywords:function (callable_obj, args, kw:PPyObject):PPyObject; cdecl; +{-} PyEval_GetFrame:function :PPyObject; cdecl; +{-} PyEval_GetGlobals:function :PPyObject; cdecl; +{-} PyEval_GetLocals:function :PPyObject; cdecl; +{-} //PyEval_GetOwner:function :PPyObject; cdecl; +{-} PyEval_GetRestricted:function :integer; cdecl; + +{-} PyEval_InitThreads:procedure; cdecl; +{-} PyEval_RestoreThread:procedure( tstate: PPyThreadState); cdecl; +{-} PyEval_SaveThread:function :PPyThreadState; cdecl; + +{-} PyFile_FromString:function (pc1,pc2:PChar):PPyObject; cdecl; +{-} PyFile_GetLine:function (ob:PPyObject;i:integer):PPyObject; cdecl; +{-} PyFile_Name:function (ob:PPyObject):PPyObject; cdecl; +{-} PyFile_SetBufSize:procedure(ob:PPyObject;i:integer); cdecl; +{-} PyFile_SoftSpace:function (ob:PPyObject;i:integer):integer; cdecl; +{-} PyFile_WriteObject:function (ob1,ob2:PPyObject;i:integer):integer; cdecl; +{-} PyFile_WriteString:procedure(s:PChar;ob:PPyObject); cdecl; +{+} PyFloat_AsDouble:function (ob:PPyObject):DOUBLE; cdecl; +{+} PyFloat_FromDouble:function (db:double):PPyObject; cdecl; +{-} PyFunction_GetCode:function (ob:PPyObject):PPyObject; cdecl; +{-} PyFunction_GetGlobals:function (ob:PPyObject):PPyObject; cdecl; +{-} PyFunction_New:function (ob1,ob2:PPyObject):PPyObject; cdecl; +{-} PyImport_AddModule:function (name:PChar):PPyObject; cdecl; +{-} PyImport_Cleanup:procedure; cdecl; +{-} PyImport_GetMagicNumber:function :LONGINT; cdecl; +{+} PyImport_ImportFrozenModule:function (key:PChar):integer; cdecl; +{+} PyImport_ImportModule:function (name:PChar):PPyObject; cdecl; +{+} PyImport_Import:function (name:PPyObject):PPyObject; cdecl; +{-} //PyImport_Init:procedure; cdecl; +{-} PyImport_ReloadModule:function (ob:PPyObject):PPyObject; cdecl; +{-} PyInstance_New:function (obClass, obArg, obKW:PPyObject):PPyObject; cdecl; +{+} PyInt_AsLong:function (ob:PPyObject):LONGINT; cdecl; +{-} PyList_Append:function (ob1,ob2:PPyObject):integer; cdecl; +{-} PyList_AsTuple:function (ob:PPyObject):PPyObject; cdecl; +{+} PyList_GetItem:function (ob:PPyObject;i:integer):PPyObject; cdecl; +{-} PyList_GetSlice:function (ob:PPyObject;i1,i2:integer):PPyObject; cdecl; +{-} PyList_Insert:function (dp:PPyObject;idx:Integer;item:PPyObject):integer; cdecl; +{-} PyList_New:function (size:integer):PPyObject; cdecl; +{-} PyList_Reverse:function (ob:PPyObject):integer; cdecl; +{-} PyList_SetItem:function (dp:PPyObject;idx:Integer;item:PPyObject):integer; cdecl; +{-} PyList_SetSlice:function (ob:PPyObject;i1,i2:integer;ob2:PPyObject):integer; cdecl; +{+} PyList_Size:function (ob:PPyObject):integer; cdecl; +{-} PyList_Sort:function (ob:PPyObject):integer; cdecl; +{-} PyLong_AsDouble:function (ob:PPyObject):DOUBLE; cdecl; +{+} PyLong_AsLong:function (ob:PPyObject):LONGINT; cdecl; +{+} PyLong_FromDouble:function (db:double):PPyObject; cdecl; +{+} PyLong_FromLong:function (l:longint):PPyObject; cdecl; +{-} PyLong_FromString:function (pc:PChar;var ppc:PChar;i:integer):PPyObject; cdecl; +{-} PyLong_FromUnsignedLong:function(val:cardinal) : PPyObject; cdecl; +{-} PyLong_AsUnsignedLong:function(ob:PPyObject) : Cardinal; cdecl; +{$IFDEF UNICODE_SUPPORT} +{-} PyLong_FromUnicode:function(ob:PPyObject; a, b : integer) : PPyObject; cdecl; +{$ENDIF} +{$IFDEF DELPHI6_OR_HIGHER} +{-} PyLong_FromLongLong:function(val:Int64) : PPyObject; cdecl; +{-} PyLong_AsLongLong:function(ob:PPyObject) : Int64; cdecl; +{$ENDIF} +{-} PyMapping_Check:function (ob:PPyObject):integer; cdecl; +{-} PyMapping_GetItemString:function (ob:PPyObject;key:PChar):PPyObject; cdecl; +{-} PyMapping_HasKey:function (ob,key:PPyObject):integer; cdecl; +{-} PyMapping_HasKeyString:function (ob:PPyObject;key:PChar):integer; cdecl; +{-} PyMapping_Length:function (ob:PPyObject):integer; cdecl; +{-} PyMapping_SetItemString:function (ob:PPyObject; key:PChar; value:PPyObject):integer; cdecl; +{-} PyMethod_Class:function (ob:PPyObject):PPyObject; cdecl; +{-} PyMethod_Function:function (ob:PPyObject):PPyObject; cdecl; +{-} PyMethod_New:function (ob1,ob2,ob3:PPyObject):PPyObject; cdecl; +{-} PyMethod_Self:function (ob:PPyObject):PPyObject; cdecl; +{-} PyModule_GetName:function (ob:PPyObject):PChar; cdecl; +{-} PyModule_New:function (key:PChar):PPyObject; cdecl; +{-} PyNumber_Absolute:function (ob:PPyObject):PPyObject; cdecl; +{-} PyNumber_Add:function (ob1,ob2:PPyObject):PPyObject; cdecl; +{-} PyNumber_And:function (ob1,ob2:PPyObject):PPyObject; cdecl; +{-} PyNumber_Check:function (ob:PPyObject):integer; cdecl; +{-} PyNumber_Coerce:function (var ob1,ob2:PPyObject):integer; cdecl; +{-} PyNumber_Divide:function (ob1,ob2:PPyObject):PPyObject; cdecl; +{$IFDEF PYTHON22_OR_HIGHER} +{-} PyNumber_FloorDivide:function (ob1,ob2:PPyObject):PPyObject; cdecl; +{-} PyNumber_TrueDivide:function (ob1,ob2:PPyObject):PPyObject; cdecl; +{$ENDIF} +{-} PyNumber_Divmod:function (ob1,ob2:PPyObject):PPyObject; cdecl; +{-} PyNumber_Float:function (ob:PPyObject):PPyObject; cdecl; +{-} PyNumber_Int:function (ob:PPyObject):PPyObject; cdecl; +{-} PyNumber_Invert:function (ob:PPyObject):PPyObject; cdecl; +{-} PyNumber_Long:function (ob:PPyObject):PPyObject; cdecl; +{-} PyNumber_Lshift:function (ob1,ob2:PPyObject):PPyObject; cdecl; +{-} PyNumber_Multiply:function (ob1,ob2:PPyObject):PPyObject; cdecl; +{-} PyNumber_Negative:function (ob:PPyObject):PPyObject; cdecl; +{-} PyNumber_Or:function (ob1,ob2:PPyObject):PPyObject; cdecl; +{-} PyNumber_Positive:function (ob:PPyObject):PPyObject; cdecl; +{-} PyNumber_Power:function (ob1,ob2,ob3:PPyObject):PPyObject; cdecl; +{-} PyNumber_Remainder:function (ob1,ob2:PPyObject):PPyObject; cdecl; +{-} PyNumber_Rshift:function (ob1,ob2:PPyObject):PPyObject; cdecl; +{-} PyNumber_Subtract:function (ob1,ob2:PPyObject):PPyObject; cdecl; +{-} PyNumber_Xor:function (ob1,ob2:PPyObject):PPyObject; cdecl; +{-} PyOS_InitInterrupts:procedure; cdecl; +{-} PyOS_InterruptOccurred:function :integer; cdecl; +{+} PyObject_CallObject:function (ob,args:PPyObject):PPyObject; cdecl; + PyObject_CallMethodStr: function ( obj : PPyObject; method, format, value : PChar ) : PPyObject; cdecl; +{-} PyObject_Compare:function (ob1,ob2:PPyObject):integer; cdecl; +{-} PyObject_GetAttr:function (ob1,ob2:PPyObject):PPyObject; cdecl; +{+} PyObject_GetAttrString:function (ob:PPyObject;c:PChar):PPyObject; cdecl; +{-} PyObject_GetItem:function (ob,key:PPyObject):PPyObject; cdecl; +{-} PyObject_DelItem:function (ob,key:PPyObject):PPyObject; cdecl; +{-} PyObject_HasAttrString:function (ob:PPyObject;key:PChar):integer; cdecl; +{-} PyObject_Hash:function (ob:PPyObject):LONGINT; cdecl; +{-} PyObject_IsTrue:function (ob:PPyObject):integer; cdecl; +{-} PyObject_Length:function (ob:PPyObject):integer; cdecl; +{-} PyObject_Repr:function (ob:PPyObject):PPyObject; cdecl; +{-} PyObject_SetAttr:function (ob1,ob2,ob3:PPyObject):integer; cdecl; +{-} PyObject_SetAttrString:function (ob:PPyObject;key:Pchar;value:PPyObject):integer; cdecl; +{-} PyObject_SetItem:function (ob1,ob2,ob3:PPyObject):integer; cdecl; +{$IFDEF PYTHON20_OR_HIGHER} +{-} PyObject_Init:function (ob:PPyObject; t:PPyTypeObject):PPyObject; cdecl; +{-} PyObject_InitVar:function (ob:PPyObject; t:PPyTypeObject; size:integer):PPyObject; cdecl; +{-} PyObject_New:function (t:PPyTypeObject):PPyObject; cdecl; +{-} PyObject_NewVar:function (t:PPyTypeObject; size:integer):PPyObject; cdecl; + PyObject_Free:procedure (ob:PPyObject); cdecl; + PyObject_GetIter: function (obj: PPyObject) : PPyObject; cdecl; + PyIter_Next: function (obj: PPyObject) : PPyObject; cdecl; +{$ENDIF} +{$IFDEF PYTHON21_OR_HIGHER} +{-} PyObject_IsInstance:function (inst, cls:PPyObject):integer; cdecl; +{-} PyObject_IsSubclass:function (derived, cls:PPyObject):integer; cdecl; +{$ENDIF} +{$IFDEF PYTHON22_OR_HIGHER} + PyObject_Call:function (ob, args, kw:PPyObject):PPyObject; cdecl; + PyObject_GenericGetAttr:function (obj, name : PPyObject) : PPyObject; cdecl; + PyObject_GenericSetAttr:function (obj, name, value : PPyObject) : Integer; cdecl; +{$ENDIF} +{$IFDEF PYTHON23_OR_HIGHER} +{-} PyObject_GC_Malloc:function (size:integer):PPyObject; cdecl; +{-} PyObject_GC_New:function (t:PPyTypeObject):PPyObject; cdecl; +{-} PyObject_GC_NewVar:function (t:PPyTypeObject; size:integer):PPyObject; cdecl; +{-} PyObject_GC_Resize:function (t:PPyObject; newsize:integer):PPyObject; cdecl; +{-} PyObject_GC_Del:procedure (ob:PPyObject); cdecl; +{-} PyObject_GC_Track:procedure (ob:PPyObject); cdecl; +{-} PyObject_GC_UnTrack:procedure (ob:PPyObject); cdecl; +{$ENDIF} +{$IFNDEF PYTHON25_OR_HIGHER} +{-} PyRange_New:function (l1,l2,l3:longint;i:integer):PPyObject; cdecl; +{$ENDIF} +{-} PySequence_Check:function (ob:PPyObject):integer; cdecl; +{-} PySequence_Concat:function (ob1,ob2:PPyObject):PPyObject; cdecl; +{-} PySequence_Count:function (ob1,ob2:PPyObject):integer; cdecl; +{-} PySequence_GetItem:function (ob:PPyObject;i:integer):PPyObject; cdecl; +{-} PySequence_GetSlice:function (ob:PPyObject;i1,i2:integer):PPyObject; cdecl; +{-} PySequence_In:function (ob1,ob2:PPyObject):integer; cdecl; +{-} PySequence_Index:function (ob1,ob2:PPyObject):integer; cdecl; +{-} PySequence_Length:function (ob:PPyObject):integer; cdecl; +{-} PySequence_Repeat:function (ob:PPyObject;count:integer):PPyObject; cdecl; +{-} PySequence_SetItem:function (ob:PPyObject;i:integer;value:PPyObject):integer; cdecl; +{-} PySequence_SetSlice:function (ob:PPyObject;i1,i2:integer;value:PPyObject):integer; cdecl; +{-} PySequence_DelSlice:function (ob:PPyObject;i1,i2:integer):integer; cdecl; +{-} PySequence_Tuple:function (ob:PPyObject):PPyObject; cdecl; +{$IFDEF PYTHON20_OR_HIGHER} +{-} PySequence_Contains:function (ob, value:PPyObject):integer; cdecl; + PySeqIter_New: function(obj : PPyObject) : PPyObject; cdecl; +{$ENDIF} +{-} PySlice_GetIndices:function (ob:PPySliceObject;length:integer;var start,stop,step:integer):integer; cdecl; +{$IFDEF PYTHON23_OR_HIGHER} +{-} PySlice_GetIndicesEx:function (ob:PPySliceObject;length:integer;var start,stop,step,slicelength:integer):integer; cdecl; +{$ENDIF} +{-} PySlice_New:function (start,stop,step:PPyObject):PPyObject; cdecl; +{-} PyString_Concat:procedure(var ob1:PPyObject;ob2:PPyObject); cdecl; +{-} PyString_ConcatAndDel:procedure(var ob1:PPyObject;ob2:PPyObject); cdecl; +{-} PyString_Format:function (ob1,ob2:PPyObject):PPyObject; cdecl; +{-} PyString_FromStringAndSize:function (s:PChar;i:integer):PPyObject; cdecl; +{-} PyString_Size:function (ob:PPyObject):integer; cdecl; +{$IFDEF PYTHON23_OR_HIGHER} +{-} PyString_DecodeEscape:function(s:PChar; len:integer; errors:PChar; unicode:integer; recode_encoding:PChar):PPyObject; cdecl; +{-} PyString_Repr:function(ob:PPyObject; smartquotes:integer):PPyObject; cdecl; +{$ENDIF} +{+} PySys_GetObject:function (s:PChar):PPyObject; cdecl; +{-} //PySys_Init:procedure; cdecl; +{-} PySys_SetObject:function (s:PChar;ob:PPyObject):integer; cdecl; +{-} PySys_SetPath:procedure(path:PChar); cdecl; +{-} //PyTraceBack_Fetch:function :PPyObject; cdecl; +{-} PyTraceBack_Here:function (p:pointer):integer; cdecl; +{-} PyTraceBack_Print:function (ob1,ob2:PPyObject):integer; cdecl; +{-} //PyTraceBack_Store:function (ob:PPyObject):integer; cdecl; +{+} PyTuple_GetItem:function (ob:PPyObject;i:integer):PPyObject; cdecl; +{-} PyTuple_GetSlice:function (ob:PPyObject;i1,i2:integer):PPyObject; cdecl; +{+} PyTuple_New:function (size:Integer):PPyObject; cdecl; +{+} PyTuple_SetItem:function (ob:PPyObject;key:integer;value:PPyObject):integer; cdecl; +{+} PyTuple_Size:function (ob:PPyObject):integer; cdecl; +{$IFDEF PYTHON22_OR_HIGHER} +{+} PyType_IsSubtype:function (a, b : PPyTypeObject):integer; cdecl; + PyType_GenericAlloc:function(atype: PPyTypeObject; nitems:Integer) : PPyObject; cdecl; + PyType_GenericNew:function(atype: PPyTypeObject; args, kwds : PPyObject) : PPyObject; cdecl; + PyType_Ready:function(atype: PPyTypeObject) : integer; cdecl; +{$ENDIF} +{$IFDEF UNICODE_SUPPORT} +{+} PyUnicode_FromWideChar:function (const w:PWideChar; size:integer):PPyObject; cdecl; +{+} PyUnicode_AsWideChar:function (unicode: PPyObject; w:PWideChar; size:integer):integer; cdecl; +{$IFDEF PYTHON23_OR_HIGHER} +{-} PyUnicode_FromOrdinal:function (ordinal:integer):PPyObject; cdecl; +{$ENDIF} +{$ENDIF} +{$IFDEF PYTHON22_OR_HIGHER} + PyWeakref_GetObject: function ( ref : PPyObject) : PPyObject; cdecl; + PyWeakref_NewProxy: function ( ob, callback : PPyObject) : PPyObject; cdecl; + PyWeakref_NewRef: function ( ob, callback : PPyObject) : PPyObject; cdecl; + PyWrapper_New: function ( ob1, ob2 : PPyObject) : PPyObject; cdecl; +{$ENDIF} +{$IFDEF PYTHON23_OR_HIGHER} + PyBool_FromLong: function ( ok : Integer) : PPyObject; cdecl; + PyThreadState_SetAsyncExc: function(t_id :LongInt; exc :PPyObject) : Integer; cdecl; +{$ENDIF} +{-} Py_AtExit:function (proc: AtExitProc):integer; cdecl; +{-} //Py_Cleanup:procedure; cdecl; +{-} Py_CompileString:function (s1,s2:PChar;i:integer):PPyObject; cdecl; +{-} Py_FatalError:procedure(s:PChar); cdecl; +{-} Py_FindMethod:function (md:PPyMethodDef;ob:PPyObject;key:PChar):PPyObject; cdecl; +{-} Py_FindMethodInChain:function (mc:PPyMethodChain;ob:PPyObject;key:PChar):PPyObject; cdecl; +{-} Py_FlushLine:procedure; cdecl; +{-} _PyObject_New:function (obt:PPyTypeObject;ob:PPyObject):PPyObject; cdecl; +{-} _PyString_Resize:function (var ob:PPyObject;i:integer):integer; cdecl; +{+} Py_Finalize : procedure; cdecl; +{-} PyErr_ExceptionMatches : function ( exc : PPyObject) : Integer; cdecl; +{-} PyErr_GivenExceptionMatches : function ( raised_exc, exc : PPyObject) : Integer; cdecl; +{-} PyEval_EvalCode : function ( co : PPyCodeObject; globals, locals : PPyObject) : PPyObject; cdecl; +{+} Py_GetVersion : function : PChar; cdecl; +{+} Py_GetCopyright : function : PChar; cdecl; +{+} Py_GetExecPrefix : function : PChar; cdecl; +{+} Py_GetPath : function : PChar; cdecl; +{+} Py_GetPrefix : function : PChar; cdecl; +{+} Py_GetProgramName : function : PChar; cdecl; + +{-} PyParser_SimpleParseString : function ( str : PChar; start : Integer) : PNode; cdecl; +{-} PyNode_Free : procedure( n : PNode ); cdecl; +{-} PyErr_NewException : function ( name : PChar; base, dict : PPyObject ) : PPyObject; cdecl; +{-} Py_Malloc : function ( size : Integer ) : Pointer; +{-} PyMem_Malloc : function ( size : Integer ) : Pointer; +{-} PyObject_CallMethod : function ( obj : PPyObject; method, format : PChar ) : PPyObject; cdecl; + +{New exported Objects in Python 1.5} + Py_SetProgramName : procedure( name: PChar); cdecl; + Py_IsInitialized : function : integer; cdecl; + Py_GetProgramFullPath : function : PChar; cdecl; + Py_NewInterpreter : function : PPyThreadState; cdecl; + Py_EndInterpreter : procedure( tstate: PPyThreadState); cdecl; + PyEval_AcquireLock : procedure; cdecl; + PyEval_ReleaseLock : procedure; cdecl; + PyEval_AcquireThread : procedure( tstate: PPyThreadState); cdecl; + PyEval_ReleaseThread : procedure( tstate: PPyThreadState); cdecl; + PyInterpreterState_New : function : PPyInterpreterState; cdecl; + PyInterpreterState_Clear : procedure( interp: PPyInterpreterState); cdecl; + PyInterpreterState_Delete : procedure( interp: PPyInterpreterState); cdecl; + PyThreadState_New : function ( interp: PPyInterpreterState): PPyThreadState; cdecl; + PyThreadState_Clear : procedure( tstate: PPyThreadState); cdecl; + PyThreadState_Delete : procedure( tstate: PPyThreadState); cdecl; + PyThreadState_Get : function : PPyThreadState; cdecl; + PyThreadState_Swap : function ( tstate: PPyThreadState): PPyThreadState; cdecl; + PyErr_SetInterrupt : procedure; cdecl; + +{Further exported Objects, may be implemented later} +{ + PyCode_New: Pointer; + PyErr_SetInterrupt: Pointer; + PyFile_AsFile: Pointer; + PyFile_FromFile: Pointer; + PyFloat_AsString: Pointer; + PyFrame_BlockPop: Pointer; + PyFrame_BlockSetup: Pointer; + PyFrame_ExtendStack: Pointer; + PyFrame_FastToLocals: Pointer; + PyFrame_LocalsToFast: Pointer; + PyFrame_New: Pointer; + PyGrammar_AddAccelerators: Pointer; + PyGrammar_FindDFA: Pointer; + PyGrammar_LabelRepr: Pointer; + PyInstance_DoBinOp: Pointer; + PyInt_GetMax: Pointer; + PyMarshal_Init: Pointer; + PyMarshal_ReadLongFromFile: Pointer; + PyMarshal_ReadObjectFromFile: Pointer; + PyMarshal_ReadObjectFromString: Pointer; + PyMarshal_WriteLongToFile: Pointer; + PyMarshal_WriteObjectToFile: Pointer; + PyMember_Get: Pointer; + PyMember_Set: Pointer; + PyNode_AddChild: Pointer; + PyNode_Compile: Pointer; + PyNode_New: Pointer; + PyOS_GetLastModificationTime: Pointer; + PyOS_Readline: Pointer; + PyOS_strtol: Pointer; + PyOS_strtoul: Pointer; + PyObject_CallFunction: Pointer; + PyObject_CallMethod: Pointer; + PyObject_Print: Pointer; + PyParser_AddToken: Pointer; + PyParser_Delete: Pointer; + PyParser_New: Pointer; + PyParser_ParseFile: Pointer; + PyParser_ParseString: Pointer; + PyParser_SimpleParseFile: Pointer; + PyRun_AnyFile: Pointer; + PyRun_File: Pointer; + PyRun_InteractiveLoop: Pointer; + PyRun_InteractiveOne: Pointer; + PyRun_SimpleFile: Pointer; + PySys_GetFile: Pointer; + PyToken_OneChar: Pointer; + PyToken_TwoChars: Pointer; + PyTokenizer_Free: Pointer; + PyTokenizer_FromFile: Pointer; + PyTokenizer_FromString: Pointer; + PyTokenizer_Get: Pointer; + Py_Main: Pointer; + _PyObject_NewVar: Pointer; + _PyParser_Grammar: Pointer; + _PyParser_TokenNames: Pointer; + _PyThread_Started: Pointer; + _Py_c_diff: Pointer; + _Py_c_neg: Pointer; + _Py_c_pow: Pointer; + _Py_c_prod: Pointer; + _Py_c_quot: Pointer; + _Py_c_sum: Pointer; +} + // functions redefined in Delphi + procedure Py_INCREF ( op: PPyObject); + procedure Py_DECREF ( op: PPyObject); + procedure Py_XINCREF ( op: PPyObject); + procedure Py_XDECREF ( op: PPyObject); + + function Py_GetPlatform: PChar; cdecl; + + function PyArg_Parse ( args: PPyObject; format: PChar; + argp: array of Pointer): Integer; cdecl; + function PyArg_ParseTuple( args: PPyObject; format: PChar; + argp: array of Pointer): Integer; cdecl; +// This function handles all cardinals, pointer types (with no adjustment of pointers!) +// (Extended) floats, which are handled as Python doubles and currencies, handled +// as (normalized) Python doubles. + function Py_BuildValue( format: PChar; args: array of const): PPyObject; cdecl; + function PyObject_CallMethodWithArgs( obj : PPyObject; method, + format: PChar; args: array of const): PPyObject; cdecl; + function PyCode_Addr2Line( co: PPyCodeObject; addrq : Integer ) : Integer; cdecl; + function Py_GetBuildInfo: PChar; cdecl; + function PyImport_ExecCodeModule( const AName : String; codeobject : PPyObject) : PPyObject; + function PyString_Check( obj : PPyObject ) : Boolean; + function PyString_CheckExact( obj : PPyObject ) : Boolean; + function PyFloat_Check( obj : PPyObject ) : Boolean; + function PyFloat_CheckExact( obj : PPyObject ) : Boolean; + function PyInt_Check( obj : PPyObject ) : Boolean; + function PyInt_CheckExact( obj : PPyObject ) : Boolean; + function PyLong_Check( obj : PPyObject ) : Boolean; + function PyLong_CheckExact( obj : PPyObject ) : Boolean; + function PyTuple_Check( obj : PPyObject ) : Boolean; + function PyTuple_CheckExact( obj : PPyObject ) : Boolean; + function PyInstance_Check( obj : PPyObject ) : Boolean; + function PyClass_Check( obj : PPyObject ) : Boolean; + function PyType_CheckExact( obj : PPyObject ) : Boolean; + function PyMethod_Check( obj : PPyObject ) : Boolean; + function PyList_Check( obj : PPyObject ) : Boolean; + function PyList_CheckExact( obj : PPyObject ) : Boolean; + function PyDict_Check( obj : PPyObject ) : Boolean; + function PyDict_CheckExact( obj : PPyObject ) : Boolean; + function PyModule_Check( obj : PPyObject ) : Boolean; + function PyModule_CheckExact( obj : PPyObject ) : Boolean; + function PySlice_Check( obj : PPyObject ) : Boolean; + function PyFunction_Check( obj : PPyObject ) : Boolean; + function PyIter_Check( obj : PPyObject ) : Boolean; +{$IFDEF UNICODE_SUPPORT} + function PyUnicode_Check( obj : PPyObject ) : Boolean; + function PyUnicode_CheckExact( obj : PPyObject ) : Boolean; +{$ENDIF} +{$IFDEF PYTHON22_OR_HIGHER} + function PyType_IS_GC(t : PPyTypeObject ) : Boolean; + function PyObject_IS_GC( obj : PPyObject ) : Boolean; +{$ENDIF} +{$IFDEF PYTHON22_OR_HIGHER} + function PyWeakref_Check( obj : PPyObject ) : Boolean; + function PyWeakref_CheckRef( obj : PPyObject ) : Boolean; + function PyWeakref_CheckProxy( obj : PPyObject ) : Boolean; +{$ENDIF} +{$IFDEF PYTHON23_OR_HIGHER} + function PyBool_Check( obj : PPyObject ) : Boolean; + function PyBaseString_Check( obj : PPyObject ) : Boolean; + function PyEnum_Check( obj : PPyObject ) : Boolean; +{$ENDIF} + function PyObject_TypeCheck(obj:PPyObject; t:PPyTypeObject) : Boolean; + function Py_InitModule( const AName : PChar; md : PPyMethodDef) : PPyObject; + + // Constructors & Destructors + constructor Create(AOwner: TComponent); override; + + // Public methods + procedure MapDll; + + // Public properties + property Initialized : Boolean read GetInitialized; + property Finalizing : Boolean read FFinalizing; +end; + +//-------------------------------------------------------- +//-- -- +//-- class: TPythonEngine derived from TPythonInterface-- +//-- Pytrunobject providing interface for -- +//-- running Python into Delphi -- +//-------------------------------------------------------- +type + TDatetimeConversionMode = (dcmToTuple, dcmToDatetime); +const + DEFAULT_DATETIME_CONVERSION_MODE = dcmToTuple; +type + TEngineClient = class; + TPathInitializationEvent = procedure ( Sender : TObject; var Path : String ) of Object; + TSysPathInitEvent = procedure ( Sender : TObject; PathList : PPyObject ) of Object; + TPythonFlag = (pfDebug, pfInteractive, pfNoSite, pfOptimize, pfTabcheck, pfUnicode, pfVerbose, + pfUseClassExceptionsFlag, pfFrozenFlag, pfIgnoreEnvironmentFlag, pfDivisionWarningFlag); + TPythonFlags = set of TPythonFlag; + + + TTracebackItem = class + FileName : String; + LineNo : Integer; + Context : String; + end; + + TPythonTraceback = class + protected + FItems : TList; + FLimit : Integer; + + function GetItemCount : Integer; + function GetItem( idx : Integer ) : TTracebackItem; + public + constructor Create; + destructor Destroy; override; + + procedure Clear; + procedure Refresh; + + property ItemCount : Integer read GetItemCount; + property Items[ idx : Integer ] : TTracebackItem read GetItem; + property Limit : Integer read FLimit write FLimit; + end; + + TPythonEngine = class(TPythonInterface) + private + FInitScript: TStrings; + FIO: TPythonInputOutput; + FRedirectIO: Boolean; + FOnAfterInit: TNotifyEvent; + FClients: TList; + FLock: TCriticalSection; + FExecModule: String; + FAutoFinalize: Boolean; + FProgramName: String; + FInitThreads: Boolean; + FOnPathInitialization: TPathInitializationEvent; + FOnSysPathInit: TSysPathInitEvent; + FTraceback: TPythonTraceback; + FUseWindowsConsole: Boolean; + FGlobalVars: PPyObject; + FLocalVars: PPyObject; + FPyFlags: TPythonFlags; + FIORedirected: Boolean; + FIOPythonModule: TObject; + FDatetimeConversionMode: TDatetimeConversionMode; + FTimeStruct: PPyObject; + FPyDateTime_DateType: PPyObject; + FPyDateTime_DateTimeType: PPyObject; + FPyDateTime_DeltaType: PPyObject; + FPyDateTime_TimeType: PPyObject; + FPyDateTime_TZInfoType: PPyObject; + FPyDateTime_TimeTZType: PPyObject; + FPyDateTime_DateTimeTZType: PPyObject; + function GetVersion: String; + procedure SetVersion(const Value: String); + + protected + procedure AfterLoad; override; + procedure BeforeLoad; override; + procedure DoOpenDll(const aDllName : String); override; + procedure SetInitScript(Value: TStrings); + function GetThreadState: PPyThreadState; + function GetInterpreterState: PPyInterpreterState; + procedure SetInitThreads(Value: Boolean); + function GetClientCount : Integer; + function GetClients( idx : Integer ) : TEngineClient; + procedure Notification(AComponent: TComponent; + Operation: TOperation); override; + procedure CheckRegistry; + procedure SetProgramArgs; + procedure InitWinConsole; + procedure SetUseWindowsConsole( const Value : Boolean ); + procedure SetGlobalVars(const Value: PPyObject); + procedure SetLocalVars(const Value: PPyObject); + procedure SetPyFlags(const Value: TPythonFlags); + procedure AssignPyFlags; + + public + // Constructors & Destructors + constructor Create(AOwner: TComponent); override; + destructor Destroy; override; + + // Public methods + procedure Initialize; + procedure Finalize; + procedure Lock; + procedure Unlock; + function IsType(ob: PPyObject; obt: PPyTypeObject): Boolean; + function GetAttrString(obj: PPyObject; AName: PChar):PChar; + function CleanString(const s : string) : string; + function Run_CommandAsString(const command : String; mode : Integer) : String; + function Run_CommandAsObject(const command : String; mode : Integer) : PPyObject; + function Run_CommandAsObjectWithDict(const command : String; mode : Integer; locals, globals : PPyObject) : PPyObject; + procedure ExecString(const command : String); {$IFDEF DELPHI4_OR_HIGHER}overload;{$ENDIF} + procedure ExecStrings( strings : TStrings ); {$IFDEF DELPHI4_OR_HIGHER}overload;{$ENDIF} + function EvalString(const command : String) : PPyObject; {$IFDEF DELPHI4_OR_HIGHER}overload;{$ENDIF} + function EvalStringAsStr(const command : String) : String; + function EvalStrings( strings : TStrings ) : PPyObject; {$IFDEF DELPHI4_OR_HIGHER}overload;{$ENDIF} +{$IFDEF DELPHI4_OR_HIGHER} + procedure ExecString(const command : String; locals, globals : PPyObject ); overload; + procedure ExecStrings( strings : TStrings; locals, globals : PPyObject ); overload; + function EvalString( const command : String; locals, globals : PPyObject ) : PPyObject; overload; + function EvalStrings( strings : TStrings; locals, globals : PPyObject ) : PPyObject; overload; +{$ENDIF} + function EvalStringsAsStr( strings : TStrings ) : String; + function EvalPyFunction(pyfunc, pyargs:PPyObject): Variant; + function EvalFunction(pyfunc:PPyObject; args: array of const): Variant; + function EvalFunctionNoArgs(pyfunc:PPyObject): Variant; + function CheckEvalSyntax( const str : String ) : Boolean; + function CheckExecSyntax( const str : String ) : Boolean; + function CheckSyntax( const str : String; mode : Integer ) : Boolean; + procedure RaiseError; + function PyObjectAsString( obj : PPyObject ) : String; + procedure DoRedirectIO; + procedure AddClient( client : TEngineClient ); + procedure RemoveClient( client : TEngineClient ); + function FindClient( const aName : String ) : TEngineClient; + function TypeByName( const aTypeName : String ) : PPyTypeObject; + function ModuleByName( const aModuleName : String ) : PPyObject; + function MethodsByName( const aMethodsContainer: String ) : PPyMethodDef; + function VariantAsPyObject( const V : Variant ) : PPyObject; virtual; + function PyObjectAsVariant( obj : PPyObject ) : Variant; virtual; + function VarRecAsPyObject( v : TVarRec ) : PPyObject; + function MakePyTuple( const objects : array of PPyObject ) : PPyObject; + function MakePyList( const objects : array of PPyObject ) : PPyObject; + function ArrayToPyTuple( items : array of const) : PPyObject; + function ArrayToPyList( items : array of const) : PPyObject; + function ArrayToPyDict( items : array of const) : PPyObject; + function StringsToPyList( strings : TStrings ) : PPyObject; + function StringsToPyTuple( strings : TStrings ) : PPyObject; + procedure PyListToStrings( list : PPyObject; strings : TStrings ); + procedure PyTupleToStrings( tuple: PPyObject; strings : TStrings ); +{$IFDEF UNICODE_SUPPORT} + function PyUnicode_AsWideString( obj : PPyObject ) : WideString; + function PyUnicode_FromWideString( const AString : WideString) : PPyObject; +{$ENDIF} + function ReturnNone : PPyObject; + function FindModule( const ModuleName : String ) : PPyObject; + function FindFunction(ModuleName,FuncName: String): PPyObject; + function SetToList( data : Pointer; size : Integer ) : PPyObject; + procedure ListToSet( List : PPyObject; data : Pointer; size : Integer ); + procedure CheckError(ACatchStopEx : Boolean {$IFDEF DELPHI4_OR_HIGHER}= False{$ENDIF}); + function GetMainModule : PPyObject; + function PyTimeStruct_Check( obj : PPyObject ) : Boolean; + { Date, Time, DateTime and related objects check functions } + function PyDate_Check( obj : PPyObject ) : Boolean; + function PyDate_CheckExact( obj : PPyObject ) : Boolean; + function PyDateTime_Check( obj : PPyObject ) : Boolean; + function PyDateTime_CheckExact( obj : PPyObject ) : Boolean; + function PyTime_Check( obj : PPyObject ) : Boolean; + function PyTime_CheckExact( obj : PPyObject ) : Boolean; + function PyDelta_Check( obj : PPyObject ) : Boolean; + function PyDelta_CheckExact( obj : PPyObject ) : Boolean; + function PyTZInfo_Check( obj : PPyObject ) : Boolean; + function PyTZInfo_CheckExact( obj : PPyObject ) : Boolean; + { Apply for date and datetime instances. } + function PyDateTime_GET_YEAR( obj : PPyObject ) : Integer; + function PyDateTime_GET_MONTH( obj : PPyObject ) : Integer; + function PyDateTime_GET_DAY( obj : PPyObject ) : Integer; + function PyDateTime_DATE_GET_HOUR( obj : PPyObject ) : Integer; + function PyDateTime_DATE_GET_MINUTE( obj : PPyObject ) : Integer; + function PyDateTime_DATE_GET_SECOND( obj : PPyObject ) : Integer; + function PyDateTime_DATE_GET_MICROSECOND( obj : PPyObject ) : Integer; + { Apply for time instances. } + function PyDateTime_TIME_GET_HOUR( obj : PPyObject ) : Integer; + function PyDateTime_TIME_GET_MINUTE( obj : PPyObject ) : Integer; + function PyDateTime_TIME_GET_SECOND( obj : PPyObject ) : Integer; + function PyDateTime_TIME_GET_MICROSECOND( obj : PPyObject ) : Integer; + { end date/time functions } + + // Public Properties + property ClientCount : Integer read GetClientCount; + property Clients[ idx : Integer ] : TEngineClient read GetClients; + property ExecModule : String read FExecModule write FExecModule; + property ThreadState: PPyThreadState read GetThreadState; + property InterpreterState: PPyInterpreterState read GetInterpreterState; + property Traceback : TPythonTraceback read FTraceback; + property LocalVars : PPyObject read FLocalVars Write SetLocalVars; + property GlobalVars : PPyObject read FGlobalVars Write SetGlobalVars; + published + property AutoFinalize: Boolean read FAutoFinalize write FAutoFinalize default True; + property DatetimeConversionMode: TDatetimeConversionMode read FDatetimeConversionMode write FDatetimeConversionMode default DEFAULT_DATETIME_CONVERSION_MODE; + property InitScript: TStrings read FInitScript write SetInitScript; + property InitThreads: Boolean read FInitThreads write SetInitThreads default False; + property IO: TPythonInputOutput read FIO write FIO; + property PyFlags: TPythonFlags read FPyFlags write SetPyFlags default []; + property RedirectIO: Boolean read FRedirectIO write FRedirectIO default True; + property UseWindowsConsole: Boolean read FUseWindowsConsole write FUseWindowsConsole default False; + property Version : String read GetVersion write SetVersion stored False; + property OnAfterInit: TNotifyEvent read FOnAfterInit write FOnAfterInit; + property OnPathInitialization: TPathInitializationEvent read FOnPathInitialization write FOnPathInitialization; + property OnSysPathInit: TSysPathInitEvent read FOnSysPathInit write FOnSysPathInit; + end; + + +//------------------------------------------------------- +//-- -- +//-- Base class: TEngineClient -- +//-- -- +//------------------------------------------------------- + + TEngineClient = class(TComponent) + protected + FEngine : TPythonEngine; + FOnInitialization : TNotifyEvent; + FOnFinalization : TNotifyEvent; + FOnCreate : TNotifyEvent; + FOnDestroy : TNotifyEvent; + FInitialized : Boolean; + + procedure SetEngine( val : TPythonEngine ); virtual; + procedure Loaded; override; + procedure Notification( AComponent: TComponent; + Operation: TOperation); override; + procedure ModuleReady(Sender : TObject); virtual; + public + // Constructors & destructors + constructor Create( AOwner : TComponent ); override; + destructor Destroy; override; + + // Public Methods + procedure Initialize; virtual; + procedure Finalize; virtual; + procedure ClearEngine; + procedure CheckEngine; + + // Public Properties + property Initialized: Boolean read FInitialized; + + published + property Engine : TPythonEngine read FEngine write SetEngine; + property OnCreate : TNotifyEvent read FOnCreate write FOnCreate; + property OnDestroy : TNotifyEvent read FOnDestroy write FOnDestroy; + property OnFinalization : TNotifyEvent read FOnFinalization write FOnFinalization; + property OnInitialization : TNotifyEvent read FOnInitialization write FOnInitialization; + end; + +//------------------------------------------------------- +//-- -- +//--class: TMethodsContainer derived from TEngineClient-- +//-- -- +//------------------------------------------------------- + + TMethodArray = array[ 0 .. 16000 ] of PyMethodDef; + PMethodArray = ^TMethodArray; + TDelphiMethod = function ( self, args : PPyObject ) : PPyObject of object; cdecl; + TDelphiMethodWithKW = function ( self, args, keywords : PPyObject ) : PPyObject of object; cdecl; + TPythonEvent = procedure(Sender: TObject; PSelf, Args: PPyObject; var Result: PPyObject) of object; + TMethodsContainer = class; // forward declaration + TEventDefs = class; // forward declaration + + // Event Collection Item + TEventDef = class(TCollectionItem) + private + FName: String; + FTmpDocString: String; + FOnExecute: TPythonEvent; + FDocString: TStringList; + procedure SetDocString(const Value: TStringList); + protected + function GetDisplayName: String; {$IFNDEF FPC} override; {$ENDIF} + procedure SetDisplayName(const Value: String); {$IFNDEF FPC} override; {$ENDIF} + public + constructor Create(ACollection: TCollection); override; + destructor Destroy; override; + + procedure Assign(Source: TPersistent); override; + function GetDocString : String; + function PythonEvent(pself, args: PPyObject): PPyObject; cdecl; + function Owner : TEventDefs; + published + property Name: string read FName write SetDisplayName; + property OnExecute: TPythonEvent read FOnExecute write FOnExecute; + property DocString: TStringList read FDocString write SetDocString; + end; + + // Event Collection + TEventDefs = class(TCollection) + protected + FMethodsContainer : TMethodsContainer; + + function GetItems( idx : Integer ) : TEventDef; + procedure SetItems( idx : Integer; Value : TEventDef ); + function GetOwner: TPersistent; override; + public + constructor Create( AMethodsContainer : TMethodsContainer ); + + function Add : TEventDef; + procedure RegisterEvents; + + property Items[ idx : Integer ] : TEventDef read GetItems; + property Container : TMethodsContainer read FMethodsContainer; + end; + + // class TMethodsContainer + TMethodsContainer = class(TEngineClient) + private + FMethodCount : Integer; + FAllocatedMethodCount : Integer; + FMethods : PPyMethodDef; + FEventDefs: TEventDefs; + + procedure AllocMethods; + procedure FreeMethods; + function GetMethods( idx : Integer ) : PPyMethodDef; + function StoreEventDefs: Boolean; + + protected + procedure ReallocMethods; virtual; + + public + // Constructors & destructors + constructor Create( AOwner : TComponent ); override; + destructor Destroy; override; + + // public methods + procedure Initialize; override; + procedure Finalize; override; + + function AddMethod( AMethodName : PChar; + AMethod : PyCFunction; + ADocString : PChar ) : PPyMethodDef; + function AddMethodWithKeywords( AMethodName : PChar; + AMethod : PyCFunctionWithKW; + ADocString : PChar ) : PPyMethodDef; + function AddDelphiMethod( AMethodName : PChar; + ADelphiMethod: TDelphiMethod; + ADocString : PChar ) : PPyMethodDef; + function AddDelphiMethodWithKeywords( AMethodName : PChar; + ADelphiMethod: TDelphiMethodWithKW; + ADocString : PChar ) : PPyMethodDef; + procedure ClearMethods; + + // properties + property MethodCount : Integer read FMethodCount; + property Methods[ idx : Integer ] : PPyMethodDef read GetMethods; + property MethodsData : PPyMethodDef read FMethods; + + published + property Events: TEventDefs read fEventDefs write fEventDefs stored StoreEventDefs; + end; + + +//------------------------------------------------------------ +//-- -- +//--class: TMembersContainer derived from TMethodsContainer -- +//-- -- +//------------------------------------------------------------ + +{$IFDEF PYTHON22_OR_HIGHER} + TMemberArray = array[ 0 .. 16000 ] of PyMemberDef; + PMemberArray = ^TMemberArray; +{$ENDIF} + + // class TMembersContainer + TMembersContainer = class(TMethodsContainer) + protected + function GetMembersStartOffset : Integer; virtual; +{$IFDEF PYTHON22_OR_HIGHER} + private + FMemberCount : Integer; + FAllocatedMemberCount : Integer; + FMembers : PPyMemberDef; + + procedure AllocMembers; + procedure FreeMembers; + function GetMembers( idx : Integer ) : PPyMemberDef; + + protected + procedure ReallocMembers; virtual; + + public + // Constructors & destructors + constructor Create( AOwner : TComponent ); override; + destructor Destroy; override; + + // public methods + procedure AddMember( MemberName : PChar; + MemberType : TPyMemberType; + MemberOffset : Integer; + MemberFlags : TPyMemberFlag; + MemberDoc : PChar ); + procedure ClearMembers; + procedure Finalize; override; + + // properties + property MemberCount : Integer read FMemberCount; + property Members[ idx : Integer ] : PPyMemberDef read GetMembers; + property MembersData : PPyMemberDef read FMembers; +{$ENDIF} + end; + +//------------------------------------------------------------ +//-- -- +//--class: TGetSetContainer derived from TMembersContainer -- +//-- -- +//------------------------------------------------------------ + +{$IFDEF PYTHON22_OR_HIGHER} + TGetSetArray = array[ 0 .. 16000 ] of PyGetSetDef; + PGetSetArray = ^TGetSetArray; +{$ENDIF} + + // class TGetSetContainer + TGetSetContainer = class(TMembersContainer) + private +{$IFDEF PYTHON22_OR_HIGHER} + FGetSetCount : Integer; + FAllocatedGetSetCount : Integer; + FGetSets : PPyGetSetDef; + + procedure AllocGetSets; + procedure FreeGetSets; + function GetGetSet( idx : Integer ) : PPyGetSetDef; + + protected + procedure ReallocGetSets; virtual; + + public + // Constructors & destructors + constructor Create( AOwner : TComponent ); override; + destructor Destroy; override; + + // public methods + procedure AddGetSet( AName : PChar; + AGet : getter; + ASet : setter; + ADoc : PChar; + AClosure : Pointer); + procedure ClearGetSets; + procedure Finalize; override; + + // properties + property GetSetCount : Integer read FGetSetCount; + property GetSet[ idx : Integer ] : PPyGetSetDef read GetGetSet; + property GetSetData : PPyGetSetDef read FGetSets; +{$ENDIF} + end; + +//------------------------------------------------------- +//-- -- +//--class: TPythonModule derived from TMethodsContainer-- +//-- -- +//------------------------------------------------------- + + TPythonModule = class; // forward declaration + TErrors = class; // forward declaration + + TErrorType = (etString, etClass); + + TParentClassError = class(TPersistent) + protected + FName : String; + FModule : String; + public + procedure AssignTo( Dest: TPersistent ); override; + published + property Module : String read FModule write FModule; + property Name : String read FName write FName; + end; + + TError = class(TCollectionItem) + protected + FName : String; + FText : String; + FError : PPyObject; + FErrorType : TErrorType; + FParentClass : TParentClassError; + + function GetDisplayName: string; {$IFNDEF FPC} override; {$ENDIF} + procedure SetName( const Value : String ); + procedure SetText( const Value : String ); + procedure SetErrorType( Value : TErrorType ); + procedure SetParentClass( Value : TParentClassError ); + public + constructor Create(ACollection: TCollection); override; + destructor Destroy; override; + procedure Assign(Source: TPersistent); override; + procedure BuildError( const ModuleName : String ); + procedure RaiseError( const msg : String ); + procedure RaiseErrorObj( const msg : String; obj : PPyObject ); + function Owner : TErrors; + property Error : PPyObject read FError write FError; + published + property Name : String read FName write SetName; + property Text : String read FText write SetText; + property ErrorType : TErrorType read FErrorType write SetErrorType; + property ParentClass : TParentClassError read FParentClass write SetParentClass; + end; + + TErrors = class(TCollection) + private + FModule: TPythonModule; + function GetError(Index: Integer): TError; + procedure SetError(Index: Integer; Value: TError); + protected + function GetOwner: TPersistent; override; + procedure Update(Item: TCollectionItem); override; + public + constructor Create(Module: TPythonModule); + function Add: TError; + function Owner : TPythonModule; + property Items[Index: Integer]: TError read GetError write SetError; default; + end; + + TPythonModule = class(TMethodsContainer) + protected + FModuleName : String; + FModule : PPyObject; + FClients : TList; + FErrors : TErrors; + FOnAfterInitialization : TNotifyEvent; + FDocString : TStringList; + + function GetClientCount : Integer; + function GetClients( idx : Integer ) : TEngineClient; + procedure SetErrors( val : TErrors ); + procedure SetModuleName( const val : String ); + procedure SetDocString( value : TStringList ); + + public + // Constructors & destructors + constructor Create( AOwner : TComponent ); override; + destructor Destroy; override; + + // Public methods + procedure MakeModule; + procedure DefineDocString; + procedure Initialize; override; + procedure InitializeForNewInterpreter; + procedure AddClient( client : TEngineClient ); + function ErrorByName( const AName : String ) : TError; + procedure RaiseError( const error, msg : String ); + procedure RaiseErrorFmt( const error, format : String; Args : array of const ); + procedure RaiseErrorObj( const error, msg : String; obj : PPyObject ); + procedure BuildErrors; + procedure SetVar( const varName : String; value : PPyObject ); + function GetVar( const varName : String ) : PPyObject; + procedure DeleteVar( const varName : String ); + procedure SetVarFromVariant( const varName : String; const value : Variant ); + function GetVarAsVariant( const varName: String ) : Variant; + + // Public properties + property Module : PPyObject read FModule; + property Clients[ idx : Integer ] : TEngineClient read GetClients; + property ClientCount : Integer read GetClientCount; + + published + property DocString : TStringList read FDocString write SetDocString; + property ModuleName : String read FModuleName write SetModuleName; + property Errors : TErrors read FErrors write SetErrors; + property OnAfterInitialization : TNotifyEvent read FOnAfterInitialization write FOnAfterInitialization; + end; + + +//------------------------------------------------------- +//-- -- +//--class: TPythonType derived from TGetSetContainer -- +//-- -- +//------------------------------------------------------- + +type + TPythonType = class; //forward declaration + +{ + A B C + +-------------------++------------------------------------------------------+ + | PyObject header || TPyObject class | + +----------+--------++-----------------+------------+----------+------------+ + |ob_refcnt |ob_type ||hidden Class Ptr |PythonType |IsSubType |PythonAlloc | + |integer |pointer ||pointer |TPythonType |Boolean |Boolean | + |4 bytes |4 bytes ||4 bytes |4 bytes |1 byte |1 byte | + +----------+--------++-----------------+------------+----------+------------+ + + ^ ^ + | | + ptr returned ptr returned by Adjust + by GetSelf + + - a Python object must start at A. + - a Delphi class class must start at B + - TPyObject.InstanceSize will return C-B + - Sizeof(TPyObject) will return C-B + - The total memory allocated for a TPyObject instance will be C-A, + even if its InstanceSize is C-B. + - When turning a Python object pointer into a Delphi instance pointer, PythonToDelphi + will offset the pointer from A to B. + - When turning a Delphi instance into a Python object pointer, GetSelf will offset + Self from B to A. + - Properties ob_refcnt and ob_type will call GetSelf to access their data. +} + // The base class of all new Python types + TPyObject = class + private + function Get_ob_refcnt: Integer; + function Get_ob_type: PPyTypeObject; + procedure Set_ob_refcnt(const Value: Integer); + procedure Set_ob_type(const Value: PPyTypeObject); + public + PythonType : TPythonType; + IsSubtype : Boolean; + PythonAlloc : Boolean; + + // Constructors & Destructors + constructor Create( APythonType : TPythonType ); virtual; + constructor CreateWith( APythonType : TPythonType; args : PPyObject ); virtual; + destructor Destroy; override; + + class function NewInstance: TObject; override; + procedure FreeInstance; override; + + // Misc + function GetSelf : PPyObject; + procedure IncRef; + procedure Adjust(PyPointer: Pointer); + function GetModule : TPythonModule; + + property ob_refcnt : Integer read Get_ob_refcnt write Set_ob_refcnt; + property ob_type : PPyTypeObject read Get_ob_type write Set_ob_type; + + // Type services + //////////////// + + // Basic services + function Print( var f: file; i: integer) : Integer; virtual; + function GetAttr(key : PChar) : PPyObject; virtual; + function SetAttr(key : PChar; value : PPyObject) : Integer; virtual; + function Repr : PPyObject; virtual; + function Compare( obj: PPyObject) : Integer; virtual; + function Hash : Integer; virtual; + function Str: PPyObject; virtual; + function GetAttrO( key: PPyObject) : PPyObject; virtual; + function SetAttrO( key, value: PPyObject) : Integer; virtual; + function Call( ob1, ob2 : PPyObject) : PPyObject; virtual; +{$IFDEF PYTHON20_OR_HIGHER} + function Traverse( proc: visitproc; ptr: Pointer) : integer; virtual; +{$ENDIF} + function Clear: integer; virtual; + function RichCompare( obj : PPyObject; Op : TRichComparisonOpcode) : PPyObject; virtual; + function Iter : PPyObject; virtual; + function IterNext : PPyObject; virtual; + function Init( args, kwds : PPyObject ) : Integer; virtual; + + // Number services + function NbAdd( obj : PPyObject) : PPyObject; virtual; + function NbSubstract( obj : PPyObject) : PPyObject; virtual; + function NbMultiply( obj : PPyObject) : PPyObject; virtual; + function NbDivide( obj : PPyObject) : PPyObject; virtual; + function NbFloorDivide( obj : PPyObject) : PPyObject; virtual; + function NbTrueDivide( obj : PPyObject) : PPyObject; virtual; + function NbRemainder( obj : PPyObject) : PPyObject; virtual; + function NbDivmod( obj : PPyObject) : PPyObject; virtual; + function NbPower( ob1, ob2 : PPyObject) : PPyObject; virtual; + function NbNegative : PPyObject; virtual; + function NbPositive : PPyObject; virtual; + function NbAbsolute : PPyObject; virtual; + function NbNonZero : Integer; virtual; + function NbInvert : PPyObject; virtual; + function NbLShift( obj : PPyObject) : PPyObject; virtual; + function NbRShift( obj : PPyObject) : PPyObject; virtual; + function NbAnd( obj : PPyObject) : PPyObject; virtual; + function NbXor( obj : PPyObject) : PPyObject; virtual; + function NbOr( obj : PPyObject) : PPyObject; virtual; + function NbCoerce( obj : PPPyObject) : Integer; virtual; + function NbInt : PPyObject; virtual; + function NbLong : PPyObject; virtual; + function NbFloat : PPyObject; virtual; + function NbOct : PPyObject; virtual; + function NbHex : PPyObject; virtual; + function NbInplaceAdd( obj : PPyObject): PPyObject; virtual; + function NbInplaceSubtract( obj : PPyObject): PPyObject; virtual; + function NbInplaceMultiply( obj : PPyObject): PPyObject; virtual; + function NbInplaceDivide( obj : PPyObject): PPyObject; virtual; + function NbInplaceFloorDivide( obj : PPyObject) : PPyObject; virtual; + function NbInplaceTrueDivide( obj : PPyObject) : PPyObject; virtual; + function NbInplaceRemainder( obj : PPyObject): PPyObject; virtual; + function NbInplacePower( ob1, ob2 : PPyObject): PPyObject; virtual; + function NbInplaceLshift( obj : PPyObject): PPyObject; virtual; + function NbInplaceRshift( obj : PPyObject): PPyObject; virtual; + function NbInplaceAnd( obj : PPyObject): PPyObject; virtual; + function NbInplaceXor( obj : PPyObject): PPyObject; virtual; + function NbInplaceOr( obj : PPyObject): PPyObject; virtual; + // Sequence services + function SqLength : Integer; virtual; + function SqConcat( obj : PPyObject) : PPyObject; virtual; + function SqRepeat( val : Integer ) : PPyObject; virtual; + function SqItem( idx : Integer ) : PPyObject; virtual; + function SqSlice( idx1, idx2 : Integer ) : PPyObject; virtual; + function SqAssItem( idx : integer; obj : PPyObject) : Integer; virtual; + function SqAssSlice( idx1, idx2 : Integer; obj : PPyObject): integer; virtual; + function SqContains( obj: PPyObject): integer; virtual; + function SqInplaceConcat( obj : PPyObject): PPyObject; virtual; + function SqInplaceRepeat( i: integer): PPyObject; virtual; + // Mapping services + function MpLength : Integer; virtual; + function MpSubscript( obj : PPyObject) : PPyObject; virtual; + function MpAssSubscript( obj1, obj2 : PPyObject) : Integer; virtual; + + // Class methods + class procedure RegisterMethods( APythonType : TPythonType ); virtual; + class procedure RegisterMembers( APythonType : TPythonType ); virtual; + class procedure RegisterGetSets( APythonType : TPythonType ); virtual; + class procedure SetupType( APythonType : TPythonType ); virtual; + end; + TPyObjectClass = class of TPyObject; + + TBasicServices = set of (bsPrint, bsGetAttr, bsSetAttr, + bsRepr, bsCompare, bsHash, + bsStr, bsGetAttrO, bsSetAttrO, + bsCall, + // since version 2.0 + bsTraverse, bsClear, + // since version 2.1 + bsRichCompare, + // since version 2.2 + bsIter, bsIterNext); + TNumberServices = set of (nsAdd, nsSubstract, nsMultiply, + nsDivide, nsRemainder, nsDivmod, + nsPower, nsNegative, nsPositive, + nsAbsolute, nsNonZero, nsInvert, + nsLShift, nsRShift, nsAnd, + nsXor, nsOr, nsCoerce, + nsInt, nsLong, nsFloat, + nsOct, nsHex, + // since version 2.2 + nsFloorDivide, nsTrueDivide); + + // TInplaceNumberServices exists since version 2.0 + TInplaceNumberServices = set of (nsInplaceAdd, nsInplaceSubtract, + nsInplaceMultiply, nsInplaceDivide, + nsInplaceRemainder, nsInplacePower, + nsInplaceLShift, nsInplaceRShift, + nsInplaceAnd, nsInplaceXor, nsInplaceOr, + // since version 2.2 + nsInplaceFloorDivide, nsInplaceTrueDivide); + + TSequenceServices = set of (ssLength, ssConcat, ssRepeat, + ssItem, ssSlice, ssAssItem, + ssAssSlice, + // since version 2.0 + ssContains, + ssInplaceConcat, + ssInplaceRepeat + ); + + TMappingServices = set of (msLength, msSubscript, msAssSubscript); + + TTypeServices = class(TPersistent) + protected + FBasic : TBasicServices; + FNumber : TNumberServices; + FSequence : TSequenceServices; + FMapping : TMappingServices; + FInplaceNumber : TInplaceNumberServices; + + public + constructor Create; + procedure AssignTo( Dest: TPersistent ); override; + + published + property Basic : TBasicServices read FBasic write FBasic; + property InplaceNumber : TInplaceNumberServices read FInplaceNumber Write FInplaceNumber; + property Number : TNumberServices read FNumber write FNumber; + property Sequence : TSequenceServices read FSequence write FSequence; + property Mapping : TMappingServices read FMapping write FMapping; + end; + + // The component that initializes the Python type and + // that creates instances of itself. + TPythonType = class(TGetSetContainer) + protected + FType : PyTypeObject; + FTypeName : String; + FModule : TPythonModule; + FPyObjectClass : TPyObjectClass; + FPrefix : String; + FCreateFuncName : String; + FServices : TTypeServices; + FNumber: PyNumberMethods; + FSequence: PySequenceMethods; + FMapping: PyMappingMethods; + FCurrentDocString: String; + FDocString: TStringList; + FCreateFuncDoc : String; + FInstanceCount : Integer; + FCreateHits : Integer; + FDeleteHits : Integer; + FTypeFlags : TPFlags; + FCreateFunc : PPyObject; + FCreateFuncDef : PyMethodDef; + FGenerateCreateFunction: Boolean; + + procedure Notification( AComponent: TComponent; + Operation: TOperation); override; + function GetTypePtr : PPyTypeObject; + procedure SetPyObjectClass( val : TPyObjectClass ); + procedure SetModule( val : TPythonModule ); + procedure SetServices( val : TTypeServices ); + procedure SetTypeName( const val : String ); + function CreateMethod( pSelf, args : PPyObject ) : PPyObject; cdecl; + procedure InitServices; + procedure SetDocString( value : TStringList ); + function TypeFlagsAsInt : LongInt; + function GetMembersStartOffset : Integer; override; + procedure ModuleReady(Sender : TObject); override; + procedure ReallocMethods; override; + procedure ReallocMembers; override; + procedure ReallocGetSets; override; + + // Type services + // They will be all forwarded to the Delphi class that + // implements the object through the use of virtual + // methods + /////////////////////////////////////// + function NewSubtypeInst( aType: PPyTypeObject; args, kwds : PPyObject) : PPyObject; cdecl; + + public + constructor Create( AOwner : TComponent ); override; + destructor Destroy; override; + + procedure Initialize; override; + procedure Finalize; override; + function CreateInstance : PPyObject; + function CreateInstanceWith( args : PPyObject ) : PPyObject; + procedure AddTypeVar; + + property TheType : PyTypeObject read FType write FType; + property TheTypePtr : PPyTypeObject read GetTypePtr; + property PyObjectClass : TPyObjectClass read FPyObjectClass write SetPyObjectClass stored False; + property InstanceCount : Integer read FInstanceCount; + property CreateHits : Integer read FCreateHits; + property DeleteHits : Integer read FDeleteHits; + + published + property DocString : TStringList read FDocString write SetDocString; + property TypeName : String read FTypeName write SetTypeName; + property TypeFlags : TPFlags read FTypeFlags write FTypeFlags default TPFLAGS_DEFAULT; + property Prefix : String read FPrefix write FPrefix; + property Module : TPythonModule read FModule write SetModule; + property Services : TTypeServices read FServices write SetServices; + property GenerateCreateFunction : Boolean read fGenerateCreateFunction write fGenerateCreateFunction default True; + end; + +//------------------------------------------------------- +//-- -- +//-- class: TPythonVar derived from TEngineClient -- +//-- -- +//------------------------------------------------------- + + TGetDataEvent = procedure ( Sender : TObject; var Data : Variant ) of Object; + TSetDataEvent = procedure ( Sender : TObject; Data : Variant ) of Object; + TExtGetDataEvent = procedure ( Sender : TObject; var Data : PPyObject ) of Object; + TExtSetDataEvent = procedure ( Sender : TObject; Data : PPyObject) of Object; + + TPythonDelphiVar = class( TEngineClient ) + protected + FModule : String; + FVarName : String; + FVarObject : PPyObject; + FOnGetData : TGetDataEvent; + FOnSetData : TSetDataEvent; + FOnExtGetData : TExtGetDataEvent; + FOnExtSetData : TExtSetDataEvent; + FOnChange : TNotifyEvent; + + procedure CreateVarType; + procedure CreateVar; + function GetValue : Variant; + procedure SetValue( const val : Variant ); + function GetValueAsPyObject : PPyObject; + procedure SetValueFromPyObject( val : PPyObject ); + function GetValueAsString : String; + procedure SetVarName( const val : String ); + + public + // Constructors & Destructors + constructor Create( AOwner : TComponent ); override; + + // Public methods + procedure Initialize; override; + procedure Finalize; override; + function IsVariantOk( const v : Variant ) : Boolean; + + // Public properties + property Value : Variant read GetValue write SetValue; + // Warning: ValueObject returns a preincremented object ! + property ValueObject : PPyObject read GetValueAsPyObject write SetValueFromPyObject; + property ValueAsString : String read GetValueAsString; + property VarObject : PPyObject read FVarObject write FVarObject; + + published + property Module : String read FModule write FModule; + property VarName : String read FVarName write SetVarName; + property OnGetData : TGetDataEvent read FOnGetData write FOnGetData; + property OnSetData : TSetDataEvent read FOnSetData write FOnSetData; + property OnExtGetData : TExtGetDataEvent read FOnExtGetData write FOnExtGetData; + property OnExtSetData : TExtSetDataEvent read FOnExtSetData write FOnExtSetData; + property OnChange : TNotifyEvent read FOnChange write FOnChange; + end; + + TPyVar = class(TPyObject) + dv_var : Variant; + dv_component : TPythonDelphiVar; + dv_object : PPyObject; + + // Constructors & Destructors + constructor Create( APythonType : TPythonType ); override; + constructor CreateWith( APythonType : TPythonType; args : PPyObject ); override; + destructor Destroy; override; + + // Type services + //////////////// + + // Basic services + function GetAttr(key : PChar) : PPyObject; override; + function SetAttr(key : PChar; value : PPyObject) : Integer; override; + function Repr : PPyObject; override; + + // Class methods + class procedure RegisterMethods( APythonType : TPythonType ); override; + + // Methods of TPyVar + function GetValue : PPyObject; + function GetValueAsVariant : Variant; + procedure SetValue( value : PPyObject ); + procedure SetValueFromVariant( const value : Variant ); + + // Interface methods + end; + +//####################################################### +//## ## +//## Thread Object with Python interpreter lock ## +//## ## +//####################################################### + TThreadExecMode = (emNewState, emNewInterpreter); + +{$HINTS OFF} + TPythonThread = class(TThread) + private + f_savethreadstate: PPyThreadState; + fInterpreterState: PPyInterpreterState; + fThreadState: PPyThreadState; + fThreadExecMode: TThreadExecMode; + +// Do not overwrite Execute! Use ExecuteWithPython instead! + procedure Execute; override; + protected + procedure ExecuteWithPython; virtual; abstract; + + procedure Py_Begin_Allow_Threads; + procedure Py_End_Allow_Threads; +// The following procedures are redundant and only for +// compatibility to the C API documentation. + procedure Py_Begin_Block_Threads; + procedure Py_Begin_Unblock_Threads; + + public + property InterpreterState: PPyInterpreterState read fInterpreterState + write fInterpreterState + default nil; + property ThreadState: PPyThreadState read fThreadState + write fThreadState; + property ThreadExecMode: TThreadExecMode read fThreadExecMode; + end; +{$HINTS ON} + +//####################################################### +//## ## +//## New Python objects ## +//## ## +//####################################################### + +//####################################################### +//## ## +//## Methods for new Python objects or modules ## +//## ## +//####################################################### + +// Module pyio for Python Input/Outputs +function pyio_write(self, args : PPyObject) : PPyObject; cdecl; +function pyio_read(self, args : PPyObject) : PPyObject; cdecl; +function pyio_SetDelayWrites(self, args : PPyObject) : PPyObject; cdecl; +function pyio_SetMaxLines(self, args : PPyObject) : PPyObject; cdecl; +function pyio_GetTypesStats(self, args : PPyObject) : PPyObject; cdecl; + + +//####################################################### +//## ## +//## Global procedures ## +//## ## +//####################################################### + +function GetPythonEngine : TPythonEngine; +function PythonOK : Boolean; +function PythonToDelphi( obj : PPyObject ) : TPyObject; +function IsDelphiObject( obj : PPyObject ) : Boolean; +procedure PyObjectDestructor( pSelf : PPyObject); cdecl; +procedure FreeSubtypeInst(ob:PPyObject); cdecl; +procedure Register; +{$IFDEF PYTHON20_OR_HIGHER} +function PyType_HasFeature(AType : PPyTypeObject; AFlag : Integer) : Boolean; +{$ENDIF} + +//####################################################### +//## ## +//## Global variables ## +//## ## +//####################################################### + + +implementation + +{$IFDEF MSWINDOWS} +uses Registry; +{$ENDIF} + + +(*******************************************************) +(** **) +(** Globals **) +(** **) +(*******************************************************) + +var + gPythonEngine : TPythonEngine; + gVarType : TPythonType; + +(*******************************************************) +(** **) +(** class TCriticalSection **) +(** **) +(*******************************************************) +{$IFNDEF HAS_SYNCOBJS_UNIT} + {$IFDEF MSWINDOWS} + // Note that this default implementation is needed to compile under Delphi3. +constructor TCriticalSection.Create; +begin + inherited Create; + InitializeCriticalSection(FSection); +end; + +destructor TCriticalSection.Destroy; +begin + DeleteCriticalSection(FSection); + inherited Destroy; +end; + +procedure TCriticalSection.Acquire; +begin + EnterCriticalSection(FSection); +end; + +procedure TCriticalSection.Release; +begin + LeaveCriticalSection(FSection); +end; + +procedure TCriticalSection.Enter; +begin + Acquire; +end; + +procedure TCriticalSection.Leave; +begin + Release; +end; + {$ENDIF} +{$ENDIF} + +(*******************************************************) +(** **) +(** class TPythonInputOutput **) +(** **) +(*******************************************************) + +constructor TPythonInputOutput.Create( AOwner : TComponent ); +begin + inherited; + FMaxLines := kMaxLines; + FQueue := TIOStringList.Create; + FDelayWrites := False; + FMaxLineLength := kMaxLineLength; + FLinesPerThread:= TIOStringList.Create; + FLock := TCriticalSection.Create; +end; + +destructor TPythonInputOutput.Destroy; +begin + FLinesPerThread.Free; + FQueue.Free; + FLock.Free; + inherited; +end; + +procedure TPythonInputOutput.Lock; +begin + FLock.Enter; +end; + +procedure TPythonInputOutput.Unlock; +begin + FLock.Leave; +end; + +procedure TPythonInputOutput.Write( const str : IOString ); + + procedure DropLine; + begin +{$IFDEF MSWINDOWS} + if DelayWrites then + AddWrite( FLine_Buffer ) + else +{$ENDIF} +{$IFDEF UNICODE_SUPPORT} + if UnicodeIO then + SendUniData( FLine_Buffer ) + else +{$ENDIF} + SendData( FLine_Buffer ); + FLine_Buffer := ''; + UpdateCurrentThreadLine; + end; + +var + i : Integer; + c : IOChar; +begin + Lock; + try + FLine_Buffer := GetCurrentThreadLine; + if FRawOutput then begin + FLine_Buffer := FLine_Buffer + str; + DropLine; + end else begin + for i := 1 to length(str) do + begin + c := str[i]; + if c = #10 then + DropLine + else if (c >= ' ') or (c = #09) then + begin + Insert( c, FLine_Buffer, length(FLine_Buffer)+1 ); + if Length(FLine_Buffer) > MaxLineLength then + DropLine; + end; + end; + end; + UpdateCurrentThreadLine; + finally + Unlock; + end; +end; + +procedure TPythonInputOutput.WriteLine( const str : IOString ); +begin + Write( str+#10 ); +end; + +procedure TPythonInputOutput.AddWrite( const str : IOString ); +begin + FQueue.Add( str ); + if FQueue.Count > FMaxLines then + FQueue.Delete(0) + else + AddPendingWrite; +end; + +procedure TPythonInputOutput.SendData( const Data : String ); +begin + if Assigned(FOnSendData) then + FOnSendData( Self, Data ); +end; + +{$IFDEF UNICODE_SUPPORT} +procedure TPythonInputOutput.SendUniData(const Data: WideString); +begin + if Assigned(FOnSendUniData) then + FOnSendUniData( Self, Data ); +end; +{$ENDIF} + +function TPythonInputOutput.ReceiveData : String; +begin + Result := ''; + if Assigned(FOnReceiveData) then + FOnReceiveData( Self, Result ); +end; + +{$IFDEF UNICODE_SUPPORT} +function TPythonInputOutput.ReceiveUniData: WideString; +begin + Result := ''; + if Assigned(FOnReceiveUniData) then + FOnReceiveUniData( Self, Result ); +end; +{$ENDIF} + +procedure TPythonInputOutput.AddPendingWrite; +begin +end; + +function TPythonInputOutput.GetCurrentThreadSlotIdx : Integer; +var + thread_id : Longint; + i : Integer; +begin + thread_id := GetCurrentThreadId; + for i := 0 to FLinesPerThread.Count-1 do + if Longint(FLinesPerThread.Objects[i]) = thread_id then + begin + Result := i; + Exit; + end; + Result := FLinesPerThread.AddObject( '', TObject(thread_id) ); +end; + +function TPythonInputOutput.GetCurrentThreadLine : IOString; +begin + Result := FLinesPerThread.Strings[ GetCurrentThreadSlotIdx ]; +end; + +procedure TPythonInputOutput.UpdateCurrentThreadLine; +begin + FLinesPerThread.Strings[ GetCurrentThreadSlotIdx ] := FLine_Buffer; +end; + +(*******************************************************) +(** **) +(** class TDynamicDll **) +(** **) +(*******************************************************) + +procedure TDynamicDll.DoOpenDll(const aDllName : String); +begin + if not IsHandleValid then + begin + FDllName := aDllName; + FDLLHandle := LoadLibrary( + {$IFDEF FPC} + PChar(AnsiString(GetDllPath+DllName)) + {$ELSE} + PChar(GetDllPath+DllName) + {$ENDIF} + ); + end; +end; + +function TDynamicDll.GetDllPath : String; +{$IFDEF MSWINDOWS} +var + key : String; + AllUserInstall : Boolean; +{$ENDIF} +begin + Result := DllPath; + + {$IFDEF MSWINDOWS} + + // Python provides for All user and Current user installations + // All User installations place the Python DLL in the Windows System directory + // and write registry info to HKEY_LOCAL_MACHINE + // Current User installations place the DLL in the install path and + // the registry info in HKEY_CURRENT_USER. + // Hence, for Current user installations we need to try and find the install path + // since it may not be on the system path. + + if DLLPath = '' then begin + AllUserInstall := False; + try + key := Format('\Software\Python\PythonCore\%s\InstallPath', [RegVersion]); + with TRegistry.Create do + try + RootKey := HKEY_LOCAL_MACHINE; + if KeyExists( key ) then + AllUserInstall := True; + finally + Free; + end; + except + // under WinNT, with a user without admin rights, the access to the + // LocalMachine keys would raise an exception. + end; + // We do not seem to have an All User Python Installation. + // Check whether we have a current user installation + if not AllUserInstall then + with TRegistry.Create do + try + RootKey := HKEY_CURRENT_USER; + if OpenKey(Key, False) then + Result := ReadString(''); + finally + Free; + end; + end; +{$ENDIF} + + if Result <> '' then + begin +{$IFDEF DELPHI6_OR_HIGHER} + Result := IncludeTrailingPathDelimiter(Result); +{$ELSE} + if Result[Length(Result)] <> '\' then + Result := Result + '\'; +{$ENDIF} + end; +end; + +procedure TDynamicDll.OpenDll(const aDllName : String); +var + s : String; +begin + UnloadDll; + + BeforeLoad; + + FDLLHandle := 0; + + DoOpenDll(aDllName); + + if not IsHandleValid then begin +{$IFDEF MSWINDOWS} + s := Format('Error %d: Could not open Dll "%s"',[GetLastError, DllName]); +{$ENDIF} +{$IFDEF LINUX} + s := Format('Error: Could not open Dll "%s"',[DllName]); +{$ENDIF} + if FatalMsgDlg then +{$IFDEF MSWINDOWS} + MessageBox( GetActiveWindow, PChar(s), 'Error', MB_TASKMODAL or MB_ICONSTOP ); +{$ENDIF} +{$IFDEF LINUX} + WriteLn(ErrOutput, s); +{$ENDIF} + + if FatalAbort then + Quit; + end else + AfterLoad; +end; + +constructor TDynamicDll.Create(AOwner: TComponent); +begin + inherited; + FFatalMsgDlg := True; + FFatalAbort := True; + FAutoLoad := True; + FUseLastKnownVersion := True; +end; + +destructor TDynamicDll.Destroy; +begin + if AutoUnload then + UnloadDll; + inherited; +end; + +function TDynamicDll.Import(const funcname: String; canFail : Boolean = True): Pointer; +var + E : EDllImportError; +begin + Result := GetProcAddress( FDLLHandle, PChar(funcname) ); + if (Result = nil) and canFail then begin + E := EDllImportError.CreateFmt('Error %d: could not map symbol "%s"', [GetLastError, funcname]); + E.ErrorCode := GetLastError; + E.WrongFunc := funcname; + raise E; + end; +end; + +procedure TDynamicDll.Loaded; +begin + inherited; + if AutoLoad and not (csDesigning in ComponentState) then + LoadDll; +end; + +function TDynamicDll.IsHandleValid : Boolean; +begin +{$IFDEF MSWINDOWS} + Result := (FDLLHandle >= 32); +{$ENDIF} +{$IFDEF LINUX} + Result := FDLLHandle <> 0; +{$ENDIF} +end; + +procedure TDynamicDll.LoadDll; +begin + OpenDll( DllName ); +end; + +procedure TDynamicDll.UnloadDll; +begin + if IsHandleValid then begin + BeforeUnload; + FreeLibrary(FDLLHandle); + FDLLHandle := 0; + end; +end; + +procedure TDynamicDll.BeforeLoad; +begin + if Assigned( FOnBeforeLoad ) then + FOnBeforeLoad( Self ); +end; + +procedure TDynamicDll.AfterLoad; +begin + if Assigned( FOnAfterLoad ) then + FOnAfterLoad( Self ); +end; + +procedure TDynamicDll.BeforeUnload; +begin + if Assigned( FOnBeforeUnload ) then + FOnBeforeUnload( Self ); +end; + +function TDynamicDll.GetQuitMessage : String; +begin + Result := Format( 'Dll %s could not be loaded. We must quit.', [DllName]); +end; + +procedure TDynamicDll.Quit; +begin + if not( csDesigning in ComponentState ) then begin +{$IFDEF MSWINDOWS} + MessageBox( GetActiveWindow, PChar(GetQuitMessage), 'Error', MB_TASKMODAL or MB_ICONSTOP ); + ExitProcess( 1 ); +{$ENDIF} +{$IFDEF LINUX} + WriteLn(ErrOutput, GetQuitMessage); + __exit( 1 ); +{$ENDIF} + end; +end; + +function TDynamicDll.IsAPIVersionStored: Boolean; +begin + Result := not UseLastKnownVersion; +end; + +function TDynamicDll.IsDllNameStored: Boolean; +begin + Result := not UseLastKnownVersion; +end; + +function TDynamicDll.IsRegVersionStored: Boolean; +begin + Result := not UseLastKnownVersion; +end; + +procedure TDynamicDll.SetDllName(const Value: String); +begin + FDllName := Value; +end; + + +(*******************************************************) +(** **) +(** class TPythonInterface **) +(** **) +(*******************************************************) + +constructor TPythonInterface.Create(AOwner: TComponent); +var + i : Integer; +begin + inherited; + i := COMPILED_FOR_PYTHON_VERSION_INDEX; + DllName := PYTHON_KNOWN_VERSIONS[i].DllName; + FAPIVersion := PYTHON_KNOWN_VERSIONS[i].APIVersion; + FRegVersion := PYTHON_KNOWN_VERSIONS[i].RegVersion; + FAutoUnload := True; +end; + +procedure TPythonInterface.AfterLoad; +begin + inherited; + try + MapDll; + except + on E: Exception do begin + if FatalMsgDlg then +{$IFDEF MSWINDOWS} + MessageBox( GetActiveWindow, PChar(E.Message), 'Error', MB_TASKMODAL or MB_ICONSTOP ); +{$ENDIF} +{$IFDEF LINUX} + WriteLn( ErrOutput, E.Message ); +{$ENDIF} + if FatalAbort then Quit; + end; + end; +end; + +function TPythonInterface.GetQuitMessage : String; +begin + Result := Format( 'Python could not be properly initialized. We must quit.', [DllName]); +end; + +function TPythonInterface.GetInitialized: Boolean; +begin + if Assigned(Py_IsInitialized) then + Result := Py_IsInitialized{$IFDEF FPC}(){$ENDIF} <> 0 + else + Result := FInitialized; +end; + +procedure TPythonInterface.CheckPython; +begin + if not Initialized then + raise Exception.Create('Python is not properly initialized' ); +end; + +function TPythonInterface.GetUnicodeTypeSuffix : String; +begin + if APIVersion >= 1011 then + Result := 'UCS2' + else + Result := ''; +end; + +procedure TPythonInterface.MapDll; +begin + Py_DebugFlag := Import('Py_DebugFlag'); + Py_VerboseFlag := Import('Py_VerboseFlag'); + Py_InteractiveFlag := Import('Py_InteractiveFlag'); + Py_OptimizeFlag := Import('Py_OptimizeFlag'); + Py_NoSiteFlag := Import('Py_NoSiteFlag'); + Py_UseClassExceptionsFlag := Import('Py_UseClassExceptionsFlag'); + Py_FrozenFlag := Import('Py_FrozenFlag'); + Py_TabcheckFlag := Import('Py_TabcheckFlag'); +{$IFDEF PYTHON20_OR_HIGHER} + Py_UnicodeFlag := Import('Py_UnicodeFlag'); +{$ENDIF} +{$IFDEF PYTHON22_OR_HIGHER} + Py_IgnoreEnvironmentFlag := Import('Py_IgnoreEnvironmentFlag'); + Py_DivisionWarningFlag := Import('Py_DivisionWarningFlag'); +{$ENDIF} + + //_PySys_TraceFunc := Import('_PySys_TraceFunc'); + //_PySys_ProfileFunc := Import('_PySys_ProfileFunc'); + + Py_None := Import('_Py_NoneStruct'); + Py_Ellipsis := Import('_Py_EllipsisObject'); + Py_False := Import('_Py_ZeroStruct'); + Py_True := Import('_Py_TrueStruct'); +{$IFDEF PYTHON21_OR_HIGHER} + Py_NotImplemented := Import('_Py_NotImplementedStruct'); +{$ENDIF} + + PyImport_FrozenModules := Import('PyImport_FrozenModules'); + + PyExc_AttributeError := Import('PyExc_AttributeError'); + PyExc_EOFError := Import('PyExc_EOFError'); + PyExc_IOError := Import('PyExc_IOError'); + PyExc_ImportError := Import('PyExc_ImportError'); + PyExc_IndexError := Import('PyExc_IndexError'); + PyExc_KeyError := Import('PyExc_KeyError'); + PyExc_KeyboardInterrupt := Import('PyExc_KeyboardInterrupt'); + PyExc_MemoryError := Import('PyExc_MemoryError'); + PyExc_NameError := Import('PyExc_NameError'); + PyExc_OverflowError := Import('PyExc_OverflowError'); + PyExc_RuntimeError := Import('PyExc_RuntimeError'); + PyExc_SyntaxError := Import('PyExc_SyntaxError'); + PyExc_SystemError := Import('PyExc_SystemError'); + PyExc_SystemExit := Import('PyExc_SystemExit'); + PyExc_TypeError := Import('PyExc_TypeError'); + PyExc_ValueError := Import('PyExc_ValueError'); + PyExc_ZeroDivisionError := Import('PyExc_ZeroDivisionError'); + PyExc_ArithmeticError := Import('PyExc_ArithmeticError'); + PyExc_Exception := Import('PyExc_Exception'); + PyExc_FloatingPointError := Import('PyExc_FloatingPointError'); + PyExc_LookupError := Import('PyExc_LookupError'); + PyExc_StandardError := Import('PyExc_StandardError'); +{$IFDEF PYTHON20_OR_HIGHER} + PyExc_AssertionError := Import('PyExc_AssertionError'); + PyExc_EnvironmentError := Import('PyExc_EnvironmentError'); + PyExc_IndentationError := Import('PyExc_IndentationError'); + PyExc_MemoryErrorInst := Import('PyExc_MemoryErrorInst'); + PyExc_NotImplementedError := Import('PyExc_NotImplementedError'); + PyExc_OSError := Import('PyExc_OSError'); + PyExc_TabError := Import('PyExc_TabError'); + PyExc_UnboundLocalError := Import('PyExc_UnboundLocalError'); + PyExc_UnicodeError := Import('PyExc_UnicodeError'); + {$IFDEF MSWINDOWS} + PyExc_WindowsError := Import('PyExc_WindowsError'); + {$ENDIF} +{$ENDIF} +{$IFDEF PYTHON21_OR_HIGHER} + PyExc_Warning := Import('PyExc_Warning'); + PyExc_DeprecationWarning := Import('PyExc_DeprecationWarning'); + PyExc_RuntimeWarning := Import('PyExc_RuntimeWarning'); + PyExc_SyntaxWarning := Import('PyExc_SyntaxWarning'); + PyExc_UserWarning := Import('PyExc_UserWarning'); +{$ENDIF} +{$IFDEF PYTHON22_OR_HIGHER} + PyExc_ReferenceError := Import('PyExc_ReferenceError'); + PyExc_StopIteration := Import('PyExc_StopIteration'); +{$ENDIF} +{$IFDEF PYTHON23_OR_HIGHER} + PyExc_FutureWarning := Import('PyExc_FutureWarning'); + PyExc_PendingDeprecationWarning:= Import('PyExc_PendingDeprecationWarning'); + PyExc_UnicodeDecodeError := Import('PyExc_UnicodeDecodeError'); + PyExc_UnicodeEncodeError := Import('PyExc_UnicodeEncodeError'); + PyExc_UnicodeTranslateError:= Import('PyExc_UnicodeTranslateError'); +{$ENDIF} + PyType_Type := Import('PyType_Type'); + PyCFunction_Type := Import('PyCFunction_Type'); + PyCObject_Type := Import('PyCObject_Type'); + PyClass_Type := Import('PyClass_Type'); + PyCode_Type := Import('PyCode_Type'); + PyComplex_Type := Import('PyComplex_Type'); + PyDict_Type := Import('PyDict_Type'); + PyFile_Type := Import('PyFile_Type'); + PyFloat_Type := Import('PyFloat_Type'); + PyFrame_Type := Import('PyFrame_Type'); + PyFunction_Type := Import('PyFunction_Type'); + PyInstance_Type := Import('PyInstance_Type'); + PyInt_Type := Import('PyInt_Type'); + PyList_Type := Import('PyList_Type'); + PyLong_Type := Import('PyLong_Type'); + PyMethod_Type := Import('PyMethod_Type'); + PyModule_Type := Import('PyModule_Type'); + PyObject_Type := Import('PyObject_Type'); + PyRange_Type := Import('PyRange_Type'); + PySlice_Type := Import('PySlice_Type'); + PyString_Type := Import('PyString_Type'); + PyTuple_Type := Import('PyTuple_Type'); +{$IFDEF UNICODE_SUPPORT} + PyUnicode_Type := Import('PyUnicode_Type'); +{$ENDIF} +{$IFDEF PYTHON22_OR_HIGHER} + PyBaseObject_Type := Import('PyBaseObject_Type'); + PyBuffer_Type := Import('PyBuffer_Type'); + PyCallIter_Type := Import('PyCallIter_Type'); + PyCell_Type := Import('PyCell_Type'); + PyClassMethod_Type := Import('PyClassMethod_Type'); + PyProperty_Type := Import('PyProperty_Type'); + PySeqIter_Type := Import('PySeqIter_Type'); + PyStaticMethod_Type := Import('PyStaticMethod_Type'); + PySuper_Type := Import('PySuper_Type'); + {$IFNDEF PYTHON25_OR_HIGHER} + PySymtableEntry_Type := Import('PySymtableEntry_Type', False); + {$ENDIF} + PyTraceBack_Type := Import('PyTraceBack_Type'); + PyWrapperDescr_Type := Import('PyWrapperDescr_Type'); + _PyWeakref_RefType := Import('_PyWeakref_RefType'); + _PyWeakref_ProxyType := Import('_PyWeakref_ProxyType'); + _PyWeakref_CallableProxyType:=Import('_PyWeakref_CallableProxyType'); +{$ENDIF} +{$IFDEF PYTHON23_OR_HIGHER} + PyBaseString_Type := Import('PyBaseString_Type'); + PyBool_Type := Import('PyBool_Type'); + PyEnum_Type := Import('PyEnum_Type'); +{$ENDIF} + + //@PyArg_GetObject := Import('PyArg_GetObject'); + //@PyArg_GetLong := Import('PyArg_GetLong'); + //@PyArg_GetShort := Import('PyArg_GetShort'); + //@PyArg_GetFloat := Import('PyArg_GetFloat'); + //@PyArg_GetString := Import('PyArg_GetString'); + //@PyArgs_VaParse := Import('PyArgs_VaParse'); + //@Py_VaBuildValue := Import('Py_VaBuildValue'); + //@PyBuiltin_Init := Import('PyBuiltin_Init'); + @PyComplex_FromCComplex := Import('PyComplex_FromCComplex'); + @PyComplex_FromDoubles := Import('PyComplex_FromDoubles'); + @PyComplex_RealAsDouble := Import('PyComplex_RealAsDouble'); + @PyComplex_ImagAsDouble := Import('PyComplex_ImagAsDouble'); + @PyComplex_AsCComplex := Import('PyComplex_AsCComplex'); + @PyCFunction_GetFunction := Import('PyCFunction_GetFunction'); + @PyCFunction_GetSelf := Import('PyCFunction_GetSelf'); + @PyCallable_Check := Import('PyCallable_Check'); + @PyCObject_FromVoidPtr := Import('PyCObject_FromVoidPtr'); + @PyCObject_AsVoidPtr := Import('PyCObject_AsVoidPtr'); + @PyClass_New := Import('PyClass_New'); + @PyClass_IsSubclass := Import('PyClass_IsSubclass'); + @PyDict_GetItem := Import('PyDict_GetItem'); + @PyDict_SetItem := Import('PyDict_SetItem'); + @PyDict_DelItem := Import('PyDict_DelItem'); + @PyDict_Clear := Import('PyDict_Clear'); + @PyDict_Next := Import('PyDict_Next'); + @PyDict_Keys := Import('PyDict_Keys'); + @PyDict_Values := Import('PyDict_Values'); + @PyDict_Items := Import('PyDict_Items'); + @PyDict_Size := Import('PyDict_Size'); + @PyDict_DelItemString := Import('PyDict_DelItemString'); +{$IFDEF PYTHON22_OR_HIGHER} + @PyDict_Copy := Import('PyDict_Copy'); + @PyDictProxy_New := Import('PyDictProxy_New'); +{$ENDIF} + @Py_InitModule4 := Import('Py_InitModule4'); + @PyErr_Print := Import('PyErr_Print'); + @PyErr_SetNone := Import('PyErr_SetNone'); + @PyErr_SetObject := Import('PyErr_SetObject'); + @PyErr_Restore := Import('PyErr_Restore'); + @PyErr_BadArgument := Import('PyErr_BadArgument'); + @PyErr_NoMemory := Import('PyErr_NoMemory'); + @PyErr_SetFromErrno := Import('PyErr_SetFromErrno'); + @PyErr_BadInternalCall := Import('PyErr_BadInternalCall'); + @PyErr_CheckSignals := Import('PyErr_CheckSignals'); + @PyErr_Occurred := Import('PyErr_Occurred'); + @PyErr_Clear := Import('PyErr_Clear'); + @PyErr_Fetch := Import('PyErr_Fetch'); + @PyErr_SetString := Import('PyErr_SetString'); + @PyEval_GetBuiltins := Import('PyEval_GetBuiltins'); + @PyImport_GetModuleDict := Import('PyImport_GetModuleDict'); + @PyInt_FromLong := Import('PyInt_FromLong'); + @DLL_PyArg_ParseTuple := Import('PyArg_ParseTuple'); + @DLL_PyArg_Parse := Import('PyArg_Parse'); + @DLL_Py_BuildValue := Import('Py_BuildValue'); + @Py_Initialize := Import('Py_Initialize'); + @PyDict_New := Import('PyDict_New'); + @PyDict_SetItemString := Import('PyDict_SetItemString'); + @PyModule_GetDict := Import('PyModule_GetDict'); + @PyObject_Str := Import('PyObject_Str'); + @PyRun_String := Import('PyRun_String'); + @PyRun_SimpleString := Import('PyRun_SimpleString'); + @PyDict_GetItemString := Import('PyDict_GetItemString'); + @PyString_AsString := Import('PyString_AsString'); + @PyString_FromString := Import('PyString_FromString'); + @PySys_SetArgv := Import('PySys_SetArgv'); + @Py_Exit := Import('Py_Exit'); + + @PyCFunction_New :=Import('PyCFunction_New'); + @PyEval_CallObject :=Import('PyEval_CallObject'); + @PyEval_CallObjectWithKeywords:=Import('PyEval_CallObjectWithKeywords'); + @PyEval_GetFrame :=Import('PyEval_GetFrame'); + @PyEval_GetGlobals :=Import('PyEval_GetGlobals'); + @PyEval_GetLocals :=Import('PyEval_GetLocals'); + //@PyEval_GetOwner :=Import('PyEval_GetOwner'); + @PyEval_GetRestricted :=Import('PyEval_GetRestricted'); + @PyEval_InitThreads :=Import('PyEval_InitThreads'); + @PyEval_RestoreThread :=Import('PyEval_RestoreThread'); + @PyEval_SaveThread :=Import('PyEval_SaveThread'); + @PyFile_FromString :=Import('PyFile_FromString'); + @PyFile_GetLine :=Import('PyFile_GetLine'); + @PyFile_Name :=Import('PyFile_Name'); + @PyFile_SetBufSize :=Import('PyFile_SetBufSize'); + @PyFile_SoftSpace :=Import('PyFile_SoftSpace'); + @PyFile_WriteObject :=Import('PyFile_WriteObject'); + @PyFile_WriteString :=Import('PyFile_WriteString'); + @PyFloat_AsDouble :=Import('PyFloat_AsDouble'); + @PyFloat_FromDouble :=Import('PyFloat_FromDouble'); + @PyFunction_GetCode :=Import('PyFunction_GetCode'); + @PyFunction_GetGlobals :=Import('PyFunction_GetGlobals'); + @PyFunction_New :=Import('PyFunction_New'); + @PyImport_AddModule :=Import('PyImport_AddModule'); + @PyImport_Cleanup :=Import('PyImport_Cleanup'); + @PyImport_GetMagicNumber :=Import('PyImport_GetMagicNumber'); + @PyImport_ImportFrozenModule:=Import('PyImport_ImportFrozenModule'); + @PyImport_ImportModule :=Import('PyImport_ImportModule'); + @PyImport_Import :=Import('PyImport_Import'); + //@PyImport_Init :=Import('PyImport_Init'); + @PyImport_ReloadModule :=Import('PyImport_ReloadModule'); + @PyInstance_New :=Import('PyInstance_New'); + @PyInt_AsLong :=Import('PyInt_AsLong'); + @PyList_Append :=Import('PyList_Append'); + @PyList_AsTuple :=Import('PyList_AsTuple'); + @PyList_GetItem :=Import('PyList_GetItem'); + @PyList_GetSlice :=Import('PyList_GetSlice'); + @PyList_Insert :=Import('PyList_Insert'); + @PyList_New :=Import('PyList_New'); + @PyList_Reverse :=Import('PyList_Reverse'); + @PyList_SetItem :=Import('PyList_SetItem'); + @PyList_SetSlice :=Import('PyList_SetSlice'); + @PyList_Size :=Import('PyList_Size'); + @PyList_Sort :=Import('PyList_Sort'); + @PyLong_AsDouble :=Import('PyLong_AsDouble'); + @PyLong_AsLong :=Import('PyLong_AsLong'); + @PyLong_FromDouble :=Import('PyLong_FromDouble'); + @PyLong_FromLong :=Import('PyLong_FromLong'); + @PyLong_FromString :=Import('PyLong_FromString'); + @PyLong_FromString :=Import('PyLong_FromString'); + @PyLong_FromUnsignedLong :=Import('PyLong_FromUnsignedLong'); + @PyLong_AsUnsignedLong :=Import('PyLong_AsUnsignedLong'); +{$IFDEF UNICODE_SUPPORT} + @PyLong_FromUnicode :=Import('PyLong_FromUnicode'); +{$ENDIF} +{$IFDEF DELPHI6_OR_HIGHER} + @PyLong_FromLongLong :=Import('PyLong_FromLongLong'); + @PyLong_AsLongLong :=Import('PyLong_AsLongLong'); +{$ENDIF} + @PyMapping_Check :=Import('PyMapping_Check'); + @PyMapping_GetItemString :=Import('PyMapping_GetItemString'); + @PyMapping_HasKey :=Import('PyMapping_HasKey'); + @PyMapping_HasKeyString :=Import('PyMapping_HasKeyString'); + @PyMapping_Length :=Import('PyMapping_Length'); + @PyMapping_SetItemString :=Import('PyMapping_SetItemString'); + @PyMethod_Class :=Import('PyMethod_Class'); + @PyMethod_Function :=Import('PyMethod_Function'); + @PyMethod_New :=Import('PyMethod_New'); + @PyMethod_Self :=Import('PyMethod_Self'); + @PyModule_GetName :=Import('PyModule_GetName'); + @PyModule_New :=Import('PyModule_New'); + @PyNumber_Absolute :=Import('PyNumber_Absolute'); + @PyNumber_Add :=Import('PyNumber_Add'); + @PyNumber_And :=Import('PyNumber_And'); + @PyNumber_Check :=Import('PyNumber_Check'); + @PyNumber_Coerce :=Import('PyNumber_Coerce'); + @PyNumber_Divide :=Import('PyNumber_Divide'); +{$IFDEF PYTHON22_OR_HIGHER} + @PyNumber_FloorDivide :=Import('PyNumber_FloorDivide'); + @PyNumber_TrueDivide :=Import('PyNumber_TrueDivide'); +{$ENDIF} + @PyNumber_Divmod :=Import('PyNumber_Divmod'); + @PyNumber_Float :=Import('PyNumber_Float'); + @PyNumber_Int :=Import('PyNumber_Int'); + @PyNumber_Invert :=Import('PyNumber_Invert'); + @PyNumber_Long :=Import('PyNumber_Long'); + @PyNumber_Lshift :=Import('PyNumber_Lshift'); + @PyNumber_Multiply :=Import('PyNumber_Multiply'); + @PyNumber_Negative :=Import('PyNumber_Negative'); + @PyNumber_Or :=Import('PyNumber_Or'); + @PyNumber_Positive :=Import('PyNumber_Positive'); + @PyNumber_Power :=Import('PyNumber_Power'); + @PyNumber_Remainder :=Import('PyNumber_Remainder'); + @PyNumber_Rshift :=Import('PyNumber_Rshift'); + @PyNumber_Subtract :=Import('PyNumber_Subtract'); + @PyNumber_Xor :=Import('PyNumber_Xor'); + @PyOS_InitInterrupts :=Import('PyOS_InitInterrupts'); + @PyOS_InterruptOccurred :=Import('PyOS_InterruptOccurred'); + @PyObject_CallObject :=Import('PyObject_CallObject'); + @PyObject_CallMethodStr :=Import('PyObject_CallMethod'); + @PyObject_Compare :=Import('PyObject_Compare'); + @PyObject_GetAttr :=Import('PyObject_GetAttr'); + @PyObject_GetAttrString :=Import('PyObject_GetAttrString'); + @PyObject_GetItem :=Import('PyObject_GetItem'); + @PyObject_DelItem :=Import('PyObject_DelItem'); + @PyObject_HasAttrString :=Import('PyObject_HasAttrString'); + @PyObject_Hash :=Import('PyObject_Hash'); + @PyObject_IsTrue :=Import('PyObject_IsTrue'); + @PyObject_Length :=Import('PyObject_Length'); + @PyObject_Repr :=Import('PyObject_Repr'); + @PyObject_SetAttr :=Import('PyObject_SetAttr'); + @PyObject_SetAttrString :=Import('PyObject_SetAttrString'); + @PyObject_SetItem :=Import('PyObject_SetItem'); +{$IFDEF PYTHON20_OR_HIGHER} + @PyObject_Init :=Import('PyObject_Init'); + @PyObject_InitVar :=Import('PyObject_InitVar'); + @PyObject_New :=Import('_PyObject_New'); + @PyObject_NewVar :=Import('_PyObject_NewVar'); + @PyObject_Free :=Import('PyObject_Free'); + @PyObject_GetIter :=Import('PyObject_GetIter'); + @PyIter_Next :=Import('PyIter_Next'); +{$ENDIF} +{$IFDEF PYTHON21_OR_HIGHER} + @PyObject_IsInstance :=Import('PyObject_IsInstance'); + @PyObject_IsSubclass :=Import('PyObject_IsSubclass'); +{$ENDIF} +{$IFDEF PYTHON22_OR_HIGHER} + @PyObject_Call :=Import('PyObject_Call'); + @PyObject_GenericGetAttr :=Import('PyObject_GenericGetAttr'); + @PyObject_GenericSetAttr :=Import('PyObject_GenericSetAttr'); +{$ENDIF} +{$IFDEF PYTHON23_OR_HIGHER} + PyObject_GC_Malloc :=Import('_PyObject_GC_Malloc'); + PyObject_GC_New :=Import('_PyObject_GC_New'); + PyObject_GC_NewVar :=Import('_PyObject_GC_NewVar'); + PyObject_GC_Resize :=Import('_PyObject_GC_Resize'); + PyObject_GC_Del :=Import('PyObject_GC_Del'); + PyObject_GC_Track :=Import('PyObject_GC_Track'); + PyObject_GC_UnTrack :=Import('PyObject_GC_UnTrack'); +{$ENDIF} +{$IFNDEF PYTHON25_OR_HIGHER} + @PyRange_New :=Import('PyRange_New', False); +{$ENDIF} + @PySequence_Check :=Import('PySequence_Check'); + @PySequence_Concat :=Import('PySequence_Concat'); + @PySequence_Count :=Import('PySequence_Count'); + @PySequence_GetItem :=Import('PySequence_GetItem'); + @PySequence_GetSlice :=Import('PySequence_GetSlice'); + @PySequence_In :=Import('PySequence_In'); + @PySequence_Index :=Import('PySequence_Index'); + @PySequence_Length :=Import('PySequence_Length'); + @PySequence_Repeat :=Import('PySequence_Repeat'); + @PySequence_SetItem :=Import('PySequence_SetItem'); + @PySequence_SetSlice :=Import('PySequence_SetSlice'); + @PySequence_DelSlice :=Import('PySequence_DelSlice'); + @PySequence_Tuple :=Import('PySequence_Tuple'); +{$IFDEF PYTHON20_OR_HIGHER} + @PySequence_Contains :=Import('PySequence_Contains'); +{$ENDIF} + @PySlice_GetIndices :=Import('PySlice_GetIndices'); + @PySeqIter_New :=Import('PySeqIter_New'); +{$IFDEF PYTHON23_OR_HIGHER} + @PySlice_GetIndicesEx :=Import('PySlice_GetIndicesEx'); +{$ENDIF} + @PySlice_New :=Import('PySlice_New'); + @PyString_Concat :=Import('PyString_Concat'); + @PyString_ConcatAndDel :=Import('PyString_ConcatAndDel'); + @PyString_Format :=Import('PyString_Format'); + @PyString_FromStringAndSize:=Import('PyString_FromStringAndSize'); + @PyString_Size :=Import('PyString_Size'); +{$IFDEF PYTHON23_OR_HIGHER} + @PyString_DecodeEscape :=Import('PyString_DecodeEscape'); + @PyString_Repr :=Import('PyString_Repr'); +{$ENDIF} + @PySys_GetObject :=Import('PySys_GetObject'); + //@PySys_Init :=Import('PySys_Init'); + @PySys_SetObject :=Import('PySys_SetObject'); + @PySys_SetPath :=Import('PySys_SetPath'); + //@PyTraceBack_Fetch :=Import('PyTraceBack_Fetch'); + @PyTraceBack_Here :=Import('PyTraceBack_Here'); + @PyTraceBack_Print :=Import('PyTraceBack_Print'); + //@PyTraceBack_Store :=Import('PyTraceBack_Store'); + @PyTuple_GetItem :=Import('PyTuple_GetItem'); + @PyTuple_GetSlice :=Import('PyTuple_GetSlice'); + @PyTuple_New :=Import('PyTuple_New'); + @PyTuple_SetItem :=Import('PyTuple_SetItem'); + @PyTuple_Size :=Import('PyTuple_Size'); +{$IFDEF PYTHON22_OR_HIGHER} + @PyType_IsSubtype :=Import('PyType_IsSubtype'); + @PyType_GenericAlloc :=Import('PyType_GenericAlloc'); + @PyType_GenericNew :=Import('PyType_GenericNew'); + @PyType_Ready :=Import('PyType_Ready'); +{$ENDIF} +{$IFDEF UNICODE_SUPPORT} + @PyUnicode_FromWideChar :=Import(Format('PyUnicode%s_FromWideChar',[GetUnicodeTypeSuffix])); + @PyUnicode_AsWideChar :=Import(Format('PyUnicode%s_AsWideChar',[GetUnicodeTypeSuffix])); +{$IFDEF PYTHON23_OR_HIGHER} + @PyUnicode_FromOrdinal :=Import(Format('PyUnicode%s_FromOrdinal',[GetUnicodeTypeSuffix])); +{$ENDIF} +{$ENDIF} +{$IFDEF PYTHON22_OR_HIGHER} + @PyWeakref_GetObject :=Import('PyWeakref_GetObject'); + @PyWeakref_NewProxy :=Import('PyWeakref_NewProxy'); + @PyWeakref_NewRef :=Import('PyWeakref_NewRef'); + @PyWrapper_New :=Import('PyWrapper_New'); +{$ENDIF} +{$IFDEF PYTHON23_OR_HIGHER} + @PyBool_FromLong :=Import('PyBool_FromLong'); + @PyThreadState_SetAsyncExc :=Import('PyThreadState_SetAsyncExc'); +{$ENDIF} + @Py_AtExit :=Import('Py_AtExit'); + //@Py_Cleanup :=Import('Py_Cleanup'); + @Py_CompileString :=Import('Py_CompileString'); + @Py_FatalError :=Import('Py_FatalError'); + @Py_FindMethod :=Import('Py_FindMethod'); + @Py_FindMethodInChain :=Import('Py_FindMethodInChain'); + @Py_FlushLine :=Import('Py_FlushLine'); + @_PyObject_New :=Import('_PyObject_New'); + @_PyString_Resize :=Import('_PyString_Resize'); + @Py_Finalize :=Import('Py_Finalize'); + if getProcAddress( FDLLHandle, 'PyCode_Addr2Line' ) <> nil then + @DLL_PyCode_Addr2Line := Import('PyCode_Addr2Line'); + if getProcAddress( FDLLHandle, 'PyImport_ExecCodeModule' ) <> nil then + @DLL_PyImport_ExecCodeModule := Import('PyImport_ExecCodeModule'); + @PyClass_IsSubclass :=Import('PyClass_IsSubclass'); + @PyErr_ExceptionMatches :=Import('PyErr_ExceptionMatches'); + @PyErr_GivenExceptionMatches:=Import('PyErr_GivenExceptionMatches'); + @PyEval_EvalCode :=Import('PyEval_EvalCode'); + @Py_GetVersion :=Import('Py_GetVersion'); + @Py_GetCopyright :=Import('Py_GetCopyright'); + @Py_GetExecPrefix :=Import('Py_GetExecPrefix'); + @Py_GetPath :=Import('Py_GetPath'); + @Py_GetPrefix :=Import('Py_GetPrefix'); + @Py_GetProgramName :=Import('Py_GetProgramName'); + @PyParser_SimpleParseString :=Import('PyParser_SimpleParseString'); + @PyNode_Free :=Import('PyNode_Free'); + @PyErr_NewException :=Import('PyErr_NewException'); +{$IFDEF PYTHON20_OR_HIGHER} +/// jah 29-sep-2000 : updated for python 2.0 +/// replaced Py_Malloc with PyMem_Malloc +///--- @Py_Malloc := Import ('Py_Malloc'); +///+++ @Py_Malloc := Import ('PyMem_Malloc'); + try + @Py_Malloc := Import ('PyMem_Malloc'); + @PyMem_Malloc := Import ('PyMem_Malloc'); + except + end; +{$ENDIF} +{$IFDEF PYTHON15} + @Py_Malloc := Import ('Py_Malloc'); +{$ENDIF} + @PyObject_CallMethod :=Import('PyObject_CallMethod'); + if (APIVersion < 1007) or + (DllName = PYTHON_KNOWN_VERSIONS[1].DllName) then + begin + @Py_SetProgramName := nil; + @Py_IsInitialized := nil; + @Py_GetProgramFullPath := nil; + @DLL_Py_GetBuildInfo := nil; + @Py_NewInterpreter := nil; + @Py_EndInterpreter := nil; + @PyEval_AcquireLock := nil; + @PyEval_ReleaseLock := nil; + @PyEval_AcquireThread := nil; + @PyEval_ReleaseThread := nil; + @PyInterpreterState_New := nil; + @PyInterpreterState_Clear := nil; + @PyInterpreterState_Delete := nil; + @PyThreadState_New := nil; + @PyThreadState_Clear := nil; + @PyThreadState_Delete := nil; + @PyThreadState_Get := nil; + @PyThreadState_Swap := nil; + @PyErr_SetInterrupt := nil; + end else + begin + @Py_SetProgramName := Import('Py_SetProgramName'); + @Py_IsInitialized := Import('Py_IsInitialized'); + @Py_GetProgramFullPath := Import('Py_GetProgramFullPath'); + if getProcAddress( FDLLHandle, 'Py_GetBuildInfo' ) <> nil then + @DLL_Py_GetBuildInfo := Import('Py_GetBuildInfo'); + @Py_NewInterpreter := Import('Py_NewInterpreter'); + @Py_EndInterpreter := Import('Py_EndInterpreter'); + @PyEval_AcquireLock := Import('PyEval_AcquireLock'); + @PyEval_ReleaseLock := Import('PyEval_ReleaseLock'); + @PyEval_AcquireThread := Import('PyEval_AcquireThread'); + @PyEval_ReleaseThread := Import('PyEval_ReleaseThread'); + @PyInterpreterState_New := Import('PyInterpreterState_New'); + @PyInterpreterState_Clear := Import('PyInterpreterState_Clear'); + @PyInterpreterState_Delete:= Import('PyInterpreterState_Delete'); + @PyThreadState_New := Import('PyThreadState_New'); + @PyThreadState_Clear := Import('PyThreadState_Clear'); + @PyThreadState_Delete := Import('PyThreadState_Delete'); + @PyThreadState_Get := Import('PyThreadState_Get'); + @PyThreadState_Swap := Import('PyThreadState_Swap'); + @PyErr_SetInterrupt := Import('PyErr_SetInterrupt'); + end; +end; + +procedure TPythonInterface.Py_INCREF(op: PPyObject); +begin + Inc(op^.ob_refcnt); +end; + +procedure TPythonInterface.Py_DECREF(op: PPyObject); +begin + with op^ do begin + Dec(ob_refcnt); + if ob_refcnt = 0 then begin + ob_type^.tp_dealloc(op); + end; + end; +end; + +procedure TPythonInterface.Py_XINCREF(op: PPyObject); +begin + if op <> nil then Py_INCREF(op); +end; + +procedure TPythonInterface.Py_XDECREF(op: PPyObject); +begin + if op <> nil then Py_DECREF(op); +end; + +function TPythonInterface.Py_GetPlatform: PChar; cdecl; +begin + Py_GetPlatform := 'win32'; +end; + +function TPythonInterface.Py_BuildValue( format: PChar; args: array of const): + PPyObject; {$IFNDEF FPC} assembler; {$ENDIF} cdecl; +const tenthousand:double = 10000.0; +var temp: Double; +{$IFDEF FPC} begin {$ENDIF} +asm + push ebx // save ebx, four registers needed + mov eax,[args] // gets args pointer + mov edx,[args+$4] // gets invisible argument count-1 parameter +@loop1: lea ebx,[eax+edx*8] // get argument address + cmp byte ptr [ebx+$4], vtExtended // Is Extended? + jz @IsDouble + cmp byte ptr [ebx+$4], vtCurrency // Is Currency, 64bit integer? + jnz @NoDouble +@IsCurrency: + mov ebx,[ebx] // get 64 bit integer + fild qword ptr [ebx] // put on float stack + wait + fdiv tenthousand // normalize to double float + jmp @PushDouble // Handle as double value +@IsDouble: + mov ebx,[ebx] // get extended float + fld tbyte ptr [ebx] // put on float stack +@PushDouble: + wait + fstp temp //get double from float stack + wait + lea ebx,temp // get temp + mov ecx,[ebx+$4] // push 4 high bytes of temp + push ecx +@NoDouble: + mov ecx,[ebx] // get one argument + push ecx // push 4 bytes of the argument + dec edx // go to the next argument + jns @loop1 // next argument, if any + mov eax,self // get invisible self parameter + mov edx,format // call DLL Py_Builtin function + push edx + call [eax+DLL_Py_BuildValue] + mov ebx,[ebp-$c] // get saved ebx from ebp-based offset + // (current esp could not be used!) +end; +{$IFDEF FPC} end; {$ENDIF} + +function TPythonInterface.PyObject_CallMethodWithArgs(obj: PPyObject; method, + format: PChar; args: array of const): PPyObject; + {$IFNDEF FPC} assembler; {$ENDIF} cdecl; +const tenthousand:double = 10000.0; +var temp: Double; +{$IFDEF FPC} begin {$ENDIF} +asm + push ebx // save ebx, four registers needed + mov eax,[args] // gets args pointer + mov edx,[args+$4] // gets invisible argument count-1 parameter +@loop1: lea ebx,[eax+edx*8] // get argument address + cmp byte ptr [ebx+$4], vtExtended // Is Extended? + jz @IsDouble + cmp byte ptr [ebx+$4], vtCurrency // Is Currency, 64bit integer? + jnz @NoDouble +@IsCurrency: + mov ebx,[ebx] // get 64 bit integer + fild qword ptr [ebx] // put on float stack + wait + fdiv tenthousand // normalize to double float + jmp @PushDouble // Handle as double value +@IsDouble: + mov ebx,[ebx] // get extended float + fld tbyte ptr [ebx] // put on float stack +@PushDouble: + wait + fstp temp //get double from float stack + wait + lea ebx,temp // get temp + mov ecx,[ebx+$4] // push 4 high bytes of temp + push ecx +@NoDouble: + mov ecx,[ebx] // get one argument + push ecx // push 4 bytes of the argument + dec edx // go to the next argument + jns @loop1 // next argument, if any + mov eax,self // get invisible self parameter + mov edx,format // call DLL Py_Builtin function + push edx + mov edx,method // call DLL Py_Builtin function + push edx + mov edx,obj // call DLL Py_Builtin function + push edx + call [eax+PyObject_CallMethod] + mov ebx,[ebp-$c] // get saved ebx from ebp-based offset + // (current esp could not be used!) +end; +{$IFDEF FPC} end; {$ENDIF} + +{DELPHI does the right thing here. It automatically generates + a copy of the argp on the stack} +function TPythonInterface.PyArg_Parse ( args: PPyObject; format: PChar; + argp: array of Pointer): Integer; cdecl; +begin +{$IFDEF DELPHI6_OR_HIGHER} + Result := 0; + { Do not optimize this to a "pure" assembler routine, because such + a routine does not copy the array arguments in the prologue code } + asm + lea edx, format + push [edx] + + sub edx, TYPE PChar + push [edx] + + mov eax, Self + mov eax, [eax].DLL_PyArg_Parse + call eax + + pop edx + pop edx + mov Result, eax + end; +{$ELSE} + Result := DLL_PyArg_Parse( args, format ); +{$ENDIF} +end; + +function TPythonInterface.PyArg_ParseTuple ( args: PPyObject; format: PChar; + argp: array of Pointer): Integer; cdecl; +begin +{$IFDEF DELPHI6_OR_HIGHER} + Result := 0; + { Do not optimize this to a "pure" assembler routine, because such + a routine does not copy the array arguments in the prologue code } + asm + lea edx, format + push [edx] + + sub edx, TYPE PChar + push [edx] + + mov eax, Self + mov eax, [eax].DLL_PyArg_ParseTuple + call eax + + pop edx + pop edx + mov Result, eax + end; +{$ELSE} + Result := DLL_PyArg_ParseTuple( args, format ); +{$ENDIF} +end; + +// This function is copied from compile.c because it was not +// exported in the Dll +function TPythonInterface.PyCode_Addr2Line( co: PPyCodeObject; addrq : Integer ) : Integer; cdecl; +var + size : Integer; + p : PChar; + line : Integer; + addr : Integer; + cpt : Integer; +begin + if Assigned(DLL_PyCode_Addr2Line) then + begin + Result := DLL_PyCode_Addr2Line( co, addrq ); + Exit; + end; + size := PyString_Size(co^.co_lnotab) div 2; + p := PyString_AsString(co^.co_lnotab); + line := co^.co_firstlineno; + addr := 0; + cpt := 0; + while (size-1) >= 0 do + begin + Dec(size); + Inc( addr, Ord(p[cpt]) ); + Inc(cpt); + if addr > addrq then + Break; + Inc( line, Ord(p[cpt]) ); + Inc(cpt); + end; + Result := line; +end; + +function TPythonInterface.Py_GetBuildInfo : PChar; cdecl; +begin + if Assigned(DLL_Py_GetBuildInfo) then + begin + Result := DLL_Py_GetBuildInfo; + Exit; + end; + Result := 'No build info'; +end; + +function TPythonInterface.PyImport_ExecCodeModule( const AName : String; codeobject : PPyObject) : PPyObject; +var + m, d, v, modules : PPyObject; +begin + if Assigned(DLL_PyImport_ExecCodeModule) then + begin + Result := DLL_PyImport_ExecCodeModule(PChar(AName), codeobject); + Exit; + end; + CheckPython; + m := PyImport_AddModule(PChar(AName)); + if not Assigned(m) then + begin + Result := nil; + Exit; + end; + d := PyModule_GetDict(m); + if PyDict_GetItemString(d, '__builtins__') = nil then + begin + if PyDict_SetItemString(d, '__builtins__', PyEval_GetBuiltins) <> 0 then + begin + Result := nil; + Exit; + end; + end; + // Remember the fielname as the __file__ attribute + if PyDict_SetItemString(d, '__file__', PPyCodeObject(codeobject)^.co_filename) <> 0 then + PyErr_Clear; // Not important enough to report + v := PyEval_EvalCode(PPyCodeObject(codeobject), d, d); // XXX owner ? + if not Assigned(v) then + begin + Result := nil; + Exit; + end; + Py_XDECREF(v); + modules := PyImport_GetModuleDict; + if PyDict_GetItemString(modules, PChar(AName)) = nil then + begin + PyErr_SetString(PyExc_ImportError^, PChar(Format('Loaded module %.200s not found in sys.modules', [AName]))); + Result := nil; + Exit; + end; + Py_XINCREF(m); + Result := m; +end; + +function TPythonInterface.PyString_Check( obj : PPyObject ) : Boolean; +begin + Result := PyObject_TypeCheck(obj, PyString_Type); +{$IFDEF UNICODE_SUPPORT} + if not Result then + Result := PyObject_TypeCheck(obj, PyUnicode_Type); +{$ENDIF} +end; + +function TPythonInterface.PyString_CheckExact(obj: PPyObject): Boolean; +begin + Result := Assigned( obj ) and (obj^.ob_type = PPyTypeObject(PyString_Type)); +end; + +function TPythonInterface.PyFloat_Check( obj : PPyObject ) : Boolean; +begin + Result := PyObject_TypeCheck(obj, PyFloat_Type); +end; + +function TPythonInterface.PyFloat_CheckExact(obj: PPyObject): Boolean; +begin + Result := Assigned( obj ) and (obj^.ob_type = PPyTypeObject(PyFloat_Type)); +end; + +function TPythonInterface.PyInt_Check( obj : PPyObject ) : Boolean; +begin + Result := PyObject_TypeCheck(obj, PyInt_Type); +end; + +function TPythonInterface.PyInt_CheckExact(obj: PPyObject): Boolean; +begin + Result := Assigned( obj ) and (obj^.ob_type = PPyTypeObject(PyInt_Type)); +end; + +function TPythonInterface.PyLong_Check( obj : PPyObject ) : Boolean; +begin + Result := PyObject_TypeCheck(obj, PyLong_Type); +end; + +function TPythonInterface.PyLong_CheckExact(obj: PPyObject): Boolean; +begin + Result := Assigned( obj ) and (obj^.ob_type = PPyTypeObject(PyLong_Type)); +end; + +function TPythonInterface.PyTuple_Check( obj : PPyObject ) : Boolean; +begin + Result := PyObject_TypeCheck(obj, PyTuple_Type); +end; + +function TPythonInterface.PyTuple_CheckExact(obj: PPyObject): Boolean; +begin + Result := Assigned( obj ) and (obj^.ob_type = PPyTypeObject(PyTuple_Type)); +end; + +function TPythonInterface.PyInstance_Check( obj : PPyObject ) : Boolean; +begin + Result := Assigned( obj ) and (obj^.ob_type = PPyTypeObject(PyInstance_Type)); +end; + +function TPythonInterface.PyClass_Check( obj : PPyObject ) : Boolean; +begin + Result := Assigned( obj ) and (obj^.ob_type = PPyTypeObject(PyClass_Type)); +end; + +function TPythonInterface.PyType_CheckExact( obj : PPyObject ) : Boolean; +begin + Result := Assigned( obj ) and (obj^.ob_type = PPyTypeObject(PyType_Type)); +end; + +function TPythonInterface.PyMethod_Check( obj : PPyObject ) : Boolean; +begin + Result := Assigned( obj ) and (obj^.ob_type = PPyTypeObject(PyMethod_Type)); +end; + +function TPythonInterface.PyList_Check( obj : PPyObject ) : Boolean; +begin + Result := PyObject_TypeCheck(obj, PyList_Type); +end; + +function TPythonInterface.PyList_CheckExact(obj: PPyObject): Boolean; +begin + Result := Assigned( obj ) and (obj^.ob_type = PPyTypeObject(PyList_Type)); +end; + +function TPythonInterface.PyDict_Check( obj : PPyObject ) : Boolean; +begin + Result := PyObject_TypeCheck(obj, PyDict_Type); +end; + +function TPythonInterface.PyDict_CheckExact(obj: PPyObject): Boolean; +begin + Result := Assigned( obj ) and (obj^.ob_type = PPyTypeObject(PyDict_Type)); +end; + +function TPythonInterface.PyModule_Check( obj : PPyObject ) : Boolean; +begin + Result := PyObject_TypeCheck(obj, PyModule_Type); +end; + +function TPythonInterface.PyModule_CheckExact(obj: PPyObject): Boolean; +begin + Result := Assigned( obj ) and (obj^.ob_type = PPyTypeObject(PyModule_Type)); +end; + +function TPythonInterface.PySlice_Check( obj : PPyObject ) : Boolean; +begin + Result := Assigned( obj ) and (obj^.ob_type = PPyTypeObject(PySlice_Type)); +end; + +function TPythonInterface.PyFunction_Check( obj : PPyObject ) : Boolean; +begin + Result := Assigned( obj ) and + ((obj^.ob_type = PPyTypeObject(PyCFunction_Type)) or + (obj^.ob_type = PPyTypeObject(PyFunction_Type))); +end; + +function TPythonInterface.PyIter_Check( obj : PPyObject ) : Boolean; +begin +{$IFDEF PYTHON20_OR_HIGHER} + Result := Assigned( obj ) and + (PyType_HasFeature(obj^.ob_type, Py_TPFLAGS_HAVE_ITER) and Assigned(obj^.ob_type^.tp_iternext)); +{$ELSE} + Result := False; +{$ENDIF} +end; + +{$IFDEF UNICODE_SUPPORT} +function TPythonInterface.PyUnicode_Check( obj : PPyObject ) : Boolean; +begin + Result := PyObject_TypeCheck(obj, PyUnicode_Type); +end; + +function TPythonInterface.PyUnicode_CheckExact(obj: PPyObject): Boolean; +begin + Result := Assigned( obj ) and (obj^.ob_type = PPyTypeObject(PyUnicode_Type)); +end; +{$ENDIF} + +{$IFDEF PYTHON22_OR_HIGHER} +function TPythonInterface.PyType_IS_GC(t : PPyTypeObject ) : Boolean; +begin + Result := PyType_HasFeature(t, Py_TPFLAGS_HAVE_GC); +end; + +function TPythonInterface.PyObject_IS_GC( obj : PPyObject ) : Boolean; +begin + Result := PyType_IS_GC(obj^.ob_type) and + (not Assigned(obj^.ob_type^.tp_is_gc) or (obj^.ob_type^.tp_is_gc(obj) = 1)); +end; +{$ENDIF} + +{$IFDEF PYTHON22_OR_HIGHER} +function TPythonInterface.PyWeakref_Check( obj : PPyObject ) : Boolean; +begin + Result := Assigned( obj ) and (PyWeakref_CheckRef(obj) or PyWeakref_CheckProxy(obj)); +end; + +function TPythonInterface.PyWeakref_CheckRef( obj : PPyObject ) : Boolean; +begin + Result := Assigned( obj ) and (obj^.ob_type = PPyTypeObject(_PyWeakref_RefType)); +end; + +function TPythonInterface.PyWeakref_CheckProxy( obj : PPyObject ) : Boolean; +begin + Result := Assigned( obj ) and + ( (obj^.ob_type = PPyTypeObject(_PyWeakref_ProxyType)) or + (obj^.ob_type = PPyTypeObject(_PyWeakref_CallableProxyType)) ); +end; +{$ENDIF} + +{$IFDEF PYTHON23_OR_HIGHER} +function TPythonInterface.PyBool_Check( obj : PPyObject ) : Boolean; +begin + Result := PyObject_TypeCheck(obj, PyBool_Type); +end; + +function TPythonInterface.PyBaseString_Check( obj : PPyObject ) : Boolean; +begin + Result := PyObject_TypeCheck(obj, PyBaseString_Type); +end; + +function TPythonInterface.PyEnum_Check( obj : PPyObject ) : Boolean; +begin + Result := Assigned( obj ) and (obj^.ob_type = PPyTypeObject(PyEnum_Type)); +end; +{$ENDIF} + +function TPythonInterface.PyObject_TypeCheck(obj : PPyObject; t : PPyTypeObject) : Boolean; +begin + Result := Assigned(obj) and (obj^.ob_type = t); +{$IFDEF PYTHON23_OR_HIGHER} + if not Result and Assigned(obj) and Assigned(t) then + Result := PyType_IsSubtype(obj^.ob_type, t) = 1; +{$ENDIF} +end; + +function TPythonInterface.Py_InitModule( const AName : PChar; md : PPyMethodDef) : PPyObject; +begin + CheckPython; + result := Py_InitModule4( AName, md, nil, nil, APIVersion ); +end; + +(*******************************************************) +(** **) +(** class TPythonTraceback **) +(** **) +(*******************************************************) + +function TPythonTraceback.GetItemCount : Integer; +begin + Result := FItems.Count; +end; + +function TPythonTraceback.GetItem( idx : Integer ) : TTracebackItem; +begin + Result := TTracebackItem(FItems.Items[idx]); +end; + +constructor TPythonTraceback.Create; +begin + inherited; + FLimit := 1000; + FItems := TList.Create; +end; + +destructor TPythonTraceback.Destroy; +begin + Clear; + FItems.Free; + inherited; +end; + +procedure TPythonTraceback.Clear; +var + i : Integer; +begin + for i := 0 to ItemCount - 1 do + Items[i].Free; + FItems.Clear; +end; + +{****** + * Warning ! + * This method must be called after the PyErr_Print function, + * otherwise it can't extract the traceback informations. + * + * This method is automatically called by the Exec/Eval methods of + * TPythonEngine. But if you use the Python core API, then don't + * forget to refresh the traceback yourself. Or much better, + * simply use the method CheckError wich will call PyErr_Print, + * Traceback.Refresh and RaiseError for you. +} +procedure TPythonTraceback.Refresh; +var +// tb, tb1 : PPyTraceBackObject; + tb, tb1 : PPyObject; + obj : PPyObject; + frame : PPyObject; + code : PPyObject; + depth : Integer; + limitv : PPyObject; + aLimit : Integer; + item : TTracebackItem; +begin + Clear; + with GetPythonEngine do + begin + // get the limit of the traceback + alimit := FLimit; + limitv := PySys_GetObject('tracebacklimit'); + if Assigned(limitv) and PyInt_Check(limitv) then + alimit := PyInt_AsLong(limitv); + tb := PySys_GetObject('last_traceback'); + tb1 := tb; + Py_XIncRef(tb1); + depth := 0; + // Evaluate the depth of the traceback + while Assigned(tb1) and (tb1 <> Py_None) do + begin + Inc(depth); + Py_XDecRef(tb1); + tb1 := PyObject_GetAttrString(tb1, 'tb_next'); + CheckError(False); + end; + Py_XDecRef(tb1); + // build the trace back + Py_XIncRef(tb); + while Assigned(tb) and (tb <> Py_None) do + begin + try + if depth <= alimit then + begin + item := TTracebackItem.Create; + try + obj := PyObject_GetAttrString(tb, 'tb_lineno'); + CheckError(False); + try + item.LineNo := PyObjectAsVariant(obj); + finally + Py_XDecRef(obj); + end; + frame := PyObject_GetAttrString(tb, 'tb_frame'); + CheckError(False); + try + if Assigned(frame) and (frame <> Py_None) then + begin + code := PyObject_GetAttrString(frame, 'f_code'); + CheckError(False); + try + obj := PyObject_GetAttrString(code, 'co_filename'); + CheckError(False); + try + item.Filename := PyObjectAsVariant( obj ); + finally + Py_XDecRef(obj); + end; + obj := PyObject_GetAttrString(code, 'co_name'); + CheckError(False); + try + item.Context := PyObjectAsVariant( obj ); + finally + Py_XDecRef(obj); + end; + finally + Py_XDecRef(code); + end; + end; + finally + Py_XDecRef(frame); + end; + except + item.Free; + raise; + end; + FItems.Add( item ); + end; + Dec( depth ); + finally + Py_XDecRef(tb); + end; + tb := PyObject_GetAttrString(tb, 'tb_next'); + CheckError(False); + end; + Py_XDecRef(tb); + end; +end; + + +(*******************************************************) +(** **) +(** class TPythonEngine **) +(** **) +(*******************************************************) + + +constructor TPythonEngine.Create(AOwner: TComponent); +var + i : Integer; +begin + inherited; + FLock := TCriticalSection.Create; + FInitialized := False; + FInitScript := TstringList.Create; + FClients := TList.Create; + FRedirectIO := True; + FExecModule := '__main__'; + FAutoFinalize := True; + FInitThreads := False; + FTraceback := TPythonTraceback.Create; + FUseWindowsConsole := False; + FPyFlags := []; + FDatetimeConversionMode := DEFAULT_DATETIME_CONVERSION_MODE; + if csDesigning in ComponentState then + begin + for i := 0 to AOwner.ComponentCount - 1 do + if (AOwner.Components[i] is TPythonEngine) and + (AOwner.Components[i] <> Self) then + raise Exception.Create('You can''t drop more than one TPythonEngine component'); + end; +end; + +destructor TPythonEngine.Destroy; +begin + LocalVars := nil; + GlobalVars := nil; + Destroying; + Finalize; + // Free our objects + FClients.Free; + FInitScript.Free; + FTraceback.Free; + FLock.Free; + inherited; +end; + +procedure TPythonEngine.Finalize; +var + i: integer; + canDetachClients : Boolean; +begin + // switch off redirection when the component is destroying, + // because the form or datamodule is beeing closed, and + // redirecting output may crash the application. + if FIORedirected and not (csDestroying in ComponentState) and Initialized then + begin + RedirectIO := False; + // restore the initial streams also. + ExecString('import sys'+LF+ + 'if hasattr(sys, "old_stdin"): sys.stdin=sys.old_stdin'+LF+ + 'if hasattr(sys, "old_stdout"): sys.stdout=sys.old_stdout'+LF+ + 'if hasattr(sys, "old_stderr"): sys.stderr=sys.old_stderr' ); + end; + // First finalize our clients + if Initialized then + for i := 0 to ClientCount - 1 do + with Clients[i] do + begin + if Initialized then + Finalize; + end; + // Then finalize Python, if we have to + if Initialized and FAutoFinalize then + try + FFinalizing := True; + Py_Finalize; + finally + FFinalizing := False; + end; + // Detach our clients, when engine is beeing destroyed or one of its clients. + canDetachClients := csDestroying in ComponentState; + if not canDetachClients then + for i := 0 to ClientCount - 1 do + if csDestroying in Clients[i].ComponentState then + begin + canDetachClients := True; + Break; + end; + if canDetachClients then + begin + for i := 0 to ClientCount - 1 do + Clients[i].ClearEngine; + FClients.Clear; + end; + // Free our reference + gPythonEngine := nil; + FTimeStruct := nil; + FPyDateTime_DateType := nil; + FPyDateTime_DateTimeType := nil; + FPyDateTime_DeltaType := nil; + FPyDateTime_TimeType := nil; + FPyDateTime_TZInfoType := nil; + FPyDateTime_TimeTZType := nil; + FPyDateTime_DateTimeTZType := nil; +end; + +procedure TPythonEngine.Lock; +begin + FLock.Enter; +end; + +procedure TPythonEngine.Unlock; +begin + FLock.Leave; +end; + +procedure TPythonEngine.AfterLoad; +begin + inherited; + Initialize; +end; + +procedure TPythonEngine.BeforeLoad; +begin + if UseWindowsConsole then + InitWinConsole; + inherited; +end; + +procedure TPythonEngine.DoOpenDll(const aDllName : String); +var + i : Integer; +begin + if UseLastKnownVersion then + for i:= Integer(COMPILED_FOR_PYTHON_VERSION_INDEX) to High(PYTHON_KNOWN_VERSIONS) do + begin + FDLLHandle := LoadLibrary(PChar(GetDllPath+PYTHON_KNOWN_VERSIONS[i].DllName)); + if IsHandleValid then + begin + DllName := PYTHON_KNOWN_VERSIONS[i].DllName; + APIVersion := PYTHON_KNOWN_VERSIONS[i].APIVersion; + RegVersion := PYTHON_KNOWN_VERSIONS[i].RegVersion; + Exit; + end; + if not PYTHON_KNOWN_VERSIONS[i].CanUseLatest then + Break; + end; + inherited; +end; + +procedure TPythonEngine.AssignPyFlags; + + procedure SetFlag( AFlag: PInt; AValue : Boolean ); + begin + if AValue then + AFlag^ := 1 + else + AFlag^ := 0; + end; + +begin + // define each Python flag. See file pyDebug.h + SetFlag(Py_DebugFlag, pfDebug in FPyFlags); + SetFlag(Py_VerboseFlag, pfVerbose in FPyFlags); + SetFlag(Py_InteractiveFlag, pfInteractive in FPyFlags); + SetFlag(Py_OptimizeFlag, pfOptimize in FPyFlags); + SetFlag(Py_NoSiteFlag, pfNoSite in FPyFlags); + SetFlag(Py_UseClassExceptionsFlag, pfUseClassExceptionsFlag in FPyFlags); + SetFlag(Py_FrozenFlag, pfFrozenFlag in FPyFlags); + SetFlag(Py_TabcheckFlag, pfTabcheck in FPyFlags); +{$IFDEF PYTHON20_OR_HIGHER} + SetFlag(Py_UnicodeFlag, pfUnicode in FPyFlags); +{$ENDIF} +{$IFDEF PYTHON22_OR_HIGHER} + SetFlag(Py_IgnoreEnvironmentFlag, pfIgnoreEnvironmentFlag in FPyFlags); + SetFlag(Py_DivisionWarningFlag, pfDivisionWarningFlag in FPyFlags); +{$ENDIF} +end; + +procedure TPythonEngine.Initialize; + + procedure InitSysPath; + var + _path : PPyObject; + begin + _path := PySys_GetObject('path'); + if Assigned(FOnSysPathInit) then + FOnSysPathInit(Self, _path); + end; + + function GetVal(AModule : PPyObject; AVarName : String) : PPyObject; + begin + Result := PyObject_GetAttrString(AModule, PChar(AVarName)); + if PyErr_Occurred <> nil then + PyErr_Clear + else + Py_XDecRef(Result); // keep a borrowed reference. + end; + + procedure GetTimeStructType; + var + timeModule : PPyObject; + begin + if APIVersion >= 1011 then // from Python 2.2 + begin + timeModule := PyImport_ImportModule('time'); + try + if Assigned(timeModule) then + FTimeStruct := GetVal(timeModule, 'struct_time') + else + PyErr_Clear; + finally + Py_XDecRef(timeModule); + end; + end + else + FTimeStruct := nil; + end; + + procedure GetDateTimeTypes; + var + dateTimeModule : PPyObject; + begin + if APIVersion >= 1012 then // from Python 2.3 + begin + dateTimeModule := PyImport_ImportModule('datetime'); + try + if Assigned(dateTimeModule) then + begin + FPyDateTime_DateType := GetVal(dateTimeModule, 'date'); + FPyDateTime_DateTimeType := GetVal(dateTimeModule, 'datetime'); + FPyDateTime_DeltaType := GetVal(dateTimeModule, 'timedelta'); + FPyDateTime_TimeType := GetVal(dateTimeModule, 'time'); + FPyDateTime_TZInfoType := GetVal(dateTimeModule, 'tzinfo'); + FPyDateTime_TimeTZType := GetVal(dateTimeModule, 'timetz'); + FPyDateTime_DateTimeTZType := GetVal(dateTimeModule, 'datetimetz'); + end + else + PyErr_Clear; + finally + Py_XDecRef(dateTimeModule); + end; + end + else + begin + FPyDateTime_DateType := nil; + FPyDateTime_DateTimeType := nil; + FPyDateTime_DeltaType := nil; + FPyDateTime_TimeType := nil; + FPyDateTime_TZInfoType := nil; + FPyDateTime_TimeTZType := nil; + FPyDateTime_DateTimeTZType := nil; + end; + end; + +var + i : Integer; +begin + if Assigned(gPythonEngine) then + raise Exception.Create('There is already one instance of TPythonEngine running' ); + + {$IFDEF FPC} + //this allows you to just call Initialize to create a non-IDE instance with + //Lazarus. + if(AutoLoad and not IsHandleValid) then begin + LoadDLL;//Calls initialize + exit; + end; + {$ENDIF} + + gPythonEngine := Self; + CheckRegistry; + if Assigned(Py_SetProgramName) then + begin + FProgramName := ParamStr(0); + Py_SetProgramName(PChar(FProgramName)); + end; + AssignPyFlags; + Py_Initialize; + FInitialized := True; + FIORedirected := False; + InitSysPath; + SetProgramArgs; + GetTimeStructType; + GetDateTimeTypes; + if InitThreads and Assigned(PyEval_InitThreads) then + PyEval_InitThreads; + if RedirectIO and Assigned(FIO) then + DoRedirectIO; + for i := 0 to ClientCount - 1 do + with Clients[i] do + if not Initialized then + Initialize; + if InitScript.Count > 0 then + ExecStrings( InitScript ); + if Assigned(FOnAfterInit) then + FOnAfterInit(Self); +end; + +procedure TPythonEngine.SetInitScript(Value: TStrings); +begin + FInitScript.Assign(Value); +end; + +function TPythonEngine.GetInterpreterState: PPyInterpreterState; +var + res: PPyThreadState; +begin + if Assigned(PyThreadState_Get) then begin + res:= PyThreadState_Get; + Result := res^.interp; + end else + Result := nil; +end; + +function TPythonEngine.GetThreadState: PPyThreadState; +begin + if Assigned(PyThreadState_Get) then + Result := PyThreadState_Get + else + Result := nil; +end; + +procedure TPythonEngine.SetInitThreads(Value: Boolean); +begin + if Value <> FInitThreads then + begin + if Value and Assigned(PyEval_InitThreads) then + PyEval_InitThreads; + FInitThreads := Value; + end; +end; + +function TPythonEngine.GetClientCount : Integer; +begin + Result := FClients.Count; +end; + +function TPythonEngine.GetClients( idx : Integer ) : TEngineClient; +begin + Result := TEngineClient( FClients.Items[idx] ); +end; + +procedure TPythonEngine.Notification( AComponent: TComponent; + Operation: TOperation); +var + i : Integer; +begin + inherited; + if Operation = opRemove then + begin + if AComponent = IO then + IO := nil + else + begin + for i := 0 to ClientCount - 1 do + if Clients[i] = AComponent then + begin + RemoveClient( Clients[i] ); + Break; + end; + end; + end; +end; + +procedure TPythonEngine.CheckRegistry; +{$IFDEF MSWINDOWS} +var + key : String; + path : String; +{$ENDIF} +begin +{$IFDEF MSWINDOWS} + try + with TRegistry.Create do + try + //Access := KEY_READ; // works only with Delphi5 or greater + RootKey := HKEY_LOCAL_MACHINE; + key := Format('\Software\Python\PythonCore\%s\PythonPath', [RegVersion]); + if not KeyExists( key ) then + begin + // try a current user installation + RootKey := HKEY_CURRENT_USER; + if not KeyExists( key ) then + begin + if Assigned( FOnPathInitialization ) then + begin + path := ''; + FOnPathInitialization( Self, path ); + if path <> '' then + begin + //Access := KEY_ALL_ACCESS; // works only with Delphi5 or greater + OpenKey( key, True ); + WriteString( '', path ); + CloseKey; + end; + end; + end; + end; + finally + Free; + end; + except + // under WinNT, with a user without admin rights, the access to the + // LocalMachine keys would raise an exception. + end; +{$ENDIF} +end; + +procedure TPythonEngine.SetProgramArgs; +var + buff : PChar; + argv : PPChar; + i, argc : Integer; + L : TStringList; +begin + // we build a string list of the arguments, because ParamStr returns a volatile string + // and we want to build an array of PChar, pointing to valid strings. + L := TStringList.Create; + argc := ParamCount; + GetMem( buff, sizeof(PChar)*(argc+1) ); + try + // get the strings + for i := 0 to argc do + L.Add( ParamStr(i) ); + // build the PChar array + argv := PPChar(buff); + for i := 0 to L.Count-1 do + argv^[i] := PChar(L.Strings[i]); + // set the argv list of the sys module with the application arguments + PySys_SetArgv( L.Count, argv ); + finally + FreeMem( buff ); + L.Free; + end; +end; + +procedure TPythonEngine.InitWinConsole; +begin +{$IFDEF MSWINDOWS} + FreeConsole; + AllocConsole; + SetConsoleTitle( 'Python console' ); +{$ENDIF} +end; + +procedure TPythonEngine.SetUseWindowsConsole( const Value : Boolean ); +begin + FUseWindowsConsole := Value; + if (csDesigning in ComponentState) then + RedirectIO := False; +end; + +// GlobalVars contains a dictionary object used by the Run_CommandAsObject method, if not nil. +// Warning ! SetGlobalVars increments the reference count of the dictionary object ! +procedure TPythonEngine.SetGlobalVars(const Value: PPyObject); +begin + Py_XDecRef(FGlobalVars); + if Assigned(Value) then + if PyDict_Check(Value) then + FGlobalVars := Value + else + begin + FGlobalVars := nil; + raise Exception.Create('You must set a Python dictionary in the GlobalVars property'); + end + else + FGlobalVars := nil; + Py_XIncRef(FGlobalVars); +end; + +// LocalVars contains a dictionary object used by the Run_CommandAsObject method, if not nil. +// Warning ! SetLocalVars increments the reference count of the dictionary object ! +procedure TPythonEngine.SetLocalVars(const Value: PPyObject); +begin + Py_XDecRef(FLocalVars); + if Assigned(Value) then + if PyDict_Check(Value) then + FLocalVars := Value + else + begin + FLocalVars := nil; + raise Exception.Create('You must set a Python dictionary in the LocalVars property'); + end + else + FLocalVars := nil; + Py_XIncRef(FLocalVars); +end; + +procedure TPythonEngine.SetPyFlags(const Value: TPythonFlags); +begin + if FPyFlags <> Value then + begin + if Initialized then + raise Exception.Create('You can''t modify Python flags after it has been initialized'); + FPyFlags := Value; + end; // of if +end; + +function TPythonEngine.IsType(ob: PPyObject; obt: PPyTypeObject): Boolean; +begin + result := ob^.ob_type = obt; +end; + +function TPythonEngine.GetAttrString(obj: PPyObject; AName: PChar):PChar; +var + attr: PPyObject; +begin + CheckPython; + result := nil; + attr := PyObject_GetAttrString(obj, AName); + if attr <> nil then begin + result := PyString_AsString(attr); + Py_XDECREF(attr); + end; + PyErr_Clear; +end; + +function TPythonEngine.CleanString(const s : string) : string; +var + i : Integer; +begin + result := s; + if s = '' then + Exit; + i := Pos(CR,s); + while i > 0 do + begin + Delete( result, i, 1 ); + i := Pos(CR,result); + end; + if result[length(result)] <> LF then + Insert( LF, result, length(result)+1 ); +end; + +function TPythonEngine.EvalPyFunction(pyfunc, pyargs:PPyObject): Variant; +var presult :PPyObject; +begin + CheckPython; + Result := -1; + if pyfunc = nil then exit; + try + presult := PyEval_CallObject(pyfunc,pyargs); + CheckError(False); + if presult = nil then + begin + PyErr_Print; + RaiseError; + end + else + begin + try + if presult = Py_None then + Result := 0 + else + Result := PyObjectAsVariant( presult ); + finally + Py_DECREF(presult); + end; + end; + Py_FlushLine; + except + Py_FlushLine; + if PyErr_Occurred <> nil then + CheckError(False) + else + raise; + end; +end; + +function TPythonEngine.EvalFunction(pyfunc:PPyObject; args: array of const): Variant; +var pargs: PPyObject; +begin + CheckPython; + pargs := ArrayToPyTuple(args); + try + Result := EvalPyFunction(pyfunc,pargs); + finally + Py_DECREF(pargs); + end; +end; + +function TPythonEngine.EvalFunctionNoArgs(pyfunc:PPyObject): Variant; +var pargs: PPyObject; +begin + CheckPython; + pargs := PyTuple_New(0); + try + Result := EvalPyFunction(pyfunc, pargs); + finally + Py_DECREF(pargs); + end; +end; + +function TPythonEngine.EvalStringAsStr(const command : String) : String; +begin + Result := Run_CommandAsString( command, eval_input ); +end; + +function TPythonEngine.EvalString(const command : String) : PPyObject; +begin + Result := Run_CommandAsObject( command, eval_input ); +end; + +procedure TPythonEngine.ExecString(const command : String); +begin + Py_XDecRef( Run_CommandAsObject( command, file_input ) ); +end; + +function TPythonEngine.Run_CommandAsString(const command : String; mode : Integer) : String; +var + v : PPyObject; +begin + Result := ''; + v := Run_CommandAsObject( command, mode ); + Result := PyObjectAsString( v ); + Py_XDECREF(v); +end; + +function TPythonEngine.Run_CommandAsObject(const command : String; mode : Integer) : PPyObject; +begin + Result := Run_CommandAsObjectWithDict(command, mode, nil, nil); +end; + +function TPythonEngine.Run_CommandAsObjectWithDict(const command : String; mode : Integer; locals, globals : PPyObject) : PPyObject; +var + m : PPyObject; + _locals, _globals : PPyObject; +begin + CheckPython; + Result := nil; + Traceback.Clear; + CheckError(False); + + m := GetMainModule; + if m = nil then + raise EPythonError.Create('Run_CommandAsObject: can''t create __main__'); + + if Assigned(locals) then + _locals := locals + else if Assigned(FLocalVars) then + _locals := LocalVars + else + _locals := PyModule_GetDict(m); + + if Assigned(globals) then + _globals := globals + else if Assigned(FGlobalVars) then + _globals := GlobalVars + else + _globals := PyModule_GetDict(m); + + try + Result := PyRun_String(PChar(CleanString(command)), mode, _globals, _locals); + if Result = nil then + CheckError(False); + Py_FlushLine; + except + Py_FlushLine; + if PyErr_Occurred <> nil then + CheckError(False) + else + raise; + end; +end; + +procedure TPythonEngine.ExecStrings( strings : TStrings ); +begin + Py_XDecRef( Run_CommandAsObject( CleanString( strings.Text ), file_input ) ); +end; + +function TPythonEngine.EvalStrings( strings : TStrings ) : PPyObject; +begin + Result := Run_CommandAsObject( CleanString( strings.Text ), eval_input ); +end; + +{$IFDEF DELPHI4_OR_HIGHER} + +procedure TPythonEngine.ExecString(const command : String; locals, globals : PPyObject ); +begin + Py_XDecRef( Run_CommandAsObjectWithDict( command, file_input, locals, globals ) ); +end; + +procedure TPythonEngine.ExecStrings( strings : TStrings; locals, globals : PPyObject ); +begin + Py_XDecRef( Run_CommandAsObjectWithDict( CleanString( strings.Text ), file_input, locals, globals ) ); +end; + +function TPythonEngine.EvalString( const command : String; locals, globals : PPyObject ) : PPyObject; +begin + Result := Run_CommandAsObjectWithDict( command, eval_input, locals, globals ); +end; + +function TPythonEngine.EvalStrings( strings : TStrings; locals, globals : PPyObject ) : PPyObject; +begin + Result := Run_CommandAsObjectWithDict( CleanString( strings.Text ), eval_input, locals, globals ); +end; + +{$ENDIF} + +function TPythonEngine.EvalStringsAsStr( strings : TStrings ) : String; +begin + Result := Run_CommandAsString( CleanString( strings.Text ), eval_input ); +end; + +function TPythonEngine.CheckEvalSyntax( const str : String ) : Boolean; +begin + result := CheckSyntax( str, eval_input ); +end; + +function TPythonEngine.CheckExecSyntax( const str : String ) : Boolean; +begin + result := CheckSyntax( str, file_input ); +end; + +function TPythonEngine.CheckSyntax( const str : String; mode : Integer ) : Boolean; +var + n : PNode; +begin + n := PyParser_SimpleParseString( PChar(str), mode ); + result := Assigned(n); + if Assigned( n ) then + PyNode_Free(n); +end; + +procedure TPythonEngine.RaiseError; + + function Define( E : EPythonError; const sType, sValue : String ) : EPythonError; + begin + E.EName := sType; + E.EValue := sValue; + if sValue <> '' then + E.Message := Format('%s: %s',[sType,sValue]) + else + E.Message := sType; + Result := E; + end; + + function DefineSyntaxError( E : EPySyntaxError; const sType, sValue : String; err_type, err_value : PPyObject ) : EPySyntaxError; + var + s_value : String; + s_line : String; + s_filename : String; + i_line_number : Integer; + i_offset : Integer; + tmp : PPyObject; + begin + Result := E; + Result.EName := sType; + Result.EValue := sValue; + s_value := ''; + s_line := ''; + s_filename := ''; + i_line_number := 0; + i_offset := 0; + // Sometimes there's a tuple instead of instance... + if PyTuple_Check( err_value ) and (PyTuple_Size( err_value) >= 2) then + begin + s_value := PyString_AsString(PyTuple_GetItem( err_value, 0)); + err_value := PyTuple_GetItem( err_value, 1); + if PyTuple_Check( err_value ) and (PyTuple_Size( err_value) >= 4) then + begin + i_line_number := PyInt_AsLong(PyTuple_GetItem( err_value, 1)); + i_offset := PyInt_AsLong(PyTuple_GetItem( err_value, 2)); + s_line := Trim(PyString_AsString(PyTuple_GetItem( err_value, 3))); + end; + end else + // Is it an instance of the SyntaxError class ? + if (PyInstance_Check( err_value ) and (PyClass_IsSubclass( PPyObject(PPyInstanceObject(err_value)^.in_class), err_type ) <> 0)) or + ((PyType_IsSubtype(PPyTypeObject(err_type), PPyTypeObject(PyExc_SyntaxError^)) = 1) and IsType(err_value, PPyTypeObject(err_type))) then + begin + // Get the filename + tmp := PyObject_GetAttrString(err_value, 'filename'); + if tmp <> nil then begin + if PyString_Check(tmp) then + s_filename := PyString_AsString(tmp) + else if tmp = Py_None then + s_filename := '???'; + Py_XDECREF(tmp); + end; + // Get the text containing the error, cut of carriage return + tmp := PyObject_GetAttrString(err_value, 'text'); + if Assigned(tmp) and PyString_Check(tmp) then + s_line := Trim(PyString_AsString(tmp)); + Py_XDECREF(tmp); + // Get the offset where the error should appear + tmp := PyObject_GetAttrString(err_value, 'offset' ); + if Assigned(tmp) and PyInt_Check(tmp) then + i_offset := PyInt_AsLong(tmp); + Py_XDECREF(tmp); + // Get the line number of the error + tmp := PyObject_GetAttrString(err_value, 'lineno' ); + if Assigned(tmp) and PyInt_Check(tmp) then + i_line_number := PyInt_AsLong(tmp); + Py_XDECREF(tmp); + // Get the message of the error + tmp := PyObject_GetAttrString(err_value, 'msg' ); + if Assigned(tmp) and PyString_Check(tmp) then + s_value := PyString_AsString(tmp); + Py_XDECREF(tmp); + end; + // If all is ok + if s_value <> '' then + begin + with Result do + begin + Message := Format('%s: %s (line %d, offset %d): ''%s''', [sType,s_value,i_line_number, i_offset,s_line]); + EName := sType; + EValue := s_value; + EFileName := s_filename; + ELineNumber := i_line_number; + EOffset := i_offset; + ELineStr := s_line; + end; + end + else + Result.Message := sType; + end; + + function GetTypeAsString( obj : PPyObject ) : String; + begin + if PyClass_Check( obj ) then + with PPyClassObject(obj)^ do + Result := StrPas( PyString_AsString(cl_name) ) + else if PyType_CheckExact( obj ) then + Result := PPyTypeObject(obj).tp_name + else + Result := PyObjectAsString(obj); + end; + +var + err_type, err_value : PPyObject; + s_type : String; + s_value : String; +begin + s_value := ''; + + if PyErr_Occurred <> nil then + PyErr_Print; + err_type := PySys_GetObject('last_type'); + err_value := PySys_GetObject('last_value'); + if Assigned(err_type) then + begin + s_type := GetTypeAsString(err_type); + s_value := PyObjectAsString(err_value); + + if (PyErr_GivenExceptionMatches(err_type, PyExc_SystemExit^) <> 0) then + raise Define( EPySystemExit.Create(''), s_type, s_value ) +{$IFDEF PYTHON22_OR_HIGHER} + else if (PyErr_GivenExceptionMatches(err_type, PyExc_StopIteration^) <> 0) then + raise Define( EPyStopIteration.Create(''), s_type, s_value ) +{$ENDIF} + else if (PyErr_GivenExceptionMatches(err_type, PyExc_KeyboardInterrupt^) <> 0) then + raise Define( EPyKeyboardInterrupt.Create(''), s_type, s_value ) + else if (PyErr_GivenExceptionMatches(err_type, PyExc_ImportError^) <> 0) then + raise Define( EPyImportError.Create(''), s_type, s_value ) +{$IFDEF PYTHON20_OR_HIGHER} + {$IFDEF MSWINDOWS} + else if (PyErr_GivenExceptionMatches(err_type, PyExc_WindowsError^) <> 0) then + raise Define( EPyWindowsError.Create(''), s_type, s_value ) + {$ENDIF} +{$ENDIF} + else if (PyErr_GivenExceptionMatches(err_type, PyExc_IOError^) <> 0) then + raise Define( EPyIOError.Create(''), s_type, s_value ) +{$IFDEF PYTHON20_OR_HIGHER} + else if (PyErr_GivenExceptionMatches(err_type, PyExc_OSError^) <> 0) then + raise Define( EPyOSError.Create(''), s_type, s_value ) + else if (PyErr_GivenExceptionMatches(err_type, PyExc_EnvironmentError^) <> 0) then + raise Define( EPyEnvironmentError.Create(''), s_type, s_value ) +{$ENDIF} + else if (PyErr_GivenExceptionMatches(err_type, PyExc_EOFError^) <> 0) then + raise Define( EPyEOFError.Create(''), s_type, s_value ) +{$IFDEF PYTHON20_OR_HIGHER} + else if (PyErr_GivenExceptionMatches(err_type, PyExc_NotImplementedError^) <> 0) then + raise Define( EPyNotImplementedError.Create(''), s_type, s_value ) +{$ENDIF} + else if (PyErr_GivenExceptionMatches(err_type, PyExc_RuntimeError^) <> 0) then + raise Define( EPyRuntimeError.Create(''), s_type, s_value ) +{$IFDEF PYTHON20_OR_HIGHER} + else if (PyErr_GivenExceptionMatches(err_type, PyExc_UnboundLocalError^) <> 0) then + raise Define( EPyUnboundLocalError.Create(''), s_type, s_value ) +{$ENDIF} + else if (PyErr_GivenExceptionMatches(err_type, PyExc_NameError^) <> 0) then + raise Define( EPyNameError.Create(''), s_type, s_value ) + else if (PyErr_GivenExceptionMatches(err_type, PyExc_AttributeError^) <> 0) then + raise Define( EPyAttributeError.Create(''), s_type, s_value ) +{$IFDEF PYTHON20_OR_HIGHER} + else if (PyErr_GivenExceptionMatches(err_type, PyExc_TabError^) <> 0) then + raise DefineSyntaxError( EPyTabError.Create(''), s_type, s_value, err_type, err_value ) + else if (PyErr_GivenExceptionMatches(err_type, PyExc_IndentationError^) <> 0) then + raise DefineSyntaxError( EPyIndentationError.Create(''), s_type, s_value, err_type, err_value ) +{$ENDIF} + else if (PyErr_GivenExceptionMatches(err_type, PyExc_SyntaxError^) <> 0) then + raise DefineSyntaxError( EPySyntaxError.Create(''), s_type, s_value, err_type, err_value ) + else if (PyErr_GivenExceptionMatches(err_type, PyExc_TypeError^) <> 0) then + raise Define( EPyTypeError.Create(''), s_type, s_value ) +{$IFDEF PYTHON20_OR_HIGHER} + else if (PyErr_GivenExceptionMatches(err_type, PyExc_AssertionError^) <> 0) then + raise Define( EPyAssertionError.Create(''), s_type, s_value ) +{$ENDIF} + else if (PyErr_GivenExceptionMatches(err_type, PyExc_IndexError^) <> 0) then + raise Define( EPyIndexError.Create(''), s_type, s_value ) + else if (PyErr_GivenExceptionMatches(err_type, PyExc_KeyError^) <> 0) then + raise Define( EPyKeyError.Create(''), s_type, s_value ) + else if (PyErr_GivenExceptionMatches(err_type, PyExc_LookupError^) <> 0) then + raise Define( EPyLookupError.Create(''), s_type, s_value ) + else if (PyErr_GivenExceptionMatches(err_type, PyExc_OverflowError^) <> 0) then + raise Define( EPyOverflowError.Create(''), s_type, s_value ) + else if (PyErr_GivenExceptionMatches(err_type, PyExc_ZeroDivisionError^) <> 0) then + raise Define( EPyZeroDivisionError.Create(''), s_type, s_value ) + else if (PyErr_GivenExceptionMatches(err_type, PyExc_FloatingPointError^) <> 0) then + raise Define( EPyFloatingPointError.Create(''), s_type, s_value ) + else if (PyErr_GivenExceptionMatches(err_type, PyExc_ArithmeticError^) <> 0) then + raise Define( EPyArithmeticError.Create(''), s_type, s_value ) +{$IFDEF PYTHON23_OR_HIGHER} + else if (PyErr_GivenExceptionMatches(err_type, PyExc_UnicodeEncodeError^) <> 0) then + raise Define( UnicodeEncodeError.Create(''), s_type, s_value ) + else if (PyErr_GivenExceptionMatches(err_type, PyExc_UnicodeDecodeError^) <> 0) then + raise Define( UnicodeDecodeError.Create(''), s_type, s_value ) + else if (PyErr_GivenExceptionMatches(err_type, PyExc_UnicodeTranslateError^) <> 0) then + raise Define( UnicodeTranslateError.Create(''), s_type, s_value ) +{$ENDIF} +{$IFDEF PYTHON20_OR_HIGHER} + else if (PyErr_GivenExceptionMatches(err_type, PyExc_UnicodeError^) <> 0) then + raise Define( EPyUnicodeError.Create(''), s_type, s_value ) +{$ENDIF} + else if (PyErr_GivenExceptionMatches(err_type, PyExc_ValueError^) <> 0) then + raise Define( EPyValueError.Create(''), s_type, s_value ) +{$IFDEF PYTHON22_OR_HIGHER} + else if (PyErr_GivenExceptionMatches(err_type, PyExc_ReferenceError^) <> 0) then + raise Define( EPyReferenceError.Create(''), s_type, s_value ) +{$ENDIF} + else if (PyErr_GivenExceptionMatches(err_type, PyExc_SystemError^) <> 0) then + raise Define( EPySystemError.Create(''), s_type, s_value ) + else if (PyErr_GivenExceptionMatches(err_type, PyExc_MemoryError^) <> 0) then + raise Define( EPyMemoryError.Create(''), s_type, s_value ) + else if (PyErr_GivenExceptionMatches(err_type, PyExc_StandardError^) <> 0) then + raise Define( EPyStandardError.Create(''), s_type, s_value ) +{$IFDEF PYTHON21_OR_HIGHER} + else if (PyErr_GivenExceptionMatches(err_type, PyExc_UserWarning^) <> 0) then + raise Define( EPyUserWarning.Create(''), s_type, s_value ) + else if (PyErr_GivenExceptionMatches(err_type, PyExc_DeprecationWarning^) <> 0) then + raise Define( EPyDeprecationWarning.Create(''), s_type, s_value ) + else if (PyErr_GivenExceptionMatches(err_type, PyExc_SyntaxWarning^) <> 0) then + raise Define( EPySyntaxWarning.Create(''), s_type, s_value ) + else if (PyErr_GivenExceptionMatches(err_type, PyExc_RuntimeWarning^) <> 0) then + raise Define( EPyRuntimeWarning.Create(''), s_type, s_value ) +{$ENDIF} +{$IFDEF PYTHON23_OR_HIGHER} + else if (PyErr_GivenExceptionMatches(err_type, PyExc_FutureWarning^) <> 0) then + raise Define( FutureWarning.Create(''), s_type, s_value ) + else if (PyErr_GivenExceptionMatches(err_type, PyExc_PendingDeprecationWarning^) <> 0) then + raise Define( PendingDeprecationWarning.Create(''), s_type, s_value ) +{$ENDIF} +{$IFDEF PYTHON21_OR_HIGHER} + else if (PyErr_GivenExceptionMatches(err_type, PyExc_Warning^) <> 0) then + raise Define( EPyWarning.Create(''), s_type, s_value ) +{$ENDIF} + else if (PyErr_GivenExceptionMatches(err_type, PyExc_Exception^) <> 0) then + raise Define( EPyException.Create(''), s_type, s_value ) + else // Else if no known exception was detected, + // then build an ExecError exception + raise Define( EPyExecError.Create(''), s_type, s_value ); + end + else + raise EPythonError.Create('RaiseError: could''nt fetch last exception'); +end; + +function TPythonEngine.PyObjectAsString( obj : PPyObject ) : String; +var + s : PPyObject; + i : Integer; + tmp : PChar; + w : WideString; +begin + CheckPython; + Result := ''; + if not Assigned( obj ) then + Exit; + +{$IFDEF UNICODE_SUPPORT} + if PyUnicode_Check(obj) then + begin + w := PyUnicode_AsWideString(obj); + Result := w; + Exit; + end; +{$ENDIF} + s := PyObject_Str( obj ); + if Assigned(s) and PyString_Check(s) then + begin + tmp := PyString_AsString(s); + SetLength( Result, PyString_Size(s)+1 ); + Result := ''; + for i := 0 to PyString_Size(s) - 1 do + Insert( tmp[i], Result, i+1 ); + end; + Py_XDECREF(s); +end; + +procedure TPythonEngine.DoRedirectIO; +const + code = 'import sys'+LF+ + 'class DebugOutput:'+LF+ + ' pyio = __import__("pyio")'+LF+ + ' softspace=0'+LF+ + ' def write(self,message):'+LF+ + ' self.pyio.write(message)'+LF+ + ' def readline(self, size=None):'+LF+ + ' return self.pyio.read(size)'+LF+ + ' def flush(self):' + LF + + ' pass' + LF + + 'sys.old_stdin=sys.stdin'+LF+ + 'sys.old_stdout=sys.stdout'+LF+ + 'sys.old_stderr=sys.stderr'+LF+ + 'sys.stdin=sys.stderr=sys.stdout=DebugOutput()'+LF+#0; +begin + if csDesigning in ComponentState then + Exit; + CheckPython; + if not Assigned(FIOPythonModule) then + begin + // create a new module called pyio + FIOPythonModule := TPythonModule.Create( Self ); + with FIOPythonModule as TPythonModule do + begin + Engine := Self; + ModuleName := 'pyio'; + AddMethod( 'write', pyio_write, 'write(String) -> None' ); + AddMethod( 'read', pyio_read, 'read() -> String' ); + AddMethod( 'SetDelayWrites', pyio_SetDelayWrites, 'SetDelayWrites(Boolean) -> None' ); + AddMethod( 'SetMaxLines', pyio_SetMaxLines, 'SetMaxLines(Integer) -> None' ); + AddMethod( 'GetTypesStats', pyio_GetTypesStats, 'GetTypesStats( [type name] ) -> a list of tuple (TypeName, InstanceCount, CreateHits, DeleteHits)' ); + end; + end; + with FIOPythonModule as TPythonModule do + if not Initialized then + Initialize; + // execute the code + ExecString(code); + FIORedirected := True; +end; + +procedure TPythonEngine.AddClient( client : TEngineClient ); +begin + FClients.Add( client ); +end; + +procedure TPythonEngine.RemoveClient( client : TEngineClient ); +begin + // We finalize the PythonEngine, as soon as a client should + // be freed, because the destroy order of the components + // is not predictable and may cause some memory crashes ! + if (csDesigning in ComponentState) then + FClients.Remove( client ) + else if Initialized or (ClientCount > 0) then + Finalize; +end; + +function TPythonEngine.FindClient( const aName : String ) : TEngineClient; +var + i : Integer; +begin + Result := nil; + for i := 0 to ClientCount - 1 do + with TPythonType( Clients[i] ) do + if Name = aName then + begin + Result := Clients[i]; + Break; + end; +end; + +function TPythonEngine.TypeByName( const aTypeName : String ) : PPyTypeObject; +var + i : Integer; +begin + for i := 0 to ClientCount - 1 do + if Clients[i] is TPythonType then + with TPythonType( Clients[i] ) do + if TypeName = aTypeName then + begin + Result := TheTypePtr; + Exit; + end; + raise Exception.CreateFmt('Could not find type: %s', [aTypeName]); +end; + +function TPythonEngine.ModuleByName( const aModuleName : String ) : PPyObject; +var + i : Integer; +begin + for i := 0 to ClientCount - 1 do + if Clients[i] is TPythonModule then + with TPythonModule( Clients[i] ) do + if ModuleName = aModuleName then + begin + Result := Module; + Exit; + end; + raise Exception.CreateFmt('Could not find module: %s', [aModuleName]); +end; + +function TPythonEngine.MethodsByName( const aMethodsContainer: String ) : PPyMethodDef; +var + i : Integer; +begin + for i := 0 to ClientCount - 1 do + if Clients[i] is TMethodsContainer then + with TMethodsContainer( Clients[i] ) do + if Name = aMethodsContainer then + begin + Result := MethodsData; + Exit; + end; + raise Exception.CreateFmt('Could not find component: %s', [aMethodsContainer]); +end; + +function TPythonEngine.VariantAsPyObject( const V : Variant ) : PPyObject; + + function ArrayVarDim1 : PPyObject; + var + i, cpt : Integer; + begin + Result := PyList_New( VarArrayHighBound( V, 1 ) - VarArrayLowBound( V, 1 ) + 1 ); + cpt := 0; + for i := VarArrayLowBound( V, 1 ) to VarArrayHighBound( V, 1 ) do + begin + PyList_SetItem( Result, cpt, VariantAsPyObject(V[i]) ); + Inc(cpt); + end; + end; + + function ArrayVarDim2 : PPyObject; + var + i, j, cpt, cpt2 : Integer; + L : PPyObject; + begin + Result := PyList_New( VarArrayHighBound( V, 1 ) - VarArrayLowBound( V, 1 ) + 1 ); + cpt := 0; + for i := VarArrayLowBound( V, 1 ) to VarArrayHighBound( V, 1 ) do + begin + L := PyList_New( VarArrayHighBound( V, 2 ) - VarArrayLowBound( V, 2 ) + 1 ); + PyList_SetItem( Result, cpt, L ); + cpt2 := 0; + for j := VarArrayLowBound( V, 2 ) to VarArrayHighBound( V, 2 ) do + begin + PyList_SetItem( L, cpt2, VariantAsPyObject(V[i, j]) ); + Inc(cpt2); + end; + Inc(cpt); + end; + end; + + function ArrayVarDim3 : PPyObject; + var + i, j, k, cpt, cpt2, cpt3 : Integer; + L, L2 : PPyObject; + begin + Result := PyList_New( VarArrayHighBound( V, 1 ) - VarArrayLowBound( V, 1 ) + 1 ); + cpt := 0; + for i := VarArrayLowBound( V, 1 ) to VarArrayHighBound( V, 1 ) do + begin + L := PyList_New( VarArrayHighBound( V, 2 ) - VarArrayLowBound( V, 2 ) + 1 ); + PyList_SetItem( Result, cpt, L ); + cpt2 := 0; + for j := VarArrayLowBound( V, 2 ) to VarArrayHighBound( V, 2 ) do + begin + L2 := PyList_New( VarArrayHighBound( V, 3 ) - VarArrayLowBound( V, 3 ) + 1 ); + PyList_SetItem( Result, cpt2, L ); + cpt3 := 0; + for k := VarArrayLowBound( V, 3 ) to VarArrayHighBound( V, 3 ) do + begin + PyList_SetItem( L2, cpt3, VariantAsPyObject(V[i, j, k]) ); + Inc(cpt3); + end; + Inc(cpt2); + end; + Inc(cpt); + end; + end; + +const + GUID_NULL: TGUID = '{00000000-0000-0000-0000-000000000000}'; // copied from ActiveX.pas +var + s : String; + y, m, d, h, mi, sec, ms, jd, wd : WORD; + dt : TDateTime; + dl : Integer; + myInt : Integer; + wStr : WideString; + Disp : IDispatch; + DispID : Integer; + args : PPyObject; +begin + Disp := nil; + case VarType(V) and VarTypeMask of + varBoolean: begin + if V = true then + Result := PPyObject(Py_True) + else + Result := PPyObject(Py_False); + Py_XIncRef(Result); + end; + varSmallint, + varByte, +{$IFDEF DELPHI6_OR_HIGHER} + varShortInt, + varWord, + varLongWord, +{$ENDIF} + varInteger: Result := PyInt_FromLong( V ); +{$IFDEF DELPHI6_OR_HIGHER} + varInt64: Result := PyLong_FromLongLong( V ); +{$ENDIF} + varSingle, + varDouble, + varCurrency: Result := PyFloat_FromDouble( V ); + varDate: + begin + dt := V; + DecodeDate( dt, y, m, d ); + DecodeTime( dt, h, mi, sec, ms ); + if (DatetimeConversionMode = dcmToTuple) then + begin + wd := (DayOfWeek( dt ) + 7 - 2) mod 7; // In Python, Monday is the first day (=0) + jd := Round(EncodeDate(y,m,d)-EncodeDate(y,1,1))+1; // This shoud be the Julian day, the day in a year (0-366) + dl := -1; // This is daylight save... ?¿?¿? I don't know what it is... + Result := ArrayToPyTuple( [y, m, d, h, mi, sec, wd, jd, dl] ); + end + else if (DatetimeConversionMode = dcmToDatetime) then + begin + if not Assigned(FPyDateTime_DateTimeType) then + raise EPythonError.Create('dcmToDatetime DatetimeConversionMode cannot be used with this version of python. Missing module datetime'); + args := ArrayToPyTuple([y, m, d, h, mi, sec, ms*1000]); + try + Result := PyEval_CallObject(FPyDateTime_DateTimeType, args); + CheckError(False); + finally + Py_DecRef(args); + end; + end + else + raise EPythonError.Create('Invalid DatetimeConversionMode'); + end; + varOleStr: + begin + if (TVarData(V).VOleStr = nil) or (TVarData(V).VOleStr^ = #0) then + wStr := '' + else + wStr := V; + {$IFDEF PREFER_UNICODE} + Result := PyUnicode_FromWideChar( PWideChar(wStr), Length(wStr) ); + {$ELSE} + s := wStr; + Result := PyString_FromString( PChar(s) ); + {$ENDIF} + end; + varString: + begin + s := V; + Result := PyString_FromString( PChar(s) ); + end; + else + if VarType(V) and varArray <> 0 then + begin + case VarArrayDimCount(V) of + 1: Result := ArrayVarDim1; + 2: Result := ArrayVarDim2; + 3: Result := ArrayVarDim3; + else + raise Exception.Create('Can''t convert a variant array of more than 3 dimensions to a Python sequence'); + end; + end + else if VarIsNull(V) or VarIsEmpty(V) then + begin + Result := ReturnNone; + end + else + try +{$IFDEF DELPHI4_OR_HIGHER} + Disp := V; +{$ELSE} + Disp := IUnknown(V) as IDispatch; + +{$ENDIF} + wStr := '__asPPyObject__'; + // detect if the variant supports this special property + if Disp.GetIDsOfNames(GUID_NULL, @wStr, 1, 0, @DispID) = S_OK then + begin + {$IFDEF FPC} {./Uncertain} + myInt := Integer(V); //Returns the address to PPyObject as integer. (See impl. in PythonAtom.pas) + {$ELSE} + myInt := V.__asPPyObject__; //Returns the address to PPyObject as integer. (See impl. in PythonAtom.pas) + {$ENDIF} + Result := PPyObject(myInt); + Py_XIncRef(Result); + end + else //If variant don't implement __asPPyObject__, then we have to return nothing. + Result := ReturnNone; + except + // if something went wrong, just return none! + Result := ReturnNone; + end; // of try + end; // of case +end; + +function TPythonEngine.PyObjectAsVariant( obj : PPyObject ) : Variant; + + function ExtractDate( var date : Variant ) : Boolean; + + function GetStructMember( obj : PPyObject; const AMember : String ) : Word; + var + member : PPyObject; + begin + member := PyObject_GetAttrString( obj, PChar(AMember) ); + CheckError(False); + if PyInt_Check(member) then + Result := PyInt_AsLong(member) + else + raise EPythonError.CreateFmt('Unexpected type found in member %s of a time_struct object', [AMember]); + Py_XDecRef(member); + end; + + var + i, wd, jd, dl : Integer; + dt : TDateTime; + y, m, d, h, mi, sec, msec : WORD; + delta : PPyDateTime_Delta; + begin + Result := False; + if PyTimeStruct_Check( obj ) then + begin + y := GetStructMember( obj, 'tm_year' ); + m := GetStructMember( obj, 'tm_mon' ); + d := GetStructMember( obj, 'tm_mday' ); + h := GetStructMember( obj, 'tm_hour' ); + mi := GetStructMember( obj, 'tm_min' ); + sec := GetStructMember( obj, 'tm_sec' ); + //wd := GetStructMember( obj, 'tm_wday' ); + //jd := GetStructMember( obj, 'tm_yday' ); + //dl := GetStructMember( obj, 'tm_isdst' ); + dt := EncodeDate( y, m, d ) + EncodeTime( h, mi, sec, 0 ); + Date := dt; + Result := True; + end + else if PyDateTime_Check( obj ) then + begin + y := PyDateTime_GET_YEAR(obj); + m := PyDateTime_GET_MONTH(obj); + d := PyDateTime_GET_DAY(obj); + h := PyDateTime_DATE_GET_HOUR(obj); + mi := PyDateTime_DATE_GET_MINUTE(obj); + sec := PyDateTime_DATE_GET_SECOND(obj); + msec:= PyDateTime_DATE_GET_MICROSECOND(obj) div 1000; + dt := EncodeDate( y, m, d ) + EncodeTime( h, mi, sec, msec ); + Date := dt; + Result := True; + end + else if PyDate_Check( obj ) then + begin + y := PyDateTime_GET_YEAR(obj); + m := PyDateTime_GET_MONTH(obj); + d := PyDateTime_GET_DAY(obj); + dt := EncodeDate( y, m, d ); + Date := dt; + Result := True; + end + else if PyTime_Check( obj ) then + begin + h := PyDateTime_TIME_GET_HOUR(obj); + mi := PyDateTime_TIME_GET_MINUTE(obj); + sec := PyDateTime_TIME_GET_SECOND(obj); + msec:= PyDateTime_TIME_GET_MICROSECOND(obj) div 1000; + dt := EncodeTime( h, mi, sec, msec ); + Date := dt; + Result := True; + end + else if PyDelta_Check( obj ) then + begin + delta := PPyDateTime_Delta(obj); + dt := delta^.days + (delta^.seconds / (24*60*60)) + ((delta^.microseconds div 1000) / (24*60*60*1000)); + Date := dt; + Result := True; + end + else if PyTuple_Check( obj ) and (PyTuple_Size(obj) = 9) then + begin + for i := 0 to 8 do + if not PyInt_Check(PyTuple_GetItem(obj, i)) then + Exit; + y := PyInt_AsLong( PyTuple_GetItem(obj, 0) ); + m := PyInt_AsLong( PyTuple_GetItem(obj, 1) ); + d := PyInt_AsLong( PyTuple_GetItem(obj, 2) ); + h := PyInt_AsLong( PyTuple_GetItem(obj, 3) ); + mi := PyInt_AsLong( PyTuple_GetItem(obj, 4) ); + sec := PyInt_AsLong( PyTuple_GetItem(obj, 5) ); + wd := PyInt_AsLong( PyTuple_GetItem(obj, 6) ); + jd := PyInt_AsLong( PyTuple_GetItem(obj, 7) ); + dl := PyInt_AsLong( PyTuple_GetItem(obj, 8) ); + if not (m in [1..12]) or + not (d in [1..31]) or + not (h in [0..23]) or + not (mi in [0..59]) or + not (sec in [0..59]) or + not (wd in [0..6]) or + not ((jd>=0) and (jd<=366)) or + not ((dl>=-1) and (dl<=1)) then + Exit; + try + dt := EncodeDate( y, m, d ); + dt := dt + EncodeTime( h, mi, sec, 0 ); + Date := dt; + Result := True; + except + end; + end; + end; + + function GetSequenceItem( sequence : PPyObject; idx : Integer ) : Variant; + var + val : PPyObject; + begin + val := PySequence_GetItem( sequence, idx ); + try + Result := PyObjectAsVariant( val ); + finally + Py_XDecRef( val ); + end; + end; + +var + i, seq_length : Integer; +begin + if PyFloat_Check(obj) then + Result := PyFloat_AsDouble(obj) +{$IFDEF PYTHON23_OR_HIGHER} + else if PyBool_Check(obj) then // we must check Bool before Int, as Boolean type inherits from Int. + Result := PyObject_IsTrue(obj) = 1 +{$ENDIF} + else if PyInt_Check(obj) then + Result := PyInt_AsLong(obj) +{$IFDEF DELPHI6_OR_HIGHER} + else if PyLong_Check(obj) then + Result := PyLong_AsLongLong(obj) +{$ENDIF} +{$IFDEF UNICODE_SUPPORT} + else if PyUnicode_Check(obj) then + Result := PyUnicode_AsWideString(obj) +{$ENDIF} + else if PyString_Check(obj) then + Result := PyObjectAsString(obj) + else if ExtractDate( Result ) then + begin + // Nothing to do + end + else if PySequence_Check( obj ) = 1 then + begin + seq_length := PySequence_Length( obj ); + // if we have at least one object in the sequence, + if seq_length > 0 then + // we try to get the first one, simply to test if the sequence API + // is really implemented. + Py_XDecRef( PySequence_GetItem( obj, 0 ) ); + // check if the Python object did really implement the sequence API + if PyErr_Occurred = nil then + begin + // Convert a Python sequence into an array of Variant + Result := VarArrayCreate( [0, seq_length-1], varVariant ); + for i := 0 to PySequence_Length( obj )-1 do + Result[i] := GetSequenceItem( obj, i ); + end + else // the object didn't implement the sequence API, so we return Null + begin + PyErr_Clear; + Result := Null; + end; + end + else + Result := Null; +end; + +function TPythonEngine.VarRecAsPyObject( v : TVarRec ) : PPyObject; +var + buff : array [0..256] of Char; +begin + case v.VType of + vtInteger: Result := PyInt_FromLong( v.VInteger ); + vtBoolean: Result := PyInt_FromLong( Integer(v.VBoolean) ); + vtChar: Result := PyString_FromString( PChar(String(v.VChar)) ); + vtExtended: Result := PyFloat_FromDouble( v.VExtended^ ); + vtString: + begin + if Assigned(v.VString) then + Result := PyString_FromString( StrPCopy( buff, v.VString^) ) + else + Result := PyString_FromString( '' ); + end; + vtPChar: Result := PyString_FromString( v.VPChar ); + vtAnsiString: + begin + if Assigned(v.VAnsiString) then + Result := PyString_FromString( v.VAnsiString ) + else + Result := PyString_FromString(''); + end; + vtCurrency: Result := PyFloat_FromDouble( v.VCurrency^ ); + vtVariant: Result := VariantAsPyObject( v.VVariant^ ); + vtPointer: Result := v.VPointer; +{$IFDEF DELPHI6_OR_HIGHER} + vtInt64: Result := PyLong_FromLongLong( v.VInt64^ ); +{$ENDIF} +{$IFDEF UNICODE_SUPPORT} + vtWideChar: Result := PyUnicode_FromWideString( v.VWideChar ); + vtPWideChar: + begin + if Assigned(v.VPWideChar) then + Result := PyUnicode_FromWideString( WideString(v.VPWideChar) ) + else + Result := PyUnicode_FromWideString( '' ); + end; + vtWideString: + begin + if Assigned(v.VWideString) then + Result := PyUnicode_FromWideString( WideString(v.VWideString) ) + else + Result := PyUnicode_FromWideString( '' ); + end; +{$ENDIF} + else + Raise Exception.Create('Argument type not allowed'); + end; +end; + +// This function prevents Python from deleting the objects contained +// when the container will be freed, because we increment each +// object's refcount. +function TPythonEngine.MakePyTuple( const objects : array of PPyObject ) : PPyObject; +var + i : Integer; +begin + Result := PyTuple_New( High(objects)+1 ); + if not Assigned(Result) then + raise EPythonError.Create('Could not create a new tuple object'); + for i := Low(objects) to High(objects) do + begin + Py_XINCREF( objects[i] ); + PyTuple_SetItem( Result, i, objects[i] ); + end; +end; + +// This function prevents Python from deleting the objects contained +// when the container will be freed, because we increment each +// object's refcount. +function TPythonEngine.MakePyList( const objects : array of PPyObject ) : PPyObject; +var + i : Integer; +begin + Result := PyList_New( High(objects)+1 ); + if not Assigned(Result) then + raise EPythonError.Create('Could not create a new list object'); + for i := Low(objects) to High(objects) do + begin + Py_XIncRef( objects[i] ); + PyList_SetItem( Result, i, objects[i] ); + end; +end; + +function TPythonEngine.ArrayToPyTuple( items : array of const) : PPyObject; +var + i : Integer; +begin + Result := PyTuple_New( High(items)+1 ); + if not Assigned(Result) then + raise EPythonError.Create('Could not create a new tuple object'); + for i := Low(items) to High(items) do + PyTuple_SetItem( Result, i, VarRecAsPyObject( items[i] ) ); +end; + +function TPythonEngine.ArrayToPyList( items : array of const) : PPyObject; +var + i : Integer; +begin + Result := PyList_New( High(items)+1 ); + if not Assigned(Result) then + raise EPythonError.Create('Could not create a new list object'); + for i := Low(items) to High(items) do + PyList_SetItem( Result, i, VarRecAsPyObject( items[i] ) ); +end; + +// You must give each entry as a couple key(string)/value +function TPythonEngine.ArrayToPyDict( items : array of const) : PPyObject; + + function VarRecAsString( v : TVarRec ) : String; + begin + case v.VType of + vtChar: Result := v.VChar; + vtString: + begin + if Assigned(v.VString) then + Result := v.VString^ + else + Result := ''; + end; + vtPChar: + begin + Result := v.VPChar; + end; + vtAnsiString: + begin + if Assigned(v.VAnsiString) then + Result := StrPas(v.VAnsiString) + else + Result := ''; + end; + vtVariant: + begin + if Assigned(v.VVariant) then + Result := v.VVariant^ + else + Result := ''; + end; + else + Raise Exception.Create('Argument type not allowed'); + end; + end; + +var + i : Integer; + s : String; + obj : PPyObject; +begin + if ((High(items)+1) mod 2) <> 0 then + raise Exception.Create('You must provide an even number of arguments'); + Result := PyDict_New; + if not Assigned(Result) then + raise EPythonError.Create('Could not create a new dict object'); + i := Low(items); + try + while i <= High(items) do + begin + s := VarRecAsString( items[i] ); + obj := VarRecAsPyObject( items[i+1] ); + if s = '' then + PyDict_SetItemString( Result, '', obj ) + else + PyDict_SetItemString( Result, PChar(s), obj ); + Py_XDecRef(obj); + Inc( i, 2 ); + end; + except + Py_XDECREF( Result ); + end; +end; + +function TPythonEngine.StringsToPyList( strings : TStrings ) : PPyObject; +var + i : Integer; +begin + Result := PyList_New( strings.Count ); + if not Assigned(Result) then + raise EPythonError.Create('Could not create a new list object'); + for i := 0 to strings.Count - 1 do + PyList_SetItem( Result, i, PyString_FromString( PChar(strings.Strings[i]) ) ); +end; + +function TPythonEngine.StringsToPyTuple( strings : TStrings ) : PPyObject; +var + i : Integer; +begin + Result := PyTuple_New( strings.Count ); + if not Assigned(Result) then + raise EPythonError.Create('Could not create a new tuple object'); + for i := 0 to strings.Count - 1 do + PyTuple_SetItem( Result, i, PyString_FromString( PChar(strings.Strings[i]) ) ); +end; + +procedure TPythonEngine.PyListToStrings( list : PPyObject; strings : TStrings ); +var + i : Integer; +begin + if not PyList_Check(list) then + raise EPythonError.Create('the python object is not a list'); + strings.Clear; + for i := 0 to PyList_Size( list ) - 1 do + strings.Add( PyObjectAsString( PyList_GetItem( list, i ) ) ); +end; + +procedure TPythonEngine.PyTupleToStrings( tuple: PPyObject; strings : TStrings ); +var + i : Integer; +begin + if not PyTuple_Check(tuple) then + raise EPythonError.Create('the python object is not a tuple'); + strings.Clear; + for i := 0 to PyTuple_Size( tuple ) - 1 do + strings.Add( PyObjectAsString( PyTuple_GetItem( tuple, i ) ) ); +end; + +{$IFDEF UNICODE_SUPPORT} +function TPythonEngine.PyUnicode_AsWideString( obj : PPyObject ) : WideString; +var + _size : Integer; +{$IFDEF LINUX} + _ucs4Str : UCS4String; +{$ENDIF} +begin + if PyUnicode_Check(obj) then + begin + _size := PySequence_Length(obj); + if _size > 0 then + begin +{$IFDEF LINUX} + // Note that Linux uses UCS4 strings, whereas it declares using UCS2 strings!!! + SetLength(_ucs4Str, _size+1); + if PyUnicode_AsWideChar(obj, @_ucs4Str[0], _size) <> _size then + raise EPythonError.Create('Could not copy the whole Unicode string into its buffer'); + Result := UCS4StringToWideString(_ucs4Str); + // remove trailing zeros (needed by Kylix1) + while (Length(Result) > 0) and (Result[Length(Result)] = #0) do + Delete(Result, Length(Result), 1); +{$ELSE} + SetLength(Result, _size); + if PyUnicode_AsWideChar(obj, @Result[1], _size) <> _size then + raise EPythonError.Create('Could not copy the whole Unicode string into its buffer'); +{$ENDIF} + end + else + Result := ''; + end + else + raise EPythonError.Create('PyUnicode_AsWideString expects a Unicode Python object'); +end; + +function TPythonEngine.PyUnicode_FromWideString( const AString : WideString) : PPyObject; +{$IFDEF LINUX} +var + _ucs4Str : UCS4String; +{$ENDIF} +begin +{$IFDEF LINUX} + // Note that Linux uses UCS4 strings, whereas it declares using UCS2 strings!!! + _ucs4Str := WideStringToUCS4String(AString); + Result := PyUnicode_FromWideChar( {PWideChar}(@_ucs4Str[0]), Length(AString) ); +{$ELSE} + Result := PyUnicode_FromWideChar( PWideChar(AString), Length(AString) ); +{$ENDIF} +end; +{$ENDIF} + +function TPythonEngine.ReturnNone : PPyObject; +begin + Result := Py_None; + Py_INCREF( Result ); +end; + +function TPythonEngine.FindModule( const ModuleName : String ) : PPyObject; +var + modules, m : PPyObject; +begin + modules := PyImport_GetModuleDict; + m := PyDict_GetItemString(modules, PChar(ModuleName) ); + if (m <> nil) and (PyModule_Check(m)) then + Result := m + else + Result := nil; +end; + +function TPythonEngine.FindFunction(ModuleName,FuncName: String): PPyObject; +var + module,func: PPyObject; +begin + module := FindModule(ModuleName); + if module = nil then result := nil + else begin + func := PyObject_GetAttrString(module, PChar(FuncName)); + if Assigned(func) then begin + if PyFunction_Check(func) then + Result := func + else + begin + Py_XDecRef(func); + Result := nil; + end; + end else begin + Result := nil; + PyErr_Clear; + end; + end; +end; + +function TPythonEngine.SetToList( data : Pointer; size : Integer ) : PPyObject; + + function GetBit( idx : Integer ) : Boolean; + var + tmp : PChar; + begin + if idx >= size*8 then + begin + Result := False; + Exit; + end; + tmp := PChar(data); + tmp := tmp + (idx div 8); + Result := (Ord(tmp^) and (1 shl (idx mod 8))) <> 0; + end; + +var + i, cpt : Integer; +begin + cpt := 0; + for i := 0 to size*8-1 do + if GetBit(i) then + Inc(cpt); + Result := PyList_New( cpt ); + cpt := 0; + for i := 0 to size*8-1 do + if GetBit(i) then + begin + PyList_SetItem( Result, cpt, PyInt_FromLong(i) ); + Inc(cpt); + end; +end; + +procedure TPythonEngine.ListToSet( List : PPyObject; data : Pointer; size : Integer ); + + procedure SetBit( idx : Integer ); + var + tmp : PChar; + begin + if idx >= size*8 then + Exit; + tmp := PChar(data); + tmp := tmp + (idx div 8); + tmp^ := Chr((Ord(tmp^) or (1 shl (idx mod 8)))); + end; + +var + i : Integer; +begin + FillChar( PChar(data)^, size, #0 ); + for i := 0 to PyList_Size(list)-1 do + SetBit( PyObjectAsVariant( PyList_GetItem(list, i) ) ); +end; + +procedure TPythonEngine.CheckError(ACatchStopEx : Boolean {$IFDEF DELPHI4_OR_HIGHER}= False{$ENDIF}); +begin + if PyErr_Occurred <> nil then + begin +{$IFDEF PYTHON22_OR_HIGHER} + if ACatchStopEx and (PyErr_GivenExceptionMatches(PyErr_Occurred, PyExc_StopIteration^) <> 0) then + begin + PyErr_Clear; + raise EPyStopIteration.Create('Stop iteration'); + end + else +{$ENDIF} + begin + PyErr_Print; + Traceback.Refresh; + RaiseError; + end; + end; +end; + +function TPythonEngine.GetMainModule : PPyObject; +begin + Result := PyImport_AddModule(PChar(ExecModule)); +end; + +function TPythonEngine.PyTimeStruct_Check( obj : PPyObject ) : Boolean; +begin + Result := Assigned(FTimeStruct) and (Pointer(obj^.ob_type) = FTimeStruct); +end; + +function TPythonEngine.PyDate_Check( obj : PPyObject ) : Boolean; +begin + Result := PyObject_TypeCheck(obj, PPyTypeObject(FPyDateTime_DateType)); +end; + +function TPythonEngine.PyDate_CheckExact( obj : PPyObject ) : Boolean; +begin + Result := Assigned(FPyDateTime_DateType) and (Pointer(obj^.ob_type) = FPyDateTime_DateType); +end; + +function TPythonEngine.PyDateTime_Check( obj : PPyObject ) : Boolean; +begin + Result := PyObject_TypeCheck(obj, PPyTypeObject(FPyDateTime_DateTimeType)); +end; + +function TPythonEngine.PyDateTime_CheckExact( obj : PPyObject ) : Boolean; +begin + Result := Assigned(FPyDateTime_DateType) and (Pointer(obj^.ob_type) = FPyDateTime_DateTimeType); +end; + +function TPythonEngine.PyTime_Check( obj : PPyObject ) : Boolean; +begin + Result := PyObject_TypeCheck(obj, PPyTypeObject(FPyDateTime_TimeType)); +end; + +function TPythonEngine.PyTime_CheckExact( obj : PPyObject ) : Boolean; +begin + Result := Assigned(FPyDateTime_DateType) and (Pointer(obj^.ob_type) = FPyDateTime_TimeType); +end; + +function TPythonEngine.PyDelta_Check( obj : PPyObject ) : Boolean; +begin + Result := PyObject_TypeCheck(obj, PPyTypeObject(FPyDateTime_DeltaType)); +end; + +function TPythonEngine.PyDelta_CheckExact( obj : PPyObject ) : Boolean; +begin + Result := Assigned(FPyDateTime_DateType) and (Pointer(obj^.ob_type) = FPyDateTime_DeltaType); +end; + +function TPythonEngine.PyTZInfo_Check( obj : PPyObject ) : Boolean; +begin + Result := PyObject_TypeCheck(obj, PPyTypeObject(FPyDateTime_TZInfoType)); +end; + +function TPythonEngine.PyTZInfo_CheckExact( obj : PPyObject ) : Boolean; +begin + Result := Assigned(FPyDateTime_DateType) and (Pointer(obj^.ob_type) = FPyDateTime_TZInfoType); +end; + +function TPythonEngine.PyDateTime_GET_YEAR( obj : PPyObject ) : Integer; +begin + Result := (PPyDateTime_Date(obj)^.data[0] Shl 8) or + PPyDateTime_Date(obj)^.data[1]; +end; + +function TPythonEngine.PyDateTime_GET_MONTH( obj : PPyObject ) : Integer; +begin + Result := PPyDateTime_Date(obj)^.data[2]; +end; + +function TPythonEngine.PyDateTime_GET_DAY( obj : PPyObject ) : Integer; +begin + Result := PPyDateTime_Date(obj)^.data[3]; +end; + +function TPythonEngine.PyDateTime_DATE_GET_HOUR( obj : PPyObject ) : Integer; +begin + Result := PPyDateTime_DateTime(obj)^.data[4]; +end; + +function TPythonEngine.PyDateTime_DATE_GET_MINUTE( obj : PPyObject ) : Integer; +begin + Result := PPyDateTime_DateTime(obj)^.data[5]; +end; + +function TPythonEngine.PyDateTime_DATE_GET_SECOND( obj : PPyObject ) : Integer; +begin + Result := PPyDateTime_DateTime(obj)^.data[6]; +end; + +function TPythonEngine.PyDateTime_DATE_GET_MICROSECOND( obj : PPyObject ) : Integer; +begin + Result := (PPyDateTime_DateTime(obj)^.data[7] Shl 16) or + (PPyDateTime_DateTime(obj)^.data[8] Shl 8) or + PPyDateTime_DateTime(obj)^.data[9]; +end; + +function TPythonEngine.PyDateTime_TIME_GET_HOUR( obj : PPyObject ) : Integer; +begin + Result := PPyDateTime_Time(obj)^.data[0]; +end; + +function TPythonEngine.PyDateTime_TIME_GET_MINUTE( obj : PPyObject ) : Integer; +begin + Result := PPyDateTime_Time(obj)^.data[1]; +end; + +function TPythonEngine.PyDateTime_TIME_GET_SECOND( obj : PPyObject ) : Integer; +begin + Result := PPyDateTime_Time(obj)^.data[2]; +end; + +function TPythonEngine.PyDateTime_TIME_GET_MICROSECOND( obj : PPyObject ) : Integer; +begin + Result := (PPyDateTime_Time(obj)^.data[3] Shl 16) or + (PPyDateTime_Time(obj)^.data[4] Shl 8) or + PPyDateTime_Time(obj)^.data[5]; +end; + +function TPythonEngine.GetVersion: String; +begin + Result := '3.32'; +end; + +procedure TPythonEngine.SetVersion(const Value: String); +begin + // do nothing +end; + + +(*******************************************************) +(** **) +(** class TEngineClient **) +(** **) +(*******************************************************) + +procedure TEngineClient.SetEngine( val : TPythonEngine ); +begin + if val <> FEngine then + begin + if Assigned(FEngine) {and not(csDesigning in ComponentState)} then + FEngine.RemoveClient( Self ); + FEngine := val; + if Assigned(FEngine) {and not(csDesigning in ComponentState)} then + FEngine.AddClient( Self ); + end; +end; + +procedure TEngineClient.ModuleReady(Sender : TObject); +begin +end; + +constructor TEngineClient.Create( AOwner : TComponent ); +var + i : Integer; +begin + inherited; + if (csDesigning in ComponentState) and Assigned(AOwner) then + with AOwner do + for i := 0 to ComponentCount - 1 do + if Components[i] is TPythonEngine then + begin + Self.Engine := TPythonEngine(Components[i]); + Break; + end; +end; + +destructor TEngineClient.Destroy; +begin + Engine := nil; // This detaches the client from the Engine. + if Assigned( FOnDestroy ) then + FOnDestroy( Self ); + inherited; +end; + +procedure TEngineClient.Loaded; +begin + inherited; + if Assigned( FOnCreate ) then + FOnCreate( Self ); +end; + +procedure TEngineClient.Notification( AComponent: TComponent; Operation: TOperation); +begin + inherited; + if Operation = opRemove then + if AComponent = FEngine then + FEngine := nil; +end; + +procedure TEngineClient.Initialize; +begin + if FInitialized then + Exit; + if Assigned( FOnInitialization ) then + FOnInitialization( Self ); + FInitialized := True; +end; + +procedure TEngineClient.Finalize; +begin + if not FInitialized then + Exit; + if Assigned( FOnFinalization ) then + FOnFinalization( Self ); + FInitialized := False; +end; + +procedure TEngineClient.ClearEngine; +begin + FEngine := nil; +end; + +procedure TEngineClient.CheckEngine; +begin + if not Assigned(FEngine) then + raise Exception.CreateFmt('No Engine defined for component "%s"', [Name]); +end; + + +(*******************************************************) +(** **) +(** class TMethodsContainer **) +(** **) +(*******************************************************) + +//////////////////////////////////////// +// class TEventDef + +constructor TEventDef.Create(ACollection: TCollection); +begin + inherited; + FDocString := TStringList.Create; + Name := Format('PythonEvent%d',[Collection.Count - 1]); +end; + +destructor TEventDef.Destroy; +begin + FDocString.Free; + inherited; +end; + +function TEventDef.GetDisplayName: string; +begin + Result := FName; +end; + +function TEventDef.GetDocString : String; +begin + Owner.Container.CheckEngine; + FTmpDocString := Owner.Container.Engine.CleanString(FDocString.Text); + Result := fTmpDocString; +end; + +function TEventDef.PythonEvent(pself, args: PPyObject): PPyObject; +begin + Owner.Container.CheckEngine; + with Owner.Container.Engine do + begin + if Assigned(fOnExecute) then + fOnExecute(Self, pself, args, Result); + end; +end; + +function TEventDef.Owner : TEventDefs; +begin + Result := Collection as TEventDefs; +end; + +procedure TEventDef.SetDisplayName(const Value: String); +begin + FName := Value; + inherited; +end; + +procedure TEventDef.Assign(Source: TPersistent); +begin + if Source is TEventDef then + begin + Name := TEventDef(Source).Name; + DocString := TEventDef(Source).DocString; + end + else + inherited Assign(Source); +end; + +procedure TEventDef.SetDocString(const Value: TStringList); +begin + FDocString.Assign(Value); +end; + +//////////////////////////////////////// +// class TEventDefs + +constructor TEventDefs.Create(AMethodsContainer : TMethodsContainer ); +begin + inherited Create(TEventDef); + FMethodsContainer := AMethodsContainer; +end; + +function TEventDefs.GetItems( idx : Integer ) : TEventDef; +begin + Result := TEventDef(inherited GetItem(idx)); +end; + +procedure TEventDefs.SetItems( idx : Integer; Value : TEventDef ); +begin + inherited SetItem( idx, Value ); +end; + +function TEventDefs.GetOwner: TPersistent; +begin + Result := FMethodsContainer; +end; + +function TEventDefs.Add : TEventDef; +begin + Result := TEventDef(inherited Add); +end; + +procedure TEventDefs.RegisterEvents; +var + i : Integer; +begin + for i := 0 to Count - 1 do + with Items[i] do + FMethodsContainer.AddDelphiMethod(PChar(Name), PythonEvent, PChar(GetDocString)); +end; + +//////////////////////////////////////// +// class TMethodsContainer + +procedure TMethodsContainer.AllocMethods; +begin + Assert(FMethods = nil); + FAllocatedMethodCount := PYT_METHOD_BUFFER_INCREASE; + FMethodCount := 0; + FMethods := PPyMethodDef(AllocMem(SizeOf(PyMethodDef)*(FAllocatedMethodCount+1))); +end; + +procedure TMethodsContainer.FreeMethods; +begin + if Assigned(FMethods) then + begin + FreeMem(FMethods); + FMethods := nil; + end; + FAllocatedMethodCount := 0; + FMethodCount := 0; +end; + +procedure TMethodsContainer.ReallocMethods; +var + MethodPtr : PPyMethodDef; +begin + Inc( FAllocatedMethodCount, PYT_METHOD_BUFFER_INCREASE ); + ReAllocMem( FMethods, SizeOf(PyMethodDef)*(FAllocatedMethodCount+1)); + MethodPtr :=@(PMethodArray(FMethods)^[MethodCount+1]); + FillChar( MethodPtr^,SizeOf(PyMethodDef)*PYT_METHOD_BUFFER_INCREASE,0); +end; + +function TMethodsContainer.GetMethods( idx : Integer ) : PPyMethodDef; +begin + if (idx < 0) or (idx > MethodCount) then + raise Exception.CreateFmt('%s: Index %d out of range', [ClassName, idx]); + Result := @( PMethodArray(FMethods)^[idx] ); +end; + +function TMethodsContainer.StoreEventDefs: Boolean; +begin + Result := (FEventDefs <> nil) and (FEventDefs.Count > 0); +end; + +constructor TMethodsContainer.Create( AOwner : TComponent ); +begin + inherited; + AllocMethods; + fEventDefs := TEventDefs.Create(Self); +end; + +destructor TMethodsContainer.Destroy; +begin + fEventDefs.Free; + fEventDefs := nil; + FreeMethods; + inherited; +end; + +procedure TMethodsContainer.Initialize; +begin + inherited; + Events.RegisterEvents; +end; + +procedure TMethodsContainer.Finalize; +begin + if not (csDestroying in ComponentState) then + ClearMethods; + inherited; +end; + +function TMethodsContainer.AddMethod( AMethodName : PChar; + AMethod : PyCFunction; + ADocString : PChar ) : PPyMethodDef; +begin + if FMethodCount = FAllocatedMethodCount then + ReallocMethods; + Result := Methods[ MethodCount ]; + Result^.ml_name := AMethodName; + Result^.ml_meth := AMethod; + Result^.ml_flags := METH_VARARGS; + Result^.ml_doc := ADocString; + Inc( FMethodCount ); +end; + +function TMethodsContainer.AddMethodWithKeywords( AMethodName : PChar; + AMethod : PyCFunctionWithKW; + ADocString : PChar ) : PPyMethodDef; +begin + Result := AddMethod( AMethodName, + PyCFunction(AMethod), + ADocString ); + Result^.ml_flags := Result^.ml_flags or METH_KEYWORDS; +end; + +function TMethodsContainer.AddDelphiMethod( AMethodName : PChar; + ADelphiMethod: TDelphiMethod; + ADocString : PChar ) : PPyMethodDef; +begin + Result := AddMethod( AMethodName, + GetOfObjectCallBack( TCallBack(ADelphiMethod), 2, ctCDECL), + ADocString ); +end; + +function TMethodsContainer.AddDelphiMethodWithKeywords( AMethodName : PChar; + ADelphiMethod: TDelphiMethodWithKW; + ADocString : PChar ) : PPyMethodDef; +begin + Result := AddMethod( AMethodName, + GetOfObjectCallBack( TCallBack(ADelphiMethod), 3, ctCDECL), + ADocString ); + Result^.ml_flags := Result^.ml_flags or METH_KEYWORDS; +end; + +procedure TMethodsContainer.ClearMethods; +begin + FMethodCount := 0; + FillChar(FMethods^, Sizeof(FMethods^)*FAllocatedMethodCount, 0); +end; + +//////////////////////////////////////// +// class TMembersContainer + +function TMembersContainer.GetMembersStartOffset : Integer; +begin + Result := 0; +end; + +{$IFDEF PYTHON22_OR_HIGHER} +procedure TMembersContainer.AddMember(MemberName: PChar; MemberType : TPyMemberType; + MemberOffset : Integer; MemberFlags: TPyMemberFlag; MemberDoc: PChar); +begin + if FMemberCount = FAllocatedMemberCount then + ReallocMembers; + with Members[ MemberCount ]^ do + begin + name := MemberName; + case MemberType of + mtShort: _type := T_Short; + mtInt: _type := T_Int; + mtLong: _type := T_Long; + mtFloat: _type := T_Float; + mtDouble: _type := T_Double; + mtString: _type := T_String; + mtObject: _type := T_Object; + mtChar: _type := T_Char; + mtByte: _type := T_Byte; + mtUByte: _type := T_UByte; + mtUShort: _type := T_UShort; + mtUInt: _type := T_UInt; + mtULong: _type := T_ULong; + mtStringInplace: _type := T_STRING_INPLACE; + mtObjectEx: _type := T_OBJECT_EX; + else + raise Exception.Create('Unknown member type'); + end; + offset := MemberOffset + GetMembersStartOffset; + case MemberFlags of + mfDefault: flags := 0; + mfReadOnly: flags := READONLY; + mfReadRestricted: flags := READ_RESTRICTED; + mfWriteRestricted: flags := WRITE_RESTRICTED; + mfRestricted: flags := RESTRICTED; + else + raise Exception.Create('Unknown member flag'); + end; + doc := MemberDoc; + end; + Inc( FMemberCount ); +end; + +procedure TMembersContainer.AllocMembers; +begin + FAllocatedMemberCount := PYT_MEMBER_BUFFER_INCREASE; + Assert(not Assigned(FMembers)); + FMembers := PPyMemberDef(AllocMem(SizeOf(PyMemberDef)*(FAllocatedMemberCount+1))); +end; + +procedure TMembersContainer.ClearMembers; +begin + FMemberCount := 0; + FillChar(FMembers^, Sizeof(FMembers^)*FAllocatedMemberCount, 0); +end; + +constructor TMembersContainer.Create(AOwner: TComponent); +begin + inherited; + AllocMembers; +end; + +destructor TMembersContainer.Destroy; +begin + FreeMembers; + inherited; +end; + +procedure TMembersContainer.Finalize; +begin + if not (csDestroying in ComponentState) then + ClearMembers; + inherited; +end; + +procedure TMembersContainer.FreeMembers; +begin + if Assigned(FMembers) then + begin + FreeMem(FMembers); + FMembers := nil; + end; + FMemberCount := 0; + FAllocatedMemberCount := 0; +end; + +function TMembersContainer.GetMembers(idx: Integer): PPyMemberDef; +begin + if (idx < 0) or (idx > MemberCount) then + raise Exception.CreateFmt('%s: Index %d out of range', [ClassName, idx]); + Result := @( PMemberArray(FMembers)^[idx] ); +end; + +procedure TMembersContainer.ReallocMembers; +var + MemberPtr : PPyMemberDef; +begin + Inc( FAllocatedMemberCount, PYT_MEMBER_BUFFER_INCREASE ); + ReAllocMem( FMembers, SizeOf(PyMemberDef)*(FAllocatedMemberCount+1)); + MemberPtr :=@(PMemberArray(FMembers)^[MemberCount+1]); + FillChar( MemberPtr^,SizeOf(PyMemberDef)*PYT_MEMBER_BUFFER_INCREASE,0); +end; +{$ENDIF} + +//////////////////////////////////////// +// class TGetSetContainer + +{$IFDEF PYTHON22_OR_HIGHER} + +procedure TGetSetContainer.AddGetSet(AName: PChar; AGet: getter; + ASet: setter; ADoc: PChar; AClosure: Pointer); +begin + if FGetSetCount = FAllocatedGetSetCount then + ReallocGetSets; + with GetSet[ GetSetCount ]^ do + begin + name := AName; + get := AGet; + _set := ASet; + doc := ADoc; + closure := AClosure; + end; + Inc( FGetSetCount ); +end; + +procedure TGetSetContainer.AllocGetSets; +begin + FAllocatedGetSetCount := PYT_GETSET_BUFFER_INCREASE; + Assert(not Assigned(FGetSets)); + FGetSets := PPyGetSetDef(AllocMem(SizeOf(PyGetSetDef)*(FAllocatedGetSetCount+1))); +end; + +procedure TGetSetContainer.ClearGetSets; +begin + FGetSetCount := 0; + FillChar(FGetSets^, Sizeof(FGetSets^)*FAllocatedGetSetCount, 0); +end; + +constructor TGetSetContainer.Create(AOwner: TComponent); +begin + inherited; + AllocGetSets; +end; + +destructor TGetSetContainer.Destroy; +begin + FreeGetSets; + inherited; +end; + +procedure TGetSetContainer.Finalize; +begin + if not (csDestroying in ComponentState) then + ClearGetSets; + inherited; +end; + +procedure TGetSetContainer.FreeGetSets; +begin + if Assigned(FGetSets) then + begin + FreeMem(FGetSets); + FGetSets := nil; + end; + FGetSetCount := 0; + FAllocatedGetSetCount := 0; +end; + +function TGetSetContainer.GetGetSet(idx: Integer): PPyGetSetDef; +begin + if (idx < 0) or (idx > GetSetCount) then + raise Exception.CreateFmt('%s: Index %d out of range', [ClassName, idx]); + Result := @( PGetSetArray(FGetSets)^[idx] ); +end; + +procedure TGetSetContainer.ReallocGetSets; +var + GetSetPtr : PPyGetSetDef; +begin + Inc( FAllocatedGetSetCount, PYT_GETSET_BUFFER_INCREASE ); + ReAllocMem( FGetSets, SizeOf(PyGetSetDef)*(FAllocatedGetSetCount+1)); + GetSetPtr :=@(PGetSetArray(FGetSets)^[GetSetCount+1]); + FillChar( GetSetPtr^,SizeOf(PyGetSetDef)*PYT_GETSET_BUFFER_INCREASE,0); +end; +{$ENDIF} + +(*******************************************************) +(** **) +(** class TPythonModule **) +(** **) +(*******************************************************) + +//////////////////////////////////////// +// class TParentClassError + +procedure TParentClassError.AssignTo( Dest: TPersistent ); +begin + if Dest is TParentClassError then + with TParentClassError( Dest ) do + begin + FName := Self.FName; + FModule := Self.FModule; + end; + inherited; +end; + +//////////////////////////////////////// +// class TError + +function TError.GetDisplayName: string; +begin + Result := Name; + if Result = '' then Result := inherited GetDisplayName; +end; + +procedure TError.SetName( const Value : String ); + + procedure CheckName; + var + i : Integer; + m : TPythonModule; + begin + with Collection as TErrors do + begin + if GetOwner = nil then + Exit; + m := GetOwner as TPythonModule; + for i := 0 to Count - 1 do + with Items[i] do + if Name = Value then + raise Exception.CreateFmt( 'In module "%s", there''s already an error named "%s"', + [m.ModuleName, Value]); + end; + end; + + procedure UpdateDependencies; + var + i, j : Integer; + m : TPythonModule; + begin + if FName = '' then + Exit; + with Collection as TErrors do + with GetOwner as TPythonModule do + begin + if not Assigned(Engine) then + Exit; + m := TPythonModule( TErrors(Self.Collection).GetOwner ); + with Engine do + begin + for i := 0 to ClientCount - 1 do + if Clients[i] is TPythonModule then + with TPythonModule(Clients[i]) do + begin + for j := 0 to Errors.Count - 1 do + with Errors.Items[j] do + if (ParentClass.Module = m.ModuleName) and + (ParentClass.Name = Self.Name) then + ParentClass.Name := Value; + end; + end; + end; + end; + +begin + if (FName <> Value) and (Value <> '') then + begin + CheckName; + if ErrorType = etClass then + UpdateDependencies; + FName := Value; + Changed(False); + end; +end; + +procedure TError.SetText( const Value : String ); +begin + if FText <> Value then + begin + FText := Value; + Changed(False); + end; +end; + +procedure TError.SetErrorType( Value : TErrorType ); +begin + if FErrorType <> Value then + begin + FErrorType := Value; + if FErrorType = etString then + FParentClass.Name := ''; + Changed(False); + end; +end; + +procedure TError.SetParentClass( Value : TParentClassError ); +begin + FParentClass.Assign( Value ); + Changed(False); +end; + +constructor TError.Create(ACollection: TCollection); +begin + inherited; + FErrorType := etString; + FParentClass := TParentClassError.Create; +end; + +destructor TError.Destroy; +begin + FParentClass.Free; + inherited; +end; + +procedure TError.Assign(Source: TPersistent); +begin + if Source is TError then + begin + Name := TError(Source).Name; + Text := TError(Source).Text; + Exit; + end; + inherited Assign(Source); +end; + +procedure TError.BuildError( const ModuleName : String ); + + function FindParentClass : PPyObject; + var + m, d : PPyObject; + begin + Owner.Owner.CheckEngine; + with Owner.Owner.Engine do + begin + if ParentClass.Module <> '' then + //m := PyImport_ImportModule( PChar(ParentClass.Module) ) + m := PyImport_AddModule( PChar(ParentClass.Module) ) + else + m := FindModule( ModuleName ); + if not Assigned(m) then + raise Exception.CreateFmt('Could not find module containing the parent class of error "%s"', [Self.Name]); + d := PyModule_GetDict(m); + Result := PyDict_GetItemString( d, PChar(ParentClass.Name) ); + if not Assigned(Result) then + raise Exception.CreateFmt('Could not find the parent class "%s" of error "%s"', [ParentClass.Name, Self.Name]); + if not PyClass_Check( Result ) and not PyType_CheckExact( Result ) then + raise Exception.CreateFmt('The object "%s" in module "%s" is not a class', [ParentClass.Name, ParentClass.Module] ); + end; + end; + +var + parent : PPyObject; +begin + if Assigned(Error) then + Exit; + if Name = '' then + with GetOwner as TPythonModule do + raise Exception.CreateFmt( 'Error without name in module "%s"', [ModuleName] ); + if Text = '' then + Text := Name; + Owner.Owner.CheckEngine; + with Owner.Owner.Engine do + begin + if ErrorType = etString then + Error := PyString_FromString( PChar(Text) ) + else if ErrorType = etClass then + begin + if FParentClass.Name <> '' then + parent := FindParentClass + else + parent := nil; + Error := PyErr_NewException( PChar(Format('%s.%s', [ModuleName, Self.Name])), + parent, nil ); + end; + end; + if not Assigned(Error) then + raise Exception.CreateFmt( 'Could not create error "%s"', [Name] ); +end; + +procedure TError.RaiseError( const msg : String ); +begin + Owner.Owner.CheckEngine; + with Owner.Owner.Engine do + PyErr_SetString( Error, PChar(msg) ); +end; + +procedure TError.RaiseErrorObj( const msg : String; obj : PPyObject ); +var + args, res, str : PPyObject; + inst : PPyInstanceObject; +{$IFDEF PYTHON23_OR_HIGHER} + i : Integer; + keys : PPyObject; + key : PPyObject; + val : PPyObject; +{$ENDIF} +begin + Owner.Owner.CheckEngine; + with Owner.Owner.Engine do + // if we give a dictionary as argument, then we use it for the + // instance. + if PyDict_Check( obj ) then + begin + args := PyTuple_New(0); + if not Assigned(args) then + raise Exception.Create('TError.RaiseErrorObj: Could not create an empty tuple'); + res := PyEval_CallObject(Error, args); + Py_DECREF(args); + if not Assigned(res) then + raise Exception.CreateFmt('TError.RaiseErrorObj: Could not create an instance of "%s"', [Self.Name]); + if PyInstance_Check( res ) then + begin + inst := PPyInstanceObject(res); + Py_XDECREF( inst^.in_dict ); + inst^.in_dict := obj; + str := PyString_FromString( PChar(msg) ); + PyDict_SetItemString( obj, 'args', str ); + Py_XDecRef(str); + end +{$IFDEF PYTHON23_OR_HIGHER} + else if PyObject_TypeCheck(res, PPyTypeObject(PyExc_Exception^)) then + begin + args := PyTuple_New(1); + if not Assigned(args) then + raise Exception.Create('TError.RaiseErrorObj: Could not create an empty tuple'); + str := PyString_FromString( PChar(msg) ); + PyTuple_SetItem(args, 0, str); + res := PyEval_CallObject(Error, args); + Py_DECREF(args); + if not Assigned(res) then + raise Exception.CreateFmt('TError.RaiseErrorObj: Could not create an instance of "%s"', [Self.Name]); + keys := PyDict_Keys(obj); + for i := 0 to PySequence_Length(keys)-1 do + begin + key := PySequence_GetItem(keys, i); + val := PyDict_GetItem(obj, key); + if Assigned(val) then + begin + PyObject_SetAttr(res, key, val); + Py_DECREF(val); + end; + Py_XDECREF(key); + end; + Py_XDECREF(keys); + end +{$ENDIF} + else + raise Exception.Create('TError.RaiseErrorObj: I didn''t get an instance' ); + PyErr_SetObject( Error, res ); + end + else + PyErr_SetObject( Error, obj ); +end; + +function TError.Owner : TErrors; +begin + Result := GetOwner as TErrors; +end; + +//////////////////////////////////////// +// class TErrors + +function TErrors.GetError(Index: Integer): TError; +begin + Result := TError(inherited GetItem(Index)); +end; + +procedure TErrors.SetError(Index: Integer; Value: TError); +begin + inherited SetItem(Index, Value); +end; + +function TErrors.GetOwner: TPersistent; +begin + Result := FModule; +end; + +procedure TErrors.Update(Item: TCollectionItem); +begin + inherited; +end; + +constructor TErrors.Create(Module: TPythonModule ); +begin + inherited Create( TError ); + FModule := Module; +end; + +function TErrors.Add: TError; +begin + Result := TError(inherited Add); +end; + +function TErrors.Owner : TPythonModule; +begin + Result := GetOwner as TPythonModule; +end; + +//////////////////////////////////////// +// class TPythonModule + +function TPythonModule.GetClientCount : Integer; +begin + Result := FClients.Count; +end; + +function TPythonModule.GetClients( idx : Integer ) : TEngineClient; +begin + Result := TEngineClient(FClients.Items[idx]); +end; + +procedure TPythonModule.SetErrors( val : TErrors ); +begin + FErrors.Assign( val ); +end; + +procedure TPythonModule.SetModuleName( const val : String ); + + procedure UpdateDependencies; + var + i, j : Integer; + begin + if not Assigned(Engine) then + Exit; + if FModuleName = '' then + Exit; + with Engine do + for i := 0 to ClientCount - 1 do + if Clients[i] is TPythonModule then + with TPythonModule(Clients[i]) do + for j := 0 to Errors.Count - 1 do + with Errors.Items[j] do + if ParentClass.Module = Self.FModuleName then + ParentClass.Module := val; + end; + +begin + if (FModuleName <> val) and (val <> '') then + begin + UpdateDependencies; + FModuleName := val; + end; +end; + +constructor TPythonModule.Create( AOwner : TComponent ); +begin + inherited; + FClients := TList.Create; + FErrors := TErrors.Create(Self); + FDocString := TStringList.Create; +end; + +destructor TPythonModule.Destroy; +begin + FDocString.Free; + FClients.Free; + FErrors.Free; + inherited; +end; + + +procedure TPythonModule.SetDocString( value : TStringList ); +begin + FDocString.Assign( value ); +end; + +procedure TPythonModule.DefineDocString; +var + doc : PPyObject; +begin + with Engine do + begin + if DocString.Text <> '' then + begin + doc := PyString_FromString( PChar(CleanString(FDocString.Text)) ); + PyObject_SetAttrString( FModule, '__doc__', doc ); + Py_XDecRef(doc); + CheckError(False); + end; + end; +end; + +procedure TPythonModule.MakeModule; +begin + CheckEngine; + if Assigned(FModule) then + Exit; + with Engine do + begin + FModule := Py_InitModule( PChar(ModuleName), MethodsData ); + DefineDocString; + end; +end; + +procedure TPythonModule.Initialize; +var + i : Integer; +begin + inherited; + FModule := nil; + MakeModule; + for i := 0 to ClientCount - 1 do + Clients[i].ModuleReady(Self); + BuildErrors; + if Assigned(FOnAfterInitialization) then + FOnAfterInitialization( Self ); +end; + +procedure TPythonModule.InitializeForNewInterpreter; +var + initialized : Boolean; + oldModule : PPyObject; +begin + initialized := FInitialized; + oldModule := FModule; + FModule := nil; + FInitialized := False; + try + Initialize; + finally + FInitialized := initialized; + FModule := oldModule; + end; +end; + +procedure TPythonModule.AddClient( client : TEngineClient ); +begin + FClients.Add( client ); +end; + +function TPythonModule.ErrorByName( const AName : String ) : TError; +var + i : Integer; +begin + for i := 0 to Errors.Count - 1 do + if CompareText( Errors.Items[i].Name, AName ) = 0 then + begin + Result := Errors.Items[i]; + Exit; + end; + raise Exception.CreateFmt( 'Could not find error "%s"', [AName] ); +end; + +procedure TPythonModule.RaiseError( const error, msg : String ); +begin + ErrorByName( error ).RaiseError( msg ); +end; + +procedure TPythonModule.RaiseErrorFmt( const error, format : String; Args : array of const ); +begin + RaiseError( error, SysUtils.Format( format, Args ) ); +end; + +procedure TPythonModule.RaiseErrorObj( const error, msg : String; obj : PPyObject ); +begin + ErrorByName( error ).RaiseErrorObj( msg, obj ); +end; + +procedure TPythonModule.BuildErrors; +var + i : Integer; + d : PPyObject; +begin + CheckEngine; + with Engine do + begin + d := PyModule_GetDict( Module ); + if not Assigned(d) then + Exit; + for i := 0 to Errors.Count - 1 do + with Errors.Items[i] do + begin + BuildError( ModuleName ); + PyDict_SetItemString( d, PChar(Name), Error ); + end; + end; +end; + +// warning, this function will increase the refcount of value, +// so, if you don't want to keep a link, don't forget to decrement +// the refcount after the SetVar method. +procedure TPythonModule.SetVar( const varName : String; value : PPyObject ); +begin + if Assigned(FEngine) and Assigned( FModule ) then + begin + if Engine.PyObject_SetAttrString(Module, PChar(varName), value ) <> 0 then + raise EPythonError.CreateFmt( 'Could not set var "%s" in module "%s"', [varName, ModuleName] ); + end + else + raise EPythonError.CreateFmt( 'Can''t set var "%s" in module "%s", because it is not yet initialized', [varName, ModuleName] ); +end; + +// warning, this function will increase the refcount of value, +// so, if you don't want to keep a link, don't forget to decrement +// the refcount after the GetVar method. +function TPythonModule.GetVar( const varName : String ) : PPyObject; +begin + if Assigned(FEngine) and Assigned( FModule ) then + begin + Result := Engine.PyObject_GetAttrString(Module, PChar(varName) ); + Engine.PyErr_Clear; + end + else + raise EPythonError.CreateFmt( 'Can''t get var "%s" in module "%s", because it is not yet initialized', [varName, ModuleName] ); +end; + +procedure TPythonModule.DeleteVar( const varName : String ); +var + dict : PPyObject; +begin + if Assigned(FEngine) and Assigned( FModule ) then + with Engine do + begin + dict := PyModule_GetDict( Module ); + if not Assigned(dict) then raise EPythonError.CreateFmt( 'Can''t get __dict__ of module "%s"', [ModuleName] ); + PyDict_DelItemString( dict, PChar(varName) ); + end + else + raise EPythonError.CreateFmt( 'Can''t delete var "%s" in module "%s", because it is not yet initialized', [varName, ModuleName] ); +end; + +procedure TPythonModule.SetVarFromVariant( const varName : String; const value : Variant ); +var + obj : PPyObject; +begin + CheckEngine; + with Engine do + begin + obj := VariantAsPyObject( value ); + try + SetVar( varName, obj ); + finally + Py_XDecRef(obj); + end; + end; +end; + +function TPythonModule.GetVarAsVariant( const varName : String ) : Variant; +var + obj : PPyObject; +begin + CheckEngine; + with Engine do + begin + obj := GetVar( varName ); + try + Result := PyObjectAsVariant( obj ); + finally + Py_XDecRef(obj); + end; + end; +end; + +(*******************************************************) +(** **) +(** class TPythonType **) +(** **) +(*******************************************************) + +////////////////////////////// +// TPyObject + +// Constructors & Destructors +constructor TPyObject.Create( APythonType : TPythonType ); +begin + inherited Create; + if Assigned(APythonType) then + begin + ob_refcnt := 1; + PythonType := APythonType; + with APythonType do + begin + Inc(FInstanceCount); + Inc(FCreateHits); + end; + end; +end; + +constructor TPyObject.CreateWith( APythonType : TPythonType; args : PPyObject ); +begin + Create( APythonType ); +end; + +destructor TPyObject.Destroy; +begin + if Assigned(PythonType) then + begin + Dec(PythonType.FInstanceCount); + Inc(PythonType.FDeleteHits); + end; + inherited; +end; + +class function TPyObject.NewInstance: TObject; +var + mem : PChar; +begin + GetMem(mem, InstanceSize + Sizeof(PyObject)); + PPyObject(mem)^.ob_refcnt := 1; + PPyObject(mem)^.ob_type := nil; + Result := InitInstance(Mem+Sizeof(PyObject)); +end; + +procedure TPyObject.FreeInstance; +begin + CleanupInstance; + if not PythonAlloc then + FreeMem(PChar(Self)-Sizeof(PyObject)); +end; + +// Misc +function TPyObject.GetSelf : PPyObject; +begin + Result := PPyObject( PChar(Self)-Sizeof(PyObject) ) +end; + +procedure TPyObject.IncRef; +begin + Inc(GetSelf^.ob_refcnt); +end; + +procedure TPyObject.Adjust(PyPointer: Pointer); +var + ptr : PInteger; +begin + ptr := PyPointer; + ptr^ := Integer(PythonToDelphi(PPyObject(ptr^))); +end; + +function TPyObject.GetModule : TPythonModule; +begin + if Assigned(PythonType) then + Result := PythonType.Module + else + Result := nil; +end; + +function TPyObject.Get_ob_refcnt: Integer; +begin + Result := GetSelf^.ob_refcnt; +end; + +function TPyObject.Get_ob_type: PPyTypeObject; +begin + Result := GetSelf^.ob_type; +end; + +procedure TPyObject.Set_ob_refcnt(const Value: Integer); +begin + GetSelf^.ob_refcnt := Value; +end; + +procedure TPyObject.Set_ob_type(const Value: PPyTypeObject); +begin + GetSelf^.ob_type := Value; +end; + +// Type services +//////////////// + +// Basic services +function TPyObject.Print( var f: file; i: integer) : Integer; +begin + Result := -1; +end; + +function TPyObject.GetAttr(key : PChar) : PPyObject; +begin + with GetPythonEngine do + begin + // check for a method + Result := Py_FindMethod( PythonType.MethodsData, GetSelf, key); + if not Assigned(Result) then + PyErr_SetString (PyExc_AttributeError^, PChar(Format('Unknown attribute "%s"',[key]))); + end; +end; + +function TPyObject.SetAttr(key : PChar; value : PPyObject) : Integer; +begin + with GetPythonEngine do + begin + Result := -1; + PyErr_SetString (PyExc_AttributeError^, PChar(Format('Unknown attribute "%s"',[key]))); + end; +end; + +function TPyObject.Repr : PPyObject; +begin + with GetPythonEngine do + Result := PyString_FromString( PChar(Format('<%s at %x>', [PythonType.TypeName, Integer(self)])) ); +end; + +function TPyObject.Compare( obj: PPyObject) : Integer; +begin + Result := 0; +end; + +function TPyObject.Hash : Integer; +begin + Result := Integer(Self); +end; + +function TPyObject.Str: PPyObject; +begin + Result := Repr; +end; + +function TPyObject.GetAttrO( key: PPyObject) : PPyObject; +begin +{$IFDEF PYTHON22_OR_HIGHER} + Result := GetPythonEngine.PyObject_GenericGetAttr(GetSelf, key); +{$ELSE} + Result := nil; +{$ENDIF} +end; + +function TPyObject.SetAttrO( key, value: PPyObject) : Integer; +begin +{$IFDEF PYTHON22_OR_HIGHER} + Result := GetPythonEngine.PyObject_GenericSetAttr(GetSelf, key, value); +{$ELSE} + Result := -1; +{$ENDIF} +end; + +function TPyObject.Call( ob1, ob2 : PPyObject) : PPyObject; +begin + Result := nil; +end; + +{$IFDEF PYTHON20_OR_HIGHER} +function TPyObject.Traverse( proc: visitproc; ptr: Pointer) : integer; +begin + Result := 0; +end; +{$ENDIF} + +function TPyObject.Clear: integer; +begin + Result := 0; +end; + +function TPyObject.RichCompare( obj : PPyObject; Op : TRichComparisonOpcode) : PPyObject; +begin + Result := nil; +end; + +function TPyObject.Iter : PPyObject; +begin + Result := nil; +end; + +function TPyObject.IterNext : PPyObject; +begin + Result := nil; +end; + +{ Called when an instance of a subtype has been created. Same as __init__ in a class } +function TPyObject.Init( args, kwds : PPyObject ) : Integer; +begin + Result := 0; +end; + +// Number services +function TPyObject.NbAdd( obj : PPyObject) : PPyObject; +begin + Result := nil; +end; + +function TPyObject.NbSubstract( obj : PPyObject) : PPyObject; +begin + Result := nil; +end; + +function TPyObject.NbMultiply( obj : PPyObject) : PPyObject; +begin + Result := nil; +end; + +function TPyObject.NbDivide( obj : PPyObject) : PPyObject; +begin + Result := nil; +end; + +function TPyObject.NbFloorDivide( obj : PPyObject) : PPyObject; +begin + Result := nil; +end; + +function TPyObject.NbTrueDivide( obj : PPyObject) : PPyObject; +begin + Result := nil; +end; + +function TPyObject.NbRemainder( obj : PPyObject) : PPyObject; +begin + Result := nil; +end; + +function TPyObject.NbDivmod( obj : PPyObject) : PPyObject; +begin + Result := nil; +end; + +function TPyObject.NbPower( ob1, ob2 : PPyObject) : PPyObject; +begin + Result := nil; +end; + +function TPyObject.NbNegative : PPyObject; +begin + Result := nil; +end; + +function TPyObject.NbPositive : PPyObject; +begin + Result := nil; +end; + +function TPyObject.NbAbsolute : PPyObject; +begin + Result := nil; +end; + +function TPyObject.NbNonZero : Integer; +begin + Result := -1; +end; + +function TPyObject.NbInvert : PPyObject; +begin + Result := nil; +end; + +function TPyObject.NbLShift( obj : PPyObject) : PPyObject; +begin + Result := nil; +end; + +function TPyObject.NbRShift( obj : PPyObject) : PPyObject; +begin + Result := nil; +end; + +function TPyObject.NbAnd( obj : PPyObject) : PPyObject; +begin + Result := nil; +end; + +function TPyObject.NbXor( obj : PPyObject) : PPyObject; +begin + Result := nil; +end; + +function TPyObject.NbOr( obj : PPyObject) : PPyObject; +begin + Result := nil; +end; + +function TPyObject.NbCoerce( obj : PPPyObject) : Integer; +begin + Result := 0; +end; + +function TPyObject.NbInt : PPyObject; +begin + Result := nil; +end; + +function TPyObject.NbLong : PPyObject; +begin + Result := nil; +end; + +function TPyObject.NbFloat : PPyObject; +begin + Result := nil; +end; + +function TPyObject.NbOct : PPyObject; +begin + Result := nil; +end; + +function TPyObject.NbHex : PPyObject; +begin + Result := nil; +end; + +function TPyObject.NbInplaceAdd(obj: PPyObject): PPyObject; +begin + Result := nil; +end; + +function TPyObject.NbInplaceAnd(obj: PPyObject): PPyObject; +begin + Result := nil; +end; + +function TPyObject.NbInplaceDivide(obj: PPyObject): PPyObject; +begin + Result := nil; +end; + +function TPyObject.NbInplaceFloorDivide( obj : PPyObject) : PPyObject; +begin + Result := nil; +end; + +function TPyObject.NbInplaceTrueDivide( obj : PPyObject) : PPyObject; +begin + Result := nil; +end; + +function TPyObject.NbInplaceLshift(obj: PPyObject): PPyObject; +begin + Result := nil; +end; + +function TPyObject.NbInplaceMultiply(obj: PPyObject): PPyObject; +begin + Result := nil; +end; + +function TPyObject.NbInplaceOr(obj: PPyObject): PPyObject; +begin + Result := nil; +end; + +function TPyObject.NbInplacePower(ob1, ob2: PPyObject): PPyObject; +begin + Result := nil; +end; + +function TPyObject.NbInplaceRemainder(obj: PPyObject): PPyObject; +begin + Result := nil; +end; + +function TPyObject.NbInplaceRshift(obj: PPyObject): PPyObject; +begin + Result := nil; +end; + +function TPyObject.NbInplaceSubtract(obj: PPyObject): PPyObject; +begin + Result := nil; +end; + +function TPyObject.NbInplaceXor(obj: PPyObject): PPyObject; +begin + Result := nil; +end; + +// Sequence services +function TPyObject.SqLength : Integer; +begin + Result := 0; +end; + +function TPyObject.SqConcat( obj : PPyObject) : PPyObject; +begin + Result := GetPythonEngine.ReturnNone; +end; + +function TPyObject.SqRepeat( val : Integer ) : PPyObject; +begin + Result := GetPythonEngine.ReturnNone; +end; + +function TPyObject.SqItem( idx : Integer ) : PPyObject; +begin + Result := GetPythonEngine.ReturnNone; +end; + +function TPyObject.SqSlice( idx1, idx2 : Integer ) : PPyObject; +begin + Result := GetPythonEngine.ReturnNone; +end; + +function TPyObject.SqAssItem( idx : integer; obj : PPyObject) : Integer; +begin + Result := -1; +end; + +function TPyObject.SqAssSlice( idx1, idx2 : Integer; obj : PPyObject): integer; +begin + Result := -1; +end; + +function TPyObject.SqContains(obj: PPyObject): integer; +begin + Result := -1; +end; + +function TPyObject.SqInplaceConcat(obj: PPyObject): PPyObject; +begin + Result := nil; +end; + +function TPyObject.SqInplaceRepeat(i: integer): PPyObject; +begin + Result := nil; +end; + +// Mapping services +function TPyObject.MpLength : Integer; +begin + Result := 0; +end; + +function TPyObject.MpSubscript( obj : PPyObject) : PPyObject; +begin + Result := GetPythonEngine.ReturnNone; +end; + +function TPyObject.MpAssSubscript( obj1, obj2 : PPyObject) : Integer; +begin + Result := -1; +end; + + +// Class methods +class procedure TPyObject.RegisterMethods( APythonType : TPythonType ); +begin +end; + +class procedure TPyObject.RegisterMembers( APythonType : TPythonType ); +begin +end; + +class procedure TPyObject.RegisterGetSets( APythonType : TPythonType ); +begin +end; + +class procedure TPyObject.SetupType(APythonType: TPythonType); +begin + +end; + + +////////////////////////////// +// TTypeServices + +constructor TTypeServices.Create; +begin + inherited; + FBasic := [bsGetAttr, bsSetAttr, bsRepr, bsStr]; +end; + +procedure TTypeServices.AssignTo( Dest: TPersistent ); +begin + if Dest is TTypeServices then + with TTypeServices( Dest ) do + begin + FBasic := Self.FBasic; + FNumber := Self.FNumber; + FSequence := Self.FSequence; + FMapping := Self.FMapping; + FInplaceNumber := Self.FInplaceNumber; + end; + inherited; +end; + +////////////////////////////// +// TPythonType + +function PythonToDelphi( obj : PPyObject ) : TPyObject; +begin + if IsDelphiObject( obj ) then + Result := TPyObject(PChar(obj)+Sizeof(PyObject)) + else + raise EPythonError.CreateFmt( 'Python object "%s" is not a Delphi class', [GetPythonEngine.PyObjectAsString(obj)] ); +end; + +procedure PyObjectDestructor( pSelf : PPyObject); cdecl; +var +{$IFDEF PYTHON22_OR_HIGHER} + call_tp_free : Boolean; +{$ENDIF} + obj : TPyObject; +begin + obj := PythonToDelphi(pSelf); +{$IFDEF PYTHON22_OR_HIGHER} + call_tp_free := obj.PythonAlloc; +{$ENDIF} + if PythonOk then + obj.Free; +{$IFDEF PYTHON22_OR_HIGHER} + if call_tp_free and Assigned(pSelf.ob_type) and Assigned(pSelf.ob_type^.tp_free) then + pSelf.ob_type^.tp_free(pSelf); +{$ENDIF} +end; + +procedure TPythonType.Notification( AComponent: TComponent; + Operation: TOperation); +begin + inherited; + if Operation = opRemove then + if AComponent = FModule then + FModule := nil; +end; + +procedure TPythonType.SetPyObjectClass( val : TPyObjectClass ); +begin + if val <> FPyObjectClass then + begin + if Assigned(FPyObjectClass) then + begin + ClearMethods; +{$IFDEF PYTHON22_OR_HIGHER} + ClearMembers; + ClearGetSets; +{$ENDIF} + end; + FPyObjectClass := val; + if Assigned(val) then + begin + FType.tp_basicsize := val.InstanceSize + Sizeof(PyObject); + val.SetupType( Self ); + val.RegisterMethods( Self ); + val.RegisterMembers( Self ); + val.RegisterGetSets( Self ); + end; + end; +end; + +procedure TPythonType.SetModule( val : TPythonModule ); +begin + if val <> FModule then + begin + FModule := val; + if Assigned(val) then + if Initialized and not (csLoading in ComponentState) then + if val.Initialized then + AddTypeVar + else + val.AddClient(Self); + end; +end; + +procedure TPythonType.ModuleReady(Sender : TObject); +begin + inherited; + AddTypeVar; +end; + +procedure TPythonType.SetServices( val : TTypeServices ); +begin + FServices.Assign( val ); +end; + +procedure TPythonType.SetTypeName( const val : String ); +begin + if (FTypeName <> val) and (val <> '') then + begin + FTypeName := val; + end; +end; + +function TPythonType.CreateMethod( pSelf, args : PPyObject ) : PPyObject; +begin + Result := CreateInstanceWith( args ); +end; + +procedure TPythonType.ReallocGetSets; +begin + inherited; +{$IFDEF PYTHON22_OR_HIGHER} + if tpfBaseType in TypeFlags then + FType.tp_getset := GetSetData; +{$ENDIF} +end; + +procedure TPythonType.ReallocMembers; +begin + inherited; +{$IFDEF PYTHON22_OR_HIGHER} + if tpfBaseType in TypeFlags then + FType.tp_members := MembersData; +{$ENDIF} +end; + +procedure TPythonType.ReallocMethods; +begin + inherited; +exit; +{$IFDEF PYTHON22_OR_HIGHER} + if tpfBaseType in TypeFlags then + FType.tp_methods := MethodsData; +{$ENDIF} +end; + +procedure TPythonType.SetDocString( value : TStringList ); +begin + FDocString.Assign( value ); +end; + +function TPythonType.TypeFlagsAsInt : LongInt; +begin + Result := 0; + if tpfHaveGetCharBuffer in TypeFlags then + Result := Result or Py_TPFLAGS_HAVE_GETCHARBUFFER; + if tpfHaveSequenceIn in TypeFlags then + Result := Result or Py_TPFLAGS_HAVE_SEQUENCE_IN; + if tpfGC in TypeFlags then + Result := Result or Py_TPFLAGS_GC; + if tpfHaveInplaceOps in TypeFlags then + Result := Result or Py_TPFLAGS_HAVE_INPLACEOPS; + if tpfCheckTypes in TypeFlags then + Result := Result or Py_TPFLAGS_CHECKTYPES; + if tpfHaveRichCompare in TypeFlags then + Result := Result or Py_TPFLAGS_HAVE_RICHCOMPARE; + if tpfHaveWeakRefs in TypeFlags then + Result := Result or Py_TPFLAGS_HAVE_WEAKREFS; +{$IFDEF PYTHON22_OR_HIGHER} + if tpfHaveIter in TypeFlags then + Result := Result or Py_TPFLAGS_HAVE_ITER; + if tpfHaveClass in TypeFlags then + Result := Result or Py_TPFLAGS_HAVE_CLASS; + if tpfHeapType in TypeFlags then + Result := Result or Py_TPFLAGS_HEAPTYPE; + if tpfBaseType in TypeFlags then + Result := Result or Py_TPFLAGS_BASETYPE; + if tpfReady in TypeFlags then + Result := Result or Py_TPFLAGS_READY; + if tpfReadying in TypeFlags then + Result := Result or Py_TPFLAGS_READYING; + if tpfHaveGC in TypeFlags then + Result := Result or Py_TPFLAGS_HAVE_GC; +{$ENDIF} +end; + +// Type services +// They will be all forwarded to the Delphi class that +// implements the object through the use of virtual +// methods +/////////////////////////////////////// + +// Basic services + +function TPythonType_Print( pSelf : PPyObject; var f: file; i: integer) : Integer; cdecl; +begin + Result := PythonToDelphi(pSelf).Print( f, i ); +end; + +function TPythonType_GetAttr( pSelf : PPyObject; key : PChar) : PPyObject; cdecl; +begin + Result := PythonToDelphi(pSelf).GetAttr( key ); +end; + +function TPythonType_SetAttr( pSelf : PPyObject; key : PChar; value : PPyObject) : Integer; cdecl; +begin + Result := PythonToDelphi(pSelf).SetAttr( key, value ); +end; + +function TPythonType_Repr( pSelf : PPyObject ) : PPyObject; cdecl; +begin + Result := PythonToDelphi(pSelf).Repr; +end; + +function TPythonType_Compare( pSelf, obj : PPyObject ) : Integer; cdecl; +begin + Result := PythonToDelphi(pSelf).Compare( obj ); +end; + +function TPythonType_Hash( pSelf : PPyObject) : Integer; cdecl; +begin + Result := PythonToDelphi(pSelf).Hash; +end; + +function TPythonType_Str( pSelf : PPyObject ) : PPyObject; cdecl; +begin + Result := PythonToDelphi(pSelf).Str; +end; + +function TPythonType_GetAttrO( pSelf, key: PPyObject) : PPyObject; cdecl; +begin + Result := PythonToDelphi(pSelf).GetAttrO( key ); +end; + +function TPythonType_SetAttrO( pSelf, key, value: PPyObject) : Integer; cdecl; +begin + Result := PythonToDelphi(pSelf).SetAttrO( key, value ); +end; + +function TPythonType_Call( pSelf, ob1, ob2 : PPyObject) : PPyObject; cdecl; +begin + Result := PythonToDelphi(pSelf).Call( ob1, ob2 ); +end; + +{$IFDEF PYTHON20_OR_HIGHER} +function TPythonType_Traverse( pSelf: PPyObject; proc: visitproc; ptr: Pointer) : integer; cdecl; +begin + Result := PythonToDelphi(pSelf).Traverse( proc, ptr ); +end; +{$ENDIF} + +function TPythonType_Clear( pSelf: PPyObject): integer; cdecl; +begin + Result := PythonToDelphi(pSelf).Clear; +end; + +function TPythonType_RichCmp( pSelf, obj : PPyObject; i : Integer) : PPyObject; cdecl; +begin + Assert(i >= Ord(Low(TRichComparisonOpcode))); + Assert(i <= Ord(High(TRichComparisonOpcode))); + Result := PythonToDelphi(pSelf).RichCompare( obj, TRichComparisonOpcode(i) ); +end; + +function TPythonType_Iter( pSelf: PPyObject) : PPyObject; cdecl; +begin + Result := PythonToDelphi(pSelf).Iter; +end; + +function TPythonType_IterNext( pSelf: PPyObject) : PPyObject; cdecl; +begin + Result := PythonToDelphi(pSelf).IterNext; +end; + +function TPythonType_InitSubtype( pSelf, args, kwds : PPyObject) : Integer; cdecl; +begin + Result := PythonToDelphi(pSelf).Init(args, kwds); +end; + +function TPythonType.NewSubtypeInst( aType: PPyTypeObject; args, kwds : PPyObject) : PPyObject; +{$IFDEF PYTHON22_OR_HIGHER} +var + obj : TPyObject; +{$ENDIF} +begin +{$IFDEF PYTHON22_OR_HIGHER} + Result := aType^.tp_alloc(aType, 0); + if Assigned(Result) then + begin + obj := PythonToDelphi(Result); + PyObjectClass.InitInstance(obj); + obj.ob_type := aType; + obj.IsSubtype := aType <> @FType; + obj.PythonAlloc := True; + obj.CreateWith(Self, args); + if Engine.PyErr_Occurred <> nil then + begin + Engine.Py_DECREF(Result); + Result := nil; + end; + end; +{$ELSE} + Result := nil; +{$ENDIF} +end; + +function TPythonType_AllocSubtypeInst( pSelf: PPyTypeObject; nitems : integer) : PPyObject; cdecl; +begin +{$IFDEF PYTHON22_OR_HIGHER} + Result := GetPythonEngine.PyType_GenericAlloc(pSelf, nitems); +{$ELSE} + Result := nil; +{$ENDIF} +end; + +procedure FreeSubtypeInst(ob:PPyObject); +begin +{$IFDEF PYTHON22_OR_HIGHER} + GetPythonEngine.PyObject_Free(ob); +{$ENDIF} +end; + + +// Number services + +function TPythonType_NbAdd( pSelf, obj : PPyObject) : PPyObject; cdecl; +begin + Result := PythonToDelphi(pSelf).NbAdd( obj ); +end; + +function TPythonType_NbSubstract( pSelf, obj : PPyObject) : PPyObject; cdecl; +begin + Result := PythonToDelphi(pSelf).NbSubstract( obj ); +end; + +function TPythonType_NbMultiply( pSelf, obj : PPyObject) : PPyObject; cdecl; +begin + Result := PythonToDelphi(pSelf).NbMultiply( obj ); +end; + +function TPythonType_NbDivide( pSelf, obj : PPyObject) : PPyObject; cdecl; +begin + Result := PythonToDelphi(pSelf).NbDivide( obj ); +end; + +function TPythonType_NbFloorDivide( pSelf, obj : PPyObject) : PPyObject; cdecl; +begin + Result := PythonToDelphi(pSelf).NbFloorDivide( obj ); +end; + +function TPythonType_NbTrueDivide( pSelf, obj : PPyObject) : PPyObject; cdecl; +begin + Result := PythonToDelphi(pSelf).NbTrueDivide( obj ); +end; + +function TPythonType_NbRemainder( pSelf, obj : PPyObject) : PPyObject; cdecl; +begin + Result := PythonToDelphi(pSelf).NbRemainder( obj ); +end; + +function TPythonType_NbDivmod( pSelf, obj : PPyObject) : PPyObject; cdecl; +begin + Result := PythonToDelphi(pSelf).NbDivmod( obj ); +end; + +function TPythonType_NbPower( pSelf, ob1, ob2 : PPyObject) : PPyObject; cdecl; +begin + Result := PythonToDelphi(pSelf).NbPower( ob1, ob2 ); +end; + +function TPythonType_NbNegative( pSelf : PPyObject ) : PPyObject; cdecl; +begin + Result := PythonToDelphi(pSelf).NbNegative; +end; + +function TPythonType_NbPositive( pSelf : PPyObject ) : PPyObject; cdecl; +begin + Result := PythonToDelphi(pSelf).NbPositive; +end; + +function TPythonType_NbAbsolute( pSelf : PPyObject ) : PPyObject; cdecl; +begin + Result := PythonToDelphi(pSelf).NbAbsolute; +end; + +function TPythonType_NbNonZero( pSelf : PPyObject ) : Integer; cdecl; +begin + Result := PythonToDelphi(pSelf).NbNonZero; +end; + +function TPythonType_NbInvert( pSelf : PPyObject ) : PPyObject; cdecl; +begin + Result := PythonToDelphi(pSelf).NbInvert; +end; + +function TPythonType_NbLShift( pSelf, obj : PPyObject) : PPyObject; cdecl; +begin + Result := PythonToDelphi(pSelf).NbLShift( obj ); +end; + +function TPythonType_NbRShift( pSelf, obj : PPyObject) : PPyObject; cdecl; +begin + Result := PythonToDelphi(pSelf).NbRShift( obj ); +end; + +function TPythonType_NbAnd( pSelf, obj : PPyObject) : PPyObject; cdecl; +begin + Result := PythonToDelphi(pSelf).NbAnd( obj ); +end; + +function TPythonType_NbXor( pSelf, obj : PPyObject) : PPyObject; cdecl; +begin + Result := PythonToDelphi(pSelf).NbXor( obj ); +end; + +function TPythonType_NbOr( pSelf, obj : PPyObject) : PPyObject; cdecl; +begin + Result := PythonToDelphi(pSelf).NbOr( obj ); +end; + +function TPythonType_NbCoerce( pSelf, obj : PPPyObject) : Integer; cdecl; +begin + Result := PythonToDelphi(pSelf^).NbCoerce( obj ); +end; + +function TPythonType_NbInt( pSelf : PPyObject ) : PPyObject; cdecl; +begin + Result := PythonToDelphi(pSelf).NbInt; +end; + +function TPythonType_NbLong( pSelf : PPyObject ) : PPyObject; cdecl; +begin + Result := PythonToDelphi(pSelf).NbLong; +end; + +function TPythonType_NbFloat( pSelf : PPyObject ) : PPyObject; cdecl; +begin + Result := PythonToDelphi(pSelf).NbFloat; +end; + +function TPythonType_NbOct( pSelf : PPyObject ) : PPyObject; cdecl; +begin + Result := PythonToDelphi(pSelf).NbOct; +end; + +function TPythonType_NbHex( pSelf : PPyObject ) : PPyObject; cdecl; +begin + Result := PythonToDelphi(pSelf).NbHex; +end; + +function TPythonType_NbInplaceAdd(pSelf, obj: PPyObject): PPyObject; cdecl; +begin + Result := PythonToDelphi(pSelf).NbInplaceAdd( obj ); +end; + +function TPythonType_NbInplaceAnd(pSelf, obj: PPyObject): PPyObject; cdecl; +begin + Result := PythonToDelphi(pSelf).NbInplaceAnd( obj ); +end; + +function TPythonType_NbInplaceDivide(pSelf, obj: PPyObject): PPyObject; cdecl; +begin + Result := PythonToDelphi(pSelf).NbInplaceDivide( obj ); +end; + +function TPythonType_NbInplaceFloorDivide( pSelf, obj : PPyObject) : PPyObject; cdecl; +begin + Result := PythonToDelphi(pSelf).NbInplaceFloorDivide( obj ); +end; + +function TPythonType_NbInplaceTrueDivide( pSelf, obj : PPyObject) : PPyObject; cdecl; +begin + Result := PythonToDelphi(pSelf).NbInplaceTrueDivide( obj ); +end; + +function TPythonType_NbInplaceLshift(pSelf, obj: PPyObject): PPyObject; cdecl; +begin + Result := PythonToDelphi(pSelf).NbInplaceLshift( obj ); +end; + +function TPythonType_NbInplaceMultiply(pSelf, obj: PPyObject): PPyObject; cdecl; +begin + Result := PythonToDelphi(pSelf).NbInplaceMultiply( obj ); +end; + +function TPythonType_NbInplaceOr(pSelf, obj: PPyObject): PPyObject; cdecl; +begin + Result := PythonToDelphi(pSelf).NbInplaceOr( obj ); +end; + +function TPythonType_NbInplacePower(pSelf, ob1, ob2: PPyObject): PPyObject; cdecl; +begin + Result := PythonToDelphi(pSelf).NbInplacePower( ob1, ob2 ); +end; + +function TPythonType_NbInplaceRemainder(pSelf, obj: PPyObject): PPyObject; cdecl; +begin + Result := PythonToDelphi(pSelf).NbInplaceRemainder( obj ); +end; + +function TPythonType_NbInplaceRshift(pSelf, obj: PPyObject): PPyObject; cdecl; +begin + Result := PythonToDelphi(pSelf).NbInplaceRshift( obj ); +end; + +function TPythonType_NbInplaceSubtract(pSelf, obj: PPyObject): PPyObject; cdecl; +begin + Result := PythonToDelphi(pSelf).NbInplaceSubtract( obj ); +end; + +function TPythonType_NbInplaceXor(pSelf, obj: PPyObject): PPyObject; cdecl; +begin + Result := PythonToDelphi(pSelf).NbInplaceXor( obj ); +end; + +// Sequence services + +function TPythonType_SqLength( pSelf : PPyObject ) : Integer; cdecl; +begin + Result := PythonToDelphi(pSelf).SqLength; +end; + +function TPythonType_SqConcat( pSelf, obj : PPyObject) : PPyObject; cdecl; +begin + Result := PythonToDelphi(pSelf).SqConcat( obj ); +end; + +function TPythonType_SqRepeat( pSelf : PPyObject; val : Integer ) : PPyObject; cdecl; +begin + Result := PythonToDelphi(pSelf).SqRepeat( val ); +end; + +function TPythonType_SqItem( pSelf : PPyObject; idx : Integer ) : PPyObject; cdecl; +begin + Result := PythonToDelphi(pSelf).SqItem( idx ); +end; + +function TPythonType_SqSlice( pSelf : PPyObject; idx1, idx2 : Integer ) : PPyObject; cdecl; +begin + Result := PythonToDelphi(pSelf).SqSlice( idx1, idx2 ); +end; + +function TPythonType_SqAssItem( pSelf : PPyObject; idx : integer; obj : PPyObject) : Integer; cdecl; +begin + Result := PythonToDelphi(pSelf).SqAssItem( idx, obj ); +end; + +function TPythonType_SqAssSlice( pSelf : PPyObject; idx1, idx2 : Integer; obj : PPyObject): integer; cdecl; +begin + Result := PythonToDelphi(pSelf).SqAssSlice( idx1, idx2, obj ); +end; + + +// Mapping services + +function TPythonType_MpLength( pSelf : PPyObject ) : Integer; cdecl; +begin + Result := PythonToDelphi(pSelf).MpLength; +end; + +function TPythonType_MpSubscript( pSelf, obj : PPyObject) : PPyObject; cdecl; +begin + Result := PythonToDelphi(pSelf).MpSubscript( obj ); +end; + +function TPythonType_MpAssSubscript( pSelf, obj1, obj2 : PPyObject) : Integer; cdecl; +begin + Result := PythonToDelphi(pSelf).MpAssSubscript( obj1, obj2 ); +end; + +function TPythonType_SqContains(pSelf, obj : PPyObject): integer; cdecl; +begin + Result := PythonToDelphi(pSelf).SqContains( obj ); +end; + +function TPythonType_SqInplaceConcat(pSelf, obj: PPyObject): PPyObject; cdecl; +begin + Result := PythonToDelphi(pSelf).SqInplaceConcat( obj ); +end; + +function TPythonType_SqInplaceRepeat(pSelf : PPyObject; i: integer): PPyObject; cdecl; +begin + Result := PythonToDelphi(pSelf).SqInplaceRepeat( i ); +end; + +procedure TPythonType.InitServices; +begin + with FType do + begin + // Basic services + if FDocString.Count > 0 then + begin + FCurrentDocString := GetPythonEngine.CleanString(FDocString.Text); +{$IFDEF PYTHON20_OR_HIGHER} + tp_doc := PChar(FCurrentDocString); +{$ENDIF} + end; + tp_dealloc := @PyObjectDestructor; + if bsGetAttr in Services.Basic then + tp_getattr := TPythonType_GetAttr; + if bsSetAttr in Services.Basic then + tp_setattr := TPythonType_SetAttr; + if bsRepr in Services.Basic then + tp_repr := TPythonType_Repr; + if bsStr in Services.Basic then + tp_str := TPythonType_Str; + if bsCompare in Services.Basic then + tp_compare := TPythonType_Compare; + if bsHash in Services.Basic then + tp_hash := TPythonType_Hash; + if bsGetAttrO in Services.Basic then + tp_getattro := TPythonType_GetAttrO; + if bsSetAttrO in Services.Basic then + tp_setattro := TPythonType_SetAttrO; + if bsCall in Services.Basic then + tp_call := TPythonType_Call; +{$IFDEF PYTHON20_OR_HIGHER} + if bsTraverse in Services.Basic then + tp_traverse := TPythonType_Traverse; + if bsClear in Services.Basic then + tp_clear := TPythonType_Clear; +{$ENDIF} +{$IFDEF PYTHON21_OR_HIGHER} + if bsRichCompare in Services.Basic then + tp_richcompare := TPythonType_RichCmp; +{$ENDIF} +{$IFDEF PYTHON22_OR_HIGHER} + if bsIter in Services.Basic then + tp_iter := TPythonType_Iter; + if bsIterNext in Services.Basic then + tp_iternext := TPythonType_IterNext; + if tpfBaseType in TypeFlags then + begin + tp_init := TPythonType_InitSubtype; + tp_alloc := TPythonType_AllocSubtypeInst; + tp_new := GetCallBack( Self, @TPythonType.NewSubtypeInst, 3, ctCDECL); + tp_free := FreeSubtypeInst; + tp_methods := MethodsData; + tp_members := MembersData; + tp_getset := GetSetData; + end; +{$ENDIF} + + // Number services + if Services.Number <> [] then + tp_as_number := @FNumber; + with FNumber do + begin + if nsAdd in Services.Number then + nb_add := TPythonType_NbAdd; + if nsSubstract in Services.Number then + nb_substract := TPythonType_NbSubstract; + if nsMultiply in Services.Number then + nb_multiply := TPythonType_NbMultiply; + if nsDivide in Services.Number then + nb_divide := TPythonType_NbDivide; +{$IFDEF PYTHON22_OR_HIGHER} + if nsFloorDivide in Services.Number then + nb_floor_divide := TPythonType_NbFloorDivide; + if nsTrueDivide in Services.Number then + nb_true_divide := TPythonType_NbTrueDivide; +{$ENDIF} + if nsRemainder in Services.Number then + nb_remainder := TPythonType_NbRemainder; + if nsDivmod in Services.Number then + nb_divmod := TPythonType_NbDivmod; + if nsPower in Services.Number then + nb_power := TPythonType_NbPower; + if nsNegative in Services.Number then + nb_negative := TPythonType_NbNegative; + if nsPositive in Services.Number then + nb_positive := TPythonType_NbPositive; + if nsAbsolute in Services.Number then + nb_absolute := TPythonType_NbAbsolute; + if nsNonZero in Services.Number then + nb_nonzero := TPythonType_NbNonZero; + if nsInvert in Services.Number then + nb_invert := TPythonType_NbInvert; + if nsLShift in Services.Number then + nb_lshift := TPythonType_NbLShift; + if nsRShift in Services.Number then + nb_rshift := TPythonType_NbRShift; + if nsAnd in Services.Number then + nb_and := TPythonType_NbAnd; + if nsXor in Services.Number then + nb_xor := TPythonType_NbXor; + if nsOr in Services.Number then + nb_or := TPythonType_NbOr; + if nsCoerce in Services.Number then + nb_coerce := TPythonType_NbCoerce; + if nsInt in Services.Number then + nb_int := TPythonType_NbInt; + if nsLong in Services.Number then + nb_long := TPythonType_NbLong; + if nsFloat in Services.Number then + nb_float := TPythonType_NbFloat; + if nsOct in Services.Number then + nb_oct := TPythonType_NbOct; + if nsHex in Services.Number then + nb_hex := TPythonType_NbHex; +{$IFDEF PYTHON20_OR_HIGHER} + if nsInplaceAdd in Services.InplaceNumber then + nb_inplace_add := TPythonType_NbInplaceAdd; + if nsInplaceSubtract in Services.InplaceNumber then + nb_inplace_subtract := TPythonType_NbInplaceSubtract; + if nsInplaceMultiply in Services.InplaceNumber then + nb_inplace_multiply := TPythonType_NbInplaceMultiply; + if nsInplaceDivide in Services.InplaceNumber then + nb_inplace_divide := TPythonType_NbInplaceDivide; +{$IFDEF PYTHON22_OR_HIGHER} + if nsInplaceFloorDivide in Services.InplaceNumber then + nb_inplace_floor_divide := TPythonType_NbInplaceFloorDivide; + if nsInplaceTrueDivide in Services.InplaceNumber then + nb_inplace_true_divide := TPythonType_NbInplaceTrueDivide; +{$ENDIF} + if nsInplaceRemainder in Services.InplaceNumber then + nb_inplace_remainder := TPythonType_NbInplaceRemainder; + if nsInplacePower in Services.InplaceNumber then + nb_inplace_power := TPythonType_NbInplacePower; + if nsInplaceLShift in Services.InplaceNumber then + nb_inplace_lshift := TPythonType_NbInplaceLShift; + if nsInplaceRShift in Services.InplaceNumber then + nb_inplace_rshift := TPythonType_NbInplaceRShift; + if nsInplaceAnd in Services.InplaceNumber then + nb_inplace_and := TPythonType_NbInplaceAnd; + if nsInplaceXor in Services.InplaceNumber then + nb_inplace_xor := TPythonType_NbInplaceXor; + if nsInplaceOr in Services.InplaceNumber then + nb_inplace_or := TPythonType_NbInplaceOr; +{$ENDIF} + end; + + // Sequence services + if Services.Sequence <> [] then + tp_as_sequence := @FSequence; + + with FSequence do + begin + if ssLength in Services.Sequence then + sq_length := TPythonType_SqLength; + if ssConcat in Services.Sequence then + sq_concat := TPythonType_SqConcat; + if ssRepeat in Services.Sequence then + sq_repeat := TPythonType_SqRepeat; + if ssItem in Services.Sequence then + sq_item := TPythonType_SqItem; + if ssSlice in Services.Sequence then + sq_slice := TPythonType_SqSlice; + if ssAssItem in Services.Sequence then + sq_ass_item := TPythonType_SqAssItem; + if ssAssSlice in Services.Sequence then + sq_ass_slice := TPythonType_SqAssSlice; +{$IFDEF PYTHON20_OR_HIGHER} + if ssContains in Services.Sequence then + sq_contains := TPythonType_SqContains; + if ssInplaceConcat in Services.Sequence then + sq_inplace_concat := TPythonType_SqInplaceConcat; + if ssInplaceRepeat in Services.Sequence then + sq_inplace_repeat := TPythonType_SqInplaceRepeat; +{$ENDIF} + end; + + // Mapping services + if Services.Mapping <> [] then + tp_as_mapping := @FMapping; + + with FMapping do + begin + if msLength in Services.Mapping then + mp_length := TPythonType_MpLength; + if msSubScript in Services.Mapping then + mp_subscript := TPythonType_MpSubscript; + if msAssSubscript in Services.Mapping then + mp_ass_subscript := TPythonType_MpAssSubscript; + end; + end; +end; + +// Public methods + +constructor TPythonType.Create( AOwner : TComponent ); +begin + inherited; + FPrefix := 'Create'; + FServices := TTypeServices.Create; + FDocString := TStringList.Create; + FTypeFlags := TPFLAGS_DEFAULT; + FGenerateCreateFunction := True; +end; + +destructor TPythonType.Destroy; +begin + if gVarType = Self then + gVarType := nil; + FDocString.Free; + FServices.Free; + inherited; +end; + +function TPythonType.GetTypePtr : PPyTypeObject; +begin + Result := PPyTypeObject(@FType); +end; + +procedure TPythonType.Initialize; +begin + CheckEngine; + with Engine, TheType do + begin + ob_type := PPyTypeObject(PyType_Type); + ob_refcnt := 1; + tp_name := PChar(FTypeName); +{$IFDEF PYTHON20_OR_HIGHER} + tp_flags := TypeFlagsAsInt; +{$ENDIF} + end; + if Assigned(FModule) then + begin + if Module.Initialized then + AddTypeVar + else + Module.AddClient( Self ); + end; + InitServices; + inherited; +end; + +procedure TPythonType.Finalize; +begin + Engine.Py_XDECREF(FCreateFunc); + FCreateFunc := nil; + inherited; +end; + +function TPythonType.CreateInstance : PPyObject; +var + obj : TPyObject; +begin + CheckEngine; + with Engine do + begin + obj := PyObjectClass.Create( Self ); + obj.ob_type := @FType; + if PyErr_Occurred <> nil then + begin + obj.Free; + Result := nil; + end + else + Result := obj.GetSelf; + end; +end; + +function TPythonType.CreateInstanceWith( args : PPyObject ) : PPyObject; +var + obj : TPyObject; +begin + CheckEngine; + with Engine do + begin + obj := PyObjectClass.CreateWith( Self, args ); + obj.ob_type := @FType; + if PyErr_Occurred <> nil then + begin + obj.Free; + Result := nil; + end + else + Result := obj.GetSelf; + end; +end; + +procedure TPythonType.AddTypeVar; +var + d : PPyObject; + meth : TDelphiMethod; +begin + CheckEngine; + Assert(Module <> nil); + Assert(Module.Module <> nil); + if FGenerateCreateFunction then + begin + FCreateFuncName := FPrefix+FTypeName; + FCreateFuncDoc := Format('Creates a new instance of type %s', [TypeName]); + if not Assigned(FCreateFunc) then + begin + meth := CreateMethod; + FCreateFuncDef.ml_name := PChar(FCreateFuncName); + FCreateFuncDef.ml_meth := GetOfObjectCallBack( TCallBack(meth), 2, ctCDECL); + FCreateFuncDef.ml_flags := METH_VARARGS; + FCreateFuncDef.ml_doc := PChar(FCreateFuncDoc); + FCreateFunc := Engine.PyCFunction_New(@FCreateFuncDef, nil); + end; + Assert(Assigned(FCreateFunc)); + end; + with Engine do + begin + d := PyModule_GetDict( Module.Module ); + Assert(Assigned(d)); + PyDict_SetItemString( d, PChar(TypeName), PPyObject(TheTypePtr) ); + if FGenerateCreateFunction then + PyDict_SetItemString( d, PChar(FCreateFuncName), FCreateFunc ); + end; +end; + +function TPythonType.GetMembersStartOffset : Integer; +begin + Result := Sizeof(PyObject); +end; + +(*******************************************************) +(** **) +(** class TPythonDelphiVar **) +(** **) +(*******************************************************) + +procedure TPythonDelphiVar.CreateVarType; +begin + if not Assigned(gVarType) then + begin + gVarType := TPythonType.Create( Self.Engine ); + with gVarType do + begin + TypeName := 'PythonDelphiVar'; + Engine := Self.Engine; + PyObjectClass := TPyVar; + Initialize; + end; + end; +end; + +procedure TPythonDelphiVar.CreateVar; +var + v : TPyVar; + m, d : PPyObject; +begin + if not Assigned(Engine) then + Exit; + Assert(Assigned(gVarType), 'missing TPythonType for TPythonDelphiVar'); + with Engine do + begin + // Create an instance of PythonDelphiVar + FVarObject := gVarType.CreateInstance; + CheckError(False); + v := TPyVar(PythonToDelphi(FVarObject)); + v.dv_component := Self; + // Add a reference to this var in the module + m := PyImport_AddModule(PChar(Module)); + if m = nil then + raise EPythonError.CreateFmt('CreateVar: can''t create module "%s"', [Module]); + d := PyModule_GetDict(m); + if @PyDict_SetItemString = nil then + raise Exception.Create('nil'); + PyDict_SetItemString( d, PChar(VarName), FVarObject ); + end; +end; + +function TPythonDelphiVar.GetValue : Variant; +begin + if Assigned( FVarObject ) then + with TPyVar(PythonToDelphi(FVarObject)) do + Result := GetValueAsVariant + else + raise Exception.Create('No variable was created' ); +end; + +procedure TPythonDelphiVar.SetValue( const val : Variant ); +begin + if Assigned( FVarObject ) then + with TPyVar(PythonToDelphi(FVarObject)) do + SetValueFromVariant(val) + else + raise Exception.Create('No variable was created' ); +end; + +// Warning: GetValueAsPyObject returns a preincremented object ! +function TPythonDelphiVar.GetValueAsPyObject : PPyObject; +begin + if Assigned( FVarObject ) then + with TPyVar(PythonToDelphi(FVarObject)) do + Result := GetValue + else + raise Exception.Create('No variable was created' ); +end; + +procedure TPythonDelphiVar.SetValueFromPyObject( val : PPyObject ); +begin + if Assigned( FVarObject ) then + with TPyVar(PythonToDelphi(FVarObject)) do + SetValue(val) + else + raise Exception.Create('No variable was created' ); +end; + +function TPythonDelphiVar.IsVariantOk( const v : Variant ) : Boolean; +var + t : Integer; +begin + t := VarType(v) and VarTypeMask; + Result := (t = varSmallint) or + (t = varInteger) or + (t = varSingle) or + (t = varDouble) or + (t = varCurrency) or + (t = varDate) or + (t = varOleStr) or + (t = varBoolean) or + (t = varByte) or + (t = varString); +end; + +function TPythonDelphiVar.GetValueAsString : String; +var + v : Variant; + obj : PPyObject; +begin + v := Value; + if IsVariantOk( v ) then + Result := v + else + begin + CheckEngine; + obj := GetValueAsPyObject; + try + Result := Engine.PyObjectAsString( obj ); + finally + Engine.Py_XDecRef(obj); + end; + end; +end; + +procedure TPythonDelphiVar.SetVarName( const val : String ); + + procedure CheckVarName; + var + i : Integer; + begin + if Owner = nil then Exit; + if (val = FVarName) or (val = '') then Exit; + for i := 0 to Owner.ComponentCount - 1 do + if Owner.Components[i] is TPythonDelphiVar then + with TPythonDelphiVar(Owner.Components[i]) do + if (VarName = val) and (Module = Self.Module) then + raise Exception.CreateFmt('A variable "%s" already exists in the module "%s"',[val, Module]); + end; + +begin + if val <> FVarName then + begin + CheckVarName; + FVarName := val; + end; +end; + +constructor TPythonDelphiVar.Create( AOwner : TComponent ); + + procedure AdjustName; + var + i, cpt : Integer; + done : Boolean; + begin + if AOwner = nil then Exit; + cpt := 1; + done := False; + while not done do + begin + done := True; + for i := 0 to AOwner.ComponentCount - 1 do + if AOwner.Components[i] is TPythonDelphiVar then + with TPythonDelphiVar(AOwner.Components[i]) do + if (VarName = Self.FVarName+IntToStr(cpt)) and + (Module = Self.Module) then + begin + Inc(cpt); + done := False; + Break; + end; + end; + FVarName := FVarName + IntToStr(cpt); + end; + +begin + inherited; + FModule := '__main__'; + FVarName := 'varname'; + if csDesigning in ComponentState then + AdjustName; +end; + +procedure TPythonDelphiVar.Initialize; +begin + if csDesigning in ComponentState then + Exit; + CheckEngine; + CreateVarType; + CreateVar; + inherited; +end; + +procedure TPythonDelphiVar.Finalize; +begin + inherited; + if not PythonOK then + Exit; + if Assigned(FVarObject) then + with TPyVar(PythonToDelphi(FVarObject)) do + begin + dv_component := nil; + SetValue( nil ); + end; + with Engine do + Py_XDECREF( FVarObject ); + FVarObject := nil; +end; + + +constructor TPyVar.Create( APythonType : TPythonType ); +begin + inherited; +end; + +// Don't call the Create constructor of TPyVar, because +// we call the inherited constructor CreateWith that calls +// the Create constructor first, and because the constructors +// are virtual, TPyVar.Create will be automatically be called. + +constructor TPyVar.CreateWith( APythonType : TPythonType; args : PPyObject ); +begin + inherited; + with GetPythonEngine do + begin + if PyArg_ParseTuple( args, 'O:CreateVar', [@dv_object] ) = 0 then + exit; + end; +end; + +destructor TPyVar.Destroy; +begin + with GetPythonEngine do + begin + if Assigned(dv_object) then + begin + Py_DecRef(dv_object); + dv_object := nil; + end; + end; + inherited; +end; + +// Then we override the needed services + +function TPyVar.GetAttr(key : PChar) : PPyObject; +begin + with GetPythonEngine do + begin + if CompareText( key, 'Value') = 0 then + Result := GetValue + else + Result := inherited GetAttr(key); + end; +end; + +function TPyVar.SetAttr(key : PChar; value : PPyObject) : Integer; +begin + Result := 0; + with GetPythonEngine do + begin + if CompareText( key, 'Value' ) = 0 then + SetValue( value ) + else + Result := inherited SetAttr(key, value); + end; +end; + +function TPyVar.Repr : PPyObject; +var + obj : PPyObject; +begin + with GetPythonEngine do + begin + obj := GetValue; + try + Result := PyString_FromString( PChar(Format('<%s: %s>', [PythonType.TypeName, PyObjectAsString(obj)])) ); + finally + Py_XDecRef(obj); + end; + end; +end; + +// Class methods +// We register the methods of our type + +class procedure TPyVar.RegisterMethods( APythonType : TPythonType ); +begin + inherited; + with APythonType do + begin + //AddMethod( 'OffsetBy', @TPyPoint.DoOffsetBy, 'Point.OffsetBy( dx, dy )' ); + end; +end; + +// Methods of TPyVar + + +// Warning: GetValue returns a preincremented object ! +function TPyVar.GetValue : PPyObject; +var + v : Variant; +begin + Result := nil; + with GetPythonEngine do + begin + if Assigned( dv_component ) and + (@dv_component.OnExtGetData <> nil) then + begin + dv_component.OnExtGetData( dv_component, Result ); + end + else if Assigned( dv_component ) and + (@dv_component.OnGetData <> nil) then + begin + dv_component.OnGetData( dv_component, v ); + Result := VariantAsPyObject(v); + end + else if Assigned(dv_object) then + begin + Result := dv_object; + Py_XIncRef(Result); + end; + if Result = nil then + Result := ReturnNone; + end; +end; + +function TPyVar.GetValueAsVariant : Variant; +var + obj : PPyObject; +begin + with GetPythonEngine do + begin + obj := GetValue; + try + try + Result := PyObjectAsVariant( obj ); + except + Result := PyObjectAsString(obj); + end; + finally + Py_XDecRef(obj); + end; + end; +end; + +procedure TPyVar.SetValue( value : PPyObject ); +begin + with GetPythonEngine do + begin + if Assigned( dv_component ) and + (@dv_component.OnExtSetData <> nil) then + begin + dv_component.OnExtSetData( dv_component, value); + end + else if Assigned( dv_component ) and + (@dv_component.OnSetData <> nil) then + begin + dv_component.OnSetData( dv_component, PyObjectAsVariant(value) ); + end; + Py_XDecRef(dv_object); + dv_object := value; + Py_XIncRef(dv_object); + if Assigned( dv_component ) and + (@dv_component.OnChange <> nil) then + dv_component.OnChange( dv_component ); + end; +end; + +procedure TPyVar.SetValueFromVariant( const value : Variant ); +var + obj : PPyObject; +begin + with GetPythonEngine do + begin + obj := VariantAsPyObject( value ); + SetValue(obj); + Py_XDecRef(obj); + end; +end; + +(*******************************************************) +(** **) +(** class TPythonThread **) +(** **) +(*******************************************************) + +procedure TPythonThread.Execute; +var + withinterp: Boolean; +begin + withinterp := Assigned( fInterpreterState); + with GetPythonEngine do + begin + if withinterp then + begin + fThreadExecMode := emNewState; + fThreadState := PyThreadState_New( fInterpreterState); + if Assigned(fThreadState) then + begin + PyEval_AcquireThread(fThreadState); + ExecuteWithPython; + PyEval_ReleaseThread( fThreadState); + PyThreadState_Clear( fThreadState); + PyThreadState_Delete( fThreadState); + end else + raise EPythonError.Create( 'Could not create a new thread state'); + end else {withinterp} + begin + fThreadExecMode := emNewInterpreter; + PyEval_AcquireLock; + fThreadState := Py_NewInterpreter; + if Assigned( fThreadState) then + begin + ExecuteWithPython; + Py_EndInterpreter( fThreadState); + PyEval_ReleaseLock; + end else + raise EPythonError.Create( 'Could not create a new thread state'); + end; {withinterp} + end; +end; + + +procedure TPythonThread.Py_Begin_Allow_Threads; +begin + with GetPythonEngine do + f_savethreadstate := PyEval_SaveThread; +end; + +procedure TPythonThread.Py_End_Allow_Threads; +begin + with GetPythonEngine do + PyEval_RestoreThread( f_savethreadstate); +end; + +procedure TPythonThread.Py_Begin_Block_Threads; +begin + Py_End_Allow_Threads; +end; + +procedure TPythonThread.Py_Begin_Unblock_Threads; +begin + Py_Begin_Allow_Threads; +end; + + +(*******************************************************) +(** **) +(** Methods for new Python objects or modules **) +(** **) +(*******************************************************) + +///////////////////////////////////////////////////////// +// Module pyio for Python Input/Outputs +// + +function pyio_write(self, args : PPyObject) : PPyObject; +var + a1 : PPyObject; +begin + // Forbid printing for any other thread than the main one + {$IFNDEF FPC} + if GetCurrentThreadId <> MainThreadId then + with GetPythonEngine do + begin + if RedirectIO and (IO <> nil) and (IO.ClassName <> 'TPythonInputOutput') then + begin + Result := GetPythonEngine.ReturnNone; + Exit; + end; + end; + {$ENDIF} + with GetPythonEngine do + begin + if Assigned(args) and (PyTuple_Size(args) > 0) then + begin + a1 := PyTuple_GetItem(args, 0); + if RedirectIO and (IO <> nil) and Assigned(a1) then + begin +{$IFDEF UNICODE_SUPPORT} + if PyUnicode_Check(a1) then + IO.Write(PyUnicode_AsWideString(a1)) + else +{$ENDIF} + if PyString_Check(a1) then + IO.Write(PyObjectAsString(a1)); + end; + Result := ReturnNone; + end + else + begin + PyErr_BadArgument; + Result := nil; + end; + end; +end; + +function pyio_read(self, args : PPyObject) : PPyObject; +var + txt, msg : String; +{$IFDEF UNICODE_SUPPORT} + Widetxt : WideString; +{$ENDIF} +begin + with GetPythonEngine do + begin + if RedirectIO then + begin + txt := ''; + msg := 'Enter text'; + if Assigned(IO) then +{$IFDEF UNICODE_SUPPORT} + if IO.UnicodeIO then begin + Widetxt := IO.ReceiveUniData; + // KV!!!!!! + if PyErr_Occurred <> nil then + Result := nil + else + // KV!!!!!! + Result := PyUnicode_FromWideString(PWideChar(Widetxt)); + end else begin + txt := IO.ReceiveData; + // KV!!!!!! + if PyErr_Occurred <> nil then + Result := nil + else + // KV!!!!!! + Result := PyString_FromString(PChar(txt)); + end + else + Result := PyString_FromString(PChar(txt)); +{$ELSE} + txt := IO.ReceiveData; + Result := PyString_FromString(PChar(txt)); +{$ENDIF} + end + else + Result := ReturnNone; + end; +end; + +function pyio_SetDelayWrites(self, args : PPyObject) : PPyObject; +var + val : Integer; +begin + with GetPythonEngine do + begin + if PyArg_ParseTuple( args, 'i:SetDelayWrites', [@val] ) <> 0 then + begin + if IO <> nil then + IO.DelayWrites := val <> 0; + Result := ReturnNone; + end + else + Result := nil; + end; +end; + +function pyio_SetMaxLines(self, args : PPyObject) : PPyObject; +var + val : Integer; +begin + with GetPythonEngine do + begin + if PyArg_ParseTuple( args, 'i:SetMaxLines', [@val] ) <> 0 then + begin + if IO <> nil then + IO .MaxLines := val; + Result := ReturnNone; + end + else + Result := nil; + end; +end; + +// With no args, it will look at all types +// With args, it will look only at the types listed in the args. + +// It returns a list of tuples. Each tuple contains: +// the Type name, the InstanceCount, the CreateHits and the DeleteHits + +function pyio_GetTypesStats(self, args : PPyObject) : PPyObject; + + function HandleType( T : TPythonType ) : PPyObject; + begin + with GetPythonEngine do + begin + Result := PyTuple_New(4); + PyTuple_SetItem( Result, 0, PyString_FromString(PChar(T.TypeName)) ); + PyTuple_SetItem( Result, 1, PyInt_FromLong(T.InstanceCount) ); + PyTuple_SetItem( Result, 2, PyInt_FromLong(T.CreateHits) ); + PyTuple_SetItem( Result, 3, PyInt_FromLong(T.DeleteHits) ); + end; + end; + + function FindType( const TName : String ) : TPythonType; + var + i : Integer; + begin + Result := nil; + with GetPythonEngine do + for i := 0 to ClientCount - 1 do + if Clients[i] is TPythonType then + with TPythonType(Clients[i]) do + if TypeName = TName then + begin + Result := TPythonType(Clients[i]); + Break; + end; + end; + +var + i : Integer; + T : TPythonType; + obj : PPyObject; + str : String; +begin + with GetPythonEngine do + begin + Result := PyList_New(0); + if PyTuple_Size(args) > 0 then + for i := 0 to PyTuple_Size(args)-1 do + begin + str := PyObjectAsString( PyTuple_GetItem(args, i) ); + T := FindType( str ); + if Assigned(T) then + begin + obj := HandleType( T ); + PyList_Append( Result, obj ); + Py_XDecRef(obj); + end; + end + else + for i := 0 to ClientCount - 1 do + if Clients[i] is TPythonType then + begin + obj := HandleType( TPythonType(Clients[i]) ); + PyList_Append( Result, obj ); + Py_XDecRef(obj); + end; + end; +end; + + + + + +(*******************************************************) +(** **) +(** Global procedures **) +(** **) +(*******************************************************) + +function GetPythonEngine : TPythonEngine; +begin + if not Assigned( gPythonEngine ) then + raise Exception.Create( 'No Python engine was created' ); + if not gPythonEngine.Finalizing then + if not gPythonEngine.Initialized then + raise Exception.Create( 'The Python engine is not properly initialized' ); + Result := gPythonEngine; +end; + +function PythonOK : Boolean; +begin + Result := Assigned( gPythonEngine ) and + (gPythonEngine.Initialized or gPythonEngine.Finalizing); +end; + +function IsDelphiObject( obj : PPyObject ) : Boolean; +var + t : PPyTypeObject; +begin + Result := False; + // Here's a simple trick: we compare the object destructor to + // our special destructor for Delphi objects, or + // we check if one of the parent types of obj has a Delphi destructor. + if Assigned(obj) then + begin + t := obj^.ob_type; + while Assigned(t) do + begin + if @t^.tp_dealloc = @PyObjectDestructor then + begin + Result := True; + Break; + end; +{$IFDEF PYTHON22_OR_HIGHER} + t := t^.tp_base; +{$ELSE} + t := nil; +{$ENDIF} + end; + end; +end; + +procedure Register; +begin + RegisterComponents('Python',[ TPythonEngine, TPythonInputOutput, + TPythonType, TPythonModule, TPythonDelphiVar]); +end; + +{$IFDEF PYTHON20_OR_HIGHER} +function PyType_HasFeature(AType : PPyTypeObject; AFlag : Integer) : Boolean; +begin + //(((t)->tp_flags & (f)) != 0) + Result := (((AType)^.tp_flags and (AFlag)) <> 0); +end; +{$ENDIF} + +end. + + + + + + + diff --git a/Readme.txt b/Readme.txt index f35a3d2ff..fd2fc02af 100644 --- a/Readme.txt +++ b/Readme.txt @@ -3,15 +3,17 @@ To compile the PythonIDE.dpr, you first need to install the following components - Python for Delphi (www.mmm-experts.com) In the Definitions.inc file activate the conditional define PREFER_UNICODE - - JVCL version 3.3 (jvcl.sf.net) and JCL version 1.98 (jcl.sf.net) + - JVCL version 3.31 (jvcl.sf.net) and JCL version 1.99 (jcl.sf.net) - Toolbar2000 version 2.1.8 (www.jrsoftware.org/tb2k.php) - TBX version 2.1b (from www.g32.org/tbx) - Download from http://club.telepolis.com/silverpointdev and apply the TB2k v2.1.8 - TBX v2.1 patch before installing Toolbar 2000 and TBX + - Tntware Delphi Unicode Controls + - SpTBXLibe Note that you can download the patch.exe tool from http://unxutils.sourceforge.net/ - Note also that If you want a painless TB2k+TBX installation for Delphi you can download the Multiinstaller from - http://club.telepolis.com/silverpointdev/multiinstaller/index.htm and follow the instructions provided in that page. You do not need TNT or SpTBXLib. - + Note also that If you want a painless TB2k+TBX+TNT Unicode+SpTBXLibe installation for Delphi you can download the Multiinstaller from + http://club.telepolis.com/silverpointdev/multiinstaller/index.htm and follow the instructions provided in that page. + - Download and install JvTBXLib.zip from mxs.bergsoft.net (no need to bother with the rest of TBXLib). - Download from http://www.rmklever.com/delphitbx.html the themes by Roy Magne Klever @@ -19,16 +21,11 @@ To compile the PythonIDE.dpr, you first need to install the following components - From the same site download the Office2003 theme by Yury Plashenkov - Copy the above themes to the TBX folder. No need to install them. - - Tntware Delphi Unicode Controls from http://www.tntware.com/delphicontrols/unicode/ + - Tntware Delphi LX Controls from http://www.tntware.com/delphicontrols/lx/ - Unicode version of SynEdit (synedit.sf.net) at http://mh-nexus.de/unisynedit.htm - VirtualTreeView (www.delphi-gems.com) at http://www.delphi-gems.com/VirtualTreeview/ - VirtualShellTools EasyListView and the "Mustangpeak Common Library" (www.mustangpeak.net) - In the file VSToolsAddins.inc in the "Include" directory enable the USE_TOOLBAR_TB2 flag and follow the instructions - for recompiling the packages - -If you have managed to do all the above then you should be able to compile PyScripter! (:)) - - - + In the file VSToolsAddins.inc in the "Include" directory enable the USE_TOOLBAR_TB2K flag and follow the instructions for recompiling the packages +If you have managed to do all the above then you should be able to compile PyScripter! :) diff --git a/SynHighlighterPython.pas b/SynHighlighterPython.pas index 414866987..9c0c18419 100644 --- a/SynHighlighterPython.pas +++ b/SynHighlighterPython.pas @@ -289,13 +289,14 @@ function TSynPythonSyn.GetKeywordIdentifiers: TWideStringList; ); // List of non-keyword identifiers - NONKEYWORDCOUNT = 65; + NONKEYWORDCOUNT = 68; NONKEYWORDS: array [1..NONKEYWORDCOUNT] of WideString = ( '__future__', '__import__', 'abs', 'apply', + 'bool', 'buffer', 'callable', 'chr', @@ -313,6 +314,7 @@ function TSynPythonSyn.GetKeywordIdentifiers: TWideStringList; 'file', 'filter', 'float', + 'frozenset', 'getattr', 'globals', 'hasattr', @@ -346,6 +348,7 @@ function TSynPythonSyn.GetKeywordIdentifiers: TWideStringList; 'repr', 'round', 'self', + 'set', 'setattr', 'slice', 'str', diff --git a/TBXOffice2003Theme.pas b/TBXOffice2003Theme.pas new file mode 100644 index 000000000..787aa97fe --- /dev/null +++ b/TBXOffice2003Theme.pas @@ -0,0 +1,2154 @@ +unit TBXOffice2003Theme; + +// TBX Package +// Copyright 2001-2004 Alex A. Denisov. All Rights Reserved +// See TBX.chm for license and installation instructions +// +// Office2003 theme +// Copyright (c) Yury Plashenkov (feb 2005) +// mailto:plashenkov@mail.ru +// +// Version for TBX version 2.1 + +{~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~} +(* +* 2006-08-23 +* The Office 2003 theme. +* +* Fully rewrited by Vladimir Bochkarev +* Have a lot changes, improvements and bug fixes. +* +* For correct work required patched TBX 2.1.beta (fourth edition patch). +* +* You can change a kind and behaviour of this theme, using defines below. +* +* You also can set style used by default in run-time using +* "TBXOffice2003Theme_Default_Color_Scheme" global variable. +* For example: TBXOffice2003Theme_Default_Color_Scheme := osMetallic; +*) +{~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~} + +interface + +// TPNGImage (written by Gustavo Daud) allows you to work with semitransparent PNG-images +// I advise you to get it from http://pngdelphi.sourceforge.net +// after downloading, install it and TPNGImageList component from PNGImgList.pas +// uncomment next string if you have TPNGImage and TPNGImageList installed +{x$DEFINE PNGIMAGELIST} + +{ Comment next string if you not want to see highlighted icons } +{$DEFINE HIGHLIGHT_TOOLBAR_ICONS} + +{ Miscellaneous } +{.$DEFINE AUTO_ADAPT_TO_MS_LUNA_SCHEME} +{$DEFINE XP_THEMED_CHECKBOX_AND_RADIOBUTTON} + +{ Popup shadow } +{$DEFINE USE_XP_POPUP_SHADOW_WHEN_POSSIBLE} + +{ Close buttons } +{$DEFINE SMALL_CLOSE_BUTTON_ON_DOCKED_TOOLBAR} +{$DEFINE SMALL_CLOSE_BUTTON_ON_DOCKED_DOCKPANEL} +{$DEFINE SMALL_CLOSE_BUTTON_ON_FLOATING_XXX} + +{ Gradients } +{$DEFINE GRADIENT_FILL_BACKGROUND} +{$DEFINE GRADIENT_FILL_STATUSBAR} +{$DEFINE VERTICAL_GRADIENT_FILL_FLOATING_TOOLBAR} + +{$I TB2Ver.inc} +{$I TBX.inc} + +uses + Windows, Messages, Graphics, ImgList, TBXThemes + {$IFDEF PNGIMAGELIST}, PNGImgList{$ENDIF}; + +type + TItemPart = (ipBody, ipText, ipFrame); + TBtnItemState = (bisNormal, bisDisabled, bisSelected, bisPressed, bisHot, + bisDisabledHot, bisSelectedHot, bisPopupParent); + TMenuItemState = (misNormal, misDisabled, misHot, misDisabledHot); + TWinFramePart = (wfpBorder, wfpCaption, wfpCaptionText); + TOffice2003Scheme = (osBlue, osMetallic, osGreen, osAuto); + + TTBXOffice2003Theme = class(TTBXTheme) + private + FMaxWindowWidth: Integer; + procedure TBXSysCommand(var Message: TMessage); message TBX_SYSCOMMAND; + protected + DockColor1: TColor; + DockColor2: TColor; + ToolbarColor1: TColor; + ToolbarColor2: TColor; + ToolbarFrameColor1: TColor; + ToolbarFrameColor2: TColor; + SeparatorColor1: TColor; + SeparatorColor2: TColor; + DragHandleColor1: TColor; + DragHandleColor2: TColor; + + EmbeddedColor: TColor; + EmbeddedFrameColor: TColor; + EmbeddedDisabledColor: TColor; + + PopupColor: TColor; + PopupFrameColor: TColor; + + DockPanelColor: TColor; + + WinFrameColors: array[TWinFramePart] of TColor; + MenuItemColors: array[TMenuItemState, TItemPart] of TColor; + BtnItemColors: array[TBtnItemState, ipText..ipFrame] of TColor; + BtnBodyColors: array[TBtnItemState, Boolean] of TColor; + + StatusPanelFrameColor: TColor; + FMDIAreaColor: TColor; + FFaceColor: TColor; + FWindowColor: TColor; + + procedure DrawCloseButton(DC: HDC; R: TRect; BtnItemState: TBtnItemState; + Gradient, Small: Boolean; Color: TColor); virtual; + function GetBtnColor(const ItemInfo: TTBXItemInfo; ItemPart: TItemPart; GradColor2: Boolean = False): TColor; + procedure GetGradientColors(X1, X2: Integer; out Color1, Color2: TColor); + function GetPartColor(const ItemInfo: TTBXItemInfo; ItemPart: TItemPart): TColor; + procedure SetupColorCache; virtual; + public + constructor Create(const AName: String); override; + destructor Destroy; override; + + function GetBooleanMetrics(Index: Integer): Boolean; override; + function GetIntegerMetrics(Index: Integer): Integer; override; + procedure GetMargins(MarginID: Integer; out Margins: TTBXMargins); override; + function GetImageOffset(Canvas: TCanvas; const ItemInfo: TTBXItemInfo; ImageList: TCustomImageList): TPoint; override; + function GetItemColor(const ItemInfo: TTBXItemInfo): TColor; override; + function GetItemTextColor(const ItemInfo: TTBXItemInfo): TColor; override; + function GetItemImageBackground(const ItemInfo: TTBXItemInfo): TColor; override; + function GetPopupShadowType: Integer; override; + procedure GetViewBorder(ViewType: Integer; out Border: TPoint); override; + function GetViewColor(AViewType: Integer): TColor; override; + procedure GetViewMargins(ViewType: Integer; out Margins: TTBXMargins); override; + + procedure PaintBackgnd(Canvas: TCanvas; const ADockRect, ARect, AClipRect: TRect; AColor: TColor; Transparent: Boolean; AViewType: Integer); override; + procedure PaintButton(Canvas: TCanvas; const ARect: TRect; const ItemInfo: TTBXItemInfo); override; + procedure PaintCaption(Canvas: TCanvas; const ARect: TRect; const ItemInfo: TTBXItemInfo; const ACaption: string; AFormat: Cardinal; Rotated: Boolean); override; + procedure PaintCheckMark(Canvas: TCanvas; ARect: TRect; const ItemInfo: TTBXItemInfo); override; + procedure PaintChevron(Canvas: TCanvas; ARect: TRect; const ItemInfo: TTBXItemInfo); override; + procedure PaintDock(Canvas: TCanvas; const ClientRect, DockRect: TRect; DockPosition: Integer); override; + procedure PaintDockPanelNCArea(Canvas: TCanvas; R: TRect; const DockPanelInfo: TTBXDockPanelInfo); override; + procedure PaintDropDownArrow(Canvas: TCanvas; const ARect: TRect; const ItemInfo: TTBXItemInfo); override; + procedure PaintEditButton(Canvas: TCanvas; const ARect: TRect; var ItemInfo: TTBXItemInfo; ButtonInfo: TTBXEditBtnInfo); override; + procedure PaintEditFrame(Canvas: TCanvas; const ARect: TRect; var ItemInfo: TTBXItemInfo; const EditInfo: TTBXEditInfo); override; + procedure PaintFloatingBorder(Canvas: TCanvas; const ARect: TRect; const WindowInfo: TTBXWindowInfo); override; + procedure PaintFrame(Canvas: TCanvas; const ARect: TRect; const ItemInfo: TTBXItemInfo); override; + procedure PaintFrameControl(Canvas: TCanvas; R: TRect; Kind, State: Integer; Params: Pointer); override; + procedure PaintImage(Canvas: TCanvas; ARect: TRect; const ItemInfo: TTBXItemInfo; ImageList: TCustomImageList; ImageIndex: Integer); override; + procedure PaintMDIButton(Canvas: TCanvas; ARect: TRect; const ItemInfo: TTBXItemInfo; ButtonKind: Cardinal); override; + procedure PaintMenuItem(Canvas: TCanvas; const ARect: TRect; var ItemInfo: TTBXItemInfo); override; + procedure PaintMenuItemFrame(Canvas: TCanvas; const ARect: TRect; const ItemInfo: TTBXItemInfo); override; + procedure PaintPageScrollButton(Canvas: TCanvas; const ARect: TRect; ButtonType: Integer; Hot: Boolean); override; + procedure PaintPopupNCArea(Canvas: TCanvas; R: TRect; const PopupInfo: TTBXPopupInfo); override; + procedure PaintSeparator(Canvas: TCanvas; ARect: TRect; ItemInfo: TTBXItemInfo; Horizontal, LineSeparator: Boolean); override; + procedure PaintToolbarNCArea(Canvas: TCanvas; R: TRect; const ToolbarInfo: TTBXToolbarInfo); override; + procedure PaintStatusBar(Canvas: TCanvas; R: TRect; Part: Integer); override; + + property MDIAreaColor: TColor read FMDIAreaColor; + end; + +var + TBXOffice2003Theme_Default_Color_Scheme: TOffice2003Scheme = osBlue; + +function GetOffice2003Scheme: TOffice2003Scheme; +function GetMDIWorkspaceColor: TColor; +procedure PaintGradient(DC: HDC; const ARect: TRect; Color1, Color2: TColor; Horz: Boolean); +procedure PaintIrregularGradient(DC: HDC; const ARect: TRect; Color1, Color2: TColor; Horz: Boolean); + +implementation + +uses Controls, SysUtils, CommCtrl, Forms, Types, + TB2Common, TB2Item, TBXUxThemes, TBXUtils; + +(******************************************************************************) +{ Misc. } +(******************************************************************************) + +//{$IFDEF AUTO_ADAPT_TO_MS_LUNA_SCHEME} +function GetOffice2003Scheme: TOffice2003Scheme; +var + ThemeFileName: array[0..MAX_PATH] of WideChar; + ColorSchemeName: array[0..15] of WideChar; + ColorSchemeNameA: String; +begin + if (TBXOffice2003Theme_Default_Color_Scheme = osAuto) and + USE_THEMES and (GetCurrentThemeName(ThemeFileName, High(ThemeFileName), + ColorSchemeName, High(ColorSchemeName), nil, 0) = S_OK) and + SameText(ExtractFileName(ThemeFileName), 'Luna.MSStyles') then + begin + ColorSchemeNameA := ColorSchemeName; + if SameText(ColorSchemeNameA, 'NormalColor') then + Result := osBlue + else if SameText(ColorSchemeNameA, 'Metallic') then + Result := osMetallic + else if SameText(ColorSchemeNameA, 'HomeStead') then + Result := osGreen + else Result := osAuto; + end + else Result := TBXOffice2003Theme_Default_Color_Scheme; +end; +//{$ELSE} +//function GetOffice2003Scheme: TOffice2003Scheme; +//begin +// Result := TBXOffice2003Theme_Default_Color_Scheme; +//end; +//{$ENDIF} + +function GetMDIWorkspaceColor: TColor; +const + MDIColors: array[TOffice2003Scheme] of TColor = + ($AE9990, $B39A9B, $7BA097, clBtnShadow); +begin + Result := MDIColors[GetOffice2003Scheme]; +end; + +procedure PaintGradient(DC: HDC; const ARect: TRect; Color1, Color2: TColor; + Horz: Boolean); +begin + GradFill(DC, ARect, Color1, Color2, TGradientKind(not Horz)); +end; + +var + IrregularGradientCenterColor: TColor; + +procedure PaintIrregularGradient(DC: HDC; const ARect: TRect; + Color1, Color2: TColor; Horz: Boolean); +var + CC: TColor; + R: TRect; +begin + if IsRectEmpty(ARect) then Exit; + if not SameColors(Color1, Color2) then + begin + CC := IrregularGradientCenterColor; + R := ARect; + if Horz then + begin + R.Right := (R.Left + R.Right - 1) div 2; + GradFill(DC, R, Color1, CC, gkHorz); + + R.Left := R.Right; R.Right := R.Left+ 1; + FillRectEx(DC, R, CC); + + R.Left := R.Right; R.Right := ARect.Right; + GradFill(DC, R, CC, Color2, gkHorz); + end + else begin + R.Bottom := (R.Top + R.Bottom - 1) div 2; + GradFill(DC, R, Color1, CC, gkVert); + + R.Top := R.Bottom; R.Bottom := R.Top+ 1; + FillRectEx(DC, R, CC); + + R.Top := R.Bottom; R.Bottom := ARect.Bottom; + GradFill(DC, R, CC, Color2, gkVert); + end; + end + else FillRectEx(DC, ARect, Color1); +end; + +procedure DrawSmCaptionText(DC: HDC; Text: PChar; const R: TRect; + TextColor: TColor; Vertical: Boolean); +const + DrawTextFlags = DT_SINGLELINE or DT_VCENTER or DT_END_ELLIPSIS or DT_NOPREFIX; +var + OldFont: HFONT; + OldBkMode: Integer; + OldTextColor: TColorRef; +begin + if TextColor < 0 then TextColor := GetSysColor(TextColor and $FF); + OldFont := SelectObject(DC, SmCaptionFont.Handle); + OldBkMode := SetBkMode(DC, TRANSPARENT); + OldTextColor := SetTextColor(DC, TextColor); + if not Vertical + then DrawTextEx(DC, Text, -1, PRect(@R)^, DrawTextFlags, nil) + else DrawRotatedText(DC, Text, R, DrawTextFlags); + SetTextColor(DC, OldTextColor); + SetBkMode(DC, OldBkMode); + SelectObject(DC, OldFont); +end; + +function GetCloseBtnItemState(BtnState: Integer): TBtnItemState; +begin + if (BtnState and CDBS_PRESSED) <> 0 + then Result := bisPressed + else if (BtnState and CDBS_HOT) <> 0 + then Result := bisHot + else Result := bisNormal; +end; + +var + StockImgList: TCustomImageList; + +function GetGlyphsImList: TCustomImageList; +begin + Result := StockImgList; + if not Assigned(Result) then + begin + Result := TImageList.Create(nil); + Result.Handle := ImageList_LoadBitmap(HInstance, 'TBXGLYPHS', 16, 0, clWhite); + StockImgList := Result; + end; +end; + +procedure FinalizeStock; +begin + FreeAndNil(StockImgList); +end; + +(******************************************************************************) +{ TTBXOffice2003Theme } +(******************************************************************************) + +constructor TTBXOffice2003Theme.Create(const AName: String); +begin + inherited; + AddTBXSysChangeNotification(Self); + SetupColorCache; +end; + +destructor TTBXOffice2003Theme.Destroy; +begin + RemoveTBXSysChangeNotification(Self); + FinalizeStock; + inherited; +end; + +function TTBXOffice2003Theme.GetBooleanMetrics(Index: Integer): Boolean; +begin + Result := Index in [ + TMB_OFFICEXPPOPUPALIGNMENT, + TMB_EDITMENUFULLSELECT, + TMB_PAINTDOCKBACKGROUND, + {$IFNDEF GRADIENT_FILL_BACKGROUND} + TMB_SOLIDTOOLBARNCAREA, + {$ENDIF} + TMB_SOLIDTOOLBARCLIENTAREA]; +end; + +function TTBXOffice2003Theme.GetIntegerMetrics(Index: Integer): Integer; +begin + case Index of + TMI_SPLITBTN_ARROWWIDTH: Result := 12; + + TMI_DROPDOWN_ARROWWIDTH: Result := 8; + TMI_DROPDOWN_ARROWMARGIN: Result := 3; + + TMI_MENU_IMGTEXTSPACE: Result := 5; + TMI_MENU_LCAPTIONMARGIN: Result := 4; + TMI_MENU_RCAPTIONMARGIN: Result := 3; + TMI_MENU_SEPARATORSIZE: Result := 3; + TMI_MENU_MDI_DW: Result := 2; + TMI_MENU_MDI_DH: Result := 2; + + TMI_TLBR_SEPARATORSIZE: Result := 6; + + TMI_EDIT_FRAMEWIDTH: Result := 1; + TMI_EDIT_TEXTMARGINHORZ: Result := 2; + TMI_EDIT_TEXTMARGINVERT: Result := 2; + TMI_EDIT_BTNWIDTH: Result := 14; + TMI_EDIT_MENURIGHTINDENT: Result := 1; + else + Result := -1; + end; +end; + +procedure TTBXOffice2003Theme.GetMargins(MarginID: Integer; out Margins: TTBXMargins); +const + CMargins: array[0..MID_STATUSPANE] of record L, R, T, B: Byte end = ( + (L:0;R:0;T:0;B:0),(L:2;R:2;T:2;B:2),(L:1;R:1;T:3;B:3),(L:1;R:1;T:1;B:3)); +begin + if not (MarginID in [MID_TOOLBARITEM,MID_MENUITEM,MID_STATUSPANE]) then + MarginID := 0; + with Margins, CMargins[MarginID] do + begin + LeftWidth := L; + RightWidth := R; + TopHeight := T; + BottomHeight := B; + end; +end; + +function TTBXOffice2003Theme.GetImageOffset(Canvas: TCanvas; + const ItemInfo: TTBXItemInfo; ImageList: TCustomImageList): TPoint; +begin + SetPoint(Result, 0, 0); +end; + +function TTBXOffice2003Theme.GetItemColor(const ItemInfo: TTBXItemInfo): TColor; +begin + Result := GetPartColor(ItemInfo, ipBody); + if Result = clNone then Result := GetViewColor(ItemInfo.ViewType); +end; + +function TTBXOffice2003Theme.GetItemTextColor(const ItemInfo: TTBXItemInfo): TColor; +begin + Result := GetPartColor(ItemInfo, ipText); +end; + +function TTBXOffice2003Theme.GetItemImageBackground(const ItemInfo: TTBXItemInfo): TColor; +begin + Result := GetBtnColor(ItemInfo, ipBody); + if Result = clNone then Result := GetViewColor(ItemInfo.ViewType); +end; + +function TTBXOffice2003Theme.GetPopupShadowType: Integer; +begin + {$IFDEF USE_XP_POPUP_SHADOW_WHEN_POSSIBLE} + if USE_THEMES then + Result := PST_WINDOWSXP + else + {$ENDIF} + Result := PST_OFFICEXP; +end; + +procedure TTBXOffice2003Theme.GetViewBorder(ViewType: Integer; out Border: TPoint); +const + XMetrics: array[Boolean] of Byte = (SM_CXDLGFRAME, SM_CXFRAME); + YMetrics: array[Boolean] of Byte = (SM_CYDLGFRAME, SM_CYFRAME); +var + Resizable: Boolean; +begin + if (ViewType and (VT_TOOLBAR or VT_DOCKPANEL)) <> 0 then + begin + if (ViewType and TVT_FLOATING) <> 0 then + begin + Resizable := (ViewType and TVT_RESIZABLE) <> 0; + Border.X := GetSystemMetrics(XMetrics[Resizable])- 1; + Border.Y := GetSystemMetrics(YMetrics[Resizable])- 1; + end + else SetPoint(Border, 2, 2); + end + else if (ViewType and VT_POPUP) <> 0 then + begin + Border.X := Ord((ViewType and PVT_POPUPMENU) <> PVT_POPUPMENU)+ 1; {1, 2} + Border.Y := 2; + end + else SetPoint(Border, 0, 0); +end; + +function TTBXOffice2003Theme.GetViewColor(AViewType: Integer): TColor; +begin + if (AViewType and VT_TOOLBAR) <> 0 then + begin + if (AViewType and TVT_MENUBAR) = TVT_MENUBAR + then Result := DockColor1 + else Result := ToolbarColor1; + end + else if (AViewType and VT_POPUP) <> 0 then + begin + if (AViewType and PVT_LISTBOX) = PVT_LISTBOX + then Result := FWindowColor + else Result := PopupColor; + end + else if (AViewType and VT_DOCKPANEL) <> 0 + then Result := DockPanelColor + else Result := DockColor1; +end; + +procedure TTBXOffice2003Theme.GetViewMargins(ViewType: Integer; + out Margins: TTBXMargins); +var + I: Integer; +begin + I := 0; + with Margins do + begin + LeftWidth := I; RightWidth := I; + TopHeight := I; BottomHeight := I; + end; +end; + +procedure TTBXOffice2003Theme.PaintBackgnd(Canvas: TCanvas; + const ADockRect, ARect, AClipRect: TRect; AColor: TColor; + Transparent: Boolean; AViewType: Integer); +var + DC: HDC; + R: TRect; + IsToolbar, Horz: Boolean; +begin + if Transparent or not IntersectRect(R, ARect, AClipRect) then Exit; + DC := Canvas.Handle; + IsToolbar := (AViewType and TVT_NORMALTOOLBAR) = TVT_NORMALTOOLBAR; + if (IsToolbar or ((AViewType and TVT_TOOLWINDOW) = TVT_TOOLWINDOW)) and + ((AViewType and TVT_EMBEDDED) = 0) then + begin + {$IFDEF VERTICAL_GRADIENT_FILL_FLOATING_TOOLBAR} + if IsToolbar and ((AViewType and TVT_FLOATING) <> 0) then + Horz := True + else + {$ENDIF} + if (AViewType and TVT_FLOATING) <> 0 + then Horz := ARect.Right > ARect.Bottom + else Horz := ARect.Right- ARect.Left > ARect.Bottom- ARect.Top; + PaintIrregularGradient(DC, ARect, ToolbarColor1, ToolbarColor2, not Horz); + end + else begin + {$IFDEF GRADIENT_FILL_BACKGROUND} + if (AViewType and TVT_MENUBAR) = TVT_MENUBAR then + begin + if (AViewType and TVT_FLOATING) = 0 + then PaintDock(Canvas, ARect, ADockRect, DP_TOP) + else PaintDock(Canvas, ARect, ARect, DP_TOP); + end + else + {$ENDIF} + FillRectEx(DC, R, AColor); + end; +end; + +procedure TTBXOffice2003Theme.PaintButton(Canvas: TCanvas; const ARect: TRect; + const ItemInfo: TTBXItemInfo); +var + DC: HDC; + R: TRect; + C1, C2: TColor; +begin + R := ARect; + DC := Canvas.Handle; + with ItemInfo do + begin + if ((ItemOptions and IO_DESIGNING) <> 0) and not Selected then + begin + if ComboPart = cpSplitRight then Dec(R.Left); + FrameRectEx(DC, R, NearestBlendedColor(ToolbarColor2, clBlack, 90), False); + end + else begin + FrameRectEx(DC, R, GetBtnColor(ItemInfo, ipFrame), True); + + if ComboPart = cpSplitRight + then Dec(R.Left) + else if (ComboPart = cpSplitLeft) and IsPopupParent then Inc(R.Right); + + C1 := GetBtnColor(ItemInfo, ipBody); + if C1 <> clNone then + begin + if ((ViewType and (VT_TOOLBAR or VT_POPUP)) <> 0) and + ((ViewType and TVT_EMBEDDED) <> 0) + then + FillRectEx(DC, R, C1) + else begin + C2 := GetBtnColor(ItemInfo, ipBody, True); + if C2 <> clNone then PaintGradient(DC, R, C1, C2, IsVertical); + end; + end; + end; + if ComboPart = cpSplitRight then PaintDropDownArrow(Canvas, R, ItemInfo); + end; +end; + +procedure TTBXOffice2003Theme.PaintCaption(Canvas: TCanvas; + const ARect: TRect; const ItemInfo: TTBXItemInfo; const ACaption: string; + AFormat: Cardinal; Rotated: Boolean); +var + DC: HDC; + OldBkMode: Integer; +begin + if Canvas.Font.Color = clNone then + Canvas.Font.Color := GetPartColor(ItemInfo, ipText); + DC := Canvas.Handle; + OldBkMode := SetBkMode(DC, TRANSPARENT); + if not Rotated + then DrawTextEx(DC, PChar(ACaption), Length(ACaption), PRect(@ARect)^, AFormat, nil) + else DrawRotatedText(DC, ACaption, ARect, AFormat); + SetBkMode(DC, OldBkMode); +end; + +procedure TTBXOffice2003Theme.PaintCheckMark(Canvas: TCanvas; ARect: TRect; + const ItemInfo: TTBXItemInfo); +const + CheckMarkPattern: array[0..6] of TPoint = ( + (X:-3; Y:-1), (X:-1; Y: 1), (X: 3; Y:-3), (X: 3; Y:-2), + (X:-1; Y: 2), (X:-3; Y: 0), (X:-3; Y:-1)); +var + DC: HDC; + X, Y: Integer; + C1, C2: TColor; +begin + GetRectCenter(ARect, X, Y); + C1 := GetBtnColor(ItemInfo, ipText); + DC := Canvas.Handle; + if (ItemInfo.ItemOptions and IO_RADIO) <> 0 then + begin + if ItemInfo.Enabled + then C2 := NearestMixedColor(C1, GetBtnColor(ItemInfo, ipBody), 32) + else C2 := NearestMixedColor(ToolbarColor1, ToolbarColor2, 127); + ARect := Rect(X-2, Y-2, X+3, Y+3); + FrameRectEx(DC, ARect, C2, False); + RoundRectEx(DC, ARect, 5, 5, C1, C1); + end + else DrawPattern(DC, X, Y, CheckMarkPattern, C1, False); +end; + +procedure TTBXOffice2003Theme.PaintChevron(Canvas: TCanvas; ARect: TRect; + const ItemInfo: TTBXItemInfo); +const + ChevronPattern: array[Boolean, 0..15] of Byte = ( + ($CC, 0, $66, 0, $33, 0, $66, 0, $CC, 0, 0, 0, 0, 0, 0, 0), + ($88, 0, $D8, 0, $70, 0, $20, 0, $88, 0, $D8, 0, $70, 0, $20, 0)); +begin + with ItemInfo do + if Selected or Pushed or (HoverKind <> hkNone) then + PaintButton(Canvas, ARect, ItemInfo); + if not ItemInfo.IsVertical then + begin + ARect.Left := (ARect.Left + ARect.Right) div 2 - 4; + ARect.Top := ARect.Top + 4; + end + else begin + ARect.Left := ARect.Right - 9; + ARect.Top := (ARect.Top + ARect.Bottom) div 2 - 4; + end; + DrawGlyph(Canvas.Handle, ARect.Left, ARect.Top, + ChevronPattern[ItemInfo.IsVertical], GetPartColor(ItemInfo, ipText)); +end; + +procedure TTBXOffice2003Theme.PaintDock(Canvas: TCanvas; const ClientRect, + DockRect: TRect; DockPosition: Integer); +var + DC: HDC; + R: TRect; + {$IFDEF GRADIENT_FILL_BACKGROUND} + P: TPoint; + C1, C2: TColor; + {$ENDIF} +begin + DC := Canvas.Handle; + if (GetClipBox(DC, R) in [SIMPLEREGION, COMPLEXREGION]) and + RectsIntersect(DockRect, R) then + {$IFDEF GRADIENT_FILL_BACKGROUND} + { Get the dock position } + if GetCurrentPositionEx(DC, @P) + then GetGradientColors(P.X and $FFFF, P.Y and $FFFF, C1, C2) + else begin + C1 := DockColor1; + C2 := DockColor2; + end; + PaintGradient(DC, DockRect, C1, C2, True); + {$ELSE} + FillRectEx(DC, R, DockColor1); + {$ENDIF} +end; + +procedure TTBXOffice2003Theme.PaintDockPanelNCArea(Canvas: TCanvas; R: TRect; + const DockPanelInfo: TTBXDockPanelInfo); +var + DC: HDC; + CI, CapSize: Integer; + R2: TRect; + C: TColor; + BtnItemState: TBtnItemState; +begin + CI := ColorIntensity(FFaceColor); + R2 := R; + DC := Canvas.Handle; + with DockPanelInfo do + begin + { Frame } + if not TBXLoColor and (CI in [64..250]) then + begin + C := ToolbarColor2; + FrameRectEx(DC, R2, C, True); + FrameRectEx(DC, R2, EffectiveColor, False); + end + else begin + FrameRectEx(DC, R2, EffectiveColor, True); + if CI < 64 then C := clWhite else C := clBtnShadow; + DitherFrame(DC, R2, EffectiveColor, C); + C := EffectiveColor; + end; + with R2 do + begin + SetPixelV(DC, Left, Top, C); + if IsVertical then Left := Right-1 else Top := Bottom-1; + SetPixelV(DC, Left, Top, C); + end; + + { Caption } + if not ShowCaption then Exit; + { Background } + R2 := R; + InflateRect(R2, -BorderSize.X, -BorderSize.Y); + CapSize := GetSystemMetrics(SM_CYSMCAPTION)- 1; + if IsVertical then + begin + R2.Bottom := R2.Top + CapSize; + DrawLineEx(DC, R2.Left, R2.Bottom, R2.Right, R2.Bottom, EffectiveColor); + end + else begin + R2.Right := R2.Left + CapSize; + DrawLineEx(DC, R2.Right, R2.Top, R2.Right, R2.Bottom, EffectiveColor); + end; + PaintGradient(DC, R2, ToolbarColor1, ToolbarColor2, not IsVertical); + { Close button } + if (CloseButtonState and CDBS_VISIBLE) <> 0 then + begin + R := R2; + if IsVertical then + begin + R.Left := R.Right - CapSize; + R2.Right := R.Left + 2; + end + else begin + R.Top := R.Bottom - CapSize; + R2.Bottom := R.Top + 2; + end; + BtnItemState := GetCloseBtnItemState(CloseButtonState); + {$IFDEF SMALL_CLOSE_BUTTON_ON_DOCKED_DOCKPANEL} + DrawCloseButton(DC, R, BtnItemState, True, True, BtnItemColors[BtnItemState, ipText]); + {$ELSE} + DrawCloseButton(DC, R, BtnItemState, True, False, BtnItemColors[BtnItemState, ipText]); + {$ENDIF} + end; + { Text } + if IsVertical then InflateRectHorz(R2, -4) else InflateRectVert(R2, -4); + DrawSmCaptionText(DC, Caption, R2, SmCaptionFont.Color, not IsVertical); + end; +end; + +procedure TTBXOffice2003Theme.PaintDropDownArrow(Canvas: TCanvas; + const ARect: TRect; const ItemInfo: TTBXItemInfo); +const + ArrowPattern: array[Boolean, 0..2] of TPoint = ( + ((X:-2; Y:-1), (X: 2; Y:-1), (X: 0; Y: 1)), + ((X: 0; Y: 1), (X: 0; Y:-3), (X:-2; Y:-1))); +begin + DrawPattern(Canvas.Handle, GetRectCenter(ARect), + ArrowPattern[ItemInfo.IsVertical], GetPartColor(ItemInfo, ipText), True); +end; + +procedure TTBXOffice2003Theme.PaintEditButton(Canvas: TCanvas; const ARect: TRect; + var ItemInfo: TTBXItemInfo; ButtonInfo: TTBXEditBtnInfo); +var + DC: HDC; + BR: TRect; + State: set of (OnToolbar, Embedded, Enabled, Hot, Pressed); + + procedure CalcButtonRect(DownArrow: Boolean); + begin + BR := ARect; + if (State * [Embedded, Hot, Pressed] <> []) or + not (OnToolbar in State) then + begin + InflateRect(BR, 1, 1); + Inc(BR.Left); + end; + if ButtonInfo.ButtonType = EBT_SPIN then + begin + if DownArrow + then BR.Top := (BR.Top + BR.Bottom) div 2 + else BR.Bottom := (BR.Top + BR.Bottom + 1) div 2; + end; + end; + + procedure DrawButtonBody; + var + SavePushed: Boolean; + begin + if State * [Embedded, Hot, Pressed] = [] then + begin + if OnToolbar in State then + begin + DrawLineEx(DC, BR.Left-1, BR.Top, BR.Left-1, BR.Bottom, FWindowColor); + FrameRectEx(DC, BR, FWindowColor, False); + end; + end + else begin + SavePushed := ItemInfo.Pushed; + ItemInfo.Pushed := Pressed in State; + PaintButton(Canvas, BR, ItemInfo); + ItemInfo.Pushed := SavePushed; + end; + end; + + procedure DrawButton(DownArrow: Boolean); + const + ArrowPattern: array[Boolean, 0..2] of TPoint = ( + ((X:-2; Y: 1), (X: 2; Y: 1), (X: 0; Y:-1)), + ((X:-2; Y:-1), (X: 2; Y:-1), (X: 0; Y: 1))); + begin + CalcButtonRect(DownArrow); + if Enabled in State then DrawButtonBody; + if not DownArrow then Dec(BR.Bottom); + DrawPattern(DC, GetRectCenter(BR), ArrowPattern[DownArrow], + GetPartColor(ItemInfo, ipText), True); + end; + +begin + State := [Enabled]; + if (ItemInfo.ViewType and VT_TOOLBAR) <> 0 then + begin + Include(State, OnToolbar); + if ((ItemInfo.ViewType and TVT_EMBEDDED) <> 0) then Include(State, Embedded); + end; + DC := Canvas.Handle; + with ButtonInfo do + begin + if ButtonType = EBT_DROPDOWN then + begin + if (ButtonState and EBDS_DISABLED) <> 0 then Exclude(State, Enabled); + if (ButtonState and EBDS_HOT) <> 0 then Include(State, Hot); + if (ButtonState and EBDS_PRESSED) <> 0 then Include(State, Pressed); + DrawButton(True); + end + else if ButtonType = EBT_SPIN then + begin + if (ButtonState and EBSS_DISABLED) <> 0 then Exclude(State, Enabled); + if (ButtonState and EBSS_HOT) <> 0 then Include(State, Hot); + { Upper button } + if (ButtonState and EBSS_UP) <> 0 then Include(State, Pressed); + DrawButton(False); + Exclude(State, Pressed); + { Lower button } + if (ButtonState and EBSS_DOWN) <> 0 then Include(State, Pressed); + DrawButton(True); + end; + end; +end; + +procedure TTBXOffice2003Theme.PaintEditFrame(Canvas: TCanvas; const ARect: TRect; + var ItemInfo: TTBXItemInfo; const EditInfo: TTBXEditInfo); +var + DC: HDC; + IsToolbar, Embedded: Boolean; + R: TRect; + C: TColor; + W: Integer; +begin + IsToolbar := (ItemInfo.ViewType and VT_TOOLBAR) <> 0; + Embedded := IsToolbar and ((ItemInfo.ViewType and TVT_EMBEDDED) <> 0); + + R := ARect; + DC := Canvas.Handle; + with ItemInfo do + begin + if ((ViewType and TVT_FLOATING) <> 0) and Enabled and + not (Pushed or Selected or (HoverKind <> hkNone)) + then + RectangleEx(DC, R, ToolbarColor2, GetPartColor(ItemInfo, ipBody)) + else begin + if ((ItemOptions and IO_DESIGNING) <> 0) and not Selected + then C := NearestBlendedColor(ToolbarColor2, clBlack, 90) + else C := GetPartColor(ItemInfo, ipFrame); + FrameRectEx(DC, R, C, False); + end; + end; + + W := EditFrameWidth; + InflateRect(R, -W, -W); + + if not (ItemInfo.Enabled or Embedded) then + FrameRectEx(DC, R, ToolbarColor2, False); + + with EditInfo do + if RightBtnWidth > 0 then Dec(R.Right, RightBtnWidth - 2); + + if ItemInfo.Enabled then + begin + if not IsToolbar and (GetPartColor(ItemInfo, ipFrame) = clNone) then + begin + RectangleEx(DC, R, ToolbarColor2, FWindowColor); + if EditInfo.RightBtnWidth > 0 then + begin + R := ARect; + InflateRect(R, -1, -1); + R.Left := R.Right - EditInfo.RightBtnWidth + 1; + FrameRectEx(DC, R, ToolbarColor2, False); + end; + end + else FillRectEx(DC, R, FWindowColor); + end; + + if EditInfo.RightBtnWidth > 0 then + begin + R := ARect; + InflateRect(R, -W, -W); + R.Left := R.Right - EditInfo.RightBtnWidth; + PaintEditButton(Canvas, R, ItemInfo, EditInfo.RightBtnInfo); + end; +end; + +procedure TTBXOffice2003Theme.PaintFloatingBorder(Canvas: TCanvas; + const ARect: TRect; const WindowInfo: TTBXWindowInfo); +var + DC: HDC; + R, CR: TRect; + Sz: TPoint; + CapSize: Integer; + C, LineColor, CapColor, TextColor: TColor; + BtnItemState: TBtnItemState; +begin + DC := Canvas.Handle; + + if (WindowInfo.RedrawPart and WRP_BORDER) <> 0 then + begin + R := ARect; + Sz := WindowInfo.FloatingBorderSize; + + SaveDC(DC); + with R, Sz do + ExcludeClipRect(DC, Left+X, Top+Y, Right-X, Bottom-Y); + FillRectEx(DC, R, WinFrameColors[wfpBorder]); + RestoreDC(DC, -1); + + OffsetPoint(Sz, -1, -1); + InflateRect(R, -Sz.X, -Sz.Y); + + {$IFDEF GRADIENT_FILL_BACKGROUND} + if (WindowInfo.ViewType and TVT_MENUBAR) = TVT_MENUBAR then + begin + with R do + begin + GetGradientColors(0, Right, LineColor, C); + DrawLineEx(DC, Left, Top+1, Left, Bottom-1, DockColor1); + PaintGradient(DC, Rect(Left+1, Top, Right-1, Top+1), DockColor1, C, True); + PaintGradient(DC, Rect(Left+1, Bottom-1, Right-1, Bottom), DockColor1, C, True); + DrawLineEx(DC, Right-1, Top+1, Right-1, Bottom-1, C); + end; + end + else + {$ENDIF} + begin + if (WindowInfo.ViewType and VT_DOCKPANEL) <> 0 + then C := WindowInfo.EffectiveColor + else C := DockColor1; + RoundFrameEx(DC, R, 2, 2, C); + end; + end; + + if not WindowInfo.ShowCaption then Exit; + + if ((WindowInfo.RedrawPart and WRP_CAPTION) <> 0) or + ((WindowInfo.CloseButtonState and CDBS_VISIBLE) <> 0) then + begin + CapSize := GetSystemMetrics(SM_CYSMCAPTION)- 1; + CR := Rect(0, 0, WindowInfo.ClientWidth, CapSize); + with WindowInfo.FloatingBorderSize do OffsetRect(CR, X, Y); + + CapColor := WinFrameColors[wfpCaption]; + TextColor := WinFrameColors[wfpCaptionText]; + + if ((WindowInfo.ViewType and TVT_MENUBAR) = TVT_MENUBAR) or + ((WindowInfo.ViewType and TVT_TOOLWINDOW) = TVT_TOOLWINDOW) + then + LineColor := DockColor1 + else if (WindowInfo.ViewType and VT_DOCKPANEL) <> 0 + then LineColor := WindowInfo.EffectiveColor + else LineColor := ToolbarColor1; + + { Caption } + if (WindowInfo.RedrawPart and WRP_CAPTION) <> 0 then + begin + R := CR; + if (WindowInfo.CloseButtonState and CDBS_VISIBLE) <> 0 then + Dec(R.Right, CapSize); + + FillRectEx(DC, R, CapColor); + DrawLineEx(DC, R.Left, R.Bottom, R.Right, R.Bottom, LineColor); + + Inc(R.Left, 2); Dec(R.Right, 1); + DrawSmCaptionText(DC, WindowInfo.Caption, R, TextColor, False); + end; + { Close button } + if ((WindowInfo.CloseButtonState and CDBS_VISIBLE) <> 0) and + ((WindowInfo.RedrawPart and WRP_CLOSEBTN) <> 0) then + begin + R := CR; + R.Left := R.Right- CapSize; + + FillRectEx(DC, R, CapColor); + DrawLineEx(DC, R.Left, R.Bottom, R.Right, R.Bottom, LineColor); + + BtnItemState := GetCloseBtnItemState(WindowInfo.CloseButtonState); + if BtnItemState = bisNormal + then C := TextColor + else C := BtnItemColors[BtnItemState, ipText]; + {$IFDEF SMALL_CLOSE_BUTTON_ON_FLOATING_XXX} + DrawCloseButton(DC, R, BtnItemState, False, True, C); + {$ELSE} + DrawCloseButton(DC, R, BtnItemState, False, False, C); + {$ENDIF} + end; + end; +end; + +procedure TTBXOffice2003Theme.PaintFrame(Canvas: TCanvas; const ARect: TRect; + const ItemInfo: TTBXItemInfo); +begin + RectangleEx(Canvas.Handle, ARect, GetPartColor(ItemInfo, ipFrame), + GetPartColor(ItemInfo, ipBody)); +end; + +procedure TTBXOffice2003Theme.PaintFrameControl(Canvas: TCanvas; R: TRect; + Kind, State: Integer; Params: Pointer); +const + CheckMarkPattern: array[0..6] of TPoint = ( + (X:-3; Y: 1), (X:-1; Y: 3), (X: 3; Y:-1), (X: 3; Y:-3), + (X:-1; Y: 1), (X:-3; Y:-1), (X:-3; Y: 1)); + XPPartId: array[Boolean] of Byte = (BP_RADIOBUTTON, BP_CHECKBOX); + + function GetXPStateFlags: Integer; + begin + if Kind = PFC_CHECKBOX then + if (State and PFS_MIXED) <> 0 then Result := CBS_MIXEDNORMAL else + if (State and PFS_CHECKED) <> 0 then Result := CBS_CHECKEDNORMAL else + Result := CBS_UNCHECKEDNORMAL + else + if (State and PFS_CHECKED) <> 0 + then Result := RBS_CHECKEDNORMAL + else Result := RBS_UNCHECKEDNORMAL; + + if (State and PFS_DISABLED) <> 0 then Inc(Result, 3) else + if (State and PFS_PUSHED) <> 0 then Inc(Result, 2) else + if (State and PFS_HOT) <> 0 then Inc(Result); + end; + + procedure GetColors(out OutlineColor, FillColor, MarkColor: TColor); + begin + if (State and PFS_DISABLED) <> 0 then + begin + OutlineColor := clBtnShadow; + FillColor := NearestMixedColor(FWindowColor, FFaceColor, 127); + MarkColor := BtnItemColors[bisDisabled, ipText]; + end + else if (State and PFS_PUSHED) <> 0 then + begin + OutlineColor := BtnItemColors[bisPressed, ipFrame]; + FillColor := BtnBodyColors[bisPressed, False]; + MarkColor := BtnItemColors[bisPressed, ipText]; + end + else if (State and PFS_HOT) <> 0 then + begin + OutlineColor := BtnItemColors[bisHot, ipFrame]; + FillColor := BtnBodyColors[bisHot, False]; + MarkColor := BtnItemColors[bisHot, ipText]; + end + else if (State and PFS_MIXED) <> 0 then + begin + OutlineColor := EmbeddedFrameColor; + FillColor := NearestMixedColor(FWindowColor, FFaceColor, 127); + MarkColor := clBtnShadow; + end + else begin + OutlineColor := EmbeddedFrameColor; + FillColor := clNone; + MarkColor := BtnItemColors[bisNormal, ipText]; + end; + end; + +var + DC: HDC; + OutlineColor, FillColor, MarkColor: TColor; +begin + DC := Canvas.Handle; + {$IFDEF XP_THEMED_CHECKBOX_AND_RADIOBUTTON} + if USE_THEMES then + begin +// DrawThemeBackground(XPTheme(tcButton), DC, XPPartId[Kind = PFC_CHECKBOX], +// GetXPStateFlags, R, nil); KV + DrawThemeBackground(BUTTON_THEME, DC, XPPartId[Kind = PFC_CHECKBOX], + GetXPStateFlags, R, nil); + end + else + {$ENDIF} + begin + InflateRect(R, -1, -1); + GetColors(OutlineColor, FillColor, MarkColor); + case Kind of + PFC_CHECKBOX: + begin + RectangleEx(DC, R, OutlineColor, FillColor); + if (State and PFS_MIXED) <> 0 then + begin + InflateRect(R, -3, -3); + FillRectEx(DC, R, MarkColor); + end + else if (State and PFS_CHECKED) <> 0 then + DrawPattern(DC, GetRectCenter(R), CheckMarkPattern, MarkColor, True); + end; + PFC_RADIOBUTTON: + begin + EllipseEx(DC, R, OutlineColor, FillColor); + if (State and PFS_CHECKED) <> 0 then + begin + InflateRect(R, -3, -3); + EllipseEx(DC, R, MarkColor, MarkColor); + end; + end; + end; + end; +end; + +procedure TTBXOffice2003Theme.PaintImage(Canvas: TCanvas; ARect: TRect; + const ItemInfo: TTBXItemInfo; ImageList: TCustomImageList; ImageIndex: Integer); +var + HiContrast: Boolean; +begin + with ItemInfo do + begin + {$IFDEF PNGIMAGELIST} + if ImageList is TPNGImageList then + begin + if Enabled + then TPNGImageList(ImageList).Images[ImageIndex].Image.Draw(Canvas, ARect) + else TPNGImageList(ImageList).Images[ImageIndex].DisabledImage.Draw(Canvas, ARect); + Exit; + end; + {$ENDIF} + if ImageList is TTBCustomImageList then + begin + TTBCustomImageList(ImageList).DrawState(Canvas, ARect.Left, ARect.Top, + ImageIndex, Enabled, (HoverKind <> hkNone), Selected); + Exit; + end; + + HiContrast := ColorIntensity(GetItemImageBackground(ItemInfo)) < 80; + if Enabled then + begin + {$IFDEF HIGHLIGHT_TOOLBAR_ICONS} + if Selected or Pushed or (HoverKind <> hkNone) or HiContrast or TBXNoBlending + then DrawTBXIcon(Canvas, ARect, ImageList, ImageIndex, HiContrast) + else HighlightTBXIcon(Canvas, ARect, ImageList, ImageIndex, FWindowColor, 178); + {$ELSE} + DrawTBXIcon(Canvas, ARect, ImageList, ImageIndex, HiContrast); + {$ENDIF} + end + else if HiContrast + then DrawTBXIconFlatShadow(Canvas, ARect, ImageList, ImageIndex, SeparatorColor1) + else DrawTBXIconShadow(Canvas, ARect, ImageList, ImageIndex, 0); + end; +end; + +procedure TTBXOffice2003Theme.PaintMDIButton(Canvas: TCanvas; ARect: TRect; + const ItemInfo: TTBXItemInfo; ButtonKind: Cardinal); +var + Index: Integer; +begin + PaintButton(Canvas, ARect, ItemInfo); + case ButtonKind of + DFCS_CAPTIONCLOSE: Index := 0; + DFCS_CAPTIONMIN: Index := 2; + DFCS_CAPTIONMAX: Index := 1; + DFCS_CAPTIONRESTORE: Index := 3; + else + Exit; + end; + Dec(ARect.Bottom); + DrawGlyph(Canvas.Handle, ARect, GetGlyphsImList, Index, + GetPartColor(ItemInfo, ipText)); +end; + +procedure TTBXOffice2003Theme.PaintMenuItem(Canvas: TCanvas; const ARect: TRect; + var ItemInfo: TTBXItemInfo); +const + ArrowPattern: array[0..2] of TPoint = + ((X: 0; Y:-3), (X: 0; Y: 3), (X: 3; Y: 0)); +var + DC: HDC; + R: TRect; + ArrowWidth, X: Integer; + C: TColor; +begin + R := ARect; + PaintMenuItemFrame(Canvas, R, ItemInfo); + DC := Canvas.Handle; + with ItemInfo do + begin + if (ItemOptions and (IO_COMBO or IO_SUBMENUITEM)) <> 0 then + begin + ArrowWidth := GetSystemMetrics(SM_CXMENUCHECK); + C := GetPartColor(ItemInfo, ipText); + + if (ItemOptions and IO_SUBMENUITEM) <> 0 then + DrawPattern(DC, R.Right - ArrowWidth * 2 div 3 - 1, R.Bottom div 2, + ArrowPattern, C, True); + + if (ItemOptions and IO_COMBO) <> 0 then + begin + X := R.Right- ArrowWidth- 1; + if Enabled then + if HoverKind = hkMouseHover + then C := GetPartColor(ItemInfo, ipFrame) + else C := PopupFrameColor; + DrawLineEx(DC, X, R.Top+ 1, X, R.Bottom- 1, C); + end; + end; + + if Enabled and Selected then + begin + Inc(R.Left); + R.Right := R.Left + PopupMargin; + InflateRect(R, -1, -1); + RectangleEx(DC, R, GetBtnColor(ItemInfo, ipFrame), + GetBtnColor(ItemInfo, ipBody)); + end; + end; +end; + +procedure TTBXOffice2003Theme.PaintMenuItemFrame(Canvas: TCanvas; + const ARect: TRect; const ItemInfo: TTBXItemInfo); +var + R: TRect; +begin + R := ARect; + with ItemInfo do + begin + if (ViewType and PVT_TOOLBOX) <> PVT_TOOLBOX then + begin + R.Right := R.Left + PopupMargin + 2; + PaintIrregularGradient(Canvas.Handle, R, ToolbarColor1, ToolbarColor2, True); + end; + if (HoverKind <> hkNone) and (Enabled or (HoverKind = hkKeyboardHover)) then + begin + R.Right := ARect.Right; + InflateRectHorz(R, -1); + PaintFrame(Canvas, R, ItemInfo); + end; + end; +end; + +procedure TTBXOffice2003Theme.PaintPageScrollButton(Canvas: TCanvas; + const ARect: TRect; ButtonType: Integer; Hot: Boolean); +const + BtnItemState: array[Boolean] of TBtnItemState = (bisNormal, bisHot); +var + DC: HDC; + FrameColor, FillColor: TColor; + X, Y, Sz: Integer; + ArrowPoints: array[0..2] of TPoint; +begin + DC := Canvas.Handle; + { Frame & body } + if Hot then + begin + FrameColor := BtnItemColors[bisHot, ipFrame]; + FillColor := BtnBodyColors[bisHot, False]; + end + else begin + FrameColor := EmbeddedFrameColor; + FillColor := EmbeddedColor; + end; + RectangleEx(DC, ARect, FrameColor, FillColor); + { Arrow } + FillLongWord(ArrowPoints[0], SizeOf(ArrowPoints) div SizeOf(Integer), 0); + GetRectCenter(ARect, X, Y); + Sz := Min(X - ARect.Left, Y - ARect.Top) * 3 div 4; + if ButtonType in [PSBT_UP, PSBT_DOWN] then + begin + if ButtonType = PSBT_UP then Sz := -Sz else Dec(Y); + ArrowPoints[0].X := -Sz; + ArrowPoints[1].X := Sz; + ArrowPoints[2].Y := Sz; + Dec(Y, Sz div 2); + end + else begin + if ButtonType = PSBT_LEFT then Sz := -Sz else Dec(X); + ArrowPoints[0].Y := -Sz; + ArrowPoints[1].Y := Sz; + ArrowPoints[2].X := Sz; + Dec(X, Sz div 2); + end; + DrawPattern(DC, X, Y, ArrowPoints, BtnItemColors[BtnItemState[Hot], ipText], True); +end; + +procedure TTBXOffice2003Theme.PaintPopupNCArea(Canvas: TCanvas; R: TRect; + const PopupInfo: TTBXPopupInfo); +var + DC: HDC; + PR: TRect; +begin + DC := Canvas.Handle; + RectangleEx(DC, R, PopupFrameColor, PopupColor); + PR := PopupInfo.ParentRect; + if IsRectEmpty(PR) then Exit; + InflateRect(R, -1, -1); + with PR do + begin + if Bottom = R.Top then + begin + if Left <= R.Left then Left := R.Left else Inc(Left); + if Right >= R.Right then Right := R.Right else Dec(Right); + Dec(Bottom); + Top := Bottom; + end + else if Top = R.Bottom then + begin + if Left <= R.Left then Left := R.Left else Inc(Left); + if Right >= R.Right then Right := R.Right else Dec(Right); + Bottom := Top; + end; + if Right = R.Left then + begin + if Top <= R.Top then Top := R.Top else Inc(Top); + if Bottom >= R.Bottom then Bottom := R.Bottom else Dec(Bottom); + Dec(Right); + Left := Right; + end + else if Left = R.Right then + begin + if Top <= R.Top then Top := R.Top else Inc(Top); + if Bottom >= R.Bottom then Bottom := R.Bottom else Dec(Bottom); + Right := Left; + end; + DrawLineEx(DC, Left, Top, Right, Bottom, PopupColor); + end; +end; + +procedure TTBXOffice2003Theme.PaintSeparator(Canvas: TCanvas; ARect: TRect; + ItemInfo: TTBXItemInfo; Horizontal, LineSeparator: Boolean); +var + DC: HDC; + I: Integer; +begin + { Note: for blank separators, Enabled = False } + DC := Canvas.Handle; + with ItemInfo, ARect do + begin + if (ViewType and PVT_POPUPMENU) = PVT_POPUPMENU then + begin + { on popup menu } + I := Right; + Right := PopupMargin + 2; + PaintIrregularGradient(DC, ARect, ToolbarColor1, ToolbarColor2, True); + if Enabled then + begin + Top := (Top + Bottom) div 2; + DrawLineEx(DC, Left + PopupMargin + 9, Top, I, Top, SeparatorColor1); + end; + end + else if Enabled then + begin + if Horizontal then + if (ViewType and TVT_NORMALTOOLBAR) = TVT_NORMALTOOLBAR then + begin + { on horizontal toolbar } + if LineSeparator + then I := -1 { on multirow (tbsmWrap or floating) toolbar } + else I := -Round((Right - Left - 2) * 0.2); + InflateRect(ARect, I, -((Bottom - Top - 1) div 2)); + DrawLineEx(DC, Left, Top, Right, Top, SeparatorColor1); + OffsetRect(ARect, 1, 1); + DrawLineEx(DC, Left, Top, Right, Top, SeparatorColor2); + end + else begin + { on listbox and... } + InflateRectVert(ARect, -((Bottom - Top - 1) div 2)); + DrawLineEx(DC, Left, Top, Right, Top, SeparatorColor1); + end + else { Vertical } + if (ViewType and TVT_NORMALTOOLBAR) = TVT_NORMALTOOLBAR then + begin + { on vertical toolbar } + if LineSeparator + then I := -1 { on multicolumn (tbsmWrap or floating) toolbar } + else I := -Round((Bottom - Top - 2) * 0.2); + InflateRect(ARect, -((Right - Left - 1) div 2), I); + DrawLineEx(DC, Left, Top, Left, Bottom, SeparatorColor1); + OffsetRect(ARect, 1, 1); + DrawLineEx(DC, Left, Top, Left, Bottom, SeparatorColor2); + end + else begin + { on listbox and... } + InflateRectHorz(ARect, -((Right - Left - 1) div 2)); + DrawLineEx(DC, Left, Top, Left, Bottom, SeparatorColor1); + end; + end; + end; +end; + +procedure TTBXOffice2003Theme.PaintToolbarNCArea(Canvas: TCanvas; R: TRect; + const ToolbarInfo: TTBXToolbarInfo); +const + DragHandleOffsets: array[Boolean, DHS_DOUBLE..DHS_SINGLE] of Integer = + ((3, 0, 2), (6, 0, 6)); + + procedure DrawDots(DC: HDC; R: TRect; Color: TColor; Horz: Boolean); + var + Fin: Integer; + Brush: HBRUSH; + begin + if Horz then Fin := R.Right else Fin := R.Bottom; + R.Right := R.Left+ 2; + R.Bottom := R.Top+ 2; + Brush := CreateBrushEx(Color); + if Horz then + while R.Left < Fin do + begin + FillRect(DC, R, Brush); + OffsetRectHorz(R, 4); + end + else + while R.Top < Fin do + begin + FillRect(DC, R, Brush); + OffsetRectVert(R, 4); + end; + DeleteObject(Brush); + end; + +var + DC: HDC; + Horz, IsMenuBar, BtnVisible: Boolean; + Sz, Offset: Integer; + R2: TRect; + BtnItemState: TBtnItemState; + Brush: HBRUSH; + {$IFNDEF GRADIENT_FILL_BACKGROUND} + C: TColor; + {$ENDIF} +begin + DC := Canvas.Handle; + Horz := not ToolbarInfo.IsVertical; + IsMenuBar := ToolbarInfo.ViewType and TVT_MENUBAR = TVT_MENUBAR; + + if (ToolbarInfo.BorderStyle = bsSingle) and not IsMenuBar then + begin + if not TBXLoColor and (ColorIntensity(FFaceColor) in [50..254]) then + begin + InflateRect(R, -1, -1); + with R do + begin + if Horz then + begin + {left} + {$IFNDEF GRADIENT_FILL_BACKGROUND} + DrawLineEx(DC, Left-1, Top-1, Left-1, Bottom+1, DockColor1); + {$ENDIF} + PaintIrregularGradient(DC, Rect(Left, Top+2, Left+1, Bottom-2), ToolbarColor1, ToolbarColor2, False); + {top} + {$IFNDEF GRADIENT_FILL_BACKGROUND} + DrawLineEx(DC, Left, Top-1, Right+1, Top-1, DockColor1); + {$ENDIF} + if (ToolbarInfo.ViewType and TVT_TOOLWINDOW) <> TVT_TOOLWINDOW + then DrawLineEx(DC, Left+2, Top, Right-1, Top, ToolbarColor1) + else PaintIrregularGradient(DC, Rect(Left+2, Top, Right-1, Top+1), ToolbarColor1, ToolbarColor2, True); + {right} + if (ToolbarInfo.ViewType and TVT_TOOLWINDOW) <> TVT_TOOLWINDOW + then PaintIrregularGradient(DC, Rect(Right-1, Top+1, Right, Bottom-1), ToolbarColor1, ToolbarColor2, False) + else DrawLineEx(DC, Right-1, Top+1, Right-1, Bottom-1, ToolbarColor2); + PaintGradient(DC, Rect(Right, Top+3, Right+1, Bottom-1), ToolbarColor2, ToolbarFrameColor1, False); + {bottom} + DrawLineEx(DC, Left+2, Bottom-1, Right-1, Bottom-1, ToolbarColor2); + DrawLineEx(DC, Left+3, Bottom, Right-1, Bottom, ToolbarFrameColor1); + {pixels} + {$IFNDEF GRADIENT_FILL_BACKGROUND} + SetPixelV(DC, Left, Top, DockColor1); + PolyLineEx(DC, [Point(Left, Bottom-1), Point(Left, Bottom), Point(Left+2, Bottom)], DockColor1); + SetPixelV(DC, Right, Top, DockColor1); + SetPixelV(DC, Right, Bottom, DockColor1); + C := NearestMixedColor(DockColor1, ToolbarColor1, 127); + SetPixelV(DC, Left, Top+1, C); + SetPixelV(DC, Left+1, Top, C); + SetPixelV(DC, Right-1, Top, C); + SetPixelV(DC, Right, Top+1, C); + C := NearestMixedColor(ToolbarColor2, DockColor1, 165); + SetPixelV(DC, Left, Bottom-2, C); + SetPixelV(DC, Left+1, Bottom-1, C); + SetPixelV(DC, Left+2, Bottom, NearestMixedColor(ToolbarFrameColor1, C, 64)); + SetPixelV(DC, Right, Top+2, C); + SetPixelV(DC, Right-1, Bottom-1, ToolbarFrameColor1); + SetPixelV(DC, Right, Bottom-1, C); + SetPixelV(DC, Right-1, Bottom, C); + {$ELSE} + SetPixelEx(DC, Left, Top+1, ToolbarColor1, 118); + SetPixelEx(DC, Left+1, Top, ToolbarColor1, 118); + SetPixelEx(DC, Right-1, Top, ToolbarColor1, 118); + SetPixelEx(DC, Right, Top+1, ToolbarColor1, 118); + SetPixelEx(DC, Left, Bottom-2, ToolbarColor2, 136); + SetPixelEx(DC, Left+1, Bottom-1, ToolbarColor2, 136); + SetPixelEx(DC, Left+2, Bottom, ToolbarFrameColor1, 127); + SetPixelEx(DC, Right, Top+2, ToolbarColor2, 136); + SetPixelV(DC, Right-1, Bottom-1, ToolbarFrameColor1); + SetPixelEx(DC, Right, Bottom-1, ToolbarColor2, 136); + SetPixelEx(DC, Right-1, Bottom, ToolbarColor2, 136); + {$ENDIF} + end + else begin + {left} + {$IFNDEF GRADIENT_FILL_BACKGROUND} + DrawLineEx(DC, Left-1, Top, Left-1, Bottom+1, DockColor1); + {$ENDIF} + DrawLineEx(DC, Left, Top+2, Left, Bottom-1, ToolbarColor1); + {top} + {$IFNDEF GRADIENT_FILL_BACKGROUND} + DrawLineEx(DC, Left-1, Top-1, Right+1, Top-1, DockColor1); + {$ENDIF} + PaintIrregularGradient(DC, Rect(Left+2, Top, Right-1, Top+1), ToolbarColor1, ToolbarColor2, True); + {right} + DrawLineEx(DC, Right-1, Top+1, Right-1, Bottom-1, ToolbarColor2); + DrawLineEx(DC, Right, Top+3, Right, Bottom-1, ToolbarFrameColor1); + {bottom} + PaintIrregularGradient(DC, Rect(Left+1, Bottom-1, Right-1, Bottom), ToolbarColor1, ToolbarColor2, True); + PaintGradient(DC, Rect(Left+3, Bottom, Right-1, Bottom+1), ToolbarColor2, ToolbarFrameColor1, True); + {pixels} + {$IFNDEF GRADIENT_FILL_BACKGROUND} + SetPixelV(DC, Left, Top, DockColor1); + SetPixelV(DC, Left, Bottom, DockColor1); + SetPixelV(DC, Right, Bottom, DockColor1); + SetPixelV(DC, Right, Top, DockColor1); + C := NearestMixedColor(DockColor1, ToolbarColor1, 127); + SetPixelV(DC, Left, Top+1, C); + SetPixelV(DC, Left+1, Top, C); + SetPixelV(DC, Left, Bottom-1, C); + SetPixelV(DC, Left+1, Bottom, C); + C := NearestMixedColor(ToolbarColor2, DockColor1, 165); + SetPixelV(DC, Left+2, Bottom, C); + SetPixelV(DC, Right-1, Top, C); + SetPixelV(DC, Right, Top+1, C); + SetPixelV(DC, Right, Top+2, NearestMixedColor(ToolbarFrameColor1, C, 127)); + SetPixelV(DC, Right-1, Bottom-1, ToolbarFrameColor1); + SetPixelV(DC, Right, Bottom-1, C); + SetPixelV(DC, Right-1, Bottom, C); + {$ELSE} + SetPixelEx(DC, Left, Top+1, ToolbarColor1, 118); + SetPixelEx(DC, Left+1, Top, ToolbarColor1, 118); + SetPixelEx(DC, Left, Bottom-1, ToolbarColor1, 118); + SetPixelEx(DC, Left+1, Bottom, ToolbarColor1, 118); + SetPixelEx(DC, Left+2, Bottom, ToolbarColor2, 136); + SetPixelEx(DC, Right-1, Top, ToolbarColor2, 136); + SetPixelEx(DC, Right, Top+1, ToolbarColor2, 136); + SetPixelEx(DC, Right, Top+2, ToolbarFrameColor1, 127); + SetPixelV(DC, Right-1, Bottom-1, ToolbarFrameColor1); + SetPixelEx(DC, Right, Bottom-1, ToolbarColor2, 136); + SetPixelEx(DC, Right-1, Bottom, ToolbarColor2, 136); + {$ENDIF} + end; + end; + OffsetPoint(R.TopLeft, 1, 1); + end + else begin + Brush := CreateDitheredBrush(ToolbarColor1, clBtnShadow); + with R do + begin + FillRect(DC, Rect(Left+1, Top, Right-1, Top+1), Brush); + FillRect(DC, Rect(Left+1, Bottom-1, Right-1, Bottom), Brush); + FillRect(DC, Rect(Left, Top+1, Left+1, Bottom-1), Brush); + FillRect(DC, Rect(Right-1, Top+1, Right, Bottom-1), Brush); + end; + DeleteObject(Brush); + InflateRect(R, -1, -1); + FillRectEx(DC, R, ToolbarColor1); + end; + end + else begin + {$IFDEF GRADIENT_FILL_BACKGROUND} + if not IsMenuBar then + {$ENDIF} + FillRectEx(DC, R, DockColor1); + InflateRect(R, -1, -1); + end; + + { Drag Handle } + if not ToolbarInfo.AllowDrag then Exit; + + InflateRect(R, -1, -1); + BtnVisible := (ToolbarInfo.CloseButtonState and CDBS_VISIBLE) <> 0; + + if (ToolbarInfo.DragHandleStyle <> DHS_NONE) then + begin + Sz := GetTBXDragHandleSize(ToolbarInfo); + if Horz then R.Right := R.Left + Sz else R.Bottom := R.Top + Sz; + if not IsMenuBar then + PaintIrregularGradient(DC, Rect(R.Left-1, R.Top-1, R.Right, R.Bottom), + ToolbarColor1, ToolbarColor2, not Horz); + { Gripper } + R2 := R; + Offset := DragHandleOffsets[BtnVisible, ToolbarInfo.DragHandleStyle]; + if Horz then + begin + Inc(R2.Left, Offset + Ord(IsMenuBar)); + InflateRectVert(R2, -(Sz div 2)); + if IsMenuBar then Inc(R2.Top, 2); + if BtnVisible then Inc(R2.Top, Sz-2); + end + else begin + Inc(R2.Top, Offset + Ord(IsMenuBar)); + InflateRectHorz(R2, -(Sz div 2)); + if IsMenuBar then Inc(R2.Left, 2); + if BtnVisible then Dec(R2.Right, Sz-2); + end; + DrawDots(DC, R2, DragHandleColor2, not Horz); + OffsetRect(R2, -1, -1); + DrawDots(DC, R2, DragHandleColor1, not Horz); + end; + { Close button } + if BtnVisible then + begin + R2 := R; + if Horz then + begin + Dec(R2.Right); + R2.Bottom := R2.Top + R2.Right - R2.Left; + end + else begin + Dec(R2.Bottom); + R2.Left := R2.Right - R2.Bottom + R2.Top; + end; + BtnItemState := GetCloseBtnItemState(ToolbarInfo.CloseButtonState); + {$IFDEF SMALL_CLOSE_BUTTON_ON_DOCKED_TOOLBAR} + DrawCloseButton(DC, R2, BtnItemState, True, True, BtnItemColors[BtnItemState, ipText]); + {$ELSE} + DrawCloseButton(DC, R2, BtnItemState, True, False, BtnItemColors[BtnItemState, ipText]); + {$ENDIF} + end; +end; + +procedure TTBXOffice2003Theme.PaintStatusBar(Canvas: TCanvas; R: TRect; Part: Integer); + + procedure DrawSizeGrip(DC: HDC; const P: TPoint; Color: TColor); + var + R: TRect; + Brush: HBRUSH; + X, Y: Integer; + begin + R := Rect(P.X-2, P.Y-2, P.X, P.Y); + Brush := CreateBrushEx(Color); + for X := 3 downto 1 do + begin + for Y := X downto 1 do + begin + FillRect(DC, R, Brush); + OffsetRectVert(R, -4); + end; + OffsetRect(R, -4, 4 * X); + end; + DeleteObject(Brush); + end; + +var + DC: HDC; +begin + DC := Canvas.Handle; + case Part of + SBP_BODY: + {$IFDEF GRADIENT_FILL_STATUSBAR} + PaintIrregularGradient(DC, R, ToolbarColor1, ToolbarColor2, False); + {$ELSE} + FillRectEx(DC, R, FFaceColor); + {$ENDIF} + SBP_PANE, SBP_LASTPANE: + begin + if Part = SBP_PANE then Dec(R.Right, 2); + FrameRectEx(DC, R, StatusPanelFrameColor, False); + end; + SBP_GRIPPER: + begin + OffsetPoint(R.BottomRight, -1, -1); + DrawSizeGrip(DC, R.BottomRight, DragHandleColor2); + OffsetPoint(R.BottomRight, -1, -1); + DrawSizeGrip(DC, R.BottomRight, DragHandleColor1); + end; + end; +end; + +{------------------------------------------------------------------------------} +{ Internal } +{------------------------------------------------------------------------------} + +procedure TTBXOffice2003Theme.DrawCloseButton(DC: HDC; R: TRect; + BtnItemState: TBtnItemState; Gradient, Small: Boolean; Color: TColor); +const + CloseBtnPattern: array[Boolean, 0..15] of Byte = ( + (0, 0, $C6, 0, $6C, 0, $38, 0, $38, 0, $6C, 0, $C6, 0, 0, 0), + ($C3, 0, $66, 0, $3C, 0, $18, 0, $3C, 0, $66, 0, $C3, 0, 0, 0)); +var + FrameColor, BodyColor: TColor; +begin + FrameColor := BtnItemColors[BtnItemState, ipFrame]; + BodyColor := BtnBodyColors[BtnItemState, False]; + if (FrameColor <> clNone) and (BodyColor <> clNone) then + if Gradient then + begin + FrameRectEx(DC, R, FrameColor, True); + PaintGradient(DC, R, BodyColor, BtnBodyColors[BtnItemState, True], False); + end + else RectangleEx(DC, R, FrameColor, BodyColor); + DrawGlyph(DC, R, 8, 8, CloseBtnPattern[not Small], Color); +end; + +function TTBXOffice2003Theme.GetBtnColor(const ItemInfo: TTBXItemInfo; + ItemPart: TItemPart; GradColor2: Boolean = False): TColor; +const + BFlags1: array[Boolean] of TBtnItemState = + (bisDisabled, bisDisabledHot); + BFlags2: array[Boolean, Boolean] of TBtnItemState = + ((bisNormal, bisHot), (bisSelected, bisSelectedHot)); +var + B: TBtnItemState; + Embedded: Boolean; +begin + with ItemInfo do + begin + if not Enabled then B := BFlags1[HoverKind = hkKeyboardHover] else + if IsPopupParent then B := bisPopupParent else + if Pushed then B := bisPressed else + B := BFlags2[Selected, HoverKind <> hkNone]; + + if ItemPart = ipBody + then Result := BtnBodyColors[B, GradColor2] + else Result := BtnItemColors[B, ItemPart]; + + Embedded := ((ViewType and VT_TOOLBAR) <> 0) and + ((ViewType and TVT_EMBEDDED) <> 0); + if Embedded and (Result = clNone) then + begin + if ItemPart = ipBody + then Result := EmbeddedColor + else if (ItemPart = ipFrame) and not Selected then Result := EmbeddedFrameColor; + end; + end; +end; + +procedure TTBXOffice2003Theme.GetGradientColors(X1, X2: Integer; + out Color1, Color2: TColor); + + function CalcColor(XPos, FullWidth: Integer): TColor; + var + Weight1: Integer; + begin + Weight1 := XPos * 1000 div FullWidth; + if Weight1 < 100 then Weight1 := Weight1 * 100 div 1000; + Result := NearestBlendedColor(DockColor2, DockColor1, Weight1); + end; + +var + FullWidth: Integer; +begin + FullWidth := Max(FMaxWindowWidth, X2 - X1); + Color1 := CalcColor(X1, FullWidth); + Color2 := CalcColor(X2, FullWidth); +end; + +function TTBXOffice2003Theme.GetPartColor(const ItemInfo: TTBXItemInfo; + ItemPart: TItemPart): TColor; +const + MFlags1: array[Boolean] of TMenuItemState = (misDisabled, misDisabledHot); + MFlags2: array[Boolean] of TMenuItemState = (misNormal, misHot); +var + M: TMenuItemState; +begin + with ItemInfo do + begin + if ((ViewType and PVT_POPUPMENU) = PVT_POPUPMENU) and + ((ItemOptions and IO_TOOLBARSTYLE) = 0) then + begin + if not Enabled + then M := MFlags1[HoverKind = hkKeyboardHover] + else M := MFlags2[HoverKind <> hkNone]; + Result := MenuItemColors[M, ItemPart]; + end + else Result := GetBtnColor(ItemInfo, ItemPart, False); + end; +end; + +procedure TTBXOffice2003Theme.SetupColorCache; +const + Office2003Colors: array[osBlue..osGreen, 0..29] of TColor = ( + ($F5BE9E, $FEECDD, $E2A981, $9C613B, $FAD5BD, $CB8C6A, $FFF9F1, $764127, + $FFFFFF, $F0C7A9, $B99D7F, $DEDEDE, $F6F6F6, $962D00, $000000, $8D8D8D, + $800000, $C9662A, $8CD5FF, $55ADFF, $4E91FE, $8ED3FF, $CCF4FF, $91D0FF, + $FFEFE3, $E7B593, $C2EEFF, $AE9990, $F9DAC3, $FEECDD), + ($E5D7D7, $FAF4F3, $B59799, $947C7C, $EFE5E5, $8F6D6E, $FFFFFF, $755454, + $FFFFFF, $D3C0C0, $B2ACA5, $DEDEDE, $FFFAFD, $947C7C, $000000, $8D8D8D, + $6F4B4B, $99797A, $8CD5FF, $55ADFF, $4E91FE, $8ED3FF, $CCF4FF, $91D0FF, + $F1E9E8, $CDB9BA, $C2EEFF, $B39A9B, $F7F3F3, $F4EEEE), + ($A7D9D9, $DEF7F4, $91C6B7, $588060, $C0E7E5, $588060, $DEF7F4, $335E51, + $FFFFFF, $9FD4C5, $7FB9A4, $DEDEDE, $EEF4F4, $5E8D75, $000000, $8D8D8D, + $385D3F, $5E8674, $8CD5FF, $55ADFF, $4E91FE, $8ED3FF, $CCF4FF, $91D0FF, + $D5F0EC, $9FCEC2, $C2EEFF, $7BA097, $E4F0F2, $E7F2F3) + ); + IrregularGradientColor1Weight: array[TOffice2003Scheme] of Integer = + (196, 196, 36, 127); + IrregularGradientCCExtrusion: array[TOffice2003Scheme] of Integer = + (5, 5, 16, 16); + +var + DC: HDC; + C, MenuItemFrame, EnabledText, DisabledText, HotBtnFace: TColor; + Scheme: TOffice2003Scheme; + + procedure Undither(var C: TColor); + begin + if C <> clNone then + begin + if C < 0 then C := GetSysColor(C and $FF); + C := GetNearestColor(DC, C); + end; + end; + + procedure ColorToColorRef(var C: TColor); + begin + if C < 0 then C := GetSysColor(C and $FF); + end; + +begin + FMaxWindowWidth := GetSystemMetrics(SM_CXSCREEN); + DC := StockCompatibleBitmap.Canvas.Handle; + + if TBXLoColor then + begin + DockColor1 := clBtnFace; + DockColor2 := clBtnFace; + ToolbarColor1 := clBtnFace; + ToolbarColor2 := clBtnFace; + ToolbarFrameColor1 := clBtnShadow; + ToolbarFrameColor2 := clBtnShadow; + SeparatorColor1 := clBtnShadow; + SeparatorColor2 := clBtnHighlight; + DragHandleColor1 := clBtnText; + DragHandleColor2 := clBtnHighlight; + + EmbeddedColor := clBtnFace; + EmbeddedFrameColor := clBtnShadow; + EmbeddedDisabledColor := clBtnFace; + + PopupColor := clWindow; + PopupFrameColor := clBtnText; + + DockPanelColor := clWindow; + + DisabledText := clBtnShadow; + MenuItemFrame := clHighlight; + + WinFrameColors[wfpBorder] := clBtnShadow; + WinFrameColors[wfpCaption] := clBtnShadow; + WinFrameColors[wfpCaptionText] := clBtnHighlight; + + BtnItemColors[bisNormal, ipText] := clBtnText; + BtnItemColors[bisNormal, ipFrame] := clNone; + BtnItemColors[bisDisabled, ipText] := DisabledText; + BtnItemColors[bisDisabled, ipFrame] := clNone; + BtnItemColors[bisSelected, ipText] := clWindowText; + BtnItemColors[bisSelected, ipFrame] := MenuItemFrame; + BtnItemColors[bisPressed, ipText] := clHighlightText; + BtnItemColors[bisPressed, ipFrame] := MenuItemFrame; + BtnItemColors[bisHot, ipText] := clWindowText; + BtnItemColors[bisHot, ipFrame] := MenuItemFrame; + BtnItemColors[bisDisabledHot, ipText] := DisabledText; + BtnItemColors[bisDisabledHot, ipFrame] := MenuItemFrame; + BtnItemColors[bisSelectedHot, ipText] := clHighlightText; + BtnItemColors[bisSelectedHot, ipFrame] := MenuItemFrame; + BtnItemColors[bisPopupParent, ipText] := clBtnText; + BtnItemColors[bisPopupParent, ipFrame] := PopupFrameColor; + + BtnBodyColors[bisNormal, False] := clNone; + BtnBodyColors[bisNormal, True] := clNone; + BtnBodyColors[bisDisabled, False] := clNone; + BtnBodyColors[bisDisabled, True] := clNone; + BtnBodyColors[bisSelected, False] := clWindow; + BtnBodyColors[bisSelected, True] := clWindow; + BtnBodyColors[bisPressed, False] := clHighlight; + BtnBodyColors[bisPressed, True] := clHighlight; + BtnBodyColors[bisHot, False] := clWindow; + BtnBodyColors[bisHot, True] := clWindow; + BtnBodyColors[bisDisabledHot, False] := clWindow; + BtnBodyColors[bisDisabledHot, True] := clWindow; + BtnBodyColors[bisSelectedHot, False] := clHighlight; + BtnBodyColors[bisSelectedHot, True] := clHighlight; + BtnBodyColors[bisPopupParent, False] := clBtnFace; + BtnBodyColors[bisPopupParent, True] := clBtnFace; + + MenuItemColors[misNormal, ipBody] := clNone; + MenuItemColors[misNormal, ipText] := clWindowText; + MenuItemColors[misNormal, ipFrame] := clNone; + MenuItemColors[misDisabled, ipBody] := clNone; + MenuItemColors[misDisabled, ipText] := clGrayText; + MenuItemColors[misDisabled, ipFrame] := clNone; + MenuItemColors[misHot, ipBody] := clWindow; + MenuItemColors[misHot, ipText] := clWindowText; + MenuItemColors[misHot, ipFrame] := MenuItemFrame; + MenuItemColors[misDisabledHot, ipBody] := PopupColor; + MenuItemColors[misDisabledHot, ipText] := clGrayText; + MenuItemColors[misDisabledHot, ipFrame] := MenuItemFrame; + + StatusPanelFrameColor := clBtnShadow; + FMDIAreaColor := clBtnShadow; + FFaceColor := clBtnFace; + FWindowColor := clWindow; + + ColorToColorRef(FFaceColor); + ColorToColorRef(FWindowColor); + end + else begin + Scheme := GetOffice2003Scheme; + if Scheme <> osAuto then + begin + DockColor1 := Office2003Colors[Scheme, 0]; + DockColor2 := Office2003Colors[Scheme, 28]; + ToolbarColor1 := Office2003Colors[Scheme, 1]; + ToolbarColor2 := Office2003Colors[Scheme, 2]; + ToolbarFrameColor1 := Office2003Colors[Scheme, 3]; + ToolbarFrameColor2 := Office2003Colors[Scheme, 4]; + SeparatorColor1 := Office2003Colors[Scheme, 5]; + SeparatorColor2 := Office2003Colors[Scheme, 6]; + DragHandleColor1 := Office2003Colors[Scheme, 7]; + DragHandleColor2 := Office2003Colors[Scheme, 8]; + + EmbeddedColor := Office2003Colors[Scheme, 9]; + EmbeddedFrameColor := Office2003Colors[Scheme, 10]; + EmbeddedDisabledColor := Office2003Colors[Scheme, 11]; + + PopupColor := Office2003Colors[Scheme, 12]; + PopupFrameColor := Office2003Colors[Scheme, 13]; + + DockPanelColor := Office2003Colors[Scheme, 29]; + + EnabledText := Office2003Colors[Scheme, 14]; + DisabledText := Office2003Colors[Scheme, 15]; + MenuItemFrame := Office2003Colors[Scheme, 16]; + + WinFrameColors[wfpBorder] := Office2003Colors[Scheme, 17]; + WinFrameColors[wfpCaption] := WinFrameColors[wfpBorder]; + WinFrameColors[wfpCaptionText] := clWhite; + + BtnItemColors[bisNormal, ipText] := EnabledText; + BtnItemColors[bisNormal, ipFrame] := clNone; + BtnItemColors[bisDisabled, ipText] := DisabledText; + BtnItemColors[bisDisabled, ipFrame] := clNone; + BtnItemColors[bisSelected, ipText] := EnabledText; + BtnItemColors[bisSelected, ipFrame] := MenuItemFrame; + BtnItemColors[bisPressed, ipText] := EnabledText; + BtnItemColors[bisPressed, ipFrame] := MenuItemFrame; + BtnItemColors[bisHot, ipText] := EnabledText; + BtnItemColors[bisHot, ipFrame] := MenuItemFrame; + BtnItemColors[bisDisabledHot, ipText] := DisabledText; + BtnItemColors[bisDisabledHot, ipFrame] := MenuItemFrame; + BtnItemColors[bisSelectedHot, ipText] := EnabledText; + BtnItemColors[bisSelectedHot, ipFrame] := MenuItemFrame; + BtnItemColors[bisPopupParent, ipText] := EnabledText; + BtnItemColors[bisPopupParent, ipFrame] := PopupFrameColor; + + BtnBodyColors[bisNormal, False] := clNone; + BtnBodyColors[bisNormal, True] := clNone; + BtnBodyColors[bisDisabled, False] := clNone; + BtnBodyColors[bisDisabled, True] := clNone; + BtnBodyColors[bisSelected, False] := Office2003Colors[Scheme, 18]; + BtnBodyColors[bisSelected, True] := Office2003Colors[Scheme, 19]; + BtnBodyColors[bisPressed, False] := Office2003Colors[Scheme, 20]; + BtnBodyColors[bisPressed, True] := Office2003Colors[Scheme, 21]; + BtnBodyColors[bisHot, False] := Office2003Colors[Scheme, 22]; + BtnBodyColors[bisHot, True] := Office2003Colors[Scheme, 23]; + BtnBodyColors[bisDisabledHot, False] := BtnBodyColors[bisHot, False]; + BtnBodyColors[bisDisabledHot, True] := BtnBodyColors[bisHot, True]; + BtnBodyColors[bisSelectedHot, False] := BtnBodyColors[bisPressed, False]; + BtnBodyColors[bisSelectedHot, True] := BtnBodyColors[bisPressed, True]; + BtnBodyColors[bisPopupParent, False] := Office2003Colors[Scheme, 24]; + BtnBodyColors[bisPopupParent, True] := Office2003Colors[Scheme, 25]; + + MenuItemColors[misNormal, ipBody] := clNone; + MenuItemColors[misNormal, ipText] := EnabledText; + MenuItemColors[misNormal, ipFrame] := clNone; + MenuItemColors[misDisabled, ipBody] := clNone; + MenuItemColors[misDisabled, ipText] := DisabledText; + MenuItemColors[misDisabled, ipFrame] := clNone; + MenuItemColors[misHot, ipBody] := Office2003Colors[Scheme, 26]; + MenuItemColors[misHot, ipText] := MenuItemColors[misNormal, ipText]; + MenuItemColors[misHot, ipFrame] := MenuItemFrame; + MenuItemColors[misDisabledHot, ipBody] := PopupColor; + MenuItemColors[misDisabledHot, ipText] := DisabledText; + MenuItemColors[misDisabledHot, ipFrame] := MenuItemColors[misHot, ipFrame]; + + {$IFDEF GRADIENT_FILL_STATUSBAR} + StatusPanelFrameColor := Blend(ToolbarColor2, clBlack, 90); + {$ELSE} + StatusPanelFrameColor := Blend(clBtnFace, clBlack, 89); + {$ENDIF} + FMDIAreaColor := Office2003Colors[Scheme, 27]; + end + else begin { osAuto } + DockColor1 := clBtnFace; + DockColor2 := Blend(clBtnFace, clWindow, 222); + ToolbarColor1 := clWindow; + ToolbarColor2 := Blend(clBtnShadow, clBtnFace, 48); + ToolbarFrameColor1 := Blend(clBtnShadow, clWindow, 85); + ToolbarFrameColor2 := Blend(clBtnFace, clWindow, 62); + SeparatorColor1 := Blend(clBtnShadow, clWindow, 70); + SeparatorColor2 := clWhite; + + DragHandleColor1 := Blend(clBtnShadow, clWindow, 75); + SetContrast(DragHandleColor1, Blend(ToolbarColor1, ToolbarColor2, 127), 180); + DragHandleColor2 := clWindow; + + EmbeddedColor := clBtnFace; + EmbeddedFrameColor := clBtnShadow; + EmbeddedDisabledColor := clBtnFace; + + PopupColor := Blend(clBtnFace, clWindow, 15); + PopupFrameColor := Blend(clBtnText, clBtnShadow, 20); + + DockPanelColor := Blend(clBtnFace, clWindow, 50); + + C := Blend(clWindow, clBtnFace, 165); + EnabledText := clBtnText; + SetContrast(EnabledText, C, 180); + DisabledText := Blend(clBtnshadow, clWindow, 90); + + MenuItemFrame := clHighlight; + + HotBtnFace := Blend(clHighlight, clWindow, 30); + SetContrast(HotBtnFace, Blend(clWindow, clBtnFace, 165), 50); + + WinFrameColors[wfpBorder] := Blend(clBtnText, clBtnShadow, 15); + WinFrameColors[wfpCaption] := clBtnShadow; + WinFrameColors[wfpCaptionText] := clBtnHighlight; + + BtnBodyColors[bisNormal, False] := clNone; + BtnBodyColors[bisNormal, True] := clNone; + BtnBodyColors[bisDisabled, False] := clNone; + BtnBodyColors[bisDisabled, True] := clNone; + BtnBodyColors[bisSelected, False] := Blend(clHighlight, Blend(clBtnFace, clWindow, 50), 10); + + BtnItemColors[bisNormal, ipText] := EnabledText; + BtnItemColors[bisNormal, ipFrame] := clNone; + BtnItemColors[bisDisabled, ipText] := DisabledText; + BtnItemColors[bisDisabled, ipFrame] := clNone; + BtnItemColors[bisSelected, ipText] := EnabledText; + BtnItemColors[bisSelected, ipFrame] := MenuItemFrame; + BtnItemColors[bisPressed, ipText] := EnabledText; + BtnItemColors[bisPressed, ipFrame] := MenuItemFrame; + BtnItemColors[bisHot, ipText] := EnabledText; + SetContrast(BtnItemColors[bisHot, ipText], HotBtnFace, 180); + BtnItemColors[bisHot, ipFrame] := MenuItemFrame; + BtnItemColors[bisDisabledHot, ipText] := DisabledText; + BtnItemColors[bisDisabledHot, ipFrame] := MenuItemFrame; + BtnItemColors[bisSelectedHot, ipText] := EnabledText; + BtnItemColors[bisSelectedHot, ipFrame] := MenuItemFrame; + BtnItemColors[bisPopupParent, ipText] := EnabledText; + BtnItemColors[bisPopupParent, ipFrame] := PopupFrameColor; + + BtnBodyColors[bisSelected, True] := BtnBodyColors[bisSelected, False]; + BtnBodyColors[bisPressed, False] := Blend(clHighlight, clWindow, 50); + BtnBodyColors[bisPressed, True] := BtnBodyColors[bisPressed, False]; + BtnBodyColors[bisHot, False] := HotBtnFace; + BtnBodyColors[bisHot, True] := HotBtnFace; + BtnBodyColors[bisDisabledHot, False] := BtnBodyColors[bisHot, False]; + BtnBodyColors[bisDisabledHot, True] := BtnBodyColors[bisHot, True]; + BtnBodyColors[bisSelectedHot, False] := BtnBodyColors[bisPressed, False]; + BtnBodyColors[bisSelectedHot, True] := BtnBodyColors[bisPressed, True]; + BtnBodyColors[bisPopupParent, False] := Blend(clBtnFace, clWindow, 16); + BtnBodyColors[bisPopupParent, True] := Blend(clBtnFace, clWindow, 42); + + MenuItemColors[misNormal, ipBody] := clNone; + MenuItemColors[misNormal, ipText] := EnabledText; + MenuItemColors[misNormal, ipFrame] := clNone; + MenuItemColors[misDisabled, ipBody] := clNone; + MenuItemColors[misDisabled, ipText] := DisabledText; + MenuItemColors[misDisabled, ipFrame] := clNone; + MenuItemColors[misHot, ipBody] := BtnBodyColors[bisHot, False]; + MenuItemColors[misHot, ipText] := EnabledText; + SetContrast(MenuItemColors[misHot, ipText], HotBtnFace, 180); + MenuItemColors[misHot, ipFrame] := MenuItemFrame; + MenuItemColors[misDisabledHot, ipBody] := PopupColor; + MenuItemColors[misDisabledHot, ipText] := DisabledText; + MenuItemColors[misDisabledHot, ipFrame] := MenuItemColors[misHot, ipFrame]; + + {$IFDEF GRADIENT_FILL_STATUSBAR} + StatusPanelFrameColor := Blend(ToolbarColor2, clBlack, 90); + {$ELSE} + StatusPanelFrameColor := Blend(clBtnFace, clBlack, 89); + {$ENDIF} + SetContrast(StatusPanelFrameColor, clBtnFace, 30); + FMDIAreaColor := clBtnShadow; + end; + FFaceColor := clBtnFace; + FWindowColor := clWindow; + + Undither(DockColor1); + Undither(DockColor2); + Undither(ToolbarColor1); + Undither(ToolbarColor2); + Undither(ToolbarFrameColor1); + Undither(ToolbarFrameColor2); + Undither(SeparatorColor1); + Undither(SeparatorColor2); + Undither(DragHandleColor1); + Undither(DragHandleColor2); + + Undither(EmbeddedColor); + Undither(EmbeddedFrameColor); + Undither(EmbeddedDisabledColor); + + Undither(PopupColor); + Undither(PopupFrameColor); + + Undither(DockPanelColor); + + Undither(WinFrameColors[wfpBorder]); + Undither(WinFrameColors[wfpCaption]); + Undither(WinFrameColors[wfpCaptionText]); + + Undither(BtnItemColors[bisNormal, ipText]); + Undither(BtnItemColors[bisNormal, ipFrame]); + Undither(BtnItemColors[bisDisabled, ipText]); + Undither(BtnItemColors[bisDisabled, ipFrame]); + Undither(BtnItemColors[bisSelected, ipText]); + Undither(BtnItemColors[bisSelected, ipFrame]); + Undither(BtnItemColors[bisPressed, ipText]); + Undither(BtnItemColors[bisPressed, ipFrame]); + Undither(BtnItemColors[bisHot, ipText]); + Undither(BtnItemColors[bisHot, ipFrame]); + Undither(BtnItemColors[bisDisabledHot, ipText]); + Undither(BtnItemColors[bisDisabledHot, ipFrame]); + Undither(BtnItemColors[bisSelectedHot, ipText]); + Undither(BtnItemColors[bisSelectedHot, ipFrame]); + Undither(BtnItemColors[bisPopupParent, ipText]); + Undither(BtnItemColors[bisPopupParent, ipFrame]); + + Undither(BtnBodyColors[bisNormal, False]); + Undither(BtnBodyColors[bisNormal, True]); + Undither(BtnBodyColors[bisDisabled, False]); + Undither(BtnBodyColors[bisDisabled, True]); + Undither(BtnBodyColors[bisSelected, False]); + Undither(BtnBodyColors[bisSelected, True]); + Undither(BtnBodyColors[bisPressed, False]); + Undither(BtnBodyColors[bisPressed, True]); + Undither(BtnBodyColors[bisHot, False]); + Undither(BtnBodyColors[bisHot, True]); + Undither(BtnBodyColors[bisDisabledHot, False]); + Undither(BtnBodyColors[bisDisabledHot, True]); + Undither(BtnBodyColors[bisSelectedHot, False]); + Undither(BtnBodyColors[bisSelectedHot, True]); + Undither(BtnBodyColors[bisPopupParent, False]); + Undither(BtnBodyColors[bisPopupParent, True]); + + Undither(MenuItemColors[misNormal, ipBody]); + Undither(MenuItemColors[misNormal, ipText]); + Undither(MenuItemColors[misNormal, ipFrame]); + Undither(MenuItemColors[misDisabled, ipBody]); + Undither(MenuItemColors[misDisabled, ipText]); + Undither(MenuItemColors[misDisabled, ipFrame]); + Undither(MenuItemColors[misHot, ipBody]); + Undither(MenuItemColors[misHot, ipText]); + Undither(MenuItemColors[misHot, ipFrame]); + Undither(MenuItemColors[misDisabledHot, ipBody]); + Undither(MenuItemColors[misDisabledHot, ipText]); + Undither(MenuItemColors[misDisabledHot, ipFrame]); + + Undither(StatusPanelFrameColor); + Undither(FMDIAreaColor); + Undither(FFaceColor); + Undither(FWindowColor); + + IrregularGradientCenterColor := + Lighten(MixColors(ToolbarColor1, ToolbarColor2, + IrregularGradientColor1Weight[Scheme]), + IrregularGradientCCExtrusion[Scheme]); + Undither(IrregularGradientCenterColor); + end; +end; + +procedure TTBXOffice2003Theme.TBXSysCommand(var Message: TMessage); +begin + if Message.WParam = TSC_VIEWCHANGE then SetupColorCache; +end; + +initialization + RegisterTBXTheme('Office 2003', TTBXOffice2003Theme); +end. diff --git a/TBXOffice2007Theme.pas b/TBXOffice2007Theme.pas new file mode 100644 index 000000000..0834d5c99 --- /dev/null +++ b/TBXOffice2007Theme.pas @@ -0,0 +1,2364 @@ +unit TBXOffice2007Theme; + +// TBX Package +// Copyright 2001-2004 Alex A. Denisov. All Rights Reserved +// See TBX.chm for license and installation instructions +// +// Office2007 theme +// Copyright (c) Jonny Kwekkeboom (Sep. 2006) +// based on Office2003Theme from Yury Plashenkov (Sep. 2005) +// +// Version for TBX version 2.1 +// +// Fixed Office2007 theme Chris.P (2006.01.22) +// + +interface + +{$I TB2Ver.inc} +{$I TBX.inc} + +// PngComponents is a set of components that allows you to include in your +// application semitransparent PNG images +// I advise you to get it from http://www.thany.org/ +// After installing, use TPngImageList (from PngComponents package) instead of +// "classic" TImageList + +// Comment next string if you use Toolbar2000 version different from 2.1.6 +{$DEFINE TB2K_VER216} + +// Uncomment next string if you want to see highlighted icons +//{$DEFINE HIGHLIGHTTOOLBARICONS} + +// Uncomment next string to turn on gradient captions on dockpanels +//{$DEFINE DOCKPANELGRADIENTCAPTION} + +uses + Windows, Messages, Graphics, Classes, TBXThemes, ImgList, TBXUxThemes; + +type + TGradDir = (tGLeftRight, tGTopBottom); + TItemPart = (ipBody, ipText, ipFrame); + TBtnItemState = (bisNormal, bisDisabled, bisSelected, bisPressed, bisHot, + bisDisabledHot, bisSelectedHot, bisPopupParent); + TMenuItemState = (misNormal, misDisabled, misHot, misDisabledHot); + TWinFramePart = (wfpBorder, wfpCaption, wfpCaptionText); + + TOffice2007Scheme = (osBlue, osMetallic, osGreen, osUnknown); + + TTBXOffice2007Theme = class(TTBXTheme) + private + FOnSetupColorCache: TNotifyEvent; + procedure TBXSysCommand(var Message: TMessage); message TBX_SYSCOMMAND; + protected + DockColor: TColor; + + ToolbarColor1: TColor; + ToolbarColor2: TColor; + ToolbarFrameColor1: TColor; + ToolbarFrameColor2: TColor; + SeparatorColor1: TColor; + SeparatorColor2: TColor; + DragHandleColor1: TColor; + DragHandleColor2: TColor; + + EmbeddedColor: TColor; + EmbeddedFrameColor: TColor; + EmbeddedDisabledColor: TColor; + + PopupColor: TColor; + PopupFrameColor: TColor; + + DockPanelColor: TColor; + WinFrameColors: array[TWinFramePart] of TColor; + MenuItemColors: array[TMenuItemState, TItemPart] of TColor; + BtnItemColors: array[TBtnItemState, ipText..ipFrame] of TColor; + BtnBodyColors: array[TBtnItemState, Boolean] of TColor; + + StatusPanelFrameColor: TColor; + FMDIAreaColor: TColor; + + procedure SetupColorCache; virtual; + protected + function GetPartColor(const ItemInfo: TTBXItemInfo; ItemPart: TItemPart): TColor; + function GetBtnColor(const ItemInfo: TTBXItemInfo; ItemPart: TItemPart; GradColor2: Boolean = False): TColor; + public + constructor Create(const AName: string); override; + destructor Destroy; override; + + function GetBooleanMetrics(Index: Integer): Boolean; override; + function GetIntegerMetrics(Index: Integer): Integer; override; + procedure GetMargins(MarginID: Integer; out Margins: TTBXMargins); override; + function GetImageOffset(Canvas: TCanvas; const ItemInfo: TTBXItemInfo; ImageList: TCustomImageList): TPoint; override; + function GetItemColor(const ItemInfo: TTBXItemInfo): TColor; override; + function GetItemTextColor(const ItemInfo: TTBXItemInfo): TColor; override; + function GetItemImageBackground(const ItemInfo: TTBXItemInfo): TColor; override; + function GetPopupShadowType: Integer; override; + procedure GetViewBorder(ViewType: Integer; out Border: TPoint); override; + function GetViewColor(AViewType: Integer): TColor; override; + procedure GetViewMargins(ViewType: Integer; out Margins: TTBXMargins); override; + + procedure PaintBackgnd(Canvas: TCanvas; const ADockRect, ARect, AClipRect: TRect; AColor: TColor; Transparent: Boolean; AViewType: Integer); override; + procedure PaintButton(Canvas: TCanvas; const ARect: TRect; const ItemInfo: TTBXItemInfo); override; + procedure PaintCaption(Canvas: TCanvas; const ARect: TRect; const ItemInfo: TTBXItemInfo; const ACaption: string; AFormat: Cardinal; Rotated: Boolean); override; + procedure PaintCheckMark(Canvas: TCanvas; ARect: TRect; const ItemInfo: TTBXItemInfo); override; + procedure PaintChevron(Canvas: TCanvas; ARect: TRect; const ItemInfo: TTBXItemInfo); override; + procedure PaintDock(Canvas: TCanvas; const ClientRect, DockRect: TRect; DockPosition: Integer); override; + procedure PaintDockPanelNCArea(Canvas: TCanvas; R: TRect; const DockPanelInfo: TTBXDockPanelInfo); override; + procedure PaintDropDownArrow(Canvas: TCanvas; const ARect: TRect; const ItemInfo: TTBXItemInfo); override; + procedure PaintEditButton(Canvas: TCanvas; const ARect: TRect; var ItemInfo: TTBXItemInfo; ButtonInfo: TTBXEditBtnInfo); override; + procedure PaintEditFrame(Canvas: TCanvas; const ARect: TRect; var ItemInfo: TTBXItemInfo; const EditInfo: TTBXEditInfo); override; + procedure PaintFloatingBorder(Canvas: TCanvas; const ARect: TRect; const WindowInfo: TTBXWindowInfo); override; + procedure PaintFrame(Canvas: TCanvas; const ARect: TRect; const ItemInfo: TTBXItemInfo); override; + procedure PaintImage(Canvas: TCanvas; ARect: TRect; const ItemInfo: TTBXItemInfo; ImageList: TCustomImageList; ImageIndex: Integer); override; + procedure PaintMDIButton(Canvas: TCanvas; ARect: TRect; const ItemInfo: TTBXItemInfo; ButtonKind: Cardinal); override; + procedure PaintMenuItem(Canvas: TCanvas; const ARect: TRect; var ItemInfo: TTBXItemInfo); override; + procedure PaintMenuItemFrame(Canvas: TCanvas; const ARect: TRect; const ItemInfo: TTBXItemInfo); override; + procedure PaintPageScrollButton(Canvas: TCanvas; const ARect: TRect; ButtonType: Integer; Hot: Boolean); override; + procedure PaintPopupNCArea(Canvas: TCanvas; R: TRect; const PopupInfo: TTBXPopupInfo); override; + procedure PaintSeparator(Canvas: TCanvas; ARect: TRect; ItemInfo: TTBXItemInfo; Horizontal, LineSeparator: Boolean); override; + procedure PaintToolbarNCArea(Canvas: TCanvas; R: TRect; const ToolbarInfo: TTBXToolbarInfo); override; + procedure PaintFrameControl(Canvas: TCanvas; R: TRect; Kind, State: Integer; Params: Pointer); override; + procedure PaintStatusBar(Canvas: TCanvas; R: TRect; Part: Integer); override; + + property MDIAreaColor: TColor read FMDIAreaColor; + + property OnSetupColorCache: TNotifyEvent read FOnSetupColorCache write FOnSetupColorCache; + end; + +function GetOffice2007Scheme: TOffice2007Scheme; +//procedure PaintGradient(DC: HDC; const ARect: TRect; Color1, Color2: TColor); +procedure PaintIrregularGradient(DC: HDC; const ARect: TRect; Color1, Color2: TColor; Horz: Boolean); +function GetMDIWorkspaceColor: TColor; + +implementation + +uses TBXUtils, TB2Common, TB2Item, Controls, CommCtrl, Forms, SysUtils; +var + GradientBmp:TBitmap; +function GetOffice2007Scheme: TOffice2007Scheme; +const + MaxChars = 1024; +var + pszThemeFileName, pszColorBuff, pszSizeBuf: PWideChar; + S: string; + +begin + Result := osUnknown; + if USE_THEMES then + begin + GetMem(pszThemeFileName, 2 * MaxChars); + GetMem(pszColorBuff, 2 * MaxChars); + GetMem(pszSizeBuf, 2 * MaxChars); + try + if not Failed(GetCurrentThemeName(pszThemeFileName, MaxChars, pszColorBuff, MaxChars, pszSizeBuf, MaxChars)) then + if UpperCase(ExtractFileName(pszThemeFileName)) = 'LUNA.MSSTYLES' then + begin + S := UpperCase(pszColorBuff); + if S = 'NORMALCOLOR' then + Result := osBlue + else if S = 'METALLIC' then + Result := osMetallic + else if S = 'HOMESTEAD' then + Result := osGreen; + end; + finally + FreeMem(pszSizeBuf); + FreeMem(pszColorBuff); + FreeMem(pszThemeFileName); + end; + end; +end; + +{chy 2007.01.16 add} +procedure FillGradient2(const DC: HDC; const ARect: TRect; + const StartColor, EndColor: TColor; + const Direction: TGradDir); +var + rc1, rc2, gc1, gc2, bc1, bc2, Counter, GSize: Integer; + Brush : HBrush; +begin + rc1 := GetRValue(ColorToRGB(StartColor)); + gc1 := GetGValue(ColorToRGB(StartColor)); + bc1 := GetBValue(ColorToRGB(StartColor)); + rc2 := GetRValue(ColorToRGB(EndColor)); + gc2 := GetGValue(ColorToRGB(EndColor)); + bc2 := GetBValue(ColorToRGB(EndColor)); + + if Direction = tGTopBottom then + begin + GSize := (ARect.Bottom - ARect.Top) - 1; + for Counter := 0 to GSize do + begin + Brush := CreateSolidBrush( + RGB(Byte(rc1 + (((rc2 - rc1) * (Counter)) div GSize)), + Byte(gc1 + (((gc2 - gc1) * (Counter)) div GSize)), + Byte(bc1 + (((bc2 - bc1) * (Counter)) div GSize)))); + Windows.FillRect(DC, Rect(ARect.Left, ARect.Top, ARect.Right, ARect.Bottom - Counter), Brush); + DeleteObject(Brush); + end; + end + else + begin + GSize := (ARect.Right - ARect.Left) - 1; + for Counter := 0 to GSize do + begin + Brush := CreateSolidBrush( + RGB(Byte(rc1 + (((rc2 - rc1) * (Counter)) div GSize)), + Byte(gc1 + (((gc2 - gc1) * (Counter)) div GSize)), + Byte(bc1 + (((bc2 - bc1) * (Counter)) div GSize)))); + Windows.FillRect(DC, Rect(ARect.Left, ARect.Top, ARect.Right - Counter, ARect.Bottom), Brush); + DeleteObject(Brush); + end; + end; +end; + +procedure FillGradient(const Canvas: TCanvas; const ARect: TRect; + const StartColor, EndColor: TColor; + const Direction: TGradDir); +type + PRGBTripleArray = ^TRGBTripleArray; + TRGBTripleArray = array[0..1024] of TRGBTriple; + TGradientColors = array[0..255] of TRGBTriple; +var + rc1, gc1, bc1, rc2, gc2, bc2, rc3, gc3, bc3, + y1, i, GSize : Integer; + + Row : PRGBTripleArray; + GradCol : TRGBTriple; +begin + rc2 := GetRValue(ColorToRGB(StartColor)); + gc2 := GetGValue(ColorToRGB(StartColor)); + bc2 := GetBValue(ColorToRGB(StartColor)); + rc1 := GetRValue(ColorToRGB(EndColor)); + gc1 := GetGValue(ColorToRGB(EndColor)); + bc1 := GetBValue(ColorToRGB(EndColor)); + + rc3 := rc1 + (((rc2 - rc1) * 15) div 9); + gc3 := gc1 + (((gc2 - gc1) * 15) div 9); + bc3 := bc1 + (((bc2 - bc1) * 15) div 9); + + if rc3 < 0 then + rc3 := 0 + else if rc3 > 255 then + rc3 := 255; + if gc3 < 0 then + gc3 := 0 + else if gc3 > 255 then + gc3 := 255; + if bc3 < 0 then + bc3 := 0 + else if bc3 > 255 then + bc3 := 255; + + if Direction = tGTopBottom then + begin + GradientBmp.Width := 1; + GradientBmp.Height := (ARect.Bottom - ARect.Top) - 1; + GSize := GradientBmp.Height; + + y1 := GSize div 2; + for i := 0 to y1 - 1 do + begin + Row := PRGBTripleArray(GradientBmp.ScanLine[i]); + GradCol.rgbtRed := Byte(rc1 + (((rc2 - rc1) * (i)) div y1)); + GradCol.rgbtGreen := Byte(gc1 + (((gc2 - gc1) * (i)) div y1)); + GradCol.rgbtBlue := Byte(bc1 + (((bc2 - bc1) * (i)) div y1)); + Row[0] := GradCol; + end; + if rc2 > rc1 then + begin + rc3 := rc2; + gc3 := gc2; + bc3 := bc2; + end; + for i := y1 to GSize - 1 do + begin + Row := PRGBTripleArray(GradientBmp.ScanLine[i]); + GradCol.rgbtRed := Byte(rc3 + (((rc2 - rc3) * (i)) div GSize)); + GradCol.rgbtGreen := Byte(gc3 + (((gc2 - gc3) * (i)) div GSize)); + GradCol.rgbtBlue := Byte(bc3 + (((bc2 - bc3) * (i)) div GSize)); + Row[0] := GradCol; + end; + Canvas.StretchDraw(ARect, GradientBmp); + end + else + begin + GradientBmp.Width := (ARect.Right - ARect.Left) - 1; + GradientBmp.Height := 1; + GSize := GradientBmp.Width; + + y1 := GSize div 2; + Row := PRGBTripleArray(GradientBmp.ScanLine[0]); + for i := 0 to y1 - 1 do + begin + GradCol.rgbtRed := Byte(rc1 + (((rc2 - rc1) * (i)) div y1)); + GradCol.rgbtGreen := Byte(gc1 + (((gc2 - gc1) * (i)) div y1)); + GradCol.rgbtBlue := Byte(bc1 + (((bc2 - bc1) * (i)) div y1)); + Row[i] := GradCol; + end; + + if rc2 > rc1 then + begin + rc3 := rc2; + gc3 := gc2; + bc3 := bc2; + end; + + for i := y1 to GSize - 1 do + begin + GradCol.rgbtRed := Byte(rc2 + (((rc3 - rc2) * (i)) div GSize)); + GradCol.rgbtGreen := Byte(gc2 + (((gc3 - gc2) * (i)) div GSize)); + GradCol.rgbtBlue := Byte(bc2 + (((bc3 - bc2) * (i)) div GSize)); + Row[i] := GradCol; + end; + + Canvas.StretchDraw(ARect, GradientBmp); + end; +end; +procedure PaintGradientEx(DC: HDC; const ARect: TRect; Color1, Color2: TColor); +var + r1, g1, b1, r2, g2, b2: Byte; + I, Size: Integer; + hbr: HBRUSH; + lprc: TRect; +begin + Color1 := ColorToRGB(Color1); + Color2 := ColorToRGB(Color2); + if Color1 = Color2 then + FillRectEx(DC, ARect, Color1) + else + begin + Size := ARect.Bottom - ARect.Top; + r1 := GetRValue(Color1); + g1 := GetGValue(Color1); + b1 := GetBValue(Color1); + r2 := GetRValue(Color2); + g2 := GetGValue(Color2); + b2 := GetBValue(Color2); + + lprc := ARect; + lprc.Bottom := lprc.Top + 1; + Dec(Size); + if Size <= 0 then Exit; + for I := 0 to Size do + begin + hbr := CreateSolidBrush(RGB((r2 - r1) * I div Size + r1, (g2 - g1) * I div Size + g1, (b2 - b1) * I div Size + b1)); + FillRect(DC, lprc, hbr); + DeleteObject(hbr); + OffsetRect(lprc, 0, 1); + end; + end; +end; +{ +procedure PaintGradient(DC: HDC; const ARect: TRect; Color1, Color2: TColor); +var + r: TRect; +begin + FillGradient(DC,ARect, Color2, Color1,tGTopBottom); +end; + } +procedure PaintGradientBig(DC: HDC; const ARect: TRect; Color1, Color2: TColor); +var + r: TRect; +begin + //First gradient - caption + r := ARect; + if r.Bottom < r.Top + 50 then + r.Bottom := r.Top + (r.Bottom - r.Top) div 4 + else + r.Bottom := r.Top + 15; + PaintGradientEx(DC, r, Color1, Color2); + //Second gradient - description + r.Top := r.Bottom; + r.Bottom := ARect.Bottom; + PaintGradientEx(DC, r, Color2, Color1); +end; +var + IrregularGradientValue: Integer; + +procedure PaintIrregularGradient(DC: HDC; const ARect: TRect; Color1, Color2: TColor; Horz: Boolean); +var + r1, g1, b1, r2, g2, b2: Integer; + rm1, gm1, bm1, rm2, gm2, bm2: Integer; + lprc: TRect; + I, Size, Middle: Integer; + hbr: HBRUSH; +begin + Color1 := ColorToRGB(Color1); + Color2 := ColorToRGB(Color2); + if Color1 = Color2 then + FillRectEx(DC, ARect, Color1) + else + begin + if IsRectEmpty(ARect) then Exit; + + r1 := GetRValue(Color1); + g1 := GetGValue(Color1); + b1 := GetBValue(Color1); + r2 := GetRValue(Color2); + g2 := GetGValue(Color2); + b2 := GetBValue(Color2); + + lprc := ARect; + + if Horz then + begin + Size := ARect.Right - ARect.Left; + lprc.Right := lprc.Left + 1; + end + else + begin + Size := ARect.Bottom - ARect.Top; + lprc.Bottom := lprc.Top + 1; + end; + + Middle := Size div 2; + + rm1 := (r2 - r1) * IrregularGradientValue div 40 + r1; + gm1 := (g2 - g1) * IrregularGradientValue div 40 + g1; + bm1 := (b2 - b1) * IrregularGradientValue div 40 + b1; + rm2 := (rm1 - r1) * Size div Middle + r1; + gm2 := (gm1 - g1) * Size div Middle + g1; + bm2 := (bm1 - b1) * Size div Middle + b1; + + Dec(Size); + for I := 0 to Middle - 1 do + begin + hbr := CreateSolidBrush(RGB((rm2 - r1) * I div Size + r1, (gm2 - g1) * I div Size + g1, (bm2 - b1) * I div Size + b1)); + FillRect(DC, lprc, hbr); + DeleteObject(hbr); + OffsetRect(lprc, Ord(Horz), Ord(not Horz)); + end; + + hbr := CreateSolidBrush(RGB(rm1, gm1, bm1)); + FillRect(DC, lprc, hbr); + DeleteObject(hbr); + OffsetRect(lprc, Ord(Horz), Ord(not Horz)); + + rm1 := rm1 * 2 - r2; + gm1 := gm1 * 2 - g2; + bm1 := bm1 * 2 - b2; + + for I := Middle + 1 to Size do + begin + hbr := CreateSolidBrush(RGB((r2 - rm1) * I div Size + rm1, (g2 - gm1) * I div Size + gm1, (b2 - bm1) * I div Size + bm1)); + FillRect(DC, lprc, hbr); + DeleteObject(hbr); + OffsetRect(lprc, Ord(Horz), Ord(not Horz)); + end; + end; +end; + +procedure PaintIrregularGradientEx(DC: HDC; const ARect: TRect; Color1, Color2: TColor; Horz: Boolean); +var + r: TRect; +begin + //First gradient - caption + r := ARect; + // r.Bottom := r.Top + r.Bottom div 3; + // PaintIrregularGradient(DC, r,Color1, Color2,Horz); + //Second gradient - description + // r.Top := r.Bottom; + // r.Bottom := ARect.Bottom; + PaintIrregularGradient(DC, r, Color2, Color1, Horz); +end; + +function GetMDIWorkspaceColor: TColor; +const + MDIColors: array[TOffice2007Scheme] of TColor = ($AE9990, $B39A9B, $7BA097, clBtnShadow); +begin + Result := MDIColors[GetOffice2007Scheme]; +end; + +var + StockImgList: TImageList; + CounterLock: Integer; + +procedure InitializeStock; +begin + StockImgList := TImageList.Create(nil); + StockImgList.Handle := ImageList_LoadBitmap(HInstance, 'TBXGLYPHS', 16, 0, clWhite); + GradientBmp := TBitmap.Create; + GradientBmp.PixelFormat := pf24bit; +end; + +procedure FinalizeStock; +begin + GradientBmp.Free; + StockImgList.Free; +end; + +{ TTBXOffice2007Theme } + +function TTBXOffice2007Theme.GetBooleanMetrics(Index: Integer): Boolean; +begin + case Index of + TMB_OFFICEXPPOPUPALIGNMENT: Result := True; + TMB_EDITMENUFULLSELECT: Result := True; + TMB_EDITHEIGHTEVEN: Result := False; + TMB_SOLIDTOOLBARNCAREA: Result := False; + TMB_SOLIDTOOLBARCLIENTAREA: Result := True; + TMB_PAINTDOCKBACKGROUND: Result := True; + else + Result := False; + end; +end; + +function TTBXOffice2007Theme.GetIntegerMetrics(Index: Integer): Integer; +begin + case Index of + TMI_SPLITBTN_ARROWWIDTH: Result := 12; + + TMI_DROPDOWN_ARROWWIDTH: Result := 8; + TMI_DROPDOWN_ARROWMARGIN: Result := 3; + + TMI_MENU_IMGTEXTSPACE: Result := 5; + TMI_MENU_LCAPTIONMARGIN: Result := 3; + TMI_MENU_RCAPTIONMARGIN: Result := 3; + TMI_MENU_SEPARATORSIZE: Result := 3; + TMI_MENU_MDI_DW: Result := 2; + TMI_MENU_MDI_DH: Result := 2; + + TMI_TLBR_SEPARATORSIZE: Result := 6; + + TMI_EDIT_FRAMEWIDTH: Result := 1; + TMI_EDIT_TEXTMARGINHORZ: Result := 2; + TMI_EDIT_TEXTMARGINVERT: Result := 2; + TMI_EDIT_BTNWIDTH: Result := 14; + TMI_EDIT_MENURIGHTINDENT: Result := 1; + else + Result := -1; + end; +end; + +function TTBXOffice2007Theme.GetViewColor(AViewType: Integer): TColor; +begin + Result := DockColor; + if (AViewType and VT_TOOLBAR) = VT_TOOLBAR then + begin + if (AViewType and TVT_MENUBAR) = TVT_MENUBAR then Result := DockColor + else Result := ToolbarColor1; + end + else if (AViewType and VT_POPUP) = VT_POPUP then + begin + if (AViewType and PVT_LISTBOX) = PVT_LISTBOX then Result := clWindow + else Result := PopupColor; + end + else if (AViewType and VT_DOCKPANEL) = VT_DOCKPANEL then Result := DockPanelColor; +end; + +function TTBXOffice2007Theme.GetBtnColor(const ItemInfo: TTBXItemInfo; ItemPart: TItemPart; GradColor2: Boolean = False): TColor; +const + BFlags1: array[Boolean] of TBtnItemState = (bisDisabled, bisDisabledHot); + BFlags2: array[Boolean] of TBtnItemState = (bisSelected, bisSelectedHot); + BFlags3: array[Boolean] of TBtnItemState = (bisNormal, bisHot); +var + B: TBtnItemState; + Embedded: Boolean; +begin + with ItemInfo do + begin + Embedded := (ViewType and VT_TOOLBAR = VT_TOOLBAR) and (ViewType and TVT_EMBEDDED = TVT_EMBEDDED); + if not Enabled then B := BFlags1[HoverKind = hkKeyboardHover] + else if ItemInfo.IsPopupParent then B := bisPopupParent + else if Pushed then B := bisPressed + else if Selected then B := BFlags2[HoverKind <> hkNone] + else B := BFlags3[HoverKind <> hkNone]; + if ItemPart = ipBody then + Result := BtnBodyColors[B, GradColor2] + else + Result := BtnItemColors[B, ItemPart]; + if Embedded and (Result = clNone) then + begin + if ItemPart = ipBody then Result := EmbeddedColor; + if (ItemPart = ipFrame) and not Selected then Result := EmbeddedFrameColor; + end; + end; +end; + +function TTBXOffice2007Theme.GetPartColor(const ItemInfo: TTBXItemInfo; ItemPart: TItemPart): TColor; +const + MFlags1: array[Boolean] of TMenuItemState = (misDisabled, misDisabledHot); + MFlags2: array[Boolean] of TMenuItemState = (misNormal, misHot); + BFlags1: array[Boolean] of TBtnItemState = (bisDisabled, bisDisabledHot); + BFlags2: array[Boolean] of TBtnItemState = (bisSelected, bisSelectedHot); + BFlags3: array[Boolean] of TBtnItemState = (bisNormal, bisHot); +var + IsMenuItem, Embedded: Boolean; + M: TMenuItemState; + B: TBtnItemState; +begin + with ItemInfo do + begin + IsMenuItem := ((ViewType and PVT_POPUPMENU) = PVT_POPUPMENU) and + ((ItemOptions and IO_TOOLBARSTYLE) = 0); + Embedded := ((ViewType and VT_TOOLBAR) = VT_TOOLBAR) and + ((ViewType and TVT_EMBEDDED) = TVT_EMBEDDED); + if IsMenuItem then + begin + if not Enabled then M := MFlags1[HoverKind = hkKeyboardHover] + else M := MFlags2[HoverKind <> hkNone]; + Result := MenuItemColors[M, ItemPart]; + end + else + begin + if not Enabled then B := BFlags1[HoverKind = hkKeyboardHover] + else if ItemInfo.IsPopupParent then B := bisPopupParent + else if Pushed then B := bisPressed + else if Selected then B := BFlags2[HoverKind <> hkNone] + else B := BFlags3[HoverKind <> hkNone]; + if ItemPart = ipBody then + Result := BtnBodyColors[B, False] + else + Result := BtnItemColors[B, ItemPart]; + if Embedded and (Result = clNone) then + begin + if ItemPart = ipBody then Result := EmbeddedColor; + if ItemPart = ipFrame then Result := EmbeddedFrameColor; + end; + end; + end; +end; + +function TTBXOffice2007Theme.GetItemColor(const ItemInfo: TTBXItemInfo): TColor; +begin + Result := GetPartColor(ItemInfo, ipBody); + if Result = clNone then Result := GetViewColor(ItemInfo.ViewType); +end; + +function TTBXOffice2007Theme.GetItemTextColor(const ItemInfo: TTBXItemInfo): TColor; +begin + Result := GetPartColor(ItemInfo, ipText); +end; + +function TTBXOffice2007Theme.GetItemImageBackground(const ItemInfo: TTBXItemInfo): TColor; +begin + Result := GetBtnColor(ItemInfo, ipBody); + if Result = clNone then Result := GetViewColor(ItemInfo.ViewType); +end; + +procedure TTBXOffice2007Theme.GetViewBorder(ViewType: Integer; out Border: TPoint); +const + XMetrics: array[Boolean] of Integer = (SM_CXDLGFRAME, SM_CXFRAME); + YMetrics: array[Boolean] of Integer = (SM_CYDLGFRAME, SM_CYFRAME); +var + Resizable: Boolean; + + procedure SetBorder(X, Y: Integer); + begin + Border.X := X; + Border.Y := Y; + end; + +begin + if (ViewType and VT_TOOLBAR) = VT_TOOLBAR then + begin + if (ViewType and TVT_FLOATING) = TVT_FLOATING then + begin + Resizable := (ViewType and TVT_RESIZABLE) = TVT_RESIZABLE; + Border.X := GetSystemMetrics(XMetrics[Resizable]) - 1; + Border.Y := GetSystemMetrics(YMetrics[Resizable]) - 1; + end + else SetBorder(2, 2); + end + else if (ViewType and VT_POPUP) = VT_POPUP then + begin + if (ViewType and PVT_POPUPMENU) = PVT_POPUPMENU then Border.X := 1 + else Border.X := 2; + Border.Y := 2; + end + else if (ViewType and VT_DOCKPANEL) = VT_DOCKPANEL then + begin + if (ViewType and DPVT_FLOATING) = DPVT_FLOATING then + begin + Resizable := (ViewType and DPVT_RESIZABLE) = DPVT_RESIZABLE; + Border.X := GetSystemMetrics(XMetrics[Resizable]) - 1; + Border.Y := GetSystemMetrics(YMetrics[Resizable]) - 1; + end + else SetBorder(2, 2); + end + else SetBorder(0, 0); +end; + +procedure TTBXOffice2007Theme.GetMargins(MarginID: Integer; out Margins: TTBXMargins); +begin + with Margins do + case MarginID of + MID_TOOLBARITEM: + begin + LeftWidth := 2; RightWidth := 2; + TopHeight := 2; BottomHeight := 2; + end; + MID_MENUITEM: + begin + LeftWidth := 1; RightWidth := 1; + TopHeight := 3; BottomHeight := 3; + end; + MID_STATUSPANE: + begin + LeftWidth := 1; RightWidth := 3; + TopHeight := 1; BottomHeight := 1; + end; + else + LeftWidth := 0; + RightWidth := 0; + TopHeight := 0; + BottomHeight := 0; + end; +end; + +procedure TTBXOffice2007Theme.PaintBackgnd(Canvas: TCanvas; const ADockRect, ARect, AClipRect: TRect; + AColor: TColor; Transparent: Boolean; AViewType: Integer); +var + DC: HDC; + R: TRect; + //Horz: Boolean; +begin + DC := Canvas.Handle; + if not Transparent then + begin + IntersectRect(R, ARect, AClipRect); + if ((AViewType and TVT_NORMALTOOLBAR = TVT_NORMALTOOLBAR) or (AViewType and TVT_TOOLWINDOW = TVT_TOOLWINDOW)) and not (AViewType and TVT_EMBEDDED = TVT_EMBEDDED) then + begin +// if IsRectEmpty(ADockRect) then +// Horz := (ARect.Right > ARect.Bottom) +// else +// Horz := Abs(R.Right - R.Left) > Abs(R.Bottom - R.Top); + // chy 2006.11.20 changed ÐèÒª¸ù¾Ý×ÝÏòºÍºáÏò½øÐнøÒ»²½´¦Àí + // PaintIrregularGradient(Canvas.Handle, R, ToolbarColor1, ToolbarColor2, not Horz); + PaintGradientBig(Canvas.Handle, R, ToolbarColor1, ToolbarColor2); + end + else + // chy 2006.11.20 changed + //FillRectEx(DC, R, AColor); + if ((AViewType and TVT_MENUBAR) = TVT_MENUBAR) then + FillRectEx(DC, R, AColor) + else if (AViewType and PVT_POPUPMENU=PVT_POPUPMENU)or(AViewType and PVT_TOOLBOX=PVT_TOOLBOX) then + FillRectEx(DC, R, ToolbarColor1) + else + begin + PaintGradientBig(DC, R, ToolbarColor1, ToolbarColor2); + end; + end; +end; + +procedure TTBXOffice2007Theme.PaintCaption(Canvas: TCanvas; + const ARect: TRect; const ItemInfo: TTBXItemInfo; const ACaption: string; + AFormat: Cardinal; Rotated: Boolean); +var + R: TRect; +begin + with ItemInfo, Canvas do + begin + R := ARect; + Brush.Style := bsClear; + if Font.Color = clNone then Font.Color := GetPartColor(ItemInfo, ipText); + if not Rotated then Windows.DrawText(Handle, PChar(ACaption), Length(ACaption), R, AFormat) + else DrawRotatedText(Handle, ACaption, R, AFormat); + Brush.Style := bsSolid; + end; +end; + +procedure TTBXOffice2007Theme.PaintCheckMark(Canvas: TCanvas; ARect: TRect; const ItemInfo: TTBXItemInfo); +var + DC: HDC; + X, Y: Integer; + C: TColor; +begin + DC := Canvas.Handle; + X := (ARect.Left + ARect.Right) div 2 - 2; + Y := (ARect.Top + ARect.Bottom) div 2 + 1; + C := GetBtnColor(ItemInfo, ipText); + if ItemInfo.ItemOptions and IO_RADIO > 0 then + begin + RoundRectEx(DC, X - 1, Y - 4, X + 5, Y + 2, 2, 2, MixColors(C, ToolbarColor1, 200), clNone); + RoundRectEx(DC, X - 1, Y - 4, X + 5, Y + 2, 6, 6, C, C); + end + else + PolylineEx(DC, [Point(X - 2, Y - 2), Point(X, Y), Point(X + 4, Y - 4), + Point(X + 4, Y - 3), Point(X, Y + 1), Point(X - 2, Y - 1), Point(X - 2, Y - 2)], C); +end; + +procedure TTBXOffice2007Theme.PaintChevron(Canvas: TCanvas; ARect: TRect; const ItemInfo: TTBXItemInfo); +const + Pattern: array[Boolean, 0..15] of Byte = ( + ($CC, 0, $66, 0, $33, 0, $66, 0, $CC, 0, 0, 0, 0, 0, 0, 0), + ($88, 0, $D8, 0, $70, 0, $20, 0, $88, 0, $D8, 0, $70, 0, $20, 0)); +var + R2: TRect; + W, H: Integer; +begin + R2 := ARect; + PaintButton(Canvas, ARect, ItemInfo); + if not ItemInfo.IsVertical then + begin + Inc(R2.Top, 4); + R2.Bottom := R2.Top + 5; + W := 8; + H := 5; + end + else + begin + R2.Left := R2.Right - 9; + R2.Right := R2.Left + 5; + W := 5; + H := 8; + end; + DrawGlyph(Canvas.Handle, R2, W, H, Pattern[ItemInfo.IsVertical][0], GetPartColor(ItemInfo, ipText)); +end; + +procedure TTBXOffice2007Theme.PaintEditButton(Canvas: TCanvas; const ARect: TRect; + var ItemInfo: TTBXItemInfo; ButtonInfo: TTBXEditBtnInfo); +var + DC: HDC; + BtnDisabled, BtnHot, BtnPressed, Embedded: Boolean; + R, BR: TRect; + X, Y: Integer; + SaveItemInfoPushed: Boolean; + C: TColor; +begin + DC := Canvas.Handle; + R := ARect; + Embedded := ((ItemInfo.ViewType and VT_TOOLBAR) = VT_TOOLBAR) and + ((ItemInfo.ViewType and TVT_EMBEDDED) = TVT_EMBEDDED); + + InflateRect(R, 1, 1); + Inc(R.Left); + with Canvas do + if ButtonInfo.ButtonType = EBT_DROPDOWN then + begin + BtnDisabled := (ButtonInfo.ButtonState and EBDS_DISABLED) <> 0; + BtnHot := (ButtonInfo.ButtonState and EBDS_HOT) <> 0; + BtnPressed := (ButtonInfo.ButtonState and EBDS_PRESSED) <> 0; + if not BtnDisabled then + begin + if BtnPressed or BtnHot or Embedded then PaintButton(Canvas, R, ItemInfo) + else if (ItemInfo.ViewType and VT_TOOLBAR) = VT_TOOLBAR then + begin + R := ARect; + if not Embedded then + begin + FrameRectEx(DC, R, clWindow, False); + C := clWindow; + end + else C := GetBtnColor(ItemInfo, ipFrame); + DrawLineEx(DC, R.Left - 1, R.Top, R.Left - 1, R.Bottom, C); + end; + end; + PaintDropDownArrow(Canvas, R, ItemInfo); + end + else if ButtonInfo.ButtonType = EBT_SPIN then + begin + BtnDisabled := (ButtonInfo.ButtonState and EBSS_DISABLED) <> 0; + BtnHot := (ButtonInfo.ButtonState and EBSS_HOT) <> 0; + + { Upper button } + BR := R; + BR.Bottom := (R.Top + R.Bottom + 1) div 2; + BtnPressed := (ButtonInfo.ButtonState and EBSS_UP) <> 0; + SaveItemInfoPushed := ItemInfo.Pushed; + ItemInfo.Pushed := BtnPressed; + if not BtnDisabled then + begin + if BtnPressed or BtnHot or Embedded then PaintButton(Canvas, BR, ItemInfo) + else if (ItemInfo.ViewType and VT_TOOLBAR) = VT_TOOLBAR then + begin + BR.Left := ARect.Left; BR.Top := ARect.Top; BR.Right := ARect.Right; + if not Embedded then + begin + FrameRectEx(DC, BR, clWindow, False); + C := clWindow; + end + else C := GetBtnColor(ItemInfo, ipFrame); + DrawLineEx(DC, BR.Left - 1, BR.Top, BR.Left - 1, BR.Bottom, C); + end; + end; + X := (BR.Left + BR.Right) div 2; + Y := (BR.Top + BR.Bottom - 1) div 2; + Pen.Color := GetPartColor(ItemInfo, ipText); + Brush.Color := Pen.Color; + Polygon([Point(X - 2, Y + 1), Point(X + 2, Y + 1), Point(X, Y - 1)]); + + { Lower button } + BR := R; + BR.Top := (R.Top + R.Bottom) div 2; + BtnPressed := (ButtonInfo.ButtonState and EBSS_DOWN) <> 0; + ItemInfo.Pushed := BtnPressed; + if not BtnDisabled then + begin + if BtnPressed or BtnHot or Embedded then PaintButton(Canvas, BR, ItemInfo) + else if (ItemInfo.ViewType and VT_TOOLBAR) = VT_TOOLBAR then + begin + BR.Left := ARect.Left; BR.Bottom := ARect.Bottom; BR.Right := ARect.Right; + if not Embedded then + begin + FrameRectEx(DC, BR, clWindow, False); + C := clWindow; + end + else C := GetBtnColor(ItemInfo, ipFrame); + DrawLineEx(DC, BR.Left - 1, BR.Top, BR.Left - 1, BR.Bottom, C); + end; + end; + X := (BR.Left + BR.Right) div 2; + Y := (BR.Top + BR.Bottom) div 2; + C := GetPartColor(ItemInfo, ipText); + PolygonEx(DC, [Point(X - 2, Y - 1), Point(X + 2, Y - 1), Point(X, Y + 1)], C, C); + + ItemInfo.Pushed := SaveItemInfoPushed; + end; +end; + +procedure TTBXOffice2007Theme.PaintEditFrame(Canvas: TCanvas; + const ARect: TRect; var ItemInfo: TTBXItemInfo; const EditInfo: TTBXEditInfo); +var + DC: HDC; + R: TRect; + W: Integer; + Embedded: Boolean; +begin + DC := Canvas.Handle; + R := ARect; + PaintFrame(Canvas, R, ItemInfo); + W := EditFrameWidth; + InflateRect(R, -W, -W); + Embedded := ((ItemInfo.ViewType and VT_TOOLBAR) = VT_TOOLBAR) and + ((ItemInfo.ViewType and TVT_EMBEDDED) = TVT_EMBEDDED); + if not (ItemInfo.Enabled or Embedded) then + FrameRectEx(DC, R, BtnItemColors[bisDisabled, ipText], False); + + with EditInfo do if RightBtnWidth > 0 then Dec(R.Right, RightBtnWidth - 2); + + if ItemInfo.Enabled then + begin + if ((ItemInfo.ViewType and VT_TOOLBAR) <> VT_TOOLBAR) and (GetPartColor(ItemInfo, ipFrame) = clNone) then + FrameRectEx(DC, R, ToolbarColor2, False) + else + FrameRectEx(DC, R, clWindow, False); + + InflateRect(R, -1, -1); + FillRectEx(DC, R, clWindow); + if ((ItemInfo.ViewType and VT_TOOLBAR) <> VT_TOOLBAR) and (GetPartColor(ItemInfo, ipFrame) = clNone) then + begin + R := ARect; + InflateRect(R, -1, -1); + FrameRectEx(DC, R, ToolbarColor2, False); + end; + end + else InflateRect(R, -1, -1); + + with EditInfo do if LeftBtnWidth > 0 then Inc(R.Left, LeftBtnWidth - 2); + + if EditInfo.RightBtnWidth > 0 then + begin + R := ARect; + InflateRect(R, -W, -W); + R.Left := R.Right - EditInfo.RightBtnWidth; + PaintEditButton(Canvas, R, ItemInfo, EditInfo.RightBtnInfo); + end; +end; + +procedure TTBXOffice2007Theme.PaintDropDownArrow(Canvas: TCanvas; + const ARect: TRect; const ItemInfo: TTBXItemInfo); +var + X, Y: Integer; +begin + with ARect, Canvas do + begin + X := (Left + Right) div 2; + Y := (Top + Bottom) div 2 - 1; + Pen.Color := GetPartColor(ItemInfo, ipText); + Brush.Color := Pen.Color; + if ItemInfo.IsVertical then Polygon([Point(X, Y + 2), Point(X, Y - 2), Point(X - 2, Y)]) + else Polygon([Point(X - 2, Y), Point(X + 2, Y), Point(X, Y + 2)]); + end; +end; + +procedure TTBXOffice2007Theme.PaintButton(Canvas: TCanvas; const ARect: TRect; const ItemInfo: TTBXItemInfo); +var + DC: HDC; + R: TRect; + tmpColor1, tmpColor2: TColor; +begin + DC := Canvas.Handle; + with ItemInfo do + begin + R := ARect; + if ((ItemOptions and IO_DESIGNING) <> 0) and not Selected then + begin + if ComboPart = cpSplitRight then Dec(R.Left); + FrameRectEx(DC, R, clNavy, False); + end + else + begin + //chy 2006.11.20 changed + // FrameRectEx(DC, R, GetBtnColor(ItemInfo, ipFrame), True); + + if (ComboPart = cpSplitLeft) and IsPopupParent then Inc(R.Right); + if ComboPart = cpSplitRight then Dec(R.Left); + + tmpColor1 := GetBtnColor(ItemInfo, ipBody); + tmpColor2 := GetBtnColor(ItemInfo, ipBody, True); + + if (ItemInfo.ViewType and VT_POPUP = VT_POPUP) or (ItemInfo.ViewType and VT_TOOLBAR = VT_TOOLBAR) and (ItemInfo.ViewType and TVT_EMBEDDED = TVT_EMBEDDED) then + begin + //chy 2006.11.20 changed + // FrameRectEx(DC, R, GetBtnColor(ItemInfo, ipFrame), True); + FillRectEx(DC, R, tmpColor1); + // chy 2007.01.15--- PaintGradient(DC, R, GetBtnColor(ItemInfo, ipBody), GetBtnColor(ItemInfo, ipBody, True)); + if ItemInfo.HoverKind<>hkNone then begin + InflateRect(R, -1, -1); + FillGradient(Canvas,R, GetBtnColor(ItemInfo, ipBody,true), clwhite,tGTopBottom); + InflateRect(R, 1, 1); + + Canvas.Pen.Color := $00C5C5C5; + Canvas.Brush.Style := bsClear; + Canvas.RoundRect(R.Left, R.Top, R.Right, R.Bottom, 4, 4); + end; + end + else if (tmpColor1 <> clNone) and (tmpColor2 <> clNone) then + begin + // PaintGradient(DC, R, tmpColor1, tmpColor2); + //¡¡2006.11.19 chy changed + InflateRect(R, -1, -1); + //chy 2007.01.115 PaintGradient(DC, R, GetBtnColor(ItemInfo, ipBody), GetBtnColor(ItemInfo, ipBody, True)); + FillGradient(Canvas,R, GetBtnColor(ItemInfo, ipBody,true), clwhite,tGTopBottom); + InflateRect(R, 1, 1); + + //ÐèÒª½øÒ»²½µ÷Õû ,ok 2007.01.17 + if ((ItemInfo.ViewType and TVT_MENUBAR) = TVT_MENUBAR) + then + Canvas.Pen.Color := ToolbarFrameColor1//PopupFrameColor;// ToolbarFrameColor1; + else + Canvas.Pen.Color :=$00C5C5C5; + Canvas.Brush.Style := bsClear; + Canvas.RoundRect(R.Left, R.Top, R.Right, R.Bottom, 4, 4); + end; + end; + if ComboPart = cpSplitRight then PaintDropDownArrow(Canvas, R, ItemInfo); + end; +end; + +procedure TTBXOffice2007Theme.PaintFloatingBorder(Canvas: TCanvas; const ARect: TRect; + const WindowInfo: TTBXWindowInfo); + + function GetBtnItemState(BtnState: Integer): TBtnItemState; + begin + if not WindowInfo.Active then Result := bisDisabled + else if (BtnState and CDBS_PRESSED) <> 0 then Result := bisPressed + else if (BtnState and CDBS_HOT) <> 0 then Result := bisHot + else Result := bisNormal; + end; + +var + BtnItemState: TBtnItemState; + SaveIndex, X, Y: Integer; + Sz: TPoint; + R: TRect; + BodyColor, CaptionColor, CaptionText: TColor; + IsDockPanel: Boolean; +begin + with Canvas do + begin + IsDockPanel := (WindowInfo.ViewType and VT_DOCKPANEL) = VT_DOCKPANEL; + BodyColor := Brush.Color; + + if (WRP_BORDER and WindowInfo.RedrawPart) <> 0 then + begin + R := ARect; + + if not IsDockPanel then Brush.Color := WinFrameColors[wfpBorder] + else Brush.Color := WinFrameColors[wfpBorder]; + + SaveIndex := SaveDC(Canvas.Handle); + Sz := WindowInfo.FloatingBorderSize; + with R, Sz do ExcludeClipRect(Canvas.Handle, Left + X, Top + Y, Right - X, Bottom - Y); + FillRect(R); + RestoreDC(Canvas.Handle, SaveIndex); + InflateRect(R, -Sz.X, -Sz.Y); + Pen.Color := BodyColor; + with R do + if not IsDockPanel then + Canvas.Polyline([ + Point(Left, Top - 1), Point(Right - 1, Top - 1), + Point(Right, Top), Point(Right, Bottom - 1), + Point(Right - 1, Bottom), + Point(Left, Bottom), Point(Left - 1, Bottom - 1), + Point(Left - 1, Top), Point(Left, Top - 1) + ]) + else + Canvas.Polyline([ + Point(Left, Top - 1), Point(Right - 1, Top - 1), + Point(Right, Top), Point(Right, Bottom), + Point(Left - 1, Bottom), + Point(Left - 1, Top), Point(Left, Top - 1) + ]); + end; + + if not WindowInfo.ShowCaption then Exit; + + if (WindowInfo.ViewType and VT_TOOLBAR) = VT_TOOLBAR then + begin + CaptionColor := WinFrameColors[wfpCaption]; + CaptionText := WinFrameColors[wfpCaptionText]; + end + else + begin + CaptionColor := WinFrameColors[wfpCaption]; + CaptionText := WinFrameColors[wfpCaptionText]; + end; + + { Caption } + if (WRP_CAPTION and WindowInfo.RedrawPart) <> 0 then + begin + R := Rect(0, 0, WindowInfo.ClientWidth, GetSystemMetrics(SM_CYSMCAPTION) - 1); + with WindowInfo.FloatingBorderSize do OffsetRect(R, X, Y); + DrawLineEx(Canvas.Handle, R.Left, R.Bottom, R.Right, R.Bottom, BodyColor); + + if ((CDBS_VISIBLE and WindowInfo.CloseButtonState) <> 0) and + ((WRP_CLOSEBTN and WindowInfo.RedrawPart) <> 0) then + Dec(R.Right, GetSystemMetrics(SM_CYSMCAPTION) - 1); + + Brush.Color := CaptionColor; + FillRect(R); + InflateRect(R, -2, 0); + Font.Assign(SmCaptionFont); + Font.Color := CaptionText; + DrawText(Canvas.Handle, WindowInfo.Caption, -1, R, + DT_SINGLELINE or DT_VCENTER or DT_END_ELLIPSIS or DT_NOPREFIX); + end; + + { Close button } + if (CDBS_VISIBLE and WindowInfo.CloseButtonState) <> 0 then + begin + R := Rect(0, 0, WindowInfo.ClientWidth, GetSystemMetrics(SM_CYSMCAPTION) - 1); + with WindowInfo.FloatingBorderSize do OffsetRect(R, X, Y); + R.Left := R.Right - (R.Bottom - R.Top); + DrawLineEx(Canvas.Handle, R.Left - 1, R.Bottom, R.Right, R.Bottom, BodyColor); + Brush.Color := CaptionColor; + FillRect(R); + with R do + begin + X := (Left + Right - StockImgList.Width + 1) div 2; + Y := (Top + Bottom - StockImgList.Height) div 2; + end; + BtnItemState := GetBtnItemState(WindowInfo.CloseButtonState); + FrameRectEx(Canvas.Handle, R, BtnItemColors[BtnItemState, ipFrame], True); + if FillRectEx(Canvas.Handle, R, BtnBodyColors[BtnItemState, False]) then + DrawGlyph(Canvas.Handle, X, Y, StockImgList, 0, BtnItemColors[BtnItemState, ipText]) + else + DrawGlyph(Canvas.Handle, X, Y, StockImgList, 0, CaptionText); + end; + end; +end; + +procedure TTBXOffice2007Theme.PaintFrame(Canvas: TCanvas; const ARect: TRect; + const ItemInfo: TTBXItemInfo); +var + //DC: HDC; + R: TRect; +begin + //DC := Canvas.Handle; + R := ARect; + // FrameRectEx(DC, R, GetPartColor(ItemInfo, ipFrame), True); + // FillRectEx(DC, R, GetPartColor(ItemInfo, ipBody)); + //2006.11.19 chy changed + if (ItemInfo.HoverKind <> hkNone) or (ItemInfo.ComboPart <> cpNone) then + begin + InflateRect(R, -1, -1); + if ItemInfo.Selected then + //chy 2007.01.15 PaintGradient(DC, R, GetBtnColor(ItemInfo, ipBody, true), GetBtnColor(ItemInfo, ipBody)) + FillGradient(Canvas,R, GetBtnColor(ItemInfo, ipBody), clwhite,tGTopBottom) + else + //chy 2007.01.15 PaintGradient(DC, R, GetBtnColor(ItemInfo, ipBody), GetBtnColor(ItemInfo, ipBody, True)); + FillGradient(Canvas,R, GetBtnColor(ItemInfo, ipBody,true), clwhite,tGTopBottom); + InflateRect(R, 1, 1); + Canvas.Pen.Color := $00C5C5C5;//PopupFrameColor; //ToolbarFrameColor1; + Canvas.Brush.Style := bsClear; + Canvas.RoundRect(R.Left, R.Top, R.Right, R.Bottom, 4, 4); + end; +end; + +function TTBXOffice2007Theme.GetImageOffset(Canvas: TCanvas; + const ItemInfo: TTBXItemInfo; ImageList: TCustomImageList): TPoint; +begin + Result.X := 0; + Result.Y := 0; +end; + +procedure TTBXOffice2007Theme.PaintImage(Canvas: TCanvas; ARect: TRect; + const ItemInfo: TTBXItemInfo; ImageList: TCustomImageList; ImageIndex: Integer); +var + HiContrast: Boolean; +begin + with ItemInfo do + begin + if ImageList is TTBCustomImageList then + begin + TTBCustomImageList(ImageList).DrawState(Canvas, ARect.Left, ARect.Top, + ImageIndex, Enabled, (HoverKind <> hkNone), Selected); + Exit; + end; + + HiContrast := ColorIntensity(GetItemImageBackground(ItemInfo)) < 80; + if not Enabled then + begin + if not HiContrast then + DrawTBXIconShadow(Canvas, ARect, ImageList, ImageIndex, 0) + else + DrawTBXIconFlatShadow(Canvas, ARect, ImageList, ImageIndex, SeparatorColor1); + end + else {$IFDEF HIGHLIGHTTOOLBARICONS}if Selected or Pushed or (HoverKind <> hkNone) or HiContrast or TBXHiContrast or TBXLoColor then {$ENDIF} + DrawTBXIcon(Canvas, ARect, ImageList, ImageIndex, HiContrast) +{$IFDEF HIGHLIGHTTOOLBARICONS} + else + HighlightTBXIcon(Canvas, ARect, ImageList, ImageIndex, clWindow, 178){$ENDIF}; + end; +end; + +procedure TTBXOffice2007Theme.PaintMDIButton(Canvas: TCanvas; ARect: TRect; + const ItemInfo: TTBXItemInfo; ButtonKind: Cardinal); +var + Index: Integer; +begin + PaintButton(Canvas, ARect, ItemInfo); + Dec(ARect.Bottom); + case ButtonKind of + DFCS_CAPTIONMIN: Index := 2; + DFCS_CAPTIONRESTORE: Index := 3; + DFCS_CAPTIONCLOSE: Index := 0; + else + Exit; + end; + DrawGlyph(Canvas.Handle, ARect, StockImgList, Index, GetPartColor(ItemInfo, ipText)); +end; + +procedure TTBXOffice2007Theme.PaintMenuItemFrame(Canvas: TCanvas; + const ARect: TRect; const ItemInfo: TTBXItemInfo); +var + R: TRect; +begin + R := ARect; + if (ItemInfo.ViewType and PVT_TOOLBOX) <> PVT_TOOLBOX then with Canvas do + begin + R.Right := R.Left + ItemInfo.PopupMargin + 2; + if GetOffice2007Scheme = osBlue then + begin + PaintIrregularGradient(Canvas.Handle, R, $00EEE7DD, $00EEE7DD, True); // RGB(233,238,238) + Canvas.Pen.Color := $00C5C5C5; //ToolbarFrameColor1; + Canvas.MoveTo(R.Right,R.Top); + Canvas.LineTo(r.Right,r.Bottom); + // Canvas.RoundRect(R.Right-1, R.Top, R.Right, R.Bottom, 2, 2); + end + else + PaintIrregularGradient(Handle, R, ToolbarColor1, ToolbarColor2, True); + Inc(R.Left); + R.Right := ARect.Right - 1; + end; + PaintFrame(Canvas, R, ItemInfo); +end; + +procedure TTBXOffice2007Theme.PaintMenuItem(Canvas: TCanvas; const ARect: TRect; var ItemInfo: TTBXItemInfo); +var + DC: HDC; + R: TRect; + X, Y: Integer; + ArrowWidth: Integer; + C, ClrText: TColor; +begin + DC := Canvas.Handle; + with ItemInfo do + begin + ArrowWidth := GetSystemMetrics(SM_CXMENUCHECK); + PaintMenuItemFrame(Canvas, ARect, ItemInfo); + ClrText := GetPartColor(ItemInfo, ipText); + R := ARect; + + if (ItemOptions and IO_COMBO) <> 0 then + begin + X := R.Right - ArrowWidth - 1; + if not ItemInfo.Enabled then C := ClrText + else if HoverKind = hkMouseHover then C := GetPartColor(ItemInfo, ipFrame) + else C := PopupFrameColor; + DrawLineEx(DC, X, R.Top + 1, X, R.Bottom - 1, C); + end; + + if (ItemOptions and IO_SUBMENUITEM) <> 0 then + begin + Y := ARect.Bottom div 2; + X := ARect.Right - ArrowWidth * 2 div 3 - 1; + PolygonEx(DC, [Point(X, Y - 3), Point(X, Y + 3), Point(X + 3, Y)], ClrText, ClrText); + end; + + if Selected and Enabled then + begin + R := ARect; + R.Left := ARect.Left + 1; + R.Right := R.Left + ItemInfo.PopupMargin; + InflateRect(R, -2, -2); + + // FrameRectEx(DC, R, GetBtnColor(ItemInfo, ipFrame), True); + // FillRectEx(DC, R, GetBtnColor(ItemInfo, ipBody)); + //¡¡2006.11.19¡¡chy ÐÞ¸ÄΪÒÔÏ嵀 + // PaintGradient(DC, R, GetBtnColor(ItemInfo, ipBody), GetBtnColor(ItemInfo, ipBody, True)); + //chy 2007.01.15 PaintGradient(DC, R, GetBtnColor(ItemInfo, ipBody), GetBtnColor(ItemInfo, ipBody, True)); + FillGradient(Canvas,R, GetBtnColor(ItemInfo, ipBody,true), clwhite,tGTopBottom); + InflateRect(R, 1, 1); + Canvas.Pen.Color := $00C5C5C5;//PopupFrameColor; + Canvas.Brush.Style := bsClear; + Canvas.RoundRect(R.Left, R.Top, R.Right, R.Bottom, 4, 4); + end; + end; +end; + +procedure TTBXOffice2007Theme.PaintPopupNCArea(Canvas: TCanvas; R: TRect; const PopupInfo: TTBXPopupInfo); +var + PR: TRect; +begin + with Canvas do + begin + Brush.Color := PopupFrameColor; + FrameRect(R); + InflateRect(R, -1, -1); + Brush.Color := ToolbarColor1; //PopupColor; + FillRect(R); + if not IsRectEmpty(PopupInfo.ParentRect) then + begin + PR := PopupInfo.ParentRect; + if not IsRectEmpty(PR) then with PR do + begin + Pen.Color := PopupColor; + if Bottom = R.Top then + begin + if Left <= R.Left then Left := R.Left - 1; + if Right >= R.Right then Right := R.Right + 1; + MoveTo(Left + 1, Bottom - 1); LineTo(Right - 1, Bottom - 1); + end + else if Top = R.Bottom then + begin + if Left <= R.Left then Left := R.Left - 1; + if Right >= R.Right then Right := R.Right + 1; + MoveTo(Left + 1, Top); LineTo(Right - 1, Top); + end; + if Right = R.Left then + begin + if Top <= R.Top then Top := R.Top - 1; + if Bottom >= R.Bottom then Bottom := R.Bottom + 1; + MoveTo(Right - 1, Top + 1); LineTo(Right - 1, Bottom - 1); + end + else if Left = R.Right then + begin + if Top <= R.Top then Top := R.Top - 1; + if Bottom >= R.Bottom then Bottom := R.Bottom + 1; + MoveTo(Left, Top + 1); LineTo(Left, Bottom - 1); + end; + end; + end; + end; +end; + +procedure TTBXOffice2007Theme.PaintSeparator(Canvas: TCanvas; ARect: TRect; + ItemInfo: TTBXItemInfo; Horizontal, LineSeparator: Boolean); +var + DC: HDC; + IsToolbox: Boolean; + R: TRect; + NewWidth: Integer; +begin + { Note: for blank separators, Enabled = False } + DC := Canvas.Handle; + with ItemInfo, ARect do + begin + if Horizontal then + begin + IsToolbox := (ViewType and PVT_TOOLBOX) = PVT_TOOLBOX; + if ((ItemOptions and IO_TOOLBARSTYLE) = 0) and not IsToolBox then + begin + R := ARect; + R.Right := ItemInfo.PopupMargin + 2; + if GetOffice2007Scheme = osBlue then begin + PaintIrregularGradient(DC, R, $00EEE7DD, $00EEE7DD, True); // RGB(233,238,238) + Canvas.Pen.Color := $00C5C5C5; //ToolbarColor1; + Canvas.MoveTo(R.Right,R.Top); + Canvas.LineTo(r.Right,r.Bottom); + end + else + PaintIrregularGradient(DC, R, ToolbarColor1, ToolbarColor2, True); + Inc(Left, ItemInfo.PopupMargin + 9); + Top := (Top + Bottom) div 2; + if Enabled then begin + DrawLineEx(DC, Left, Top, Right, Top, ToolbarColor2); + OffsetRect(ARect, 1, 1); + DrawLineEx(DC, Left, Top, Right, Top, ToolbarColor1); + end; + end + else + begin + Top := (Top + Bottom) div 2; + Right := Right + 1; + NewWidth := Round(0.9 * (Right - Left)); + Left := (Right - Left - NewWidth) div 2; + Right := Left + NewWidth; + if Enabled then + begin + DrawLineEx(DC, Left, Top, Right, Top, SeparatorColor1); + OffsetRect(ARect, 1, 1); + DrawLineEx(DC, Left, Top, Right, Top, SeparatorColor2); + end; + end; + end + else if Enabled then + {begin + Left := (Left + Right) div 2; + Bottom := Bottom + 1; + NewWidth := Round(0.6 * (Bottom - Top)); + Top := (Bottom - Top - NewWidth) div 2; + Bottom := Top + NewWidth; + DrawLineEx(DC, Left, Top, Left, Bottom, SeparatorColor1); + OffsetRect(ARect, 1, 1); + DrawLineEx(DC, Left, Top, Left, Bottom, SeparatorColor2); + end;} + begin + IsToolbox := (ViewType and PVT_TOOLBOX) = PVT_TOOLBOX; + if (((ItemOptions and IO_TOOLBARSTYLE) = 0) and not IsToolBox) then + begin + R := ARect; + R.Right := ItemInfo.PopupMargin + 2; + if R.Right > R.Left then + if GetOffice2007Scheme = osBlue then begin + PaintIrregularGradient(DC, R, $00EEE7DD, $00EEE7DD, True); // RGB(233,238,238) + Canvas.Pen.Color := $00C5C5C5; //ToolbarFrameColor1; + Canvas.MoveTo(R.Right,R.Top); + Canvas.LineTo(r.Right,r.Bottom); + end + else + PaintIrregularGradient(DC, R, ToolbarColor1, ToolbarColor2, True); + + Inc(Left, ItemInfo.PopupMargin + 9); + Top := (Top + Bottom) div 2; + if Enabled then + DrawLineEx(DC, Left, Top, Right, Top, SeparatorColor1); + end else + begin + Left := (Left + Right) div 2; + Bottom := Bottom + 1; + NewWidth := Round(0.6 * (Bottom - Top)); + Top := (Bottom - Top - NewWidth) div 2; + Bottom := Top + NewWidth; + DrawLineEx(DC, Left, Top, Left, Bottom, SeparatorColor1); + OffsetRect(ARect, 1, 1); + DrawLineEx(DC, Left, Top, Left, Bottom, SeparatorColor2); + end; + end; + + + end; +end; + +procedure DrawButtonBitmap(DC: HDC; R: TRect; Color: TColor); +const +{$IFNDEF SMALL_CLOSE_BUTTON} + Pattern: array[0..15] of Byte = + ($C3, 0, $66, 0, $3C, 0, $18, 0, $3C, 0, $66, 0, $C3, 0, 0, 0); +{$ELSE} + Pattern: array[0..15] of Byte = + (0, 0, $63, 0, $36, 0, $1C, 0, $1C, 0, $36, 0, $63, 0, 0, 0); +{$ENDIF} +begin + DrawGlyph(DC, R, 8, 7, Pattern[0], Color); +end; + +procedure TTBXOffice2007Theme.PaintToolbarNCArea(Canvas: TCanvas; R: TRect; const ToolbarInfo: TTBXToolbarInfo); +const + DragHandleOffsets: array[Boolean, DHS_DOUBLE..DHS_SINGLE] of Integer = ((2, 0, 1), (5, 0, 5)); + + function GetBtnItemState(BtnState: Integer): TBtnItemState; + begin + if (BtnState and CDBS_PRESSED) <> 0 then Result := bisPressed + else if (BtnState and CDBS_HOT) <> 0 then Result := bisHot + else Result := bisNormal; + end; + + procedure DrawHandleElement(const P: TPoint); + begin + Canvas.Brush.Color := DragHandleColor2; + Canvas.FillRect(Rect(P.X + 1, P.Y + 1, P.X + 3, P.Y + 3)); + Canvas.Brush.Color := DragHandleColor1; + Canvas.FillRect(Rect(P.X, P.Y, P.X + 2, P.Y + 2)); + end; + +var + DC: HDC; + Sz: Integer; + R2: TRect; + I: Integer; + BtnVisible, Horz: Boolean; + BtnItemState: TBtnItemState; + IsMenuBar: Boolean; +begin + DC := Canvas.Handle; + Horz := not ToolbarInfo.IsVertical; + with Canvas do + begin + IsMenuBar := ToolbarInfo.ViewType and TVT_MENUBAR = TVT_MENUBAR; + if (ToolbarInfo.BorderStyle = bsSingle) and not IsMenuBar then + begin + I := ColorIntensity(clBtnFace); + if not (TBXLoColor or not (I in [50..254])) then + begin + InflateRect(R, -1, -1); + Pen.Style := psSolid; + with R do + begin + if Horz then + begin + {left} + PaintIrregularGradient(Handle, Rect(Left, Top + 1, Left + 1, Bottom - 1), ToolbarColor1, ToolbarColor2, False); + + {right} + PaintIrregularGradient(Handle, Rect(Right - 1, Top + 1, Right, Bottom - 1), ToolbarColor1, ToolbarColor2, False); + PaintIrregularGradient(Handle, Rect(Right, Top + 1, Right + 1, Bottom - 1), ToolbarColor2, ToolbarFrameColor1, False); + + {top} + Pen.Color := ToolbarColor1; + Polyline([Point(Left + 2, Top), Point(Right - 1, Top)]); + + {bottom} + Pen.Color := ToolbarColor2; + Polyline([Point(Left + 1, Bottom - 1), Point(Right - 1, Bottom - 1)]); + Pen.Color := ToolbarFrameColor1; + Polyline([Point(Left + 2, Bottom), Point(Right - 1, Bottom)]); + + {pixels} + SetPixelV(Handle, Left + 1, Top, ToolbarFrameColor2); + SetPixelV(Handle, Left, Top + 1, ToolbarFrameColor2); + SetPixelV(Handle, Right - 1, Top, ToolbarFrameColor2); + SetPixelV(Handle, Right, Top + 1, ToolbarFrameColor2); + SetPixelV(Handle, Right - 1, Bottom - 1, ToolbarFrameColor1); + end + else + begin + {left} + Pen.Color := ToolbarColor1; + Polyline([Point(Left, Top + 2), Point(Left, Bottom - 1)]); + + {right} + Pen.Color := ToolbarColor2; + Polyline([Point(Right - 1, Top + 1), Point(Right - 1, Bottom - 1)]); + Pen.Color := ToolbarFrameColor1; + Polyline([Point(Right, Top + 2), Point(Right, Bottom - 1)]); + + {top} + PaintIrregularGradient(Handle, Rect(Left + 1, Top, Right - 1, Top + 1), ToolbarColor1, ToolbarColor2, True); + + {bottom} + PaintIrregularGradient(Handle, Rect(Left + 2, Bottom - 1, Right - 1, Bottom), ToolbarColor1, ToolbarColor2, True); + PaintIrregularGradient(Handle, Rect(Left + 2, Bottom, Right - 1, Bottom + 1), ToolbarColor2, ToolbarFrameColor1, True); + {pixels} + SetPixelV(Handle, Left + 1, Top, ToolbarFrameColor2); + SetPixelV(Handle, Left, Top + 1, ToolbarFrameColor2); + SetPixelV(Handle, Left + 1, Bottom - 1, ToolbarColor2); + SetPixelV(Handle, Left, Bottom - 2, ToolbarFrameColor2); + SetPixelV(Handle, Right - 1, Bottom - 1, ToolbarFrameColor1); + end; + end; + Brush.Style := bsSolid; + Inc(R.Left); + Inc(R.Top); + end + else + begin + Brush.Bitmap := AllocPatternBitmap(ToolbarColor1, BtnItemColors[bisDisabled, ipText]); + with R do + begin + FillRect(Rect(Left + 1, Top, Right - 1, Top + 1)); + FillRect(Rect(Left + 1, Bottom - 1, Right - 1, Bottom)); + FillRect(Rect(Left, Top + 1, Left + 1, Bottom - 1)); + FillRect(Rect(Right - 1, Top + 1, Right, Bottom - 1)); + end; + InflateRect(R, -1, -1); + Brush.Color := ToolbarColor1; + FillRect(R); + end; + end + else + InflateRect(R, -1, -1); + InflateRect(R, -1, -1); + + if not ToolbarInfo.AllowDrag then Exit; + + BtnVisible := (ToolbarInfo.CloseButtonState and CDBS_VISIBLE) <> 0; + Sz := GetTBXDragHandleSize(ToolbarInfo); + if Horz then R.Right := R.Left + Sz + else R.Bottom := R.Top + Sz; + + { Drag Handle } + if ToolbarInfo.DragHandleStyle <> DHS_NONE then + begin + R2 := R; + if Horz then + begin + Inc(R2.Left, DragHandleOffsets[BtnVisible, ToolbarInfo.DragHandleStyle]); + if BtnVisible then Inc(R2.Top, Sz - 2); + R2.Right := R2.Left + 3; + end + else + begin + Inc(R2.Top, DragHandleOffsets[BtnVisible, ToolbarInfo.DragHandleStyle]); + if BtnVisible then Dec(R2.Right, Sz - 2); + R2.Bottom := R2.Top + 3; + end; + + if not IsMenuBar then + //PaintIrregularGradient(Canvas.Handle, Rect(R.Left - 1, R.Top - 1, R.Right, R.Bottom), ToolbarColor1, ToolbarColor2, not Horz) + // chy 2006.11.20 changed ÐèÒª¸ù¾Ý×ÝÏòºÍºáÏò½øÐнøÒ»²½´¦Àí + PaintGradientBig(Canvas.Handle, Rect(R.Left - 1, R.Top - 1, R.Right, R.Bottom), ToolbarColor1, ToolbarColor2) + else + begin + Inc(R2.Left); + Inc(R2.Top); + end; + + if Horz then + begin + I := R2.Top + Sz div 2; + while I < R2.Bottom - Sz div 2 - 2 do + begin + DrawHandleElement(Point(R2.Left, I)); + Inc(I, 4); + end; + end + else + begin + I := R2.Left + Sz div 2; + while I < R2.Right - Sz div 2 - 2 do + begin + DrawHandleElement(Point(I, R2.Top)); + Inc(I, 4); + end; + end; + end; + + { Close button } + if BtnVisible then + begin + R2 := R; + if Horz then + begin + Dec(R2.Right); + R2.Bottom := R2.Top + R2.Right - R2.Left; + end + else + begin + Dec(R2.Bottom); + R2.Left := R2.Right - R2.Bottom + R2.Top; + end; + + BtnItemState := GetBtnItemState(ToolbarInfo.CloseButtonState); + FrameRectEx(DC, R2, BtnItemColors[BtnItemState, ipFrame], True); + FillRectEx(DC, R2, BtnBodyColors[BtnItemState, False]); + DrawButtonBitmap(DC, R2, BtnItemColors[BtnItemState, ipText]); + end; + end; +end; + +procedure TTBXOffice2007Theme.PaintDock(Canvas: TCanvas; const ClientRect, + DockRect: TRect; DockPosition: Integer); +begin + + FillRectEx(Canvas.Handle, DockRect, DockColor); + // chy 2006.11.20 changed + //PaintGradientBig(Canvas.Handle, DockRect, ToolbarColor2, ToolbarColor1); +end; + +procedure TTBXOffice2007Theme.PaintDockPanelNCArea(Canvas: TCanvas; R: TRect; const DockPanelInfo: TTBXDockPanelInfo); + + function GetBtnItemState(BtnState: Integer): TBtnItemState; + begin + if (BtnState and CDBS_PRESSED) <> 0 then Result := bisPressed + else if (BtnState and CDBS_HOT) <> 0 then Result := bisHot + else Result := bisNormal; + end; + +var + DC: HDC; + C: TColor; + I, Sz, Flags: Integer; + R2: TRect; + BtnItemState: TBtnItemState; + B: HBRUSH; + OldBkMode: Cardinal; + OldFont: HFONT; + OldTextColor: TColorRef; +begin + DC := Canvas.Handle; + with DockPanelInfo do + begin + I := ColorIntensity(ColorToRGB(clBtnFace)); + R2 := R; + if not TBXLoColor and (I in [64..250]) then + begin + FrameRectEx(DC, R, ToolbarColor2, True); + FrameRectEx(DC, R, EffectiveColor, False); + with R do + begin + C := ToolbarColor2; + SetPixelV(DC, Left, Top, C); + if IsVertical then SetPixelV(DC, Right - 1, Top, C) + else SetPixelV(DC, Left, Bottom - 1, C); + end; + end + else + begin + + FrameRectEx(DC, R, EffectiveColor, True); + + if I < 64 then B := CreateDitheredBrush(EffectiveColor, clWhite) + else B := CreateDitheredBrush(EffectiveColor, clBtnShadow); + Windows.FrameRect(DC, R, B); + DeleteObject(B); + + with R do + begin + SetPixelV(DC, Left, Top, EffectiveColor); + if IsVertical then SetPixelV(DC, Right - 1, Top, EffectiveColor) + else SetPixelV(DC, Left, Bottom - 1, EffectiveColor); + end; + InflateRect(R, -1, -1); + FrameRectEx(DC, R, EffectiveColor, False); + end; + R := R2; + InflateRect(R, -BorderSize.X, -BorderSize.Y); + Sz := GetSystemMetrics(SM_CYSMCAPTION); + + if IsVertical then + begin + R.Bottom := R.Top + Sz - 1; + DrawLineEx(DC, R.Left, R.Bottom, R.Right, R.Bottom, EffectiveColor); + end + else + begin + R.Right := R.Left + Sz - 1; + DrawLineEx(DC, R.Right, R.Top, R.Right, R.Bottom, EffectiveColor); + end; + // {$IFDEF DOCKPANELGRADIENTCAPTION} + PaintGradientBig(DC, R, ToolbarColor1, ToolbarColor2); + PaintIrregularGradient(DC, Rect(R.Left , R.Bottom-1, R.Right , R.Bottom+1), ToolbarColor2, ToolbarColor1, false); + + // {$ELSE} + // FillRectEx(DC, R, DockColor); + // {$ENDIF} + + if (CDBS_VISIBLE and CloseButtonState) <> 0 then + begin + R2 := R; + if IsVertical then + begin + R2.Left := R2.Right - Sz + 1; + R.Right := R2.Left; + end + else + begin + R2.Top := R2.Bottom - Sz + 1; + R.Bottom := R2.Top; + end; + + BtnItemState := GetBtnItemState(CloseButtonState); + FrameRectEx(DC, R2, BtnItemColors[BtnItemState, ipFrame], True); + FillRectEx(DC, R2,BtnBodyColors[BtnItemState, False]); + DrawButtonBitmap(DC, R2, BtnItemColors[BtnItemState, ipText]); + end; + + if IsVertical then InflateRect(R, -4, 0) + else InflateRect(R, 0, -4); + + OldFont := SelectObject(DC, SmCaptionFont.Handle); + OldBkMode := SetBkMode(DC, TRANSPARENT); + OldTextColor := SetTextColor(DC, ColorToRGB(SmCaptionFont.Color)); + Flags := DT_SINGLELINE or DT_VCENTER or DT_END_ELLIPSIS or DT_NOPREFIX; + if IsVertical then DrawText(DC, Caption, -1, R, Flags) + else DrawRotatedText(DC, string(Caption), R, Flags); + SetTextColor(DC, OldTextColor); + SetBkMode(DC, OldBkMode); + SelectObject(DC, OldFont); + end; +end; + +procedure TTBXOffice2007Theme.SetupColorCache; +const // $FFC69A + Office2007Colors: array[osBlue..osGreen, 0..27] of TColor = ( + ($FFDBBF, $FFEFE3, $FFD3B1, $D99D6F, $FFDBBF, $00C5C5C5, $FFFFFF, $D99D6F, + $FFFFFF, $FFEFE3, $FFFFFF, $DDDDDD, $F6F6F6, $CF9365, $000000, $8D8D8D, + $3FABFF, $C9662A, $92CFFF, $69BDFF, $3D97FC, $5EB8FF, $CCF5FF, $84DFFF, + $FFEFE3, $F0BF99, $A2E7FF, $AE9990), + //320AFC + ($E5D7D7, $FAF4F3, $B59799, $947C7C, $EFE5E5, $8F6D6E, $FFFFFF, $755454, + $FFFFFF, $D3C0C0, $B2ACA5, $DEDEDE, $FFFAFD, $947C7C, $000000, $8D8D8D, + $6F4B4B, $99797A, $8CD5FF, $69BDFF, $4E91FE, $8ED3FF, $CCF4FF, $91D0FF, + $F1E9E8, $CDB9BA, $C2EEFF, $B39A9B), + ($A7D9D9, $DEF7F4, $91C6B7, $588060, $C0E7E5, $588060, $DEF7F4, $335E51, + $FFFFFF, $9FD4C5, $7FB9A4, $DEDEDE, $EEF4F4, $5E8D75, $000000, $8D8D8D, + $385D3F, $5E8674, $8CD5FF, $55ADFF, $4E91FE, $8ED3FF, $CCF4FF, $91D0FF, + $D5F0EC, $9FCEC2, $C2EEFF, $7BA097) + ); //320AFC + Office2007IrregularGradientValues: array[TOffice2007Scheme] of Integer = (8, 8, 25, 15); + +var + DC: HDC; + MenuItemFrame, EnabledText, DisabledText: TColor; + Scheme: TOffice2007Scheme; + + procedure Undither(var C: TColor); + begin + if C <> clNone then C := GetNearestColor(DC, ColorToRGB(C)); + end; + +begin + DC := StockCompatibleBitmap.Canvas.Handle; + + if TBXLoColor then + begin + DockColor := clBtnFace; + + ToolbarColor1 := clBtnFace; + ToolbarColor2 := clBtnFace; + ToolbarFrameColor1 := clBtnShadow; + ToolbarFrameColor2 := clBtnShadow; + SeparatorColor1 := clBtnShadow; + SeparatorColor2 := clBtnHighlight; + DragHandleColor1 := clBtnText; + DragHandleColor2 := clBtnHighlight; + + EmbeddedColor := clBtnFace; + EmbeddedFrameColor := clBtnShadow; + EmbeddedDisabledColor := clBtnFace; + + PopupColor := clWindow; + PopupFrameColor := clBtnText; + + DockPanelColor := clWindow; + + DisabledText := clBtnShadow; + MenuItemFrame := clHighlight; + + WinFrameColors[wfpBorder] := clBtnShadow; + WinFrameColors[wfpCaption] := clBtnShadow; + WinFrameColors[wfpCaptionText] := clBtnHighlight; + + BtnItemColors[bisNormal, ipText] := clBtnText; + BtnItemColors[bisNormal, ipFrame] := clNone; + BtnItemColors[bisDisabled, ipText] := DisabledText; + BtnItemColors[bisDisabled, ipFrame] := clNone; + BtnItemColors[bisSelected, ipText] := clWindowText; + BtnItemColors[bisSelected, ipFrame] := MenuItemFrame; + BtnItemColors[bisPressed, ipText] := clHighlightText; + BtnItemColors[bisPressed, ipFrame] := MenuItemFrame; + BtnItemColors[bisHot, ipText] := clWindowText; + BtnItemColors[bisHot, ipFrame] := MenuItemFrame; + BtnItemColors[bisDisabledHot, ipText] := DisabledText; + BtnItemColors[bisDisabledHot, ipFrame] := MenuItemFrame; + BtnItemColors[bisSelectedHot, ipText] := clHighlightText; + BtnItemColors[bisSelectedHot, ipFrame] := MenuItemFrame; + BtnItemColors[bisPopupParent, ipText] := clBtnText; + BtnItemColors[bisPopupParent, ipFrame] := PopupFrameColor; + + BtnBodyColors[bisNormal, False] := clNone; + BtnBodyColors[bisNormal, True] := clNone; + BtnBodyColors[bisDisabled, False] := clNone; + BtnBodyColors[bisDisabled, True] := clNone; + BtnBodyColors[bisSelected, False] := clWindow; + BtnBodyColors[bisSelected, True] := clWindow; + BtnBodyColors[bisPressed, False] := clHighlight; + BtnBodyColors[bisPressed, True] := clHighlight; + BtnBodyColors[bisHot, False] := clWindow; + BtnBodyColors[bisHot, True] := clWindow; + BtnBodyColors[bisDisabledHot, False] := clWindow; + BtnBodyColors[bisDisabledHot, True] := clWindow; + BtnBodyColors[bisSelectedHot, False] := clHighlight; + BtnBodyColors[bisSelectedHot, True] := clHighlight; + BtnBodyColors[bisPopupParent, False] := clBtnFace; + BtnBodyColors[bisPopupParent, True] := clBtnFace; + + MenuItemColors[misNormal, ipBody] := clNone; + MenuItemColors[misNormal, ipText] := clWindowText; + MenuItemColors[misNormal, ipFrame] := clNone; + MenuItemColors[misDisabled, ipBody] := clNone; + MenuItemColors[misDisabled, ipText] := clGrayText; + MenuItemColors[misDisabled, ipFrame] := clNone; + MenuItemColors[misHot, ipBody] := clWindow; + MenuItemColors[misHot, ipText] := clWindowText; + MenuItemColors[misHot, ipFrame] := MenuItemFrame; + MenuItemColors[misDisabledHot, ipBody] := PopupColor; + MenuItemColors[misDisabledHot, ipText] := clGrayText; + MenuItemColors[misDisabledHot, ipFrame] := MenuItemFrame; + + StatusPanelFrameColor := clBtnShadow; + FMDIAreaColor := clBtnShadow; + end + else + begin + + Scheme := GetOffice2007Scheme; + if Scheme <> osUnknown then + begin + DockColor := Office2007Colors[Scheme, 0]; + + ToolbarColor1 := Office2007Colors[Scheme, 1]; + ToolbarColor2 := Office2007Colors[Scheme, 2]; + ToolbarFrameColor1 := Office2007Colors[Scheme, 3]; + ToolbarFrameColor2 := Office2007Colors[Scheme, 4]; + SeparatorColor1 := Office2007Colors[Scheme, 5]; + SeparatorColor2 := Office2007Colors[Scheme, 6]; + DragHandleColor1 := Office2007Colors[Scheme, 7]; + DragHandleColor2 := Office2007Colors[Scheme, 8]; + + EmbeddedColor := Office2007Colors[Scheme, 9]; + EmbeddedFrameColor := Office2007Colors[Scheme, 10]; + EmbeddedDisabledColor := Office2007Colors[Scheme, 11]; + + PopupColor := Office2007Colors[Scheme, 12]; + PopupFrameColor := Office2007Colors[Scheme, 13]; + + DockPanelColor := ToolbarColor1; + + EnabledText := Office2007Colors[Scheme, 14]; + DisabledText := Office2007Colors[Scheme, 15]; + MenuItemFrame := Office2007Colors[Scheme, 16]; + + WinFrameColors[wfpBorder] := Office2007Colors[Scheme, 17]; + WinFrameColors[wfpCaption] := WinFrameColors[wfpBorder]; + WinFrameColors[wfpCaptionText] := clWhite; + + BtnItemColors[bisNormal, ipText] := EnabledText; + BtnItemColors[bisNormal, ipFrame] := clNone; + BtnItemColors[bisDisabled, ipText] := DisabledText; + BtnItemColors[bisDisabled, ipFrame] := clNone; + BtnItemColors[bisSelected, ipText] := EnabledText; + BtnItemColors[bisSelected, ipFrame] := MenuItemFrame; + BtnItemColors[bisPressed, ipText] := EnabledText; + BtnItemColors[bisPressed, ipFrame] := MenuItemFrame; + BtnItemColors[bisHot, ipText] := EnabledText; + BtnItemColors[bisHot, ipFrame] := MenuItemFrame; + BtnItemColors[bisDisabledHot, ipText] := DisabledText; + BtnItemColors[bisDisabledHot, ipFrame] := MenuItemFrame; + BtnItemColors[bisSelectedHot, ipText] := EnabledText; + BtnItemColors[bisSelectedHot, ipFrame] := MenuItemFrame; + BtnItemColors[bisPopupParent, ipText] := EnabledText; + BtnItemColors[bisPopupParent, ipFrame] := PopupFrameColor; + + BtnBodyColors[bisNormal, False] := clNone; + BtnBodyColors[bisNormal, True] := clNone; + BtnBodyColors[bisDisabled, False] := clNone; + BtnBodyColors[bisDisabled, True] := clNone; + BtnBodyColors[bisSelected, False] := Office2007Colors[Scheme, 18]; + BtnBodyColors[bisSelected, True] := Office2007Colors[Scheme, 19]; + BtnBodyColors[bisPressed, False] := Office2007Colors[Scheme, 20]; + BtnBodyColors[bisPressed, True] := Office2007Colors[Scheme, 21]; + BtnBodyColors[bisHot, False] := Office2007Colors[Scheme, 22]; + BtnBodyColors[bisHot, True] := Office2007Colors[Scheme, 23]; + BtnBodyColors[bisDisabledHot, False] := BtnBodyColors[bisHot, False]; + BtnBodyColors[bisDisabledHot, True] := BtnBodyColors[bisHot, True]; + BtnBodyColors[bisSelectedHot, False] := BtnBodyColors[bisPressed, False]; + BtnBodyColors[bisSelectedHot, True] := BtnBodyColors[bisPressed, True]; + BtnBodyColors[bisPopupParent, False] := Office2007Colors[Scheme, 24]; + BtnBodyColors[bisPopupParent, True] := Office2007Colors[Scheme, 25]; + + MenuItemColors[misNormal, ipBody] := clNone; + MenuItemColors[misNormal, ipText] := EnabledText; + MenuItemColors[misNormal, ipFrame] := clNone; + MenuItemColors[misDisabled, ipBody] := clNone; + MenuItemColors[misDisabled, ipText] := DisabledText; + MenuItemColors[misDisabled, ipFrame] := clNone; + MenuItemColors[misHot, ipBody] := Office2007Colors[Scheme, 26]; + MenuItemColors[misHot, ipText] := MenuItemColors[misNormal, ipText]; + MenuItemColors[misHot, ipFrame] := MenuItemFrame; + MenuItemColors[misDisabledHot, ipBody] := PopupColor; + MenuItemColors[misDisabledHot, ipText] := DisabledText; + MenuItemColors[misDisabledHot, ipFrame] := MenuItemColors[misHot, ipFrame]; + + StatusPanelFrameColor := Blend(ToolbarColor2, clBlack, 90); + FMDIAreaColor := Office2007Colors[Scheme, 27]; + end + else + begin + DockColor := clBtnFace; + + ToolbarColor1 := Blend(clBtnFace, clWindow, 23); + ToolbarColor2 := Blend(clBtnFace, clWindow, 96); + ToolbarFrameColor1 := Blend(clBtnFace, clWindow, 85); + ToolbarFrameColor2 := Blend(clBtnFace, clWindow, 62); + SeparatorColor1 := Blend(clBtnShadow, clWindow, 70); + SeparatorColor2 := clWhite; + DragHandleColor1 := Blend(clBtnShadow, clWindow, 75); + DragHandleColor2 := clWindow; + + EmbeddedColor := clBtnFace; + EmbeddedFrameColor := clBtnShadow; + EmbeddedDisabledColor := clBtnFace; + + PopupColor := Blend(clBtnFace, clWindow, 15); + PopupFrameColor := Blend(clBtnText, clBtnShadow, 20); + + DockPanelColor := ToolbarColor1; + + EnabledText := clBtnText; + DisabledText := clGrayText; + MenuItemFrame := clHighlight; + + WinFrameColors[wfpBorder] := Blend(clBtnText, clBtnShadow, 15); + WinFrameColors[wfpCaption] := clBtnShadow; + WinFrameColors[wfpCaptionText] := clBtnHighlight; + + BtnBodyColors[bisNormal, False] := clNone; + BtnBodyColors[bisNormal, True] := clNone; + BtnBodyColors[bisDisabled, False] := clNone; + BtnBodyColors[bisDisabled, True] := clNone; + BtnBodyColors[bisSelected, False] := Blend(clHighlight, Blend(clBtnFace, clWindow, 50), 10); + + BtnItemColors[bisNormal, ipText] := EnabledText; + BtnItemColors[bisNormal, ipFrame] := clNone; + BtnItemColors[bisDisabled, ipText] := DisabledText; + BtnItemColors[bisDisabled, ipFrame] := clNone; + BtnItemColors[bisSelected, ipText] := EnabledText; + BtnItemColors[bisSelected, ipFrame] := MenuItemFrame; + BtnItemColors[bisPressed, ipText] := EnabledText; + BtnItemColors[bisPressed, ipFrame] := MenuItemFrame; + BtnItemColors[bisHot, ipText] := EnabledText; + BtnItemColors[bisHot, ipFrame] := MenuItemFrame; + BtnItemColors[bisDisabledHot, ipText] := DisabledText; + BtnItemColors[bisDisabledHot, ipFrame] := MenuItemFrame; + BtnItemColors[bisSelectedHot, ipText] := EnabledText; + BtnItemColors[bisSelectedHot, ipFrame] := MenuItemFrame; + BtnItemColors[bisPopupParent, ipText] := EnabledText; + BtnItemColors[bisPopupParent, ipFrame] := PopupFrameColor; + + BtnBodyColors[bisSelected, True] := BtnBodyColors[bisSelected, False]; + BtnBodyColors[bisPressed, False] := Blend(clHighlight, clWindow, 50); + BtnBodyColors[bisPressed, True] := BtnBodyColors[bisPressed, False]; + BtnBodyColors[bisHot, False] := Blend(clHighlight, clWindow, 30); + BtnBodyColors[bisHot, True] := BtnBodyColors[bisHot, False]; + BtnBodyColors[bisDisabledHot, False] := BtnBodyColors[bisHot, False]; + BtnBodyColors[bisDisabledHot, True] := BtnBodyColors[bisHot, True]; + BtnBodyColors[bisSelectedHot, False] := BtnBodyColors[bisPressed, False]; + BtnBodyColors[bisSelectedHot, True] := BtnBodyColors[bisPressed, True]; + BtnBodyColors[bisPopupParent, False] := Blend(clBtnFace, clWindow, 16); + BtnBodyColors[bisPopupParent, True] := Blend(clBtnFace, clWindow, 42); + + MenuItemColors[misNormal, ipBody] := clNone; + MenuItemColors[misNormal, ipText] := EnabledText; + MenuItemColors[misNormal, ipFrame] := clNone; + MenuItemColors[misDisabled, ipBody] := clNone; + MenuItemColors[misDisabled, ipText] := DisabledText; + MenuItemColors[misDisabled, ipFrame] := clNone; + MenuItemColors[misHot, ipBody] := BtnBodyColors[bisHot, False]; + MenuItemColors[misHot, ipText] := MenuItemColors[misNormal, ipText]; + MenuItemColors[misHot, ipFrame] := MenuItemFrame; + MenuItemColors[misDisabledHot, ipBody] := PopupColor; + MenuItemColors[misDisabledHot, ipText] := DisabledText; + MenuItemColors[misDisabledHot, ipFrame] := MenuItemColors[misHot, ipFrame]; + + StatusPanelFrameColor := Blend(ToolbarColor2, clBlack, 90); + FMDIAreaColor := clBtnShadow; + end; + + IrregularGradientValue := Office2007IrregularGradientValues[Scheme]; + + Undither(DockColor); + + Undither(ToolbarColor1); + Undither(ToolbarColor2); + Undither(ToolbarFrameColor1); + Undither(ToolbarFrameColor2); + Undither(SeparatorColor1); + Undither(SeparatorColor2); + Undither(DragHandleColor1); + Undither(DragHandleColor2); + + Undither(EmbeddedColor); + Undither(EmbeddedFrameColor); + Undither(EmbeddedDisabledColor); + + Undither(PopupColor); + Undither(PopupFrameColor); + + Undither(DockPanelColor); + + Undither(WinFrameColors[wfpBorder]); + Undither(WinFrameColors[wfpCaption]); + Undither(WinFrameColors[wfpCaptionText]); + + Undither(BtnItemColors[bisNormal, ipText]); + Undither(BtnItemColors[bisNormal, ipFrame]); + Undither(BtnItemColors[bisDisabled, ipText]); + Undither(BtnItemColors[bisDisabled, ipFrame]); + Undither(BtnItemColors[bisSelected, ipText]); + Undither(BtnItemColors[bisSelected, ipFrame]); + Undither(BtnItemColors[bisPressed, ipText]); + Undither(BtnItemColors[bisPressed, ipFrame]); + Undither(BtnItemColors[bisHot, ipText]); + Undither(BtnItemColors[bisHot, ipFrame]); + Undither(BtnItemColors[bisDisabledHot, ipText]); + Undither(BtnItemColors[bisDisabledHot, ipFrame]); + Undither(BtnItemColors[bisSelectedHot, ipText]); + Undither(BtnItemColors[bisSelectedHot, ipFrame]); + Undither(BtnItemColors[bisPopupParent, ipText]); + Undither(BtnItemColors[bisPopupParent, ipFrame]); + + Undither(BtnBodyColors[bisNormal, False]); + Undither(BtnBodyColors[bisNormal, True]); + Undither(BtnBodyColors[bisDisabled, False]); + Undither(BtnBodyColors[bisDisabled, True]); + Undither(BtnBodyColors[bisSelected, False]); + Undither(BtnBodyColors[bisSelected, True]); + Undither(BtnBodyColors[bisPressed, False]); + Undither(BtnBodyColors[bisPressed, True]); + Undither(BtnBodyColors[bisHot, False]); + Undither(BtnBodyColors[bisHot, True]); + Undither(BtnBodyColors[bisDisabledHot, False]); + Undither(BtnBodyColors[bisDisabledHot, True]); + Undither(BtnBodyColors[bisSelectedHot, False]); + Undither(BtnBodyColors[bisSelectedHot, True]); + Undither(BtnBodyColors[bisPopupParent, False]); + Undither(BtnBodyColors[bisPopupParent, True]); + + Undither(MenuItemColors[misNormal, ipBody]); + Undither(MenuItemColors[misNormal, ipText]); + Undither(MenuItemColors[misNormal, ipFrame]); + Undither(MenuItemColors[misDisabled, ipBody]); + Undither(MenuItemColors[misDisabled, ipText]); + Undither(MenuItemColors[misDisabled, ipFrame]); + Undither(MenuItemColors[misHot, ipBody]); + Undither(MenuItemColors[misHot, ipText]); + Undither(MenuItemColors[misHot, ipFrame]); + Undither(MenuItemColors[misDisabledHot, ipBody]); + Undither(MenuItemColors[misDisabledHot, ipText]); + Undither(MenuItemColors[misDisabledHot, ipFrame]); + + Undither(StatusPanelFrameColor); + Undither(FMDIAreaColor); + end; + + if Assigned(FOnSetupColorCache) then FOnSetupColorCache(Self); +end; + +function TTBXOffice2007Theme.GetPopupShadowType: Integer; +begin + Result := PST_OFFICEXP; +end; + +constructor TTBXOffice2007Theme.Create(const AName: string); +begin + inherited; + if CounterLock = 0 then InitializeStock; + Inc(CounterLock); + AddTBXSysChangeNotification(Self); + SetupColorCache; +end; + +destructor TTBXOffice2007Theme.Destroy; +begin + RemoveTBXSysChangeNotification(Self); + Dec(CounterLock); + if CounterLock = 0 then FinalizeStock; + inherited; +end; + +procedure TTBXOffice2007Theme.GetViewMargins(ViewType: Integer; out Margins: TTBXMargins); +begin + Margins.LeftWidth := 0; + Margins.TopHeight := 0; + Margins.RightWidth := 0; + Margins.BottomHeight := 0; +end; + +procedure TTBXOffice2007Theme.PaintPageScrollButton(Canvas: TCanvas; + const ARect: TRect; ButtonType: Integer; Hot: Boolean); +var + DC: HDC; + R: TRect; + X, Y, Sz: Integer; + C: TColor; +begin + DC := Canvas.Handle; + R := ARect; + if Hot then C := BtnItemColors[bisHot, ipFrame] + else C := EmbeddedFrameColor; + FrameRectEx(DC, R, C, False); + InflateRect(R, -1, -1); + if Hot then C := BtnBodyColors[bisHot, False] + else C := EmbeddedColor; + FillRectEx(DC, R, C); + X := (R.Left + R.Right) div 2; + Y := (R.Top + R.Bottom) div 2; + Sz := Min(X - R.Left, Y - R.Top) * 3 div 4; + + if Hot then C := BtnItemColors[bisHot, ipText] + else C := BtnItemColors[bisNormal, ipText]; + + case ButtonType of + PSBT_UP: + begin + Inc(Y, Sz div 2); + PolygonEx(DC, [Point(X + Sz, Y), Point(X, Y - Sz), Point(X - Sz, Y)], C, C); + end; + PSBT_DOWN: + begin + Y := (R.Top + R.Bottom - 1) div 2; + Dec(Y, Sz div 2); + PolygonEx(DC, [Point(X + Sz, Y), Point(X, Y + Sz), Point(X - Sz, Y)], C, C); + end; + PSBT_LEFT: + begin + Inc(X, Sz div 2); + PolygonEx(DC, [Point(X, Y + Sz), Point(X - Sz, Y), Point(X, Y - Sz)], C, C); + end; + PSBT_RIGHT: + begin + X := (R.Left + R.Right - 1) div 2; + Dec(X, Sz div 2); + PolygonEx(DC, [Point(X, Y + Sz), Point(X + Sz, Y), Point(X, Y - Sz)], C, C); + end; + end; +end; + +procedure TTBXOffice2007Theme.PaintFrameControl(Canvas: TCanvas; R: TRect; Kind, State: Integer; Params: Pointer); +var + DC: HDC; + X, Y: Integer; + Pen, OldPen: HPen; + Brush, OldBrush: HBRUSH; + C: TColor; + + function GetPenColor: TColor; + begin + if Boolean(State and PFS_DISABLED) then Result := clBtnShadow + else if Boolean(State and PFS_PUSHED) then Result := BtnItemColors[bisPressed, ipFrame] + else if Boolean(State and PFS_HOT) then Result := BtnItemColors[bisHot, ipFrame] + else Result := EmbeddedFrameColor; + end; + + function GetBrush: HBRUSH; + begin + if Boolean(State and PFS_DISABLED) then Result := CreateDitheredBrush(clWindow, clBtnFace) + else if Boolean(State and PFS_PUSHED) then Result := CreateBrushEx(BtnBodyColors[bisPressed, False]) + else if Boolean(State and PFS_HOT) then Result := CreateBrushEx(BtnBodyColors[bisHot, False]) + else if Boolean(State and PFS_MIXED) then Result := CreateDitheredBrush(clWindow, clBtnFace) + else Result := CreateBrushEx(clNone); + end; + + function GetTextColor: TColor; + begin + if Boolean(State and PFS_DISABLED) then Result := BtnItemColors[bisDisabled, ipText] + else if Boolean(State and PFS_PUSHED) then Result := BtnItemColors[bisPressed, ipText] + else if Boolean(State and PFS_MIXED) then Result := clBtnShadow + else if Boolean(State and PFS_HOT) then Result := BtnItemColors[bisHot, ipText] + else Result := BtnItemColors[bisNormal, ipText]; + end; + +begin + DC := Canvas.Handle; + case Kind of + PFC_CHECKBOX: + begin + InflateRect(R, -1, -1); + FrameRectEx(DC, R, GetPenColor, True); + Brush := GetBrush; + Windows.FillRect(DC, R, Brush); + DeleteObject(Brush); + InflateRect(R, 1, 1); + + if Boolean(State and (PFS_CHECKED or PFS_MIXED)) then + begin + X := (R.Left + R.Right) div 2 - 1; + Y := (R.Top + R.Bottom) div 2 + 1; + C := GetTextColor; + PolygonEx(DC, [Point(X - 2, Y), Point(X, Y + 2), Point(X + 4, Y - 2), + Point(X + 4, Y - 4), Point(X, Y), Point(X - 2, Y - 2), Point(X - 2, Y)], C, C); + end; + end; + PFC_RADIOBUTTON: + begin + InflateRect(R, -1, -1); + + with R do + begin + Brush := GetBrush; + OldBrush := SelectObject(DC, Brush); + Pen := CreatePenEx(GetPenColor); + OldPen := SelectObject(DC, Pen); + Windows.Ellipse(DC, Left, Top, Right, Bottom); + SelectObject(DC, OldPen); + DeleteObject(Pen); + SelectObject(DC, OldBrush); + DeleteObject(Brush); + end; + + if Boolean(State and PFS_CHECKED) then + begin + InflateRect(R, -3, -3); + C := GetTextColor; + Brush := CreateBrushEx(C); + OldBrush := SelectObject(DC, Brush); + Pen := CreatePenEx(C); + OldPen := SelectObject(DC, Pen); + with R do Windows.Ellipse(DC, Left, Top, Right, Bottom); + SelectObject(DC, OldPen); + DeleteObject(Pen); + SelectObject(DC, OldBrush); + DeleteObject(Brush); + end; + end; + end; +end; + +procedure TTBXOffice2007Theme.PaintStatusBar(Canvas: TCanvas; R: TRect; Part: Integer); + + procedure DrawHandleElement(const P: TPoint); + begin + Canvas.Brush.Color := DragHandleColor2; + Canvas.FillRect(Rect(P.X - 2, P.Y - 2, P.X, P.Y)); + Canvas.Brush.Color := DragHandleColor1; + Canvas.FillRect(Rect(P.X - 3, P.Y - 3, P.X - 1, P.Y - 1)); + end; + +begin + case Part of + SBP_BODY: + // chy 2006.11.20 changed + // PaintIrregularGradient(Canvas.Handle, R, ToolbarColor1, ToolbarColor2, False); + PaintGradientbig(Canvas.Handle, R, ToolbarColor1, ToolbarColor2); + + SBP_PANE, SBP_LASTPANE: + begin + if Part = SBP_PANE then Dec(R.Right, 2); + FrameRectEx(Canvas.Handle, R, StatusPanelFrameColor, False); + end; + SBP_GRIPPER: + begin + Dec(R.Right); + Dec(R.Bottom); + DrawHandleElement(Point(R.Right, R.Bottom)); + DrawHandleElement(Point(R.Right, R.Bottom - 4)); + DrawHandleElement(Point(R.Right, R.Bottom - 8)); + + Dec(R.Right, 4); + DrawHandleElement(Point(R.Right, R.Bottom)); + DrawHandleElement(Point(R.Right, R.Bottom - 4)); + + Dec(R.Right, 4); + DrawHandleElement(Point(R.Right, R.Bottom)); + end; + end; +end; + +procedure TTBXOffice2007Theme.TBXSysCommand(var Message: TMessage); +begin + if Message.WParam = TSC_VIEWCHANGE then SetupColorCache; +end; + +initialization + if not IsTBXThemeAvailable('Office2007') then + RegisterTBXTheme('Office2007', TTBXOffice2007Theme); + +end. + diff --git a/TBXUtils.pas b/TBXUtils.pas new file mode 100644 index 000000000..97bc436f4 --- /dev/null +++ b/TBXUtils.pas @@ -0,0 +1,3218 @@ +unit TBXUtils; + +// TBX Package +// Copyright 2001-2004 Alex A. Denisov. All Rights Reserved +// See TBX.chm for license and installation instructions +// +// $Id: TBXUtils.pas 11 2004-04-01 07:22:56Z Alex@ZEISS $ + +interface + +{$I TB2Ver.inc} +{$I TBX.inc} + +uses + Windows, Messages, Classes, SysUtils, Graphics, Controls, Forms, ImgList; + +{$IFDEF TBX_UNICODE} +function GetTextHeightW(DC: HDC): Integer; +function GetTextWidthW(DC: HDC; const S: WideString; StripAccelChar: Boolean): Integer; +procedure DrawRotatedTextW(DC: HDC; AText: WideString; const ARect: TRect; const AFormat: Cardinal); +function EscapeAmpersandsW(const S: WideString): WideString; +function FindAccelCharW(const S: WideString): WideChar; +function StripAccelCharsW(const S: WideString): WideString; +function StripTrailingPunctuationW(const S: WideString): WideString; +{$ENDIF} + +{vb+} +{ Misc. functions } +{$IFNDEF JR_D6} +function CheckWin32Version(AMajor: Integer; AMinor: Integer = 0): Boolean; +{$ENDIF} +function GetRectCenter(const ARect: TRect): TPoint; overload; +procedure GetRectCenter(const ARect: TRect; out X, Y: Integer); overload; +procedure InflateRectHorz(var ARect: TRect; DX: Integer); {$IFDEF JR_D9} inline; {$ENDIF} +procedure InflateRectVert(var ARect: TRect; DY: Integer); {$IFDEF JR_D9} inline; {$ENDIF} +procedure OffsetPoint(var P: TPoint; DX, DY: Integer); {$IFDEF JR_D9} inline; {$ENDIF} +procedure OffsetPoints(var Points: array of TPoint; DX, DY: Integer); +procedure OffsetRectHorz(var ARect: TRect; DX: Integer); {$IFDEF JR_D9} inline; {$ENDIF} +procedure OffsetRectVert(var ARect: TRect; DY: Integer); {$IFDEF JR_D9} inline; {$ENDIF} +function RectsIntersect(const R1, R2: TRect): Boolean; +procedure SetPoint(out P: TPoint; X, Y: Integer); {$IFDEF JR_D9} inline; {$ENDIF} + +type + TBufDCRec = record + DC : HDC; + Bmp : HBITMAP; + end; + +function CreateBufDC(DC: HDC; BufWidth, BufHeight: Integer; out BufDCRec: TBufDCRec): HDC; +function DeleteBufDC(const BufDCRec: TBufDCRec): Boolean; +{vb+end} + +procedure GetRGB(C: TColor; out R, G, B: Integer); +function MixColors(C1, C2: TColor; W1: Integer): TColor; +function SameColors(C1, C2: TColor): Boolean; +function Lighten(C: TColor; Amount: Integer): TColor; +function NearestBlendedColor(C1, C2: TColor; W1: Integer): TColor; {vb+} +function NearestLighten(C: TColor; Amount: Integer): TColor; +function NearestMixedColor(C1, C2: TColor; W1: Integer): TColor; +function ColorIntensity(C: TColor): Integer; +function IsDarkColor(C: TColor; Threshold: Integer = 100): Boolean; +function Blend(C1, C2: TColor; W1: Integer): TColor; +procedure SetContrast(var Color: TColor; BkgndColor: TColor; Threshold: Integer); +procedure RGBtoHSL(RGB: TColor; out H, S, L : Single); +function HSLtoRGB(H, S, L: Single): TColor; +function GetBGR(C: TColorRef): Cardinal; + +{ A few drawing functions } +{ these functions recognize clNone value of TColor } + +procedure SetPixelEx(DC: HDC; X, Y: Integer; C: TColorRef; Alpha: Longword = $FF); +function CreatePenEx(Color: TColor): HPen; +function CreateBrushEx(Color: TColor): HBrush; +function CreateDitheredBrush(C1, C2: TColor): HBrush; +function FillRectEx(DC: HDC; const Rect: TRect; Color: TColor): Boolean; {$IFDEF COMPATIBLE_GFX}overload;{$ENDIF} +function FrameRectEx(DC: HDC; var Rect: TRect; Color: TColor; Adjust: Boolean): Boolean; {$IFDEF COMPATIBLE_GFX}overload;{$ENDIF} +//procedure DrawLineEx(DC: HDC; X1, Y1, X2, Y2: Integer; Color: TColor); {$IFDEF COMPATIBLE_GFX}overload;{$ENDIF} {vb-} +{vb+} +procedure DrawLineEx(DC: HDC; X1, Y1, X2, Y2: Integer; Color: TColor); overload; +procedure DrawLineEx(DC: HDC; const R: TRect; Color: TColor); overload; +procedure DrawPattern(DC: HDC; X, Y: Integer; Points: array of TPoint; Color: TColor; Fill: Boolean); overload; +procedure DrawPattern(DC: HDC; const P: TPoint; Points: array of TPoint; Color: TColor; Fill: Boolean); overload; +procedure EllipseEx(DC: HDC; Left, Top, Right, Bottom: Integer; OutlineColor, FillColor: TColor); overload; +procedure EllipseEx(DC: HDC; const R: TRect; OutlineColor, FillColor: TColor); overload; +{vb+end} +function PolyLineEx(DC: HDC; const Points: array of TPoint; Color: TColor): Boolean; +procedure PolygonEx(DC: HDC; const Points: array of TPoint; OutlineColor, FillColor: TColor); +{vb+} +procedure RectangleEx(DC: HDC; Left, Top, Right, Bottom: Integer; OutlineColor, FillColor: TColor); overload; +procedure RectangleEx(DC: HDC; const R: TRect; OutlineColor, FillColor: TColor); overload; +procedure RoundFrameEx(DC: HDC; Left, Top, Right, Bottom, EllipseWidth, EllipseHeight: Integer; Color: TColor); overload; +procedure RoundFrameEx(DC: HDC; const R: TRect; EllipseWidth, EllipseHeight: Integer; Color: TColor); overload; +procedure RoundRectEx(DC: HDC; Left, Top, Right, Bottom, EllipseWidth, EllipseHeight: Integer; OutlineColor, FillColor: TColor); overload; +procedure RoundRectEx(DC: HDC; const R: TRect; EllipseWidth, EllipseHeight: Integer; OutlineColor, FillColor: TColor); overload; +procedure DitherFrame(DC: HDC; const R: TRect; C1, C2: TColor); +{vb+end} +procedure DitherRect(DC: HDC; const R: TRect; C1, C2: TColor); {$IFDEF COMPATIBLE_GFX}overload;{$ENDIF} +procedure Frame3D(DC: HDC; var Rect: TRect; TopColor, BottomColor: TColor; Adjust: Boolean); {$IFDEF COMPATIBLE_GFX}overload;{$ENDIF} +procedure DrawDraggingOutline(DC: HDC; const NewRect, OldRect: TRect); + +{ Gradients } +type + TGradientKind = (gkHorz, gkVert); + +procedure GradFill(DC: HDC; ARect: TRect; ClrTopLeft, ClrBottomRight: TColor; Kind: TGradientKind); +procedure BrushedFill(DC: HDC; Origin: PPoint; ARect: TRect; Color: TColor; Roughness: Integer); +procedure ResetBrushedFillCache; +procedure FinalizeBrushedFill; {vb+} + +{ drawing functions for compatibility with previous versions } +{$IFDEF COMPATIBLE_GFX} +function FillRectEx(Canvas: TCanvas; const Rect: TRect; Color: TColor): Boolean; overload; +function FrameRectEx(Canvas: TCanvas; var Rect: TRect; Color: TColor; Adjust: Boolean = False): Boolean; overload; +procedure DrawLineEx(Canvas: TCanvas; X1, Y1, X2, Y2: Integer; Color: TColor); overload; +procedure DitherRect(Canvas: TCanvas; const R: TRect; C1, C2: TColor); overload; +procedure Frame3D(Canvas: TCanvas; var Rect: TRect; TopColor, BottomColor: TColor); overload; +function FillRectEx2(DC: HDC; const Rect: TRect; Color: TColor): Boolean; deprecated; +function FrameRectEx2(DC: HDC; var Rect: TRect; Color: TColor; Adjust: Boolean = False): Boolean; deprecated; +{$ENDIF} + +{ alternatives to fillchar and move routines what work with 32-bit aligned memory blocks } +procedure FillLongword(var X; Count: Integer; Value: Longword); +procedure MoveLongword(const Source; var Dest; Count: Integer); + +{ extended icon painting routines } +procedure DrawTBXIcon(Canvas: TCanvas; const R: TRect; + ImageList: TCustomImageList; ImageIndex: Integer; HiContrast: Boolean); +procedure BlendTBXIcon(Canvas: TCanvas; const R: TRect; + ImageList: TCustomImageList; ImageIndex: Integer; Opacity: Byte); +procedure HighlightTBXIcon(Canvas: TCanvas; const R: TRect; + ImageList: TCustomImageList; ImageIndex: Integer; HighlightColor: TColor; Amount: Byte); +procedure DrawTBXIconShadow(Canvas: TCanvas; const R: TRect; + ImageList: TCustomImageList; ImageIndex: Integer; Density: Integer); +procedure DrawTBXIconFlatShadow(Canvas: TCanvas; const R: TRect; + ImageList: TCustomImageList; ImageIndex: Integer; ShadowColor: TColor); +procedure DrawTBXIconFullShadow(Canvas: TCanvas; const R: TRect; + ImageList: TCustomImageList; ImageIndex: Integer; ShadowColor: TColor); + +procedure DrawGlyph(DC: HDC; X, Y: Integer; ImageList: TCustomImageList; ImageIndex: Integer; Color: TColor); overload; +procedure DrawGlyph(DC: HDC; const R: TRect; ImageList: TCustomImageList; ImageIndex: Integer; Color: TColor); overload; +procedure DrawGlyph(DC: HDC; X, Y: Integer; const Bits; Color: TColor); overload; +procedure DrawGlyph(DC: HDC; const R: TRect; Width, Height: Integer; const Bits; Color: TColor); overload; + +function GetClientSizeEx(Control: TWinControl): TPoint; + +const + SHD_DENSE = 0; + SHD_LIGHT = 1; + +{ An additional declaration for D4 compiler } +type + PColor = ^TColor; + +{ Stock Objects } +var + {StockBitmap1, StockBitmap2: TBitmap;} {vb-} + StockBitmap1: TBitmap; {vb+} + StockMonoBitmap, StockCompatibleBitmap: TBitmap; + SmCaptionFont: TFont; + +const + ROP_DSPDxax = $00E20746; + +{ Support for window shadows } +type + TShadowEdges = set of (seTopLeft, seBottomRight); + TShadowStyle = (ssFlat, ssLayered, ssAlphaBlend); + + TShadow = class(TCustomControl) + protected + FOpacity: Byte; + FBuffer: TBitmap; + FClearRect: TRect; + FEdges: TShadowEdges; + FStyle: TShadowStyle; + FSaveBits: Boolean; + procedure GradR(const R: TRect); + procedure GradB(const R: TRect); + procedure GradBR(const R: TRect); + procedure GradTR(const R: TRect); + procedure GradBL(const R: TRect); + procedure CreateParams(var Params: TCreateParams); override; + procedure FillBuffer; virtual; abstract; + procedure WMNCHitTest(var Message: TMessage); message WM_NCHITTEST; + procedure WMEraseBkgnd(var Message: TWMEraseBkgnd); message WM_ERASEBKGND; + public + constructor Create(const Bounds: TRect; Opacity: Byte; LoColor: Boolean; Edges: TShadowEdges); reintroduce; + procedure Clear(const R: TRect); + procedure Render; + procedure Show(ParentHandle: HWND); + end; + + THorzShadow = class(TShadow) + protected + procedure FillBuffer; override; + end; + + TVertShadow = class(TShadow) + protected + procedure FillBuffer; override; + end; + + TShadows = class + private + FSaveBits: Boolean; + procedure SetSaveBits(Value: Boolean); + protected + V1: TShadow; + H1: TShadow; + V2: TShadow; + H2: TShadow; + V3: TShadow; + H3: TShadow; + public + constructor Create(R1, R2: TRect; Size: Integer; Opacity: Byte; LoColor: Boolean); + destructor Destroy; override; + procedure Show(ParentHandle: HWND); + property SaveBits: Boolean read FSaveBits write SetSaveBits; + end; + +procedure RecreateStock; + +type + PBlendFunction = ^TBlendFunction; + TBlendFunction = packed record + BlendOp: Byte; + BlendFlags: Byte; + SourceConstantAlpha: Byte; + AlphaFormat: Byte; + end; + + TUpdateLayeredWindow = function(hWnd : hWnd; hdcDst : hDC; pptDst : PPoint; + psize : PSize; hdcSrc : hDC; pptSrc : PPoint; crKey : TColorRef; + pblend : PBlendFunction; dwFlags : Integer): Integer; stdcall; + + TAlphaBlend = function(hdcDest: HDC; nXOriginDest, nYOriginDest, + nWidthDest, nHeightDest: Integer; hdcSrc: HDC; + nXOriginSrc, nYOriginSrc, nWidthSrc, nHeightSrc: Integer; + blendFunction: TBlendFunction): BOOL; stdcall; + + TGradientFill = function(Handle: HDC; pVertex: Pointer; dwNumVertex: DWORD; + pMesh: Pointer; dwNumMesh: DWORD; dwMode: DWORD): DWORD; stdcall; + +var + UpdateLayeredWindow: TUpdateLayeredWindow = nil; + AlphaBlend: TAlphaBlend = nil; + GradientFill: TGradientFill = nil; + + +implementation + +{$R-}{$Q-} + +{uses TB2Common, Math;} {vb-} +uses TB2Common, Math, Consts, Types; {vb+} + + +{$IFDEF TBX_UNICODE} + +function GetTextHeightW(DC: HDC): Integer; +var + TextMetric: TTextMetricW; +begin + GetTextMetricsW(DC, TextMetric); + Result := TextMetric.tmHeight; +end; + +function GetTextWidthW(DC: HDC; const S: WideString; StripAccelChar: Boolean): Integer; +var + Size: TSize; + S2: WideString; +begin + if StripAccelChar then + begin + S2 := StripAccelCharsW(S); + GetTextExtentPoint32W(DC, PWideChar(S2), Length(S2), Size); + end + else GetTextExtentPoint32W(DC, PWideChar(S), Length(S), Size); + Result := Size.cx; +end; + +procedure DrawRotatedTextW(DC: HDC; AText: WideString; const ARect: TRect; const AFormat: Cardinal); +{ Like DrawText, but draws the text at a 270 degree angle. + The format flag this function respects are + DT_NOPREFIX, DT_HIDEPREFIX, DT_CENTER, DT_END_ELLIPSIS, DT_NOCLIP } +var + RotatedFont, SaveFont: HFONT; + TextMetrics: TTextMetricW; + X, Y, P, I, SU, FU, W: Integer; + SaveAlign: UINT; + Clip: Boolean; + + function GetSize(DC: HDC; const S: WideString): Integer; + var + Size: TSize; + begin + GetTextExtentPoint32W(DC, PWideChar(S), Length(S), Size); + Result := Size.cx; + end; + +begin + if Length(AText) = 0 then Exit; + + RotatedFont := CreateRotatedFont(DC); + SaveFont := SelectObject(DC, RotatedFont); + + GetTextMetricsW(DC, TextMetrics); + X := ARect.Left + ((ARect.Right - ARect.Left) - TextMetrics.tmHeight) div 2; + + Clip := AFormat and DT_NOCLIP = 0; + + { 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; + if AFormat and DT_NOPREFIX = 0 then + while I <= Length(AText) do + begin + if AText[I] = '&' then + begin + Delete(AText, I, 1); + if PWideChar(AText)[I - 1] <> '&' then P := I; + end; + Inc(I); + end; + + if AFormat and DT_END_ELLIPSIS <> 0 then + begin + if (Length(AText) > 1) and (GetSize(DC, AText) > ARect.Bottom - ARect.Top) then + begin + W := ARect.Bottom - ARect.Top; + if W > 2 then + begin + Delete(AText, Length(AText), 1); + while (Length(AText) > 1) and (GetSize(DC, AText + '...') > W) do + Delete(AText, Length(AText), 1); + end + else AText := AText[1]; + if P > Length(AText) then P := 0; + AText := AText + '...'; + end; + end; + + if AFormat and DT_CENTER <> 0 then + Y := ARect.Top + ((ARect.Bottom - ARect.Top) - GetSize(DC, AText)) div 2 + else + Y := ARect.Top; + + if Clip then + begin + SaveDC(DC); + with ARect do IntersectClipRect(DC, Left, Top, Right, Bottom); + end; + + SaveAlign := SetTextAlign(DC, TA_BOTTOM); + TextOutW(DC, X, Y, PWideChar(AText), Length(AText)); + SetTextAlign(DC, SaveAlign); + + { Underline } + if (P > 0) and (AFormat and DT_HIDEPREFIX = 0) then + begin + SU := GetTextWidthW(DC, Copy(AText, 1, P - 1), False); + FU := SU + GetTextWidthW(DC, PWideChar(AText)[P - 1], False); + Inc(X, TextMetrics.tmDescent - 2); + DrawLineEx(DC, X, Y + SU, X, Y + FU, GetTextColor(DC)); + end; + + if Clip then RestoreDC(DC, -1); + + SelectObject(DC, SaveFont); + DeleteObject(RotatedFont); +end; + +function EscapeAmpersandsW(const S: WideString): WideString; +var + I: Integer; +begin + Result := S; + I := 1; + while I <= Length(Result) do + begin + if Result[I] = '&' then + begin + Inc(I); + Insert('&', Result, I); + end; + Inc(I); + end; +end; + +function FindAccelCharW(const S: WideString): WideChar; +var + PStart, P: PWideChar; +begin + { locate the last char with '&' prefix } + Result := #0; + if Length(S) > 0 then + begin + PStart := PWideChar(S); + P := PStart; + Inc(P, Length(S) - 2); + while P >= PStart do + begin + if P^ = '&' then + begin + if (P = PStart) or (PWideChar(Integer(P) - 2)^ <> '&') then + begin + Result := PWideChar(Integer(P) + 2)^; + Exit; + end + else Dec(P); + end; + Dec(P); + end; + end; +end; + +function StripAccelCharsW(const S: WideString): WideString; +var + I: Integer; +begin + Result := S; + I := 1; + while I <= Length(Result) do + begin + if Result[I] = '&' then + System.Delete(Result, I, 1); + Inc(I); + end; +end; + +function StripTrailingPunctuationW(const S: WideString): WideString; +var + L: Integer; +begin + Result := S; + L := Length(Result); + if (L > 1) and (Result[L] = ':') then SetLength(Result, L - 1) + else if (L > 3) and (Result[L - 2] = '.') and (Result[L - 1] = '.') and + (Result[L] = '.') then SetLength(Result, L - 3); +end; + +{$ENDIF} + +{vb+} +{$IFNDEF JR_D6} +function CheckWin32Version(AMajor: Integer; AMinor: Integer = 0): Boolean; +begin + Result := (Win32MajorVersion > AMajor) or + ((Win32MajorVersion = AMajor) and (Win32MinorVersion >= AMinor)); +end; +{$ENDIF} + +function GetRectCenter(const ARect: TRect): TPoint; +begin + with ARect, Result do + begin + X := (Left + Right) div 2; + Y := (Top + Bottom) div 2; + end; +end; + +procedure GetRectCenter(const ARect: TRect; out X, Y: Integer); +begin + with ARect do + begin + X := (Left + Right) div 2; + Y := (Top + Bottom) div 2; + end; +end; + +procedure InflateRectHorz(var ARect: TRect; DX: Integer); +begin + Dec(ARect.Left, DX); + Inc(ARect.Right, DX); +end; + +procedure InflateRectVert(var ARect: TRect; DY: Integer); +begin + Dec(ARect.Top, DY); + Inc(ARect.Bottom, DY); +end; + +procedure OffsetPoint(var P: TPoint; DX, DY: Integer); +begin + Inc(P.X, DX); + Inc(P.Y, DY); +end; + +procedure OffsetPoints(var Points: array of TPoint; DX, DY: Integer); +var + I: Integer; +begin + for I := Low(Points) to High(Points) do + with Points[I] do + begin + Inc(X, DX); + Inc(Y, DY); + end; +end; + +procedure OffsetRectHorz(var ARect: TRect; DX: Integer); +begin + Inc(ARect.Left, DX); + Inc(ARect.Right, DX); +end; + +procedure OffsetRectVert(var ARect: TRect; DY: Integer); +begin + Inc(ARect.Top, DY); + Inc(ARect.Bottom, DY); +end; + +function RectsIntersect(const R1, R2: TRect): Boolean; +begin + Result := + (Min(R1.Right, R2.Right) > Max(R1.Left, R2.Left)) and + (Min(R1.Bottom, R2.Bottom) > Max(R1.Top, R2.Top)); +end; + +procedure SetPoint(out P: TPoint; X, Y: Integer); +begin + P.X := X; + P.Y := Y; +end; + +function CreateBufDC(DC: HDC; BufWidth, BufHeight: Integer; out BufDCRec: TBufDCRec): HDC; +var + CDC: HDC; + Bmp: HBitmap; +begin + CDC := CreateCompatibleDC(DC); + if CDC <> 0 then + begin + Bmp := CreateCompatibleBitmap(DC, BufWidth, BufHeight); + if Bmp <> 0 then + begin + if SelectObject(CDC, Bmp) <> 0 then + begin + BufDCRec.DC := CDC; + BufDCRec.Bmp := Bmp; + Result := CDC; + Exit; + end; + DeleteObject(Bmp); + end; + DeleteDC(DC); + end; + Result := 0; + BufDCRec.DC := Result; + BufDCRec.Bmp := Result; +end; + +function DeleteBufDC(const BufDCRec: TBufDCRec): Boolean; +begin + { Importantly: First DeleteDC, then DeleteObject. + Bitmap selected into DC do not be deleted. } + Result := DeleteDC(BufDCRec.DC); + if not DeleteObject(BufDCRec.Bmp) then Result := False; +end; +{vb+end} + +type + PPoints = ^TPoints; + TPoints = array [0..0] of TPoint; + +const + WeightR: single = 0.764706; + WeightG: single = 1.52941; + WeightB: single = 0.254902; + +procedure GetRGB(C: TColor; out R, G, B: Integer); +begin + if Integer(C) < 0 then C := GetSysColor(C and $000000FF); + R := C and $FF; + G := C shr 8 and $FF; + B := C shr 16 and $FF; +end; + +function MixColors(C1, C2: TColor; W1: Integer): TColor; +var + W2: Cardinal; +begin + Assert(W1 in [0..255]); + W2 := W1 xor 255; + if Integer(C1) < 0 then C1 := GetSysColor(C1 and $000000FF); + if Integer(C2) < 0 then C2 := GetSysColor(C2 and $000000FF); + Result := Integer( + ((Cardinal(C1) and $FF00FF) * Cardinal(W1) + + (Cardinal(C2) and $FF00FF) * W2) and $FF00FF00 + + ((Cardinal(C1) and $00FF00) * Cardinal(W1) + + (Cardinal(C2) and $00FF00) * W2) and $00FF0000) shr 8; +end; + +function SameColors(C1, C2: TColor): Boolean; +begin + if C1 < 0 then C1 := GetSysColor(C1 and $000000FF); + if C2 < 0 then C2 := GetSysColor(C2 and $000000FF); + Result := C1 = C2; +end; + +function Lighten(C: TColor; Amount: Integer): TColor; +var + R, G, B: Integer; +begin + if C < 0 then C := GetSysColor(C and $000000FF); + R := C and $FF + Amount; + G := C shr 8 and $FF + Amount; + B := C shr 16 and $FF + Amount; + if R < 0 then R := 0 else if R > 255 then R := 255; + if G < 0 then G := 0 else if G > 255 then G := 255; + if B < 0 then B := 0 else if B > 255 then B := 255; + Result := R or (G shl 8) or (B shl 16); +end; + +{vb+} +function NearestBlendedColor(C1, C2: TColor; W1: Integer): TColor; +begin + Result := Blend(C1, C2, W1); + Result := GetNearestColor(StockCompatibleBitmap.Canvas.Handle, Result); +end; +{vb+end} + +function NearestLighten(C: TColor; Amount: Integer): TColor; +begin + Result := GetNearestColor(StockCompatibleBitmap.Canvas.Handle, Lighten(C, Amount)); +end; + +function NearestMixedColor(C1, C2: TColor; W1: Integer): TColor; +begin + Result := MixColors(C1, C2, W1); + Result := GetNearestColor(StockCompatibleBitmap.Canvas.Handle, Result); +end; + +function ColorIntensity(C: TColor): Integer; +begin + if C < 0 then C := GetSysColor(C and $FF); + Result := ((C shr 16 and $FF) * 30 + (C shr 8 and $FF) * 150 + (C and $FF) * 76) shr 8; +end; + +function IsDarkColor(C: TColor; Threshold: Integer = 100): Boolean; +begin + if C < 0 then C := GetSysColor(C and $FF); + Threshold := Threshold shl 8; + Result := ((C and $FF) * 76 + (C shr 8 and $FF) * 150 + (C shr 16 and $FF) * 30 ) < Threshold; +end; + +function Blend(C1, C2: TColor; W1: Integer): TColor; +var + W2, A1, A2, D, F, G: Integer; +begin + if C1 < 0 then C1 := GetSysColor(C1 and $FF); + if C2 < 0 then C2 := GetSysColor(C2 and $FF); + + if W1 >= 100 then D := 1000 + else D := 100; + + W2 := D - W1; + F := D div 2; + + A2 := C2 shr 16 * W2; + A1 := C1 shr 16 * W1; + G := (A1 + A2 + F) div D and $FF; + Result := G shl 16; + + A2 := (C2 shr 8 and $FF) * W2; + A1 := (C1 shr 8 and $FF) * W1; + G := (A1 + A2 + F) div D and $FF; + Result := Result or G shl 8; + + A2 := (C2 and $FF) * W2; + A1 := (C1 and $FF) * W1; + G := (A1 + A2 + F) div D and $FF; + Result := Result or G; +end; + +function ColorDistance(C1, C2: Integer): Single; +var + DR, DG, DB: Integer; +begin + DR := (C1 and $FF) - (C2 and $FF); + Result := Sqr(DR * WeightR); + DG := (C1 shr 8 and $FF) - (C2 shr 8 and $FF); + Result := Result + Sqr(DG * WeightG); + DB := (C1 shr 16) - (C2 shr 16); + Result := Result + Sqr(DB * WeightB); + Result := SqRt(Result); +end; + +function GetAdjustedThreshold(BkgndIntensity, Threshold: Single): Single; +begin + if BkgndIntensity < 220 then Result := (2 - BkgndIntensity / 220) * Threshold + else Result := Threshold; +end; + +function IsContrastEnough(AColor, ABkgndColor: Integer; + DoAdjustThreshold: Boolean; Threshold: Single): Boolean; +begin + if DoAdjustThreshold then + Threshold := GetAdjustedThreshold(ColorDistance(ABkgndColor, $000000), Threshold); + Result := ColorDistance(ABkgndColor, AColor) > Threshold; +end; + +procedure AdjustContrast(var AColor: Integer; ABkgndColor: Integer; Threshold: Single); +var + x, y, z: Single; + r, g, b: Single; + RR, GG, BB: Integer; + i1, i2, s, q, w: Single; + DoInvert: Boolean; +begin + i1 := ColorDistance(AColor, $000000); + i2 := ColorDistance(ABkgndColor, $000000); + Threshold := GetAdjustedThreshold(i2, Threshold); + + if i1 > i2 then DoInvert := i2 < 442 - Threshold + else DoInvert := i2 < Threshold; + + x := (ABkgndColor and $FF) * WeightR; + y := (ABkgndColor shr 8 and $FF) * WeightG; + z := (ABkgndColor shr 16) * WeightB; + + r := (AColor and $FF) * WeightR; + g := (AColor shr 8 and $FF) * WeightG; + b := (AColor shr 16) * WeightB; + + if DoInvert then + begin + r := 195 - r; + g := 390 - g; + b := 65 - b; + x := 195 - x; + y := 390 - y; + z := 65 - z; + end; + + s := Sqrt(Sqr(b) + Sqr(g) + Sqr(r)); + if s < 0.01 then s := 0.01; + + q := (r * x + g * y + b * z) / S; + + x := Q / S * r - x; + y := Q / S * g - y; + z := Q / S * b - z; + + w := Sqrt(Sqr(Threshold) - Sqr(x) - Sqr(y) - Sqr(z)); + + r := (q - w) * r / s; + g := (q - w) * g / s; + b := (q - w) * b / s; + + if DoInvert then + begin + r := 195 - r; + g := 390 - g; + b := 65 - b; + end; + + if r < 0 then r := 0 else if r > 195 then r := 195; + if g < 0 then g := 0 else if g > 390 then g := 390; + if b < 0 then b := 0 else if b > 65 then b := 65; + + RR := Trunc(r * (1 / WeightR) + 0.5); + GG := Trunc(g * (1 / WeightG) + 0.5); + BB := Trunc(b * (1 / WeightB) + 0.5); + + if RR > $FF then RR := $FF else if RR < 0 then RR := 0; + if GG > $FF then GG := $FF else if GG < 0 then GG := 0; + if BB > $FF then BB := $FF else if BB < 0 then BB := 0; + + AColor := (BB and $FF) shl 16 or (GG and $FF) shl 8 or (RR and $FF); +end; + +procedure SetContrast(var Color: TColor; BkgndColor: TColor; Threshold: Integer); +var + t: Single; +begin + if Color < 0 then Color := GetSysColor(Color and $FF); + if BkgndColor < 0 then BkgndColor := GetSysColor(BkgndColor and $FF); + t := Threshold; + if not IsContrastEnough(Color, BkgndColor, True, t) then + AdjustContrast(Integer(Color), BkgndColor, t); +end; + +procedure RGBtoHSL(RGB: TColor; out H, S, L : Single); +var + R, G, B, D, Cmax, Cmin: Single; +begin + if RGB < 0 then RGB := GetSysColor(RGB and $FF); + R := GetRValue(RGB) / 255; + G := GetGValue(RGB) / 255; + B := GetBValue(RGB) / 255; + Cmax := Max(R, Max(G, B)); + Cmin := Min(R, Min(G, B)); + L := (Cmax + Cmin) / 2; + + if Cmax = Cmin then + begin + H := 0; + S := 0 + end + else + begin + D := Cmax - Cmin; + if L < 0.5 then S := D / (Cmax + Cmin) + else S := D / (2 - Cmax - Cmin); + if R = Cmax then H := (G - B) / D + else + if G = Cmax then H := 2 + (B - R) / D + else H := 4 + (R - G) / D; + H := H / 6; + if H < 0 then H := H + 1 + end; +end; + +function HSLtoRGB(H, S, L: Single): TColor; +const + OneOverThree = 1 / 3; +var + M1, M2: Single; + R, G, B: Byte; + + function HueToColor(Hue: Single): Byte; + var + V: Double; + begin + Hue := Hue - Floor(Hue); + if 6 * Hue < 1 then V := M1 + (M2 - M1) * Hue * 6 + else if 2 * Hue < 1 then V := M2 + else if 3 * Hue < 2 then V := M1 + (M2 - M1) * (2 / 3 - Hue) * 6 + else V := M1; + Result := Round(255 * V); + end; + +begin + if S = 0 then + begin + R := Round(255 * L); + G := R; + B := R; + end + else + begin + if L <= 0.5 then M2 := L * (1 + S) + else M2 := L + S - L * S; + M1 := 2 * L - M2; + R := HueToColor(H + OneOverThree); + G := HueToColor(H); + B := HueToColor(H - OneOverThree) + end; + Result := RGB(R, G, B); +end; + +{ Drawing routines } +{function GetBGR(C: TColorRef): Cardinal; +asm + MOV ECX,EAX // this function swaps R and B bytes in ABGR + SHR EAX,16 + XCHG AL,CL + MOV AH,$FF // and writes $FF into A component + SHL EAX,16 + MOV AX,CX +end;} {vb-} + +{vb+} +function GetBGR(C: TColorRef): Cardinal; +asm + SHL EAX, 8 //ROL EAX, 8 // ABGR -> BGRA + MOV AL, $FF // A = $FF + BSWAP EAX // BGRA -> ARGB +end; +{vb+end} + +procedure SetPixelEx(DC: HDC; X, Y: Integer; C: TColorRef; Alpha: Longword = $FF); +var + W2: Cardinal; + B: TColorRef; +begin + {if Alpha <= 0 then Exit} {vb- signed Longword 8-[] } + if Alpha = 0 then Exit {vb+} + else if Alpha >= 255 then SetPixelV(DC, X, Y, C) + else + begin + B := GetPixel(DC, X, Y); + if B <> CLR_INVALID then + begin + Inc(Alpha, Integer(Alpha > 127)); + W2 := 256 - Alpha; + B := + ((C and $FF00FF) * Alpha + (B and $FF00FF) * W2 + $007F007F) and $FF00FF00 + + ((C and $00FF00) * Alpha + (B and $00FF00) * W2 + $00007F00) and $00FF0000; + SetPixelV(DC, X, Y, B shr 8); + end; + end; +end; + +{function CreatePenEx(Color: TColor): HPen; +begin + if Color = clNone then Result := CreatePen(PS_NULL, 1, 0) + else if Color < 0 then Result := CreatePen(PS_SOLID, 1, GetSysColor(Color and $000000FF)) + else Result := CreatePen(PS_SOLID, 1, Color); +end;} {vb-} + +{vb+} +function CreatePenEx(Color: TColor): HPen; +begin + if Color <> clNone then + begin + if Color < 0 then Color := GetSysColor(Color and $FF); + Result := CreatePen(PS_SOLID, 1, Color); + end + else Result := CreatePen(PS_NULL, 1, 0); +end; +{vb+end} + +{function CreateBrushEx(Color: TColor): HBrush; +var + LB: TLogBrush; +begin + if Color = clNone then + begin + LB.lbStyle := BS_HOLLOW; + Result := CreateBrushIndirect(LB); + end + else if Color < 0 then Result := GetSysColorBrush(Color and $000000FF) + else Result := CreateSolidBrush(Color); +end;} {vb-} + +{vb+} +function CreateBrushEx(Color: TColor): HBrush; +var + LB: TLogBrush; +begin + if Color <> clNone then + begin + if Color < 0 then Color := GetSysColor(Color and $FF); + Result := CreateSolidBrush(Color); + end + else begin + LB.lbStyle := BS_HOLLOW; + Result := CreateBrushIndirect(LB); + end; +end; +{vb+end} + +{function FillRectEx(DC: HDC; const Rect: TRect; Color: TColor): Boolean; +var + Brush: HBRUSH; +begin + Result := Color <> clNone; + if Result then + begin + if Color < 0 then Brush := GetSysColorBrush(Color and $000000FF) + else Brush := CreateSolidBrush(Color); + Windows.FillRect(DC, Rect, Brush); + DeleteObject(Brush); + end; +end;} {vb-} + +{vb+} +function FillRectEx(DC: HDC; const Rect: TRect; Color: TColor): Boolean; +var + Brush: HBRUSH; +begin + if Color <> clNone then + begin + if Color >= 0 then + begin + Brush := CreateSolidBrush(Color); + Windows.FillRect(DC, Rect, Brush); + DeleteObject(Brush); + end + else Windows.FillRect(DC, Rect, GetSysColorBrush(Color and $FF)); + Result := True; + end + else Result := False; +end; +{vb+end} + +{function FrameRectEx(DC: HDC; var Rect: TRect; Color: TColor; Adjust: Boolean): Boolean; +var + Brush: HBRUSH; +begin + Result := Color <> clNone; + if Result then + begin + if Color < 0 then Brush := GetSysColorBrush(Color and $000000FF) + else Brush := CreateSolidBrush(Color); + Windows.FrameRect(DC, Rect, Brush); + DeleteObject(Brush); + end; + if Adjust then with Rect do + begin + Inc(Left); Dec(Right); + Inc(Top); Dec(Bottom); + end; +end;} {vb-} + +{vb+} +function FrameRectEx(DC: HDC; var Rect: TRect; Color: TColor; Adjust: Boolean): Boolean; +var + Brush: HBRUSH; +begin + if Color <> clNone then + begin + if Color >= 0 then + begin + Brush := CreateSolidBrush(Color); + Windows.FrameRect(DC, Rect, Brush); + DeleteObject(Brush); + end + else Windows.FrameRect(DC, Rect, GetSysColorBrush(Color and $FF)); + Result := True; + end + else Result := False; + if Adjust then with Rect do + begin + Inc(Left); Inc(Top); + Dec(Right); Dec(Bottom); + end; +end; +{vb+end} + +procedure DrawLineEx(DC: HDC; X1, Y1, X2, Y2: Integer; Color: TColor); +{var + OldPen, Pen: HPen; +begin + Pen := CreatePen(PS_SOLID, 1, ColorToRGB(Color)); + OldPen := SelectObject(DC, Pen); + Windows.MoveToEx(DC, X1, Y1, nil); + Windows.LineTo(DC, X2, Y2); + SelectObject(DC, OldPen); + DeleteObject(Pen);} {vb-} +{vb+} +var + OldPen: HPEN; +begin + if Color <> clNone then + begin + if Color < 0 then Color := GetSysColor(Color and $FF); + OldPen := SelectObject(DC, CreatePen(PS_SOLID, 1, Color)); + Windows.MoveToEx(DC, X1, Y1, nil); + Windows.LineTo(DC, X2, Y2); + DeleteObject(SelectObject(DC, OldPen)); + end; +end; + +procedure DrawLineEx(DC: HDC; const R: TRect; Color: TColor); +begin + with R do + DrawLineEx(DC, Left, Top, Right, Bottom, Color); +end; + +procedure DrawPattern(DC: HDC; X, Y: Integer; Points: array of TPoint; + Color: TColor; Fill: Boolean); +begin + if Color <> clNone then + begin + OffsetPoints(Points, X, Y); + if Fill + then PolygonEx(DC, Points, Color, Color) + else PolyLineEx(DC, Points, Color); + end; +end; + +procedure DrawPattern(DC: HDC; const P: TPoint; Points: array of TPoint; + Color: TColor; Fill: Boolean); +begin + if Color <> clNone then + begin + OffsetPoints(Points, P.X, P.Y); + if Fill + then PolygonEx(DC, Points, Color, Color) + else PolyLineEx(DC, Points, Color); + end; +end; + +procedure EllipseEx(DC: HDC; Left, Top, Right, Bottom: Integer; + OutlineColor, FillColor: TColor); +var + OldPen: HPEN; + OldBrush: HBRUSH; +begin + if (OutlineColor <> clNone) or (FillColor <> clNone) then + begin + OldPen := SelectObject(DC, CreatePenEx(OutlineColor)); + OldBrush := SelectObject(DC, CreateBrushEx(FillColor)); + Windows.Ellipse(DC, Left, Top, Right, Bottom); + DeleteObject(SelectObject(DC, OldBrush)); + DeleteObject(SelectObject(DC, OldPen)); + end; +end; + +procedure EllipseEx(DC: HDC; const R: TRect; OutlineColor, FillColor: TColor); +begin + with R do + EllipseEx(DC, Left, Top, Right, Bottom, OutlineColor, FillColor); +end; +{vb+end} + +function PolyLineEx(DC: HDC; const Points: array of TPoint; Color: TColor): Boolean; +{var + Pen, OldPen: HPEN; +begin + Result := Color <> clNone; + if Result then + begin + if Color < 0 then Color := GetSysColor(Color and $FF); + Pen := CreatePen(PS_SOLID, 1, Color); + OldPen := SelectObject(DC, Pen); + Windows.Polyline(DC, PPoints(@Points[0])^, Length(Points)); + SelectObject(DC, OldPen); + DeleteObject(Pen); + end;} {vb-} +{vb+} +var + OldPen: HPEN; +begin + if Color <> clNone then + begin + if Color < 0 then Color := GetSysColor(Color and $FF); + OldPen := SelectObject(DC, CreatePen(PS_SOLID, 1, Color)); + Windows.Polyline(DC, PPoints(@Points[0])^, Length(Points)); + DeleteObject(SelectObject(DC, OldPen)); + Result := True; + end + else Result := False; +end; +{vb+end} + +procedure PolygonEx(DC: HDC; const Points: array of TPoint; OutlineColor, FillColor: TColor); +{var + OldBrush, Brush: HBrush; + OldPen, Pen: HPen; +begin + if (OutlineColor = clNone) and (FillColor = clNone) then Exit; + Pen := CreatePenEx(OutlineColor); + Brush := CreateBrushEx(FillColor); + OldPen := SelectObject(DC, Pen); + OldBrush := SelectObject(DC, Brush); + Windows.Polygon(DC, PPoints(@Points[0])^, Length(Points)); + SelectObject(DC, OldBrush); + SelectObject(DC, OldPen); + DeleteObject(Brush); + DeleteObject(Pen);} {vb-} +{vb+} +var + OldPen: HPEN; + OldBrush: HBRUSH; +begin + if (OutlineColor <> clNone) or (FillColor <> clNone) then + begin + OldPen := SelectObject(DC, CreatePenEx(OutlineColor)); + OldBrush := SelectObject(DC, CreateBrushEx(FillColor)); + Windows.Polygon(DC, PPoints(@Points[0])^, Length(Points)); + DeleteObject(SelectObject(DC, OldBrush)); + DeleteObject(SelectObject(DC, OldPen)); + end; +end; +{vb+end} + +{vb+} +procedure RectangleEx(DC: HDC; Left, Top, Right, Bottom: Integer; + OutlineColor, FillColor: TColor); +var + OldPen: HPEN; + OldBrush: HBRUSH; +begin + if (OutlineColor <> clNone) or (FillColor <> clNone) then + begin + OldPen := SelectObject(DC, CreatePenEx(OutlineColor)); + OldBrush := SelectObject(DC, CreateBrushEx(FillColor)); + Windows.Rectangle(DC, Left, Top, Right, Bottom); + DeleteObject(SelectObject(DC, OldBrush)); + DeleteObject(SelectObject(DC, OldPen)); + end; +end; + +procedure RectangleEx(DC: HDC; const R: TRect; OutlineColor, FillColor: TColor); +begin + with R do + RectangleEx(DC, Left, Top, Right, Bottom, OutlineColor, FillColor); +end; + +procedure RoundFrameEx(DC: HDC; Left, Top, Right, Bottom, EllipseWidth, + EllipseHeight: Integer; Color: TColor); +var + OldPen: HPEN; + OldBrush: HBRUSH; +begin + if Color <> clNone then + begin + OldPen := SelectObject(DC, CreatePenEx(Color)); + OldBrush := SelectObject(DC, GetStockObject(NULL_BRUSH)); + Windows.RoundRect(DC, Left, Top, Right, Bottom, EllipseWidth, EllipseHeight); + SelectObject(DC, OldBrush); + DeleteObject(SelectObject(DC, OldPen)); + end; +end; + +procedure RoundFrameEx(DC: HDC; const R: TRect; EllipseWidth, + EllipseHeight: Integer; Color: TColor); +begin + with R do + RoundFrameEx(DC, Left, Top, Right, Bottom, EllipseWidth, + EllipseHeight, Color); +end; + +procedure RoundRectEx(DC: HDC; Left, Top, Right, Bottom, EllipseWidth, + EllipseHeight: Integer; OutlineColor, FillColor: TColor); +var + OldPen: HPEN; + OldBrush: HBRUSH; +begin + if (OutlineColor <> clNone) or (FillColor <> clNone) then + begin + OldPen := SelectObject(DC, CreatePenEx(OutlineColor)); + OldBrush := SelectObject(DC, CreateBrushEx(FillColor)); + Windows.RoundRect(DC, Left, Top, Right, Bottom, EllipseWidth, EllipseHeight); + DeleteObject(SelectObject(DC, OldBrush)); + DeleteObject(SelectObject(DC, OldPen)); + end; +end; + +procedure RoundRectEx(DC: HDC; const R: TRect; EllipseWidth, + EllipseHeight: Integer; OutlineColor, FillColor: TColor); +begin + with R do + RoundRectEx(DC, Left, Top, Right, Bottom, EllipseWidth, + EllipseHeight, OutlineColor, FillColor); +end; +{vb+end} + +function CreateDitheredBrush(C1, C2: TColor): HBrush; +var + B: TBitmap; +begin + B := AllocPatternBitmap(C1, C2); + B.HandleType := bmDDB; + Result := CreatePatternBrush(B.Handle); +end; + +procedure DitherRect(DC: HDC; const R: TRect; C1, C2: TColor); +var + Brush: HBRUSH; +begin + Brush := CreateDitheredBrush(C1, C2); + FillRect(DC, R, Brush); + DeleteObject(Brush); +end; + +{vb+} +procedure DitherFrame(DC: HDC; const R: TRect; C1, C2: TColor); +var + Brush: HBRUSH; +begin + Brush := CreateDitheredBrush(C1, C2); + FrameRect(DC, R, Brush); + DeleteObject(Brush); +end; +{vb+end} + +procedure Frame3D(DC: HDC; var Rect: TRect; TopColor, BottomColor: TColor; Adjust: Boolean); +var + TopRight, BottomLeft: TPoint; +begin + with Rect do + begin + Dec(Bottom); Dec(Right); + TopRight.X := Right; + TopRight.Y := Top; + BottomLeft.X := Left; + BottomLeft.Y := Bottom; + PolyLineEx(DC, [BottomLeft, TopLeft, TopRight], TopColor); + Dec(BottomLeft.X); + PolyLineEx(DC, [TopRight, BottomRight, BottomLeft], BottomColor); + if Adjust then + begin + Inc(Left); + Inc(Top); + end + else + begin + Dec(Right); + Dec(Bottom); + end; + end; +end; + + +{$IFDEF COMPATIBLE_GFX} +procedure DitherRect(Canvas: TCanvas; const R: TRect; C1, C2: TColor); +begin + DitherRect(Canvas.Handle, R, C1, C2); +end; + +procedure Frame3D(Canvas: TCanvas; var Rect: TRect; TopColor, BottomColor: TColor); +var + TopRight, BottomLeft: TPoint; +begin + with Canvas, Rect do + begin + Pen.Width := 1; + Dec(Bottom); Dec(Right); + TopRight.X := Right; + TopRight.Y := Top; + BottomLeft.X := Left; + BottomLeft.Y := Bottom; + Pen.Color := TopColor; + PolyLine([BottomLeft, TopLeft, TopRight]); + Pen.Color := BottomColor; + Dec(BottomLeft.X); + PolyLine([TopRight, BottomRight, BottomLeft]); + Inc(Left); Inc(Top); + end; +end; + +function FillRectEx(Canvas: TCanvas; const Rect: TRect; Color: TColor): Boolean; +begin + Result := FillRectEx(Canvas.Handle, Rect, Color); +end; + +function FillRectEx2(DC: HDC; const Rect: TRect; Color: TColor): Boolean; deprecated; +begin + Result := FillRectEx(DC, Rect, Color); +end; + +function FrameRectEx(Canvas: TCanvas; var Rect: TRect; Color: TColor; Adjust: Boolean = False): Boolean; +begin + Result := FrameRectEx(Canvas.Handle, Rect, Color, Adjust); +end; + +function FrameRectEx2(DC: HDC; var Rect: TRect; Color: TColor; Adjust: Boolean = False): Boolean; deprecated; +begin + Result := FrameRectEx(DC, Rect, Color, Adjust); +end; + +procedure DrawLineEx(Canvas: TCanvas; X1, Y1, X2, Y2: Integer; Color: TColor); +begin + DrawLineEx(Canvas.Handle, X1, Y1, X2, Y2, Color); +end; +{$ENDIF} + +procedure DrawDraggingOutline(DC: HDC; const NewRect, OldRect: TRect); +var + Sz: TSize; +begin + Sz.CX := 3; Sz.CY := 2; + DrawHalftoneInvertRect(DC, @NewRect, @OldRect, Sz, Sz); {vb-} + //DrawHalftoneInvertRect(DC, NewRect, OldRect, Sz, Sz); {vb+} +end; + +{procedure FillLongword(var X; Count: Integer; Value: Longword); +asm +// EAX = X; EDX = Count; ECX = Value + PUSH EDI + MOV EDI,EAX // Point EDI to destination + MOV EAX,ECX + MOV ECX,EDX + TEST ECX,ECX + JS @exit + REP STOSD // Fill count dwords +@exit: + POP EDI +end;} {vb-} + +{vb+} +{ On modern processors this faster than REP STOSD } +procedure FillLongWord(var X; Count: Integer; Value: LongWord); +asm + cmp edx, 8 + jl @@Small +@@LargeLoop: + mov [eax ], ecx + mov [eax+ 4], ecx + mov [eax+ 8], ecx + mov [eax+12], ecx + mov [eax+16], ecx + mov [eax+20], ecx + mov [eax+24], ecx + mov [eax+28], ecx + add eax, 32 + sub edx, 8 + cmp edx, 8 + jns @@LargeLoop + nop +@@Small: + test edx, edx + jle @@Exit +@@SmallLoop: + mov [eax], ecx + add eax, 4 + dec edx + jnz @@SmallLoop +@@Exit: +end; +{vb+end} + +{procedure MoveLongword(const Source; var Dest; Count: Integer); +asm +// EAX = Source; EDX = Dest; ECX = Count + PUSH ESI + PUSH EDI + MOV ESI,EAX // Source + MOV EDI,EDX // Destination + MOV EAX,ECX // Counter + CMP EDI,ESI + JE @exit + REP MOVSD +@exit: + POP EDI + POP ESI +end;} {vb-} + +{vb+} +{ On modern processors this faster than REP MOVSD } +procedure MoveLongWord(const Source; var Dest; Count: Integer); +asm + push ebx + cmp ecx, 8 + jl @@Small +@@LargeLoop: + mov ebx, [eax ] + mov [edx ], ebx + mov ebx, [eax+ 4] + mov [edx+ 4], ebx + mov ebx, [eax+ 8] + mov [edx+ 8], ebx + mov ebx, [eax+12] + mov [edx+12], ebx + mov ebx, [eax+16] + mov [edx+16], ebx + mov ebx, [eax+20] + mov [edx+20], ebx + mov ebx, [eax+24] + mov [edx+24], ebx + mov ebx, [eax+28] + mov [edx+28], ebx + add eax, 32 + add edx, 32 + sub ecx, 8 + cmp ecx, 8 + jns @@LargeLoop + nop + nop +@@Small: + test ecx, ecx + jle @@Exit +@@SmallLoop: + mov ebx, [eax] + mov [edx], ebx + add eax, 4 + add edx, 4 + dec ecx + jnz @@SmallLoop +@@Exit: + pop ebx +end; +{vb+end} + +{procedure DrawTBXIcon(Canvas: TCanvas; const R: TRect; + ImageList: TCustomImageList; ImageIndex: Integer; HiContrast: Boolean); +const + CWeirdColor = $00203241; +var + ImageWidth, ImageHeight: Integer; + I, J: Integer; + Src, Dst: PColor; + S, C: TColor; +begin + if not HiContrast then + begin + ImageList.Draw(Canvas, R.Left, R.Top, ImageIndex); + Exit; + end; + + ImageWidth := R.Right - R.Left; + ImageHeight := R.Bottom - R.Top; + with ImageList do + begin + if Width < ImageWidth then ImageWidth := Width; + if Height < ImageHeight then ImageHeight := Height; + end; + + StockBitmap1.Width := ImageWidth; + StockBitmap1.Height := ImageHeight; + StockBitmap2.Width := ImageWidth; + StockBitmap2.Height := ImageHeight; + + BitBlt(StockBitmap1.Canvas.Handle, 0, 0, ImageWidth, ImageHeight, + Canvas.Handle, R.Left, R.Top, SRCCOPY); + for J := 0 to ImageHeight - 1 do + FillLongWord(StockBitmap2.ScanLine[J]^, ImageWidth, CWeirdColor); + ImageList.Draw(StockBitmap2.Canvas, 0, 0, ImageIndex); + + for J := 0 to ImageHeight - 1 do + begin + Src := StockBitmap2.ScanLine[J]; + Dst := StockBitmap1.ScanLine[J]; + for I := 0 to ImageWidth - 1 do + begin + S := Src^ and $00FFFFFF; + if S <> CWeirdColor then + begin + C := (S and $FF0000) shr 16 * 76 + (S and $00FF00) shr 8 * 150 + + (S and $0000FF) * 29; + if C > $FD00 then S := $000000 + else if C < $6400 then S := $FFFFFF; + Dst^ := Lighten(S, 32); + end; + Inc(Src); + Inc(Dst); + end; + end; + BitBlt(Canvas.Handle, R.Left, R.Top, ImageWidth, ImageHeight, + StockBitmap1.Canvas.Handle, 0, 0, SRCCOPY); +end; + +procedure BlendTBXIcon(Canvas: TCanvas; const R: TRect; + ImageList: TCustomImageList; ImageIndex: Integer; Opacity: Byte); +const + CWeirdColor = $00203241; +var + ImageWidth, ImageHeight: Integer; + I, J: Integer; + Src, Dst: ^Cardinal; + S, C, CBRB, CBG: Cardinal; + Wt1, Wt2: Cardinal; +begin + Wt2 := Opacity; + Wt1 := 255 - Wt2; + ImageWidth := R.Right - R.Left; + ImageHeight := R.Bottom - R.Top; + with ImageList do + begin + if Width < ImageWidth then ImageWidth := Width; + if Height < ImageHeight then ImageHeight := Height; + end; + + StockBitmap1.Width := ImageWidth; + StockBitmap1.Height := ImageHeight; + StockBitmap2.Width := ImageWidth; + StockBitmap2.Height := ImageHeight; + + BitBlt(StockBitmap1.Canvas.Handle, 0, 0, ImageWidth, ImageHeight, + Canvas.Handle, R.Left, R.Top, SRCCOPY); + BitBlt(StockBitmap2.Canvas.Handle, 0, 0, ImageWidth, ImageHeight, + StockBitmap1.Canvas.Handle, 0, 0, SRCCOPY); + ImageList.Draw(StockBitmap2.Canvas, 0, 0, ImageIndex, True); + + for J := 0 to ImageHeight - 1 do + begin + Src := StockBitmap2.ScanLine[J]; + Dst := StockBitmap1.ScanLine[J]; + for I := 0 to ImageWidth - 1 do + begin + S := Src^; + if S <> Dst^ then + begin + CBRB := (Dst^ and $00FF00FF) * Wt1; + CBG := (Dst^ and $0000FF00) * Wt1; + C := ((S and $FF00FF) * Wt2 + CBRB) and $FF00FF00 + ((S and $00FF00) * Wt2 + CBG) and $00FF0000; + Dst^ := C shr 8; + end; + Inc(Src); + Inc(Dst); + end; + end; + BitBlt(Canvas.Handle, R.Left, R.Top, ImageWidth, ImageHeight, + StockBitmap1.Canvas.Handle, 0, 0, SRCCOPY); +end; + +procedure HighlightTBXIcon(Canvas: TCanvas; const R: TRect; + ImageList: TCustomImageList; ImageIndex: Integer; HighlightColor: TColor; Amount: Byte); +const + CWeirdColor = $00203241; +var + ImageWidth, ImageHeight: Integer; + I, J: Integer; + Src, Dst: PColor; + S, C: Cardinal; + CBRB, CBG: Cardinal; + W1, W2: Cardinal; +begin + ImageWidth := R.Right - R.Left; + ImageHeight := R.Bottom - R.Top; + with ImageList do + begin + if Width < ImageWidth then ImageWidth := Width; + if Height < ImageHeight then ImageHeight := Height; + end; + + StockBitmap1.Width := ImageWidth; + StockBitmap1.Height := ImageHeight; + StockBitmap2.Width := ImageWidth; + StockBitmap2.Height := ImageHeight; + + BitBlt(StockBitmap1.Canvas.Handle, 0, 0, ImageWidth, ImageHeight, + Canvas.Handle, R.Left, R.Top, SRCCOPY); + for J := 0 to ImageHeight - 1 do + FillLongWord(StockBitmap2.ScanLine[J]^, ImageWidth, CWeirdColor); + ImageList.Draw(StockBitmap2.Canvas, 0, 0, ImageIndex); + + W2 := Amount; + W1 := 255 - W2; + HighlightColor := GetBGR(ColorToRGB(HighlightColor)); + CBRB := (Cardinal(HighlightColor) and $00FF00FF) * W1; + CBG := (Cardinal(HighlightColor) and $0000FF00) * W1; + + for J := 0 to ImageHeight - 1 do + begin + Src := StockBitmap2.ScanLine[J]; + Dst := StockBitmap1.ScanLine[J]; + for I := 0 to ImageWidth - 1 do + begin + S := Src^ and $00FFFFFF; + if S <> CWeirdColor then + begin + C := ((S and $FF00FF) * W2 + CBRB) and $FF00FF00 + ((S and $00FF00) * W2 + CBG) and $00FF0000; + Dst^ := C shr 8; + end; + Inc(Src); + Inc(Dst); + end; + end; + BitBlt(Canvas.Handle, R.Left, R.Top, ImageWidth, ImageHeight, + StockBitmap1.Canvas.Handle, 0, 0, SRCCOPY); +end; + +procedure DrawTBXIconShadow(Canvas: TCanvas; const R: TRect; + ImageList: TCustomImageList; ImageIndex: Integer; Density: Integer); +const + D_DIV: array [0..2] of Cardinal = (3, 8, 20); + D_ADD: array [0..2] of Cardinal = (255 - 255 div 3, 255 - 255 div 8, 255 - 255 div 20); +var + ImageWidth, ImageHeight: Integer; + I, J: Integer; + Src, Dst: ^Cardinal; + S, C, CBRB, CBG: Cardinal; +begin + Assert(Density in [0..2]); + + ImageWidth := R.Right - R.Left; + ImageHeight := R.Bottom - R.Top; + with ImageList do + begin + if Width < ImageWidth then ImageWidth := Width; + if Height < ImageHeight then ImageHeight := Height; + end; + + StockBitmap1.Width := ImageWidth; + StockBitmap1.Height := ImageHeight; + StockBitmap2.Width := ImageWidth; + StockBitmap2.Height := ImageHeight; + + BitBlt(StockBitmap1.Canvas.Handle, 0, 0, ImageWidth, ImageHeight, + Canvas.Handle, R.Left, R.Top, SRCCOPY); + BitBlt(StockBitmap2.Canvas.Handle, 0, 0, ImageWidth, ImageHeight, + StockBitmap1.Canvas.Handle, 0, 0, SRCCOPY); + ImageList.Draw(StockBitmap2.Canvas, 0, 0, ImageIndex, True); + + for J := 0 to ImageHeight - 1 do + begin + Src := StockBitmap2.ScanLine[J]; + Dst := StockBitmap1.ScanLine[J]; + for I := 0 to ImageWidth - 1 do + begin + S := Src^; + if S <> Dst^ then + begin + CBRB := Dst^ and $00FF00FF; + CBG := Dst^ and $0000FF00; + C := ((S and $FF0000) shr 16 * 29 + (S and $00FF00) shr 8 * 150 + + (S and $0000FF) * 76) shr 8; + C := C div D_DIV[Density] + D_ADD[Density]; + Dst^ := ((CBRB * C and $FF00FF00) or (CBG * C and $00FF0000)) shr 8; + end; + Inc(Src); + Inc(Dst); + end; + end; + BitBlt(Canvas.Handle, R.Left, R.Top, ImageWidth, ImageHeight, + StockBitmap1.Canvas.Handle, 0, 0, SRCCOPY); +end; + +procedure DrawTBXIconFlatShadow(Canvas: TCanvas; const R: TRect; + ImageList: TCustomImageList; ImageIndex: Integer; ShadowColor: TColor); +const + CShadowThreshold = 180 * 256; +var + ImageWidth, ImageHeight: Integer; + I, J: Integer; + P: ^Cardinal; + C: Cardinal; + SrcDC, DstDC: HDC; +begin + ImageWidth := R.Right - R.Left; + ImageHeight := R.Bottom - R.Top; + with ImageList do + begin + if Width < ImageWidth then ImageWidth := Width; + if Height < ImageHeight then ImageHeight := Height; + end; + + StockBitmap2.Width := ImageWidth; + StockBitmap2.Height := ImageHeight; + StockBitmap2.Canvas.Brush.Color := clWhite; + StockBitmap2.Canvas.FillRect(Rect(0, 0, ImageWidth, ImageHeight)); + ImageList.Draw(StockBitmap2.Canvas, 0, 0, ImageIndex, True); + + for J := 0 to ImageHeight - 1 do + begin + P := StockBitmap2.ScanLine[J]; + for I := 0 to ImageWidth - 1 do + begin + C := P^ and $00FFFFFF; + if C <> $0 then + begin + C := (C and $FF0000) shr 16 * 76 + (C and $00FF00) shr 8 * 150 + (C and $0000FF) * 29; + if C > CShadowThreshold then P^ := $00FFFFFF + else P^ := $00000000; + end; + Inc(P); + end; + end; + + StockMonoBitmap.Width := ImageWidth; + StockMonoBitmap.Height := ImageHeight; + StockMonoBitmap.Canvas.Brush.Color := clBlack; + BitBlt(StockMonoBitmap.Canvas.Handle, 0, 0, ImageWidth, ImageHeight, + StockBitmap2.Canvas.Handle, 0, 0, SRCCOPY); + + SrcDC := StockMonoBitmap.Canvas.Handle; + Canvas.Brush.Color := ColorToRGB(ShadowColor); + DstDC := Canvas.Handle; + Windows.SetTextColor(DstDC, clWhite); + Windows.SetBkColor(DstDC, clBlack); + BitBlt(DstDC, R.Left, R.Top, ImageWidth, ImageHeight, SrcDC, 0, 0, ROP_DSPDxax); +end; + +procedure DrawTBXIconFullShadow(Canvas: TCanvas; const R: TRect; + ImageList: TCustomImageList; ImageIndex: Integer; ShadowColor: TColor); +const + CWeirdColor = $00203241; +var + ImageWidth, ImageHeight: Integer; + I, J: Integer; + P: ^Cardinal; + C: Cardinal; + SrcDC, DstDC: HDC; +begin + ImageWidth := R.Right - R.Left; + ImageHeight := R.Bottom - R.Top; + with ImageList do + begin + if Width < ImageWidth then ImageWidth := Width; + if Height < ImageHeight then ImageHeight := Height; + end; + + StockBitmap2.Width := ImageWidth; + StockBitmap2.Height := ImageHeight; + for J := 0 to ImageHeight - 1 do + FillLongWord(StockBitmap2.ScanLine[J]^, ImageWidth, CWeirdColor); + ImageList.Draw(StockBitmap2.Canvas, 0, 0, ImageIndex, True); + + for J := 0 to ImageHeight - 1 do + begin + P := StockBitmap2.ScanLine[J]; + for I := 0 to ImageWidth - 1 do + begin + C := P^ and $00FFFFFF; + if C <> CWeirdColor then P^ := $00000000 + else P^ := $00FFFFFF; + Inc(P); + end; + end; + + StockMonoBitmap.Width := ImageWidth; + StockMonoBitmap.Height := ImageHeight; + StockMonoBitmap.Canvas.Brush.Color := clBlack; + BitBlt(StockMonoBitmap.Canvas.Handle, 0, 0, ImageWidth, ImageHeight, + StockBitmap2.Canvas.Handle, 0, 0, SRCCOPY); + + SrcDC := StockMonoBitmap.Canvas.Handle; + Canvas.Brush.Color := ColorToRGB(ShadowColor); + DstDC := Canvas.Handle; + Windows.SetTextColor(DstDC, clWhite); + Windows.SetBkColor(DstDC, clBlack); + BitBlt(DstDC, R.Left, R.Top, ImageWidth, ImageHeight, SrcDC, 0, 0, ROP_DSPDxax); +end; + +procedure DrawGlyph(DC: HDC; X, Y: Integer; ImageList: TCustomImageList; ImageIndex: Integer; Color: TColor); +var + B: TBitmap; + OldTextColor, OldBkColor: Longword; + OldBrush, Brush: HBrush; +begin + if Color = clNone then Exit; + B := TBitmap.Create; + B.Monochrome := True; + ImageList.GetBitmap(ImageIndex, B); + OldTextColor := SetTextColor(DC, clBlack); + OldBkColor := SetBkColor(DC, clWhite); + if Color < 0 then Brush := GetSysColorBrush(Color and $FF) + else Brush := CreateSolidBrush(Color); + OldBrush := SelectObject(DC, Brush); + BitBlt(DC, X, Y, ImageList.Width, ImageList.Height, B.Canvas.Handle, 0, 0, ROP_DSPDxax); + SelectObject(DC, OldBrush); + if Color >= 0 then DeleteObject(Brush); + SetTextColor(DC, OldTextColor); + SetBkColor(DC, OldBkColor); + B.Free; +end; + +procedure DrawGlyph(DC: HDC; const R: TRect; ImageList: TCustomImageList; ImageIndex: Integer; Color: TColor); overload; +begin + DrawGlyph(DC, (R.Left + R.Right + 1 - ImageList.Width) div 2, (R.Top + R.Bottom + 1 - ImageList.Height) div 2, ImageList, ImageIndex, Color); +end; + +procedure DrawGlyph(DC: HDC; X, Y: Integer; const Bits; Color: TColor); overload; +var + B: TBitmap; + OldTextColor, OldBkColor: Longword; + OldBrush, Brush: HBrush; +begin + B := TBitmap.Create; + B.Handle := CreateBitmap(8, 8, 1, 1, @Bits); + OldTextColor := SetTextColor(DC, clBlack); + OldBkColor := SetBkColor(DC, clWhite); + if Color < 0 then Brush := GetSysColorBrush(Color and $FF) + else Brush := CreateSolidBrush(Color); + OldBrush := SelectObject(DC, Brush); + BitBlt(DC, X, Y, 8, 8, B.Canvas.Handle, 0, 0, ROP_DSPDxax); + SelectObject(DC, OldBrush); + if Color >= 0 then DeleteObject(Brush); + SetTextColor(DC, OldTextColor); + SetBkColor(DC, OldBkColor); + B.Free; +end; + +procedure DrawGlyph(DC: HDC; const R: TRect; Width, Height: Integer; const Bits; Color: TColor); overload; +var + B: TBitmap; + OldTextColor, OldBkColor: Longword; + OldBrush, Brush: HBrush; +begin + B := TBitmap.Create; + B.Handle := CreateBitmap(8, 8, 1, 1, @Bits); + OldTextColor := SetTextColor(DC, clBlack); + OldBkColor := SetBkColor(DC, clWhite); + if Color < 0 then Brush := GetSysColorBrush(Color and $FF) + else Brush := CreateSolidBrush(Color); + OldBrush := SelectObject(DC, Brush); + BitBlt(DC, (R.Left + R.Right + 1 - Width) div 2, (R.Top + R.Bottom + 1 - Height) div 2, Width, Height, B.Canvas.Handle, 0, 0, ROP_DSPDxax); + SelectObject(DC, OldBrush); + if Color >= 0 then DeleteObject(Brush); + SetTextColor(DC, OldTextColor); + SetBkColor(DC, OldBkColor); + B.Free; +end;} {vb-} + +{vb+} +type + TDrawEffect = (deContrast, deBlend, deHighlight, deShadow); + + TDrawParams = record + case DrawEffect: TDrawEffect of + deContrast : (); + deBlend : (Opacity: Integer); + deHighlight : (Color: TColorRef; Amount: Integer); + deShadow : (Density: Integer); + end; + +procedure IntDrawIcon(Canvas: TCanvas; const R: TRect; ImageList: TCustomImageList; + ImageIndex: Integer; const DrawParams: TDrawParams); +var + DestDC: HDC; + ImageWidth, ImageHeight: Integer; + Src, Dst: PCardinal; + Fin, SC, DC, C, W1, W2, C1, C2: Cardinal; +begin + DestDC := Canvas.Handle; + ImageWidth := Min(R.Right - R.Left, ImageList.Width); + ImageHeight := Min(R.Bottom - R.Top, ImageList.Height); + + {$IFDEF JR_D10} + StockBitmap1.SetSize(ImageWidth, ImageHeight * 2); + {$ELSE} + StockBitmap1.Width := ImageWidth; + StockBitmap1.Height := ImageHeight * 2; + {$ENDIF} + + BitBlt(StockBitmap1.Canvas.Handle, 0, 0, ImageWidth, ImageHeight, + DestDC, R.Left, R.Top, SRCCOPY); + Src := StockBitmap1.ScanLine[ImageHeight * 2 - 1]; + Dst := StockBitmap1.ScanLine[ImageHeight - 1]; + MoveLongWord(Dst^, Src^, ImageWidth * ImageHeight); + ImageList.Draw(StockBitmap1.Canvas, 0, ImageHeight, ImageIndex, True); + + Fin := Cardinal(Dst); + case DrawParams.DrawEffect of + deContrast: + while Cardinal(Src) < Fin do + begin + SC := Src^ and $00FFFFFF; + if SC <> Dst^ and $00FFFFFF then + begin + C := (SC and $00FF0000) shr 16 * 77 + (SC and $0000FF00) shr 8 * 150 + + (SC and $000000FF) * 29; + if C > $FD00 then SC := 0 else if C < $6400 then SC := $FFFFFF; + Dst^ := Lighten(SC, 32); + end; + Inc(Dst); Inc(Src); + end; + deBlend: begin + W2 := DrawParams.Opacity; + W1 := 255 - W2; + while Cardinal(Src) < Fin do + begin + SC := Src^ and $00FFFFFF; + DC := Dst^ and $00FFFFFF; + if SC <> DC then + Dst^ := (((SC and $00FF00FF) * W2 + ((DC and $00FF00FF) * W1)) and $FF00FF00 + + ((SC and $0000FF00) * W2 + ((DC and $0000FF00) * W1)) and $00FF0000) shr 8; + Inc(Dst); Inc(Src); + end; + end; + deHighlight: begin + W2 := DrawParams.Amount; + W1 := 255 - W2; + C := GetBGR(DrawParams.Color); + C1 := (C and $00FF00FF) * W1; + C2 := (C and $0000FF00) * W1; + while Cardinal(Src) < Fin do + begin + SC := Src^ and $00FFFFFF; + if SC <> Dst^ and $00FFFFFF then + Dst^ := (((SC and $00FF00FF) * W2 + C1) and $FF00FF00 + + ((SC and $0000FF00) * W2 + C2) and $00FF0000) shr 8; + Inc(Dst); Inc(Src); + end; + end; + deShadow: begin + case DrawParams.Density of + 0: begin C1 := 3; C2 := 255 - 255 div 3; end; + 1: begin C1 := 8; C2 := 255 - 255 div 8; end; + else + C1 := 20; C2 := 255 - 255 div 20; + end; + while Cardinal(Src) < Fin do + begin + SC := Src^ and $00FFFFFF; + DC := Dst^ and $00FFFFFF; + if SC <> DC then + begin + SC := (((SC and $00FF0000) shr 16 * 77 + (SC and $0000FF00) shr 8 * 150 + + (SC and $000000FF) * 29) shr 8) div C1 + C2; + Dst^ := (((DC and $00FF00FF) * SC and $FF00FF00) or + ((DC and $0000FF00) * SC and $00FF0000)) shr 8; + end; + Inc(Dst); Inc(Src); + end; + end; + end; + BitBlt(DestDC, R.Left, R.Top, ImageWidth, ImageHeight, + StockBitmap1.Canvas.Handle, 0, 0, SRCCOPY); +end; + +procedure IntDrawWithColor(DestDC: HDC; const R: TRect; Bitmap: TBitmap; + Color: TColor); +var + OldBrush: HBRUSH; + OldTextColor, OldBkColor: TColorRef; +begin + OldBrush := SelectObject(DestDC, CreateBrushEx(Color)); + OldTextColor := SetTextColor(DestDC, clBlack); + OldBkColor := SetBkColor(DestDC, clWhite); + BitBlt(DestDC, R.Left, R.Top, R.Right, R.Bottom, Bitmap.Canvas.Handle, + 0, 0, ROP_DSPDxax); + SetBkColor(DestDC, OldBkColor); + SetTextColor(DestDC, OldTextColor); + DeleteObject(SelectObject(DestDC, OldBrush)); +end; + +procedure IntDrawIconShadow(Canvas: TCanvas; const R: TRect; + ImageList: TCustomImageList; ImageIndex: Integer; ShadowColor: TColor; + FullShadow: Boolean); +const + CWeirdColor = $00203241; + CShadowThreshold = 180 * 256; +var + DestDC: HDC; + ImageWidth, ImageHeight: Integer; + Src: PCardinal; + Fin, C: Cardinal; +begin + DestDC := Canvas.Handle; + ImageWidth := Min(R.Right - R.Left, ImageList.Width); + ImageHeight := Min(R.Bottom - R.Top, ImageList.Height); + + {$IFDEF JR_D10} + StockBitmap1.SetSize(ImageWidth, ImageHeight * 2); + {$ELSE} + StockBitmap1.Width := ImageWidth; + StockBitmap1.Height := ImageHeight * 2; + {$ENDIF} + + Src := StockBitmap1.ScanLine[ImageHeight - 1]; + if FullShadow then C := CWeirdColor else C := $00FFFFFF; + FillLongWord(Src^, ImageWidth * ImageHeight, C); + ImageList.Draw(StockBitmap1.Canvas, 0, 0, ImageIndex, True); + + Fin := Cardinal(Src)+ Cardinal(ImageWidth * ImageHeight * SizeOf(Cardinal)); + if FullShadow then + while Cardinal(Src) < Fin do + begin + if Src^ and $00FFFFFF <> CWeirdColor + then Src^ := $00FFFFFF + else Src^ := $00000000; + Inc(Src); + end + else + while Cardinal(Src) < Fin do + begin + C := Src^ and $00FFFFFF; + if C <> 0 then + begin + C := (C and $00FF0000) shr 16 * 77 + (C and $0000FF00) shr 8 * 150 + + (C and $000000FF) * 29; + if C > CShadowThreshold then Src^ := $00000000 else Src^ := $00FFFFFF; + end; + Inc(Src); + end; + + {$IFDEF JR_D10} + StockMonoBitmap.SetSize(ImageWidth, ImageHeight); + {$ELSE} + StockMonoBitmap.Width := ImageWidth; + StockMonoBitmap.Height := ImageHeight; + {$ENDIF} + + StockMonoBitmap.Canvas.Brush.Color := clBlack; + BitBlt(StockMonoBitmap.Canvas.Handle, 0, 0, ImageWidth, ImageHeight, + StockBitmap1.Canvas.Handle, 0, 0, SRCCOPY); + IntDrawWithColor(DestDC, Rect(R.Left, R.Top, ImageWidth, ImageHeight), + StockMonoBitmap, ShadowColor); +end; + +procedure IntDrawGlyph(DestDC: HDC; const R: TRect; + ImageList: TCustomImageList; ImageIndex: Integer; Bits: Pointer; Color: TColor); +var + Bmp: TBitmap; +begin + if Color <> clNone then + begin + Bmp := TBitmap.Create; + try + if ImageList <> nil then + begin + Bmp.Monochrome := True; + ImageList.GetBitmap(ImageIndex, Bmp); + end + else Bmp.Handle := CreateBitmap(8, 8, 1, 1, Bits); + IntDrawWithColor(DestDC, R, Bmp, Color); + finally + Bmp.Free; + end; + end; +end; + +{------------------------------------------------------------------------------} + +procedure DrawTBXIcon(Canvas: TCanvas; const R: TRect; + ImageList: TCustomImageList; ImageIndex: Integer; HiContrast: Boolean); +var + DrawParams: TDrawParams; +begin + if HiContrast then + begin + DrawParams.DrawEffect := deContrast; + IntDrawIcon(Canvas, R, ImageList, ImageIndex, DrawParams); + end + else ImageList.Draw(Canvas, R.Left, R.Top, ImageIndex); +end; + +procedure BlendTBXIcon(Canvas: TCanvas; const R: TRect; + ImageList: TCustomImageList; ImageIndex: Integer; Opacity: Byte); +var + DrawParams: TDrawParams; +begin + DrawParams.DrawEffect := deBlend; + DrawParams.Opacity := Opacity; + IntDrawIcon(Canvas, R, ImageList, ImageIndex, DrawParams); +end; + +procedure HighlightTBXIcon(Canvas: TCanvas; const R: TRect; + ImageList: TCustomImageList; ImageIndex: Integer; HighlightColor: TColor; Amount: Byte); +var + DrawParams: TDrawParams; +begin + if HighlightColor < 0 then + HighlightColor := GetSysColor(HighlightColor and $FF); + DrawParams.DrawEffect := deHighlight; + DrawParams.Color := HighlightColor; + DrawParams.Amount := Amount; + IntDrawIcon(Canvas, R, ImageList, ImageIndex, DrawParams); +end; + +procedure DrawTBXIconShadow(Canvas: TCanvas; const R: TRect; + ImageList: TCustomImageList; ImageIndex: Integer; Density: Integer); +var + DrawParams: TDrawParams; +begin + Assert(Density in [0..2]); + DrawParams.DrawEffect := deShadow; + DrawParams.Density := Density; + IntDrawIcon(Canvas, R, ImageList, ImageIndex, DrawParams); +end; + +procedure DrawTBXIconFlatShadow(Canvas: TCanvas; const R: TRect; + ImageList: TCustomImageList; ImageIndex: Integer; ShadowColor: TColor); +begin + IntDrawIconShadow(Canvas, R, ImageList, ImageIndex, ShadowColor, False); +end; + +procedure DrawTBXIconFullShadow(Canvas: TCanvas; const R: TRect; + ImageList: TCustomImageList; ImageIndex: Integer; ShadowColor: TColor); +begin + IntDrawIconShadow(Canvas, R, ImageList, ImageIndex, ShadowColor, True); +end; + +procedure DrawGlyph(DC: HDC; X, Y: Integer; ImageList: TCustomImageList; + ImageIndex: Integer; Color: TColor); +var LR: TRect; +begin + LR.Left := X; + LR.Top := Y; + LR.Right := ImageList.Width; + LR.Bottom := ImageList.Height; + IntDrawGlyph(DC, LR, ImageList, ImageIndex, nil, Color); +end; + +procedure DrawGlyph(DC: HDC; const R: TRect; ImageList: TCustomImageList; + ImageIndex: Integer; Color: TColor); +var LR: TRect; +begin + LR.Left := (R.Left + R.Right + 1 - ImageList.Width) div 2; + LR.Top := (R.Top + R.Bottom + 1 - ImageList.Height) div 2; + LR.Right := ImageList.Width; + LR.Bottom := ImageList.Height; + IntDrawGlyph(DC, LR, ImageList, ImageIndex, nil, Color); +end; + +procedure DrawGlyph(DC: HDC; X, Y: Integer; const Bits; Color: TColor); +var LR: TRect; +begin + LR.Left := X; + LR.Top := Y; + LR.Right := 8; + LR.Bottom := 8; + IntDrawGlyph(DC, LR, nil, 0, @Bits, Color); +end; + +procedure DrawGlyph(DC: HDC; const R: TRect; Width, Height: Integer; + const Bits; Color: TColor); +var LR: TRect; +begin + LR.Left := (R.Left + R.Right + 1 - Width) div 2; + LR.Top := (R.Top + R.Bottom + 1 - Height) div 2; + LR.Right := Width; + LR.Bottom := Height; + IntDrawGlyph(DC, LR, nil, 0, @Bits, Color); +end; +{vb+end} + +type + TCustomFormAccess = class(TCustomForm); + +function GetClientSizeEx(Control: TWinControl): TPoint; +var + R: TRect; +begin + if (Control is TCustomForm) and (TCustomFormAccess(Control).FormStyle = fsMDIForm) + and not (csDesigning in Control.ComponentState) then + GetWindowRect(TCustomFormAccess(Control).ClientHandle, R) + else + R := Control.ClientRect; + Result.X := R.Right - R.Left; + Result.Y := R.Bottom - R.Top; +end; + +procedure InitializeStock; +var + NonClientMetrics: TNonClientMetrics; +begin + StockBitmap1 := TBitmap.Create; + StockBitmap1.PixelFormat := pf32bit; + {StockBitmap2 := TBitmap.Create; + StockBitmap2.PixelFormat := pf32bit;} {vb-} + StockMonoBitmap := TBitmap.Create; + StockMonoBitmap.Monochrome := True; + StockCompatibleBitmap := TBitmap.Create; + {StockCompatibleBitmap.Width := 8; + StockCompatibleBitmap.Height := 8;} {vb-} + {vb+} + {$IFDEF JR_D10} + StockCompatibleBitmap.SetSize(8, 8); + {$ELSE} + StockCompatibleBitmap.Width := 8; + StockCompatibleBitmap.Height := 8; + {$ENDIF} + {vb+end} + SmCaptionFont := TFont.Create; + NonClientMetrics.cbSize := SizeOf(NonClientMetrics); + if SystemParametersInfo(SPI_GETNONCLIENTMETRICS, 0, @NonClientMetrics, 0) then + SmCaptionFont.Handle := CreateFontIndirect(NonClientMetrics.lfSmCaptionFont); +end; + +{procedure FinalizeStock; +begin + SmCaptionFont.Free; + SmCaptionFont := nil; + StockCompatibleBitmap.Free; + StockMonoBitmap.Free; + StockBitmap2.Free; + StockBitmap1.Free; +end;} {vb-} + +{vb+} +procedure FinalizeStock; +begin + FreeAndNil(SmCaptionFont); + FreeAndNil(StockCompatibleBitmap); + FreeAndNil(StockMonoBitmap); + FreeAndNil(StockBitmap1); +end; +{vb+end} + +procedure RecreateStock; +begin + FinalizeStock; + InitializeStock; +end; + +{ TShadow } //////////////////////////////////////////////////////////////////// + +procedure TShadow.Clear(const R: TRect); +begin + FClearRect := R; +end; + +constructor TShadow.Create(const Bounds: TRect; Opacity: Byte; LoColor: Boolean; Edges: TShadowEdges); +begin + inherited Create(nil); + Hide; + ParentWindow := Application.Handle; + BoundsRect := Bounds; + Color := clBtnShadow; + FOpacity := Opacity; + FEdges := Edges; + FSaveBits := False; + + if LoColor then FStyle := ssFlat + else if (@UpdateLayeredWindow <> nil) and (@AlphaBlend <> nil) then + FStyle := ssLayered + else if @AlphaBlend <> nil then + FStyle := ssAlphaBlend + else + FStyle := ssFlat; +end; + +procedure TShadow.CreateParams(var Params: TCreateParams); +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_TOOLWINDOW; + if FSaveBits then WindowClass.Style := WindowClass.Style or CS_SAVEBITS; + end; +end; + +procedure TShadow.GradB(const R: TRect); +var + J, W, H: Integer; + V: Cardinal; + P: ^Cardinal; +begin + W := R.Right - R.Left; + H := R.Bottom - R.Top; + for J := 0 to H - 1 do + begin + P := FBuffer.ScanLine[J + R.Top]; + Inc(P, R.Left); + V := (255 - J shl 8 div H) shl 24; + FillLongword(P^, W, V); + end; +end; + +procedure TShadow.GradBL(const R: TRect); +var + I, J, W, H, CX, CY, D, DMax, A, B: Integer; + P: ^Cardinal; +begin + W := R.Right - R.Left; + H := R.Bottom - R.Top; + DMax := W; + if H > W then DMax := H; + CX := DMax - 1; + CY := H - DMax; + for J := 0 to H - 1 do + begin + P := FBuffer.ScanLine[J + R.Top]; + Inc(P, R.Left); + for I := 0 to W - 1 do + begin + A := Abs(I - CX); + B := Abs(J - CY); + D := A; + if B > A then D := B; + D := (A + B + D) * 128 div DMax; + if D < 255 then P^ := (255 - D) shl 24 + else P^ := 0; + Inc(P); + end; + end; +end; + +procedure TShadow.GradBR(const R: TRect); +var + I, J, W, H, CX, CY, D, DMax, A, B: Integer; + P: ^Cardinal; +begin + W := R.Right - R.Left; + H := R.Bottom - R.Top; + DMax := W; + if H > W then DMax := H; + CX := W - DMax; + CY := H - DMax; + for J := 0 to H - 1 do + begin + P := FBuffer.ScanLine[J + R.Top]; + Inc(P, R.Left); + for I := 0 to W - 1 do + begin + A := Abs(I - CX); + B := Abs(J - CY); + D := A; + if B > A then D := B; + D := (A + B + D) * 128 div DMax; + if D < 255 then P^ := (255 - D) shl 24 + else P^ := 0; + Inc(P); + end; + end; +end; + +procedure TShadow.GradR(const R: TRect); +var + I, J, W: Integer; + P: ^Cardinal; + ScanLine: array of Cardinal; +begin + W := R.Right - R.Left; + SetLength(ScanLine, W); + for I := 0 to W - 1 do + ScanLine[I] :=(255 - I shl 8 div W) shl 24; + + for J := R.Top to R.Bottom - 1 do + begin + P := FBuffer.ScanLine[J]; + Inc(P, R.Left); + MoveLongword(ScanLine[0], P^, W); + end; +end; + +procedure TShadow.GradTR(const R: TRect); +var + I, J, W, H, CX, CY, D, DMax, A, B: Integer; + P: ^Cardinal; +begin + W := R.Right - R.Left; + H := R.Bottom - R.Top; + DMax := W; + if H > W then DMax := H; + CX := W - DMax; + CY := DMax - 1; + for J := 0 to H - 1 do + begin + P := FBuffer.ScanLine[J + R.Top]; + Inc(P, R.Left); + for I := 0 to W - 1 do + begin + A := Abs(I - CX); + B := Abs(J - CY); + D := A; + if B > A then D := B; + D := (A + B + D) * 128 div DMax; + if D < 255 then P^ := (255 - D) shl 24 + else P^ := 0; + Inc(P); + end; + end; +end; + +procedure TShadow.Render; +var + DstDC: HDC; + SrcPos, DstPos: TPoint; + Size: TSize; + BlendFunc: TBlendFunction; +begin + if FStyle <> ssLayered then Exit; + Assert(Assigned(UpdateLayeredWindow)); + + SetWindowLong(Handle, GWL_EXSTYLE, GetWindowLong(Handle, GWL_EXSTYLE) or $00080000{WS_EX_LAYERED}); + DstDC := GetDC(0); + try + SrcPos := Point(0, 0); + with BoundsRect do + begin + DstPos := Point(Left, Top); + Size.cx := Right - Left; + Size.cy := Bottom - Top; + end; + BlendFunc.BlendOp := 0; + BlendFunc.BlendFlags := 0; + BlendFunc.SourceConstantAlpha := FOpacity; + BlendFunc.AlphaFormat := 1; + + FBuffer := TBitmap.Create; + FBuffer.PixelFormat := pf32bit; + {FBuffer.Width := Size.cx; + FBuffer.Height := Size.cy;} {vb-} + {vb+} + {$IFDEF JR_D10} + FBuffer.SetSize(Size.cx, Size.cy); + {$ELSE} + FBuffer.Width := Size.cx; + FBuffer.Height := Size.cy; + {$ENDIF} + {vb+end} + + FillBuffer; + + UpdateLayeredWindow( + Handle, + DstDC, + @DstPos, + @Size, + FBuffer.Canvas.Handle, + @SrcPos, + 0, + @BlendFunc, + $00000002{ULW_ALPHA}); + + FBuffer.Free; + finally + ReleaseDC(0, DstDC); + end; +end; + +procedure TShadow.Show(ParentHandle: HWND); +begin + SetWindowPos(Handle, ParentHandle, 0, 0, 0, 0, + SWP_NOACTIVATE or SWP_NOSENDCHANGING or SWP_NOMOVE or + SWP_NOOWNERZORDER or SWP_NOSIZE or SWP_SHOWWINDOW); +end; + +procedure TShadow.WMEraseBkgnd(var Message: TWMEraseBkgnd); +var + SrcPos, DstPos: TPoint; + Size: TSize; + BlendFunc: TBlendFunction; +begin + if FStyle = ssAlphaBlend then + begin + Assert(Assigned(AlphaBlend)); + + { Dispatch all the painting messages } + ProcessPaintMessages; + + SrcPos := Point(0, 0); + with BoundsRect do + begin + DstPos := Point(Left, Top); + Size.cx := Right - Left; + Size.cy := Bottom - Top; + end; + + FBuffer := TBitmap.Create; + FBuffer.PixelFormat := pf32bit; + {FBuffer.Width := Size.cx; + FBuffer.Height := Size.cy;} {vb-} + {vb+} + {$IFDEF JR_D10} + FBuffer.SetSize(Size.cx, Size.cy); + {$ELSE} + FBuffer.Width := Size.cx; + FBuffer.Height := Size.cy; + {$ENDIF} + {vb+end} + + FillBuffer; + + { Blend the buffer directly into the screen } + BlendFunc.BlendOp := 0; + BlendFunc.BlendFlags := 0; + BlendFunc.SourceConstantAlpha := FOpacity; + BlendFunc.AlphaFormat := 1; + AlphaBlend(Message.DC, 0, 0, Size.cx, Size.cy, + FBuffer.Canvas.Handle, 0, 0, Size.cx, Size.cy, BlendFunc); + FBuffer.Free; + + Message.Result := 1; + end + else inherited; +end; + +procedure TShadow.WMNCHitTest(var Message: TMessage); +begin + Message.Result := HTTRANSPARENT; +end; + +{ THorzShadow } + +procedure THorzShadow.FillBuffer; +var + R: TRect; + L1, L2, L3: Integer; +begin + if seTopLeft in FEdges then L1 := Height else L1 := 0; + if seBottomRight in FEdges then L3 := Height else L3 := 0; + if L1 + L3 > Width then + begin + if (L1 > 0) and (L3 > 0) then + begin + L1 := Width div 2; + L3 := L1; + end + else if L1 > 0 then L1 := Width + else if L3 > 0 then L3 := Width; + end; + L2 := Width - L1 - L3; + R := Rect(0, 0, Width, Height); + R.Right := R.Left + L1; + if L1 > 0 then GradBL(R); + R.Left := R.Right; + R.Right := R.Left + L2; + if L2 > 0 then GradB(R); + if L3 > 0 then + begin + R.Left := R.Right; + R.Right := R.Left + L3; + GradBR(R); + end; +end; + +{ TVertShadow } + +procedure TVertShadow.FillBuffer; +var + R: TRect; + L1, L2, L3: Integer; +begin + if seTopLeft in FEdges then L1 := Width else L1 := 0; + if seBottomRight in FEdges then L3 := Width else L3 := 0; + if L1 + L3 > Height then + begin + if (L1 > 0) and (L3 > 0) then + begin + L1 := Height div 2; + L3 := L1; + end + else if L1 > 0 then L1 := Height + else if L3 > 0 then L3 := Height; + end; + L2 := Height - L1 - L3; + + R := Rect(0, 0, Width, Height); + R.Bottom := R.Top + L1; + if L1 > 0 then GradTR(R); + R.Top := R.Bottom; + R.Bottom := R.Top + L2; + if L2 > 0 then GradR(R); + if L3 > 0 then + begin + R.Top := R.Bottom; + R.Bottom := R.Top + L3; + GradBR(R); + end; +end; + +{ TShadows } + +constructor TShadows.Create(R1, R2: TRect; Size: Integer; Opacity: Byte; LoColor: Boolean); +var + R: TRect; + R1Valid, R2Valid: Boolean; +begin + if LoColor or + ((@UpdateLayeredWindow = nil) and (@AlphaBlend = nil)) then + begin + Size := Size div 2; + end; + + R1Valid := not IsRectEmpty(R1); + R2Valid := not IsRectEmpty(R2); + if not (R1Valid or R2Valid) then Exit; + + if R1Valid xor R2Valid then + begin + { A simple square shadow } + if R1Valid then R := R1 else R:= R2; + with R do + begin + V1 := TVertShadow.Create(Rect(Right, Top + Size, Right + Size, Bottom), Opacity, LoColor, [seTopLeft]); + H1 := THorzShadow.Create(Rect(Left + Size, Bottom, Right + Size, Bottom + Size), Opacity, LoColor, [seTopLeft, seBottomRight]) + end; + end + else + begin + + if (R1.Bottom <= R2.Top + 2) or (R1.Top >= R2.Bottom - 2) then + begin + if R1.Top > R2.Top then + begin + R := R2; + R2 := R1; + R1 := R; + end; + if R1.Left + Size < R2.Left then + H1 := THorzShadow.Create(Rect(R1.Left + Size, R1.Bottom, R2.Left, R1.Bottom + Size), Opacity, LoColor, [seTopLeft]); + H2 := THorzShadow.Create(Rect(R2.Left + Size, R2.Bottom, R2.Right + Size, R2.Bottom + Size), Opacity, LoColor, [seTopLeft, seBottomRight]); + V1 := TVertShadow.Create(Rect(R1.Right, R1.Top + Size, R1.Right + Size, R1.Bottom), Opacity, LoColor, [seTopLeft]); + if R1.Right > R2.Right then + H3 := THorzShadow.Create(Rect(R2.Right, R1.Bottom, R1.Right + Size, R1.Bottom + Size), Opacity, LoColor, [seTopLeft, seBottomRight]); + if R1.Right + Size < R2.Right then + V2 := TVertShadow.Create(Rect(R2.Right, R2.Top + Size, R2.Right + Size, R2.Bottom), Opacity, LoColor, [seTopLeft]) + else + V2 := TVertShadow.Create(Rect(R2.Right, R2.Top + 1, R2.Right + Size, R2.Bottom), Opacity, LoColor, []); + end + else if (R1.Right <= R2.Left + 2) or (R1.Left >= R2.Right - 2) then + begin + if R1.Left > R2.Left then + begin + R := R2; + R2 := R1; + R1 := R; + end; + if R1.Top + Size < R2.Top then + V1 := TVertShadow.Create(Rect(R1.Right, R1.Top + Size, R1.Right + Size, R2.Top), Opacity, LoColor, [seTopLeft]); + V2 := TVertShadow.Create(Rect(R2.Right, R2.Top + Size, R2.Right + Size, R2.Bottom + Size), Opacity, LoColor, [seTopLeft, seBottomRight]); + H1 := THorzShadow.Create(Rect(R1.Left + Size, R1.Bottom, R1.Right, R1.Bottom + Size), Opacity, LoColor, [seTopLeft]); + if R1.Bottom > R2.Bottom then + V3 := TVertShadow.Create(Rect(R1.Right, R2.Bottom, R1.Right + Size, R1.Bottom + Size), Opacity, LoColor, [seTopLeft, seBottomRight]); + if R1.Bottom + Size < R2.Bottom then + H2 := THorzShadow.Create(Rect(R2.Left + Size, R2.Bottom, R2.Right, R2.Bottom + Size), Opacity, LoColor, [seTopLeft]) + else + H2 := THorzShadow.Create(Rect(R2.Left, R2.Bottom, R2.Right, R2.Bottom + Size), Opacity, LoColor, []); + end; + end; + + if V1 <> nil then V1.Render; + if H1 <> nil then H1.Render; + if V2 <> nil then V2.Render; + if H2 <> nil then H2.Render; + if V3 <> nil then V3.Render; + if H3 <> nil then H3.Render; + + SetSaveBits(True); +end; + +destructor TShadows.Destroy; +begin + H3.Free; + V3.Free; + H2.Free; + V2.Free; + H1.Free; + V1.Free; + inherited; +end; + +procedure TShadows.SetSaveBits(Value: Boolean); +begin + FSaveBits := Value; + if V1 <> nil then V1.FSaveBits := Value; + if H1 <> nil then H1.FSaveBits := Value; + if V2 <> nil then V2.FSaveBits := Value; + if H2 <> nil then H2.FSaveBits := Value; + if V3 <> nil then V3.FSaveBits := Value; + if H3 <> nil then H3.FSaveBits := Value; +end; + +procedure TShadows.Show(ParentHandle: HWND); +begin + if V1 <> nil then V1.Show(ParentHandle); + if H1 <> nil then H1.Show(ParentHandle); + if V2 <> nil then V2.Show(ParentHandle); + if H2 <> nil then H2.Show(ParentHandle); + if V3 <> nil then V3.Show(ParentHandle); + if H3 <> nil then H3.Show(ParentHandle); +end; + +{ Gradients } ////////////////////////////////////////////////////////////////// + +const + GRADIENT_CACHE_SIZE = 16; + +type + PRGBQuad = ^TRGBQuad; + TRGBQuad = Integer; + PRGBQuadArray = ^TRGBQuadArray; + TRGBQuadArray = array [0..0] of TRGBQuad; + + +var + {GradientCache: array [0..GRADIENT_CACHE_SIZE] of array of TRGBQuad;} {vb-} + GradientCache: array of array of TRGBQuad; {vb+} + NextCacheIndex: Integer = 0; + +function FindGradient(Size: Integer; CL, CR: TRGBQuad): Integer; +var Len: Integer; {vb+} +begin + Assert(Size > 0); + {Result := GRADIENT_CACHE_SIZE - 1;} {vb-} + Result := High(GradientCache); {vb+} + while Result >= 0 do + begin + {if (Length(GradientCache[Result]) = Size) and + (GradientCache[Result][0] = CL) and + (GradientCache[Result][Length(GradientCache[Result]) - 1] = CR) then Exit;} {vb-} + {vb+} + Len := Length(GradientCache[Result]); + if (Len = Size) and + (GradientCache[Result][0] = CL) and + (GradientCache[Result][Len- 1] = CR) then Exit; + Dec(Result); + {vb+end} + end; +end; + +function MakeGradient(Size: Integer; CL, CR: TRGBQuad): Integer; +var + R1, G1, B1: Integer; + R2, G2, B2: Integer; + R, G, B: Integer; + I: Integer; + Bias: Integer; +begin + Assert(Size > 0); + Result := NextCacheIndex; + if Result > High(GradientCache) then + SetLength(GradientCache, Result+ 1); {vb+} + Inc(NextCacheIndex); + if NextCacheIndex >= GRADIENT_CACHE_SIZE then NextCacheIndex := 0; + R1 := CL and $FF; + G1 := CL shr 8 and $FF; + B1 := CL shr 16 and $FF; + R2 := CR and $FF - R1; + G2 := CR shr 8 and $FF - G1; + B2 := CR shr 16 and $FF - B1; + {vb+} + if Length(GradientCache[Result]) < Size then + GradientCache[Result] := nil; + {vb+end} + SetLength(GradientCache[Result], Size); + Dec(Size); + Bias := Size div 2; + if Size > 0 then + for I := 0 to Size do + begin + R := R1 + (R2 * I + Bias) div Size; + G := G1 + (G2 * I + Bias) div Size; + B := B1 + (B2 * I + Bias) div Size; + GradientCache[Result][I] := R + G shl 8 + B shl 16; + end + else + begin + R := R1 + R2 div 2; + G := G1 + G2 div 2; + B := B1 + B2 div 2; + GradientCache[Result][0] := R + G shl 8 + B shl 16; + end; +end; + +function GetGradient(Size: Integer; CL, CR: TRGBQuad): Integer; +begin + Result := FindGradient(Size, CL, CR); + if Result < 0 then Result := MakeGradient(Size, CL, CR); +end; + +procedure FinalizeGradientFill; {vb+} +begin + GradientCache := nil; +end; + +{ GradFill function } + +procedure GradFill(DC: HDC; ARect: TRect; ClrTopLeft, ClrBottomRight: TColor; Kind: TGradientKind); +const + GRAD_MODE: array [TGradientKind] of DWORD = (GRADIENT_FILL_RECT_H, GRADIENT_FILL_RECT_V); + W: array [TGradientKind] of Integer = (2, 1); + H: array [TGradientKind] of Integer = (1, 2); +type + TriVertex = packed record + X, Y: Longint; + R, G, B, A: Word; + end; +var + V: array [0..1] of TriVertex; + GR: GRADIENT_RECT; + Size, I, Start, Finish: Integer; + GradIndex: Integer; + R, CR: TRect; + Brush: HBRUSH; + RGBQuadArray: PRGBQuadArray; {vb+} +begin + if not RectVisible(DC, ARect) then Exit; + {ClrTopLeft := ColorToRGB(ClrTopLeft); + ClrBottomRight := ColorToRGB(ClrBottomRight);} {vb-} + {vb+} + if ClrTopLeft < 0 then + ClrTopLeft := GetSysColor(ClrTopLeft and $FF); + if ClrBottomRight < 0 then + ClrBottomRight := GetSysColor(ClrBottomRight and $FF); + + if ClrTopLeft = ClrBottomRight then + begin + FillRectEx(DC, ARect, ClrTopLeft); + Exit; + end; + {vb+end} + + if @GradientFill <> nil then + begin + { Use msimg32.dll } + with V[0] do + begin + X := ARect.Left; + Y := ARect.Top; + R := ClrTopLeft shl 8 and $FF00; + G := ClrTopLeft and $FF00; + B := ClrTopLeft shr 8 and $FF00; + A := 0; + end; + with V[1] do + begin + X := ARect.Right; + Y := ARect.Bottom; + R := ClrBottomRight shl 8 and $FF00; + G := ClrBottomRight and $FF00; + B := ClrBottomRight shr 8 and $FF00; + A := 0; + end; + GR.UpperLeft := 0; GR.LowerRight := 1; + GradientFill(DC, @V, 2, @GR, 1, GRAD_MODE[Kind]); + end + else + begin + { Have to do it manually if msimg32.dll is not available } + GetClipBox(DC, CR); + + if Kind = gkHorz then + begin + Size := ARect.Right - ARect.Left; + if Size <= 0 then Exit; + Start := 0; Finish := Size - 1; + if CR.Left > ARect.Left then Inc(Start, CR.Left - ARect.Left); + if CR.Right < ARect.Right then Dec(Finish, ARect.Right - CR.Right); + R := ARect; Inc(R.Left, Start); R.Right := R.Left + 1; + end + else + begin + Size := ARect.Bottom - ARect.Top; + if Size <= 0 then Exit; + Start := 0; Finish := Size - 1; + if CR.Top > ARect.Top then Inc(Start, CR.Top - ARect.Top); + if CR.Bottom < ARect.Bottom then Dec(Finish, ARect.Bottom - CR.Bottom); + R := ARect; Inc(R.Top, Start); R.Bottom := R.Top + 1; + end; + GradIndex := GetGradient(Size, ClrTopLeft, ClrBottomRight); + RGBQuadArray := @GradientCache[GradIndex][0]; {vb+} + for I := Start to Finish do + begin + {Brush := CreateSolidBrush(GradientCache[GradIndex][I]);} {vb-} + Brush := CreateSolidBrush(RGBQuadArray[I]); {vb+} + Windows.FillRect(DC, R, Brush); + OffsetRect(R, Integer(Kind = gkHorz), Integer(Kind = gkVert)); + DeleteObject(Brush); + end; + end; +end; + +{ Brushed Fill } /////////////////////////////////////////////////////////////// + +{ Templates } + +const + NUM_TEMPLATES = 8; + MIN_TEMPLATE_SIZE = 100; + MAX_TEMPLATE_SIZE = 200; + NUM_RANDTHREADS = 1024; {vb+} + +var + {ThreadTemplates: array [0..NUM_TEMPLATES - 1] of array of Integer; + RandThreadIndex: array [0..1023] of Integer; + RandThreadPositions: array [0..1023] of Integer;} {vb-} + ThreadTemplates: array of array of Integer; + RandThreadIndex: array of Integer; + RandThreadPositions: array of Integer; + +procedure InitializeBrushedFill; +const + Pi = 3.14159265358987; +var + TemplateIndex, Size, I, V, V1, V2: Integer; + T, R12, R13, R14, R21, R22, R23, R24: Single; +begin + {vb+} + SetLength(ThreadTemplates, NUM_TEMPLATES); + SetLength(RandThreadIndex, NUM_RANDTHREADS); + SetLength(RandThreadPositions, NUM_RANDTHREADS); + {vb+end} + { Make thread templates } + for TemplateIndex := 0 to NUM_TEMPLATES - 1 do + begin + Size := (MIN_TEMPLATE_SIZE + Random(MAX_TEMPLATE_SIZE - MIN_TEMPLATE_SIZE + 1)) div 2; + SetLength(ThreadTemplates[TemplateIndex], Size * 2); + R12 := Random * 2 * Pi; + R13 := Random * 2 * Pi; + R14 := Random * 2 * Pi; + R21 := Random * 2 * Pi; + R22 := Random * 2 * Pi; + R23 := Random * 2 * Pi; + R24 := Random * 2 * Pi; + for I := 0 to Size - 1 do + begin + T := 2 * Pi * I / Size; + V1 := Round(150 * Sin(T) + 100 * Sin(2 * T + R12) + 50 * Sin(3 * T + R13) + 20 * Sin(4 * T + R14)); + if V1 > 255 then V1 := 255; + if V1 < -255 then V1 := -255; + + V2 := Round(150 * Sin(T + R21) + 100 * Sin(2 * T + R22) + 50 * Sin(3 * T + R23) + 20 * Sin(4 * T + R24)); + if V2 > 255 then V2 := 255; + if V2 < -255 then V2 := -255; + + if Abs(V2 - V1) > 300 then + begin + V := (V1 + V2) div 2; + V1 := V - 150; + V2 := V + 150; + end; + + ThreadTemplates[TemplateIndex][I * 2] := Min(V1, V2); + ThreadTemplates[TemplateIndex][I * 2 + 1] := Max(V1, V2); + end; + end; + + { Initialize Rand arrays } + {for I := 0 to 1023 do} {vb-} + for I := 0 to NUM_RANDTHREADS- 1 do {vb+} + begin + RandThreadIndex[I] := Random(NUM_TEMPLATES); + V1 := Random(Length(ThreadTemplates[RandThreadIndex[I]])) and not $1; + if Odd(I) then Inc(V1); + RandThreadPositions[I] := V1; + end; +end; + +{ Cache } + +const + THREAD_CACHE_SIZE = 16; + +type + TThreadCacheItem = record + BaseColor: TColorRef; + Roughness: Integer; + Bitmaps: array [0..NUM_TEMPLATES - 1] of HBITMAP; + end; + +var + {ThreadCache: array [0..THREAD_CACHE_SIZE] of TThreadCacheItem;} {vb-} + ThreadCache: array of TThreadCacheItem; {vb+} + NextCacheEntry: Integer = 0; + +procedure ClearCacheItem(var CacheItem: TThreadCacheItem); +var + I: Integer; +begin + {for I := NUM_TEMPLATES - 1 downto 0 do + begin + CacheItem.BaseColor := $FFFFFFFF; + CacheItem.Roughness := -1; + if CacheItem.Bitmaps[I] <> 0 then DeleteObject(CacheItem.Bitmaps[I]); + CacheItem.Bitmaps[I] := 0; + end;} {vb-} + {vb+} + with CacheItem do + begin + BaseColor := $FFFFFFFF; + Roughness := -1; + for I := NUM_TEMPLATES- 1 downto 0 do + if Bitmaps[I] <> 0 then + begin + DeleteObject(Bitmaps[I]); + Bitmaps[I] := 0; + end; + end; + {vb+end} +end; + +procedure ResetBrushedFillCache; +var + I: Integer; +begin + { Should be called each time the screen parameters change } + {for I := THREAD_CACHE_SIZE - 1 downto 0 do ClearCacheItem(ThreadCache[I]);} {vb-} + for I := High(ThreadCache) downto 0 do ClearCacheItem(ThreadCache[I]); {vb+} +end; + +procedure FinalizeBrushedFill; +begin + ResetBrushedFillCache; + {vb+} + ThreadCache := nil; + RandThreadPositions := nil; + RandThreadIndex := nil; + ThreadTemplates := nil; + {vb+end} +end; + +procedure MakeCacheItem(var CacheItem: TThreadCacheItem; Color: TColorRef; Roughness: Integer); +var + TemplateIndex, Size, I, V: Integer; + CR, CG, CB: Integer; + R, G, B: Integer; + ScreenDC: HDC; + BMI: TBitmapInfo; + Bits: PRGBQuadArray; + DIBSection: HBITMAP; + DIBDC, CacheDC: HDC; +begin + ScreenDC := GetDC(0); + FillChar(BMI, SizeOf(TBitmapInfo), 0); + with BMI.bmiHeader do + begin + biSize := SizeOf(TBitmapInfoHeader); + biPlanes := 1; + biCompression := BI_RGB; + biWidth := MAX_TEMPLATE_SIZE; + biHeight := -1; + biBitCount := 32; + end; + DIBSection := CreateDIBSection(0, BMI, DIB_RGB_COLORS, Pointer(Bits), 0, 0); + DIBDC := CreateCompatibleDC(0); + SelectObject(DIBDC, DIBSection); + CacheDC := CreateCompatibleDC(0); + + CR := Color shl 8 and $FF00; + CG := Color and $FF00; + CB := Color shr 8 and $FF00; + + try + for TemplateIndex := 0 to NUM_TEMPLATES - 1 do + begin + CacheItem.BaseColor := Color; + CacheItem.Roughness := Roughness; + Size := Length(ThreadTemplates[TemplateIndex]); + + if CacheItem.Bitmaps[TemplateIndex] = 0 then + CacheItem.Bitmaps[TemplateIndex] := CreateCompatibleBitmap(ScreenDC, Size, 1); + SelectObject(CacheDC, CacheItem.Bitmaps[TemplateIndex]); + + for I := 0 to Size - 1 do + begin + V := ThreadTemplates[TemplateIndex][I]; + R := CR + V * Roughness; + G := CG + V * Roughness; + B := CB + V * Roughness; + if R < 0 then R := 0; + if G < 0 then G := 0; + if B < 0 then B := 0; + if R > $EF00 then R := $EF00; + if G > $EF00 then G := $EF00; + if B > $EF00 then B := $EF00; + Bits^[I] := (R and $FF00 + (G and $FF00) shl 8 + (B and $FF00) shl 16) shr 8; + end; + + BitBlt(CacheDC, 0, 0, Size, 1, DIBDC, 0, 0, SRCCOPY); + end; + + finally + DeleteDC(CacheDC); + DeleteDC(DIBDC); + DeleteObject(DIBSection); + ReleaseDC(0, ScreenDC); + end; +end; + +function FindCacheItem(Color: TColorRef; Roughness: Integer): Integer; +begin + {Result := THREAD_CACHE_SIZE - 1;} {vb-} + Result := High(ThreadCache); {vb+} + while Result >= 0 do + if (ThreadCache[Result].BaseColor = Color) and (ThreadCache[Result].Roughness = Roughness) then Exit + else Dec(Result); +end; + +function GetCacheItem(Color: TColorRef; Roughness: Integer): Integer; +begin + Result := FindCacheItem(Color, Roughness); + if Result >= 0 then Exit + else + begin + Result := NextCacheEntry; + {vb+} + if Result > High(ThreadCache) then + begin + SetLength(ThreadCache, Result+ 1); + ClearCacheItem(ThreadCache[Result]); + end; + {vb+end} + MakeCacheItem(ThreadCache[Result], Color, Roughness); + NextCacheEntry := (NextCacheEntry + 1) mod THREAD_CACHE_SIZE; + end; +end; + +procedure BrushedFill(DC: HDC; Origin: PPoint; ARect: TRect; Color: TColor; Roughness: Integer); +const + ZeroOrigin: TPoint = (X: 0; Y: 0); +var + CR: TColorRef; + X, Y: Integer; + CacheIndex: Integer; + TemplateIndex: Integer; + CacheDC: HDC; + Size: Integer; + BoxR: TRect; +begin + if (Color = clNone) or not RectVisible(DC, ARect) then Exit; + CR := GetBGR(ColorToRGB(Color)); + if Origin = nil then Origin := @ZeroOrigin; + if ThreadTemplates = nil then InitializeBrushedFill; {vb+} + CacheIndex := GetCacheItem(CR, Roughness); + GetClipBox(DC, BoxR); + IntersectRect(ARect, ARect, BoxR); + SaveDC(DC); + with ARect do IntersectClipRect(DC, Left, Top, Right, Bottom); + + CacheDC := CreateCompatibleDC(0); + for Y := ARect.Top to ARect.Bottom - 1 do + begin + {TemplateIndex := RandThreadIndex[(65536 + Y - Origin.Y) mod 1024];} {vb-} + TemplateIndex := RandThreadIndex[(65536 + Y - Origin.Y) mod NUM_RANDTHREADS]; {vb+} + Size := Length(ThreadTemplates[TemplateIndex]); + {X := -RandThreadPositions[(65536 + Y - Origin.Y) mod 1024] + Origin.X;} {vb-} + X := -RandThreadPositions[(65536 + Y - Origin.Y) mod NUM_RANDTHREADS] + Origin.X; {vb+} + SelectObject(CacheDC, ThreadCache[CacheIndex].Bitmaps[TemplateIndex]); + while X < ARect.Right do + begin + if X + Size >= ARect.Left then BitBlt(DC, X, Y, Size, 1, CacheDC, 0, 0, SRCCOPY); + Inc(X, Size); + end; + end; + DeleteDC(CacheDC); + + RestoreDC(DC, -1); +end; + +{var + hUser, hMSImg: HModule;} {vb-} + +{vb+} +var + hMSImg: HModule; + +procedure InitializeProcs; +begin + UpdateLayeredWindow := GetProcAddress(GetModuleHandle(user32), + 'UpdateLayeredWindow'); + hMSImg := {$IFDEF JR_D5}SafeLoadLibrary{$ELSE}LoadLibrary{$ENDIF}(msimg32); + if hMSImg <> 0 then + begin + AlphaBlend := GetProcAddress(hMSImg, 'AlphaBlend'); + { vb+ Note: Windows9x/ME has a bug in GradientFill function: + not fill window nonclient area. So we will use GradientFill + only in the WindowsNT } + if Win32Platform = VER_PLATFORM_WIN32_NT then + GradientFill := GetProcAddress(hMSImg, 'GradientFill'); + end; +end; +{vb+end} + +initialization + {hUser := LoadLibrary('user32.dll'); + hMSImg := LoadLibrary('msimg32.dll'); + @UpdateLayeredWindow := GetProcAddress(hUser, 'UpdateLayeredWindow'); + @AlphaBlend := GetProcAddress(hMSImg, 'AlphaBlend'); + @GradientFill := GetProcAddress(hMSImg, 'GradientFill'); + InitializeStock; + InitializeBrushedFill; + ResetBrushedFillCache;} {vb-} + {vb+} + InitializeProcs; + InitializeStock; + {vb+end} +finalization + FinalizeGradientFill; {vb+} + FinalizeBrushedFill; + FinalizeStock; + {FreeLibrary(hMSImg); + FreeLibrary(hUser);} {vb-} + if hMSImg <> 0 then FreeLibrary(hMSImg); {vb+} +end. diff --git a/WebCopy.avi b/WebCopy.avi new file mode 100644 index 0000000000000000000000000000000000000000..8fbc347e72e8e6cdd3f86722c633b7d9490817a2 GIT binary patch literal 9918 zcmeI2O>A6O701t;%tvONWb8BvNowIBO(1P2^`NO#B&4b=sQMs7430^ptPlZpq`Y?g z(Riw1(FH;RDUtjZ4U%oC61%s8EXHD{A+SJV&0-8QNo_hUDiQ+0qT9>w-1nY69oMk~ z*^$ir-+Sl2d+)g)=bZaL<9x?`<(1|aMZWf3_sj)%`qCegBClPWyZ*f!)z`ivBJcjh z5&0#B{2K*N*(VW7!WBZwYet3>PRbQ;vk%M+DFMoTxo-K&P8SVivDi=g%KmZI77a0V=0P&DP z01OZx83e!pX(EFF7$7}l5C8*I$qWd9i4@MDGyq1G7YgV{1_p?W3<6+)c*r0C28fRg z0$_kNkwE|qkRCD!fB`zG84v&yO>l-u2EgcK3oiPRfdS$og8&#H9x@1k0pcTr02m-m zWDo!Yq=yUwV1O>-3!R84;ci&0P&GQ01S{OG6;YH(nAITFn|mCk%5UE zVg}6t(2o=h`jLSF;v$0p7$6=p2!H|NBZB}KAWdWt00X3l3<6*PO3{xD4EV;(x4t<# zf?q!QxBCj%wbGT-@9xze&zn%oW4RJcHI@$kvn2$yq3>f+_oS2mw-w+daOd1lz znGe; zPRScLs-@Dk?_Ve9HvLq8uj`5a`!Y(c6Mad_=H}*~jT6a^IGbH@wq!XVo8apQaM$V&Rr-Ki`-N4o4(^ZzSh(9SL+?_%Q4B)O*Wm*rO($&Q^h20gdQtl%~n+N zP+v|^Gn>k3%~Y{gd!bY+(u}b?)vzvuw7rh>C0|G}$Q)JEx%0K!f+TB_Dk2u7z18>n zcKwsOBvejk7)AX`{Zjo>tyavXwYD41t?MRj@43F5KFgT3^O5vOZK1xhT3@JNSvarV zw{$J+95v2mqvbCY?-_1QYu0UD(9#Zo;#J-;}AwK4zVbQvv~7qmsR5Ap7* zjQy7Vj_rH<&VuNg+x1|m>Gb*fN}Qr`5aJ z?qK+sdVFOHaX(4zCS6}yd8<@fDKFpNSYBSd+9*#RSt*{SpV3OEy=3OPYfHxOyx!`{ z;Q>Fedr$l90z2~H{_0eDV`JlXqtPf|WHv2YyWMrOWIAm!_?F*k+t%@FSW9zQi>Zax z_a2m2Rxg$BF^S9b&u5O*ur$e6+nqUctF?}9or4^aZQsHRP73>5Q`Hadmsh7=Y%HRA za;k_`6D>L|{94zb*_#cQft3iqO@7}-b*6XD*n^C^_Y_UKe$K8(l zcv`&yACA6~6>QqJw_cmcr7m20Yh`ss7V728^JSLqf{i$puC~DM)c^I%Lyli+nr-Pc zC5%@#LZlPt>h(A4Z%X~@#`4DG#dL`X!49rzTh(sA+Eq5y>sy$O&zQ@ijm*ng{)!gpd=&0)# z1x%u3x7{Uxb|Tv$(jKC1n;pNm+?K-cXjgUJO4Y5n+_{BcSD&$9U`I?`KkF2dk|_L* z9S}#)oM)AZB|eu)n5Q`@c;fWf^=?~W3Di54IcOyDlpNd)`^nkTFJw+@Kek?2^3@$B zGdoJ&*irJ+9VNfmQF3>nr9zTXaK`dkG_8ZF+=IX@6<%tQEKjH`R#-eF#znhqVpxAfs^Uj5@ zq$cEmS=1s)yf2O?iG<_0lE{ct3CrY2g&oIV)C8J-OA?3izIL}AwUNBrYx;O+$2Uvu zoB9i2A}>x=TW@mowfK>aoWM7oxh}s(T0N5Y*1EUMtcH|Z!~@!d11_OH zVO>NYDw_FNi&Y~Ue)>fJz>@eE{-Jm5>ND?u&n0|VmzVSu(J210*K9Dc*BYeSJr>V)6P(qo z?DGLOme!PJyRz1jwI-2P`(ykQ)vgVudL)F=+?r5qZ92`co~uh0lFM+>Fa!N`h@PFE zI+(6j!j%+TPh3p8*bpWWg-onMN5K4tEJFVt_GsMPk^5Ub9A0jQcsX{ogO~48_Jo%Y z^Kv|fNE%1-F?i8_8M+**&@zts+H!wfT@JZR#>8hssBwR+T@HC@j8745xnKS+NA$ILgkR+=`bj}A;?v3g?y-9wu-BQTYq)D3u*W&3ZFlAY z2L{izW1l|Pl<8D=%>({n8T3C7$>G@WZ6+L_tH-Op@+|$mX5bpVg|{Zg#ZjuMjQTJU zLV1pYzy7D-L@I@>CuF?TR&o>Z0NCx}*_*zZ{T1--;y_X*@mE;8 za&%)}_cFdDX{4QNZ;XV4I;H#_LZ2Ah(jzDJ#8B$4@swD4$IRYYdgsp49pz_^Wl__S^8fY=650YuU@Nvxdh|a%vk@I zl_n(mtE|e}ah+$)m}5CW)_gdYe~YYnZ!G_DNd9n0{$xl#NCGz4{`8Ps9Fku`*4#JN z_v0*+AJBhmNd7spW;AjAclci!aebZdyU5CPkY+}z#O|#i3y-jy1{O%HS$M!sIz!!}A|Vhgy1o3)eeZc(PbV{h z>`3hYd+*$L?>+b9oOA!j6A_VvB$JkC zph-c}`=iF+b-(eACT(AQ#XWh}J%8a3agkTA%w7HdwaTm7-#b5bM1Dmf|Hi>%_DO_N z`BPFP&co@jZ1|>q{g`I+3v*Y&t1s~KTII^TH+S`i!}YEpe7r9x(Z03M@h=V6*m|a) zADyO8)fee?WWOED3*XtQXA45H%-shpn@CQi418dKE>s!#!04iR$iN2%NCO%8zyN6? z10NV5J!Iem15`;F_=7#lNg1U+FseL<418dKxX8c<28f3Yd|-eykbw^jkR~$lfdSG( z20k!ACshVMFyREtOwtENC!2H8j|>bD7a91#0P&E44-Ak7GVp-`(nJP6FhF|9zy}8C zB9?&q=^iCV1V?Hfe#GOO)CQ* zm~aEjY@!d0Zf355eq>;PxX8c<28f3Yd|-eykbw^jkR~$lfdSG(20k!=O6W%hCN!8b zM&kpc#*=HJ9~l@RE;8_e0pcM89~dAFWZ(k>q=^iCV1V?Hfe#Fz5dFx&ga%s1NPS?` zSaUt}BLf4(MFu`FKs;pN0|TUi418dKG?9T143Hi&@PPqb(2opE=n!Qz`#?XEGw4SK z28fFcd|-fh$iN2%NCO%8zyN6?10NV5J!Iem15k>7WMIHI%isRi_!xfq=-dpK_bEf3{NFx6N({LhvU&_=!wMct!L{@+%BlaRyd0k1CSmzv+mb+jwjGJ;RJ z-ha2eN+}>6ockQT_NqL?%LSr32Nl#Kf-3{lSo`SvXayc<1u$ty5NAGAgOeTtqF0{p zSJH!%Kn-9jTUSb&wmi7@di0EuKG0ycR}Q@Z=7|eLUuF4_X!^$;qQbxP4iJK}71#Tm%5Pd3Tr``qD_VVfPxe&0VSN&0=P z@8q0QanWniz1^3SrOL?1^@5KrcH`P=qAwFUNu(3$cs`ww+{;hC?3UzRTDy()R z4X&Mbca2ZG!>8+7o!Pz|&Ph6%NF=%p}iL3p4pRZG;|6LCscJ^FUvYQ8S&$Xw5{v zT79-q$kU9mJC&d=gS5Sl^(C82Fvtv5lbJKs>Vm|plE@?Gq&?_+eXIU)T@orMQ;ec^ zsdk}up<2ynl3Lph=GJxNw)ae59zVsHwezv$SaqScvRYfHU0OJ!-M4ft>>M@a*Ewo^ z396@(nN)%5@2;-Ys%J8(WJ;(%vLz7w)aB-d&hUWyjFR41P11 zLA2hqnapJpNmg51oT;teyGQ?nxu>VIjO(*?umdzmX7hzw_Wba>^4Tz75BG&--fx^i&H5A5F4KE1$> z+`GFvQ{33txLL2)i|3e4i`H&;-7J|-n+(3y=(KI?Xf>>*IjqIZ!s@&CiYu!Zig%dA z#rbDahpJebWGn5?oVn3jN4L&F4#}2p;RVNq{jI9%dv}YgGtbo*(L6nq$Et}Iofdwr zYtZb?2Ft)o1m7mEr1RH4bOZAUr7r# zZQEO~O=S{iFTA<3x*`j;;>GzQOLx{roKja?;CJf(`sE?RFE!1!bea;xD;pt_vD3BM z8?`s2c6noYWBOdOK!jii*R-u_w_oilooIH2g`kUy9f6HRPQH4nCUUcWbK}m&bfHEh zl9OID7;}a`BK6#ZA*F-)6Ys`zk}p)B%rDW*q|cWrdk^$PBc7qi4=j%EV%y zOU29+oD@89dhB?&EwBXYok;CB5_?ScZwCEjZ0Q$Lk83}+UQqJYZ6)PxC9iKQ`PsIT zUv4Y8Jyi01OvkiNNo-S}{>?e~S@#c;vVUSc_~`o&MD~xLm^eOhV*ErTpO`!`d3^Hd zWF$`>L7*U#v2^>5)VJPEO+irXyZ3qL!dDVgvd=7Pk;L8? z$CFshaa@U|#3==3a;U_P<1cCg%|=UN2l2jkw;i^TtlMig@Xk)dEVZxeFMzSEI2CQZ z$=wXhUv_8`8Cq&k*v4YyE)`;=;MYTm57btu?`87#ycnSodV5ZC|QaY9;HJ>1Ibzj(2i^1YdwvdKLGaQp%HkuGh7_Y>G@`3c(Sgkv#ekV0%1k9~-QMo)b5^>$9fO zWveB2NSq#a#aq@XTk7=8oN0B;jo>th$}6p&XO`Am4KvqiuwS-acVJ7C%F{HGV>j!Z zV@Tmi#xS&xkFl6RgoayaSznx_6YSREF#fUEY%sCc8l>7i7SDDQoYk!C^FB6~)|95Z zveuHdCXrVAWBgN}Q) zT#UQe5GE0ZOsqmj!2CxnLjNB2VBFl1y8|8$FE=B+96Q>^%XcVy#LGu{IUYkKjUxF3 zylAfsT@I9J8O3~Uxi_vZ2izrNqO&2;xHr}=2Rt-Jr--)PD}R^6dR|254S&fZdJthU zHp1|SodJ{FmDLBcj!r5a!-Mhrgpm`AbyMdo^E`$T1u|py&ibP<1SjI?81B#ihfdD= zlxW)r$OOWyDdN6+$ON*Q2@GYt62{~NF_};k@pm%8`{n`g;QPew!R}4&mIt^apKYLfZy; z!0$U@VR#6)90Ep zoyv}Rz&|X5{^tQX7#Y6JgrjryXr-Y%OMkB!x`uDzt+7dQlxixYK1hU6o}=Ke{|Pve zN&)K$7%#Pz+=M&;c6)I4dc(~A8Z>T&{3xgi%}m&6P3^=gkRI6e>mR5J|+OV$^YW<-P*auAk;IAT&Yo4pr434HW z4M6H!9rcr-M&N%u)8?@DLEQulva_bul)h;{lj>jr!P9(M`w5(m+B$X11WU~xW3{8@ zX9k-kS;og`nSgd>`S9n5D8JHuD=N#g^uIL9?*i^$xl;Rb0miSHvHmYBO-S@tS(UZp z8qbx1QAS=_2-oJHNL?c5aUn2{S>Qi0b3T2W1015D89{>OV literal 0 HcmV?d00001 diff --git a/XP_UAC.manifest b/XP_UAC.manifest new file mode 100644 index 000000000..cca4115e5 --- /dev/null +++ b/XP_UAC.manifest @@ -0,0 +1,31 @@ + + + + + + + + + + + + + + + + + + true + + + \ No newline at end of file diff --git a/XP_UAC.rc b/XP_UAC.rc new file mode 100644 index 000000000..33ec1da7b --- /dev/null +++ b/XP_UAC.rc @@ -0,0 +1 @@ +1 PyScripter ".\XP_UAC.manifest" diff --git a/XP_UAC.res b/XP_UAC.res new file mode 100644 index 0000000000000000000000000000000000000000..dd57a790379fb42610bbec3f3ecfa238a175b245 GIT binary patch literal 1080 zcma)5+m6#P5H;cjkobqlk4TN%?L|*9c(Avd>apZ3tzw| zEaT>~tylz+9N9CTnRCvJ2_YoFb$?$k++KV?pAs@c%Zhv|b|E3ou>{_;h{ zt%YoxRskkZc18=MrdAvv?atGFZI{a7dJj2tfS_>m{2c|K*Do68Cs^Jx7b=3rN zP*_n^r!(ScEpE}UYaD-t=wY5`t`T}`4db>|BK#~>qK`IQ>MYZ$x75lRo!SPSkLbEE z@nk!?-t`a4rz^!amEs*#8~qiqm6P$C@pdvAj7CE22FdQMP|DT5;QNziwG_yYJWeR(+of9#2?wdOdbvUB$p@cL@ z{eMQeja7+kP18^>L&UnEKXOLw0zt$&DyO12g;_bA@;pZ&xv$m&uN^o$zJqIU4qu0D z=^vcSr;IhTA9k}J;_S2aZOpFv{V{9W-v+muAmAjIiz7EMM>K$Px5s*vBKBzU8gS#g NMC>E#r#Z)m{u>g{K{x;a literal 0 HcmV?d00001 diff --git a/cFileSearch.pas b/cFileSearch.pas index da74fae6a..30539e86d 100644 --- a/cFileSearch.pas +++ b/cFileSearch.pas @@ -328,7 +328,8 @@ procedure TBaseSearcher.DoSearch; FillBuffer; except on E: ELineTooLong do begin - MessageDlg(E.Message, mtWarning, [mbOK], 0); + // Just ingnore Issue 74 + //MessageDlg(E.Message, mtWarning, [mbOK], 0); Exit; end; end; diff --git a/cFindInFiles.pas b/cFindInFiles.pas index d20f633b8..075b5f226 100644 --- a/cFindInFiles.pas +++ b/cFindInFiles.pas @@ -242,7 +242,7 @@ implementation uses SysUtils, Forms, JclStrings, uEditAppIntfs, Dialogs, JvSearchFiles, JclFileUtils, VarPyth, frmFindResults, frmPyIDEMain, - dlgFindResultsOptions, Controls; + dlgFindResultsOptions, Controls, uCommonFunctions; { TLineMatches } @@ -640,7 +640,9 @@ constructor TFindInFilesExpert.Create; FMaskList := TStringList.Create; FDirList := TStringList.Create; FListFont := TFont.Create; + SetVistaContentFonts(FListFont); FContextFont := TFont.Create; + SetVistaContentFonts(FContextFont); FContextMatchColor := clHighlight; FNumContextLines := 2; diff --git a/cPyBaseDebugger.pas b/cPyBaseDebugger.pas index e55331987..9c6c1a6a1 100644 --- a/cPyBaseDebugger.pas +++ b/cPyBaseDebugger.pas @@ -108,14 +108,14 @@ TPyBaseInterpreter = class(TObject) function CallTipFromExpression(const Expr : string; var DisplayString, DocString : string) : Boolean; virtual; abstract; // Service routines - procedure HandlePyException(E : EPyException; SkipFrames : integer = 1); virtual; + procedure HandlePyException(E : EPythonError; SkipFrames : integer = 1); virtual; procedure SetCommandLine(const ScriptName : string); virtual; abstract; procedure RestoreCommandLine; virtual; abstract; procedure ReInitialize; virtual; // Main interface function ImportModule(Editor : IEditor; AddToNameSpace : Boolean = False) : Variant; virtual; abstract; procedure RunNoDebug(Editor : IEditor); virtual; abstract; - function RunSource(Const Source, FileName : string) : boolean; virtual; abstract; + function RunSource(Const Source, FileName : string; symbol : string = 'single') : boolean; virtual; abstract; function EvalCode(const Expr : string) : Variant; virtual; abstract; property InterpreterCapabilities : TInterpreterCapabilities read fInterpreterCapabilities; end; @@ -142,7 +142,7 @@ TPyBaseDebugger = class(TObject) // Evaluate expression in the current frame procedure Evaluate(const Expr : string; out ObjType, Value : string); virtual; abstract; // Like the InteractiveInterpreter runsource but for the debugger frame - function RunSource(Const Source, FileName : string) : boolean; virtual; abstract; + function RunSource(Const Source, FileName : string; symbol : string = 'single') : boolean; virtual; abstract; // Fills in CallStackList with TBaseFrameInfo objects procedure GetCallStack(CallStackList : TObjectList); virtual; abstract; // functions to get TBaseNamespaceItems corresponding to a frame's gloabals and locals @@ -178,7 +178,8 @@ TPythonControl = class(Tobject) constructor Create; destructor Destroy; override; // Breakpoint related - procedure ToggleBreakpoint(Editor : IEditor; ALine: integer); + procedure ToggleBreakpoint(Editor : IEditor; ALine: integer; + CtrlPressed : Boolean = False); procedure SetBreakPoint(FileName : string; ALine : integer; Disabled : Boolean; Condition : string); procedure ClearAllBreakpoints; @@ -335,7 +336,7 @@ function TPyBaseInterpreter.AddPathToPythonPath(const Path: string; Result := TPythonPathAdder.Create(SysPathAdd, SysPathRemove, Path, AutoRemove); end; -procedure TPyBaseInterpreter.HandlePyException(E: EPyException; SkipFrames : integer = 1); +procedure TPyBaseInterpreter.HandlePyException(E: EPythonError; SkipFrames : integer = 1); Var TI : TTracebackItem; begin @@ -461,7 +462,8 @@ function TPythonControl.IsExecutableLine(Editor: IEditor; ALine: integer): boole end; end; -procedure TPythonControl.ToggleBreakpoint(Editor : IEditor; ALine: integer); +procedure TPythonControl.ToggleBreakpoint(Editor : IEditor; ALine: integer; + CtrlPressed : Boolean = False); var Index : integer; i: integer; @@ -471,7 +473,12 @@ procedure TPythonControl.ToggleBreakpoint(Editor : IEditor; ALine: integer); Index := Editor.Breakpoints.Count; // append at the end for i := 0 to Editor.Breakpoints.Count - 1 do begin if TBreakPoint(Editor.Breakpoints[i]).LineNo = ALine then begin - Editor.Breakpoints.Delete(i); + if CtrlPressed then + // Toggle disabled + TBreakPoint(Editor.Breakpoints[i]).Disabled := + not TBreakPoint(Editor.Breakpoints[i]).Disabled + else + Editor.Breakpoints.Delete(i); Index := -1; break; end else if TBreakPoint(Editor.Breakpoints[i]).LineNo > ALine then begin @@ -482,6 +489,8 @@ procedure TPythonControl.ToggleBreakpoint(Editor : IEditor; ALine: integer); if Index >= 0 then begin BreakPoint := TBreakPoint.Create; BreakPoint.LineNo := ALine; + if CtrlPressed then + BreakPoint.Disabled := True; Editor.Breakpoints.Insert(Index, BreakPoint); end; DoOnBreakpointChanged(Editor, ALine); diff --git a/cPyDebugger.pas b/cPyDebugger.pas index 985e4f71c..9de1bc696 100644 --- a/cPyDebugger.pas +++ b/cPyDebugger.pas @@ -77,7 +77,7 @@ TPyInternalInterpreter = class(TPyBaseInterpreter) function ImportModule(Editor : IEditor; AddToNameSpace : Boolean = False) : Variant; override; procedure RunNoDebug(Editor : IEditor); override; function SyntaxCheck(Editor : IEditor; Quiet : Boolean = False) : Boolean; - function RunSource(const Source, FileName : string) : boolean; override; + function RunSource(const Source, FileName : string; symbol : string = 'single') : boolean; override; function EvalCode(const Expr : string) : Variant; override; property Debugger : Variant read fDebugger; property PyInteractiveInterpreter : Variant read fII; @@ -114,7 +114,7 @@ TPyInternalDebugger = class(TPyBaseDebugger) procedure Pause; override; procedure Abort; override; procedure Evaluate(const Expr : string; out ObjType, Value : string); override; - function RunSource(Const Source, FileName : string) : boolean; override; + function RunSource(Const Source, FileName : string; symbol : string = 'single') : boolean; override; procedure GetCallStack(CallStackList : TObjectList); override; function GetFrameGlobals(Frame : TBaseFrameInfo) : TBaseNameSpaceItem; override; function GetFrameLocals(Frame : TBaseFrameInfo) : TBaseNameSpaceItem; override; @@ -463,6 +463,7 @@ procedure TPyInternalDebugger.Run(Editor : IEditor; InitStepIn : Boolean = False Code : Variant; Path, OldPath : string; PythonPathAdder : IInterface; + ReturnFocusToEditor: Boolean; begin // Repeat here to make sure it is set right MaskFPUExceptions(CommandsDataModule.PyIDEOptions.MaskFPUExceptions); @@ -491,14 +492,15 @@ procedure TPyInternalDebugger.Run(Editor : IEditor; InitStepIn : Boolean = False PyControl.DoStateChange(dsRunning); - // Set the layout to the Debug layout is it exists MessagesWindow.ClearMessages; + ReturnFocusToEditor := Editor = GI_ActiveEditor; + // Set the layout to the Debug layout is it exists if PyIDEMainForm.Layouts.IndexOf('Debug') >= 0 then begin PyIDEMainForm.SaveLayout('Current'); PyIDEMainForm.LoadLayout('Debug'); Application.ProcessMessages; end else - ShowDockForm(PythonIIForm); + PyIDEMainForm.actNavInterpreterExecute(nil); try with PythonIIForm do begin @@ -531,7 +533,7 @@ procedure TPyInternalDebugger.Run(Editor : IEditor; InitStepIn : Boolean = False InternalInterpreter.Debugger.run(Code); except // CheckError already called by VarPyth - on E: EPyException do begin + on E: EPythonError do begin InternalInterpreter.HandlePyException(E, 2); MessageDlg(E.Message, mtError, [mbOK], 0); SysUtils.Abort; @@ -556,15 +558,27 @@ procedure TPyInternalDebugger.Run(Editor : IEditor; InitStepIn : Boolean = False PyIDEMainForm.LoadLayout('Current'); PyControl.DoStateChange(dsInactive); + if ReturnFocusToEditor then + Editor.Activate; end; end; end; -function TPyInternalDebugger.RunSource(const Source, FileName: string): boolean; +function TPyInternalDebugger.RunSource(const Source, FileName: string; symbol : string = 'single'): boolean; // The internal interpreter RunSource calls II.runsource which differs // according to whether we debugging or not +Var + OldCurrentPos : TEditorPos; begin - Result := InternalInterpreter.RunSource(Source, FileName); + OldCurrentPos := TEditorPos.Create; + OldCurrentPos.Assign(PyControl.CurrentPos); + try + Result := InternalInterpreter.RunSource(Source, FileName, symbol); + PyControl.CurrentPos.Assign(OldCurrentPos); + PyControl.DoCurrentPosChanged; + finally + OldCurrentPos.Free; + end; end; procedure TPyInternalDebugger.RunToCursor(Editor : IEditor; ALine: integer); @@ -718,13 +732,15 @@ procedure TPyInternalDebugger.SetDebuggerBreakpoints; if FName = '' then FName := '<'+FileTitle+'>'; for j := 0 to BreakPoints.Count - 1 do begin - if TBreakPoint(BreakPoints[j]).Condition <> '' then begin - InternalInterpreter.Debugger.set_break(VarPythonCreate(FName), - TBreakPoint(BreakPoints[j]).LineNo, - 0, TBreakPoint(BreakPoints[j]).Condition); - end else - InternalInterpreter.Debugger.set_break(VarPythonCreate(FName), - TBreakPoint(BreakPoints[j]).LineNo); + if not TBreakPoint(BreakPoints[j]).Disabled then begin + if TBreakPoint(BreakPoints[j]).Condition <> '' then begin + InternalInterpreter.Debugger.set_break(VarPythonCreate(FName), + TBreakPoint(BreakPoints[j]).LineNo, + 0, TBreakPoint(BreakPoints[j]).Condition); + end else + InternalInterpreter.Debugger.set_break(VarPythonCreate(FName), + TBreakPoint(BreakPoints[j]).LineNo); + end; end; end; PyControl.BreakPointsChanged := False; @@ -762,6 +778,11 @@ constructor TPyInternalInterpreter.Create(II: Variant); begin fII := II; fDebugger := II.debugger; + + // Execute PyscripterSetup.py here + + // sys.displayhook + fII.setupdisplayhook() end; function TPyInternalInterpreter.EvalCode(const Expr: string): Variant; @@ -841,7 +862,7 @@ function TPyInternalInterpreter.Compile(Editor: IEditor): Variant; MessageDlg(E.Message, mtError, [mbOK], 0); SysUtils.Abort; end; - on E: EPyException do begin //may raise OverflowError or ValueError + on E: EPythonError do begin //may raise OverflowError or ValueError HandlePyException(E); MessageDlg(E.Message, mtError, [mbOK], 0); SysUtils.Abort; @@ -904,7 +925,7 @@ function TPyInternalInterpreter.ImportModule(Editor: IEditor; end; CheckError; except - on E: EPyException do begin + on E: EPythonError do begin HandlePyException(E); Result := None; end; @@ -1016,6 +1037,7 @@ procedure TPyInternalInterpreter.RunNoDebug(Editor: IEditor); tc : TTimeCaps; Path, OldPath : string; PythonPathAdder : IInterface; + ReturnFocusToEditor : Boolean; begin // Repeat here to make sure it is set right MaskFPUExceptions(CommandsDataModule.PyIDEOptions.MaskFPUExceptions); @@ -1048,7 +1070,8 @@ procedure TPyInternalInterpreter.RunNoDebug(Editor: IEditor); // Set the command line parameters SetCommandLine(Editor.GetFileNameOrTitle); - ShowDockForm(PythonIIForm); + ReturnFocusToEditor := Editor = GI_ActiveEditor; + PyIDEMainForm.actNavInterpreterExecute(nil); try // Set Multimedia Timer @@ -1064,7 +1087,7 @@ procedure TPyInternalInterpreter.RunNoDebug(Editor: IEditor); fII.run_nodebug(Code); except // CheckError already called by VarPyth - on E: EPyException do begin + on E: EPythonError do begin HandlePyException(E); MessageDlg(E.Message, mtError, [mbOK], 0); SysUtils.Abort; @@ -1084,10 +1107,12 @@ procedure TPyInternalInterpreter.RunNoDebug(Editor: IEditor); ChDir(OldPath); PyControl.DoStateChange(dsInactive); + if ReturnFocusToEditor then + Editor.Activate; end; end; -function TPyInternalInterpreter.RunSource(const Source, FileName : string): boolean; +function TPyInternalInterpreter.RunSource(const Source, FileName : string; symbol : string = 'single'): boolean; Var OldDebuggerState : TDebuggerState; begin @@ -1097,7 +1122,7 @@ function TPyInternalInterpreter.RunSource(const Source, FileName : string): bool try // Workaround due to PREFER_UNICODE flag to make sure // no conversion to Unicode and back will take place - Result := fII.runsource(VarPythonCreate(Source), FileName); + Result := fII.runsource(VarPythonCreate(Source), FileName, symbol); finally PyControl.DoStateChange(OldDebuggerState); end; diff --git a/cPyRemoteDebugger.pas b/cPyRemoteDebugger.pas index 0bb200152..46b06034d 100644 --- a/cPyRemoteDebugger.pas +++ b/cPyRemoteDebugger.pas @@ -5,8 +5,6 @@ Purpose: Remote debugger using an Rpyc based server History: -----------------------------------------------------------------------------} -{ TODO : Check with matplotlib and wxPython } -{ REMINDER: I have modified PythonEngine.pas and TBXOffice2007theme.pas!} unit cPyRemoteDebugger; interface @@ -37,6 +35,9 @@ TPyRemoteInterpreter = class(TPyBaseInterpreter) fThreadExecInterrupted: Boolean; fDebugger : Variant; fServerType : TServerType; + fSocketPort: integer; + fOldCleanUpMainDict : boolean; + fOldCleanUpSysModules : Boolean; public constructor Create(AServerType : TServerType = stStandard); destructor Destroy; override; @@ -47,6 +48,7 @@ TPyRemoteInterpreter = class(TPyBaseInterpreter) procedure HandleRemoteException(ExcInfo : Variant; SkipFrames : integer = 1); procedure ReInitialize; override; procedure CheckConnected; + procedure ServeConnection; // Python Path function SysPathAdd(const Path : WideString) : boolean; override; function SysPathRemove(const Path : WideString) : boolean; override; @@ -63,7 +65,7 @@ TPyRemoteInterpreter = class(TPyBaseInterpreter) // Main interface function ImportModule(Editor : IEditor; AddToNameSpace : Boolean = False) : Variant; override; procedure RunNoDebug(Editor : IEditor); override; - function RunSource(Const Source, FileName : string) : boolean; override; + function RunSource(Const Source, FileName : string; symbol : string = 'single') : boolean; override; function EvalCode(const Expr : string) : Variant; override; property IsAvailable : Boolean read fIsAvailable; @@ -141,7 +143,7 @@ TPyRemDebugger = class(TPyBaseDebugger) // Evaluate expression in the current frame procedure Evaluate(const Expr : string; out ObjType, Value : string); override; // Like the InteractiveInterpreter runsource but for the debugger frame - function RunSource(Const Source, FileName : string) : boolean; override; + function RunSource(Const Source, FileName : string; symbol : string = 'single') : boolean; override; // Fills in CallStackList with TBaseFrameInfo objects procedure GetCallStack(CallStackList : TObjectList); override; // functions to get TBaseNamespaceItems corresponding to a frame's gloabals and locals @@ -482,7 +484,7 @@ function TPyRemoteInterpreter.Compile(Editor: IEditor): Variant; SysUtils.Abort; end; except - on E: EPyException do begin //may raise OverflowError or ValueError + on E: EPythonError do begin //may raise OverflowError or ValueError // New Line for output PythonIIForm.AppendText(sLineBreak); VarClear(Result); @@ -507,6 +509,16 @@ constructor TPyRemoteInterpreter.Create(AServerType : TServerType = stStandard); begin fInterpreterCapabilities := [icReInitialize]; fServerType := AServerType; + fSocketPort := 18888; + + if fServerType in [stTkinter, stWxPython] then begin + fOldCleanUpMainDict := CommandsDataModule.PyIDEOptions.CleanupMainDict; + fOldCleanUpSysModules := CommandsDataModule.PyIDEOptions.CleanupSysModules; + CommandsDataModule.PyIDEOptions.CleanupMainDict := False; + CommandsDataModule.PyIDEOptions.CleanupSysModules := False; + end; + + ServerProcess := TJvCreateProcess.Create(nil); with ServerProcess do begin @@ -560,7 +572,7 @@ constructor TPyRemoteInterpreter.Create(AServerType : TServerType = stStandard); RemoteServer := TExternalTool.Create; RemoteServer.CaptureOutput := False; RemoteServer.ApplicationName := '$[PythonDir]\pythonw.exe'; - RemoteServer.Parameters := '"' + ServerFile + '"'; + RemoteServer.Parameters := Format('"%s" %d', [ServerFile, fSocketPort]); // '$[PythonExe-Short-Path]Lib\site-packages\Rpyc\Servers\threaded_server.py'; // '"$[PythonExe-Path]Lib\site-packages\Rpyc\Servers\simple_server_wx.py"'; fIsAvailable := fIsAvailable and CreateAndConnectToServer; @@ -586,6 +598,10 @@ destructor TPyRemoteInterpreter.Destroy; ServerProcess.Free; RemoteServer.Free; + if fServerType in [stTkinter, stWxPython] then begin + CommandsDataModule.PyIDEOptions.CleanupMainDict := fOldCleanUpMainDict; + CommandsDataModule.PyIDEOptions.CleanupSysModules := fOldCleanUpSysModules; + end; inherited; end; @@ -728,7 +744,7 @@ function TPyRemoteInterpreter.ImportModule(Editor: IEditor; SysUtils.Abort; end; except - on E: EPyException do begin + on E: EPythonError do begin HandlePyException(E); Result := None; end; @@ -737,7 +753,7 @@ function TPyRemoteInterpreter.ImportModule(Editor: IEditor; MessageDlg('Error in importing module', mtError, [mbOK], 0); SysUtils.Abort; end else if AddToNameSpace then - RPI.globals.__setitem__(VarPythonCreate(NameOfModule), Result); + RPI.locals.__setitem__(VarPythonCreate(NameOfModule), Result); finally PyControl.DoStateChange(dsInactive); end; @@ -773,11 +789,7 @@ procedure TPyRemoteInterpreter.ReInitialize; Var SuppressOutput : IInterface; begin - if PyControl.DebuggerState in [dsRunning, dsPaused] then begin - if PyControl.DebuggerState <> dsInactive then begin - if MessageDlg('The Python interpreter is busy. Are you sure you want to terminate it?', - mtWarning, [mbYes, mbNo], 0) = idNo then Exit; - end; + if PyControl.DebuggerState in [dsRunning, dsRunningNoDebug, dsPaused] then begin fThreadExecInterrupted := True; SuppressOutput := PythonIIForm.OutputSuppressor; // Do not show errors try @@ -825,6 +837,7 @@ procedure TPyRemoteInterpreter.RunNoDebug(Editor: IEditor); Path, OldPath : WideString; PythonPathAdder : IInterface; ExcInfo : Variant; + ReturnFocusToEditor: Boolean; begin CheckConnected; //Compile @@ -852,7 +865,8 @@ procedure TPyRemoteInterpreter.RunNoDebug(Editor: IEditor); // Set the command line parameters SetCommandLine(Editor.GetFileNameOrTitle); - ShowDockForm(PythonIIForm); + ReturnFocusToEditor := Editor = GI_ActiveEditor; + PyIDEMainForm.actNavInterpreterExecute(nil); try try @@ -868,10 +882,12 @@ procedure TPyRemoteInterpreter.RunNoDebug(Editor: IEditor); end; end; except - on E: EPyException do begin + on E: EPythonError do begin // should not happen - HandlePyException(E); - MessageDlg(E.Message, mtError, [mbOK], 0); + if not fThreadExecInterrupted then begin + HandlePyException(E); + MessageDlg(E.Message, mtError, [mbOK], 0); + end; SysUtils.Abort; end; end; @@ -887,11 +903,18 @@ procedure TPyRemoteInterpreter.RunNoDebug(Editor: IEditor); RPI.rem_chdir(OldPath); end; PyControl.DoStateChange(dsInactive); + if ReturnFocusToEditor then + Editor.Activate; + if fThreadExecInterrupted then begin + PythonPathAdder := nil; + PythonIIForm.ClearPendingMessages; + ReInitialize; + end; end; end; function TPyRemoteInterpreter.RunSource(const Source, - FileName: string): boolean; + FileName: string; symbol : string = 'single'): boolean; // works asynchronously Var OldDebuggerState : TDebuggerState; @@ -901,7 +924,7 @@ function TPyRemoteInterpreter.RunSource(const Source, OldDebuggerState := PyControl.DebuggerState; PyControl.DoStateChange(dsRunningNoDebug); try - Result := ExecuteInThread(RPI.runsource, VarPythonCreate([Source, FileName], stTuple)); + Result := ExecuteInThread(RPI.runsource, VarPythonCreate([Source, FileName, symbol], stTuple)); finally PyControl.DoStateChange(OldDebuggerState); end; @@ -946,7 +969,7 @@ function TPyRemoteInterpreter.CreateAndConnectToServer : Boolean; else for i := 1 to 10 do begin try - Conn := Rpyc.SocketConnection('localhost'); + Conn := Rpyc.SocketConnection('localhost', fSocketPort); Result := True; fIsConnected := True; break; @@ -970,13 +993,30 @@ function TPyRemoteInterpreter.CreateAndConnectToServer : Boolean; Conn.execute('del _RPI.locals["_RPI"]'); Rpyc.getattr(RPI, '__class__').debugIDE := InternalInterpreter.PyInteractiveInterpreter.debugIDE; + // input and raw_input + Conn.modules.__builtin__.raw_input := InternalInterpreter.PyInteractiveInterpreter.Win32RawInput; + // make sys.stdout etc asynchronous when writing RPI.asyncIO(); + // debugger fDebugger := RPI.debugger; Rpyc.getattr(fDebugger, '__class__').debugIDE := InternalInterpreter.PyInteractiveInterpreter.debugIDE; // Install Rpyc excepthook SysModule.excepthook := Rpyc.rpyc_excepthook; + // Execute PyscripterSetup.py here + Conn.namespace.pyscripter := Import('pyscripter'); + + // sys.displayhook + RPI.setupdisplayhook(); + GetPythonEngine.CheckError; + end; +end; + +procedure TPyRemoteInterpreter.ServeConnection; +begin + CheckConnected; + While Conn.poll() do begin end; end; @@ -1281,6 +1321,7 @@ procedure TPyRemDebugger.Run(Editor: IEditor; InitStepIn: Boolean); Path, OldPath : string; PythonPathAdder : IInterface; ExcInfo : Variant; + ReturnFocusToEditor: Boolean; begin fRemotePython.CheckConnected; fDebuggerCommand := dcRun; @@ -1307,14 +1348,15 @@ procedure TPyRemDebugger.Run(Editor: IEditor; InitStepIn: Boolean); PyControl.DoStateChange(dsRunning); - // Set the layout to the Debug layout is it exists MessagesWindow.ClearMessages; + ReturnFocusToEditor := Editor = GI_ActiveEditor; + // Set the layout to the Debug layout is it exists if PyIDEMainForm.Layouts.IndexOf('Debug') >= 0 then begin PyIDEMainForm.SaveLayout('Current'); PyIDEMainForm.LoadLayout('Debug'); Application.ProcessMessages; - end else - ShowDockForm(PythonIIForm); + end else + PyIDEMainForm.actNavInterpreterExecute(nil); try with PythonIIForm do begin @@ -1361,7 +1403,7 @@ procedure TPyRemDebugger.Run(Editor: IEditor; InitStepIn: Boolean); end; except // CheckError already called by VarPyth - on E: EPyException do begin + on E: EPythonError do begin // should not happen if not fRemotePython.fThreadExecInterrupted then begin fRemotePython.HandlePyException(E); @@ -1393,6 +1435,8 @@ procedure TPyRemDebugger.Run(Editor: IEditor; InitStepIn: Boolean); PyIDEMainForm.LoadLayout('Current'); PyControl.DoStateChange(dsInactive); + if ReturnFocusToEditor then + Editor.Activate; if fRemotePython.fThreadExecInterrupted then begin PythonPathAdder := nil; PythonIIForm.ClearPendingMessages; @@ -1402,11 +1446,21 @@ procedure TPyRemDebugger.Run(Editor: IEditor; InitStepIn: Boolean); end; end; -function TPyRemDebugger.RunSource(const Source, FileName: string): boolean; +function TPyRemDebugger.RunSource(const Source, FileName: string; symbol : string = 'single'): boolean; // The internal interpreter RunSource calls II.runsource which differs // according to whether we debugging or not +Var + OldCurrentPos : TEditorPos; begin - Result := fRemotePython.RunSource(Source, FileName); + OldCurrentPos := TEditorPos.Create; + OldCurrentPos.Assign(PyControl.CurrentPos); + try + Result := fRemotePython.RunSource(Source, FileName, symbol); + PyControl.CurrentPos.Assign(OldCurrentPos); + PyControl.DoCurrentPosChanged; + finally + OldCurrentPos.Free; + end; end; procedure TPyRemDebugger.RunToCursor(Editor: IEditor; ALine: integer); @@ -1445,13 +1499,15 @@ procedure TPyRemDebugger.SetDebuggerBreakpoints; if FName = '' then FName := '<'+FileTitle+'>'; for j := 0 to BreakPoints.Count - 1 do begin - if TBreakPoint(BreakPoints[j]).Condition <> '' then begin - fRemotePython.Debugger.set_break(VarPythonCreate(FName), - TBreakPoint(BreakPoints[j]).LineNo, - 0, TBreakPoint(BreakPoints[j]).Condition); - end else - fRemotePython.Debugger.set_break(VarPythonCreate(FName), - TBreakPoint(BreakPoints[j]).LineNo); + if not TBreakPoint(BreakPoints[j]).Disabled then begin + if TBreakPoint(BreakPoints[j]).Condition <> '' then begin + fRemotePython.Debugger.set_break(VarPythonCreate(FName), + TBreakPoint(BreakPoints[j]).LineNo, + 0, TBreakPoint(BreakPoints[j]).Condition); + end else + fRemotePython.Debugger.set_break(VarPythonCreate(FName), + TBreakPoint(BreakPoints[j]).LineNo); + end; end; end; PyControl.BreakPointsChanged := False; diff --git a/cPythonSourceScanner.pas b/cPythonSourceScanner.pas index 9269f5692..7c3358210 100644 --- a/cPythonSourceScanner.pas +++ b/cPythonSourceScanner.pas @@ -185,8 +185,7 @@ TPythonScanner = class fLineContinueRE : TRegExpr; fImportRE : TRegExpr; fFromImportRE : TRegExpr; - fClassAttributeRE : TRegExpr; - fVarRE : TRegExpr; + fAssignmentRE : TRegExpr; fAliasRE : TRegExpr; fListRE : TRegExpr; // function StringAndCommentsReplaceFunc(ARegExpr : TRegExpr): string; @@ -431,12 +430,9 @@ constructor TPythonScanner.Create; fImportRE := CompiledRegExpr('^[ \t]*import[ \t]+([^#;]+)'); fFromImportRE := CompiledRegExpr(Format('^[ \t]*from[ \t]+(%s)[ \t]+import[ \t]+([^#;]+)', [DottedIdentRE])); - fClassAttributeRE := - CompiledRegExpr(Format('^[ \t]*self\.(%s)[ \t]*(=)[ \t]*((%s)(\(?))?', - [IdentRE, DottedIdentRE])); - fVarRE := - CompiledRegExpr(Format('^[ \t]*(%s)[ \t]*(=)[ \t]*((%s)(\(?))?', - [IdentRE, DottedIdentRE])); + fAssignmentRE := + CompiledRegExpr(Format('^([ \t]*(self.)?%s[ \t]*(,[ \t]*(self.)?%s[ \t]*)*(=))+[ \t]*((%s)(\(?))?', + [IdentRE, IdentRE, DottedIdentRE])); fAliasRE := CompiledRegExpr(Format('^[ \t]*(%s)([ \t]+as[ \t]+(%s))?', [DottedIdentRE, IdentRE])); @@ -453,8 +449,7 @@ destructor TPythonScanner.Destroy; fLineContinueRE.Free; fImportRE.Free; fFromImportRE.Free; - fClassAttributeRE.Free; - fVarRE.Free; + fAssignmentRE.Free; fAliasRE.Free; fListRE.Free; inherited; @@ -662,7 +657,7 @@ function TPythonScanner.ScanModule(Source: string; Module : TParsedModule): bool P : PChar; LineNo, Indent, Index, CharOffset, CharOffset2, LastLength : integer; CodeStart : integer; - Line, Token, S : string; + Line, Token, AsgnTargetList, S : string; Stop : Boolean; CodeElement, LastCodeElement, Parent : TCodeElement; ModuleImport : TModuleImport; @@ -671,6 +666,7 @@ function TPythonScanner.ScanModule(Source: string; Module : TParsedModule): bool IsBuiltInType : Boolean; SafeGuard: ISafeGuard; LineStarts: TList; + AsgnTargetCount : integer; begin LineStarts := TList(Guard(TList.Create, SafeGuard)); UseModifiedSource := True; @@ -859,63 +855,77 @@ function TPythonScanner.ScanModule(Source: string; Module : TParsedModule): bool end; ModuleImport.Parent := Module; Module.fImportedModules.Add(ModuleImport); - end else if fClassAttributeRE.Exec(Line) then begin - // search for class attributes - Klass := GetActiveClass(LastCodeElement); - if Assigned(Klass) then begin - Variable := TVariable.Create; - Variable.Name := fClassAttributeRE.Match[1]; - Variable.Parent := Klass; - Variable.fCodePos.LineNo := LineNo; - Variable.fCodePos.CharOffset := fClassAttributeRE.MatchPos[1]; - if fClassAttributeRE.Match[4] <> '' then begin - Variable.ObjType := fClassAttributeRE.Match[4]; - if fClassAttributeRE.Match[5] = '(' then - Include(Variable.Attributes, vaCall); - end else begin - S := Copy(Line, fClassAttributeRE.MatchPos[2]+1, MaxInt); - Variable.ObjType := GetExpressionType(S, IsBuiltInType); - if IsBuiltInType then - Include(Variable.Attributes, vaBuiltIn) - else - Variable.ObjType := ''; // not a dotted name so we can't do much with it + end else if fAssignmentRE.Exec(Line) then begin + S := Copy(Line, 1, fAssignmentRE.MatchPos[5]-1); + AsgnTargetList := StrToken(S, '='); + CharOffset2 := 1; // Keeps track of the end of the identifier + while AsgnTargetList <> '' do begin + AsgnTargetCount := 0; + Variable := nil; + Token := StrToken(AsgnTargetList, ','); + while Token <> '' do begin + CharOffset := CharOffset2; // Keeps track of the start of the identifier + Inc(CharOffset, CalcIndent(Token)); + Inc(CharOffset2, Succ(Length(Token))); // account for , + Token := Trim(Token); + if StrIsLeft(PChar(Token), 'self.') then begin + // class variable + Token := Copy(Token, 6, Length(Token) - 5); + Inc(CharOffset, 5); // Length of "self." + // search for class attributes + Klass := GetActiveClass(LastCodeElement); + if Assigned(Klass) then begin + Variable := TVariable.Create; + Variable.Name := Token; + Variable.Parent := Klass; + Variable.fCodePos.LineNo := LineNo; + Variable.fCodePos.CharOffset := CharOffset; + Klass.fAttributes.Add(Variable); + Inc(AsgnTargetCount); + end; + end else begin + // search for local/global variables + Variable := TVariable.Create; + Variable.Name := Token; + Variable.Parent := LastCodeElement; + Variable.fCodePos.LineNo := LineNo; + Variable.fCodePos.CharOffset := CharOffset; + if LastCodeElement.ClassType = TParsedFunction then + TParsedFunction(LastCodeElement).Locals.Add(Variable) + else if LastCodeElement.ClassType = TParsedClass then begin + Include(Variable.Attributes, vaClassAttribute); + TParsedClass(LastCodeElement).Attributes.Add(Variable) + end else begin + Module.Globals.Add(Variable); + if Variable.Name = '__all__' then begin + Line := GetNthLine(Source, LineNo); + UseModifiedSource := False; + ProcessLineContinuation(P, Line, LineNo, LineStarts); + if fListRE.Exec(Line) then + Module.fAllExportsVar := fListRE.Match[1]; + UseModifiedSource := True; + end; + end; + Inc(AsgnTargetCount); + end; + Token := StrToken(AsgnTargetList, ','); end; - Klass.fAttributes.Add(Variable); - end; - end else if fVarRE.Exec(Line) then begin - // search for local/global variables - Variable := TVariable.Create; - Variable.Name := fVarRE.Match[1]; - Variable.Parent := LastCodeElement; - Variable.fCodePos.LineNo := LineNo; - Variable.fCodePos.CharOffset := fVarRE.MatchPos[1]; - if fVarRE.Match[4] <> '' then begin - Variable.ObjType := fVarRE.Match[4]; - if fVarRE.Match[5] = '(' then - Include(Variable.Attributes, vaCall); - end else begin - S := Copy(Line, fVarRE.MatchPos[2]+1, MaxInt); - Variable.ObjType := GetExpressionType(S, IsBuiltInType); - if IsBuiltInType then - Include(Variable.Attributes, vaBuiltIn) - else - Variable.ObjType := ''; // not a dotted name so we can't do much with it - end; - if LastCodeElement.ClassType = TParsedFunction then - TParsedFunction(LastCodeElement).Locals.Add(Variable) - else if LastCodeElement.ClassType = TParsedClass then begin - Include(Variable.Attributes, vaClassAttribute); - TParsedClass(LastCodeElement).Attributes.Add(Variable) - end else begin - Module.Globals.Add(Variable); - if Variable.Name = '__all__' then begin - Line := GetNthLine(Source, LineNo); - UseModifiedSource := False; - ProcessLineContinuation(P, Line, LineNo, LineStarts); - if fListRE.Exec(Line) then - Module.fAllExportsVar := fListRE.Match[1]; - UseModifiedSource := True; + // Variable Type if the assignment has a single target + if AsgnTargetCount = 1 then begin + if fAssignmentRE.Match[7] <> '' then begin + Variable.ObjType := fAssignmentRE.Match[7]; + if fAssignmentRE.Match[8] = '(' then + Include(Variable.Attributes, vaCall); + end else begin + Variable.ObjType := GetExpressionType( + Copy(Line, fAssignmentRE.MatchPos[5]+1, MaxInt), IsBuiltInType); + if IsBuiltInType then + Include(Variable.Attributes, vaBuiltIn) + else + Variable.ObjType := ''; // not a dotted name so we can't do much with it + end; end; + AsgnTargetList := StrToken(S, '='); end; end; end; diff --git a/cTools.pas b/cTools.pas index 2dc39294a..b5e1eddb3 100644 --- a/cTools.pas +++ b/cTools.pas @@ -333,8 +333,7 @@ initialization Caption := 'Py&lint'; Description := 'PyLint tool (www.logilab.org/projects/pylint)'; ApplicationName := '$[PythonExe-Short]'; - Parameters := '$[PythonDir-Short]Lib\site-packages\pylint\lint.py $[ActiveDoc-Short] --parseable=y'; - WorkingDirectory := '$[ActiveDoc-Dir]'; + Parameters := '$[PythonDir-Short]Lib\site-packages\pylint\lint.py $[ActiveDoc-Short] -f parseable'; ShortCut := Menus.Shortcut(Ord('L'), [ssCtrl]); Context := tcActiveFile; SaveFiles := sfAll; @@ -362,6 +361,21 @@ initialization WaitForTerminate := True; end; + with (ToolsCollection.Add as TToolItem).ExternalTool do begin + Caption := '&Reindent'; + Description := 'Reindent the active file'; + ApplicationName := '$[PythonExe-Short]'; + Parameters := '$[PythonDir-Short]Tools\Scripts\reindent.py'; + Context := tcActivePythonFile; + SaveFiles := sfNone; + ProcessInput := piActiveFile; + ProcessOutput := poActiveFile; + ParseMessages := False; + CaptureOutput := True; + ConsoleHidden := True; + WaitForTerminate := True; + end; + with (ToolsCollection.Add as TToolItem).ExternalTool do begin Caption := '&Upper Case'; Description := 'Change selection to upper case'; diff --git a/dlgAboutPyScripter.dfm b/dlgAboutPyScripter.dfm index fbf78e67e..d7e8c7e43 100644 --- a/dlgAboutPyScripter.dfm +++ b/dlgAboutPyScripter.dfm @@ -1493,7 +1493,7 @@ object AboutBox: TAboutBox Top = 0 Width = 348 Height = 199 - VertScrollBar.Position = 75 + VertScrollBar.Position = 103 VertScrollBar.Smooth = True VertScrollBar.Style = ssHotTrack VertScrollBar.Tracking = True @@ -1503,9 +1503,9 @@ object AboutBox: TAboutBox TabOrder = 0 object JvLinkLabel: TJvLinkLabel Left = 0 - Top = -75 + Top = -103 Width = 327 - Height = 270 + Height = 298 Caption = 'Credits
'#13#10'Special thanks to the many great developers ' + 'who,'#13#10'with their amazing work, have made PyScripter '#13#10'possible. ' + @@ -1522,8 +1522,10 @@ object AboutBox: TAboutBox 'ink>www.jrsoftware.org/tb2k.php)'#13#10'
'#13#10'- TBX (www.g32.org/tbx)'#13#10'
'#13#10'- Additional TBX Themes' + ' (www.rmklever.com)'#13#10'
'#13#10'- JvTBXLib (mxs.bergsoft.net)'#13#10'
'#13#10'- TntWare Unicode Controls(www.tntware.com)'#13#10#13#10#13#10 + '>mxs.bergsoft.net)'#13#10'
'#13#10'- SpTBXLib(club.te' + + 'lepolis.com/silverpointdev)'#13#10'
'#13#10'- TntWare Unicode C' + + 'ontrols(www.tntware.com)'#13#10'
'#13#10'- TCommandLi' + + 'neReader(www.benibela.de)' Text.Strings = ( 'Credits
'#13#10'Special thanks to the many great developers ' + @@ -1541,8 +1543,10 @@ object AboutBox: TAboutBox 'ink>www.jrsoftware.org/tb2k.php)'#13#10'
'#13#10'- TBX (www.g32.org/tbx)'#13#10'
'#13#10'- Additional TBX Themes' + ' (www.rmklever.com)'#13#10'
'#13#10'- JvTBXLib (mxs.bergsoft.net)'#13#10'
'#13#10'- TntWare Unicode Controls(www.tntware.com)'#13#10#13#10#13#10) + '>mxs.bergsoft.net)'#13#10'
'#13#10'- SpTBXLib(club.te' + + 'lepolis.com/silverpointdev)'#13#10'
'#13#10'- TntWare Unicode C' + + 'ontrols(www.tntware.com)'#13#10'
'#13#10'- TCommandLi' + + 'neReader(www.benibela.de)') Transparent = True HotLinks = True MarginWidth = 2 @@ -1555,7 +1559,7 @@ object AboutBox: TAboutBox Font.Name = 'Arial' Font.Style = [] ParentFont = False - ExplicitTop = -29 + ExplicitTop = -75 end end end diff --git a/dlgAskParam.dfm b/dlgAskParam.dfm index c4d7cf838..c4fee0656 100644 --- a/dlgAskParam.dfm +++ b/dlgAskParam.dfm @@ -1,10 +1,10 @@ object AskParamForm: TAskParamForm Left = 262 Top = 241 - Width = 393 - Height = 147 BorderIcons = [biSystemMenu] Caption = 'Unknown parameter' + ClientHeight = 113 + ClientWidth = 385 Color = clBtnFace Font.Charset = DEFAULT_CHARSET Font.Color = clWindowText @@ -34,34 +34,46 @@ object AskParamForm: TAskParamForm Anchors = [akLeft, akTop, akRight] TabOrder = 0 end - object chkSaveToFile: TCheckBox - Left = 8 - Top = 73 - Width = 186 - Height = 17 - Caption = 'and save it a custom parameter' - TabOrder = 1 - end - object btnOK: TButton + object btnOK: TSpTBXButton Left = 222 Top = 82 Width = 75 Height = 25 - Anchors = [akRight, akBottom] Caption = 'OK' + Anchors = [akRight, akBottom] + TabOrder = 2 Default = True + LinkFont.Charset = DEFAULT_CHARSET + LinkFont.Color = clBlue + LinkFont.Height = -11 + LinkFont.Name = 'Tahoma' + LinkFont.Style = [fsUnderline] ModalResult = 1 - TabOrder = 2 end - object btnCancel: TButton + object btnCancel: TSpTBXButton Left = 302 Top = 82 Width = 75 Height = 25 + Caption = 'Cancel' Anchors = [akRight, akBottom] + TabOrder = 3 Cancel = True - Caption = 'Cancel' + LinkFont.Charset = DEFAULT_CHARSET + LinkFont.Color = clBlue + LinkFont.Height = -11 + LinkFont.Name = 'Tahoma' + LinkFont.Style = [fsUnderline] ModalResult = 2 - TabOrder = 3 + end + object chkSaveToFile: TSpTBXCheckBox + Left = 8 + Top = 73 + Width = 166 + Height = 15 + Caption = 'and save it a custom parameter' + ParentColor = True + TabOrder = 1 + ThemeType = thtWindows end end diff --git a/dlgAskParam.pas b/dlgAskParam.pas index 4c945734b..b24233a2c 100644 --- a/dlgAskParam.pas +++ b/dlgAskParam.pas @@ -41,16 +41,16 @@ interface uses Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs, - StdCtrls; + StdCtrls, SpTBXControls, TBXDkPanels; type (* asks for parameter value and optionally stores parameter to file *) TAskParamForm = class(TForm) Label1: TLabel; txtParamValue: TEdit; - chkSaveToFile: TCheckBox; - btnOK: TButton; - btnCancel: TButton; + btnOK: TSpTBXButton; + btnCancel: TSpTBXButton; + chkSaveToFile: TSpTBXCheckBox; private FParamName: string; procedure SetParamName(const Value: string); diff --git a/dlgCodeTemplates.dfm b/dlgCodeTemplates.dfm index e18b98043..e6a36a8cd 100644 --- a/dlgCodeTemplates.dfm +++ b/dlgCodeTemplates.dfm @@ -28,7 +28,6 @@ object CodeTemplates: TCodeTemplates Height = 423 Align = alClient TabOrder = 0 - ExplicitLeft = 1 DesignSize = ( 430 423) @@ -56,29 +55,6 @@ object CodeTemplates: TCodeTemplates ViewStyle = vsReport OnChange = lvItemsChange OnDeletion = lvItemsDeletion - ExplicitWidth = 413 - end - object btnCancel: TButton - Left = 263 - Top = 391 - Width = 75 - Height = 25 - Anchors = [akRight, akBottom] - Cancel = True - Caption = '&Cancel' - ModalResult = 2 - TabOrder = 1 - end - object btnOK: TButton - Left = 179 - Top = 391 - Width = 75 - Height = 25 - Anchors = [akRight, akBottom] - Caption = '&OK' - Default = True - ModalResult = 1 - TabOrder = 2 end object JvGroupBox: TJvGroupBox Left = 10 @@ -142,8 +118,8 @@ object CodeTemplates: TCodeTemplates ParentFont = False end object SynTemplate: TSynEdit - Left = 7 - Top = 82 + Left = 3 + Top = 80 Width = 400 Height = 117 Anchors = [akLeft, akTop, akRight] @@ -191,70 +167,127 @@ object CodeTemplates: TCodeTemplates TabOrder = 2 end end - object TBXButton1: TTBXButton - Left = 9 + object TBXButton1: TSpTBXButton + Left = 6 Top = 118 - Width = 64 + Width = 84 Height = 24 Action = actAddItem - ButtonStyle = bsFlat - ImageIndex = 49 - Images = CommandsDataModule.Images TabOrder = 4 + Images = CommandsDataModule.Images + ImageIndex = 49 + LinkFont.Charset = DEFAULT_CHARSET + LinkFont.Color = clBlue + LinkFont.Height = -11 + LinkFont.Name = 'Tahoma' + LinkFont.Style = [fsUnderline] end - object TBXButton3: TTBXButton - Left = 80 + object TBXButton3: TSpTBXButton + Left = 89 Top = 118 - Width = 64 + Width = 84 Height = 24 Action = actDeleteItem - ButtonStyle = bsFlat - ImageIndex = 14 - Images = CommandsDataModule.Images TabOrder = 5 + Images = CommandsDataModule.Images + ImageIndex = 14 + LinkFont.Charset = DEFAULT_CHARSET + LinkFont.Color = clBlue + LinkFont.Height = -11 + LinkFont.Name = 'Tahoma' + LinkFont.Style = [fsUnderline] end - object TBXButton4: TTBXButton - Left = 151 + object TBXButton4: TSpTBXButton + Left = 173 Top = 118 - Width = 80 + Width = 84 Height = 24 Action = actMoveUp - ButtonStyle = bsFlat - ImageIndex = 47 - Images = CommandsDataModule.Images TabOrder = 6 + Images = CommandsDataModule.Images + ImageIndex = 47 + LinkFont.Charset = DEFAULT_CHARSET + LinkFont.Color = clBlue + LinkFont.Height = -11 + LinkFont.Name = 'Tahoma' + LinkFont.Style = [fsUnderline] end - object TBXButton5: TTBXButton - Left = 238 + object TBXButton5: TSpTBXButton + Left = 257 Top = 118 Width = 84 Height = 24 Action = actMoveDown - ButtonStyle = bsFlat - ImageIndex = 48 - Images = CommandsDataModule.Images TabOrder = 7 + Images = CommandsDataModule.Images + ImageIndex = 48 + LinkFont.Charset = DEFAULT_CHARSET + LinkFont.Color = clBlue + LinkFont.Height = -11 + LinkFont.Name = 'Tahoma' + LinkFont.Style = [fsUnderline] end - object TBXButton2: TTBXButton - Left = 329 + object TBXButton2: TSpTBXButton + Left = 341 Top = 118 - Width = 66 + Width = 84 Height = 24 Action = actUpdateItem - ButtonStyle = bsFlat - ImageIndex = 39 - Images = CommandsDataModule.Images TabOrder = 8 + Images = CommandsDataModule.Images + ImageIndex = 39 + LinkFont.Charset = DEFAULT_CHARSET + LinkFont.Color = clBlue + LinkFont.Height = -11 + LinkFont.Name = 'Tahoma' + LinkFont.Style = [fsUnderline] end - object btnHelp: TButton - Left = 347 + object btnCancel: TSpTBXButton + Left = 263 Top = 391 Width = 75 Height = 25 + Caption = 'Cancel' Anchors = [akRight, akBottom] + TabOrder = 1 + Cancel = True + LinkFont.Charset = DEFAULT_CHARSET + LinkFont.Color = clBlue + LinkFont.Height = -11 + LinkFont.Name = 'Tahoma' + LinkFont.Style = [fsUnderline] + ModalResult = 2 + end + object btnOK: TSpTBXButton + Left = 179 + Top = 391 + Width = 75 + Height = 25 + Caption = 'OK' + Anchors = [akRight, akBottom] + TabOrder = 2 + Default = True + LinkFont.Charset = DEFAULT_CHARSET + LinkFont.Color = clBlue + LinkFont.Height = -11 + LinkFont.Name = 'Tahoma' + LinkFont.Style = [fsUnderline] + ModalResult = 1 + end + object btnHelp: TSpTBXButton + Left = 347 + Top = 391 + Width = 75 + Height = 25 Caption = '&Help' + Anchors = [akRight, akBottom] TabOrder = 9 OnClick = btnHelpClick + LinkFont.Charset = DEFAULT_CHARSET + LinkFont.Color = clBlue + LinkFont.Height = -11 + LinkFont.Name = 'Tahoma' + LinkFont.Style = [fsUnderline] end end object ActionList: TActionList diff --git a/dlgCodeTemplates.pas b/dlgCodeTemplates.pas index ac6e0a1c7..5fcdd22c3 100644 --- a/dlgCodeTemplates.pas +++ b/dlgCodeTemplates.pas @@ -13,14 +13,12 @@ interface uses Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms, Dialogs, StdCtrls, ComCtrls, ExtCtrls, JvExStdCtrls, JvEdit, - SynEdit, JvGroupBox, ActnList, TBXDkPanels; + SynEdit, JvGroupBox, ActnList, TBXDkPanels, SpTBXControls; type TCodeTemplates = class(TForm) Panel: TPanel; lvItems: TListView; - btnCancel: TButton; - btnOK: TButton; JvGroupBox: TJvGroupBox; Label1: TLabel; Label2: TLabel; @@ -34,14 +32,16 @@ TCodeTemplates = class(TForm) actUpdateItem: TAction; Label5: TLabel; edDescription: TEdit; - TBXButton1: TTBXButton; - TBXButton3: TTBXButton; - TBXButton4: TTBXButton; - TBXButton5: TTBXButton; - TBXButton2: TTBXButton; Label4: TLabel; Label3: TLabel; - btnHelp: TButton; + TBXButton1: TSpTBXButton; + TBXButton3: TSpTBXButton; + TBXButton4: TSpTBXButton; + TBXButton5: TSpTBXButton; + TBXButton2: TSpTBXButton; + btnCancel: TSpTBXButton; + btnOK: TSpTBXButton; + btnHelp: TSpTBXButton; procedure FormClose(Sender: TObject; var Action: TCloseAction); procedure FormDestroy(Sender: TObject); procedure FormShow(Sender: TObject); @@ -161,6 +161,7 @@ procedure TCodeTemplates.actAddItemExecute(Sender: TObject); i : Integer; begin if edShortCut.Text <> '' then begin + SynTemplate.Modified := False; for i := 0 to lvItems.Items.Count - 1 do if CompareText(lvItems.Items[i].Caption, edShortCut.Text) = 0 then begin Item := lvItems.Items[i]; @@ -202,6 +203,7 @@ procedure TCodeTemplates.actUpdateItemExecute(Sender: TObject); Caption := edShortCut.Text; SubItems[0] := edDescription.Text; TStringList(Data).Assign(SynTemplate.Lines); + SynTemplate.Modified := False; end; end; end; @@ -218,6 +220,7 @@ procedure TCodeTemplates.lvItemsChange(Sender: TObject; Item: TListItem; edShortCut.Text := Item.Caption; edDescription.Text := Item.SubItems[0]; SynTemplate.Lines.Assign(TStringList(Item.Data)); + SynTemplate.Modified := False; end; end; @@ -275,6 +278,12 @@ procedure TCodeTemplates.lvItemsDeletion(Sender: TObject; Item: TListItem); procedure TCodeTemplates.FormClose(Sender: TObject; var Action: TCloseAction); begin + if (edShortcut.Text <> '') and SynTemplate.Modified then begin + if (MessageDlg('The template has been modified. Do you want to update it with the new definition?', + mtConfirmation, [mbYes, mbNo], 0) = idYes) + then + actUpdateItemExecute(Sender); + end; GetItems; end; diff --git a/dlgCommandLine.dfm b/dlgCommandLine.dfm index 3ae4ffe02..a738a78c2 100644 --- a/dlgCommandLine.dfm +++ b/dlgCommandLine.dfm @@ -26,7 +26,6 @@ object CommandLineDlg: TCommandLineDlg Height = 151 Align = alClient TabOrder = 0 - ExplicitWidth = 435 DesignSize = ( 458 151) @@ -84,11 +83,9 @@ object CommandLineDlg: TCommandLineDlg Width = 75 Height = 25 Anchors = [akRight, akBottom] - Caption = '&OK' TabOrder = 1 OnClick = OKButtonClick Kind = bkOK - ExplicitLeft = 89 end object BitBtn2: TBitBtn Left = 206 @@ -96,10 +93,8 @@ object CommandLineDlg: TCommandLineDlg Width = 75 Height = 25 Anchors = [akRight, akBottom] - Caption = '&Cancel' TabOrder = 2 Kind = bkCancel - ExplicitLeft = 183 end object HelpButton: TBitBtn Left = 301 @@ -110,15 +105,6 @@ object CommandLineDlg: TCommandLineDlg TabOrder = 3 OnClick = btnHelpClick Kind = bkHelp - ExplicitLeft = 278 - end - object cbUseCommandLine: TCheckBox - Left = 8 - Top = 8 - Width = 241 - Height = 17 - Caption = 'Use Command Line Parameters?' - TabOrder = 4 end object TBXButton1: TTBXButton Left = 429 @@ -132,6 +118,15 @@ object CommandLineDlg: TCommandLineDlg ShowHint = True TabOrder = 5 end + object cbUseCommandLine: TSpTBXCheckBox + Left = 8 + Top = 8 + Width = 171 + Height = 15 + Caption = 'Use Command Line Parameters?' + ParentColor = True + TabOrder = 4 + end end object TBXPopupHistory: TTBXPopupMenu OnPopup = TBXPopupHistoryPopup diff --git a/dlgCommandLine.pas b/dlgCommandLine.pas index 9c0b27f94..f2fdd72c0 100644 --- a/dlgCommandLine.pas +++ b/dlgCommandLine.pas @@ -5,7 +5,7 @@ interface uses Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms, Dialogs, SynEdit, StdCtrls, ExtCtrls, Buttons, TB2Item, TBX, TBXExtItems, - Menus, TBXDkPanels; + Menus, TBXDkPanels, SpTBXControls; type TCommandLineDlg = class(TForm) @@ -16,11 +16,11 @@ TCommandLineDlg = class(TForm) OKButton: TBitBtn; BitBtn2: TBitBtn; HelpButton: TBitBtn; - cbUseCommandLine: TCheckBox; TBXButton1: TTBXButton; TBXPopupHistory: TTBXPopupMenu; PopupHistoryItem: TTBXMRUListItem; EmptyHistoryPopupItem: TTBXItem; + cbUseCommandLine: TSpTBXCheckBox; procedure btnHelpClick(Sender: TObject); procedure FormDestroy(Sender: TObject); procedure SynParametersEnter(Sender: TObject); diff --git a/dlgConfigureTools.dfm b/dlgConfigureTools.dfm index 8e7218315..ff727ae67 100644 --- a/dlgConfigureTools.dfm +++ b/dlgConfigureTools.dfm @@ -2,7 +2,6 @@ object ConfigureTools: TConfigureTools Left = 342 Top = 215 HelpContext = 710 - ActiveControl = AddBtn BorderIcons = [biSystemMenu] BorderStyle = bsDialog Caption = 'Configure Tools' @@ -24,90 +23,125 @@ object ConfigureTools: TConfigureTools 267) PixelsPerInch = 96 TextHeight = 13 - object AddBtn: TButton + object ToolsList: TListBox + Left = 8 + Top = 8 + Width = 165 + Height = 251 + Anchors = [akLeft, akTop, akRight, akBottom] + DragMode = dmAutomatic + ItemHeight = 13 + TabOrder = 5 + OnClick = ToolsListClick + OnDblClick = ModifyBtnClick + OnDragDrop = ToolsListDragDrop + OnDragOver = ToolsListDragOver + end + object AddBtn: TSpTBXButton Left = 184 Top = 12 Width = 75 Height = 25 - Anchors = [akTop, akRight] Caption = '&Add...' + Anchors = [akTop, akRight] TabOrder = 0 OnClick = AddBtnClick + LinkFont.Charset = DEFAULT_CHARSET + LinkFont.Color = clBlue + LinkFont.Height = -11 + LinkFont.Name = 'Tahoma' + LinkFont.Style = [fsUnderline] end - object RemoveBtn: TButton + object RemoveBtn: TSpTBXButton Left = 184 Top = 76 Width = 75 Height = 25 - Anchors = [akTop, akRight] Caption = '&Remove' + Anchors = [akTop, akRight] TabOrder = 2 OnClick = RemoveBtnClick + LinkFont.Charset = DEFAULT_CHARSET + LinkFont.Color = clBlue + LinkFont.Height = -11 + LinkFont.Name = 'Tahoma' + LinkFont.Style = [fsUnderline] end - object ModifyBtn: TButton + object ModifyBtn: TSpTBXButton Left = 184 Top = 44 Width = 75 Height = 25 - Anchors = [akTop, akRight] Caption = '&Modify..' + Anchors = [akTop, akRight] TabOrder = 1 OnClick = ModifyBtnClick + LinkFont.Charset = DEFAULT_CHARSET + LinkFont.Color = clBlue + LinkFont.Height = -11 + LinkFont.Name = 'Tahoma' + LinkFont.Style = [fsUnderline] end - object OKBtn: TButton + object OKBtn: TSpTBXButton Left = 184 Top = 206 Width = 75 Height = 25 - Anchors = [akRight, akBottom] Caption = 'OK' + Anchors = [akRight, akBottom] + TabOrder = 3 Default = True + LinkFont.Charset = DEFAULT_CHARSET + LinkFont.Color = clBlue + LinkFont.Height = -11 + LinkFont.Name = 'Tahoma' + LinkFont.Style = [fsUnderline] ModalResult = 1 - TabOrder = 3 end - object CancelBtn: TButton + object CancelBtn: TSpTBXButton Left = 184 Top = 238 Width = 75 Height = 25 + Caption = 'Cancel' Anchors = [akRight, akBottom] + TabOrder = 4 Cancel = True - Caption = 'Cancel' + LinkFont.Charset = DEFAULT_CHARSET + LinkFont.Color = clBlue + LinkFont.Height = -11 + LinkFont.Name = 'Tahoma' + LinkFont.Style = [fsUnderline] ModalResult = 2 - TabOrder = 4 end - object MoveUpBtn: TButton + object MoveUpBtn: TSpTBXButton Left = 184 Top = 108 Width = 75 Height = 25 - Anchors = [akTop, akRight] Caption = 'Move &Up' + Anchors = [akTop, akRight] TabOrder = 6 OnClick = MoveUpBtnClick + LinkFont.Charset = DEFAULT_CHARSET + LinkFont.Color = clBlue + LinkFont.Height = -11 + LinkFont.Name = 'Tahoma' + LinkFont.Style = [fsUnderline] end - object MoveDownBtn: TButton + object MoveDownBtn: TSpTBXButton Left = 184 Top = 140 Width = 75 Height = 25 - Anchors = [akTop, akRight] Caption = 'Move &Down' + Anchors = [akTop, akRight] TabOrder = 7 OnClick = MoveDownBtnClick - end - object ToolsList: TListBox - Left = 8 - Top = 8 - Width = 165 - Height = 251 - Anchors = [akLeft, akTop, akRight, akBottom] - DragMode = dmAutomatic - ItemHeight = 13 - TabOrder = 5 - OnClick = ToolsListClick - OnDblClick = ModifyBtnClick - OnDragDrop = ToolsListDragDrop - OnDragOver = ToolsListDragOver + LinkFont.Charset = DEFAULT_CHARSET + LinkFont.Color = clBlue + LinkFont.Height = -11 + LinkFont.Name = 'Tahoma' + LinkFont.Style = [fsUnderline] end end diff --git a/dlgConfigureTools.pas b/dlgConfigureTools.pas index 286e2be69..766d2e2b9 100644 --- a/dlgConfigureTools.pas +++ b/dlgConfigureTools.pas @@ -10,18 +10,19 @@ interface uses - SysUtils, Classes, Windows, Controls, Forms, StdCtrls; + SysUtils, Classes, Windows, Controls, Forms, StdCtrls, TBXDkPanels, + SpTBXControls; type TConfigureTools = class(TForm) - AddBtn: TButton; - RemoveBtn: TButton; - ModifyBtn: TButton; - OKBtn: TButton; - CancelBtn: TButton; - MoveUpBtn: TButton; - MoveDownBtn: TButton; ToolsList: TListBox; + AddBtn: TSpTBXButton; + RemoveBtn: TSpTBXButton; + ModifyBtn: TSpTBXButton; + OKBtn: TSpTBXButton; + CancelBtn: TSpTBXButton; + MoveUpBtn: TSpTBXButton; + MoveDownBtn: TSpTBXButton; procedure AddBtnClick(Sender: TObject); procedure ModifyBtnClick(Sender: TObject); procedure RemoveBtnClick(Sender: TObject); diff --git a/dlgConfirmReplace.dfm b/dlgConfirmReplace.dfm index 42dc0857994b6825e351fa5f11f84576c933d7c5..d3fabc4913661abc9fd243ebb60627de9af255b7 100644 GIT binary patch literal 1445 zcmd6m&5qhI6opMPZ$#j2{N`)(k>fC>bWjA&P_fy-cxV@Hlrhdw|bqsy-Q zaH^Ck{B z+Yph=A*FZ)J%TB}fBnDW)fhI?{DaJxr{*u@b-7rBh~%Dv?JP5`v;&+j5Re?;;Zx)}_v=Zjk49p?<1rU9>n~$VDp(=5H4mxHGM6L=}ayRQ4AmXAf|&2cFM2dPfvoF?Oy;g axEO3Q6DKGvkPT)Rtub4R` zzktb&BP21&zbGZOh>3}T;UjlQP-04EK3I!jQ94AuOJ-4OGDr)$4rZVZ_7JDil9K#9 s)})d=e{YZq=FJRnL$#S$kkoJj)i@{SC8y?~t7BqiV3=IZ7zlI&0A-#)9smFU diff --git a/dlgReplaceText.pas b/dlgReplaceText.pas index 34182d7a0..f4790ebd4 100644 --- a/dlgReplaceText.pas +++ b/dlgReplaceText.pas @@ -42,7 +42,7 @@ interface uses Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs, - dlgSearchText, StdCtrls, ExtCtrls; + dlgSearchText, StdCtrls, ExtCtrls, SpTBXControls, TBXDkPanels; type TTextReplaceDialog = class(TTextSearchDialog) diff --git a/dlgSearchText.dfm b/dlgSearchText.dfm index 2f5b0be4191146b536fb4a64526caa7e53e74772..eb64192708f75b4eac23607bce303c3db0fb2811 100644 GIT binary patch delta 778 zcmc(bzfZzI9L2BK(prlGaX=!34oY;Xx)~P}Aj;s61ZpsD2R&%Rao4ohAcOHgFq$q- zZjKKAAI8PS&A-CYL_k6{Y8c%vFZX%xecxUDCV7>H@5)1_0hPE}bIsyO*obXqW=zyL z@+|B@Q7PjV3J6z|`ws0~-{&sohmT!Gxlv+-d5YX5MH1k|M6O_`ZFBfGH&G5z7t6AV zY}Q2)UgLd&HLc|z(?Jw*CF7p)NMwv-eaES z>x`2Az%H!|)BJ8lL;KMYDldRZfkrXk574@;}qbfSVE-Qerjs@r_?vTmeECJk}C8@cd zc`2zCObnBEv#27O1hkGlWO5Ueg&Mm{YFc7xP6;QsZ+=Q*PEcwwki*1?Fb`-cP-!x= bfhn7FVqS7;4ktWlpaLj5nGiZbE@1!wkSk@& diff --git a/dlgSearchText.pas b/dlgSearchText.pas index d7dda0cb5..ceec24021 100644 --- a/dlgSearchText.pas +++ b/dlgSearchText.pas @@ -42,22 +42,22 @@ interface uses Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs, - StdCtrls, ExtCtrls; + StdCtrls, ExtCtrls, SpTBXControls, TBXDkPanels; type TTextSearchDialog = class(TForm) Panel1: TPanel; Label1: TLabel; cbSearchText: TComboBox; - gbSearchOptions: TGroupBox; - cbSearchCaseSensitive: TCheckBox; - cbSearchWholeWords: TCheckBox; - cbSearchFromCursor: TCheckBox; - cbSearchSelectedOnly: TCheckBox; - cbRegularExpression: TCheckBox; - rgSearchDirection: TRadioGroup; - btnOK: TButton; - btnCancel: TButton; + btnOK: TSpTBXButton; + btnCancel: TSpTBXButton; + rgSearchDirection: TSpTBXRadioGroup; + gbSearchOptions: TSpTBXGroupBox; + cbSearchCaseSensitive: TSpTBXCheckBox; + cbSearchWholeWords: TSpTBXCheckBox; + cbSearchFromCursor: TSpTBXCheckBox; + cbSearchSelectedOnly: TSpTBXCheckBox; + cbRegularExpression: TSpTBXCheckBox; procedure FormCloseQuery(Sender: TObject; var CanClose: Boolean); private function GetSearchBackwards: boolean; diff --git a/dlgSynEditOptions.dfm b/dlgSynEditOptions.dfm index a145f1869041c9bb479ecb12c33ffe5eb22d1064..17ddc4189010ec74793d3a28eecc4f6a37ebb110 100644 GIT binary patch delta 4262 zcmc(iOH3O_7{~1edu@*mfta@+3*i+Awu6bNP*Y+%A#R|h3g#goN)~%yS6=Tr>jeX9 z^H9@6A5tIFLvL-f_Q=d+0cY9Sn@-Qq-Hh+Wme1 z`R4!4_sy^JgIC`1aa+%Q8SvRkclkFs-kqAtr{Z&Hf|qPZCS)~>KKA%wP5IZDrW&Dy zrf52EPb+a{71o-MlTcof4DL^l`Q$}02krKhC}}y7d_HAtC=h_lD4YInp|4Xq$=LhzEPL)CaH!RbheOOrZ=a8_qZf;pJl$V1*` zNXD$JX0&2~aNoBLEoS#~>!u{FD3mn_>S}HY>IF&wjuqf<+mK5&1E3MRZ^-?3pq|-4H}W*o3-PfhD`=V5z?C3c2P@IC|_F4pC6fgHgx_=J*|tt%3fz1(Rmx z*Av&YY);g(LKbe&d|)}4PmJ~ugj_2o968->G^rHNqOg0u^u(REnsxZ5dx6y90x6{b zybeprnh&eYH2qxH3%Dd%iogB_&C<-QY}H2qw@z43>aR(Z9i*hi%y2@2>1 z0azya)*Axc6{67EFhXN_S*!~Un3W-{TMcm<%gtgvYB&KngRne}3pAF8#VR&pR*|so zG~T4KYFMn%CY<|4!dh=i(^$1E)-O%i)@KPT&`jM&JB#&6bAN>=9yc%2bk(s~=UN5< zrx0DQwp^mI>RGJcTYA9m3g~D(O=H)<^ys8jEMKY=JO%d)FFA z1J`IQW)FQ3z`CvyUAEvHjYVmq<`ImPU=)0?OV{VYA89NXYmILSQNZa$*L~q-8mocD znrX*vX4e$9;OuwR%vh=Sr!)_Y2b1 zJG(^E)em{P-kIoM@5+#v*AH=$z!Uv;%s3t@HPyXjsMGn3Xuxr}@o&4HK|l0N5;cc8 z*P#2ypFyYVMoZOwSF6qWrWopX^^pDD3N?EwW&`w9sFykR{t+5D*=s_~S(5L5-VhZz z&7V_6JhEpTmE>5MP0ocQu2GYWJ`MYuD#n;b{6uorzd2x|DVa9Lbc45xW#JXD8)7qpD1T!aN2lC$pd zn-lvjA)=oKJJEIC8MG%vH4T+rDcgSXe`w|QXyviiBt+jtkD(j9*5Cyi(kUqC@xo0r`+sjQ{`u delta 1881 zcmZvdO-vg{6vubhn6-CpK8+2wF-zYuh2mnu+e63WeKCMQ6!gnOBukm0|cb z^gCavPkC>0b~*ONZ1x2ff~zJlObM9MHE8I>w-0-W1~T;4RswmEAbxZwaNd><2ZyuZ zsMFw_u2;8!QI)FjDpfUSd!Gd}!qvkdbUzrQq*)YgxxiUF__uX~W$LvSnXUia_JzmJ zb}=*<@O;RS&`(1j94X#nSJn;P=(>KESjQ(mUxB6SoW9#psxBB{b5@fV41If1QDLoV z8J0~h;#t$Txk>LiMK&w0l$+svveOQdfF?__6(*JKIFiA+8vlhy-8LeTE0k9e7x~vn z#tl7-OjA$@Lt1wO^i}s91qCo9^^CZc&h>0iQ1Cev*^hR)IVpOB;#x5GFxud~EmoqS zRt$X;YdDO5V)O=^G4yeK*q!c|_(e*o9Yd?VFS((;-nS^I14F6AfE!v*%utXQLw6Hn zZm6kGqaddvzwT=={&!!6f|{_>yVAILi@IrdBuFuBj_>{x?rb0Re@Q`|7`l9{p_aFf zty2(>q2tLhai7X|DS4e@oQ4dgEFl_NPMxP9KNk8cbyB=d3H2O*KrsSllIfFf+aUcO z1$AL4G|*@Dhi@VXE_6`(po>3$7HLq9}hv6 zWzZWVm+g=FtWy7B@&~8Pe>txo%X>4LaxZeQq>GzLBw-K5GJN z2=Zq%U`nK07xFy2nrxFzBvAO!~soz*Oh|1F$ z+xzF!lczoD!fX5jEQ1}@^oy_SGEi4w&HBT!WH7LNLBkW87mB7D_i{GZJP))I zRQ=RmoE4WGN93G2vpX{+Tp@P9n@Kc0Db}U8Ozxf6 VTg+ijZ+Z!;+t$O[](){}^-=+-*/\|'; end; @@ -712,6 +718,7 @@ procedure TfmEditorOptionsDialog.GetData; var I : Integer; Item : TListItem; begin + ckWordWrap.Checked := FSynedit.WordWrap; //Gutter ckGutterVisible.Checked:= FSynEdit.Gutter.Visible; ckGutterAutosize.Checked:= FSynEdit.Gutter.AutoSize; //fixed by KF Orig: FSynEdit.Gutter.Visible; @@ -742,7 +749,6 @@ procedure TfmEditorOptionsDialog.GetData; //Options ckAutoIndent.Checked:= eoAutoIndent in FSynEdit.Options; ckDragAndDropEditing.Checked:= eoDragDropEditing in FSynEdit.Options; - ckDragAndDropFiles.Checked:= eoDropFiles in FSynEdit.Options; ckTabIndent.Checked:= eoTabIndent in FSynEdit.Options; ckSmartTabs.Checked:= eoSmartTabs in FSynEdit.Options; ckAltSetsColumnMode.Checked:= eoAltSetsColumnMode in FSynEdit.Options; @@ -796,6 +802,7 @@ procedure TfmEditorOptionsDialog.PutData; Exclude(vOptions, aOption); end; begin + fSynEdit.WordWrap := ckWordWrap.Checked; //Gutter FSynEdit.Gutter.Visible:= ckGutterVisible.Checked; FSynEdit.Gutter.AutoSize := ckGutterAutosize.Checked; @@ -825,7 +832,6 @@ procedure TfmEditorOptionsDialog.PutData; vOptions := FSynEdit.Options; //Keep old values for unsupported options SetFlag(eoAutoIndent, ckAutoIndent.Checked); SetFlag(eoDragDropEditing, ckDragAndDropEditing.Checked); - SetFlag(eoDropFiles, ckDragAndDropFiles.Checked); SetFlag(eoTabIndent, ckTabIndent.Checked); SetFlag(eoSmartTabs, ckSmartTabs.Checked); SetFlag(eoAltSetsColumnMode, ckAltSetsColumnMode.Checked); @@ -879,9 +885,9 @@ procedure TfmEditorOptionsDialog.FormCreate(Sender: TObject); Top := 55; Width := 185; Height := 21; - HotKey := 0; InvalidKeys := []; Modifiers := []; + HotKey := 0; TabOrder := 1; end; @@ -893,9 +899,9 @@ procedure TfmEditorOptionsDialog.FormCreate(Sender: TObject); Top := 87; Width := 185; Height := 21; - HotKey := 0; InvalidKeys := []; Modifiers := []; + HotKey := 0; TabOrder := 2; end; end; diff --git a/dlgSynPageSetup.dfm b/dlgSynPageSetup.dfm index 21056264c488efd8852aac165eddef132c1e6e88..c7079a50b11ec81836b72b6489af9864dd1aee1c 100644 GIT binary patch delta 2179 zcmZoU#eDV>v*>>=hL8Y9ch_Lokk9}ZA9n@=0kfAIMGadwFKIPoX6FkDE(mdonC#K2 z%N54vk(!yFQNqMOxxQ7xoI4<~C^fIdIX@@Ah?65EG0DFuCAEl&fiol{H8(Y+vLKb6 zt0bc&JTosPzr2`%0cOMvjA=Gk zXmP4SGAKZCg#bSxlLNa{xm@5TPj2WE(Zk_L0qjO?p5N8TJo#~#;N(?(&)IpP@!vC{ zoK*lAL)nuPp2*hofmm+&c_n(_*k@-;&T+~qP34CRLleqZUbu)~Vs0uMTS#I?er_T{ zdvHl*PAWHdT5)I|Fzw_3Qvd@41Jq8Z(vp(=JQ0u7M4(h~Mj|j3fo*dtnQSvLg>J5a zCR^u>)Z}cZ{0bgtCy0xHK1*fsNlh!6ytbb|6cOa`gu(?9)7>*bqm{nf(Yxt?a zBNJ{iGteD4jAXR78T@Gku^Eq+5P|33`IenK6(F65=96g6x^b zAL@n~$B+b>n3P|ZiX$EfCdkLrsGcBwrqd)r{-2@~Nc99c`OS><&5<)7GsDY8ySWyU zNOd2(OKMtTX-)|zeacF1-~5!soS@WVpp{IFXeB47b7Ed{>f{x3RVK$wF4 delta 1091 zcmX?miMizzv*>>=hL8Y9ch_Lokk9}ZA9n@=fwxaKiW;^uafVE;>(JFrWb;VPOwTA` z5@dHyEGWs$&tv2B%`7U)FH*=&EK1MJE9MAEO!6;ENiAYx*zD43%nZ`W(y6VFMJJC> zW?rg7UTJPpY7vq?9tH-Wp0-Y7?l}x_>n0!RRO3gO%?nne*rlZ(2v-7k5l?VsUP)qw zLP1exUI{`EA6U<#E_GcWOg&to#iF5w63kn2{}#HJ&>D6v2x2j~SPw+n3U z?`~wC+%j2*3*q6(?`BJ?A>6^j?w{wHSCU%9F6iv!mY)w~fdT?7G}&Rg=w!wI=b%s% znxv`giN&ShP%F&?1~I}+2Cz#fOwv#@z|_I)lwW~R$_Q4 - HotTrackFont.Charset = DEFAULT_CHARSET - HotTrackFont.Color = clWindowText - HotTrackFont.Height = -11 - HotTrackFont.Name = 'MS Shell Dlg 2' - HotTrackFont.Style = [] - end - object cbParseMessages: TJvCheckBox - Left = 232 - Top = 30 - Width = 98 - Height = 17 - Hint = - 'If checked output lines that look like messages '#13#10'will be parsed' + - ' and shown in the messages window.' - Caption = 'Parse &Messages' - Checked = True - State = cbChecked - TabOrder = 3 - LinkedControls = < - item - Control = edMessagesFormat - end - item - Control = btnStdFormats - end> - HotTrackFont.Charset = DEFAULT_CHARSET - HotTrackFont.Color = clWindowText - HotTrackFont.Height = -11 - HotTrackFont.Name = 'MS Shell Dlg 2' - HotTrackFont.Style = [] - end object edMessagesFormat: TEdit Left = 98 Top = 66 @@ -397,34 +344,6 @@ object ToolProperties: TToolProperties AutoSize = False TabOrder = 4 end - object btnStdFormats: TButton - Left = 357 - Top = 66 - Width = 19 - Height = 20 - Caption = '<' - TabOrder = 5 - OnClick = btnStdFormatsClick - end - object cbParseTraceback: TJvCheckBox - Left = 233 - Top = 47 - Width = 100 - Height = 17 - Hint = - 'If checked output lines that look like messages '#13#10'will be parsed' + - ' and shown in the messages window.' - Caption = 'Parse &Traceback' - Checked = True - State = cbChecked - TabOrder = 6 - LinkedControls = <> - HotTrackFont.Charset = DEFAULT_CHARSET - HotTrackFont.Color = clWindowText - HotTrackFont.Height = -11 - HotTrackFont.Name = 'MS Shell Dlg 2' - HotTrackFont.Style = [] - end object cbStandardInput: TComboBox Left = 68 Top = 16 @@ -466,6 +385,63 @@ object ToolProperties: TToolProperties 'Active file' 'New file') end + object btnStdFormats: TSpTBXButton + Left = 357 + Top = 66 + Width = 19 + Height = 20 + Caption = '<' + TabOrder = 5 + OnClick = btnStdFormatsClick + LinkFont.Charset = DEFAULT_CHARSET + LinkFont.Color = clBlue + LinkFont.Height = -11 + LinkFont.Name = 'Tahoma' + LinkFont.Style = [fsUnderline] + end + object cbCaptureOutput: TSpTBXCheckBox + Left = 232 + Top = 13 + Width = 94 + Height = 15 + Caption = '&Capture Output' + ParentColor = True + TabOrder = 2 + Checked = True + State = cbChecked + ThemeType = thtWindows + end + object cbParseMessages: TSpTBXCheckBox + Left = 232 + Top = 30 + Width = 95 + Height = 15 + Hint = + 'If checked output lines that look like messages '#13#10'will be parsed' + + ' and shown in the messages window.' + Caption = 'Parse &Messages' + ParentColor = True + TabOrder = 3 + OnClick = cbParseMessagesClick + Checked = True + State = cbChecked + ThemeType = thtWindows + end + object cbParseTraceback: TSpTBXCheckBox + Left = 233 + Top = 47 + Width = 97 + Height = 15 + Hint = + 'If checked output lines that look like messages '#13#10'will be parsed' + + ' and shown in the messages window.' + Caption = 'Parse &Traceback' + ParentColor = True + TabOrder = 6 + Checked = True + State = cbChecked + ThemeType = thtWindows + end end object JvGroupBox5: TJvGroupBox Left = 4 @@ -482,53 +458,45 @@ object ToolProperties: TToolProperties Caption = '&Timeout (ms):' FocusControl = seTimeout end - object cbHideConsole: TJvCheckBox + object seTimeout: TJvSpinEdit + Left = 312 + Top = 16 + Width = 65 + Height = 21 + Hint = + 'If set to a value <> 0 then you will be prompted '#13#10'to abort the ' + + 'program after the specified time.' + CheckMinValue = True + Increment = 100.000000000000000000 + TabOrder = 2 + end + object cbHideConsole: TSpTBXCheckBox Left = 8 Top = 16 - Width = 81 - Height = 17 + Width = 78 + Height = 15 Hint = 'Check to hide the console.' Caption = '&Hide console' + ParentColor = True + TabOrder = 0 Checked = True State = cbChecked - TabOrder = 0 - LinkedControls = <> - HotTrackFont.Charset = DEFAULT_CHARSET - HotTrackFont.Color = clWindowText - HotTrackFont.Height = -11 - HotTrackFont.Name = 'MS Shell Dlg 2' - HotTrackFont.Style = [] - end - object cbWaitForTermination: TJvCheckBox + ThemeType = thtWindows + end + object cbWaitForTermination: TSpTBXCheckBox Left = 104 Top = 16 - Width = 119 - Height = 17 + Width = 116 + Height = 15 Hint = 'If checked will monitor the process '#13#10'and notify you when is ter' + 'minated.' Caption = '&Wait for Termination' + ParentColor = True + TabOrder = 1 Checked = True State = cbChecked - TabOrder = 1 - LinkedControls = <> - HotTrackFont.Charset = DEFAULT_CHARSET - HotTrackFont.Color = clWindowText - HotTrackFont.Height = -11 - HotTrackFont.Name = 'MS Shell Dlg 2' - HotTrackFont.Style = [] - end - object seTimeout: TJvSpinEdit - Left = 312 - Top = 16 - Width = 65 - Height = 21 - Hint = - 'If set to a value <> 0 then you will be prompted '#13#10'to abort the ' + - 'program after the specified time.' - CheckMinValue = True - Increment = 100.000000000000000000 - TabOrder = 2 + ThemeType = thtWindows end end end @@ -598,86 +566,139 @@ object ToolProperties: TToolProperties TabOrder = 1 end end - object cbUseCustomEnv: TJvCheckBox + object cbUseCustomEnv: TSpTBXCheckBox Left = 123 Top = 369 - Width = 160 - Height = 17 + Width = 157 + Height = 15 Caption = 'Use Customized Environment' + ParentColor = True TabOrder = 2 - LinkedControls = <> - HotTrackFont.Charset = DEFAULT_CHARSET - HotTrackFont.Color = clWindowText - HotTrackFont.Height = -11 - HotTrackFont.Name = 'MS Shell Dlg 2' - HotTrackFont.Style = [] + ThemeType = thtWindows end - object TBXButton1: TTBXButton + object TBXButton1: TSpTBXButton Left = 4 Top = 243 Width = 64 Height = 24 Action = actAddItem - ButtonStyle = bsFlat - ImageIndex = 49 - Images = CommandsDataModule.Images TabOrder = 3 + Images = CommandsDataModule.Images + ImageIndex = 49 + LinkFont.Charset = DEFAULT_CHARSET + LinkFont.Color = clBlue + LinkFont.Height = -11 + LinkFont.Name = 'Tahoma' + LinkFont.Style = [fsUnderline] end - object TBXButton3: TTBXButton + object TBXButton3: TSpTBXButton Left = 75 Top = 243 Width = 64 Height = 24 Action = actDeleteItem - ButtonStyle = bsFlat - ImageIndex = 14 - Images = CommandsDataModule.Images TabOrder = 4 + Images = CommandsDataModule.Images + ImageIndex = 14 + LinkFont.Charset = DEFAULT_CHARSET + LinkFont.Color = clBlue + LinkFont.Height = -11 + LinkFont.Name = 'Tahoma' + LinkFont.Style = [fsUnderline] end - object TBXButton4: TTBXButton + object TBXButton4: TSpTBXButton Left = 146 Top = 243 Width = 80 Height = 24 Action = actMoveUp - ButtonStyle = bsFlat - ImageIndex = 47 - Images = CommandsDataModule.Images TabOrder = 5 + Images = CommandsDataModule.Images + ImageIndex = 47 + LinkFont.Charset = DEFAULT_CHARSET + LinkFont.Color = clBlue + LinkFont.Height = -11 + LinkFont.Name = 'Tahoma' + LinkFont.Style = [fsUnderline] end - object TBXButton5: TTBXButton + object TBXButton5: TSpTBXButton Left = 233 Top = 243 Width = 84 Height = 24 Action = actMoveDown - ButtonStyle = bsFlat - ImageIndex = 48 - Images = CommandsDataModule.Images TabOrder = 6 + Images = CommandsDataModule.Images + ImageIndex = 48 + LinkFont.Charset = DEFAULT_CHARSET + LinkFont.Color = clBlue + LinkFont.Height = -11 + LinkFont.Name = 'Tahoma' + LinkFont.Style = [fsUnderline] end - object TBXButton2: TTBXButton + object TBXButton2: TSpTBXButton Left = 324 Top = 243 Width = 66 Height = 24 Action = actUpdateItem - ButtonStyle = bsFlat - ImageIndex = 39 - Images = CommandsDataModule.Images TabOrder = 7 + Images = CommandsDataModule.Images + ImageIndex = 39 + LinkFont.Charset = DEFAULT_CHARSET + LinkFont.Color = clBlue + LinkFont.Height = -11 + LinkFont.Name = 'Tahoma' + LinkFont.Style = [fsUnderline] end end end - object btnHelp: TButton - Left = 317 + object btnOK: TSpTBXButton + Left = 149 Top = 436 Width = 75 Height = 25 + Caption = 'OK' + Anchors = [akRight, akBottom] + TabOrder = 0 + Default = True + LinkFont.Charset = DEFAULT_CHARSET + LinkFont.Color = clBlue + LinkFont.Height = -11 + LinkFont.Name = 'Tahoma' + LinkFont.Style = [fsUnderline] + ModalResult = 1 + end + object btnCancel: TSpTBXButton + Left = 233 + Top = 436 + Width = 75 + Height = 25 + Caption = 'Cancel' Anchors = [akRight, akBottom] + TabOrder = 1 + Cancel = True + LinkFont.Charset = DEFAULT_CHARSET + LinkFont.Color = clBlue + LinkFont.Height = -11 + LinkFont.Name = 'Tahoma' + LinkFont.Style = [fsUnderline] + ModalResult = 2 + end + object btnHelp: TSpTBXButton + Left = 317 + Top = 436 + Width = 75 + Height = 25 Caption = '&Help' + Anchors = [akRight, akBottom] TabOrder = 3 OnClick = btnHelpClick + LinkFont.Charset = DEFAULT_CHARSET + LinkFont.Color = clBlue + LinkFont.Height = -11 + LinkFont.Name = 'Tahoma' + LinkFont.Style = [fsUnderline] end end object FormatsPopup: TPopupMenu diff --git a/dlgToolProperties.pas b/dlgToolProperties.pas index 38f1a8225..980e119e5 100644 --- a/dlgToolProperties.pas +++ b/dlgToolProperties.pas @@ -12,15 +12,13 @@ interface uses Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms, - Dialogs, cTools, ExtCtrls, StdCtrls, JvExStdCtrls, JvCheckBox, SynEdit, + Dialogs, cTools, ExtCtrls, StdCtrls, SynEdit, JvGroupBox, ComCtrls, JvExComCtrls, JvHotKey, Mask, JvExMask, - JvSpin, Menus, ActnList, TBXDkPanels; + JvSpin, Menus, ActnList, TBXDkPanels, SpTBXControls, JvExStdCtrls; type TToolProperties = class(TForm) Panel1: TPanel; - btnOK: TButton; - btnCancel: TButton; FormatsPopup: TPopupMenu; Filename1: TMenuItem; Linenumber1: TMenuItem; @@ -42,8 +40,6 @@ TToolProperties = class(TForm) SynApplication: TSynEdit; SynParameters: TSynEdit; SynWorkDir: TSynEdit; - btnAppDir: TButton; - btnWorkDir: TButton; JvGroupBox4: TJvGroupBox; Label4: TLabel; Label8: TLabel; @@ -53,16 +49,10 @@ TToolProperties = class(TForm) Label10: TLabel; Label11: TLabel; Label12: TLabel; - cbCaptureOutput: TJvCheckBox; - cbParseMessages: TJvCheckBox; edMessagesFormat: TEdit; - btnStdFormats: TButton; JvGroupBox5: TJvGroupBox; Label9: TLabel; - cbHideConsole: TJvCheckBox; - cbWaitForTermination: TJvCheckBox; seTimeout: TJvSpinEdit; - cbParseTraceback: TJvCheckBox; lvItems: TListView; JvGroupBox6: TJvGroupBox; Label15: TLabel; @@ -75,17 +65,27 @@ TToolProperties = class(TForm) actMoveDown: TAction; actUpdateItem: TAction; edEnvValue: TEdit; - cbUseCustomEnv: TJvCheckBox; - btnHelp: TButton; - TBXButton1: TTBXButton; - TBXButton3: TTBXButton; - TBXButton4: TTBXButton; - TBXButton5: TTBXButton; - TBXButton2: TTBXButton; cbStandardInput: TComboBox; cbStandardOutput: TComboBox; cbContext: TComboBox; cbSaveFiles: TComboBox; + btnOK: TSpTBXButton; + btnCancel: TSpTBXButton; + btnAppDir: TSpTBXButton; + btnWorkDir: TSpTBXButton; + btnStdFormats: TSpTBXButton; + btnHelp: TSpTBXButton; + cbCaptureOutput: TSpTBXCheckBox; + cbParseMessages: TSpTBXCheckBox; + cbParseTraceback: TSpTBXCheckBox; + cbHideConsole: TSpTBXCheckBox; + cbWaitForTermination: TSpTBXCheckBox; + cbUseCustomEnv: TSpTBXCheckBox; + TBXButton1: TSpTBXButton; + TBXButton3: TSpTBXButton; + TBXButton4: TSpTBXButton; + TBXButton5: TSpTBXButton; + TBXButton2: TSpTBXButton; procedure FormShow(Sender: TObject); procedure btnStdFormatsClick(Sender: TObject); procedure Filename1Click(Sender: TObject); @@ -105,6 +105,7 @@ TToolProperties = class(TForm) Change: TItemChange); procedure ActionListUpdate(Action: TBasicAction; var Handled: Boolean); procedure btnHelpClick(Sender: TObject); + procedure cbParseMessagesClick(Sender: TObject); private { Private declarations } fEnvStrings : TStrings; @@ -178,7 +179,6 @@ function EditTool(Tool : TExternalTool) : Boolean; Environment.Add(lvItems.Items[i].Caption + '=' + lvItems.Items[i].SubItems[0]); end; end; - cbParseMessages.LinkedControls.Clear; // workaround to JVCL bug in JvCheckBox finally Release; end; @@ -192,7 +192,7 @@ procedure TToolProperties.btnStdFormatsClick(Sender: TObject); FormatsPopup.Popup(p.x, p.y); end; -procedure TToolProperties.Filename1Click(Sender: TObject); +procedure TToolProperties.Filename1Click(Sender: TObject); begin case (Sender as TMenuItem).Tag of 0: edMessagesFormat.SelText := GrepFileNameParam; @@ -243,6 +243,12 @@ procedure TToolProperties.btnWorkDirClick(Sender: TObject); end; end; +procedure TToolProperties.cbParseMessagesClick(Sender: TObject); +begin + edMessagesFormat.Enabled := cbParseMessages.Checked; + btnStdFormats.Enabled := cbParseMessages.Checked; +end; + procedure TToolProperties.btnAppDirClick(Sender: TObject); begin with CommandsDataModule.dlgFileOpen do begin diff --git a/dlgUnitTestWizard.dfm b/dlgUnitTestWizard.dfm index 8e11af33e..5c9ffec95 100644 --- a/dlgUnitTestWizard.dfm +++ b/dlgUnitTestWizard.dfm @@ -58,7 +58,7 @@ object UnitTestWizard: TUnitTestWizard ParentFont = False end object ExplorerTree: TVirtualStringTree - Left = 3 + Left = 2 Top = 83 Width = 395 Height = 319 @@ -97,7 +97,6 @@ object UnitTestWizard: TUnitTestWizard Width = 75 Height = 25 Anchors = [akRight, akBottom] - Caption = '&OK' TabOrder = 1 Kind = bkOK end @@ -107,7 +106,6 @@ object UnitTestWizard: TUnitTestWizard Width = 75 Height = 25 Anchors = [akRight, akBottom] - Caption = '&Cancel' TabOrder = 2 Kind = bkCancel end diff --git a/dmCommands.dfm b/dmCommands.dfm index f90afb852..35a9bb2a5 100644 --- a/dmCommands.dfm +++ b/dmCommands.dfm @@ -4,11 +4,6 @@ object CommandsDataModule: TCommandsDataModule OnDestroy = DataModuleDestroy Height = 335 Width = 663 - object dlgFileOpen: TOpenDialog - Options = [ofHideReadOnly, ofPathMustExist, ofEnableSizing] - Left = 20 - Top = 16 - end object actlMain: TActionList Images = Images Left = 21 @@ -86,7 +81,6 @@ object CommandsDataModule: TCommandsDataModule object actEditUndo: TEditUndo Category = 'Edit' Caption = '&Undo' - Enabled = False HelpContext = 320 HelpType = htContext Hint = 'Undo|Reverts the last action' @@ -533,7 +527,7 @@ object CommandsDataModule: TCommandsDataModule Caption = 'Check For &Updates' HelpContext = 350 HelpType = htContext - Hint = 'Check wheter a newer version of PyScripter is available' + Hint = 'Check whether a newer version of PyScripter is available' OnExecute = actCheckForUpdatesExecute end object actUnitTestWizard: TAction @@ -592,11 +586,40 @@ object CommandsDataModule: TCommandsDataModule Hint = 'Use UTF8 enconding without BOM' OnExecute = actEditFileEncodingExecute end - end - object dlgFileSave: TSaveDialog - Options = [ofOverwritePrompt, ofHideReadOnly, ofPathMustExist, ofNoReadOnlyReturn, ofEnableSizing] - Left = 20 - Top = 68 + object actFileReload: TAction + Category = 'File' + Caption = '&Reload' + Enabled = False + HelpContext = 310 + HelpType = htContext + Hint = 'Reload|Reload active file' + ImageIndex = 120 + OnExecute = actFileReloadExecute + end + object actImportShortcuts: TAction + Category = 'Import/Export' + Caption = 'Import Shortcuts' + Hint = 'Import Shortcuts' + OnExecute = actImportShortcutsExecute + end + object actExportShortCuts: TAction + Category = 'Import/Export' + Caption = 'Export Shortcuts' + Hint = 'Export Shortcuts' + OnExecute = actExportShortCutsExecute + end + object actImportHighlighters: TAction + Category = 'Import/Export' + Caption = 'Import Highlighters' + Hint = 'Import Syntax Highlighters' + OnExecute = actImportHighlightersExecute + end + object actExportHighlighters: TAction + Category = 'Import/Export' + Caption = 'Export Highlighters' + Hint = 'Export Syntax Highlighters' + OnExecute = actExportHighlightersExecute + end end object SynPythonSyn: TSynPythonSyn DefaultFilter = 'Python Files (*.py;*.pyw)|*.py;*.pyw' @@ -1565,130 +1588,256 @@ object CommandsDataModule: TCommandsDataModule Left = 30 Top = 188 Bitmap = { - 494C01017A007C00040010001000FFFFFFFFFF10FFFFFFFFFFFFFFFF424D3600 - 000000000000360000002800000040000000F0010000010020000000000000F0 - 010000000000000000000000000000000000000000000000000000000000EADD - CB00AB7734009655000096550000AB773400EADDCB0000000000000000000000 + 494C01017E008100040010001000FFFFFFFFFF10FFFFFFFFFFFFFFFF424D3600 + 0000000000003600000028000000400000001002000001002000000000000010 + 0200000000000000000000000000000000000000000000000000000000000000 + 0000000000000000000000000000000000000000000000000000000000000000 + 0000000000000000000000000000000000000000000000000000000000000000 + 0000000000000000000000000000000000000000000000000000000000000000 + 0000000000000000000000000000000000000000000000000000000000000000 + 0000000000000000000000000000000000000000000000000000000000000000 + 0000000000000000000000000000000000000000000000000000000000000000 + 0000000000000000000000000000000000000000000000000000000000000000 + 0000000000000000000000000000000000000000000000000000000000000000 + 0000000000000000000000000000000000000000000000000000000000000000 + 0000000000000000000000000000000000000000000000000000000000000000 + 0000000000000000000000000000000000000000000000000000000000000000 + 0000000000000000000000000000000000000000000000000000000000000000 + 0000000000000000000000000000000000000000000000000000000000000000 + 0000000000000000000000000000000000000000000000000000000000000000 + 0000000000000000000000000000000000000000000000000000000000000000 + 0000000000000000000000000000000000000000000000000000000000000000 + 0000000000000000000000000000000000000000000000000000000000000000 + 0000000000000000000000000000000000000000000000000000000000000000 + 0000000000000000000000000000000000000000000000000000000000000000 + 0000000000000000000000000000000000000000000000000000000000000000 + 0000000000000000000000000000000000000000000000000000000000000000 + 0000000000000000000000000000000000000000000000000000000000000000 + 0000000000000000000000000000000000000000000000000000000000000000 + 0000000000000000000000000000000000000000000000000000000000000000 + 0000000000000000000000000000000000000000000000000000000000000000 + 0000000000000000000000000000000000000000000000000000000000000000 + 0000000000000000000000000000000000000000000000000000000000000000 + 0000000000000000000000000000000000000000000000000000000000000000 + 0000000000000000000000000000000000000000000000000000000000000000 + 0000000000000000000000000000000000000000000000000000000000000000 + 0000000000000000000000000000000000000000000000000000000000000000 + 0000000000000000000000000000000000000000000000000000000000000000 + 0000000000000000000000000000000000000000000000000000000000000000 + 0000000000000000000000000000000000000000000000000000000000000000 + 0000000000000000000000000000000000000000000000000000000000000000 + 0000000000000000000000000000000000000000000000000000000000000000 + 0000000000000000000000000000000000000000000000000000000000000000 + 0000000000000000000000000000000000000000000000000000000000000000 + 0000000000000000000000000000000000000000000000000000000000000000 + 0000000000000000000000000000000000000000000000000000000000000000 + 0000000000000000000000000000000000000000000000000000000000000000 + 0000000000000000000000000000000000000000000000000000000000000000 + 0000000000000000000000000000000000000000000000000000000000000000 + 0000000000000000000000000000000000000000000000000000000000000000 + 0000000000000000000000000000000000000000000000000000000000000000 + 0000000000000000000000000000000000000000000000000000000000000000 + 0000000000000000000000000000000000000000000000000000000000000000 + 0000000000000000000000000000000000000000000000000000000000000000 + 0000000000000000000000000000000000000000000000000000000000000000 + 0000000000000000000000000000000000000000000000000000000000000000 + 0000000000000000000000000000000000000000000000000000000000000000 + 0000000000000000000000000000000000000000000000000000000000000000 + 0000000000000000000000000000000000000000000000000000000000000000 + 0000000000000000000000000000000000000000000000000000000000000000 + 0000000000000000000000000000000000000000000000000000000000000000 + 0000000000000000000000000000000000000000000000000000000000000000 + 0000000000000000000000000000000000000000000000000000000000000000 + 0000000000000000000000000000000000000000000000000000000000000000 + 0000000000000000000000000000000000000000000000000000000000000000 + 0000000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 + 0000000000000000000000000000000000000000000000000000000000000000 + 0000000000000000000000000000000000000000000000000000000000000000 + 0000000000000000000000000000000000000000000000000000000000000000 + 0000000000000000000000000000000000000000000000000000000000000000 + 0000000000000000000000000000000000000000000000000000000000000000 + 0000000000000000000000000000000000000000000000000000000000000000 + 0000000000000000000000000000000000000000000000000000000000000000 + 0000000000000000000000000000000000000000000000000000000000000000 + 0000000000000000000000000000000000000000000000000000000000000000 + 0000000000000000000000000000000000000000000000000000000000000000 + 0000000000000000000000000000000000000000000000000000000000000000 + 0000000000000000000000000000000000000000000000000000000000000000 + 0000000000000000000000000000000000000000000000000000000000000000 + 0000000000000000000000000000000000000000000000000000000000000000 + 0000000000000000000000000000000000000000000000000000000000000000 + 0000000000000000000000000000000000000000000000000000000000000000 + 0000000000000000000000000000000000000000000000000000000000000000 + 0000000000000000000000000000000000000000000000000000000000000000 + 0000000000000000000000000000000000000000000000000000000000000000 + 0000000000000000000000000000000000000000000000000000000000000000 + 0000000000000000000000000000000000000000000000000000000000000000 + 0000000000000000000000000000000000000000000000000000000000000000 + 0000000000000000000000000000000000000000000000000000000000000000 + 0000000000000000000000000000000000000000000000000000000000000000 + 0000000000000000000000000000000000000000000000000000000000000000 + 0000000000000000000000000000000000000000000000000000000000000000 + 0000000000000000000000000000000000000000000000000000000000000000 + 0000000000000000000000000000000000000000000000000000000000000000 + 0000000000000000000000000000000000000000000000000000000000000000 + 0000000000000000000000000000000000000000000000000000000000000000 + 0000000000000000000000000000000000000000000000000000000000000000 + 0000000000000000000000000000000000000000000000000000000000000000 + 0000000000000000000000000000000000000000000000000000000000000000 + 0000000000000000000000000000000000000000000000000000000000000000 + 0000000000000000000000000000000000000000000000000000000000000000 + 0000000000000000000000000000000000000000000000000000000000000000 + 0000000000000000000000000000000000000000000000000000000000000000 + 0000000000000000000000000000000000000000000000000000000000000000 + 0000000000000000000000000000000000000000000000000000000000000000 + 0000000000000000000000000000000000000000000000000000000000000000 + 0000000000000000000000000000000000000000000000000000000000000000 + 0000000000000000000000000000000000000000000000000000000000000000 + 0000000000000000000000000000000000000000000000000000000000000000 + 0000000000000000000000000000000000000000000000000000000000000000 + 0000000000000000000000000000000000000000000000000000000000000000 + 0000000000000000000000000000000000000000000000000000000000000000 + 0000000000000000000000000000000000000000000000000000000000000000 + 0000000000000000000000000000000000000000000000000000000000000000 + 0000000000000000000000000000000000000000000000000000000000000000 + 0000000000000000000000000000000000000000000000000000000000000000 + 0000000000000000000000000000000000000000000000000000000000000000 + 0000000000000000000000000000000000000000000000000000000000000000 + 0000000000000000000000000000000000000000000000000000000000000000 + 0000000000000000000000000000000000000000000000000000000000000000 + 0000000000000000000000000000000000000000000000000000000000000000 + 0000000000000000000000000000000000000000000000000000000000000000 + 0000000000000000000000000000000000000000000000000000000000000000 + 0000000000000000000000000000000000000000000000000000000000000000 + 0000000000000000000000000000000000000000000000000000000000000000 + 0000000000000000000000000000000000000000000000000000000000000000 + 0000000000000000000000000000000000000000000000000000000000000000 + 0000000000000000000000000000000000000000000000000000000000000000 + 0000000000000000000000000000000000000000000000000000000000000000 + 0000000000000000000000000000000000000000000000000000000000000000 + 0000000000000000000000000000000000000000000000000000000000000000 + 0000000000000000000000000000000000000000000000000000000000000000 + 0000000000000000000000000000000000000000000000000000000000000000 + 0000000000000000000000000000000000000000000000000000000000001267 + 9B0012679B000000000000000000000000000000000000000000000000000000 000000000000000000004A563100000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000EADDCB009655 - 0000FFFCF200FFFCF200FFFCF200FFFCF20096550000EADDCB0000000000C7A5 - 9100C19E8A00BB948000B38A7500AE836E000000000000000000000000000000 + 0000000000000000000000000000000000000000000000000000000000000000 + 0000000000000000000000000000000000000000000000000000000000001267 + 9B0062CEF80012679B0000000000000000000000000000000000000000000000 00000000000000000000000000003D4828000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000AB773400FFF4 - D800FFFAEC00FFFAED00FFFAEC008F6F3400FFFCF400AB773400000000000000 0000000000000000000000000000000000000000000000000000000000000000 + 00000000000000000000000000000000000000000000126DA200126DA200126D + A20081D5F80062CEF800126DA200000000000000000000000000000000000000 000000000000000000000000000032412300B1AEB100B1AEB100000000000000 0000000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 - 000000000000000000000000000000000000000000000000000096550000FFF5 - DD00FFFBF2008F6F340096550000FFFCF200FFFDF7009655000000000000C7A5 - 9100C19E8A00BB948000B38A7500AE836E000000000000000000000000004A56 + 0000000000000000000000000000000000000000000000000000000000000000 + 0000000000000000000000000000000000001774AA007AD5F80099E5F80099E5 + F80099E5F80099E5F8007AD5F8001774AA000000000000000000000000004A56 31000000000000000000000000003239200079621D0078631D0079631D007962 1D00000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000CCAC8300FFF9 - EB00FFFDF70096550000FFFDF700FFFDF700FFFEFA0096550000000000000000 0000000000000000000000000000000000000000000000000000000000000000 + 00000000000000000000000000001C81B10089DDF800B1EDF800B1EDF800B1ED + F800B1EDF800B1EDF80081D5F000177BB1000000000000000000000000000000 0000454E2D00B1AEB10079651F007965200087C9A60081C79F0079C295002B7C 3A0078641F000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000CBDCC60083B4 - 740056953E00598A3A005B9844009CC19000F5F8F500AB77340000000000C7A5 - 9100C19E8A00BB948000B38A7500AE836E000000000000000000000000000000 + 0000000000000000000000000000000000000000000000000000000000000000 + 00009BA6950000000000000000001C81B100E8F5F800B1EDF8001C81B1001C81 + B100E8F5F800A9DDF0001C81B100000000000000000000000000000000000000 000039452800B1AEB100796721009CD2B80099D2B50091CEAE003C8D530079C3 96007A662200B1AEB100000000004A4E31000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 - 00000000000000000000000000000000000000000000ADCEA3005597430068A4 - 5D0063A45B005CA054005BA4550053994600599A4800EADDCB00000000000000 0000000000000000000000000000000000000000000000000000000000000000 + 00000000000065725E00000000001C81B100EFFAFE001C81B100000000001C81 + B100E8F5F8001C81B10000000000000000000000000000000000000000000000 0000323E23007A682400AEDCC600B4DFCB00AEDBC70058A7730091CEAF0081C7 9F007A682400323920003D4E2D00000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 - 000000000000000000000000000000000000DBE6D9004E933C004C984800B7D2 - B800B9D3B8003D883A003B8C3700509E5000549C4B005B9B4A00F5F8F500C39F - 8C00BE998400B78F7B00B2887300AE836E00000000000000000000000000454E + 00000000000000000000000000000000000000000000000000009FA99A000000 + 0000C8C5B800534E1E007A793C00868350002D85A80000000000000000001C81 + B1001C81B100000000000000000000000000000000000000000000000000454E 3100394528007B6A2700C2E7D500CCEBDB007FC19200AEDBC60099D2B60087C9 A6007A6B27000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 - 0000000000000000000000000000000000007FB07200488D3C0049904400B1CE - B00000000000B8D2B6004C8D4500448F3E00569E4F00529241008EB880000000 + 0000000000000000000000000000000000000000000000000000000000006977 + 66008775430098C1930089D2B4004FAB7B009D966C0000000000A1A89E000000 0000000000000000000000000000000000000000000053563800535638000000 0000B1AEB1007B6D2A00CCEADB00DBF3E700CCEBDB00B4DFCB009DD2B8007C6D 2A00B1AEB1000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 - 00000000000000000000000000000000000044842D00357F2F00327D2A00ADCB - AD000000000000000000B9D3B8003D843500387C2F005B9A51005B9443000000 + 0000000000000000000000000000000000000000000000000000000000004344 + 1900AFC79C00B5E6D5007FBF970089D2B40073773B006C775E00BBBFBB000000 0000000000000000000000000000000000000000000000000000000000000000 00007C6E2B00AFDCC700226A2E00CCEBDB00C2E6D500AEDCC6007B6F2C00B1AE B100B1AEB1003D4E2D004A563100000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 - 000000000000000000000000000000000000498432003E773A003A763600ADCA - AD00000000000000000000000000C5DCCB003B884A00639256005E9343000000 + 000000000000000000000000000000000000000000008A928100A1A8A000786D + 4A00B1C69D00D0F4E700B5E5D30098C39A008A7E590000000000000000000000 000000000000000000000000000000000000000000000000000000000000B1AE B1007C702D00DBF3E700AFDBC7007C702D007C702D007C702D00000000003239 2000394128000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 - 0000000000000000000000000000000000004E8D410054925A004F8F5400B7D0 - B7000000000000000000F8FFFE0076DCAE0059A36C006DA46C005F974D000000 + 0000000000000000000000000000000000000000000000000000000000009B90 + 5E007FC4A300B1C9A000ABC5970082774A008B8D8E007D8E7800C2C7C3000000 000000000000000000000000000000000000000000004A5631004A4E3100454E 2D003D4828007C702D007C702D00B1AEB10039452800B1AEB100000000000000 0000000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 - 00000000000000000000000000000000000070A76000589D5D005EA67200C2D5 - C00000000000F6FFFB0060D59D0048A3650060A46F005FA36C007FB173000000 + 0000000000000000000000000000000000000000000083907C006A755E007780 + 4F00948C5900726945007A6F4B00000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 0000B1AEB1003D482D00B1AEB1000000000000000000454E3100000000000000 0000000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 - 000000000000000000000000000000000000CBDAC60054934A006EB48700A6D8 - BA00F0FEF9005FD59E0058B4810078B992006EB486005A984E00DAE4D7000000 + 000000000000000000000000000000000000000000000000000000000000979C + 9500000000000000000075816F00000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 0000000000004A4E310000000000000000000000000053563800000000000000 0000000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 - 0000000000000000000000000000000000000000000095BD870056974D002ECE - 850072DEAE006DBF980081BA960067A671005E985200B0CFA500000000000000 + 000000000000000000000000000000000000000000000000000000000000B7BB + B7000000000000000000C5C7C500000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 0000000000004E56380000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000BCD2B3006CB6 - 7400469344005D9149005D964D008DB88100C5DABE0000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 @@ -1697,133 +1846,263 @@ object CommandsDataModule: TCommandsDataModule 0000000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 + 00000000000000000000000000000000000000000000BFBFBF00BFBFBF00BFBF + BF00BFBFBF00BFBFBF00BFBFBF00BFBFBF00BFBFBF00BFBFBF00BFBFBF00BFBF + BF00BFBFBF00BFBFBF000000000000000000000000000000000000000000EADD + CB00AB7734009655000096550000AB773400EADDCB0000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 000000000000000000000000000080800000C0C0C00000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000001267 - 9B0012679B000000000000000000000000000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 + 00000000000000000000000000000000000000000000BFBFBF00E5E5E500E5E5 + E500E6E6E600E6E6E600A74A1F00DBCFCC00E5E5E500E5E5E500E4E4E400E4E4 + E400E4E4E400BFBFBF0000000000000000000000000000000000EADDCB009655 + 0000FFFCF200FFFCF200FFFCF200FFFCF20096550000EADDCB0000000000C7A5 + 9100C19E8A00BB948000B38A7500AE836E000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 + 00000000000000000000000000000000000000000000BFBFBF00E8E8E800E8E8 + E800E9E9E900A74A1F00A9542F00A74A1F009C514400D3BCBC00E7E7E700E6E6 + E600E4E4E400BFBFBF0000000000000000000000000000000000AB773400FFF4 + D800FFFAEC00FFFAED00FFFAEC008F6F3400FFFCF400AB773400000000000000 0000000000000000000000000000000000000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000001267 - 9B0062CEF80012679B00000000000000000000000000000000000000000061A5 - C2001C7EA7001C7EA7001C7EA70061A6C2000000000061A5C2001C7EA7001C7E - A7001C7EA70061A6C20000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000808000000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 00000000000000000000000000000000000000000000126DA200126DA200126D - A20081D5F80062CEF800126DA200000000000000000000000000000000001E82 - AA00D9F6FE00D9F6FE00D9F6FE001E82AA00000000001E82AA00D9F6FE00D9F6 - FE00D9F6FE001E82AA0000000000000000000000000000000000000000000000 + 00000000000000000000000000000000000000000000BFBFBF00EBEBEB00EBEB + EB00A74A1F00C6792400B1572200CC822400CC822400B4492200E8E1DB00E8E8 + E800E7E7E700BFBFBF000000000000000000000000000000000096550000FFF5 + DD00FFFBF2008F6F340096550000FFFCF200FFFDF7009655000000000000C7A5 + 9100C19E8A00BB948000B38A7500AE836E000000000000000000000000000000 0000000000000000000000000000000000000000000000000000848484000000 0000000000000000000000000000000000000000000000000000000000000000 000000000000000000000000000080800000C0C0C00000000000000000000000 + 00000000000000000000000000000000000000000000BFBFBF00EDEDED00EEEE + EE00EEEEEE00DFA32F00DFA32F00EEEEEE00EAE0D600E7BB8000E0A87E00EBEB + EB00E9E9E900BFBFBF0000000000000000000000000000000000CCAC8300FFF9 + EB00FFFDF70096550000FFFDF700FFFDF700FFFEFA0096550000000000000000 0000000000000000000000000000000000000000000000000000000000000000 - 0000000000000000000000000000000000001774AA007AD5F80099E5F80099E5 - F80099E5F80099E5F8007AD5F8001774AA000000000000000000000000001F85 - AD00CBF2FD00B4ECFC00CBF2FD001F85AD00000000001F85AD00CBF2FD00B5EC - FD00CBF2FD001F85AD0000000000000000000000000000000000000000000000 000000000000000000000000000000000000000000000000000000000000FF00 0000FF0000000000000000000000000000000000000080800000808000008080 0000000000000000000000000000C0C0C00080808000C0C0C000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 00000000000000000000000000001C81B10089DDF800B1EDF800B1EDF800B1ED - F800B1EDF800B1EDF80081D5F000177BB1000000000000000000000000002089 - AF00B6ECFD0097E3FC00B7EBFD002089AF00000000002089AF00B6ECFD0097E3 - FC00B7EBFD002089AF0000000000000000000000000000000000000000000000 + 00000000000000000000000000000000000000000000BFBFBF00F0F0F000F0F0 + F000F1F1F100F1F1F100DFA32F00F1F1F100F0F0F000EFECE800E7C08600EDED + ED00ECECEC00BFBFBF0000000000000000000000000000000000CBDCC60083B4 + 740056953E00598A3A005B9844009CC19000F5F8F500AB77340000000000C7A5 + 9100C19E8A00BB948000B38A7500AE836E000000000000000000000000000000 000000000000000000000000000000000000000000008400000084000000FF00 0000FF000000FF00000000000000000000000000000000000000000000000000 00000000000000000000C0C0C000000000000000000080800000000000000000 + 00000000000000000000000000000000000000000000BFBFBF00F2F2F200EFDF + CF00E5B18D00F3F3F300F3F3F300F3F3F300F2F2F200F2F2F200F1F1F100EFEF + EF00EEEEEE00BFBFBF00000000000000000000000000ADCEA3005597430068A4 + 5D0063A45B005CA054005BA4550053994600599A4800EADDCB00000000000000 0000000000000000000000000000000000000000000000000000000000000000 - 00009BA6950000000000000000001C81B100E8F5F800B1EDF8001C81B1001C81 - B100E8F5F800A9DDF0001C81B10000000000000000000000000000000000228D - B200A8E7FC0083DDFB00A8E7FC00228DB20000000000228DB200A8E7FC0083DD - FB00A8E7FC00228DB20000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000084000000840000008400 0000FF000000FF000000FF000000000000000000000080800000808000008080 0000000000000000000080800000C0C0C000C0C0C00080800000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 00000000000065725E00000000001C81B100EFFAFE001C81B100000000001C81 - B100E8F5F8001C81B10000000000000000000000000000000000000000002391 - B600B8EBFD0098E3FB00B8EBFD002391B600000000002391B600B8EBFD0099E3 - FC00B8EBFD002391B60000000000000000000000000000000000000000000000 + 00000000000000000000000000000000000000000000BFBFBF00F4F4F400F4F1 + EC00E3A35500C46C5300D7B8B800F5F5F500A74A1F00F4F4F400F3F3F300F1F1 + F100F0F0F000BFBFBF000000000000000000DBE6D9004E933C004C984800B7D2 + B800B9D3B8003D883A003B8C3700509E5000549C4B005B9B4A00F5F8F500C39F + 8C00BE998400B78F7B00B2887300AE836E000000000000000000000000000000 0000000000000000000000000000000000000000000084000000840000008400 000084000000FF000000FF000000000000000000000000000000000000000000 00000000000000000000C0C0C0008080000080800000C0C0C000000000000000 - 00008080000000000000000000000000000000000000000000009FA99A000000 - 0000C8C5B800534E1E007A793C00868350002D85A80000000000000000001C81 - B1001C81B1000000000000000000000000000000000000000000000000002594 - B800CEF2FD00B9EDFD00CEF2FE002594B800000000002594B800CEF2FD00B9ED - FC00CEF2FE002594B80000000000000000000000000000000000000000000000 + 00008080000000000000000000000000000000000000BFBFBF00F5F5F500F6F6 + F600F2E2C100DFA43800C3711E00C3711E00A74A1F008F311D00F4F4F400F3F3 + F300F1F1F100BFBFBF0000000000000000007FB07200488D3C0049904400B1CE + B00000000000B8D2B6004C8D4500448F3E00569E4F00529241008EB880000000 + 0000000000000000000000000000000000000000000000000000000000000000 000000000000000000000000000000000000FF000000FF000000840000008400 0000840000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 - 000080800000C0C0C00000000000000000000000000000000000000000006977 - 66008775430098C1930089D2B4004FAB7B009D966C0000000000A1A89E000000 - 0000000000000000000000000000000000000000000000000000000000002697 - BA00E4F9FE00D9F7FD00E5F9FE002697BA00000000002697BA00E4F9FE00D9F6 - FD00E5F9FE002697BA0000000000000000000000000000000000000000000000 + 000080800000C0C0C000000000000000000000000000BFBFBF00F7F7F700F8F8 + F800F8F8F800F6EACA00CC822400CC822400A74A1F00B65E260098381800F4F4 + F400F3F3F300BFBFBF00000000000000000044842D00357F2F00327D2A00ADCB + AD000000000000000000B9D3B8003D843500387C2F005B9A51005B9443000000 + 0000000000000000000000000000000000000000000000000000000000000000 000000000000000000000000000000000000FF000000FF000000FF0000008400 0000000000000000000000000000000000000000000080800000C0C0C0000000 0000C0C0C0008080000000000000000000008080800000000000000000000000 - 0000C0C0C0008080000000000000000000000000000000000000000000004344 - 1900AFC79C00B5E6D5007FBF970089D2B40073773B006C775E00BBBFBB000000 - 000000000000000000000000000000000000000000000000000000000000279A - BD00F4FEFE00EFFDFE00F4FEFE00279ABD0000000000279ABD00F4FEFE00EFFD - FE00F4FEFE00279ABD0000000000000000000000000000000000000000000000 + 0000C0C0C00080800000000000000000000000000000BFBFBF00F8F8F800F9F9 + F900FAFAFA00FAFAFA00FAFAFA00FAFAFA00CC822400DFA32F00F7F7F700F5F5 + F500F4F4F400BFBFBF000000000000000000498432003E773A003A763600ADCA + AD00000000000000000000000000C5DCCB003B884A00639256005E9343000000 + 0000000000000000000000000000000000000000000000000000000000000000 00000000000000000000000000000000000000000000FF000000FF000000FF00 00000000000000000000000000000000000000000000C0C0C00080800000C0C0 C00080800000C0C0C00000000000000000008080000000000000000000000000 - 0000C0C0C00080800000C0C0C00000000000000000008A928100A1A8A000786D - 4A00B1C69D00D0F4E700B5E5D30098C39A008A7E590000000000000000000000 - 000000000000000000000000000000000000000000000000000000000000289C - BE00F7FEFE00F4FEFE00F4FEFE00289CBE0000000000289CBE00F7FEFE00F4FE - FE00F4FEFE00289CBE0000000000000000000000000000000000000000000000 + 0000C0C0C00080800000C0C0C0000000000000000000BFBFBF00F9F9F900FAFA + FA00FBFBFB00FBFBFB00FBFBFB00FBFBFB00DFA32F00BFBFBF00BFBFBF00BFBF + BF00BFBFBF00BFBFBF0000000000000000004E8D410054925A004F8F5400B7D0 + B7000000000000000000F8FFFE0076DCAE0059A36C006DA46C005F974D000000 + 0000000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000FF000000FF00 0000000000000000000000000000000000000000000000000000C0C0C0008080 0000C0C0C0000000000080808000808000008080000080800000808080000000 - 000080800000C0C0C00080800000000000000000000000000000000000009B90 - 5E007FC4A300B1C9A000ABC5970082774A008B8D8E007D8E7800C2C7C3000000 - 00000000000000000000000000000000000000000000000000000000000069BA - D200289CBE00289CBE00289CBE0069BAD2000000000069BAD200289CBE00289C - BE00289CBE0069BAD20000000000000000000000000000000000000000000000 + 000080800000C0C0C000808000000000000000000000BFBFBF00FAFAFA00FBFB + FB00FBFBFB00FCFCFC00FCFCFC00FBFBFB00FBFBFB00BFBFBF00D4D4D400E9E9 + E900BFBFBF0000000000000000000000000070A76000589D5D005EA67200C2D5 + C00000000000F6FFFB0060D59D0048A3650060A46F005FA36C007FB173000000 + 0000000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000C0C0C0008080 0000C0C0C000000000000000000000000000808000000000000000000000C0C0 - C000808000000000000080800000C0C0C0000000000083907C006A755E007780 - 4F00948C5900726945007A6F4B00000000000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 + C000808000000000000080800000C0C0C00000000000BFBFBF00FAFAFA00FBFB + FB00FCFCFC00FCFCFC00FCFCFC00FBFBFB00FBFBFB00BFBFBF00E9E9E900BFBF + BF0000000000000000000000000000000000CBDAC60054934A006EB48700A6D8 + BA00F0FEF9005FD59E0058B4810078B992006EB486005A984E00DAE4D7000000 0000000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 00000000000000000000000000000000000000000000C0C0C00080800000C0C0 C00080800000C0C0C00000000000000000008080800000000000000000008080 - 0000C0C0C00000000000C0C0C00080800000000000000000000000000000979C - 9500000000000000000075816F00000000000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 + 0000C0C0C00000000000C0C0C0008080000000000000BFBFBF00FAFAFA00FBFB + FB00FCFCFC00FCFCFC00FCFCFC00FBFBFB00FBFBFB00BFBFBF00BFBFBF000000 + 0000000000000000000000000000000000000000000095BD870056974D002ECE + 850072DEAE006DBF980081BA960067A671005E985200B0CFA500000000000000 0000000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000080800000C0C0C0000000 0000C0C0C0008080000000000000000000000000000000000000000000008080 - 000000000000000000000000000080800000000000000000000000000000B7BB - B7000000000000000000C5C7C500000000000000000000000000000000000000 + 00000000000000000000000000008080000000000000BFBFBF00BFBFBF00BFBF + BF00BFBFBF00BFBFBF00BFBFBF00BFBFBF00BFBFBF00BFBFBF00000000000000 + 0000000000000000000000000000000000000000000000000000BCD2B3006CB6 + 7400469344005D9149005D964D008DB88100C5DABE0000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 + 000000000000000000000000000000000000000000000000007F192632FF131D + 269F05180C6F1354297F0B3A215F000000000000000000000000000000000000 + 000000000000000000000000000000000000A1A1A1006058500098988F000000 0000000000000000000000000000000000000000000000000000000000000000 + 000000000000000000000000000000000000A1A1A1006058500098988F000000 0000000000000000000000000000000000000000000000000000000000000000 - 000000000000000000000000000000000000EFEFEF00313163009C9C6300EFEF + 0000000000000000000000000000000000000000000000000000000000000000 + 0000000000000000000000000000000000000000000000000000000000000000 + 000000000000000000000000000000000000000000000000006F6599C7FF6496 + C4FF2F465CFF115634FF23AE60FF177443BF1157329F1A8249FF1B7946EF1157 + 325F0000000000000000000000000000000098B6CA00607BD400845058008484 + 8400000000000000000000000000000000000000000000000000000000000000 + 00000000000000000000000000000000000098B6CA00607BD400845058008484 + 8400000000000000000000000000000000000000000000000000000000000000 + 00000000000000000000000000000000000000000000000000000000000061A5 + C2001C7EA7001C7EA7001C7EA70061A6C2000000000061A5C2001C7EA7001C7E + A7001C7EA70061A6C2000000000000000000000000000000003F5883ABFF4A70 + 92FF0C6B87FF0C89A6FF176649FF22986BFF239B6AFF208B77FF1E8181FF1F8B + 67FF155C318F16643BCF197346DF0C391C2F8FE0FF002AA1FF00586ACA008458 + 58008F8F8F000000000000000000000000000000000000000000000000000000 + 0000000000000000000000000000000000008FE0FF002AA1FF00586ACA008458 + 58008F8F8F000000000000000000000000000000000000000000000000000000 + 0000000000000000000000000000000000000000000000000000000000001E82 + AA00D9F6FE00D9F6FE00D9F6FE001E82AA00000000001E82AA00D9F6FE00D9F6 + FE00D9F6FE001E82AA000000000000000000000000000000002F224A5BFF139C + AAFF17BAE9FF0E8CAFFF096376FF166060FF1E8181FF1E8181FF1E8181FF1868 + 68FF1E8181FF1E8181FF1E827FFF155F44AF000000008FE0FF0023ABFF005073 + D4007B505800ABABAB0000000000000000000000000000000000000000000000 + 000000000000000000000000000000000000000000008FE0FF0023ABFF005073 + D4007B505800ABABAB0000000000000000000000000000000000000000000000 + 0000000000000000000000000000000000000000000000000000000000001F85 + AD00CBF2FD00B4ECFC00CBF2FD001F85AD00000000001F85AD00CBF2FD00B5EC + FD00CBF2FD001F85AD000000000000000000000000000000000F042C329F129C + ABFF15A6BAFF16B6E7FF0E96B8FF073D46FF166060FF166060FF1047478F0C33 + 334F145656BF0F40407F0B30307F145858FFC0C0CA00C0C0CA00487BA10016A1 + FF00506AC000484040007B7373006A585000736058005848480073737300ABAB + AB00A1A1A100A1A1A1000000000000000000C0C0CA00C0C0CA00487BA10016A1 + FF00506AC000484040007B7373006A585000736058005848480073737300ABAB + AB00A1A1A100A1A1A10000000000000000000000000000000000000000002089 + AF00B6ECFD0097E3FC00B7EBFD002089AF00000000002089AF00B6ECFD0097E3 + FC00B7EBFD002089AF0000000000000000000000006F0000007F0202022F0533 + 3ACF18C7DAFF149FBBFF13A7D5FF0D95B5FF0E4346FF145656BF0000000F0000 + 0000000000000000000000000000061C1C8FA1583100A1583100A1502A0073AB + CA0084A1B600AB7B6A00FFEAAB00FFFFEA00FFFFFF00FFFFFF008F6A6000481C + 1100CA7B5800603116000000000000000000A1583100A1583100A1502A0073AB + CA0084A1B600AB7B6A00FFEAAB00FFFFEA00FFFFFF00FFFFFF008F6A6000481C + 1100CA7B5800603116000000000000000000000000000000000000000000228D + B200A8E7FC0083DDFB00A8E7FC00228DB20000000000228DB200A8E7FC0083DD + FB00A8E7FC00228DB20000000000000000000807383F15118EFF1B834AFF1B83 + 49FF168262FF17A9B1FF15A4CBFF0F8EB3FF0B89A6FF145858FF176363CF0000 + 000F00000000000000000000000000000000EAC08400E0FFFF00E0FFFF00D4F4 + F400C0ABAB00EAC08F00F4F4B600F4F4C00099362F00F4FFFF00FFFFFF006A60 + 5800CAF4FF007B6050000000000000000000EAC08400E0FFFF00E0FFFF00D4F4 + F400C0ABAB00EAC08F00F4F4B600F4F4C000EAF4D400F4FFFF00FFFFFF006A60 + 5800CAF4FF007B60500000000000000000000000000000000000000000002391 + B600B8EBFD0098E3FB00B8EBFD002391B600000000002391B600B8EBFD0099E3 + FC00B8EBFD002391B6000000000000000000000000000A1237DF1B1FAFFF1041 + 2DFF1B8143FF21A35BFF116458FF17B8E8FF0E8CAEFF085768FF1C7878FF0C37 + 376F00000000000000000000000000000000E0AB6A00C0EAFF00B6CAD400B6C0 + CA00CAAB8F00E0CA9800D4C08F00D4E0B60099362F00E0E0E000FFFFEA00AB98 + 7B008F98A100735850000000000000000000E0AB6A00C0EAFF00B6CAD400B6C0 + CA00CAAB8F00E0CA9800D4C08F00D4E0B600D4E0D400E0E0E000FFFFEA00AB98 + 7B008F98A1007358500000000000000000000000000000000000000000002594 + B800CEF2FD00B9EDFD00CEF2FE002594B800000000002594B800CEF2FD00B9ED + FC00CEF2FE002594B80000000000000000001359347F1A834BFF1A834CFF1878 + 45FF082B19FF0E4020FF21A35CFF147565FF16B6E6FF0E96B8FF0A4249FF1352 + 52AF00000000000000000000000000000000E0AB6A00C0EAFF00B6CAD400B6C0 + CA00CAAB9800D4C08F0099362F0099362F0099362F0099362F0099362F00CAAB + 84008F98A1007B5848000000000000000000E0AB6A00C0EAFF00B6CAD400B6C0 + CA00CAAB9800D4C08F0099362F0099362F0099362F0099362F00EAF4CA00CAAB + 84008F98A1007B58480000000000000000000000000000000000000000002697 + BA00E4F9FE00D9F7FD00E5F9FE002697BA00000000002697BA00E4F9FE00D9F6 + FD00E5F9FE002697BA0000000000000000001B834BFF23A461FF21996BFF23A7 + 60FF23AE62FF1A8248FF104A25FF23AE64FF169095FF13A7D4FF0C89A6FF0319 + 1CBF00000000000000000000000000000000E0AB6A00C0EAFF00B6CAD400B6CA + D400CAAB9800E0E0AB00D4C09800D4CA980099362F00E0D4AB00FFFFC000AB84 + 6A00B6CAD4007B5848000000000000000000E0AB6A00C0EAFF00B6CAD400B6CA + D400CAAB9800E0E0AB00D4C09800D4CA9800D4D4AB00E0D4AB00FFFFC000AB84 + 6A00B6CAD4007B5848000000000000000000000000000000000000000000279A + BD00F4FEFE00EFFDFE00F4FEFE00279ABD0000000000279ABD00F4FEFE00EFFD + FE00F4FEFE00279ABD000000000000000000186C4EDF0D3838FF104848FF1E81 + 81FF208B75FF24A95EFF21A35BFF23AD60FF166F4CFF16B0DAFF0F8DB2FF0A7D + 97FF0000003F000000000000000000000000E0AB6A00CAEAFF00C0D4D400C0D4 + D400B6B6AB00D4C0B600EAF4F400E0D4AB0099362F00F4EAA100EAC084008F73 + 7300F4FFFF007B5840000000000000000000E0AB6A00CAEAFF00C0D4D400C0D4 + D400B6B6AB00D4C0B600EAF4F400E0D4AB00EACA8F00F4EAA100EAC084008F73 + 7300F4FFFF007B5840000000000000000000000000000000000000000000289C + BE00F7FEFE00F4FEFE00F4FEFE00289CBE0000000000289CBE00F7FEFE00F4FE + FE00F4FEFE00289CBE0000000000000000000A2B2B2F186767EF1E8181FF1E81 + 81FF1E8181FF1E837EFF229569FF229569FF147373FF17B8CAFF17B7E8FF0D80 + 9EFF384E54EF0000000F0000000000000000E0AB6A00C0EAFF00B6CAD400B6CA + D400B6CAD400ABA1A100CAB6AB00E0CA9800EACA8F00E0B68F00A1847B00B6CA + D400FFFFFF007B5840000000000000000000E0AB6A00C0EAFF00B6CAD400B6CA + D400B6CAD400ABA1A100CAB6AB00E0CA9800EACA8F00E0B68F00A1847B00B6CA + D400FFFFFF007B584000000000000000000000000000000000000000000069BA + D200289CBE00289CBE00289CBE0069BAD2000000000069BAD200289CBE00289C + BE00289CBE0069BAD2000000000000000000000000000000000F1B5A5ADF3F78 + 79FF418081FF3F7879FF1A7171FF166060FF05282DDF15B8CAFF1E95A8FF6E8E + 99FF202121FF46454DBF0000000000000000E0AB6A00CAEAFF00C0CAE000C0D4 + E000C0D4E000C0E0EA00B6B6C000A1989800ABA1AB00B6B6C000CAEAF400D4F4 + FF00FFFFFF007B5840000000000000000000E0AB6A00CAEAFF00C0CAE000C0D4 + E000C0D4E000C0E0EA00B6B6C000A1989800ABA1AB00B6B6C000CAEAF400D4F4 + FF00FFFFFF007B58400000000000000000000000000000000000000000000000 + 0000000000000000000000000000000000000000000000000000000000000000 + 00000000000000000000000000000000000000000000000000004974757F594F + 4AFF5D7C7CFF481C15FF104242FF0F40407F0000000F2A4549EF636364FF4141 + 42FF8D8EA6FF6868BEFF0000003F00000000EAB67B00CAF4FF00C0E0EA00C0E0 + EA00CAEAF400CAEAF400CAEAF400D4F4FF00CAF4FF00CAEAFF00CAEAF400D4F4 + F400FFFFFF007B5840000000000000000000EAB67B00CAF4FF00C0E0EA00C0E0 + EA00CAEAF400CAEAF400CAEAF400D4F4FF00CAF4FF00CAEAFF00CAEAF400D4F4 + F400FFFFFF007B58400000000000000000000000000000000000000000000000 + 0000000000000000000000000000000000000000000000000000000000000000 + 0000000000000000000000000000000000000000000000000000162E2E7F5078 + 78FF497172FF455D5DFF1E6868FF0A2B2B5F000000000000003F6B6A7DFF797A + ADFF6F6FC9FF37345D8F0000000000000000AB500B00AB581100AB581100AB58 + 1100AB581100AB581100AB581100AB581100AB581100B66A1600B66A1600B66A + 16008F6A50006A3811000000000000000000AB500B00AB581100AB581100AB58 + 1100AB581100AB581100AB581100AB581100AB581100B66A1600B66A1600B66A + 16008F6A50006A38110000000000000000000000000000000000000000000000 + 0000000000000000000000000000000000000000000000000000000000000000 + 00000000000000000000000000000000000000000000000000000000001F155C + 5CDF104646AF165E5EEF145656BF0000000F000000000000000038355E6F5C59 + A0DF1A172A4F000000000000000000000000D4600600E06A0600E06A0600E06A + 0600E06A0600E06A0600E06A0600E06A0600E06A0600E06A0600E06A0600E06A + 0600E06A0600987348000000000000000000D4600600E06A0600E06A0600E06A + 0600E06A0600E06A0600E06A0600E06A0600E06A0600E06A0600E06A0600E06A + 0600E06A0600987348000000000000000000EFEFEF00313163009C9C6300EFEF EF00000000000000000000000000000000000000000000000000000000000000 000000000000000000000000000000000000EFEFEF00313163009C9C6300EFEF EF00000000000000000000000000000000000000000000000000000000000000 @@ -5536,16 +5815,24 @@ object CommandsDataModule: TCommandsDataModule 0000000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 000000000000000000000000000000000000424D3E000000000000003E000000 - 2800000040000000F00100000100010000000000800F00000000000000000000 - 000000000000000000000000FFFFFF00E07FFDFF00000000C020FEFF00000000 - C03FFE3F00000000C020EE0F00000000C03FF00700000000C020F00200000000 - 803FF001000000000000E00700000000081F9007000000000C1FF00100000000 - 0E1FE027000000000C1F803F00000000081FF1BF00000000001FFBBF00000000 - 803FFBFF00000000C07FFFFF00000000FFFFFFFFFE7FFFE7FFFFFFFFFFFFFFE3 - E0837FFFFEFFFF81E083BFC7FE7FFF00E083DF838E3FFE00E083EF01FDBFF601 - E083F7008C3FFA23E083FB00FC37D067E083FC01FFF3E05FE083FE079373E01F - E083FF078371807FE083FF87C411E01FE083FFCFC76481FFFFFFFFEF8364EDFF - FFFFFFF793EEEDFFFFFFFFFFFFFFFFFF0FFF0FFFE7E3FFFF0FFF0FFFC1C18EFF + 2800000040000000100200000100010000000000801000000000000000000000 + 000000000000000000000000FFFFFF0000000000000000000000000000000000 + 0000000000000000000000000000000000000000000000000000000000000000 + 0000000000000000000000000000000000000000000000000000000000000000 + 0000000000000000000000000000000000000000000000000000000000000000 + 00000000000000000000000000000000FFE7FDFF00000000FFE3FEFF00000000 + FF81FE3F00000000FF00EE0F00000000FE00F00700000000F601F00200000000 + FA23F00100000000D067E00700000000E05F900700000000E01FF00100000000 + 807FE02700000000E01F803F0000000081FFF1BF00000000EDFFFBBF00000000 + EDFFFBFF00000000FFFFFFFF000000008003E07FFFFFFE7F8003C020FFFFFFFF + 8003C03F7FFFFEFF8003C020BFC7FE7F8003C03FDF838E3F8003C020EF01FDBF + 8003803FF7008C3F80030000FB00FC378003081FFC01FFF380030C1FFE079373 + 80030E1FFF07837180030C1FFF87C4118007081FFFCFC764800F001FFFEF8364 + 801F803FFFF793EE803FC07FFFFFFFFFFFFF81FF1FFF1FFFFFFF800F0FFF0FFF + E083800007FF07FFE083800083FF83FFE083800000030003E083001E00030003 + E083000F00030003E083800F00030003E083000F00030003E083000F00030003 + E083000700030003E083000300030003E083800300030003FFFFC00100030003 + FFFFC08300030003FFFFC0C7000300030FFF0FFFE7E3FFFF0FFF0FFFC1C18EFF 07FF07FFE087807F81FF81FFE0078007C1BFC19FF0078007E107E10FF81F8003 F001F003A0078001F800F80180008001F805F80500008000F800F80000008000 F800F800FC3F8000F800F800FC3F8000F801F801FC1F8000FD00FD00FC3FC1C0 @@ -5669,130 +5956,256 @@ object CommandsDataModule: TCommandsDataModule Left = 100 Top = 187 Bitmap = { - 494C01017A007C00040010001000FFFFFFFFFF10FFFFFFFFFFFFFFFF424D3600 - 000000000000360000002800000040000000F0010000010020000000000000F0 - 010000000000000000000000000000000000000000000000000000000000C1C1 - C200C1C1C200C1C1C200C1C1C200C1C1C200C1C1C20000000000000000000000 + 494C01017E008100040010001000FFFFFFFFFF10FFFFFFFFFFFFFFFF424D3600 + 0000000000003600000028000000400000001002000001002000000000000010 + 0200000000000000000000000000000000000000000000000000000000000000 + 0000000000000000000000000000000000000000000000000000000000000000 + 0000000000000000000000000000000000000000000000000000000000000000 + 0000000000000000000000000000000000000000000000000000000000000000 + 0000000000000000000000000000000000000000000000000000000000000000 + 0000000000000000000000000000000000000000000000000000000000000000 + 0000000000000000000000000000000000000000000000000000000000000000 + 0000000000000000000000000000000000000000000000000000000000000000 + 0000000000000000000000000000000000000000000000000000000000000000 + 0000000000000000000000000000000000000000000000000000000000000000 + 0000000000000000000000000000000000000000000000000000000000000000 + 0000000000000000000000000000000000000000000000000000000000000000 + 0000000000000000000000000000000000000000000000000000000000000000 + 0000000000000000000000000000000000000000000000000000000000000000 + 0000000000000000000000000000000000000000000000000000000000000000 + 0000000000000000000000000000000000000000000000000000000000000000 + 0000000000000000000000000000000000000000000000000000000000000000 + 0000000000000000000000000000000000000000000000000000000000000000 + 0000000000000000000000000000000000000000000000000000000000000000 + 0000000000000000000000000000000000000000000000000000000000000000 + 0000000000000000000000000000000000000000000000000000000000000000 + 0000000000000000000000000000000000000000000000000000000000000000 + 0000000000000000000000000000000000000000000000000000000000000000 + 0000000000000000000000000000000000000000000000000000000000000000 + 0000000000000000000000000000000000000000000000000000000000000000 + 0000000000000000000000000000000000000000000000000000000000000000 + 0000000000000000000000000000000000000000000000000000000000000000 + 0000000000000000000000000000000000000000000000000000000000000000 + 0000000000000000000000000000000000000000000000000000000000000000 + 0000000000000000000000000000000000000000000000000000000000000000 + 0000000000000000000000000000000000000000000000000000000000000000 + 0000000000000000000000000000000000000000000000000000000000000000 + 0000000000000000000000000000000000000000000000000000000000000000 + 0000000000000000000000000000000000000000000000000000000000000000 + 0000000000000000000000000000000000000000000000000000000000000000 + 0000000000000000000000000000000000000000000000000000000000000000 + 0000000000000000000000000000000000000000000000000000000000000000 + 0000000000000000000000000000000000000000000000000000000000000000 + 0000000000000000000000000000000000000000000000000000000000000000 + 0000000000000000000000000000000000000000000000000000000000000000 + 0000000000000000000000000000000000000000000000000000000000000000 + 0000000000000000000000000000000000000000000000000000000000000000 + 0000000000000000000000000000000000000000000000000000000000000000 + 0000000000000000000000000000000000000000000000000000000000000000 + 0000000000000000000000000000000000000000000000000000000000000000 + 0000000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 + 0000000000000000000000000000000000000000000000000000000000000000 + 0000000000000000000000000000000000000000000000000000000000000000 + 0000000000000000000000000000000000000000000000000000000000000000 + 0000000000000000000000000000000000000000000000000000000000000000 + 0000000000000000000000000000000000000000000000000000000000000000 + 0000000000000000000000000000000000000000000000000000000000000000 + 0000000000000000000000000000000000000000000000000000000000000000 + 0000000000000000000000000000000000000000000000000000000000000000 + 0000000000000000000000000000000000000000000000000000000000000000 + 0000000000000000000000000000000000000000000000000000000000000000 + 0000000000000000000000000000000000000000000000000000000000000000 + 0000000000000000000000000000000000000000000000000000000000000000 + 0000000000000000000000000000000000000000000000000000000000000000 + 0000000000000000000000000000000000000000000000000000000000000000 + 0000000000000000000000000000000000000000000000000000000000000000 + 0000000000000000000000000000000000000000000000000000000000000000 + 0000000000000000000000000000000000000000000000000000000000000000 + 0000000000000000000000000000000000000000000000000000000000000000 + 0000000000000000000000000000000000000000000000000000000000000000 + 0000000000000000000000000000000000000000000000000000000000000000 + 0000000000000000000000000000000000000000000000000000000000000000 + 0000000000000000000000000000000000000000000000000000000000000000 + 0000000000000000000000000000000000000000000000000000000000000000 + 0000000000000000000000000000000000000000000000000000000000000000 + 0000000000000000000000000000000000000000000000000000000000000000 + 0000000000000000000000000000000000000000000000000000000000000000 + 0000000000000000000000000000000000000000000000000000000000000000 + 0000000000000000000000000000000000000000000000000000000000000000 + 0000000000000000000000000000000000000000000000000000000000000000 + 0000000000000000000000000000000000000000000000000000000000000000 + 0000000000000000000000000000000000000000000000000000000000000000 + 0000000000000000000000000000000000000000000000000000000000000000 + 0000000000000000000000000000000000000000000000000000000000000000 + 0000000000000000000000000000000000000000000000000000000000000000 + 0000000000000000000000000000000000000000000000000000000000000000 + 0000000000000000000000000000000000000000000000000000000000000000 + 0000000000000000000000000000000000000000000000000000000000000000 + 0000000000000000000000000000000000000000000000000000000000000000 + 0000000000000000000000000000000000000000000000000000000000000000 + 0000000000000000000000000000000000000000000000000000000000000000 + 0000000000000000000000000000000000000000000000000000000000000000 + 0000000000000000000000000000000000000000000000000000000000000000 + 0000000000000000000000000000000000000000000000000000000000000000 + 0000000000000000000000000000000000000000000000000000000000000000 + 0000000000000000000000000000000000000000000000000000000000000000 + 0000000000000000000000000000000000000000000000000000000000000000 + 0000000000000000000000000000000000000000000000000000000000000000 + 0000000000000000000000000000000000000000000000000000000000000000 + 0000000000000000000000000000000000000000000000000000000000000000 + 0000000000000000000000000000000000000000000000000000000000000000 + 0000000000000000000000000000000000000000000000000000000000000000 + 0000000000000000000000000000000000000000000000000000000000000000 + 0000000000000000000000000000000000000000000000000000000000000000 + 0000000000000000000000000000000000000000000000000000000000000000 + 0000000000000000000000000000000000000000000000000000000000000000 + 0000000000000000000000000000000000000000000000000000000000000000 + 0000000000000000000000000000000000000000000000000000000000000000 + 0000000000000000000000000000000000000000000000000000000000000000 + 0000000000000000000000000000000000000000000000000000000000000000 + 0000000000000000000000000000000000000000000000000000000000000000 + 0000000000000000000000000000000000000000000000000000000000000000 + 0000000000000000000000000000000000000000000000000000000000000000 + 0000000000000000000000000000000000000000000000000000000000000000 + 0000000000000000000000000000000000000000000000000000000000000000 + 0000000000000000000000000000000000000000000000000000000000000000 + 0000000000000000000000000000000000000000000000000000000000000000 + 0000000000000000000000000000000000000000000000000000000000000000 + 0000000000000000000000000000000000000000000000000000000000000000 + 0000000000000000000000000000000000000000000000000000000000000000 + 0000000000000000000000000000000000000000000000000000000000000000 + 0000000000000000000000000000000000000000000000000000000000000000 + 0000000000000000000000000000000000000000000000000000000000000000 + 0000000000000000000000000000000000000000000000000000000000000000 + 0000000000000000000000000000000000000000000000000000000000000000 + 0000000000000000000000000000000000000000000000000000000000000000 + 0000000000000000000000000000000000000000000000000000000000000000 + 0000000000000000000000000000000000000000000000000000000000000000 + 0000000000000000000000000000000000000000000000000000000000000000 + 0000000000000000000000000000000000000000000000000000000000000000 + 0000000000000000000000000000000000000000000000000000000000000000 + 0000000000000000000000000000000000000000000000000000000000000000 + 0000000000000000000000000000000000000000000000000000000000000000 + 000000000000000000000000000000000000000000000000000000000000C1C1 + C200C1C1C2000000000000000000000000000000000000000000000000000000 00000000000000000000C1C1C200000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000C1C1C2009C94 - 8A00FCFBFA00FCFBFA00FCFBFA00FCFBFA009C948A00C1C1C20000000000C1C1 - C200C1C1C200C1C1C200C1C1C200C1C1C2000000000000000000000000000000 + 0000000000000000000000000000000000000000000000000000000000000000 + 000000000000000000000000000000000000000000000000000000000000C1C1 + C200C4D1D600C1C1C20000000000000000000000000000000000000000000000 0000000000000000000000000000C1C1C2000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000C1C1C200F6F4 - F100FAF9F800FAF9F800FAF9F800A6A29B00FCFCFB00C1C1C200000000000000 0000000000000000000000000000000000000000000000000000000000000000 + 00000000000000000000000000000000000000000000C1C1C200C1C1C20096A3 + A800CFDADE00C4D1D600C1C1C200000000000000000000000000000000000000 0000000000000000000000000000C1C1C200C1C1C200C1C1C200000000000000 0000000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000C1C1C200F7F6 - F300FCFBFA00A6A29B009C948A00FCFBFA00FDFDFC00C1C1C20000000000C1C1 - C200C1C1C200C1C1C200C1C1C200C1C1C200000000000000000000000000C1C1 + 0000000000000000000000000000000000000000000000000000000000000000 + 000000000000000000000000000000000000C1C1C200CCD8DC00D8E2E400D8E2 + E400D8E2E400D8E2E400CCD8DC00C1C1C200000000000000000000000000C1C1 C200000000000000000000000000C1C1C200979E9200989E9200C1C1C200C1C1 C200000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000C1C1C200F4F3 - F200FDFDFC009C948A00FDFDFC00FDFDFC00FEFEFD00C1C1C200000000000000 0000000000000000000000000000000000000000000000000000000000000000 + 0000000000000000000000000000C1C1C200D2DDE000E1E9EA00E1E9EA00E1E9 + EA00E1E9EA00E1E9EA00CDD8DB00C1C1C2000000000000000000000000000000 0000C1C1C200C1C1C200C1C1C2009AA19500C6CFCA00C4CDC800BFC9C30099A5 9C00C1C1C2000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000C1C1C200C1C1 - C200C1C1C200C1C1C200C1C1C200C1C1C200FAFAFA00C1C1C20000000000C1C1 - C200C1C1C200C1C1C200C1C1C200C1C1C2000000000000000000000000000000 + 0000000000000000000000000000000000000000000000000000000000000000 + 0000C1C1C2000000000000000000C1C1C200F5F7F700E1E9EA00C1C1C200A0AD + B100F5F7F700DCE3E500C1C1C200000000000000000000000000000000000000 0000C1C1C200D0D0D0009CA39700D1D8D400CFD6D200CBD3CF00A4AFA800BFC9 C3009CA39700C1C1C20000000000C1C1C2000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 - 00000000000000000000000000000000000000000000C1C1C200B0B5B000B1B8 - B000AFB7AE00ABB3AA00ACB5AB00A6AEA400C1C1C200C1C1C200000000000000 0000000000000000000000000000000000000000000000000000000000000000 + 000000000000C1C1C20000000000C1C1C200F8FAFA00C1C1C20000000000C1C1 + C200F5F7F700C1C1C20000000000000000000000000000000000000000000000 0000C1C1C2009FA69A00DAE0DD00DCE2DF00D9DFDC00B2BCB600CBD3CF00C4CD C8009FA69A00C1C1C200C1C1C200000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 - 000000000000000000000000000000000000C1C1C200AEB3AD00A5AEA400DADD - DA00DBDEDB009BA59B009BA59B00A8B2A800A7B0A600C1C1C20000000000C1C1 - C200C1C1C200C1C1C200C1C1C200C1C1C200000000000000000000000000C1C1 + 0000000000000000000000000000000000000000000000000000C1C1C2000000 + 0000C1C1C20092938B00C1C1C200BBBDB600C1C1C2000000000000000000C1C1 + C200C1C1C200000000000000000000000000000000000000000000000000C1C1 C2008E918D00A2A99D00E3E8E500E8ECEA00C8D1CC00D9DFDC00CFD6D200C6CF CA00C1C1C2000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 - 000000000000000000000000000000000000C1C1C2009EA79D00A2AAA100D7DB - D70000000000DADDDA00A1A9A0009FA89E00A9B2A800A3ABA200C1C1C2000000 + 000000000000000000000000000000000000000000000000000000000000C1C1 + C200B5B4AD00CACFC900CAD3CF00ABB7B100C1C1C20000000000C1C1C2000000 00000000000000000000000000000000000000000000C1C1C200C1C1C2000000 0000C1C1C200A4AB9F00E8ECEA00F0F3F100E8ECEA00DCE2DF00D1D8D400A4AB 9F00C1C1C2000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 - 000000000000000000000000000000000000BFC0C00098A09700949D9300D5D9 - D5000000000000000000DBDEDB0099A29800959D9400ACB3AB00BDBDBB000000 + 000000000000000000000000000000000000000000000000000000000000C1C1 + C200D0D4CE00DFE5E300C1C9C400CAD3CF00AEB1A800C1C1C200C1C1C2000000 0000000000000000000000000000000000000000000000000000000000000000 0000C1C1C200DAE0DD00929E9500E8ECEA00E3E8E500DAE0DD00C1C1C200D0D0 D000D0D0D000C1C1C200C1C1C200000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 - 000000000000000000000000000000000000BFC0C000989F9900969D9500D5D8 - D500000000000000000000000000E1E4E2009BA59D00ACB1AB00BDBDBB000000 + 00000000000000000000000000000000000000000000C1C1C200C1C1C200B1B1 + AC00D0D3CE00EBF0EE00DEE4E100CCD1CC00C1C1C20000000000000000000000 000000000000000000000000000000000000000000000000000000000000C1C1 C200A9B0A500F0F3F100D9DFDC00A9B0A500A9B0A500C1C1C20000000000C1C1 C200C1C1C2000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 - 000000000000000000000000000000000000C0C0C100A8B0A900A4ACA500DADD - DA000000000000000000FCFDFD00C5D1CB00ADB6AF00B5BCB600BDBDBC000000 + 000000000000000000000000000000000000000000000000000000000000C1C1 + C200C2CBC600D2D5D000CDD1CB00C1C1C200C1C1C200C1C1C200C1C1C2000000 00000000000000000000000000000000000000000000C1C1C200C1C1C200C1C1 C20090938E00ABB2A700ABB2A700C1C1C200C1C1C200C1C1C200000000000000 0000000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 - 000000000000000000000000000000000000C1C1C200ABB3AC00AFB8B100DEE1 - DE0000000000FCFDFD00BCCAC300A7B2AB00B0B8B200B0B8B200C1C1C2000000 + 00000000000000000000000000000000000000000000C1C1C200C1C1C200A5A7 + A100C1C1C200C1C1C200C1C1C200000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 0000C1C1C20091949000C1C1C2000000000000000000C1C1C200000000000000 0000000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 - 000000000000000000000000000000000000C1C1C200ACB2AB00B8C1BB00D6DC - D800F9FBFA00BBC9C200B1BCB600BDC5C000B8C1BB00B2B6B200C1C1C2000000 + 000000000000000000000000000000000000000000000000000000000000C1C1 + C2000000000000000000C1C1C200000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 000000000000C1C1C200000000000000000000000000C1C1C200000000000000 0000000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 - 00000000000000000000000000000000000000000000C1C1C200AEB4AE00A9BB - B300C4D0CB00BBC5C000C1C8C400B3BBB400B3B7B300C1C1C200000000000000 + 000000000000000000000000000000000000000000000000000000000000C1C1 + C2000000000000000000C1C1C200000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 000000000000C1C1C20000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000C1C1C200C1C1 - C200C0C0C100C0C0C100C0C0C100C1C1C200C1C1C20000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 @@ -5801,133 +6214,263 @@ object CommandsDataModule: TCommandsDataModule 0000000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 + 00000000000000000000000000000000000000000000DCDCDC00DCDCDC00DCDC + DC00DCDCDC00DCDCDC00DCDCDC00DCDCDC00DCDCDC00DCDCDC00DCDCDC00DCDC + DC00DCDCDC00DCDCDC000000000000000000000000000000000000000000C1C1 + C200C1C1C200C1C1C200C1C1C200C1C1C200C1C1C20000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000C0C0C000C0C0C00000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 000000000000000000000000000000000000000000000000000000000000C1C1 - C200C1C1C2000000000000000000000000000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 + 00000000000000000000000000000000000000000000DCDCDC00EFEFEF00EFEF + EF00F0F0F000F0F0F000C3C3C300E3E3E300EFEFEF00EFEFEF00EEEEEE00EEEE + EE00EEEEEE00DCDCDC0000000000000000000000000000000000C1C1C2009C94 + 8A00FCFBFA00FCFBFA00FCFBFA00FCFBFA009C948A00C1C1C20000000000C1C1 + C200C1C1C200C1C1C200C1C1C200C1C1C2000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 - 000000000000000000000000000000000000000000000000000000000000C1C1 - C200C4D1D600C1C1C2000000000000000000000000000000000000000000C0C0 - C000C0C0C000C0C0C000C0C0C000C0C0C00000000000C0C0C000C0C0C000C0C0 - C000C0C0C000C0C0C00000000000000000008484840000000000000000000000 + 00000000000000000000000000000000000000000000DCDCDC00F1F1F100F1F1 + F100F1F1F100C3C3C300C8C8C800C3C3C300C9C9C900DCDCDC00F0F0F000F0F0 + F000EEEEEE00DCDCDC0000000000000000000000000000000000C1C1C200F6F4 + F100FAF9F800FAF9F800FAF9F800A6A29B00FCFCFB00C1C1C200000000000000 + 0000000000000000000000000000000000008484840000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000C0C0C000C0C0C00000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 00000000000000000000000000000000000000000000C1C1C200C1C1C20096A3 - A800CFDADE00C4D1D600C1C1C20000000000000000000000000000000000C0C0 - C000000000000000000000000000C0C0C00000000000C0C0C000000000000000 - 000000000000C0C0C00000000000000000000000000084848400000000000000 + 00000000000000000000000000000000000000000000DCDCDC00F3F3F300F3F3 + F300C3C3C300CDCDCD00C7C7C700CECECE00CECECE00C4C4C400ECECEC00F1F1 + F100F0F0F000DCDCDC0000000000000000000000000000000000C1C1C200F7F6 + F300FCFBFA00A6A29B009C948A00FCFBFA00FDFDFC00C1C1C20000000000C1C1 + C200C1C1C200C1C1C200C1C1C200C1C1C2000000000084848400000000000000 0000000000000000000000000000000000000000000000000000C6C6C6008484 8400848484000000000000000000000000000000000000000000000000000000 0000000000000000000000000000C0C0C000C0C0C00000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 000000000000000000000000000000000000C1C1C200CCD8DC00D8E2E400D8E2 - E400D8E2E400D8E2E400CCD8DC00C1C1C200000000000000000000000000C0C0 - C000000000000000000000000000C0C0C00000000000C0C0C000000000000000 - 000000000000C0C0C00000000000000000000000000000000000848484000000 + 00000000000000000000000000000000000000000000DCDCDC00F4F4F400F4F4 + F400F4F4F400D1D1D100D1D1D100F4F4F400EBEBEB00D7D7D700D5D5D500F3F3 + F300F1F1F100DCDCDC0000000000000000000000000000000000C1C1C200F4F3 + F200FDFDFC009C948A00FDFDFC00FDFDFC00FEFEFD00C1C1C200000000000000 + 0000000000000000000000000000000000000000000000000000848484000000 0000000000000000000000000000000000000000000084848400848484000000 00000000000084848400000000000000000000000000C0C0C000C0C0C000C0C0 C000000000000000000000000000C0C0C000C0C0C000C0C0C000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 0000000000000000000000000000C1C1C200D2DDE000E1E9EA00E1E9EA00E1E9 - EA00E1E9EA00E1E9EA00CDD8DB00C1C1C200000000000000000000000000C0C0 - C000000000000000000000000000C0C0C00000000000C0C0C000000000000000 - 000000000000C0C0C00000000000000000000000000000000000000000008484 + 00000000000000000000000000000000000000000000DCDCDC00F6F6F600F6F6 + F600F6F6F600F6F6F600D1D1D100F6F6F600F6F6F600F3F3F300D8D8D800F4F4 + F400F3F3F300DCDCDC0000000000000000000000000000000000C1C1C200C1C1 + C200C1C1C200C1C1C200C1C1C200C1C1C200FAFAFA00C1C1C20000000000C1C1 + C200C1C1C200C1C1C200C1C1C200C1C1C2000000000000000000000000008484 84000000000000000000000000000000000084848400A5A5A500A5A5A5000000 0000000000000000000084848400000000000000000000000000000000000000 00000000000000000000C0C0C0000000000000000000C0C0C000000000000000 + 00000000000000000000000000000000000000000000DCDCDC00F7F7F700EAEA + EA00D7D7D700F8F8F800F8F8F800F8F8F800F7F7F700F7F7F700F6F6F600F5F5 + F500F4F4F400DCDCDC00000000000000000000000000C1C1C200B0B5B000B1B8 + B000AFB7AE00ABB3AA00ACB5AB00A6AEA400C1C1C200C1C1C200000000000000 0000000000000000000000000000000000000000000000000000000000000000 - 0000C1C1C2000000000000000000C1C1C200F5F7F700E1E9EA00C1C1C200A0AD - B100F5F7F700DCE3E500C1C1C20000000000000000000000000000000000C0C0 - C00000000000C0C0C00000000000C0C0C00000000000C0C0C00000000000C0C0 - C00000000000C0C0C00000000000000000000000000000000000000000000000 00008484840000000000000000000000000084848400A5A5A500A5A5A500A5A5 A5000000000000000000000000008484840000000000C0C0C000C0C0C000C0C0 C0000000000000000000C0C0C000C0C0C000C0C0C000C0C0C000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 000000000000C1C1C20000000000C1C1C200F8FAFA00C1C1C20000000000C1C1 - C200F5F7F700C1C1C2000000000000000000000000000000000000000000C0C0 - C000000000000000000000000000C0C0C00000000000C0C0C000000000000000 - 000000000000C0C0C00000000000000000000000000000000000000000000000 + 00000000000000000000000000000000000000000000DCDCDC00F8F8F800F6F6 + F600D2D2D200CECECE00DBDBDB00F9F9F900C3C3C300F8F8F800F8F8F800F6F6 + F600F6F6F600DCDCDC000000000000000000C1C1C200AEB3AD00A5AEA400DADD + DA00DBDEDB009BA59B009BA59B00A8B2A800A7B0A600C1C1C20000000000C1C1 + C200C1C1C200C1C1C200C1C1C200C1C1C2000000000000000000000000000000 00000000000084848400000000000000000084848400A5A5A500A5A5A500A5A5 A500A5A5A5000000000000000000848484000000000000000000000000000000 00000000000000000000C0C0C000C0C0C000C0C0C000C0C0C000000000000000 - 0000C0C0C0000000000000000000000000000000000000000000C1C1C2000000 - 0000C1C1C20092938B00C1C1C200BBBDB600C1C1C2000000000000000000C1C1 - C200C1C1C200000000000000000000000000000000000000000000000000C0C0 - C000000000000000000000000000C0C0C00000000000C0C0C000000000000000 - 000000000000C0C0C00000000000000000000000000000000000000000000000 + 0000C0C0C00000000000000000000000000000000000DCDCDC00F9F9F900F9F9 + F900E9E9E900D1D1D100CCCCCC00CCCCCC00C3C3C300B7B7B700F8F8F800F8F8 + F800F6F6F600DCDCDC000000000000000000C1C1C2009EA79D00A2AAA100D7DB + D70000000000DADDDA00A1A9A0009FA89E00A9B2A800A3ABA200C1C1C2000000 + 0000000000000000000000000000000000000000000000000000000000000000 0000000000000000000084848400848484000000000000000000A5A5A500A5A5 A500A5A5A5008484840084848400000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 - 0000C0C0C000C0C0C0000000000000000000000000000000000000000000C1C1 - C200B5B4AD00CACFC900CAD3CF00ABB7B100C1C1C20000000000C1C1C2000000 - 000000000000000000000000000000000000000000000000000000000000C0C0 - C000000000000000000000000000C0C0C00000000000C0C0C000000000000000 - 000000000000C0C0C00000000000000000000000000000000000000000000000 + 0000C0C0C000C0C0C000000000000000000000000000DCDCDC00FAFAFA00FBFB + FB00FBFBFB00EDEDED00CECECE00CECECE00C3C3C300C9C9C900BABABA00F8F8 + F800F8F8F800DCDCDC000000000000000000BFC0C00098A09700949D9300D5D9 + D5000000000000000000DBDEDB0099A29800959D9400ACB3AB00BDBDBB000000 + 0000000000000000000000000000000000000000000000000000000000000000 000000000000000000000000000084848400000000000000000000000000A5A5 A5008484840000000000000000000000000000000000C0C0C000C0C0C0000000 0000C0C0C000C0C0C0000000000000000000C0C0C00000000000000000000000 - 0000C0C0C000C0C0C0000000000000000000000000000000000000000000C1C1 - C200D0D4CE00DFE5E300C1C9C400CAD3CF00AEB1A800C1C1C200C1C1C2000000 - 000000000000000000000000000000000000000000000000000000000000C0C0 - C000000000000000000000000000C0C0C00000000000C0C0C000000000000000 - 000000000000C0C0C00000000000000000000000000000000000000000000000 + 0000C0C0C000C0C0C000000000000000000000000000DCDCDC00FBFBFB00FBFB + FB00FCFCFC00FCFCFC00FCFCFC00FCFCFC00CECECE00D1D1D100FAFAFA00F9F9 + F900F8F8F800DCDCDC000000000000000000BFC0C000989F9900969D9500D5D8 + D500000000000000000000000000E1E4E2009BA59D00ACB1AB00BDBDBB000000 + 0000000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000008484840000000000000000000000 00008484840000000000000000000000000000000000C0C0C000C0C0C000C0C0 C000C0C0C000C0C0C0000000000000000000C0C0C00000000000000000000000 - 0000C0C0C000C0C0C000C0C0C0000000000000000000C1C1C200C1C1C200B1B1 - AC00D0D3CE00EBF0EE00DEE4E100CCD1CC00C1C1C20000000000000000000000 - 000000000000000000000000000000000000000000000000000000000000C0C0 - C000000000000000000000000000C0C0C00000000000C0C0C000000000000000 - 000000000000C0C0C00000000000000000000000000000000000000000000000 + 0000C0C0C000C0C0C000C0C0C0000000000000000000DCDCDC00FBFBFB00FCFC + FC00FCFCFC00FCFCFC00FCFCFC00FCFCFC00D1D1D100DCDCDC00DCDCDC00DCDC + DC00DCDCDC00DCDCDC000000000000000000C0C0C100A8B0A900A4ACA500DADD + DA000000000000000000FCFDFD00C5D1CB00ADB6AF00B5BCB600BDBDBC000000 + 0000000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000084848400000000000000 0000848484000000000000000000000000000000000000000000C0C0C000C0C0 C000C0C0C00000000000C0C0C000C0C0C000C0C0C000C0C0C000C0C0C0000000 - 0000C0C0C000C0C0C000C0C0C00000000000000000000000000000000000C1C1 - C200C2CBC600D2D5D000CDD1CB00C1C1C200C1C1C200C1C1C200C1C1C2000000 - 000000000000000000000000000000000000000000000000000000000000C0C0 - C000C0C0C000C0C0C000C0C0C000C0C0C00000000000C0C0C000C0C0C000C0C0 - C000C0C0C000C0C0C00000000000000000000000000000000000000000000000 + 0000C0C0C000C0C0C000C0C0C0000000000000000000DCDCDC00FCFCFC00FCFC + FC00FCFCFC00FDFDFD00FDFDFD00FCFCFC00FCFCFC00DCDCDC00E6E6E600F1F1 + F100DCDCDC00000000000000000000000000C1C1C200ABB3AC00AFB8B100DEE1 + DE0000000000FCFDFD00BCCAC300A7B2AB00B0B8B200B0B8B200C1C1C2000000 + 0000000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000848484008484 8400000000000000000000000000000000000000000000000000C0C0C000C0C0 C000C0C0C000000000000000000000000000C0C0C0000000000000000000C0C0 - C000C0C0C00000000000C0C0C000C0C0C00000000000C1C1C200C1C1C200A5A7 - A100C1C1C200C1C1C200C1C1C200000000000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 + C000C0C0C00000000000C0C0C000C0C0C00000000000DCDCDC00FCFCFC00FCFC + FC00FDFDFD00FDFDFD00FDFDFD00FCFCFC00FCFCFC00DCDCDC00F1F1F100DCDC + DC0000000000000000000000000000000000C1C1C200ACB2AB00B8C1BB00D6DC + D800F9FBFA00BBC9C200B1BCB600BDC5C000B8C1BB00B2B6B200C1C1C2000000 0000000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000008484 84000000000000000000000000000000000000000000C0C0C000C0C0C000C0C0 C000C0C0C000C0C0C0000000000000000000C0C0C0000000000000000000C0C0 - C000C0C0C00000000000C0C0C000C0C0C000000000000000000000000000C1C1 - C2000000000000000000C1C1C200000000000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 + C000C0C0C00000000000C0C0C000C0C0C00000000000DCDCDC00FCFCFC00FCFC + FC00FDFDFD00FDFDFD00FDFDFD00FCFCFC00FCFCFC00DCDCDC00DCDCDC000000 + 00000000000000000000000000000000000000000000C1C1C200AEB4AE00A9BB + B300C4D0CB00BBC5C000C1C8C400B3BBB400B3B7B300C1C1C200000000000000 0000000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 00008484840000000000000000000000000000000000C0C0C000C0C0C0000000 0000C0C0C000C0C0C0000000000000000000000000000000000000000000C0C0 - C000000000000000000000000000C0C0C000000000000000000000000000C1C1 - C2000000000000000000C1C1C200000000000000000000000000000000000000 + C000000000000000000000000000C0C0C00000000000DCDCDC00DCDCDC00DCDC + DC00DCDCDC00DCDCDC00DCDCDC00DCDCDC00DCDCDC00DCDCDC00000000000000 + 0000000000000000000000000000000000000000000000000000C1C1C200C1C1 + C200C0C0C100C0C0C100C0C0C100C1C1C200C1C1C20000000000000000000000 + 0000000000000000000000000000000000000000000000000000000000000000 + 0000000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 + 000000000000000000000000000000000000000000008787877F878787FF8080 + 809F6E6E6E6F8787877F7A7A7A5F000000000000000000000000000000000000 + 000000000000000000000000000000000000C9C9C9FFA8A8A8FFC9C9C9FF0000 0000000000000000000000000000000000000000000000000000000000000000 + 00000000000000000000000000000000000000000000ABABABFFC9C9C9FF0000 0000000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 - 000000000000000000000000000000000000EFEFEF00ADADAD00BDBDBD00EFEF + 000000000000000000000000000000000000000000008787876FC9C9C9FFC9C9 + C9FF9C9C9CFF878787FFB0B0B0FF949494BF8787879F9C9C9CFF999999EF8787 + 875F00000000000000000000000000000000D6D6D6FFCCCCCCFFB0B0B0FFC2C2 + C2FF000000000000000000000000000000000000000000000000000000000000 + 000000000000000000000000000000000000D9D9D9FFCFCFCFFFB0B0B0FFC2C2 + C2FF000000000000000000000000000000000000000000000000000000000000 + 000000000000000000000000000000000000000000000000000000000000C0C0 + C000C0C0C000C0C0C000C0C0C000C0C0C00000000000C0C0C000C0C0C000C0C0 + C000C0C0C000C0C0C0000000000000000000000000008787873FBFBFBFFFB2B2 + B2FF9C9C9CFFA6A6A6FF919191FFA8A8A8FFABABABFFA3A3A3FF9E9E9EFFA1A1 + A1FF8C8C8C8F8F8F8FCF969696DF7A7A7A2FE8E8E8FFD4D4D4FFC7C7C7FFB2B2 + B2FFC7C7C7FF0000000000000000000000000000000000000000000000000000 + 000000000000000000000000000000000000E8E8E8FFD6D6D6FFC9C9C9FFB2B2 + B2FFC7C7C7FF0000000000000000000000000000000000000000000000000000 + 000000000000000000000000000000000000000000000000000000000000C0C0 + C000000000000000000000000000C0C0C00000000000C0C0C000000000000000 + 000000000000C0C0C0000000000000000000000000008787872F919191FFABAB + ABFFC7C7C7FFADADADFF919191FF8F8F8FFF9E9E9EFF9E9E9EFF9E9E9EFF9191 + 91FF9E9E9EFF9E9E9EFF9E9E9EFF8C8C8CAFCCCCCCFFE8E8E8FFD4D4D4FFC9C9 + C9FFABABABFFD4D4D4FF00000000000000000000000000000000000000000000 + 000000000000000000000000000000000000CCCCCCFFE8E8E8FFD4D4D4FFCCCC + CCFFADADADFFD6D6D6FF00000000000000000000000000000000000000000000 + 000000000000000000000000000000000000000000000000000000000000C0C0 + C000000000000000000000000000C0C0C00000000000C0C0C000000000000000 + 000000000000C0C0C0000000000000000000000000008787870F7373739FABAB + ABFFB2B2B2FFC7C7C7FFB0B0B0FF7A7A7AFF8F8F8FFF8F8F8FFF8282828F7878 + 784F8A8A8ABF8080807F7878787F8C8C8CFFE0E0E0FFE0E0E0FFB5B5B5FFD1D1 + D1FFC2C2C2FF9E9E9EFFBABABAFFA8A8A8FFADADADFFA3A3A3FFBABABAFFD4D4 + D4FFCFCFCFFFCFCFCFFF0000000000000000E0E0E0FFE0E0E0FFB5B5B5FFD1D1 + D1FFC2C2C2FFA1A1A1FFBDBDBDFFABABABFFB0B0B0FFA6A6A6FFBABABAFFD6D6 + D6FFD1D1D1FFD1D1D1FF0000000000000000000000000000000000000000C0C0 + C000000000000000000000000000C0C0C00000000000C0C0C000000000000000 + 000000000000C0C0C00000000000000000008787876F8787877F8787872F7575 + 75CFBFBFBFFFB2B2B2FFBFBFBFFFADADADFF808080FF8A8A8ABF8787870F0000 + 00000000000000000000000000006E6E6E8FADADADFFADADADFFABABABFFCFCF + CFFFCCCCCCFFC2C2C2FFEDEDEDFFFAFAFAFFFFFFFFFFFFFFFFFFB8B8B8FF8080 + 80FFC7C7C7FF8A8A8AFF0000000000000000ADADADFFADADADFFADADADFFCFCF + CFFFCFCFCFFFC2C2C2FFEDEDEDFFFAFAFAFFFFFFFFFFFFFFFFFFB8B8B8FF8282 + 82FFC9C9C9FF8C8C8CFF0000000000000000000000000000000000000000C0C0 + C00000000000C0C0C00000000000C0C0C00000000000C0C0C00000000000C0C0 + C00000000000C0C0C00000000000000000007575753F9E9E9EFF9C9C9CFF9C9C + 9CFF9C9C9CFFB0B0B0FFBABABAFFADADADFFA6A6A6FF8C8C8CFF919191CF8787 + 870F00000000000000000000000000000000DEDEDEFFFAFAFAFFFAFAFAFFF2F2 + F2FFD9D9D9FFE0E0E0FFEDEDEDFFF0F0F0FFABABABFFFCFCFCFFFFFFFFFFADAD + ADFFF5F5F5FFABABABFF0000000000000000E0E0E0FFFAFAFAFFFAFAFAFFF2F2 + F2FFDBDBDBFFE0E0E0FFEDEDEDFFF0F0F0FFF2F2F2FFFCFCFCFFFFFFFFFFB0B0 + B0FFF5F5F5FFADADADFF0000000000000000000000000000000000000000C0C0 + C000000000000000000000000000C0C0C00000000000C0C0C000000000000000 + 000000000000C0C0C000000000000000000000000000787878DFB0B0B0FF8080 + 80FF9C9C9CFFABABABFF8C8C8CFFC7C7C7FFABABABFF8C8C8CFF9C9C9CFF7A7A + 7A6F00000000000000000000000000000000D4D4D4FFF2F2F2FFE3E3E3FFDEDE + DEFFD6D6D6FFE0E0E0FFD9D9D9FFE6E6E6FFABABABFFF0F0F0FFFAFAFAFFC7C7 + C7FFC9C9C9FFABABABFF0000000000000000D6D6D6FFF2F2F2FFE3E3E3FFE0E0 + E0FFD6D6D6FFE0E0E0FFD9D9D9FFE6E6E6FFEDEDEDFFF0F0F0FFFAFAFAFFC7C7 + C7FFCCCCCCFFABABABFF0000000000000000000000000000000000000000C0C0 + C000000000000000000000000000C0C0C00000000000C0C0C000000000000000 + 000000000000C0C0C00000000000000000008A8A8A7F9C9C9CFF9C9C9CFF9696 + 96FF737373FF808080FFABABABFF949494FFC4C4C4FFB0B0B0FF808080FF8787 + 87AF00000000000000000000000000000000D4D4D4FFF2F2F2FFE3E3E3FFDEDE + DEFFD6D6D6FFD9D9D9FFABABABFFABABABFFABABABFFABABABFFABABABFFD1D1 + D1FFC9C9C9FFA8A8A8FF0000000000000000D6D6D6FFF2F2F2FFE3E3E3FFE0E0 + E0FFD9D9D9FFD9D9D9FFABABABFFABABABFFABABABFFABABABFFF2F2F2FFD4D4 + D4FFCCCCCCFFABABABFF0000000000000000000000000000000000000000C0C0 + C000000000000000000000000000C0C0C00000000000C0C0C000000000000000 + 000000000000C0C0C00000000000000000009C9C9CFFADADADFFA8A8A8FFADAD + ADFFB0B0B0FF9C9C9CFF828282FFB0B0B0FFA1A1A1FFBFBFBFFFA6A6A6FF6E6E + 6EBF00000000000000000000000000000000D4D4D4FFF2F2F2FFE3E3E3FFE3E3 + E3FFD6D6D6FFE3E3E3FFDBDBDBFFDBDBDBFFABABABFFE3E3E3FFF2F2F2FFC2C2 + C2FFE3E3E3FFA8A8A8FF0000000000000000D6D6D6FFF2F2F2FFE3E3E3FFE3E3 + E3FFD9D9D9FFE3E3E3FFDBDBDBFFDBDBDBFFE0E0E0FFE3E3E3FFF2F2F2FFC2C2 + C2FFE3E3E3FFABABABFF0000000000000000000000000000000000000000C0C0 + C000000000000000000000000000C0C0C00000000000C0C0C000000000000000 + 000000000000C0C0C0000000000000000000919191DF7D7D7DFF828282FF9E9E + 9EFFA3A3A3FFB0B0B0FFABABABFFB0B0B0FF919191FFBFBFBFFFADADADFFA1A1 + A1FF8787873F000000000000000000000000D4D4D4FFF5F5F5FFE6E6E6FFE6E6 + E6FFD6D6D6FFE3E3E3FFF7F7F7FFE3E3E3FFABABABFFE8E8E8FFDEDEDEFFBDBD + BDFFFCFCFCFFA6A6A6FF0000000000000000D6D6D6FFF5F5F5FFE6E6E6FFE6E6 + E6FFD9D9D9FFE3E3E3FFF7F7F7FFE3E3E3FFE0E0E0FFE8E8E8FFE0E0E0FFBFBF + BFFFFCFCFCFFA6A6A6FF0000000000000000000000000000000000000000C0C0 + C000000000000000000000000000C0C0C00000000000C0C0C000000000000000 + 000000000000C0C0C00000000000000000007575752F919191EF9E9E9EFF9E9E + 9EFF9E9E9EFF9E9E9EFFA6A6A6FFA6A6A6FF919191FFBABABAFFC7C7C7FFA3A3 + A3FF9C9C9CEF8787870F0000000000000000D4D4D4FFF2F2F2FFE3E3E3FFE3E3 + E3FFE3E3E3FFD1D1D1FFDBDBDBFFE0E0E0FFE0E0E0FFDEDEDEFFC4C4C4FFE3E3 + E3FFFFFFFFFFA6A6A6FF0000000000000000D6D6D6FFF2F2F2FFE3E3E3FFE3E3 + E3FFE3E3E3FFD4D4D4FFDEDEDEFFE0E0E0FFE0E0E0FFDEDEDEFFC4C4C4FFE3E3 + E3FFFFFFFFFFA6A6A6FF0000000000000000000000000000000000000000C0C0 + C000C0C0C000C0C0C000C0C0C000C0C0C00000000000C0C0C000C0C0C000C0C0 + C000C0C0C000C0C0C0000000000000000000000000008787870F8C8C8CDFA6A6 + A6FFABABABFFA6A6A6FF969696FF8F8F8FFF707070DFB8B8B8FFADADADFFBFBF + BFFF919191FFA3A3A3BF0000000000000000D4D4D4FFF5F5F5FFE8E8E8FFE8E8 + E8FFE8E8E8FFEBEBEBFFDBDBDBFFCCCCCCFFD1D1D1FFDBDBDBFFF2F2F2FFF7F7 + F7FFFFFFFFFFA6A6A6FF0000000000000000D6D6D6FFF5F5F5FFE8E8E8FFE8E8 + E8FFE8E8E8FFEBEBEBFFDEDEDEFFCFCFCFFFD4D4D4FFDEDEDEFFF2F2F2FFF7F7 + F7FFFFFFFFFFA6A6A6FF00000000000000000000000000000000000000000000 + 0000000000000000000000000000000000000000000000000000000000000000 + 0000000000000000000000000000000000000000000000000000ABABAB7FA8A8 + A8FFB5B5B5FF878787FF808080FF8080807F8787870F949494EFB5B5B5FFA3A3 + A3FFC9C9C9FFC9C9C9FF8787873F00000000DEDEDEFFF5F5F5FFEBEBEBFFEBEB + EBFFF2F2F2FFF2F2F2FFF2F2F2FFF7F7F7FFF5F5F5FFF5F5F5FFF2F2F2FFF2F2 + F2FFFFFFFFFFA6A6A6FF0000000000000000DEDEDEFFF5F5F5FFEBEBEBFFEBEB + EBFFF2F2F2FFF2F2F2FFF2F2F2FFF7F7F7FFF5F5F5FFF5F5F5FFF2F2F2FFF2F2 + F2FFFFFFFFFFA6A6A6FF00000000000000000000000000000000000000000000 + 0000000000000000000000000000000000000000000000000000000000000000 + 00000000000000000000000000000000000000000000000000008282827FADAD + ADFFABABABFFA3A3A3FF949494FF7575755F000000008787873FB8B8B8FFC7C7 + C7FFCFCFCFFF9C9C9C8F0000000000000000A6A6A6FFA8A8A8FFA8A8A8FFA8A8 + A8FFA8A8A8FFA8A8A8FFA8A8A8FFA8A8A8FFA8A8A8FFADADADFFADADADFFADAD + ADFFB2B2B2FF8C8C8CFF0000000000000000A8A8A8FFA8A8A8FFA8A8A8FFA8A8 + A8FFA8A8A8FFA8A8A8FFA8A8A8FFA8A8A8FFA8A8A8FFB0B0B0FFB0B0B0FFB0B0 + B0FFB2B2B2FF8F8F8FFF00000000000000000000000000000000000000000000 + 0000000000000000000000000000000000000000000000000000000000000000 + 00000000000000000000000000000000000000000000000000008787871F8C8C + 8CDF828282AF8C8C8CEF8A8A8ABF8787870F00000000000000009C9C9C6FBDBD + BDDF8282824F000000000000000000000000BABABAFFBFBFBFFFBFBFBFFFBFBF + BFFFBFBFBFFFBFBFBFFFBFBFBFFFBFBFBFFFBFBFBFFFBFBFBFFFBFBFBFFFBFBF + BFFFBFBFBFFFB2B2B2FF0000000000000000BABABAFFC2C2C2FFC2C2C2FFC2C2 + C2FFC2C2C2FFC2C2C2FFC2C2C2FFC2C2C2FFC2C2C2FFC2C2C2FFC2C2C2FFC2C2 + C2FFC2C2C2FFB2B2B2FF0000000000000000EFEFEF00ADADAD00BDBDBD00EFEF EF00000000000000000000000000000000000000000000000000000000000000 000000000000000000000000000000000000000000009C9C9C00BDBDBD000000 0000000000000000000000000000000000000000000000000000000000000000 @@ -9640,16 +10183,24 @@ object CommandsDataModule: TCommandsDataModule 0000000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 000000000000000000000000000000000000424D3E000000000000003E000000 - 2800000040000000F00100000100010000000000800F00000000000000000000 - 000000000000000000000000FFFFFF00E07FFDFF00000000C020FEFF00000000 - C03FFE3F00000000C020EE0F00000000C03FF00700000000C020F00200000000 - 803FF001000000000020E00700000000081F9007000000000C1FF00100000000 - 0E1FE027000000000C1F803F00000000081FF1BF00000000001FFBBF00000000 - 803FFBFF00000000C07FFFFF00000000FFFFFFFFFE7FFFE7FFFFFFFFFFFFFFE3 - E0837FFFFE7FFF81EEBBBFC7FE7FFF00EEBBDF9B8E3FFE00EEBBEF1DFDBFF601 - EAABF70E8C3FFA23EEBBFB06FC37D067EEBBFCC1FFF3E05FEEBBFEE79373E01F - EEBBFF778371807FEEBBFFB7C411E01FE083FFCFC76481FFFFFFFFEF8364EDFF - FFFFFFF793EEEDFFFFFFFFFFFFFFFFFF0FFF9FFFE7E7FFFF0FFF0FFFC1C38FFF + 2800000040000000100200000100010000000000801000000000000000000000 + 000000000000000000000000FFFFFF0000000000000000000000000000000000 + 0000000000000000000000000000000000000000000000000000000000000000 + 0000000000000000000000000000000000000000000000000000000000000000 + 0000000000000000000000000000000000000000000000000000000000000000 + 00000000000000000000000000000000FFE7FDFF00000000FFE3FEFF00000000 + FF81FE3F00000000FF00EE0F00000000FE00F00700000000F601F00200000000 + FA23F00100000000D067E00700000000E05F900700000000E01FF00100000000 + 807FE02700000000E01F803F0000000081FFF1BF00000000EDFFFBBF00000000 + EDFFFBFF00000000FFFFFFFF000000008003E07FFFFFFE7F8003C020FFFFFFFF + 8003C03F7FFFFE7F8003C020BFC7FE7F8003C03FDF9B8E3F8003C020EF1DFDBF + 8003803FF70E8C3F80030020FB06FC378003081FFCC1FFF380030C1FFEE79373 + 80030E1FFF77837180030C1FFFB7C4118007081FFFCFC764800F001FFFEF8364 + 801F803FFFF793EE803FC07FFFFFFFFFFFFF81FF1FFF9FFFFFFF800F0FFF0FFF + E083800007FF07FFEEBB800003FF03FFEEBB800000030003EEBB001E00030003 + EAAB000F00030003EEBB800F00030003EEBB000F00030003EEBB000F00030003 + EEBB000700030003EEBB000300030003E083800300030003FFFFC00100030003 + FFFFC08300030003FFFFC0C7000300030FFF9FFFE7E7FFFF0FFF0FFFC1C38FFF 07FF07FFE187807F83FF83FFE007800FC1BFC1FFF00F8007E107E10FF81F8007 F003F003E0078003F885F80980018003F815F82D00008000F880F80400008000 F804F804FC3F8000F800F810FC3F8200F801F801FC3F8000FD01FD01FC3FC3C0 @@ -9826,6 +10377,7 @@ object CommandsDataModule: TCommandsDataModule item Name = 'RpyC_Init' Strings.Strings = ( + 'import sys' 'import code' '' '__import__('#39'bdb'#39').__traceable__ = 0' @@ -9907,6 +10459,7 @@ object CommandsDataModule: TCommandsDataModule '' ' maindictcopy = self.locals.copy()' ' sysmodulescopy = sys.modules.copy()' + ' self.saveStdio = (sys.stdin, sys.stdout, sys.stderr)' '' ' self.exc_info = None' ' self.interrupted = False' @@ -9918,15 +10471,25 @@ object CommandsDataModule: TCommandsDataModule ' except:' ' self.showtraceback()' ' exc_info = sys.exc_info()' + ' if hasattr(exc_info[0], "__name__"):' + ' name = exc_info[0].__name__' + ' elif type(exc_info[0]) == str:' + ' name = exc_info[0]' + ' else:' + ' name = ""' - ' self.exc_info = (exc_info[0].__name__, exc_i' + - 'nfo[1], exc_info[2])' + ' self.exc_info = (name, exc_info[1], exc_info' + + '[2])' ' finally:' + ' sys.stdin, sys.stdout, sys.stderr = self.saveStd' + + 'io' + ' if self.debugIDE.cleanupMainDict() and (self.loc' + 'als is globals):' ' self.locals.clear()' ' self.locals.update(maindictcopy)' + ' __import__("gc").collect()' ' if self.debugIDE.cleanupSysModules():' ' sys.modules.clear()' ' sys.modules.update(sysmodulescopy)' @@ -10003,7 +10566,9 @@ object CommandsDataModule: TCommandsDataModule ' return 0' '' ' def _getmembers(self, ob):' - ' return [(i, getattr(ob, i)) for i in dir(ob)]' + + ' return [(i, getattr(ob, i)) for i in __import__('#39'Rpyc'#39').' + + 'dir(ob)]' '' ' def safegetmembers(self, x):' ' try:' @@ -10078,6 +10643,7 @@ object CommandsDataModule: TCommandsDataModule ' return filename' '' ' def runcode(self, code):' + ' import sys' ' def softspace(file, newvalue):' ' oldvalue = 0' ' try:' @@ -10093,6 +10659,7 @@ object CommandsDataModule: TCommandsDataModule ' pass' ' return oldvalue' '' + ' self.saveStdio = (sys.stdin, sys.stdout, sys.stderr)' ' try:' ' if self.debugger.InIDEDebug:' @@ -10108,6 +10675,7 @@ object CommandsDataModule: TCommandsDataModule ' import sys' ' if softspace(sys.stdout, 0):' ' print' + ' sys.stdin, sys.stdout, sys.stderr = self.saveStdio' '' ' def evalcode(self, code):' ' # may raise exceptions' @@ -10210,9 +10778,13 @@ object CommandsDataModule: TCommandsDataModule ' except:' ' self.showtraceback()' ' exc_info = sys.exc_info()' - - ' self.exc_info = (exc_info[0].__name__, exc_info[1], ' + - 'exc_info[2])' + ' if hasattr(exc_info[0], "__name__"):' + ' name = exc_info[0].__name__' + ' elif type(exc_info[0]) == str:' + ' name = exc_info[0]' + ' else:' + ' name = ""' + ' self.exc_info = (name, exc_info[1], exc_info[2])' '' ' def run_nodebug(self, cmd, globals=None, locals=None):' ' import types' @@ -10225,6 +10797,7 @@ object CommandsDataModule: TCommandsDataModule '' ' maindictcopy = self.locals.copy()' ' sysmodulescopy = sys.modules.copy()' + ' self.saveStdio = (sys.stdin, sys.stdout, sys.stderr)' '' ' if not isinstance(cmd, types.CodeType):' ' cmd = cmd+'#39'\n'#39 @@ -10237,15 +10810,21 @@ object CommandsDataModule: TCommandsDataModule ' except:' ' self.showtraceback()' ' exc_info = sys.exc_info()' - - ' self.exc_info = (exc_info[0].__name__, exc_info[' + - '1], exc_info[2])' + ' if hasattr(exc_info[0], "__name__"):' + ' name = exc_info[0].__name__' + ' elif type(exc_info[0]) == str:' + ' name = exc_info[0]' + ' else:' + ' name = ""' + ' self.exc_info = (name, exc_info[1], exc_info[2])' ' finally:' + ' sys.stdin, sys.stdout, sys.stderr = self.saveStdio' ' if self.debugIDE.cleanupMainDict() and (self.locals ' + 'is globals):' ' self.locals.clear()' ' self.locals.update(maindictcopy)' + ' __import__("gc").collect()' ' if self.debugIDE.cleanupSysModules():' ' sys.modules.clear()' ' sys.modules.update(sysmodulescopy)' @@ -10334,10 +10913,27 @@ object CommandsDataModule: TCommandsDataModule ' sys.stdout = self.AsyncStream(sys.stdout)' ' sys.stderr = self.AsyncStream(sys.stderr)' '' + ' def setupdisplayhook(self):' + ' if pyscripter.IDEOptions.PrettyPrintOutput:' + ' import sys, pprint, __builtin__' + + ' def pphook(value, show=pprint.pprint, bltin=__builti' + + 'n__):' + ' if value is not None:' + ' bltin._ = value' + ' show(value)' + ' sys.displayhook = pphook' + '' + ' def Win32Input(self, prompt=None):' + ' "Provide input() for gui apps"' + ' return eval(raw_input(prompt))' + '' '_RPI = RemotePythonInterpreter(globals())' '' + 'sys.modules['#39'__builtin__'#39'].input=_RPI.Win32Input' 'del code' - 'del RemotePythonInterpreter') + 'del RemotePythonInterpreter' + 'del sys') end item Name = 'SimpleServer' @@ -10346,7 +10942,14 @@ object CommandsDataModule: TCommandsDataModule 'from Rpyc.Utils.Serving import serve_socket, create_listener_soc' + 'ket, DEFAULT_PORT' '' - 'def main(port = DEFAULT_PORT):' + '__traceable__ = 0' + '' + 'def main():' + ' import sys' + ' try:' + ' port = int(sys.argv[1])' + ' except:' + ' port = DEFAULT_PORT' ' sock = create_listener_socket(port)' ' newsock, name = sock.accept()' ' serve_socket(newsock)' @@ -10362,6 +10965,7 @@ object CommandsDataModule: TCommandsDataModule 'import threading' 'import gc' '' + '__traceable__ = 0' 'running = False' '' 'class GuiPart:' @@ -10396,12 +11000,17 @@ object CommandsDataModule: TCommandsDataModule 'EFAULT_PORT' '' ' global running' - ' ' + '' ' self.master = master' '' ' self.conn = None' '' - ' sock = create_listener_socket(DEFAULT_PORT)' + ' import sys' + ' try:' + ' port = int(sys.argv[1])' + ' except:' + ' port = DEFAULT_PORT' + ' sock = create_listener_socket(port)' ' newsock, name = sock.accept()' ' channel = Channel(SocketStream(newsock))' '' @@ -10445,11 +11054,15 @@ object CommandsDataModule: TCommandsDataModule ' pass' ' def tkinter_mainloop(n=0):' ' pass' + ' def dummy_exit(arg=0):' + ' pass' '' ' Tkinter.oldmainloop = Tkinter.mainloop' ' Tkinter.Misc.oldmainloop = Tkinter.Misc.mainloop' ' Tkinter.Misc.mainloop = misc_mainloop' ' Tkinter.mainloop = tkinter_mainloop' + ' import sys' + ' sys.exit = dummy_exit' '' 'def main():' ' root = Tkinter.Tk()' @@ -10469,6 +11082,7 @@ object CommandsDataModule: TCommandsDataModule 'import threading' 'import gc' '' + '__traceable__ = 0' 'running = False' '' 'class GuiPart:' @@ -10484,7 +11098,13 @@ object CommandsDataModule: TCommandsDataModule ' from Rpyc.Utils.Serving import create_listener_socket, D' + 'EFAULT_PORT' - ' sock = create_listener_socket(DEFAULT_PORT)' + '' + ' import sys' + ' try:' + ' port = int(sys.argv[1])' + ' except:' + ' port = DEFAULT_PORT' + ' sock = create_listener_socket(port)' ' newsock, name = sock.accept()' ' channel = Channel(SocketStream(newsock))' ' self.conn = Connection(channel)' @@ -10512,7 +11132,7 @@ object CommandsDataModule: TCommandsDataModule ' def __init__(self, master):' '' ' global running' - ' ' + '' ' self.master = master' '' ' # Set up the GUI part' @@ -10556,10 +11176,20 @@ object CommandsDataModule: TCommandsDataModule ' def RedirectStdio(self, filename=None):' ' pass' '' + ' def RestoreStdio(self):' + ' pass' + '' + ' def dummy_exit(arg=0):' + ' pass' + '' ' wx.PyApp.OldMainLoop = wx.PyApp.MainLoop' ' wx.PyApp.MainLoop = MainLoop' ' wx.App.OldRedirectStdio = wx.App.RedirectStdio' ' wx.App.RedirectStdio = RedirectStdio' + ' wx.App.OldRestoreStdio = wx.App.RestoreStdio' + ' wx.App.RestoreStdio = RestoreStdio' + ' import sys' + ' sys.exit = dummy_exit' '' 'def main():' ' app = wx.PySimpleApp()' @@ -10576,4 +11206,14 @@ object CommandsDataModule: TCommandsDataModule Left = 333 Top = 166 end + object dlgFileOpen: TTntOpenDialogLX + Options = [ofHideReadOnly, ofPathMustExist, ofFileMustExist, ofEnableSizing] + Left = 20 + Top = 16 + end + object dlgFileSave: TTntSaveDialogLX + Options = [ofOverwritePrompt, ofHideReadOnly, ofPathMustExist, ofNoReadOnlyReturn, ofEnableSizing] + Left = 20 + Top = 68 + end end diff --git a/dmCommands.pas b/dmCommands.pas index 152738a42..ee5390e98 100644 --- a/dmCommands.pas +++ b/dmCommands.pas @@ -21,7 +21,7 @@ interface SynEditTextBuffer, SynEditKeyCmds, JvComponentBase, SynHighlighterXML, SynHighlighterCSS, SynHighlighterHtml, JvProgramVersionCheck, JvPropertyStore, SynHighlighterIni, TB2MRU, TBXExtItems, JvAppInst, uEditAppIntfs, SynUnicode, - JvTabBar, JvStringHolder, cPyBaseDebugger; + JvTabBar, JvStringHolder, cPyBaseDebugger, TntDialogs, TntLXDialogs; type TPythonIDEOptions = class(TPersistent) @@ -29,6 +29,7 @@ TPythonIDEOptions = class(TPersistent) fTimeOut : integer; fUndoAfterSave : Boolean; fSaveFilesBeforeRun : Boolean; + fSaveEnvironmentBeforeRun : Boolean; fRestoreOpenFiles : Boolean; fCreateBackupFiles : Boolean; fExporerInitiallyExpanded : Boolean; @@ -60,6 +61,9 @@ TPythonIDEOptions = class(TPersistent) fDetectUTF8Encoding: Boolean; fEditorTabPosition : TJvTabBarOrientation; fPythonEngineType : TPythonEngineType; + fPrettyPrintOutput : Boolean; + fSmartNextPrevPage : Boolean; + fAutoReloadChangedFiles : Boolean; public constructor Create; procedure Assign(Source: TPersistent); override; @@ -69,6 +73,8 @@ TPythonIDEOptions = class(TPersistent) write fUndoAfterSave; property SaveFilesBeforeRun : boolean read fSaveFilesBeforeRun write fSaveFilesBeforeRun; + property SaveEnvironmentBeforeRun : boolean read fSaveEnvironmentBeforeRun + write fSaveEnvironmentBeforeRun; property RestoreOpenFiles : Boolean read fRestoreOpenFiles write fRestoreOpenFiles; property CreateBackupFiles : boolean read fCreateBackupFiles @@ -124,6 +130,10 @@ TPythonIDEOptions = class(TPersistent) write fEditorTabPosition; property PythonEngineType : TPythonEngineType read fPythonEngineType write fPythonEngineType; + property PrettyPrintOutput : Boolean read fPrettyPrintOutput write fPrettyPrintOutput; + property SmartNextPrevPage : Boolean read fSmartNextPrevPage write fSmartNextPrevPage; + property AutoReloadChangedFiles : Boolean read fAutoReloadChangedFiles + write fAutoReloadChangedFiles; end; TEditorSearchOptions = class(TPersistent) @@ -157,7 +167,6 @@ TEditorSearchOptions = class(TPersistent) end; TCommandsDataModule = class(TDataModule) - dlgFileOpen: TOpenDialog; actlMain: TActionList; actFileSave: TAction; actFileSaveAs: TAction; @@ -169,7 +178,6 @@ TCommandsDataModule = class(TDataModule) actSearchFindNext: TAction; actSearchFindPrev: TAction; actSearchReplace: TAction; - dlgFileSave: TSaveDialog; SynPythonSyn: TSynPythonSyn; actFileSaveAll: TAction; SynEditPrint: TSynEditPrint; @@ -243,6 +251,13 @@ TCommandsDataModule = class(TDataModule) actEditAnsi: TAction; actEditUTF8NoBOM: TAction; JvMultiStringHolder: TJvMultiStringHolder; + dlgFileOpen: TTntOpenDialogLX; + dlgFileSave: TTntSaveDialogLX; + actFileReload: TAction; + actImportShortcuts: TAction; + actExportShortCuts: TAction; + actImportHighlighters: TAction; + actExportHighlighters: TAction; function ProgramVersionHTTPLocationLoadFileFromRemote( AProgramVersionLocation: TJvProgramVersionHTTPLocation; const ARemotePath, ARemoteFileName, ALocalPath, ALocalFileName: string): string; @@ -313,6 +328,11 @@ TCommandsDataModule = class(TDataModule) procedure actEditToggleCommentExecute(Sender: TObject); procedure actFileTemplatesExecute(Sender: TObject); procedure actEditFileEncodingExecute(Sender: TObject); + procedure actFileReloadExecute(Sender: TObject); + procedure actExportShortCutsExecute(Sender: TObject); + procedure actImportShortcutsExecute(Sender: TObject); + procedure actExportHighlightersExecute(Sender: TObject); + procedure actImportHighlightersExecute(Sender: TObject); private fHighlighters: TStrings; fUntitledNumbers: TBits; @@ -321,7 +341,6 @@ TCommandsDataModule = class(TDataModule) public BlockOpenerRE : TRegExpr; BlockCloserRE : TRegExpr; - //EOLCleanerRE : TRegExpr; CommentLineRE : TRegExpr; NumberOfOriginalImages : integer; NonExecutableLineRE : TRegExpr; @@ -392,7 +411,8 @@ implementation StoHtmlHelp, {uMMMXP_MainService, }JvJCLUtils, Menus, SynEditStrConst, dlgSearchText, dlgReplaceText, dlgConfirmReplace, dlgCustomShortcuts, dlgUnitTestWizard, WinInet, Math, Registry, ShlObj, ShellAPI, - dlgFileTemplates, JclSysInfo, JclSysUtils, dlgPickList; + dlgFileTemplates, JclSysInfo, JclSysUtils, dlgPickList, JvAppIniStorage, + cFilePersist, JvAppStorage; { TPythonIDEOptions } @@ -403,6 +423,7 @@ procedure TPythonIDEOptions.Assign(Source: TPersistent); Self.fTimeOut := TimeOut; Self.fUndoAfterSave := UndoAfterSave; Self.fSaveFilesBeforeRun := SaveFilesBeforeRun; + Self.fSaveEnvironmentBeforeRun := SaveEnvironmentBeforeRun; Self.fRestoreOpenFiles := fRestoreOpenFiles; Self.fCreateBackUpFiles := CreateBackUpFiles; Self.fExporerInitiallyExpanded := ExporerInitiallyExpanded; @@ -434,6 +455,9 @@ procedure TPythonIDEOptions.Assign(Source: TPersistent); Self.fDetectUTF8Encoding := DetectUTF8Encoding; Self.fEditorTabPosition := EditorTabPosition; Self.fPythonEngineType := PythonEngineType; + Self.fPrettyPrintOutput := PrettyPrintOutput; + Self.fSmartNextPrevPage := SmartNextPrevPage; + Self.fAutoReloadChangedFiles := AutoReloadChangedFiles; end else inherited; @@ -443,13 +467,14 @@ constructor TPythonIDEOptions.Create; begin fTimeOut := 0; // 5000; fSaveFilesBeforeRun := True; + fSaveEnvironmentBeforeRun := False; fCreateBackupFiles := False; fExporerInitiallyExpanded := False; fPythonFileFilter := 'Python Files (*.py;*.pyw)|*.py;*.pyw'; fHTMLFileFilter := SYNS_FilterHTML; fXMLFileFilter := SYNS_FilterXML; fCSSFileFilter := SYNS_FilterCSS; - fFileExplorerFilter := '*.py'; + fFileExplorerFilter := '*.py;*.pyw'; fSearchTextAtCaret := True; fRestoreOpenFiles := True; fDateLastCheckedForUpdates := MinDateTime; @@ -472,6 +497,9 @@ constructor TPythonIDEOptions.Create; fDetectUTF8Encoding := True; fEditorTabPosition := toBottom; fPythonEngineType := peInternal; + fPrettyPrintOutput := True; + fSmartNextPrevPage := True; + fAutoReloadChangedFiles := True; end; { TEditorSearchOptions } @@ -513,6 +541,10 @@ procedure TCommandsDataModule.DataModuleCreate(Sender: TObject); begin // User Data directory for storing the ini file etc. UserDataDir := PathAddSeparator(GetAppdataFolder) + 'PyScripter\'; + if not ForceDirectories(UserDataDir) then + MessageDlg(Format('Pyscripter needs access to the User Application Data directory: "%s". '+ + 'Certain features such as remote debugging will not function properly otherwise.', + [UserDataDir]), mtWarning, [mbOK], 0); // Setup Highlighters fHighlighters := TStringList.Create; TStringList(fHighlighters).CaseSensitive := False; @@ -545,10 +577,6 @@ procedure TCommandsDataModule.DataModuleCreate(Sender: TObject); BlockCloserRE.Expression := '\s*(return|break|continue|raise|pass)\b'; NonExecutableLineRE := TRegExpr.Create; NonExecutableLineRE.Expression := '(^\s*(class|def)\b)|(^\s*#)|(^\s*$)'; - //EOLCleanerRE := TRegExpr.Create; - //EOLCleanerRE.Expression := '(\r\n)|\r|(\n\r)'; - //EOLCleanerRE.ModifierM := True; - //EOLCleanerRE.ModifierS := False; CommentLineRE := TRegExpr.Create; CommentLineRE.Expression := '^##'; CommentLineRE.ModifierM := True; @@ -560,6 +588,12 @@ procedure TCommandsDataModule.DataModuleCreate(Sender: TObject); Gutter.Font.Height := -11; Gutter.Font.Name := 'Courier New'; Gutter.Gradient := True; + Gutter.LeftOffset := 25; + Gutter.RightOffset := 1; + Gutter.Width := 27; + Gutter.DigitCount := 3; + Gutter.Autosize := True; + Options := [eoAutoSizeMaxScrollWidth, eoDragDropEditing, eoEnhanceHomeKey, eoEnhanceEndKey, eoGroupUndo, eoHideShowScrollbars, eoKeepCaretX, eoShowScrollHint, eoSmartTabDelete, eoTabsToSpaces, eoTabIndent, @@ -585,6 +619,7 @@ procedure TCommandsDataModule.DataModuleCreate(Sender: TObject); InterpreterEditorOptions.Assign(EditorOptions); InterpreterEditorOptions.Options := InterpreterEditorOptions.Options - [eoTrimTrailingSpaces, eoTabsToSpaces]; + InterpreterEditorOptions.WordWrap := True; InterpreterEditorOptions.Gutter.Visible := False; InterpreterEditorOptions.RightEdge := 0; @@ -614,6 +649,7 @@ procedure TCommandsDataModule.DataModuleCreate(Sender: TObject); //Program Version Check ProgramVersionCheck.ThreadDialog.DialogOptions.ShowModal := False; ProgramVersionCheck.ThreadDialog.DialogOptions.Caption := 'Downloading...'; + ProgramVersionCheck.ThreadDialog.DialogOptions.ResName := 'WebCopyAvi'; ProgramVersionCheck.LocalDirectory := ExtractFilePath(Application.ExeName)+ 'Updates'; end; @@ -625,7 +661,6 @@ procedure TCommandsDataModule.DataModuleDestroy(Sender: TObject); BlockOpenerRE.Free; BlockCloserRE.Free; NonExecutableLineRE.Free; - //EOLCleanerRE.Free; CommentLineRE.Free; PyIDEOptions.Free; ExcludedFileNotificationdDrives.Free; @@ -685,10 +720,10 @@ function TCommandsDataModule.GetSaveFileName(var ANewName: string; Filter := SFilterAllFiles; DefaultExt := DefaultExtension; - // Make the current file extension the default extension + // Make the current file extension the default extension if DefaultExt = '' then DefaultExt := ExtractFileExt(ANewName); - + if Execute then begin ANewName := FileName; Result := TRUE; @@ -747,6 +782,12 @@ procedure TCommandsDataModule.actFilePrintExecute(Sender: TObject); GI_FileCmds.ExecPrint; end; +procedure TCommandsDataModule.actFileReloadExecute(Sender: TObject); +begin + if GI_FileCmds <> nil then + GI_FileCmds.ExecReload; +end; + procedure TCommandsDataModule.actPrintPreviewExecute(Sender: TObject); begin if GI_FileCmds <> nil then @@ -771,7 +812,7 @@ procedure TCommandsDataModule.actPageSetupExecute(Sender: TObject); procedure TCommandsDataModule.actFileCloseExecute(Sender: TObject); begin if GI_FileCmds <> nil then - GI_FileCmds.ExecClose; + GI_FileCmds.ExecClose; end; procedure TCommandsDataModule.actEditCutExecute(Sender: TObject); @@ -937,6 +978,7 @@ procedure TCommandsDataModule.actEditorOptionsExecute(Sender: TObject); ApplyEditorOptions; end else if Assigned(GI_ActiveEditor) then GI_ActiveEditor.SynEdit.Assign(TempEditorOptions); + PyIDEMainForm.StoreApplicationData; end; Free; end; @@ -1114,6 +1156,129 @@ procedure TCommandsDataModule.actEditUntabifyExecute(Sender: TObject); end; end; +procedure TCommandsDataModule.actExportHighlightersExecute(Sender: TObject); +Var + i : integer; + AppStorage : TJvAppIniFileStorage; +begin + with dlgFileSave do begin + Title := 'Export Highlighters'; + Filter := SynIniSyn.DefaultFilter; + DefaultExt := 'ini'; + if Execute then begin + AppStorage := TJvAppIniFileStorage.Create(nil); + try + AppStorage.FlushOnDestroy := True; + AppStorage.Location := flCustom; + AppStorage.FileName := FileName; + AppStorage.WriteString('PyScripter\Version', ApplicationVersion); + AppStorage.DeleteSubTree('Highlighters'); + for i := 0 to Highlighters.Count - 1 do + AppStorage.WritePersistent('Highlighters\'+Highlighters[i], + TPersistent(Highlighters.Objects[i])); + finally + AppStorage.Free; + end; + end; + end; +end; + +procedure TCommandsDataModule.actExportShortCutsExecute(Sender: TObject); +Var + AppStorage : TJvAppIniFileStorage; + ActionProxyCollection: TActionProxyCollection; +begin + with dlgFileSave do begin + Title := 'Export Shortcuts'; + Filter := SynIniSyn.DefaultFilter; + DefaultExt := 'ini'; + if Execute then begin + AppStorage := TJvAppIniFileStorage.Create(nil); + try + AppStorage.FlushOnDestroy := True; + AppStorage.Location := flCustom; + AppStorage.FileName := FileName; + AppStorage.StorageOptions.StoreDefaultValues := False; + AppStorage.WriteString('PyScripter\Version', ApplicationVersion); + AppStorage.DeleteSubTree('IDE Shortcuts'); + ActionProxyCollection := TActionProxyCollection.Create(PyIDEMainForm.ActionListArray); + try + AppStorage.WriteCollection('IDE Shortcuts', ActionProxyCollection, 'Action'); + finally + ActionProxyCollection.Free; + end; + AppStorage.DeleteSubTree('Editor Shortcuts'); + AppStorage.WriteCollection('Editor Shortcuts', EditorOptions.Keystrokes); + finally + AppStorage.Free; + end; + end; + end; +end; + +procedure TCommandsDataModule.actImportHighlightersExecute(Sender: TObject); +Var + i : integer; + AppStorage : TJvAppIniFileStorage; +begin + with dlgFileOpen do begin + Title := 'Import Highlighters'; + Filter := SynIniSyn.DefaultFilter; + if Execute then begin + AppStorage := TJvAppIniFileStorage.Create(nil); + try + AppStorage.Location := flCustom; + AppStorage.FileName := FileName; + for i := 0 to Highlighters.Count - 1 do + AppStorage.ReadPersistent('Highlighters\'+Highlighters[i], + TPersistent(Highlighters.Objects[i])); + PythonIIForm.SynEdit.Highlighter.Assign(CommandsDataModule.SynPythonSyn); + finally + AppStorage.Free; + end; + end; + end; +end; + +procedure TCommandsDataModule.actImportShortcutsExecute(Sender: TObject); +Var + i : integer; + AppStorage : TJvAppIniFileStorage; + ActionProxyCollection: TActionProxyCollection; +begin + with dlgFileOpen do begin + Title := 'Import Shortcuts'; + Filter := SynIniSyn.DefaultFilter; + if Execute then begin + AppStorage := TJvAppIniFileStorage.Create(nil); + try + AppStorage.Location := flCustom; + AppStorage.FileName := FileName; + + if AppStorage.PathExists('IDE Shortcuts') then begin + ActionProxyCollection := TActionProxyCollection.Create(PyIDEMainForm.ActionListArray); + try + AppStorage.ReadCollection('IDE Shortcuts', ActionProxyCollection, True, 'Action'); + ActionProxyCollection.ApplyShortCuts(PyIDEMainForm.ActionListArray); + finally + ActionProxyCollection.Free; + end; + end; + if AppStorage.PathExists('Editor Shortcuts') then begin + AppStorage.ReadCollection('Editor Shortcuts', EditorOptions.Keystrokes, True); + for i := 0 to GI_EditorFactory.Count - 1 do + GI_EditorFactory.Editor[i].SynEdit.Keystrokes.Assign(EditorOptions.Keystrokes); + InterpreterEditorOptions.Keystrokes.Assign(EditorOptions.Keystrokes); + PythonIIForm.SynEdit.Keystrokes.Assign(EditorOptions.Keystrokes); + PythonIIForm.RegisterHistoryCommands; + end; + finally + AppStorage.Free; + end; + end; + end; +end; + procedure TCommandsDataModule.actEditLBExecute(Sender: TObject); begin if (Sender is TAction) and Assigned(GI_ActiveEditor) then begin @@ -1345,8 +1510,8 @@ procedure TCommandsDataModule.JvChangeNotifyChangeNotify(Sender: TObject; ZeroFileTime : TFileTime = (dwLowDateTime : 0; dwHighDateTime : 0); Var i : integer; + ModifiedCount : integer; SR: TSearchRec; - P : TBufferCoord; Editor : IEditor; ChangedFiles : TStringList; SafeGuard: ISafeGuard; @@ -1370,7 +1535,6 @@ procedure TCommandsDataModule.JvChangeNotifyChangeNotify(Sender: TObject; end; end else if not AreFileTimesEqual(TEditorForm(Editor.Form).FileTime, SR.FindData.ftLastWriteTime) then begin ChangedFiles.AddObject(Editor.GetFileNameOrTitle, Editor.Form); - Editor.SynEdit.Modified := True; // Prevent further notifications on this file TEditorForm(Editor.Form).FileTime := SR.FindData.ftLastWriteTime; end; @@ -1378,8 +1542,24 @@ procedure TCommandsDataModule.JvChangeNotifyChangeNotify(Sender: TObject; end; end; + ModifiedCount := 0; + for I := 0 to ChangedFiles.Count - 1 do begin + Editor := TEditorForm(ChangedFiles.Objects[i]).GetEditor; + if Editor.Modified then + Inc(ModifiedCount); + Editor.SynEdit.Modified := True; //So that we are prompted to save changes + end; + if ChangedFiles.Count > 0 then - with TPickListDialog.Create(Application.MainForm) do begin + if PyIDEOptions.AutoReloadChangedFiles and (ModifiedCount = 0) then begin + for I := 0 to ChangedFiles.Count - 1 do begin + Editor := TEditorForm(ChangedFiles.Objects[i]).GetEditor; + (Editor as IFileCommands).ExecReload(True); + end; + MessageBeep(MB_ICONASTERISK); + PyIDEMainForm.WriteStatusMsg('Changed files have been reloaded'); + end + else with TPickListDialog.Create(Application.MainForm) do begin Caption := 'File Change Notification'; lbMessage.Caption := 'The following files have been changed on disk.'+ ' Select the files that you wish to reload and press the OK button. '+ @@ -1393,10 +1573,7 @@ procedure TCommandsDataModule.JvChangeNotifyChangeNotify(Sender: TObject; for i := CheckListBox.Count - 1 downto 0 do begin if CheckListBox.Checked[i] then begin Editor := TEditorForm(CheckListBox.Items.Objects[i]).GetEditor; - P := Editor.Synedit.CaretXY; - Editor.OpenFile(CheckListBox.Items[i]); - if (P.Line <= Editor.SynEdit.Lines.Count) then - Editor.SynEdit.CaretXY := P; + (Editor as IFileCommands).ExecReload(True); end; end; finally @@ -1451,7 +1628,7 @@ procedure TCommandsDataModule.actIDEOptionsExecute(Sender: TObject); SetLength(Categories, 7); with Categories[0] do begin DisplayName := 'IDE'; - SetLength(Options, 5); + SetLength(Options, 6); Options[0].PropertyName := 'AutoCheckForUpdates'; Options[0].DisplayName := 'Check for updates automatically'; Options[1].PropertyName := 'DaysBetweenChecks'; @@ -1462,22 +1639,28 @@ procedure TCommandsDataModule.actIDEOptionsExecute(Sender: TObject); Options[3].DisplayName := 'Use BicycleRepairMan'; Options[4].PropertyName := 'EditorTabPosition'; Options[4].DisplayName := 'Editor Tab Position'; + Options[5].PropertyName := 'SmartNextPrevPage'; + Options[5].DisplayName := 'Smart Next Previous Page'; end; with Categories[1] do begin DisplayName := 'Python Interpreter'; - SetLength(Options, 6); + SetLength(Options, 8); Options[0].PropertyName := 'SaveFilesBeforeRun'; Options[0].DisplayName := 'Save files before run'; - Options[1].PropertyName := 'TimeOut'; - Options[1].DisplayName := 'Timeout for running scripts in ms'; - Options[2].PropertyName := 'UTF8inInterpreter'; - Options[2].DisplayName := 'UTF8 in interactive interpreter'; - Options[3].PropertyName := 'CleanupMainDict'; - Options[3].DisplayName := 'Clean up namespace after run'; - Options[4].PropertyName := 'CleanupSysModules'; - Options[4].DisplayName := 'Clean up sys.modules after run'; - Options[5].PropertyName := 'PythonEngineType'; - Options[5].DisplayName := 'Python engine type'; + Options[1].PropertyName := 'SaveEnvironmentBeforeRun'; + Options[1].DisplayName := 'Save environment before run'; + Options[2].PropertyName := 'TimeOut'; + Options[2].DisplayName := 'Timeout for running scripts in ms'; + Options[3].PropertyName := 'UTF8inInterpreter'; + Options[3].DisplayName := 'UTF8 in interactive interpreter'; + Options[4].PropertyName := 'CleanupMainDict'; + Options[4].DisplayName := 'Clean up namespace after run'; + Options[5].PropertyName := 'CleanupSysModules'; + Options[5].DisplayName := 'Clean up sys.modules after run'; + Options[6].PropertyName := 'PythonEngineType'; + Options[6].DisplayName := 'Python engine type'; + Options[7].PropertyName := 'PrettyPrintOutput'; + Options[7].DisplayName := 'Pretty Print Output'; end; with Categories[2] do begin DisplayName := 'Code Explorer'; @@ -1501,7 +1684,7 @@ procedure TCommandsDataModule.actIDEOptionsExecute(Sender: TObject); end; with Categories[4] do begin DisplayName := 'Editor'; - SetLength(Options, 12); + SetLength(Options, 13); Options[0].PropertyName := 'RestoreOpenFiles'; Options[0].DisplayName := 'Restore open files'; Options[1].PropertyName := 'SearchTextAtCaret'; @@ -1526,6 +1709,8 @@ procedure TCommandsDataModule.actIDEOptionsExecute(Sender: TObject); Options[10].DisplayName := 'Default file encoding for new files'; Options[11].PropertyName := 'DetectUTF8Encoding'; Options[11].DisplayName := 'Detect UTF-8 encoding when opening files'; + Options[12].PropertyName := 'AutoReloadChangedFiles'; + Options[12].DisplayName := 'Auto-reload changed files'; end; with Categories[5] do begin DisplayName := 'Code Completion'; @@ -1555,6 +1740,7 @@ procedure TCommandsDataModule.actIDEOptionsExecute(Sender: TObject); if InspectOptions(PyIDEOptions, Categories, 'IDE Options', 610) then begin PyIDEMainForm.PyIDEOptionsChanged; + PyIDEMainForm.StoreApplicationData; if PyIDEOptions.FileExplorerContextMenu <> IsRegistered then begin try if IsRegistered then begin @@ -1580,7 +1766,8 @@ procedure TCommandsDataModule.actIDEOptionsExecute(Sender: TObject); procedure TCommandsDataModule.actIDEShortcutsExecute(Sender: TObject); begin with TfrmCustomKeyboard.Create(Self) do begin - Execute(PyIDEMainForm.ActionListArray); + if Execute(PyIDEMainForm.ActionListArray) then + PyIDEMainForm.StoreApplicationData; Release; end; end; @@ -1697,6 +1884,7 @@ procedure TCommandsDataModule.UpdateMainActions; end; // File Actions + actFileReload.Enabled := (GI_FileCmds <> nil) and GI_FileCmds.CanReload; actFileClose.Enabled := (GI_FileCmds <> nil) and GI_FileCmds.CanClose; actFilePrint.Enabled := (GI_FileCmds <> nil) and GI_FileCmds.CanPrint; actPrintPreview.Enabled := actFilePrint.Enabled; @@ -2125,18 +2313,22 @@ procedure TCommandsDataModule.DoSearchReplaceText(SynEdit : TSynEdit; SynEdit.SearchEngine := CommandsDataModule.SynEditRegexSearch else SynEdit.SearchEngine := CommandsDataModule.SynEditSearch; + + PyIDEMainForm.WriteStatusMsg(''); if SynEdit.SearchReplace(EditorSearchOptions.SearchText, EditorSearchOptions.ReplaceText, Options) = 0 then begin MessageBeep(MB_ICONASTERISK); PyIDEMainForm.WriteStatusMsg(Format(SNotFound, [EditorSearchOptions.SearchText])); + fSearchFromCaret := False; if ssoBackwards in Options then SynEdit.BlockEnd := SynEdit.BlockBegin else SynEdit.BlockBegin := SynEdit.BlockEnd; SynEdit.CaretXY := SynEdit.BlockBegin; - end; + end else + fSearchFromCaret := True; if ConfirmReplaceDialog <> nil then ConfirmReplaceDialog.Free; @@ -2187,10 +2379,8 @@ procedure TCommandsDataModule.ShowSearchReplaceDialog(SynEdit : TSynEdit; ARepla EditorSearchOptions.ReplaceTextHistory := ReplaceTextHistory; end; fSearchFromCaret := EditorSearchOptions.SearchFromCaret; - if EditorSearchOptions.SearchText <> '' then begin + if EditorSearchOptions.SearchText <> '' then DoSearchReplaceText(SynEdit, AReplace, EditorSearchOptions.SearchBackwards); - fSearchFromCaret := TRUE; - end; end; finally dlg.Free; diff --git a/frmBreakPoints.dfm b/frmBreakPoints.dfm index 986b66ef7..2c6ba79ef 100644 --- a/frmBreakPoints.dfm +++ b/frmBreakPoints.dfm @@ -42,9 +42,8 @@ inherited BreakPointsWindow: TBreakPointsWindow 00FF00000000000000000000000000000000000000000000000000000000FFFF 0000FFFF0000F8070000F8070000F0030000E0030000E0030000C00300008003 000088030000F8030000F8030000F8070000F80F0000FC1F0000FE7F0000} - OnActivate = FormActivate - ExplicitWidth = 387 - ExplicitHeight = 270 + ExplicitWidth = 395 + ExplicitHeight = 278 DesignSize = ( 379 244) @@ -70,9 +69,10 @@ inherited BreakPointsWindow: TBreakPointsWindow Header.Font.Charset = DEFAULT_CHARSET Header.Font.Color = clWindowText Header.Font.Height = -11 - Header.Font.Name = 'Tahoma' + Header.Font.Name = 'MS Shell Dlg 2' Header.Font.Style = [] Header.Options = [hoColumnResize, hoDrag, hoHotTrack, hoOwnerDraw, hoVisible] + Header.ParentFont = True HintMode = hmTooltip PopupMenu = TBXPopupMenu TabOrder = 0 diff --git a/frmBreakPoints.pas b/frmBreakPoints.pas index dede2c299..2f680b21a 100644 --- a/frmBreakPoints.pas +++ b/frmBreakPoints.pas @@ -31,7 +31,6 @@ TBreakPointsWindow = class(TIDEDockWindow) Node: PVirtualNode); procedure BreakPointLVDblClick(Sender: TObject); procedure mnClearClick(Sender: TObject); - procedure FormActivate(Sender: TObject); procedure FormCreate(Sender: TObject); procedure FormDestroy(Sender: TObject); procedure BreakPointsViewInitNode(Sender: TBaseVirtualTree; ParentNode, @@ -39,6 +38,7 @@ TBreakPointsWindow = class(TIDEDockWindow) procedure BreakPointsViewGetText(Sender: TBaseVirtualTree; Node: PVirtualNode; Column: TColumnIndex; TextType: TVSTTextType; var CellText: WideString); + procedure FormActivate(Sender: TObject); private { Private declarations } fBreakPointsList : TObjectList; @@ -150,10 +150,8 @@ procedure TBreakPointsWindow.mnCopyToClipboardClick(Sender: TObject); procedure TBreakPointsWindow.FormActivate(Sender: TObject); begin inherited; - if not HasFocus then begin - FGPanelEnter(Self); - PostMessage(BreakPointsView.Handle, WM_SETFOCUS, 0, 0); - end; + if BreakPointsView.CanFocus then + BreakPointsView.SetFocus; end; procedure TBreakPointsWindow.FormCreate(Sender: TObject); diff --git a/frmCallStack.dfm b/frmCallStack.dfm index 414763458..089370d5e 100644 --- a/frmCallStack.dfm +++ b/frmCallStack.dfm @@ -42,9 +42,8 @@ inherited CallStackWindow: TCallStackWindow 000000000000000000000000000000000000000000000000000000000000FFFF 0000F1FF0000F9C00000F5C00000EFC00000DE000000BE000000BE070000B007 0000B0070000F03F0000803F0000803F000081FF000081FF000081FF0000} - OnActivate = FormActivate - ExplicitWidth = 389 - ExplicitHeight = 194 + ExplicitWidth = 397 + ExplicitHeight = 202 PixelsPerInch = 96 TextHeight = 13 inherited FGPanel: TPanel @@ -71,10 +70,11 @@ inherited CallStackWindow: TCallStackWindow Header.Font.Charset = DEFAULT_CHARSET Header.Font.Color = clWindowText Header.Font.Height = -11 - Header.Font.Name = 'Tahoma' + Header.Font.Name = 'MS Shell Dlg 2' Header.Font.Style = [] Header.MainColumn = 1 Header.Options = [hoColumnResize, hoDrag, hoHotTrack, hoOwnerDraw, hoVisible] + Header.ParentFont = True HintMode = hmTooltip TabOrder = 0 TreeOptions.AnimationOptions = [toAnimatedToggle] diff --git a/frmCallStack.pas b/frmCallStack.pas index 48c4bf948..80e163443 100644 --- a/frmCallStack.pas +++ b/frmCallStack.pas @@ -18,7 +18,6 @@ interface TCallStackWindow = class(TIDEDockWindow) CallStackView: TVirtualStringTree; procedure CallStackViewDblClick(Sender: TObject); - procedure FormActivate(Sender: TObject); procedure FormCreate(Sender: TObject); procedure FormDestroy(Sender: TObject); procedure CallStackViewGetText(Sender: TBaseVirtualTree; @@ -28,6 +27,7 @@ TCallStackWindow = class(TIDEDockWindow) Node: PVirtualNode; var InitialStates: TVirtualNodeInitStates); procedure CallStackViewChange(Sender: TBaseVirtualTree; Node: PVirtualNode); + procedure FormActivate(Sender: TObject); private { Private declarations } SelectedNode: PVirtualNode; @@ -121,15 +121,6 @@ procedure TCallStackWindow.CallStackViewDblClick(Sender: TObject); PyIDEMainForm.ShowFilePosition(FileName, Line, 1); end; -procedure TCallStackWindow.FormActivate(Sender: TObject); -begin - inherited; - if not HasFocus then begin - FGPanelEnter(Self); - PostMessage(CallStackView.Handle, WM_SETFOCUS, 0, 0); - end; -end; - procedure TCallStackWindow.TBMThemeChange(var Message: TMessage); begin inherited; @@ -140,6 +131,13 @@ procedure TCallStackWindow.TBMThemeChange(var Message: TMessage); end; end; +procedure TCallStackWindow.FormActivate(Sender: TObject); +begin + inherited; + if CallStackView.CanFocus then + CallStackView.SetFocus; +end; + procedure TCallStackWindow.FormCreate(Sender: TObject); begin inherited; diff --git a/frmCodeExplorer.dfm b/frmCodeExplorer.dfm index 4857f17a5..1792bb3d3 100644 --- a/frmCodeExplorer.dfm +++ b/frmCodeExplorer.dfm @@ -30,9 +30,8 @@ inherited CodeExplorerWindow: TCodeExplorerWindow 0000000000000003C0008003E0008007E001C007E001E00FF003F807E10FFFC4 03FFFFC003FFFFE007FFFFC003FFFF8003FFFF8001FFFF0001FFFF0001FFFF00 01FFFF0001FFFF8003FFFF8003FFFFC007FFFFE00FFFFFF83FFFFFFFFFFF} - OnActivate = FormActivate - ExplicitWidth = 257 - ExplicitHeight = 332 + ExplicitWidth = 265 + ExplicitHeight = 340 PixelsPerInch = 96 TextHeight = 13 inherited FGPanel: TPanel diff --git a/frmCodeExplorer.pas b/frmCodeExplorer.pas index 5b391f647..544ddbb71 100644 --- a/frmCodeExplorer.pas +++ b/frmCodeExplorer.pas @@ -375,6 +375,13 @@ TNodeDataRec = record CENode : TAbstractCENode; end; +procedure TCodeExplorerWindow.FormActivate(Sender: TObject); +begin + inherited; + if ExplorerTree.CanFocus then + ExplorerTree.SetFocus; +end; + procedure TCodeExplorerWindow.FormCreate(Sender: TObject); begin inherited; @@ -509,15 +516,6 @@ procedure TCodeExplorerWindow.nCollapseAllClick(Sender: TObject); ExplorerTree.FullCollapse; end; -procedure TCodeExplorerWindow.FormActivate(Sender: TObject); -begin - inherited; - if not HasFocus then begin - FGPanelEnter(Self); - PostMessage(ExplorerTree.Handle, WM_SETFOCUS, 0, 0); - end; -end; - { TAbstractCENode } procedure TAbstractCENode.AddChild(CENode: TAbstractCENode); diff --git a/frmCommandOutput.dfm b/frmCommandOutput.dfm index 790e7bad5..9ad6801a4 100644 --- a/frmCommandOutput.dfm +++ b/frmCommandOutput.dfm @@ -42,9 +42,8 @@ inherited OutputWindow: TOutputWindow 000000000000000000000000000000000000000000000000000000000000FFFF 0000FFFF00000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000FFFF0000} - OnActivate = FormActivate - ExplicitWidth = 560 - ExplicitHeight = 357 + ExplicitWidth = 568 + ExplicitHeight = 365 PixelsPerInch = 96 TextHeight = 13 inherited FGPanel: TPanel diff --git a/frmCommandOutput.pas b/frmCommandOutput.pas index 8da3c0910..255f21276 100644 --- a/frmCommandOutput.pas +++ b/frmCommandOutput.pas @@ -35,7 +35,6 @@ TOutputWindow = class(TIDEDockWindow) N2: TTBXSeparatorItem; Font1: TTBXItem; BackgroundColor1: TTBXItem; - procedure FormActivate(Sender: TObject); procedure actSelectColorExecute(Sender: TObject); procedure actOutputFontExecute(Sender: TObject); procedure actClearOutputExecute(Sender: TObject); @@ -53,6 +52,7 @@ TOutputWindow = class(TIDEDockWindow) procedure FormCreate(Sender: TObject); procedure FormDestroy(Sender: TObject); procedure TimeoutTimerTimer(Sender: TObject); + procedure FormActivate(Sender: TObject); private { Private declarations } fTool : TExternalTool; @@ -124,15 +124,6 @@ procedure TOutputWindow.ClearScreen; fItemMaxWidth := 0; end; -procedure TOutputWindow.FormActivate(Sender: TObject); -begin - inherited; - if not HasFocus then begin - FGPanelEnter(Self); - PostMessage(lsbConsole.Handle, WM_SETFOCUS, 0, 0); - end; -end; - procedure TOutputWindow.actSelectColorExecute(Sender: TObject); begin with TColorDialog.Create(Application) do @@ -595,6 +586,13 @@ procedure TOutputWindow.OutputActionsUpdate(Action: TBasicAction; not (coRedirect in JvCreateProcess.ConsoleOptions); end; +procedure TOutputWindow.FormActivate(Sender: TObject); +begin + inherited; + if lsbConsole.CanFocus then + lsbConsole.SetFocus; +end; + procedure TOutputWindow.FormCreate(Sender: TObject); begin inherited; diff --git a/frmEditor.pas b/frmEditor.pas index 24e604196..7150837e7 100644 --- a/frmEditor.pas +++ b/frmEditor.pas @@ -151,6 +151,7 @@ TEditor = class(TInterfacedObject, IUnknown, IEditor, IEditCommands, IFileComm function GetEncodedText : string; procedure OpenFile(const AFileName: string; HighlighterName : string = ''); function HasPythonFile : Boolean; + procedure ExecuteSelection; function GetForm : TForm; // IEditCommands implementation function CanCopy: boolean; @@ -172,11 +173,13 @@ TEditor = class(TInterfacedObject, IUnknown, IEditor, IEditCommands, IFileComm function CanPrint: boolean; function CanSave: boolean; function CanSaveAs: boolean; + function CanReload: boolean; procedure ExecClose; procedure ExecPrint; procedure ExecPrintPreview; procedure ExecSave; procedure ExecSaveAs; + procedure ExecReload(Quiet : Boolean = False); // ISearchCommands implementation function CanFind: boolean; function CanFindNext: boolean; @@ -213,7 +216,7 @@ implementation TBXThemes, StringResources, JclStrings, VarPyth, cRefactoring, cPythonSourceScanner, cCodeHint, frmPythonII, dlgConfirmReplace, Math, JvTypes, frmWatches, JclSysUtils, PythonEngine, frmMessages, - SynEditTextBuffer, cPyDebugger, dlgPickList; + SynEditTextBuffer, cPyDebugger, dlgPickList, JvDockControlForm; const WM_DELETETHIS = WM_USER + 42; @@ -417,6 +420,7 @@ procedure TEditor.Close; TabSheet := (fForm.Parent as TJvStandardPage); fForm.Close; TabSheet.Free; + PyIDEMainForm.zOrder.Remove(TabBarItem); FreeAndNil(TabBarItem); CodeExplorerWindow.UpdateWindow; CommandsDataModule.UpdateChangeNotify; @@ -695,6 +699,11 @@ function TEditor.CanRedo: boolean; Result := (fForm <> nil) and fForm.SynEdit.CanRedo; end; +function TEditor.CanReload: boolean; +begin + Result := fFileName <> ''; +end; + function TEditor.CanSelectAll: boolean; begin Result := fForm <> nil; @@ -735,6 +744,21 @@ procedure TEditor.ExecRedo; fForm.SynEdit.Redo; end; +procedure TEditor.ExecReload(Quiet : Boolean = False); +Var + P : TBufferCoord; +begin + if Quiet or not GetModified or + (MessageDlg('Reloading the file will result in the loss of all changes. Do you want to proceed?', + mtWarning, [mbYes, mbNo], 0) = mrYes) + then begin + P := GetSynedit.CaretXY; + OpenFile(GetFileName); + if (P.Line <= GetSynEdit.Lines.Count) then + GetSynEdit.CaretXY := P; + end; +end; + procedure TEditor.ExecSelectAll; begin if fForm <> nil then @@ -747,6 +771,32 @@ procedure TEditor.ExecUndo; fForm.SynEdit.Undo; end; +procedure TEditor.ExecuteSelection; +var + EncodedSource: string; +begin + if not (HasPythonFile and fHasSelection) then Exit; + EncodedSource := UTF8BOMString + CleanEOLs(Utf8Encode(fForm.SynEdit.SelText))+#10; + + ShowDockForm(PythonIIForm); + PythonIIForm.SynEdit.ExecuteCommand(ecEditorBottom, ' ', nil); + PythonIIForm.AppendText(WideLineBreak); + + // RunSource + case PyControl.DebuggerState of + dsInactive : + PyControl.ActiveInterpreter.RunSource(EncodedSource, '', 'exec'); + dsPaused : + PyControl.ActiveDebugger.RunSource(EncodedSource, '', 'exec'); + else //dsRunning, dsRunningNoDebug + // it is dangerous to execute code while running scripts + // so just beep and do nothing + Beep(); + end; + PythonIIForm.WritePendingMessages; + PythonIIForm.AppendPrompt; +end; + // IFileCommands implementation function TEditor.CanPrint: boolean; @@ -1335,6 +1385,10 @@ function TEditorForm.DoSaveFile: boolean; end; Result := True; + // Trim the last lin + if (eoTrimTrailingSpaces in Synedit.Options) and (SynEdit.Lines.Count > 0) then + SynEdit.Lines[SynEdit.Lines.Count -1] := TrimRight(SynEdit.Lines[SynEdit.Lines.Count -1]); + if fEditor.fFileEncoding = sf_Ansi then Result := fEditor.GetEncodedTextEx(S, True); @@ -1496,6 +1550,9 @@ procedure TEditorForm.doProcessUserCommand(Sender: TObject; Indent := Indent + iPrevLine[Position]; Inc(Position); end; + + if (eoTrimTrailingSpaces in Synedit.Options) and (IPrevLine = '') then + SynEdit.Lines[ SynEdit.CaretY -2 ] := ''; if CommandsDataModule.IsBlockOpener(iPrevLine) or (Indent <> '') then begin @@ -1526,7 +1583,7 @@ procedure TEditorForm.doProcessUserCommand(Sender: TObject; end; // use ReplaceSel to ensure it goes at the cursor rather than end of buffer if Trim(iPrevLine) <> '' then - SynEdit.SelText := indent; + SynEdit.SelText := Indent; finally SynEdit.UndoList.EndBlock; SynEdit.Options := OldOptions; @@ -1677,7 +1734,8 @@ procedure TEditorForm.SynEditGutterClick(Sender: TObject; if (SynEdit.Highlighter = CommandsDataModule.SynPythonSyn) and (PyControl.ActiveDebugger <> nil) and not (sfGutterDragging in SynEdit.StateFlags) then - PyControl.ToggleBreakpoint(fEditor, SynEdit.RowToLine(Line)); + PyControl.ToggleBreakpoint(fEditor, SynEdit.RowToLine(Line), + GetKeyState(VK_CONTROL)<0); end; procedure TEditorForm.SynEditSpecialLineColors(Sender: TObject; @@ -1967,7 +2025,6 @@ procedure TEditorForm.AutoCompleteBeforeExecute(Sender: TObject); end; procedure TEditorForm.TBMThemeChange(var Message: TMessage); - begin if Message.WParam = TSC_VIEWCHANGE then begin if HasFocus then @@ -1985,7 +2042,7 @@ procedure TEditorForm.TBMThemeChange(var Message: TMessage); procedure TEditorForm.SynEditReplaceText(Sender: TObject; const ASearch, AReplace: WideString; Line, Column: Integer; var Action: TSynReplaceAction); -var +Var APos: TPoint; EditRect: TRect; begin @@ -2016,7 +2073,7 @@ procedure TEditorForm.SynEditReplaceText(Sender: TObject; const ASearch, procedure TEditorForm.SynCodeCompletionExecute(Kind: SynCompletionType; Sender: TObject; var CurrentInput: WideString; var x, y: Integer; var CanExecute: Boolean); -var +Var locline, lookup: string; TmpX, Index, ImageIndex, i, TmpLocation : Integer; @@ -2131,10 +2188,19 @@ procedure TEditorForm.SynCodeCompletionExecute(Kind: SynCompletionType; end; end; +type + TParamCompletionData = record + lookup, + DisplayText, + Doc : string; + end; +Var + OldParamCompetionData : TParamCompletionData; + procedure TEditorForm.SynParamCompletionExecute(Kind: SynCompletionType; Sender: TObject; var CurrentInput: WideString; var x, y: Integer; var CanExecute: Boolean); -var +Var locline, lookup: String; TmpX, StartX, ParenCounter, @@ -2149,6 +2215,7 @@ procedure TEditorForm.SynParamCompletionExecute(Kind: SynCompletionType; TokenType, Start: Integer; Token: WideString; Attri: TSynHighlighterAttributes; + AlreadyActive : Boolean; begin if not fEditor.HasPythonFile or PyControl.IsRunning then begin CanExecute := False; @@ -2157,6 +2224,8 @@ procedure TEditorForm.SynParamCompletionExecute(Kind: SynCompletionType; with TSynCompletionProposal(Sender).Editor do begin + AlreadyActive := TSynCompletionProposal(Sender).Form.Visible; + locLine := LineText; //go back from the cursor and find the first open paren @@ -2202,36 +2271,45 @@ procedure TEditorForm.SynParamCompletionExecute(Kind: SynCompletionType; (Attri = CommandsDataModule.SynPythonSyn.SystemAttri) then begin lookup := GetWordAtPos(LocLine, TmpX, IdentChars+['.'], True, False); - - FName := GetEditor.GetFileNameOrTitle; - // Add the file path to the Python path - Will be automatically removed - PythonPathAdder := InternalInterpreter.AddPathToPythonPath(ExtractFilePath(FName)); - - PyScripterRefactor.InitializeQuery; - // GetParsedModule - ParsedModule := PyScripterRefactor.GetParsedModule( - FileNameToModuleName(FName), None); - Scope := nil; - if Assigned(ParsedModule) then - Scope := ParsedModule.GetScopeForLine(CaretY); - if Assigned(ParsedModule) and Assigned(Scope) then begin - Def := PyScripterRefactor.FindDottedDefinition(lookup, ParsedModule, - Scope, ErrMsg); - - if Assigned(Def) and (Def is TParsedClass) then - Def := TParsedClass(Def).GetConstructor; - - if Assigned(Def) and (Def is TParsedFunction) then begin - DisplayText := TParsedFunction(Def).ArgumentsString; - // Remove self arguments from methods - if StrIsLeft(PChar(DisplayText), 'self') then - Delete(DisplayText, 1, 4); - if StrIsLeft(PChar(DisplayText), ', ') then - Delete(DisplayText, 1, 2); - Doc := TParsedFunction(Def).DocString; - if Doc <> '' then - Doc := GetNthLine(Doc, 1); - FoundMatch := True; + if AlreadyActive and (lookup = OldParamCompetionData.lookup) then begin + DisplayText := OldParamCompetionData.DisplayText; + Doc := OldParamCompetionData.Doc; + FoundMatch := True; + end else begin + FName := GetEditor.GetFileNameOrTitle; + // Add the file path to the Python path - Will be automatically removed + PythonPathAdder := InternalInterpreter.AddPathToPythonPath(ExtractFilePath(FName)); + + PyScripterRefactor.InitializeQuery; + // GetParsedModule + ParsedModule := PyScripterRefactor.GetParsedModule( + FileNameToModuleName(FName), None); + Scope := nil; + if Assigned(ParsedModule) then + Scope := ParsedModule.GetScopeForLine(CaretY); + if Assigned(ParsedModule) and Assigned(Scope) then begin + Def := PyScripterRefactor.FindDottedDefinition(lookup, ParsedModule, + Scope, ErrMsg); + + if Assigned(Def) and (Def is TParsedClass) then + Def := TParsedClass(Def).GetConstructor; + + if Assigned(Def) and (Def is TParsedFunction) then begin + DisplayText := TParsedFunction(Def).ArgumentsString; + // Remove self arguments from methods + if StrIsLeft(PChar(DisplayText), 'self') then + Delete(DisplayText, 1, 4); + if StrIsLeft(PChar(DisplayText), ', ') then + Delete(DisplayText, 1, 2); + Doc := TParsedFunction(Def).DocString; + if Doc <> '' then + Doc := GetNthLine(Doc, 1); + + OldParamCompetionData.lookup := lookup; + OldParamCompetionData.DisplayText := DisplayText; + OldParamCompetionData.Doc := Doc; + FoundMatch := True; + end; end; end; end; diff --git a/frmFileExplorer.dfm b/frmFileExplorer.dfm index 3e97ce154..7ba9fdb62 100644 --- a/frmFileExplorer.dfm +++ b/frmFileExplorer.dfm @@ -34,7 +34,7 @@ inherited FileExplorerWindow: TFileExplorerWindow 000000000000000000000000000000000000000000000000000000000000FBC1 0000FD410000FBC10000FFFF0000FBC10000FD410000FBC10000FFFF0000001F 0000001F0000001F0000001F0000001F0000001F0000003F00000FFF0000} - OnActivate = FormActivate + ExplicitWidth = 237 ExplicitHeight = 465 PixelsPerInch = 96 TextHeight = 13 diff --git a/frmFileExplorer.pas b/frmFileExplorer.pas index 6c03e12b3..13c0ab424 100644 --- a/frmFileExplorer.pas +++ b/frmFileExplorer.pas @@ -104,7 +104,6 @@ TFileExplorerWindow = class(TIDEDockWindow) procedure actGoUpExecute(Sender: TObject); procedure actRefreshExecute(Sender: TObject); procedure actEnableFilterExecute(Sender: TObject); - procedure FormActivate(Sender: TObject); procedure TBXItemBackPopup(Sender: TTBCustomItem; FromLink: Boolean); procedure TBXItemForwardPopup(Sender: TTBCustomItem; @@ -117,6 +116,7 @@ TFileExplorerWindow = class(TIDEDockWindow) procedure actAddToFavouritesExecute(Sender: TObject); procedure mnFavouritesPopup(Sender: TTBCustomItem; FromLink: Boolean); procedure actNewFolderExecute(Sender: TObject); + procedure FormActivate(Sender: TObject); private fFavourites: TStringList; { Private declarations } @@ -400,10 +400,8 @@ procedure TFileExplorerWindow.FileExplorerActionsUpdate( procedure TFileExplorerWindow.FormActivate(Sender: TObject); begin inherited; - if not HasFocus then begin - FGPanelEnter(Self); - PostMessage(FileExplorerTree.Handle, WM_SETFOCUS, 0, 0); - end; + if FileExplorerTree.CanFocus then + FileExplorerTree.SetFocus; end; procedure TFileExplorerWindow.FormCreate(Sender: TObject); diff --git a/frmFindResults.dfm b/frmFindResults.dfm index ce18f9257..b96982018 100644 --- a/frmFindResults.dfm +++ b/frmFindResults.dfm @@ -5,6 +5,7 @@ inherited FindResultsWindow: TFindResultsWindow Caption = 'Find in Files Results' ClientHeight = 339 ClientWidth = 603 + Font.Name = 'Tahoma' Icon.Data = { 0000010001001010000000000000680500001600000028000000100000002000 0000010008000000000040010000000000000000000000010000000000000000 @@ -50,11 +51,10 @@ inherited FindResultsWindow: TFindResultsWindow 0000000000000000F77E8477007D0000000000000000000000F77E7E100080FF 0000007F0000000F000000030000000100000001000000010000000100000001 0000000300000007000080030000E0010000FF800000FFC00000FFE00000} - OnActivate = FormActivate OnKeyPress = FormKeyPress OnShow = FormShow - ExplicitWidth = 611 - ExplicitHeight = 365 + ExplicitWidth = 619 + ExplicitHeight = 373 PixelsPerInch = 96 TextHeight = 13 inherited FGPanel: TPanel diff --git a/frmFindResults.pas b/frmFindResults.pas index df4458d7c..438e74d10 100644 --- a/frmFindResults.pas +++ b/frmFindResults.pas @@ -145,9 +145,9 @@ TFindResultsWindow = class(TIDEDockWindow, IJvAppStorageHandler) procedure FormShow(Sender: TObject); procedure actReplaceAllExecute(Sender: TObject); procedure actReplaceSelectedExecute(Sender: TObject); - procedure FormActivate(Sender: TObject); procedure actViewStatusBarExecute(Sender: TObject); procedure actHelpHelpExecute(Sender: TObject); + procedure FormActivate(Sender: TObject); private FSearchInProgress: Boolean; FReplaceInProgress: Boolean; @@ -262,6 +262,13 @@ procedure TFindResultsWindow.lbResultsKeyPress(Sender: TObject; end; end; +procedure TFindResultsWindow.FormActivate(Sender: TObject); +begin + inherited; + if lbResults.CanFocus then + lbResults.SetFocus; +end; + procedure TFindResultsWindow.FormKeyPress(Sender: TObject; var Key: Char); begin inherited; @@ -1241,15 +1248,6 @@ procedure PrintGrepResults(Owner: TWinControl; Results: TStrings; Where: TGrepOu end; end; -procedure TFindResultsWindow.FormActivate(Sender: TObject); -begin - inherited; - if not HasFocus then begin - FGPanelEnter(Self); - PostMessage(lbResults.Handle, WM_SETFOCUS, 0, 0); - end; -end; - procedure TFindResultsWindow.ReadFromAppStorage( AppStorage: TJvCustomAppStorage; const BasePath: string); begin diff --git a/frmIDEDockWin.dfm b/frmIDEDockWin.dfm index ad3a07b46..44f3d0a91 100644 --- a/frmIDEDockWin.dfm +++ b/frmIDEDockWin.dfm @@ -17,8 +17,10 @@ object IDEDockWindow: TIDEDockWindow FormStyle = fsStayOnTop OldCreateOrder = False ShowHint = True + OnActivate = FormActivate OnCreate = FormCreate OnDestroy = FormDestroy + OnDeactivate = FormDeactivate OnResize = FormResize DesignSize = ( 229 @@ -35,8 +37,6 @@ object IDEDockWindow: TIDEDockWindow FullRepaint = False ParentBackground = False TabOrder = 0 - OnEnter = FGPanelEnter - OnExit = FGPanelExit end object DockClient: TJvDockClient LRDockWidth = 220 diff --git a/frmIDEDockWin.pas b/frmIDEDockWin.pas index 8d843998c..c1c42b0f7 100644 --- a/frmIDEDockWin.pas +++ b/frmIDEDockWin.pas @@ -19,13 +19,13 @@ interface TIDEDockWindow = class(TForm) DockClient: TJvDockClient; FGPanel: TPanel; - procedure FGPanelEnter(Sender: TObject); - procedure FGPanelExit(Sender: TObject); procedure FormResize(Sender: TObject); procedure FormCreate(Sender: TObject); procedure FormDestroy(Sender: TObject); procedure DockClientTabHostFormCreated(DockClient: TJvDockClient; TabHost: TJvDockTabHostForm); + procedure FormDeactivate(Sender: TObject); + procedure FormActivate(Sender: TObject); private { Private declarations } protected @@ -44,19 +44,6 @@ implementation {$R *.dfm} -procedure TIDEDockWindow.FGPanelEnter(Sender: TObject); -begin - HasFocus := True; - Color := CurrentTheme.GetItemColor(GetItemInfo('hot')); -end; - -procedure TIDEDockWindow.FGPanelExit(Sender: TObject); -begin - HasFocus := False; - //Color := CurrentTheme.GetItemColor(GetItemInfo('inactive')); - Color := GetBorderColor('inactive'); -end; - procedure TIDEDockWindow.FormResize(Sender: TObject); begin with FGPanel do begin @@ -86,16 +73,31 @@ procedure TIDEDockWindow.TBMThemeChange(var Message: TMessage); end; end; +procedure TIDEDockWindow.FormActivate(Sender: TObject); +begin + HasFocus := True; + Color := CurrentTheme.GetItemColor(GetItemInfo('hot')); +end; + procedure TIDEDockWindow.FormCreate(Sender: TObject); begin + SetDesktopIconFonts(Self.Font); // For Vista + SetVistaContentFonts(FGPanel.Font); FGPanel.ControlStyle := FGPanel.ControlStyle + [csOpaque]; FormResize(Self); - FGPanelExit(Self); + //FGPanelExit(Self); AddThemeNotification(Self); end; +procedure TIDEDockWindow.FormDeactivate(Sender: TObject); +begin + HasFocus := False; + //Color := CurrentTheme.GetItemColor(GetItemInfo('inactive')); + Color := GetBorderColor('inactive'); +end; + procedure TIDEDockWindow.FormDestroy(Sender: TObject); begin RemoveThemeNotification(Self); diff --git a/frmMessages.dfm b/frmMessages.dfm index 48089055b..ee0b638c5 100644 --- a/frmMessages.dfm +++ b/frmMessages.dfm @@ -42,9 +42,8 @@ inherited MessagesWindow: TMessagesWindow 000000000000000000000000000000000000000000000000000000000000F9FF 0000F8FF0000F87F0000C0000000C0000000C0000000C0000000C0000000C000 0000C0000000C0000000C0000000C0000000C0000000FFFF0000FFFF0000} - OnActivate = FormActivate - ExplicitWidth = 701 - ExplicitHeight = 212 + ExplicitWidth = 709 + ExplicitHeight = 220 PixelsPerInch = 96 TextHeight = 13 inherited FGPanel: TPanel @@ -66,9 +65,10 @@ inherited MessagesWindow: TMessagesWindow Header.Font.Charset = DEFAULT_CHARSET Header.Font.Color = clWindowText Header.Font.Height = -11 - Header.Font.Name = 'Tahoma' + Header.Font.Name = 'MS Shell Dlg 2' Header.Font.Style = [] Header.Options = [hoColumnResize, hoDrag, hoHotTrack, hoOwnerDraw, hoVisible] + Header.ParentFont = True HintMode = hmTooltip PopupMenu = TBXPopupMenu TabOrder = 0 diff --git a/frmMessages.pas b/frmMessages.pas index 499317cdb..dd18323b5 100644 --- a/frmMessages.pas +++ b/frmMessages.pas @@ -38,7 +38,6 @@ TMessagesWindow = class(TIDEDockWindow) procedure TBXPopupMenuPopup(Sender: TObject); procedure actCopyToClipboardExecute(Sender: TObject); procedure ClearAllExecute(Sender: TObject); - procedure FormActivate(Sender: TObject); procedure FormCreate(Sender: TObject); procedure FormDestroy(Sender: TObject); procedure MessagesViewInitNode(Sender: TBaseVirtualTree; ParentNode, @@ -49,6 +48,7 @@ TMessagesWindow = class(TIDEDockWindow) procedure MessagesViewDblClick(Sender: TObject); procedure actNextMsgsExecute(Sender: TObject); procedure actPreviousMsgsExecute(Sender: TObject); + procedure FormActivate(Sender: TObject); private { Private declarations } fMessageHistory : TObjectList; @@ -220,15 +220,6 @@ procedure TMessagesWindow.ShowWindow; ShowDockForm(Self); end; -procedure TMessagesWindow.FormActivate(Sender: TObject); -begin - inherited; - if not HasFocus then begin - FGPanelEnter(Self); - PostMessage(MessagesView.Handle, WM_SETFOCUS, 0, 0); - end; -end; - procedure TMessagesWindow.JumpToPosition(Node : PVirtualNode); Var Msg : TMsg; @@ -242,6 +233,13 @@ procedure TMessagesWindow.JumpToPosition(Node : PVirtualNode); end; end; +procedure TMessagesWindow.FormActivate(Sender: TObject); +begin + inherited; + if MessagesView.CanFocus then + MessagesView.SetFocus; +end; + procedure TMessagesWindow.FormCreate(Sender: TObject); begin inherited; diff --git a/frmPyIDEMain.dfm b/frmPyIDEMain.dfm index b0b76c99cf7ee03ca9273a2684ec495d9503778d..38a7fab4d1306ebcf89089a0b4cdc5240ceddfe3 100644 GIT binary patch delta 2913 zcmbtWO>7%Q6!xxNuN}uulQ?eE7`knU)6k+OaT>d{hdTcuaS~!TsVbUwV^8eG>)q}C zBu;1=3P>#+P|66XgoKh_da01wRXK2=LPAJ@gt#Eoa-k9kai~-T96&{4W`Araaa$x# zt9kFud*6QZ-ZyjM3-aL|a@9}%bp1vk)3K8p=SRTeagp*Rd1XM5@}np8HC*o4?@Kar zu7{C&R7DYZH@wzyxIVmXnoTQN`$N(>1lUYgv3~`B@8Adxp6UFd(LK(`1yu$ppEt?O zqP^x49tk%$RgLp~vs^F7rgEs9?zYx&CVUj-_#n&@VYsbJ^w?YjD#s<*CE$k4+FtEy z*DnO5A_}~paFNk=C_KNrYJlayB;W)l4bOKUg|DyI!N0nF@Ri6R_(^w6`#f^XfsD_< z8>jtEk#1)!rLY1|ZD&$Se*vTtfCIV(?ip#-K0NAmt>pQMMI|fn{d|VyflT!>BHrTk z8fMzCBg!TOQ57lwrg+_Ib0w2KCx#V}cbnfxmsPqJl{Qih^9qo7hO?E2!9oA1T)Gz|bMVE%`e3BvQ32Bhcws$6bmK5Oa>xp6D67Kqtim!J zA{}wkpw;%bY=h!hE!lY(Ugu91y8Zg<|9cNfR4tN!Q6K{gE z@x3R#A#9?Pg22r(64fj4iX?E92V1cb^|)sUa3Xeqf@04Sjv6Q-)P{b;1()>a%<+_;ef!v#ZQ-On0)H768C zQDqvDyooKj=s*qJqFoq!K*7XdZDS;2^)MdkNg$(N0vIiPb+AEuZHgy}M(wu~-#gIf z%Tx1sb?i)@K%bA8l)cVWGSXcXGOZaj5p|@YaO5u2PS(STxo{=(yK^fQvcOR0V>)C{ z3L=@cQOTIDFWYO+RR9&( z+^+2_4cddu6#}-Ob!gt)U3;Lx5ICBl=a5dKW1s~Q@Y>(}n+~`tIw+Gcc>mnf?wXLb zs$KTO?U#bS2Gc+T+$!%}_O~n)p*T*i*=%KCc9iIcmzQ^72=Jn;dWsuJS$ingkkv(l zeSy|I^LL%v%K2~I#Jo0fX_X8-LW%Cp?+7+c0!y1hOMo`z80az$Z*a{srOaoKl_3iv zWJYi)!4fb@v=vXMq@|WFyLuS~WCUr^X`fViczY@EwB@3DvmliNX?NA2B&gyrp9Tez zKq%U}cO91jjfP*Bb_=C(X_SG&XJ>#iTo9ezu!Rx{J+LR43`uN+;Et(^pjUPmuO$kd z8jjxrWJL$U(30-9fEaW=2FPQ0vF;ch8u=t>LEc$y?4b9BlDW360K=H6$^hv(L86m6 zokp4wMf6-?@GUI=ALP>o9l6~^e#ku7O01TUPZzc#pXho5@`Zxgo&OO!j9m_BKfm>- z%Ud;^XEMO(Cl%g>2jJSW3y-RI<8uWKM6RwsWGDeGThACnMuX-d>i3L3yHY8nyh43x zWai691`qRwdfGqm7P;Lwz^QT;J>ZbcO2VQG-h6Ms^_@+ZxxBV;rOrjA^~K9@b?ut* zYKR&ylEaov<1vdf1vZZ!7{;xF1DYaHD`1n33lb81zZO})NVxQndEkPdUhUcCF;#Vx zl@%{a$_?l9s=~~20KFCW?d;nmzQuRIujg);-T~K_zlOy7{o{UJh4Isup5T}iK&q>} uR6PYG88w|gag=9HoKKAjDLnYq34G0@rx;EJvd`ui1#^o150eO+&Gs*|?D`7; delta 1158 zcma)4OK1~O6wOT1%v561Ce{*vq}JAj+M1@?Rur)|r7hLOBvkP~nZ8b5o6N+_OHFAd ze!wDrs9qFAr6NeRtqXam2;$O(A5>68MQ~A2H&QoJ#Dz0S`qM64y?f8OpZCr?zu&XR zp0EQ8*l#!PE|lDG(Y*>@x@#Toyq&n6M2x>#a}&Z+gczU0qN*r!5BjSqP)eaUe)wtp7kR2*&E8$~}1;*AB_)@bDlmm9Ur}lvfJiAxW)0?b3 z_*cODz^G?e)0m~spiPj4Vw|R?5up)DIjcvo|@C?pi;6vK*W^L#E z1{6+8fA=_YJy{Yy?I?jq{^d{>Sjm~1uuRNL;8383TNsL<7*fF!aKei~DXa;u1^2Ep zIvO13=+ixEmMNw!``?+gW4YL^XO~fo(GE@$jrN?}Z2q*`>1Yu>-)Uy-rtDX+&K$=U z!0j&2T=4g<^xTu~b0x-*5@#cHEOwKD(GxsBDFKuu7u&4mdg{`j?$Y#vc)F^-bP5U! zi9TJm$|l^7Tr=T(pX^N`F-Z{T{8w6d)mLQG8>e&)3ovlZSzs&AAhY(Z_@907`nY4> z^fb7hET(6b4@QUG7e}&7aH(Pf$BC;0M-e@uo-)CcR1a zm>9m6wac}UXYe@1)6K_UUqt zG&gv4DRg)4<=Rj})eOcmmRz(og2XP)+7a&-GoklTQi$4oa!}|-{-_{oUXcm6sHI!) z4-zFINN5&k_sIdIYQ&84rIY39O#R=yL!X1%{Rt(mRs=}`%aY2N9r`VErmkqiDh@}H zxyaj&wPGFCes>C9Fs_3tWu9QqA*AVl2kRjOtu>=*$cD@(Iir>22(5QAjY>j c-KaEZ=eeyJ5iuMc8loe&`We_TT+bN(0CZiVSO5S3 diff --git a/frmPyIDEMain.pas b/frmPyIDEMain.pas index 18ab2cc89..d0d2845f6 100644 --- a/frmPyIDEMain.pas +++ b/frmPyIDEMain.pas @@ -219,10 +219,11 @@ Unit Testing broken (regression) Gap in the default tool bar (Issue #3) - History: v 1.7.8 + History: v 1.8.6 New Features Remote interpreter and debugger New debugger command: Pause + Execute selection command added (Ctrl-F7) Interpreter command history improvements: - Delete duplicates - Filter history by typing the first few command characters @@ -237,6 +238,23 @@ Warning when file encoding results in information loss IDE option to position the editor tabs at the top IDE window navigation shortcuts + Pretty print intperpreter output option (on by default) + Pyscripter is now Vista ready + Docking window improvements + PYTHONDLLPATH command line option so that Pyscripter can work with unregistered Python + Watches Window: DblClick on empty space adds a watch, pressing Delete deletes (Issue 45) + Wrapping in Search & Replace (Issue 38) + New IDE Option "Save Environment Before Run" (Issue 50) + New IDE command Restore Editor pair to Maximize Editor (both work by double clicking the Tabbar) + New IDE Option "Smart Next Previous Tab" (z-Order) on by default (Issue 20) + Word Wrap option exposed in Editor Options + New File Reload command + Import/Export Settings (Shortcuts, Highlighter schemes) + New IDE option "Auto-reload changed files" on by default (Issue 25) + New menu command to show/hide the menu bar. The shortcut is Shift-F10 (Issue 63) + New command line option --DPIAWARE (-D) to avoid scaling in VISTA high DPI displays (Issue 77) + New command line option --NEWINSTANCE (-N) to start a new instance of PyScripter + You can disable a breakpoint by Ctrl+Clicking in the gutter Bug fixes Shell Integration - Error when opening multiple files Configure External Run - ParseTraceback not saved properly @@ -261,22 +279,35 @@ ToDo List did not support multiline comments (Issue 14) Fixed bug in IDE Shortcuts dialog Swapped the positions of the indent/dedent buttons (Issue 23) - - ** Pyscripter flickers a lot when resizing. I do not know what to do - about it. In fact this may be a Windows problem. Even in .NET try the - following using C#. Create a form, add a panel with a caption aligned - to the bottom. Run and resize fast. The label of the panel flickers. + Syntax highlighter changes to the interpreter are not persisted + Multiple target assignments are now parsed correctly + Gutter gradient setting not saved + Handling of string exceptions + Disabling a breakpoint had no effect + Issues 28, 39, 41, 46, 47, 48, 49, 52, 57, 65, 66, 71, 72, 74, 75, 76, 81 fixed + + Vista Compatibility issues (all resolved) + - Flip3D and Form preview (solved with LX) + - Dissapearring controls (solved with SpTXPLib) + - Dragging forms rectagle + - Flicker related to LockWindowsUpdate in loading layouts + - Common AVI not available + - Fonts + - VISTA compatible manifest -----------------------------------------------------------------------------} +// DONE: bug in middle click +// DONE: Next/Previous Tab corrected +// DONE: Parameter completion performance issue +// TODO: GeneratorExit bug + +// TODO: Merge find dialogs + // TODO: Post mortem debugging -// TODO: Pretty print intperpreter output option (on by default) // TODO: Customize Pyscripter with Setup python script run at startup -// TODO: Update Help File -// TODO: Project Manager +// TODO: Project Manager // Bugs and minor features -// TODO: File Reload command -// TODO: Z-Order in CTRL+TAB and CTRL+SHIFT+TAB // TODO: Internal Tool as in pywin // TODO: Interpreter raw_input // TODO: Improve parameter completion with an option to provide more help (docstring) @@ -300,14 +331,15 @@ interface JvDockControlForm, JvDockVIDStyle, JvDockVSNetStyle, JvComponent, SynEditTypes, SynEditMiscClasses, SynEditRegexSearch, cPyBaseDebugger, cPyDebugger, ToolWin, ExtCtrls, JvExComCtrls, JvAppStorage, - JvAppIniStorage, JvExControls, JvLED, JvFormPlacement, SynEdit, JvTabBar, - JvDragDrop, XPMan, TB2Dock, TB2Toolbar, TBX, TBXSwitcher, TB2Item, + JvAppIniStorage, JvExControls, JvLED, SynEdit, JvTabBar, + JvDragDrop, TB2Dock, TB2Toolbar, TBX, TBXSwitcher, TB2Item, TBXStatusBars, JvmbTBXTabBarPainter, JvDockVSNETStyleTBX, TB2MRU, TBXExtItems, JvPageList, cRefactoring, dlgCustomShortcuts, // Themes TBXNexosXTheme, TBXOfficeXPTheme, TBXAluminumTheme, TBXWhidbeyTheme, TBXOffice2003Theme, TBXOffice2007Theme, TBXLists, TB2ExtItems, JvDockTree, - JvComponentBase, JvAppInst, uHighlighterProcs, cFileTemplates; + JvComponentBase, JvAppInst, uHighlighterProcs, cFileTemplates, TntLXForms, + JvFormPlacement; const WM_FINDDEFINITION = WM_USER + 100; @@ -315,7 +347,7 @@ interface WM_UPDATEBREAKPOINTS = WM_USER + 120; type - TPyIDEMainForm = class(TForm) + TPyIDEMainForm = class(TTntFormLX) DockServer: TJvDockServer; actlStandard : TActionList; actRun: TAction; @@ -325,8 +357,6 @@ TPyIDEMainForm = class(TForm) actStepOut: TAction; actToggleBreakPoint: TAction; actClearAllBreakpoints: TAction; - actViewDebugToolbar: TAction; - actViewMainToolBar: TAction; actCallStackWin: TAction; actVariablesWin: TAction; actBreakPointsWin: TAction; @@ -335,8 +365,6 @@ TPyIDEMainForm = class(TForm) actMessagesWin: TAction; actDebug: TAction; actViewII: TAction; - actNextEditor: TAction; - actPreviousEditor: TAction; actViewCodeExplorer: TAction; AppStorage: TJvAppIniFileStorage; actFileNewModule: TAction; @@ -344,7 +372,6 @@ TPyIDEMainForm = class(TForm) actFileCloseAll: TAction; actFileExit: TAction; actViewStatusBar: TAction; - JvFormStorage: TJvFormStorage; actViewFileExplorer: TAction; BGPanel: TPanel; TabBar: TJvTabBar; @@ -444,8 +471,6 @@ TPyIDEMainForm = class(TForm) PreviousEditor1: TTBXItem; N10: TTBXSeparatorItem; oolbars1: TTBXSubmenuItem; - MainToolBar1: TTBXItem; - DebugToolBar1: TTBXItem; StatusBar1: TTBXItem; InteractiveInterpreter1: TTBXItem; FileExplorer1: TTBXItem; @@ -524,7 +549,7 @@ TPyIDEMainForm = class(TForm) EditorsPageList: TJvPageList; TBXSeparatorItem8: TTBXSeparatorItem; mnThemes: TTBXSubmenuItem; - ThemesVisibilityToggle: TTBXVisibilityToggleItem; + ViewToolbarVisibilityToggle: TTBXVisibilityToggleItem; EditorToolbar: TTBXToolbar; TBXItem27: TTBXItem; TBXItem28: TTBXItem; @@ -533,7 +558,7 @@ TPyIDEMainForm = class(TForm) TBXSeparatorItem11: TTBXSeparatorItem; TBXItem31: TTBXItem; TBXItem32: TTBXItem; - TBXVisibilityToggleItem1: TTBXVisibilityToggleItem; + EditorToolbarVisibilityToggle: TTBXVisibilityToggleItem; TBXItem25: TTBXItem; TBXItem26: TTBXItem; actFindDefinition: TAction; @@ -635,7 +660,42 @@ TPyIDEMainForm = class(TForm) actDebugPause: TAction; TBXItem61: TTBXItem; TBXItem70: TTBXItem; + mnPythonEngines: TTBXSubmenuItem; + actPythonReinitialize: TAction; + actPythonInternal: TAction; + actPythonRemote: TAction; + actPythonRemoteTk: TAction; + actPythonRemoteWx: TAction; + TBXItem71: TTBXItem; + TBXItem72: TTBXItem; + TBXItem73: TTBXItem; + TBXItem74: TTBXItem; + TBXItem75: TTBXItem; + TBXSeparatorItem26: TTBXSeparatorItem; + actExecSelection: TAction; + TBXSeparatorItem27: TTBXSeparatorItem; + TBXItem76: TTBXItem; + actRestoreEditor: TAction; + TBXItem77: TTBXItem; + TBXSeparatorItem28: TTBXSeparatorItem; + TBXItem78: TTBXItem; + TBXItem79: TTBXItem; + TBXItem80: TTBXItem; + TBXSeparatorItem29: TTBXSeparatorItem; TBXSubmenuItem7: TTBXSubmenuItem; + TBXItem81: TTBXItem; + TBXItem82: TTBXItem; + TBXSeparatorItem30: TTBXSeparatorItem; + TBXItem83: TTBXItem; + TBXItem84: TTBXItem; + DebugtoolbarVisibilityToggle: TTBXVisibilityToggleItem; + TBXVisibilityToggleItem1: TTBXVisibilityToggleItem; + actViewMainMenu: TAction; + TBXItem85: TTBXItem; + actlImmutable: TActionList; + actViewNextEditor: TAction; + actViewPreviousEditor: TAction; + JvFormStorage: TJvFormStorage; procedure mnFilesClick(Sender: TObject); procedure actEditorZoomInExecute(Sender: TObject); procedure actEditorZoomOutExecute(Sender: TObject); @@ -663,8 +723,6 @@ TPyIDEMainForm = class(TForm) procedure actStepOutExecute(Sender: TObject); procedure actRunToCursorExecute(Sender: TObject); procedure actDebugAbortExecute(Sender: TObject); - procedure actViewMainToolBarExecute(Sender: TObject); - procedure actViewDebugToolbarExecute(Sender: TObject); procedure actViewIIExecute(Sender: TObject); procedure actMessagesWinExecute(Sender: TObject); procedure actNextEditorExecute(Sender: TObject); @@ -680,8 +738,6 @@ TPyIDEMainForm = class(TForm) procedure actFileNewModuleExecute(Sender: TObject); procedure actFileOpenExecute(Sender: TObject); procedure actFileCloseAllExecute(Sender: TObject); - procedure JvFormStorageSavePlacement(Sender: TObject); - procedure JvFormStorageRestorePlacement(Sender: TObject); procedure actViewFileExplorerExecute(Sender: TObject); procedure TabBarTabSelected(Sender: TObject; Item: TJvTabBarItem); procedure TabBarTabClosed(Sender: TObject; Item: TJvTabBarItem); @@ -722,13 +778,24 @@ TPyIDEMainForm = class(TForm) procedure actNavRETesterExecute(Sender: TObject); procedure actNavEditorExecute(Sender: TObject); procedure actDebugPauseExecute(Sender: TObject); + procedure actPythonReinitializeExecute(Sender: TObject); + procedure actPythonEngineExecute(Sender: TObject); + procedure mnPythonEnginesPopup(Sender: TTBCustomItem; FromLink: Boolean); + procedure actExecSelectionExecute(Sender: TObject); + procedure TabBarMouseUp(Sender: TObject; Button: TMouseButton; + Shift: TShiftState; X, Y: Integer); + procedure TabBarDblClick(Sender: TObject); + procedure actRestoreEditorExecute(Sender: TObject); + procedure actViewMainMenuExecute(Sender: TObject); + procedure TntFormLXKeyUp(Sender: TObject; var Key: Word; + Shift: TShiftState); protected fCurrentLine : integer; fErrorLine : integer; fRefactoring : TBRMRefactor; fCurrentBrowseInfo : string; function DoCreateEditor: IEditor; - function CmdLineOpenFiles(AMultipleFiles: boolean): boolean; + function CmdLineOpenFiles(): boolean; procedure DebuggerBreakpointChange(Sender: TObject; Editor : IEditor; ALine: integer); procedure SetCurrentPos(Editor : IEditor; ALine: integer); procedure DebuggerCurrentPosChange(Sender: TObject); @@ -750,6 +817,12 @@ TPyIDEMainForm = class(TForm) MenuHelpRequested : Boolean; ActionListArray : TActionListArray; Layouts : TStringList; + zOrder : TList; + zOrderPos : integer; + zOrderProcessing : Boolean; + procedure SaveEnvironment; + procedure StoreApplicationData; + procedure RestoreApplicationData; function DoOpenFile(AFileName: string; HighlighterName : string = '') : IEditor; function NewFileFromTemplate(FileTemplate : TFileTemplate) : IEditor; function GetActiveEditor : IEditor; @@ -794,7 +867,8 @@ implementation JvJVCLUtils, DateUtils, cPythonSourceScanner, frmRegExpTester, StringResources, dlgCommandLine, frmUnitTests, cFilePersist, frmIDEDockWin, dlgPickList, VirtualTrees, VirtualExplorerTree, JvDockGlobals, Math, - cCodeHint, dlgNewFile, SynEditTextBuffer, JclSysInfo; + cCodeHint, dlgNewFile, SynEditTextBuffer, JclSysInfo, cPyRemoteDebugger, + uCmdLine; {$R *.DFM} @@ -848,6 +922,12 @@ procedure TPyIDEMainForm.FormCreate(Sender: TObject); TabHost : TJvDockTabHostForm; OptionsFileName: string; begin + // App Instances + if not CmdLineReader.readFlag('NEWINSTANCE') then begin + JvAppInstances.Active := True; + JvAppInstances.Check; + end; + // Trying to reduce flicker! ControlStyle := ControlStyle + [csOpaque]; BGPanel.ControlStyle := BGPanel.ControlStyle + [csOpaque]; @@ -860,16 +940,22 @@ procedure TPyIDEMainForm.FormCreate(Sender: TObject); // so that it gets repainted when there are no open files and the theme changes EditorsPageList.ControlStyle := EditorsPageList.ControlStyle - [csOpaque]; + SetDesktopIconFonts(Self.Font); // For Vista + SetDesktopIconFonts(JvmbTBXTabBarPainter.Font); + SetDesktopIconFonts(JvmbTBXTabBarPainter.SelectedFont); + SetDesktopIconFonts(JvmbTBXTabBarPainter.DisabledFont); + JvmbTBXTabBarPainter.DisabledFont.Color := clGrayText; + SetDesktopIconFonts(TJvDockVSNETTabServerOption(JvDockVSNetStyleTBX.TabServerOption).ActiveFont); + SetDesktopIconFonts(TJvDockVSNETTabServerOption(JvDockVSNetStyleTBX.TabServerOption).InactiveFont); + TJvDockVSNETTabServerOption(JvDockVSNetStyleTBX.TabServerOption).InactiveFont.Color := 5395794; + AddThemeNotification(Self); Layouts := TStringList.Create; Layouts.Sorted := True; Layouts.Duplicates := dupError; - // ActionLists - SetLength(ActionListArray, 2); - ActionListArray[0] := actlStandard; - ActionListArray[1] := CommandsDataModule.actlMain; + zOrder := TList.Create; // Application Storage OptionsFileName := ChangeFileExt(ExtractFileName(Application.ExeName), '.ini'); @@ -910,14 +996,27 @@ procedure TPyIDEMainForm.FormCreate(Sender: TObject); OnYield := DebuggerYield; end; + // ActionLists + SetLength(ActionListArray, 3); + ActionListArray[0] := actlStandard; + ActionListArray[1] := CommandsDataModule.actlMain; + ActionListArray[2] := PythonIIForm.InterpreterActionList; + + // Read Settings from PyScripter.ini + if FileExists(AppStorage.IniFile.FileName) then begin + RestoreApplicationData; + JvFormStorage.RestoreFormPlacement; + end; + // Note that the following will trigger the AppStorage to RestoreFormPlacement etc. // Otherwise this would have happened after exiting FormCreate when the Form is shown. AppStorage.ReadStringList('Layouts', Layouts, True); - if AppStorage.PathExists('Layouts\Current\Forms') then - LoadDockTreeFromAppStorage(AppStorage, 'Layouts\Current') - else begin - TBXSwitcher.Theme := 'Office2003'; + if AppStorage.PathExists('Layouts\Current\Forms') then begin + //LoadDockTreeFromAppStorage(AppStorage, 'Layouts\Current') + LoadLayout('Current'); + end else begin + TBXSwitcher.Theme := 'Office 2003'; TabHost := ManualTabDock(DockServer.LeftDockPanel, FileExplorerWindow, CodeExplorerWindow); DockServer.LeftDockPanel.Width := 200; ManualTabDockAddPage(TabHost, UnitTestWindow); @@ -951,7 +1050,7 @@ procedure TPyIDEMainForm.FormCreate(Sender: TObject); SendMessage(EditorsPageList.Handle, WM_SETREDRAW, 0, 0); // To avoid flicker try // Open Files on the command line - CmdLineOpenFiles(True); + CmdLineOpenFiles(); // if there was no file on the command line try restoring open files if CommandsDataModule.PyIDEOptions.RestoreOpenFiles and @@ -984,25 +1083,31 @@ procedure TPyIDEMainForm.FormCreate(Sender: TObject); procedure TPyIDEMainForm.FormCloseQuery(Sender: TObject; var CanClose: Boolean); -//Var -// i : integer; begin if JvGlobalDockIsLoading then begin CanClose := False; CloseTimer.Enabled := True; Exit; end else if PyControl.DebuggerState <> dsInactive then begin - CanClose := False; if Windows.MessageBox(Handle, 'A debugging session is in process. Do you want to abort the session and Exit?', PChar(Application.Title), MB_ICONWARNING or MB_YESNO) = idYes then begin -// if (MessageDlg('A debugging session is in process. Do you want to abort the session and Exit?', -// mtWarning, [mbYes, mbNo], 0) = mrYes) then begin - PyControl.ActiveDebugger.Abort; - CloseTimer.Enabled := True; + if (PyControl.DebuggerState = dsPaused) or + (PyControl.ActiveDebugger is TPyInternalDebugger) then + begin + CanClose := False; + PyControl.ActiveDebugger.Abort; + CloseTimer.Enabled := True; + Exit; + end else begin + PyControl.ActiveInterpreter.ReInitialize; + CanClose := True + end; + end else begin // idNo + CanClose := False; + Exit; end; - Exit; end; if OutputWindow.JvCreateProcess.State <> psReady then @@ -1035,7 +1140,11 @@ procedure TPyIDEMainForm.FormCloseQuery(Sender: TObject; // Shut down help Application.OnHelp := nil; - Application.HelpCommand(HELP_QUIT, 0); + // QC25183 + try + Application.HelpCommand(HELP_QUIT, 0); + except + end; VariablesWindow.ClearAll; UnitTestWindow.ClearAll; @@ -1044,14 +1153,10 @@ procedure TPyIDEMainForm.FormCloseQuery(Sender: TObject; // Give the time to the treads to terminate Sleep(200); - // Save the list of open files - AppStorage.DeleteSubTree('Open Files'); - TPersistFileInfo.WriteToAppStorage(AppStorage, 'Open Files'); + // We need to do this here so that MRU and docking information are persisted + SaveEnvironment; - // We need to do these here so that MRU and docking information are persisted - SaveLayout('Current'); SendMessage(EditorsPageList.Handle, WM_SETREDRAW, 0, 0); // To avoid flicker - if GI_EditorFactory <> nil then GI_EditorFactory.CloseAll; SendMessage(EditorsPageList.Handle, WM_SETREDRAW, 1, 0); @@ -1166,11 +1271,31 @@ procedure TPyIDEMainForm.actNextEditorExecute(Sender: TObject); Var TabBarItem : TJvTabBarItem; begin - if TabBar.Tabs.Count = 0 then Exit; - if Assigned(TabBar.SelectedTab) then - TabBarItem := TabBar.SelectedTab.GetNextVisible - else - TabBarItem := TabBar.Tabs.Items[0]; + if TabBar.Tabs.Count <= 1 then Exit; + TabBarItem := nil; + if CommandsDataModule.PyIDEOptions.SmartNextPrevPage then begin + Repeat + Inc(zOrderPos); + if zOrderPos >= zOrder.Count then + ZOrderPos := 0; + while zOrderPos < zOrder.Count do begin + TabBarItem := zOrder[zOrderPos]; + if TabBar.Tabs.IndexOf(TabBarItem) < 0 then begin + zOrder.Delete(zOrderPos); + TabBarItem := nil; + end else + break; + end; + Until Assigned(TabBarItem) or (ZOrder.Count = 0); + KeyPreview := True; + zOrderProcessing := True; + end else begin + if Assigned(TabBar.SelectedTab) then + TabBarItem := TabBar.SelectedTab.GetNextVisible + else + TabBarItem := TabBar.Tabs.Items[0]; + end; + if not Assigned(TabBarItem) then TabBarItem := TabBar.Tabs.Items[0]; if Assigned(TabBarItem) then @@ -1181,17 +1306,62 @@ procedure TPyIDEMainForm.actPreviousEditorExecute(Sender: TObject); Var TabBarItem : TJvTabBarItem; begin - if TabBar.Tabs.Count = 0 then Exit; - if Assigned(TabBar.SelectedTab) then - TabBarItem := TabBar.SelectedTab.GetPreviousVisible - else - TabBarItem := TabBar.Tabs.Items[TabBar.Tabs.Count-1]; + if TabBar.Tabs.Count <= 1 then Exit; + TabBarItem := nil; + if CommandsDataModule.PyIDEOptions.SmartNextPrevPage then begin + Repeat + Dec(zOrderPos); + if zOrderPos < 0 then + zOrderPos := zOrder.Count - 1; + while zOrderPos < zOrder.Count do begin + TabBarItem := zOrder[zOrderPos]; + if TabBar.Tabs.IndexOf(TabBarItem) < 0 then begin + zOrder.Delete(zOrderPos); + TabBarItem := nil; + end else + break; + end; + Until Assigned(TabBarItem) or (ZOrder.Count = 0); + KeyPreview := True; + zOrderProcessing := True; + end else begin + if Assigned(TabBar.SelectedTab) then + TabBarItem := TabBar.SelectedTab.GetPreviousVisible + else + TabBarItem := TabBar.Tabs.Items[TabBar.Tabs.Count-1]; + end; if not Assigned(TabBarItem) then TabBarItem := TabBar.Tabs.Items[TabBar.Tabs.Count-1]; if Assigned(TabBarItem) then TabBarItem.Selected := True; end; +procedure TPyIDEMainForm.actPythonEngineExecute(Sender: TObject); +Var + PythonEngineType : TPythonEngineType; + Msg : string; +begin + PythonEngineType := TPythonEngineType((Sender as TAction).Tag); + PythonIIForm.SetPythonEngineType(PythonEngineType); + case CommandsDataModule.PyIDEOptions.PythonEngineType of + peInternal : Msg := Format(SEngineActive, ['Internal','']); + peRemote : Msg := Format(SEngineActive, ['Remote','']); + peRemoteTk : Msg := Format(SEngineActive, ['Remote','(Tkinter) ']); + peRemoteWx : Msg := Format(SEngineActive, ['Remote','(wxPython) ']); + end; + PythonIIForm.AppendText(WideLineBreak + Msg); + PythonIIForm.AppendPrompt; +end; + +procedure TPyIDEMainForm.actPythonReinitializeExecute(Sender: TObject); +begin + if PyControl.DebuggerState <> dsInactive then begin + if MessageDlg('The Python interpreter is busy. Are you sure you want to terminate it?', + mtWarning, [mbYes, mbNo], 0) = idNo then Exit; + end; + PyControl.ActiveInterpreter.ReInitialize; +end; + procedure TPyIDEMainForm.actSyntaxCheckExecute(Sender: TObject); var ActiveEditor : IEditor; @@ -1254,6 +1424,8 @@ procedure TPyIDEMainForm.actRunExecute(Sender: TObject); if CommandsDataModule.PyIDEOptions.SaveFilesBeforeRun then SaveFileModules; + if CommandsDataModule.PyIDEOptions.SaveEnvironmentBeforeRun then + SaveEnvironment; PyControl.ActiveInterpreter.RunNoDebug(ActiveEditor); @@ -1271,6 +1443,8 @@ procedure TPyIDEMainForm.actDebugExecute(Sender: TObject); if CommandsDataModule.PyIDEOptions.SaveFilesBeforeRun then SaveFileModules; + if CommandsDataModule.PyIDEOptions.SaveEnvironmentBeforeRun then + SaveEnvironment; PyControl.ActiveDebugger.Run(ActiveEditor); end; @@ -1351,6 +1525,8 @@ procedure TPyIDEMainForm.UpdateDebugCommands(DebuggerState : TDebuggerState); actToggleBreakPoint.Enabled := PyFileActive; actClearAllBreakPoints.Enabled := PyFileActive; actAddWatchAtCursor.Enabled := PyFileActive; + actExecSelection.Enabled := not (DebuggerState in [dsRunning, dsRunningNoDebug]) + and PyFileActive and Editor.SynEdit.SelAvail; end; procedure TPyIDEMainForm.SetCurrentPos(Editor : IEditor; ALine: integer); @@ -1487,6 +1663,16 @@ procedure TPyIDEMainForm.ApplicationOnIdle(Sender: TObject; var Done: Boolean); EditorViewsMenu.Items[i].Enabled := Assigned(GI_ActiveEditor); if Assigned(GI_ActiveEditor) then TEditorForm(GI_ActiveEditor.Form).DoOnIdle; + + // If a Tk or Wx remote engine is active pump up event handling + // This is for processing input output coming from event handlers + if (PyControl.ActiveInterpreter is TPyRemoteInterpreter) and + (PyControl.DebuggerState = dsInactive) + then + with(TPyRemoteInterpreter(PyControl.ActiveInterpreter)) do begin + if IsConnected and (ServerType in [stTkinter, stWxPython]) then + ServeConnection; + end; Done := True; end; @@ -1536,16 +1722,6 @@ function TPyIDEMainForm.ShowFilePosition(FileName: string; Line, end; end; -procedure TPyIDEMainForm.actViewMainToolBarExecute(Sender: TObject); -begin - MainToolBar.Visible := not MainToolBar.Visible; -end; - -procedure TPyIDEMainForm.actViewDebugToolbarExecute(Sender: TObject); -begin - DebugToolBar.Visible := not DebugToolBar.Visible; -end; - procedure TPyIDEMainForm.actViewStatusBarExecute(Sender: TObject); begin StatusBar.Visible := not StatusBar.Visible; @@ -1562,6 +1738,11 @@ procedure TPyIDEMainForm.actViewIIExecute(Sender: TObject); HideDockForm(PythonIIForm); end; +procedure TPyIDEMainForm.actViewMainMenuExecute(Sender: TObject); +begin + MainMenu.Visible := not MainMenu.Visible; +end; + procedure TPyIDEMainForm.actViewCodeExplorerExecute(Sender: TObject); begin if not CodeExplorerWindow.Visible then @@ -1707,20 +1888,14 @@ procedure TPyIDEMainForm.UpdateStatusBarPanels; ExternalToolsLED.Visible := OutputWindow.JvCreateProcess.State <> psReady; end; -function TPyIDEMainForm.CmdLineOpenFiles(AMultipleFiles: boolean): boolean; +function TPyIDEMainForm.CmdLineOpenFiles(): boolean; var - i, Cnt: integer; -begin - Cnt := ParamCount; - if Cnt > 0 then begin - if not AMultipleFiles and (Cnt > 1) then - Cnt := 1; - for i := 1 to Cnt do - if (ParamStr(i)[1] <> '-') and FileExists(ParamStr(i)) then - DoOpenFile(ParamStr(i)); - Result := TRUE; - end else - Result := FALSE; + i : integer; +begin + Result := False; + for i := Low(CmdLineReader.readNamelessString) to High(CmdLineReader.readNamelessString) do + if FileExists(CmdLineReader.readNamelessString[i]) then + Result := Result or Assigned(DoOpenFile(CmdLineReader.readNamelessString[i])); end; procedure TPyIDEMainForm.FormDestroy(Sender: TObject); @@ -1728,6 +1903,7 @@ procedure TPyIDEMainForm.FormDestroy(Sender: TObject); FreeAndNil(FindInFilesExpert); FreeAndNil(fRefactoring); FreeAndNil(Layouts); + FreeAndNil(zOrder); end; procedure TPyIDEMainForm.actFileExitExecute(Sender: TObject); @@ -1827,12 +2003,14 @@ procedure TPyIDEMainForm.PyIDEOptionsChanged; Editor.SynEdit.InvalidateGutter; end; -procedure TPyIDEMainForm.JvFormStorageSavePlacement(Sender: TObject); +procedure TPyIDEMainForm.StoreApplicationData; Var TempStringList : TStringList; ActionProxyCollection : TActionProxyCollection; i : integer; + TempCursor : IInterface; begin + TempCursor := WaitCursor; TempStringList := TStringList.Create; AppStorage.BeginUpdate; try @@ -1841,6 +2019,11 @@ procedure TPyIDEMainForm.JvFormStorageSavePlacement(Sender: TObject); with CommandsDataModule do begin AppStorage.DeleteSubTree('Editor Options'); AppStorage.WritePersistent('Editor Options', EditorOptions); + AppStorage.DeleteSubTree('Highlighters'); + for i := 0 to Highlighters.Count - 1 do + AppStorage.WritePersistent('Highlighters\'+Highlighters[i], + TPersistent(Highlighters.Objects[i])); + TempStringList.Add('KeyStrokes'); AppStorage.WritePersistent('Interpreter Editor Options', InterpreterEditorOptions, True, TempStringList); @@ -1862,10 +2045,6 @@ procedure TPyIDEMainForm.JvFormStorageSavePlacement(Sender: TObject); TempStringList.Assign(CodeTemplatesCompletion.AutoCompleteList); AppStorage.WriteStringList('Code Templates', TempStringList); AppStorage.StorageOptions.PreserveLeadingTrailingBlanks := False; - - AppStorage.DeleteSubTree('Highlighters'); - for i := 0 to Highlighters.Count - 1 do - AppStorage.WritePersistent('Highlighters\'+Highlighters[i], TPersistent(Highlighters.Objects[i])); end; AppStorage.WritePersistent('ToDo Options', ToDoExpert); AppStorage.WritePersistent('Find in Files Options', FindInFilesExpert); @@ -1892,8 +2071,6 @@ procedure TPyIDEMainForm.JvFormStorageSavePlacement(Sender: TObject); finally ActionProxyCollection.Free; end; - // Store Toolbar positions - TBIniSavePositions(Self, AppStorage.FileName, 'Toolbars'); finally AppStorage.EndUpdate; TempStringList.Free; @@ -1901,9 +2078,17 @@ procedure TPyIDEMainForm.JvFormStorageSavePlacement(Sender: TObject); // Save MRU Lists TBXMRUList.SaveToIni(AppStorage.IniFile, 'MRU File List'); CommandsDataModule.CommandLineMRU.SaveToIni(AppStorage.IniFile, 'CommandLine MRU'); + + // Form Placement + JvFormStorage.SaveFormPlacement; + + // Store Toolbar positions + AppStorage.Flush; + TBIniSavePositions(Self, AppStorage.IniFile.FileName, 'Toolbars'); + AppStorage.WriteBoolean('Status Bar', StatusBar.Visible); end; -procedure TPyIDEMainForm.JvFormStorageRestorePlacement(Sender: TObject); +procedure TPyIDEMainForm.RestoreApplicationData; Const DefaultHeader='$TITLE$\.1\.0\.-13\.Arial\.0\.96\.10\.0\.1\.2'; DefaultFooter='$PAGENUM$\\.$PAGECOUNT$\.1\.0\.-13\.Arial\.0\.96\.10\.0\.1\.2'; @@ -1918,10 +2103,15 @@ procedure TPyIDEMainForm.JvFormStorageRestorePlacement(Sender: TObject); end; if AppStorage.IniFile.SectionExists('Editor Options') then with CommandsDataModule do begin + EditorOptions.Gutter.Gradient := False; //default value AppStorage.ReadPersistent('Editor Options', EditorOptions); + for i := 0 to Highlighters.Count - 1 do + AppStorage.ReadPersistent('Highlighters\'+Highlighters[i], + TPersistent(Highlighters.Objects[i])); CommandsDataModule.ApplyEditorOptions; if AppStorage.IniFile.SectionExists('Interpreter Editor Options') then begin + InterpreterEditorOptions.Gutter.Gradient := False; //default value AppStorage.ReadPersistent('Interpreter Editor Options', InterpreterEditorOptions); PythonIIForm.SynEdit.Assign(InterpreterEditorOptions); PythonIIForm.RegisterHistoryCommands; @@ -1948,8 +2138,6 @@ procedure TPyIDEMainForm.JvFormStorageRestorePlacement(Sender: TObject); end; AppStorage.StorageOptions.PreserveLeadingTrailingBlanks := False; - for i := 0 to Highlighters.Count - 1 do - AppStorage.ReadPersistent('Highlighters\'+Highlighters[i], TPersistent(Highlighters.Objects[i])); end; if AppStorage.IniFile.SectionExists('ToDo Options') then AppStorage.ReadPersistent('ToDo Options', ToDoExpert); @@ -1983,31 +2171,79 @@ procedure TPyIDEMainForm.JvFormStorageRestorePlacement(Sender: TObject); end; // Restore Toolbar positions TBIniLoadPositions(Self, AppStorage.FileName, 'Toolbars'); + StatusBar.Visible := AppStorage.ReadBoolean('Status Bar'); end; procedure TPyIDEMainForm.TabBarTabSelected(Sender: TObject; Item: TJvTabBarItem); Var WinControl : TWinControl; + Index : integer; begin if Assigned(Item) and not (csDestroying in ComponentState) then begin EditorsPageList.ActivePage := Item.Data as TJvStandardPage; - if Assigned(EditorsPageList.ActivePage) then begin + if Assigned(EditorsPageList.ActivePage) + and (EditorsPageList.ActivePage.ControlCount > 0) then + begin WinControl := (EditorsPageList.ActivePage.Controls[0] as TEditorForm).EditorViews.ActivePage.Controls[0] as TWinControl; - if WinControl.CanFocus then + if Visible and WinControl.CanFocus then ActiveControl := WinControl; end; + // zOrder + if not zOrderProcessing then begin + Index := zOrder.IndexOf(Item); + if Index < 0 then + zOrder.Insert(0, Item) + else + zOrder.Move(Index, 0); + zOrderPos := 0; + end; + end; +end; + +procedure TPyIDEMainForm.TabBarDblClick(Sender: TObject); +begin + if AppStorage.PathExists('Layouts\BeforeZoom\Forms') then + actRestoreEditorExecute(Sender) + else + actMaximizeEditorExecute(Sender); +end; + +function EditorFromTab(Tab : TJvTabBarItem) : IEditor; +Var + Page : TJvStandardPage; +begin + Result := nil; + if Assigned(Tab) then begin + Page := Tab.Data as TJvStandardPage; + if Assigned(Page) and (Page.ControlCount > 0) then + Result := (Page.Controls[0] as TEditorForm).GetEditor; + end; +end; + +procedure TPyIDEMainForm.TabBarMouseUp(Sender: TObject; Button: TMouseButton; + Shift: TShiftState; X, Y: Integer); +Var + Editor : IEditor; +begin + if Button = mbMiddle then begin + Editor := EditorFromTab(TabBar.TabAt(X, Y)); + if Assigned(Editor) then begin + (Editor as IFileCommands).ExecClose; + TabBarTabSelected(Sender, TabBar.SelectedTab); + end; end; end; procedure TPyIDEMainForm.TabBarTabClosed(Sender: TObject; Item: TJvTabBarItem); +Var + Editor : IEditor; begin - if Assigned(GetActiveEditor()) then - with GetActiveEditor do begin - if AskSaveChanges then Close; - end; + Editor := EditorFromTab(Item); + if Assigned(Editor) then + (Editor as IFileCommands).ExecClose; end; procedure TPyIDEMainForm.UpdateStandardActions; @@ -2026,9 +2262,8 @@ procedure TPyIDEMainForm.UpdateStandardActions; actVIewII.Checked := PythonIIForm.Visible; actWatchesWin.Checked := WatchesWindow.Visible; - actViewDebugToolBar.Checked := DebugToolBar.Visible; - actViewMainToolBar.Checked := MainToolBar.Visible; actViewStatusbar.Checked := StatusBar.Visible; + actViewMainMenu .Checked := MainMenu.Visible; actFileNewModule.Enabled := GI_EditorFactory <> nil; actFileOpen.Enabled := GI_EditorFactory <> nil; @@ -2183,6 +2418,19 @@ procedure TPyIDEMainForm.mnNoSyntaxClick(Sender: TObject); Editor.SynEdit.Highlighter := nil; end; +procedure TPyIDEMainForm.mnPythonEnginesPopup(Sender: TTBCustomItem; + FromLink: Boolean); +begin + case CommandsDataModule.PyIDEOptions.PythonEngineType of + peInternal : actPythonInternal.Checked := True; + peRemote : actPythonRemote.Checked := True; + peRemoteTk : actPythonRemoteTk.Checked := True; + peRemoteWx : actPythonRemoteWx.Checked := True; + end; + actPythonReinitialize.Enabled := icReInitialize in + PyControl.ActiveInterpreter.InterpreterCapabilities; +end; + procedure TPyIDEMainForm.SetupSyntaxMenu; Var i : integer; @@ -2209,15 +2457,13 @@ procedure TPyIDEMainForm.LoadLayout(Layout: string); if AppStorage.PathExists(Path + '\Forms') then begin TempCursor := WaitCursor; SaveActiveControl := ActiveControl; - SendMessage(EditorsPageList.Handle, WM_SETREDRAW, 0, 0); - // To avoid delays in creating and destroying FileExplorer's Change Notify thread - FileExplorerWindow.FileExplorerTree.TreeOptions.VETMiscOptions := - FileExplorerWindow.FileExplorerTree.TreeOptions.VETMiscOptions - [toChangeNotifierThread]; + SendMessage(EditorsPageList.Handle, WM_SETREDRAW, 0, 0); try - for i := 0 to EditorsPageList.PageCount - 1 do begin + for i := 0 to EditorsPageList.PageCount - 1 do TEditorForm(EditorsPageList.Pages[i].Components[0]).Visible := False; - end; + + // Now Load the DockTree LoadDockTreeFromAppStorage(AppStorage, Path); finally SendMessage(EditorsPageList.Handle, WM_SETREDRAW, 1, 0); @@ -2227,18 +2473,16 @@ procedure TPyIDEMainForm.LoadLayout(Layout: string); TEditorForm(EditorsPageList.Pages[i].Components[0]).Visible := True; end; EditorsPageList.Invalidate; - SendMessage(EditorsPageList.Handle, WM_SETREDRAW, 1, 0); - for i := 0 to Screen.FormCount - 1 do + for i := 0 to Screen.FormCount - 1 do begin if Screen.Forms[i] is TIDEDockWindow then - TIDEDockWindow(Screen.Forms[i]).FGPanelExit(Self); - FileExplorerWindow.FileExplorerTree.TreeOptions.VETMiscOptions := - FileExplorerWindow.FileExplorerTree.TreeOptions.VETMiscOptions + [toChangeNotifierThread]; + TIDEDockWindow(Screen.Forms[i]).FormDeactivate(Self); + end; end; if Assigned(SaveActiveControl) and SaveActiveControl.Visible - and SaveActiveControl.CanFocus + and GetParentForm(SaveActiveControl).Visible and SaveActiveControl.CanFocus then try - ActiveControl := SaveActiveControl; + SaveActiveControl.SetFocus; except end; end; @@ -2346,6 +2590,14 @@ procedure TPyIDEMainForm.actExternalRunExecute(Sender: TObject); OutputWindow.ExecuteTool(ExternalPython); end; +procedure TPyIDEMainForm.actExecSelectionExecute(Sender: TObject); +begin + if Assigned(GI_ActiveEditor) and GI_ActiveEditor.HasPythonFile and + GI_ActiveEditor.SynEdit.SelAvail + then + GI_ActiveEditor.ExecuteSelection; +end; + procedure TPyIDEMainForm.actExternalRunConfigureExecute(Sender: TObject); begin EditTool(ExternalPython); @@ -2369,6 +2621,18 @@ procedure TPyIDEMainForm.ThemeEditorGutter(Gutter : TSynGutter); end; end; +procedure TPyIDEMainForm.TntFormLXKeyUp(Sender: TObject; var Key: Word; + Shift: TShiftState); +begin + inherited; + if (Key = VK_Control) and zOrderProcessing and (zOrderPos > 0) then begin + zOrder.Move(zOrderPos, 0); + zOrderPos := 0; + zOrderProcessing := False; + KeyPreview := False; + end; +end; + procedure TPyIDEMainForm.AdjustBrowserLists(FileName: string; Line: Integer; Col: Integer; FilePosInfo: string); begin if FilePosInfo <> '' then @@ -2784,24 +3048,39 @@ procedure TPyIDEMainForm.FillTBXThemeMenu; end; end; +procedure TPyIDEMainForm.SaveEnvironment; +begin + // Save the list of open files + AppStorage.DeleteSubTree('Open Files'); + TPersistFileInfo.WriteToAppStorage(AppStorage, 'Open Files'); + // Save Layout + SaveLayout('Current'); + // Store other application data and flush AppStorage + StoreApplicationData; +end; + procedure TPyIDEMainForm.actMaximizeEditorExecute(Sender: TObject); var i : TJvDockPosition; - j : integer; Panel : TJvDockPanel; begin + SaveLayout('BeforeZoom'); for i := Low(TJvDockPosition) to High(TJvDockPosition) do begin Panel := DockServer.DockPanel[i]; if not (Panel is TJvDockVSNETPanel) then continue; - for j := 0 to Panel.DockClientCount - 1 do - // for some reason DoAutoHideControl changes DockClientCount - if j < Panel.DockClientCount then - TJvDockVSNETPanel(Panel).DoAutoHideControl(Panel.DockClients[j]as TWinControl) - else - break; + while Panel.DockClientCount >0 do + TJvDockVSNETPanel(Panel).DoAutoHideControl( + Panel.DockClients[Panel.DockClientCount-1]as TWinControl); end; end; +procedure TPyIDEMainForm.actRestoreEditorExecute(Sender: TObject); +begin + if AppStorage.PathExists('Layouts\BeforeZoom\Forms') then begin + LoadLayout('BeforeZoom'); + Appstorage.DeleteSubTree('Layouts\BeforeZoom'); + end; +end; procedure TPyIDEMainForm.actEditorZoomOutExecute(Sender: TObject); begin diff --git a/frmPythonII.dfm b/frmPythonII.dfm index 649c59186..7d2971ee9 100644 --- a/frmPythonII.dfm +++ b/frmPythonII.dfm @@ -17,19 +17,22 @@ inherited PythonIIForm: TPythonIIForm 0000000000008000000000000000000000000000000000000000000000000000 0000000000000000000080010000C00F0000C00F0000C00F0000E01F0000} Position = poDefault - OnActivate = FormActivate OnHelp = FormHelp - ExplicitWidth = 711 - ExplicitHeight = 479 + ExplicitWidth = 719 + ExplicitHeight = 487 DesignSize = ( 703 453) PixelsPerInch = 96 TextHeight = 13 inherited FGPanel: TPanel + Left = -4 + Top = -5 Width = 700 Height = 444 Color = clInactiveBorder + ExplicitLeft = -4 + ExplicitTop = -5 ExplicitWidth = 700 ExplicitHeight = 444 object SynEdit: TSynEdit @@ -66,8 +69,6 @@ inherited PythonIIForm: TPythonIIForm OnProcessUserCommand = SynEditProcessUserCommand OnReplaceText = SynEditReplaceText OnPaintTransient = SynEditPaintTransient - ExplicitLeft = 1 - ExplicitTop = -1 end end object PythonEngine: TPythonEngine @@ -81,6 +82,7 @@ inherited PythonIIForm: TPythonIIForm InitScript.Strings = ( 'import sys' 'import code' + 'import pyscripter' '' 'try:' ' sys.ps1' @@ -227,6 +229,7 @@ inherited PythonIIForm: TPythonIIForm '' ' maindictcopy = self.locals.copy()' ' sysmodulescopy = sys.modules.copy()' + ' self.saveStdio = (sys.stdin, sys.stdout, sys.stderr)' '' ' try:' ' try:' @@ -235,10 +238,14 @@ inherited PythonIIForm: TPythonIIForm ' pass' ' finally:' + ' sys.stdin, sys.stdout, sys.stderr = self.saveStd' + + 'io' + ' if self.debugIDE.cleanupMainDict() and (self.loc' + 'als is globals):' ' self.locals.clear()' ' self.locals.update(maindictcopy)' + ' __import__("gc").collect()' ' if self.debugIDE.cleanupSysModules():' ' sys.modules.clear()' ' sys.modules.update(sysmodulescopy)' @@ -307,6 +314,7 @@ inherited PythonIIForm: TPythonIIForm '' ' maindictcopy = self.locals.copy()' ' sysmodulescopy = sys.modules.copy()' + ' self.saveStdio = (sys.stdin, sys.stdout, sys.stderr)' '' ' if not isinstance(cmd, types.CodeType):' ' cmd = cmd+'#39'\n'#39 @@ -316,11 +324,13 @@ inherited PythonIIForm: TPythonIIForm ' except SystemExit:' ' pass' ' finally:' + ' sys.stdin, sys.stdout, sys.stderr = self.saveStdio' ' if self.debugIDE.cleanupMainDict() and (self.locals ' + 'is globals):' ' self.locals.clear()' ' self.locals.update(maindictcopy)' + ' __import__("gc").collect()' ' if self.debugIDE.cleanupSysModules():' ' sys.modules.clear()' ' sys.modules.update(sysmodulescopy)' @@ -470,6 +480,7 @@ inherited PythonIIForm: TPythonIIForm ' return False' '' ' def runcode(self, code):' + ' import sys' ' def softspace(file, newvalue):' ' oldvalue = 0' ' try:' @@ -485,6 +496,7 @@ inherited PythonIIForm: TPythonIIForm ' pass' ' return oldvalue' '' + ' self.saveStdio = (sys.stdin, sys.stdout, sys.stderr)' ' try:' ' if self.debugger.InIDEDebug:' @@ -497,9 +509,9 @@ inherited PythonIIForm: TPythonIIForm ' except:' ' self.showtraceback()' ' else:' - ' import sys' ' if softspace(sys.stdout, 0):' ' print' + ' sys.stdin, sys.stdout, sys.stderr = self.saveStdio' '' ' def evalcode(self, code):' ' # may raise exceptions' @@ -595,10 +607,22 @@ inherited PythonIIForm: TPythonIIForm ' "Provide input() for gui apps"' ' return eval(raw_input(prompt))' '' + ' def setupdisplayhook(self):' + ' if pyscripter.IDEOptions.PrettyPrintOutput:' + ' import sys, pprint, __builtin__' + + ' def pphook(value, show=pprint.pprint, bltin=__builti' + + 'n__):' + ' if value is not None:' + ' bltin._ = value' + ' show(value)' + ' sys.displayhook = pphook' + '' '_II = PythonInteractiveInterpreter(globals())' '' 'sys.modules['#39'__builtin__'#39'].raw_input=_II.Win32RawInput' 'sys.modules['#39'__builtin__'#39'].input=_II.Win32Input' + '' 'del DebugOutput' 'del code' 'del PythonInteractiveInterpreter' @@ -611,6 +635,8 @@ inherited PythonIIForm: TPythonIIForm Top = 54 end object PythonIO: TPythonInputOutput + UnicodeIO = False + RawOutput = False Left = 586 Top = 53 end @@ -749,28 +775,11 @@ inherited PythonIIForm: TPythonIIForm object InterpreterPopUp: TTBXPopupMenu Images = CommandsDataModule.Images OnPopup = InterpreterPopUpPopup - Left = 46 - Top = 6 + Left = 45 + Top = 12 object TBXPythonEngines: TTBXSubmenuItem Caption = 'Python Engine' - OnPopup = TBXPythonEnginesPopup - object TBXItem5: TTBXItem - Action = actPythonEngineInternal - end - object TBXItem10: TTBXItem - Action = actPythonEngineRemote - end - object TBXItem9: TTBXItem - Action = actPythonEngineRemoteTk - end - object TBXItem8: TTBXItem - Action = actPythonEngineRemoteWx - end - object TBXSepReinitialize: TTBXSeparatorItem - end - object TBXItem6: TTBXItem - Action = actReinitialize - end + LinkSubitems = PyIDEMainForm.mnPythonEngines end object TBXSeparatorItem3: TTBXSeparatorItem end @@ -799,6 +808,7 @@ inherited PythonIIForm: TPythonIIForm Left = 8 Top = 45 object actCleanUpNameSpace: TAction + Category = 'Interpreter' AutoCheck = True Caption = 'Clean up &Namespace' HelpContext = 410 @@ -807,6 +817,7 @@ inherited PythonIIForm: TPythonIIForm OnExecute = actCleanUpNameSpaceExecute end object actCleanUpSysModules: TAction + Category = 'Interpreter' AutoCheck = True Caption = 'Clean up &sys.modules' HelpContext = 410 @@ -815,6 +826,7 @@ inherited PythonIIForm: TPythonIIForm OnExecute = actCleanUpSysModulesExecute end object actCopyHistory: TAction + Category = 'Interpreter' Caption = 'Copy &History' HelpContext = 410 HelpType = htContext @@ -822,13 +834,8 @@ inherited PythonIIForm: TPythonIIForm ImageIndex = 12 OnExecute = actCopyHistoryExecute end - object actReinitialize: TAction - Caption = 'Reinitiali&ze Python engine' - HelpContext = 340 - HelpType = htContext - OnExecute = actReinitializeExecute - end object actClearContents: TAction + Category = 'Interpreter' Caption = 'Clear &All' HelpContext = 410 HelpType = htContext @@ -836,45 +843,18 @@ inherited PythonIIForm: TPythonIIForm ImageIndex = 14 OnExecute = actClearContentsExecute end - object actPythonEngineInternal: TAction - AutoCheck = True - Caption = '&Internal' - Checked = True - GroupIndex = 1 - HelpContext = 340 - HelpType = htContext - Hint = 'Use internal Python Engine' - OnExecute = actPythonEngineExecute - end - object actPythonEngineRemote: TAction - Tag = 1 - AutoCheck = True - Caption = '&Remote' - GroupIndex = 1 - HelpContext = 340 - HelpType = htContext - Hint = 'Use a remote Python engine' - OnExecute = actPythonEngineExecute - end - object actPythonEngineRemoteTk: TAction - Tag = 2 - AutoCheck = True - Caption = 'Remote (&Tk)' - GroupIndex = 1 - HelpContext = 340 - HelpType = htContext - Hint = 'Use a remote Python engine for Tkinter applications' - OnExecute = actPythonEngineExecute - end - object actPythonEngineRemoteWx: TAction - Tag = 3 - AutoCheck = True - Caption = 'Remote (&Wx)' - GroupIndex = 1 - HelpContext = 340 - HelpType = htContext - Hint = 'Use a remote Python engine for wxPython applications' - OnExecute = actPythonEngineExecute - end + end + object PyDelphiWrapper: TPyDelphiWrapper + Engine = PythonEngine + Module = PyscripterModule + Left = 612 + Top = 86 + end + object PyscripterModule: TPythonModule + Engine = PythonEngine + ModuleName = 'pyscripter' + Errors = <> + Left = 584 + Top = 87 end end diff --git a/frmPythonII.pas b/frmPythonII.pas index 7e0ee428c..0eeea6d6b 100644 --- a/frmPythonII.pas +++ b/frmPythonII.pas @@ -24,7 +24,7 @@ interface SynEditHighlighter, SynEdit, SynEditKeyCmds, SynCompletionProposal, JvComponent, JvDockControlForm, frmIDEDockWin, ExtCtrls, TBX, TBXThemes, PythonGUIInputOutput, JvComponentBase, - SynUnicode, TB2Item, ActnList, cPyBaseDebugger; + SynUnicode, TB2Item, ActnList, cPyBaseDebugger, WrapDelphi, WrapDelphiClasses; const WM_APPENDTEXT = WM_USER + 1020; @@ -48,21 +48,12 @@ TPythonIIForm = class(TIDEDockWindow) actCopyHistory: TAction; TBXSeparatorItem2: TTBXSeparatorItem; TBXItem4: TTBXItem; - actPythonEngineInternal: TAction; - TBXSepReinitialize: TTBXSeparatorItem; - actReinitialize: TAction; - TBXItem6: TTBXItem; actClearContents: TAction; TBXItem7: TTBXItem; TBXPythonEngines: TTBXSubmenuItem; - TBXItem5: TTBXItem; - TBXItem8: TTBXItem; - TBXItem9: TTBXItem; - TBXItem10: TTBXItem; - actPythonEngineRemote: TAction; - actPythonEngineRemoteTk: TAction; - actPythonEngineRemoteWx: TAction; TBXSeparatorItem3: TTBXSeparatorItem; + PyDelphiWrapper: TPyDelphiWrapper; + PyscripterModule: TPythonModule; procedure testResultAddError(Sender: TObject; PSelf, Args: PPyObject; var Result: PPyObject); procedure testResultAddFailure(Sender: TObject; PSelf, Args: PPyObject; @@ -117,10 +108,7 @@ TPythonIIForm = class(TIDEDockWindow) var Result: PPyObject); procedure awakeGUIExecute(Sender: TObject; PSelf, Args: PPyObject; var Result: PPyObject); - procedure actReinitializeExecute(Sender: TObject); procedure actClearContentsExecute(Sender: TObject); - procedure actPythonEngineExecute(Sender: TObject); - procedure TBXPythonEnginesPopup(Sender: TTBCustomItem; FromLink: Boolean); private { Private declarations } fCommandHistory : TWideStringList; @@ -177,7 +165,7 @@ implementation SynEditTypes, Math, frmPyIDEMain, dmCommands, VarPyth, Registry, frmMessages, uCommonFunctions, JclStrings, frmVariables, StringResources, dlgConfirmReplace, frmUnitTests, JvDockGlobals, SynRegExpr, - cPyDebugger, cPyRemoteDebugger, JvJVCLUtils, frmCallStack; + cPyDebugger, cPyRemoteDebugger, JvJVCLUtils, frmCallStack, uCmdLine; {$R *.dfm} @@ -381,28 +369,6 @@ procedure TPythonIIForm.WritePendingMessages; end; end; -procedure TPythonIIForm.actReinitializeExecute(Sender: TObject); -begin - PyControl.ActiveInterpreter.ReInitialize; -end; - -procedure TPythonIIForm.actPythonEngineExecute(Sender: TObject); -Var - PythonEngineType : TPythonEngineType; - Msg : string; -begin - PythonEngineType := TPythonEngineType((Sender as TAction).Tag); - SetPythonEngineType(PythonEngineType); - case CommandsDataModule.PyIDEOptions.PythonEngineType of - peInternal : Msg := Format(SEngineActive, ['Internal','']); - peRemote : Msg := Format(SEngineActive, ['Remote','']); - peRemoteTk : Msg := Format(SEngineActive, ['Remote','(Tkinter) ']); - peRemoteWx : Msg := Format(SEngineActive, ['Remote','(wxPython) ']); - end; - AppendText(WideLineBreak + Msg); - AppendPrompt; -end; - procedure TPythonIIForm.AppendText(S: WideString); begin SynEdit.ExecuteCommand(ecEditorBottom, ' ', nil); @@ -437,6 +403,7 @@ procedure TPythonIIForm.FormCreate(Sender: TObject); Registry : TRegistry; RegKey : string; II : Variant; // wrapping sys and code modules + P : PPyObject; begin inherited; SynEdit.ControlStyle := SynEdit.ControlStyle + [csOpaque]; @@ -462,7 +429,7 @@ procedure TPythonIIForm.FormCreate(Sender: TObject); // For recalling old commands in Interactive Window; fCommandHistory := TWideStringList.Create(); - fCommandHistorySize := 20; + fCommandHistorySize := 50; fCommandHistoryPointer := 0; PS1 := SysModule.ps1; @@ -488,10 +455,24 @@ procedure TPythonIIForm.FormCreate(Sender: TObject); finally Registry.Free; end; + + // for unregistered Python + if PythonHelpFile = '' then begin + PythonHelpFile := SysModule.prefix + '\Doc\Python' +IntToStr(SysModule.version_info[0]) + + IntToStr(SysModule.version_info[1]) + '.chm'; + if not FileExists(PythonHelpFile) then + PythonHelpFile := ''; + end; + // Create internal Interpreter and Debugger II := VarPythonEval('_II'); PythonEngine.ExecString('del _II'); + // Wrap IDE Options + p := PyDelphiWrapper.Wrap(CommandsDataModule.PyIDEOptions); + PyscripterModule.SetVar('IDEOptions', p); + PythonEngine.Py_XDECREF(p); + InternalInterpreter := TPyInternalInterpreter.Create(II); PyControl.ActiveInterpreter := InternalInterpreter; PyControl.ActiveDebugger := TPyInternalDebugger.Create; @@ -516,7 +497,7 @@ procedure TPythonIIForm.GetBlockBoundary(LineN: integer; var StartLineN, start and end line numbers of the block, and a flag indicating if the block is a Python code block. If the line specified has a Python prompt, then the lines are parsed - and forwards, and the IsCode is true. + backwards and forwards, and the IsCode is true. If the line does not start with a prompt, the block is searched forward and backward until a prompt _is_ found, and all lines in between without prompts are returned, and the IsCode is false. @@ -808,11 +789,11 @@ procedure TPythonIIForm.SynEditProcessUserCommand(Sender: TObject; //SynCodeCompletion.DefaultType := ctParams; SynParamCompletion.ActivateCompletion; Command := ecNone; - end; + end // The following does not work. compiler bug??? // if Command in [ecRecallCommandPrev, ecRecallCommandNext, ecRecallCommandEsc] then begin - if (Command = ecRecallCommandPrev) or (Command = ecRecallCommandNext) or + else if (Command = ecRecallCommandPrev) or (Command = ecRecallCommandNext) or (Command = ecRecallCommandEsc) then begin SynCodeCompletion.CancelCompletion; @@ -837,82 +818,76 @@ procedure TPythonIIForm.SynEditProcessUserCommand(Sender: TObject; fCommandHistoryPrefix := BlockSource; end; - // if we have code at the end remove code block + Source := ''; + if Command = ecRecallCommandEsc then begin + fCommandHistoryPointer := fCommandHistory.Count; + fCommandHistoryPrefix := ''; + end else + Repeat + if Command = ecRecallCommandPrev then + Dec(fCommandHistoryPointer) + else if Command = ecRecallCommandNext then + Inc(fCommandHistoryPointer); + fCommandHistoryPointer := EnsureRange(fCommandHistoryPointer, -1, fCommandHistory.Count); + Until not InRange(fCommandHistoryPointer, 0, fCommandHistory.Count-1) or + (fCommandHistoryPrefix = '') or + WideStrIsLeft(PWideChar(fCommandHistory[fCommandHistoryPointer]), PWideChar(fCommandHistoryPrefix)); + + if InRange(fCommandHistoryPointer, 0, fCommandHistory.Count-1) then + Source := fCommandHistory[fCommandHistoryPointer] + else begin + if Command <> ecRecallCommandEsc then + Beep(); + Source := fCommandHistoryPrefix; + fCommandHistoryPrefix := ''; + end; + SynEdit.BeginUpdate; try if IsCode and (EndLineN = SynEdit.Lines.Count - 1) then begin + // already at the bottom and inside the prompt + if (BlockSource <> Source) then begin for i := EndLineN downto StartLineN do SynEdit.Lines.Delete(i); + //Append new prompt if needed + SetLength(Buffer, 0); + AppendToPrompt(Buffer); + end; // else do nothing + end else begin + SetLength(Buffer, 0); + AppendToPrompt(Buffer); end; - //Append new prompt if needed - SetLength(Buffer, 0); - AppendToPrompt(Buffer); -// SynEdit.ExecuteCommand(ecEditorBottom, ' ', nil); -// SynEdit.EnsureCursorPosVisible; - finally - SynEdit.EndUpdate; - end; - end else - Exit; - - // We get here if Command is one or our defined Recall commands - - Source := ''; - if fCommandHistory.Count = 0 then Exit; - - if Command = ecRecallCommandEsc then begin - fCommandHistoryPointer := fCommandHistory.Count; - fCommandHistoryPrefix := ''; - end else - Repeat - if Command = ecRecallCommandPrev then - Dec(fCommandHistoryPointer) - else if Command = ecRecallCommandNext then - Inc(fCommandHistoryPointer); - fCommandHistoryPointer := EnsureRange(fCommandHistoryPointer, -1, fCommandHistory.Count); - Until not InRange(fCommandHistoryPointer, 0, fCommandHistory.Count-1) or - (fCommandHistoryPrefix = '') or - WideStrIsLeft(PWideChar(fCommandHistory[fCommandHistoryPointer]), PWideChar(fCommandHistoryPrefix)); - - if InRange(fCommandHistoryPointer, 0, fCommandHistory.Count-1) then - Source := fCommandHistory[fCommandHistoryPointer] - else begin - if Command <> ecRecallCommandEsc then - Beep(); - Source := fCommandHistoryPrefix; - fCommandHistoryPrefix := ''; - end; - if Source <> '' then begin - SynEdit.BeginUpdate; - try - i := 0; - P1 := PWideChar(Source); - while P1 <> nil do begin - P1 := StrScanW(P1, WideLF); - if Assigned(P1) then Inc(P1); - Inc(i); - end; - SetLength(Buffer, i); - - i := 0; - P1 := PWideChar(Source); - while P1 <> nil do begin - P2 := StrScanW(P1, WideLF); - if P2 = nil then - Buffer[i] := Copy(Source, P1 - PWideChar(Source) + 1, - Length(Source) - (P1 - PWideChar(Source))) - else begin - Buffer[i] := Copy(Source, P1 - PWideChar(Source) + 1, P2 - P1); - Inc(P2); + if (Source <> '') and + ((BlockSource <> Source) or (EndLineN < SynEdit.Lines.Count - 1)) then + begin + i := 0; + P1 := PWideChar(Source); + while P1 <> nil do begin + P1 := StrScanW(P1, WideLF); + if Assigned(P1) then Inc(P1); + Inc(i); + end; + SetLength(Buffer, i); + + i := 0; + P1 := PWideChar(Source); + while P1 <> nil do begin + P2 := StrScanW(P1, WideLF); + if P2 = nil then + Buffer[i] := Copy(Source, P1 - PWideChar(Source) + 1, + Length(Source) - (P1 - PWideChar(Source))) + else begin + Buffer[i] := Copy(Source, P1 - PWideChar(Source) + 1, P2 - P1); + Inc(P2); + end; + P1 := P2; + Inc(i); end; - P1 := P2; - Inc(i); + AppendToPrompt(Buffer); end; - - AppendToPrompt(Buffer); -// SynEdit.ExecuteCommand(ecEditorBottom, ' ', nil); -// SynEdit.EnsureCursorPosVisible; + SynEdit.ExecuteCommand(ecEditorBottom, ' ', nil); + SynEdit.EnsureCursorPosVisible; finally SynEdit.EndUpdate; end; @@ -1284,12 +1259,8 @@ procedure TPythonIIForm.testResultAddError(Sender: TObject; PSelf, procedure TPythonIIForm.FormActivate(Sender: TObject); begin inherited; - if not HasFocus then begin - FGPanelEnter(Self); - PostMessage(SynEdit.Handle, WM_SETFOCUS, 0, 0); - if Synedit.CanFocus then - SynEdit.SetFocus; - end; + if Synedit.CanFocus then + SynEdit.SetFocus; end; procedure TPythonIIForm.TBMThemeChange(var Message: TMessage); @@ -1302,23 +1273,18 @@ procedure TPythonIIForm.TBMThemeChange(var Message: TMessage); end; end; -procedure TPythonIIForm.TBXPythonEnginesPopup(Sender: TTBCustomItem; - FromLink: Boolean); -begin - case CommandsDataModule.PyIDEOptions.PythonEngineType of - peInternal : actPythonEngineInternal.Checked := True; - peRemote : actPythonEngineRemote.Checked := True; - peRemoteTk : actPythonEngineRemoteTk.Checked := True; - peRemoteWx : actPythonEngineRemoteWx.Checked := True; - end; - actReinitialize.Enabled := icReInitialize in - PyControl.ActiveInterpreter.InterpreterCapabilities; -end; - procedure TPythonIIForm.InterpreterPopUpPopup(Sender: TObject); begin actCleanUpNameSpace.Checked := CommandsDataModule.PyIDEOptions.CleanupMainDict; actCleanUpSysModules.Checked := CommandsDataModule.PyIDEOptions.CleanupSysModules; + if CommandsDataModule.PyIDEOptions.PythonEngineType in [peRemoteTk, peRemoteWx] then begin + // CleanupNamespace and CleanUpSysModules are set to false by these engines and should stay so + actCleanUpNameSpace.Enabled := False; + actCleanUpSysModules.Enabled := False; + end else begin + actCleanUpNameSpace.Enabled := True; + actCleanUpSysModules.Enabled := True; + end; end; procedure TPythonIIForm.WMAPPENDTEXT(var Message: TMessage); @@ -1395,16 +1361,16 @@ procedure TPythonIIForm.RegisterHistoryCommands; procedure TPythonIIForm.LoadPythonEngine; - function IsPythonVersionParam(const AParam : String; out AVersion : String) : Boolean; - begin - Result := (Length(AParam) = 9) and - SameText(Copy(AParam, 1, 7), '-PYTHON') and - (AParam[8] in ['0'..'9']) and - (AParam[9] in ['0'..'9']); - if Result then - AVersion := AParam[8] + '.' + AParam[9]; - end; - +// function IsPythonVersionParam(const AParam : String; out AVersion : String) : Boolean; +// begin +// Result := (Length(AParam) = 9) and +// SameText(Copy(AParam, 1, 7), '-PYTHON') and +// (AParam[8] in ['0'..'9']) and +// (AParam[9] in ['0'..'9']); +// if Result then +// AVersion := AParam[8] + '.' + AParam[9]; +// end; +// function IndexOfKnownVersion(const AVersion : String) : Integer; var i : Integer; @@ -1428,23 +1394,51 @@ procedure TPythonIIForm.LoadPythonEngine; // first find an optional parameter specifying the expected Python version in the form of -PYTHONXY expectedVersion := ''; expectedVersionIdx := -1; - for i := 1 to ParamCount do begin - if IsPythonVersionParam(ParamStr(i), expectedVersion) then - begin - idx := IndexOfKnownVersion(expectedVersion); - if idx >= COMPILED_FOR_PYTHON_VERSION_INDEX then - expectedVersionIdx := idx; - if expectedVersionIdx = -1 then - if idx = -1 then - MessageDlg(Format('PyScripter can''t use command line parameter %s because it doesn''t know this version of Python.', - [ParamStr(i)]), mtWarning, [mbOK], 0) - else - MessageDlg(Format('PyScripter can''t use command line parameter %s because it was compiled for Python %s or later.', - [ParamStr(i), PYTHON_KNOWN_VERSIONS[COMPILED_FOR_PYTHON_VERSION_INDEX].RegVersion]), mtWarning, [mbOK], 0); - Break; - end; +// for i := 1 to ParamCount do begin +// if IsPythonVersionParam(ParamStr(i), expectedVersion) then +// begin +// idx := IndexOfKnownVersion(expectedVersion); +// if idx >= COMPILED_FOR_PYTHON_VERSION_INDEX then +// expectedVersionIdx := idx; +// if expectedVersionIdx = -1 then +// if idx = -1 then +// MessageDlg(Format('PyScripter can''t use command line parameter %s because it doesn''t know this version of Python.', +// [ParamStr(i)]), mtWarning, [mbOK], 0) +// else +// MessageDlg(Format('PyScripter can''t use command line parameter %s because it was compiled for Python %s or later.', +// [ParamStr(i), PYTHON_KNOWN_VERSIONS[COMPILED_FOR_PYTHON_VERSION_INDEX].RegVersion]), mtWarning, [mbOK], 0); +// Break; +// end; +// end; + try + if CmdLineReader.readFlag('PYTHON23') then + expectedVersion := '2.3' + else if CmdLineReader.readFlag('PYTHON24') then + expectedVersion := '2.4' + else if CmdLineReader.readFlag('PYTHON25') then + expectedVersion := '2.5'; + PythonEngine.DllPath := CmdLineReader.readString('PYTHONDLLPATH'); + except + on ECommandLineParseException do; + end; + + if expectedVersion <> '' then begin + idx := IndexOfKnownVersion(expectedVersion); + if idx >= COMPILED_FOR_PYTHON_VERSION_INDEX then + expectedVersionIdx := idx; + if expectedVersionIdx = -1 then + if idx = -1 then + MessageDlg(Format('PyScripter can''t use command line parameter PYTHON%s because it doesn''t know this version of Python.', + [StringReplace(expectedVersion, '.', '', [])]), mtWarning, [mbOK], 0) + else + MessageDlg(Format('PyScripter can''t use command line parameter PYTHON%s because it was compiled for Python %s or later.', + [StringReplace(expectedVersion, '.', '', []), + PYTHON_KNOWN_VERSIONS[COMPILED_FOR_PYTHON_VERSION_INDEX].RegVersion]), + mtWarning, [mbOK], 0); end; -// disable feature that will try to use the last version of Python because we provide our + + + // disable feature that will try to use the last version of Python because we provide our // own behaviour. Note that this feature would not load the latest version if the python dll // matching the compiled version of P4D was found. PythonEngine.UseLastKnownVersion := False; diff --git a/frmRegExpTester.dfm b/frmRegExpTester.dfm index c42e89e7f..a5f03f8de 100644 --- a/frmRegExpTester.dfm +++ b/frmRegExpTester.dfm @@ -47,8 +47,7 @@ inherited RegExpTesterWindow: TRegExpTesterWindow 000000000000000000F77E7E1023000000000000000000000000F77D7E11FFFF 0000E00F00008003000000010000000100000001000000010000000100000003 00000007000080030000E0010000FF800000FFC00000FFE00000FFF00000} - OnActivate = FormActivate - ExplicitWidth = 241 + ExplicitWidth = 249 PixelsPerInch = 96 TextHeight = 13 inherited FGPanel: TPanel @@ -189,18 +188,17 @@ inherited RegExpTesterWindow: TRegExpTesterWindow Width = 402 Height = 358 Position = dpLeft - object TBXDockablePanel3: TTBXDockablePanel + object TBXDockablePanel4: TTBXDockablePanel Left = 0 Top = 218 Align = alBottom - Caption = 'TBXDockablePanel3' DockedWidth = 398 DockPos = 218 ShowCaption = False ShowCaptionWhenDocked = False - SplitHeight = 125 + SplitHeight = 124 SupportedDocks = [dkStandardDock, dkMultiDock] - TabOrder = 0 + TabOrder = 3 object TBXLabel1: TTBXLabel Left = 0 Top = 0 @@ -239,12 +237,14 @@ inherited RegExpTesterWindow: TRegExpTesterWindow Header.Font.Name = 'MS Shell Dlg 2' Header.Font.Style = [] Header.Options = [hoAutoResize, hoColumnResize, hoDrag, hoOwnerDraw, hoVisible] + Header.ParentFont = True HintMode = hmTooltip TabOrder = 1 TreeOptions.MiscOptions = [toFullRepaintOnResize, toInitOnSave, toReportMode, toToggleOnDblClick, toWheelPanning] TreeOptions.PaintOptions = [toShowButtons, toShowDropmark, toShowHorzGridLines, toShowVertGridLines, toUseBlendedImages, toUseBlendedSelection] TreeOptions.StringOptions = [toAutoAcceptEditChange] OnGetText = GroupsViewGetText + ExplicitTop = 21 Columns = < item Alignment = taRightJustify @@ -269,17 +269,16 @@ inherited RegExpTesterWindow: TRegExpTesterWindow end> end end - object TBXDockablePanel1: TTBXDockablePanel + object TBXDockablePanel3: TTBXDockablePanel Left = 0 - Top = 139 - Caption = 'TBXDockablePanel3' + Top = 155 DockedWidth = 398 - DockPos = 139 + DockPos = 155 ShowCaption = False ShowCaptionWhenDocked = False - SplitHeight = 79 + SplitHeight = 63 SupportedDocks = [dkStandardDock, dkMultiDock] - TabOrder = 1 + TabOrder = 2 object TBXLabel2: TTBXLabel Left = 0 Top = 0 @@ -305,24 +304,25 @@ inherited RegExpTesterWindow: TRegExpTesterWindow Left = 0 Top = 22 Width = 398 - Height = 53 + Height = 37 Align = alClient + AutoSize = False AutoURLDetect = False PlainText = True TabOrder = 1 + ExplicitHeight = 53 end end - object TBXDockablePanel2: TTBXDockablePanel + object TBXDockablePanel1: TTBXDockablePanel Left = 0 Top = 0 - Caption = 'TBXDockablePanel3' DockedWidth = 398 DockPos = 0 ShowCaption = False ShowCaptionWhenDocked = False - SplitHeight = 60 + SplitHeight = 76 SupportedDocks = [dkStandardDock, dkMultiDock] - TabOrder = 2 + TabOrder = 0 object TBXLabel3: TTBXLabel Left = 0 Top = 0 @@ -348,25 +348,26 @@ inherited RegExpTesterWindow: TRegExpTesterWindow Left = 0 Top = 22 Width = 398 - Height = 33 + Height = 50 Align = alClient + AutoSize = False AutoURLDetect = False PlainText = True TabOrder = 1 OnChange = RegExpTextChange + ExplicitHeight = 33 end end - object TBXDockablePanel4: TTBXDockablePanel + object TBXDockablePanel2: TTBXDockablePanel Left = 0 - Top = 59 - Caption = 'TBXDockablePanel3' + Top = 76 DockedWidth = 398 - DockPos = 59 + DockPos = 76 ShowCaption = False ShowCaptionWhenDocked = False - SplitHeight = 81 + SplitHeight = 79 SupportedDocks = [dkStandardDock, dkMultiDock] - TabOrder = 3 + TabOrder = 1 object TBXLabel4: TTBXLabel Left = 0 Top = 0 @@ -392,12 +393,14 @@ inherited RegExpTesterWindow: TRegExpTesterWindow Left = 0 Top = 22 Width = 398 - Height = 54 + Height = 53 Align = alClient + AutoSize = False AutoURLDetect = False PlainText = True TabOrder = 1 OnChange = RegExpTextChange + ExplicitHeight = 54 end end end diff --git a/frmRegExpTester.pas b/frmRegExpTester.pas index 368b73e71..1692400f5 100644 --- a/frmRegExpTester.pas +++ b/frmRegExpTester.pas @@ -30,16 +30,16 @@ TRegExpTesterWindow = class(TIDEDockWindow, IJvAppStorageHandler) TBXSeparatorItem1: TTBXSeparatorItem; TIExecute: TTBXItem; TBXMultiDock: TTBXMultiDock; - TBXDockablePanel3: TTBXDockablePanel; + TBXDockablePanel4: TTBXDockablePanel; TBXLabel1: TTBXLabel; GroupsView: TVirtualStringTree; - TBXDockablePanel1: TTBXDockablePanel; + TBXDockablePanel3: TTBXDockablePanel; TBXLabel2: TTBXLabel; MatchText: TmbTBXJvRichEdit; - TBXDockablePanel2: TTBXDockablePanel; + TBXDockablePanel1: TTBXDockablePanel; TBXLabel3: TTBXLabel; RegExpText: TmbTBXJvRichEdit; - TBXDockablePanel4: TTBXDockablePanel; + TBXDockablePanel2: TTBXDockablePanel; TBXLabel4: TTBXLabel; SearchText: TmbTBXJvRichEdit; TBXSeparatorItem2: TTBXSeparatorItem; @@ -92,11 +92,10 @@ procedure TRegExpTesterWindow.FormResize(Sender: TObject); procedure TRegExpTesterWindow.FormActivate(Sender: TObject); begin inherited; - if not HasFocus then begin - FGPanelEnter(Self); - PostMessage(RegExpText.Handle, WM_SETFOCUS, 0, 0); - end; -end; + if RegExpText.CanFocus then + RegExpText.SetFocus; +// PostMessage(RegExpText.Handle, WM_SETFOCUS, 0, 0); + end; procedure TRegExpTesterWindow.FormCreate(Sender: TObject); begin diff --git a/frmToDo.dfm b/frmToDo.dfm index 0156830ec..2da29ceac 100644 --- a/frmToDo.dfm +++ b/frmToDo.dfm @@ -76,9 +76,8 @@ inherited ToDoWindow: TToDoWindow 003F8000003F8000003F8000003FC000003FFC00003FFC00003FFC00003FFC00 003FFC00003FFC00003FFC00003FFC00003FFC00003FFC00007FFC0001FFFC00 07FFFC001FFFFC007FFFFC01FFFFFC07FFFFFC1FFFFFFE7FFFFFFFFFFFFF} - OnActivate = FormActivate - ExplicitWidth = 500 - ExplicitHeight = 319 + ExplicitWidth = 508 + ExplicitHeight = 327 PixelsPerInch = 96 TextHeight = 13 inherited FGPanel: TPanel diff --git a/frmToDo.pas b/frmToDo.pas index 4ba13da39..8df3c2388 100644 --- a/frmToDo.pas +++ b/frmToDo.pas @@ -797,10 +797,9 @@ procedure TToDoWindow.FormActivate(Sender: TObject); FIsFirstActivation := False; RefreshTodoList; end; - if not HasFocus then begin - FGPanelEnter(Self); - PostMessage(ToDoView.Handle, WM_SETFOCUS, 0, 0); - end; + if ToDoView.CanFocus then + ToDoView.SetFocus; + //PostMessage(ToDoView.Handle, WM_SETFOCUS, 0, 0); end; procedure TToDoWindow.actViewStayOnTopExecute(Sender: TObject); diff --git a/frmUnitTests.dfm b/frmUnitTests.dfm index 0e1733772..dfe4ad77d 100644 --- a/frmUnitTests.dfm +++ b/frmUnitTests.dfm @@ -40,9 +40,8 @@ inherited UnitTestWindow: TUnitTestWindow 000000000022000000150000000000000000000000000000000000000000C3C1 00008001000000000000000000000000000080010000C0030000E00700000000 000000000000F00F0000C00300008C3100009C390000FC3F0000F99F0000} - OnActivate = FormActivate - ExplicitWidth = 270 - ExplicitHeight = 477 + ExplicitWidth = 278 + ExplicitHeight = 485 PixelsPerInch = 96 TextHeight = 13 inherited FGPanel: TPanel @@ -66,7 +65,7 @@ inherited UnitTestWindow: TUnitTestWindow Maximized = False Minimized = False ButtonCursor = crDefault - ButtonHighlightColor = 14400935 + ButtonHighlightColor = 15195862 AutoHighlightColor = True end object ExplorerDock: TTBXDock diff --git a/frmUnitTests.pas b/frmUnitTests.pas index 0734c6e0f..33125cae7 100644 --- a/frmUnitTests.pas +++ b/frmUnitTests.pas @@ -210,10 +210,9 @@ procedure TUnitTestWindow.actRefreshExecute(Sender: TObject); procedure TUnitTestWindow.FormActivate(Sender: TObject); begin inherited; - if not HasFocus then begin - FGPanelEnter(Self); - PostMessage(UnitTests.Handle, WM_SETFOCUS, 0, 0); - end; + if UnitTests.CanFocus then + UnitTests.SetFocus; + //PostMessage(UnitTests.Handle, WM_SETFOCUS, 0, 0); end; procedure TUnitTestWindow.FormCreate(Sender: TObject); diff --git a/frmVariables.dfm b/frmVariables.dfm index 192062864..eaed520d2 100644 --- a/frmVariables.dfm +++ b/frmVariables.dfm @@ -42,9 +42,8 @@ inherited VariablesWindow: TVariablesWindow 000000000000000000000000000000000000000000000000000000000000F00F 0000F00F0000F0030000F0030000F0000000D0000000F0000000D0000000FC00 0000DC000000FF0000008F00000007FF0000055F000007FF00008FFF0000} - OnActivate = FormActivate - ExplicitWidth = 587 - ExplicitHeight = 273 + ExplicitWidth = 595 + ExplicitHeight = 281 PixelsPerInch = 96 TextHeight = 13 inherited FGPanel: TPanel @@ -66,7 +65,7 @@ inherited VariablesWindow: TVariablesWindow Maximized = False Minimized = False ButtonCursor = crDefault - ButtonHighlightColor = 14400935 + ButtonHighlightColor = 15195862 AutoHighlightColor = True end object VariablesTree: TVirtualStringTree @@ -84,9 +83,10 @@ inherited VariablesWindow: TVariablesWindow Header.Font.Charset = DEFAULT_CHARSET Header.Font.Color = clWindowText Header.Font.Height = -11 - Header.Font.Name = 'Tahoma' + Header.Font.Name = 'MS Shell Dlg 2' Header.Font.Style = [] Header.Options = [hoAutoResize, hoColumnResize, hoDrag, hoHotTrack, hoOwnerDraw, hoVisible] + Header.ParentFont = True Header.PopupMenu = VTHeaderPopupMenu HintMode = hmTooltip Images = CommandsDataModule.CodeImages @@ -141,13 +141,7 @@ inherited VariablesWindow: TVariablesWindow MarginHeight = 2 Align = alTop Color = clBtnFace - Font.Charset = DEFAULT_CHARSET - Font.Color = clWindowText - Font.Height = -11 - Font.Name = 'MS Shell Dlg 2' - Font.Style = [] ParentColor = False - ParentFont = False end end end diff --git a/frmVariables.pas b/frmVariables.pas index d44c24938..69321fdb6 100644 --- a/frmVariables.pas +++ b/frmVariables.pas @@ -345,10 +345,9 @@ procedure TVariablesWindow.ClearAll; procedure TVariablesWindow.FormActivate(Sender: TObject); begin inherited; - if not HasFocus then begin - FGPanelEnter(Self); - PostMessage(VariablesTree.Handle, WM_SETFOCUS, 0, 0); - end; + if VariablesTree.CanFocus then + VariablesTree.SetFocus; + //PostMessage(VariablesTree.Handle, WM_SETFOCUS, 0, 0); end; procedure TVariablesWindow.TBMThemeChange(var Message: TMessage); diff --git a/frmWatches.dfm b/frmWatches.dfm index 51694df21..368b94386 100644 --- a/frmWatches.dfm +++ b/frmWatches.dfm @@ -42,9 +42,8 @@ inherited WatchesWindow: TWatchesWindow 00FF800000FF800000FF800000FF800000FF800000FF800000FF800000FFFFFF 00009E7F00000C3F00000C3F00000000000080000000C0000000C0000000C000 0000C0000000C0000000C0000000C0000000C0000000C0000000C0000000} - OnActivate = FormActivate - ExplicitWidth = 447 - ExplicitHeight = 251 + ExplicitWidth = 455 + ExplicitHeight = 259 PixelsPerInch = 96 TextHeight = 13 inherited FGPanel: TPanel @@ -66,10 +65,11 @@ inherited WatchesWindow: TWatchesWindow Header.Font.Charset = DEFAULT_CHARSET Header.Font.Color = clWindowText Header.Font.Height = -11 - Header.Font.Name = 'Tahoma' + Header.Font.Name = 'MS Shell Dlg 2' Header.Font.Style = [] Header.MainColumn = 1 Header.Options = [hoColumnResize, hoDrag, hoHotTrack, hoOwnerDraw, hoVisible] + Header.ParentFont = True HintMode = hmTooltip PopupMenu = TBXPopupMenu TabOrder = 0 @@ -81,6 +81,7 @@ inherited WatchesWindow: TWatchesWindow OnDblClick = WatchesViewDblClick OnGetText = WatchesViewGetText OnInitNode = WatchesViewInitNode + OnKeyDown = WatchesViewKeyDown Columns = < item Position = 0 diff --git a/frmWatches.pas b/frmWatches.pas index 9b69e1c72..f35cda49a 100644 --- a/frmWatches.pas +++ b/frmWatches.pas @@ -43,6 +43,8 @@ TWatchesWindow = class(TIDEDockWindow, IJvAppStorageHandler) Node: PVirtualNode; Column: TColumnIndex; TextType: TVSTTextType; var CellText: WideString); procedure TBXPopupMenuPopup(Sender: TObject); + procedure WatchesViewKeyDown(Sender: TObject; var Key: Word; + Shift: TShiftState); private { Private declarations } fWatchesList : TObjectList; @@ -162,8 +164,21 @@ procedure TWatchesWindow.mnClearAllClick(Sender: TObject); end; procedure TWatchesWindow.WatchesViewDblClick(Sender: TObject); +Var + Pt : TPoint; + HitInfo: THitInfo; begin - mnEditWatchClick(Sender); + try + Pt := Mouse.CursorPos; + Pt := WatchesView.ScreenToClient(Pt); + WatchesView.GetHitTestInfoAt(Pt.X, Pt.Y, True, HitInfo); + except + HitInfo.HitNode := nil; + end; + if Assigned(HitInfo.HitNode) then + mnEditWatchClick(Sender) + else + mnAddWatchClick(Sender); end; procedure TWatchesWindow.mnCopyToClipboardClick(Sender: TObject); @@ -174,10 +189,9 @@ procedure TWatchesWindow.mnCopyToClipboardClick(Sender: TObject); procedure TWatchesWindow.FormActivate(Sender: TObject); begin inherited; - if not HasFocus then begin - FGPanelEnter(Self); - PostMessage(WatchesView.Handle, WM_SETFOCUS, 0, 0); - end; + if WatchesView.CanFocus then + WatchesView.SetFocus; + //PostMessage(WatchesView.Handle, WM_SETFOCUS, 0, 0); end; procedure TWatchesWindow.TBMThemeChange(var Message: TMessage); @@ -218,6 +232,16 @@ procedure TWatchesWindow.WatchesViewInitNode(Sender: TBaseVirtualTree; fWatchesList[Node.Index] as TWatchInfo; end; +procedure TWatchesWindow.WatchesViewKeyDown(Sender: TObject; var Key: Word; + Shift: TShiftState); +begin + inherited; + if Key = VK_Delete then begin + mnRemoveWatchClick(Sender); + Key := 0; + end; +end; + procedure TWatchesWindow.WatchesViewGetText(Sender: TBaseVirtualTree; Node: PVirtualNode; Column: TColumnIndex; TextType: TVSTTextType; var CellText: WideString); diff --git a/uCmdLine.pas b/uCmdLine.pas new file mode 100644 index 000000000..631c65a20 --- /dev/null +++ b/uCmdLine.pas @@ -0,0 +1,479 @@ +{Copyright (C) 2006 Benito van der Zander + +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., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301, USA. +} +unit uCmdLine; + +interface +{$IFDEF FPC} + {$mode objfpc}{$H+} +{$ENDIF} + +uses sysutils; //for exceptions +type + TStringArray=array of string; + TLongintArray=array of longint; + TFloatArray=array of extended; + TBooleanArray=array of boolean; + TCommandLineReaderLanguage=(clrlEnglish,clrlGerman); + TCommandLineReaderShowError=procedure (errorDescription: string); + ECommandLineParseException=class(Exception); + TKindOfProperty=(kpStr,kpFile,kpInt,kpFloat,kpFlag); + TProperty=record + name,desc,strvalue:string; + found: boolean; + case kind: TKindOfProperty of + kpStr,kpFile: (); + kpInt: (intvalue: longint); + kpFloat: (floatvalue: extended); + kpFlag: (flagvalue,flagdefault: boolean; + abbreviation: char) + end; + PProperty=^TProperty; + + { TCommandLineReader } + + TCommandLineReader=class + protected + parsed{,searchNameLessFile,searchNameLessInt,searchNameLessFloat,searchNameLessFlag}: boolean; + propertyArray: array of TProperty; + nameless: TStringArray; + function findProperty(name:string):PProperty; + function declareProperty(name,description,default:string;kind: TKindOfProperty):PProperty; + public + language:TCommandLineReaderLanguage; //not implemented yet + onShowError: TCommandLineReaderShowError; + automaticalShowError: boolean; + allowDOSStyle: boolean; + + constructor create; + destructor Destroy; override; + + function avaibleOptions:string; + + procedure parse();overload; + procedure parse(const s:string);overload; + + //DeclareFlag allows the use of flags + //Example: + // declareFlag('flag','f',true); + // Following command-line options are always possible + // --enable-flag => flag:=true + // --disable-flag => flag:=false + // --flag => flag:=not default + // -xfy => flag:=not default + procedure declareFlag(const name,description:string;flagNameAbbreviation:char;default:boolean=false);overload; + procedure declareFlag(const name,description:string;default:boolean=false);overload; + + + //DeclareFlag allows the use of a file name + //Example: + // declareFile('file'); + // Following command-line options are possible + // --file C:\test => file:=C:\test + // --file 'C:\test' => file:=C:\test + // --file "C:\test" => file:=C:\test + // --file='C:\test' => file:=C:\test + // --file="C:\test" => file:=C:\test + // --file C:\Eigene Dateien\a.bmp => file:=C:\Eigene + // or file:=C:\Eigene Dateien\a.bmp, + // if C:\Eigene does not exist + procedure declareFile(const name,description:string;default:string='');overload; + + //DeclareXXXX allows the use of string, int, float, ... + //Example: + // declareFlag('property'); + // Following command-line options are possible + // --file 123 => file:=123 + // --file '123' => file:=123 + // --file "123" => file:=123 + // --file='123' => file:=123 + // --file="123" => file:=123 + + procedure declareString(const name,description:string;value: string='');overload; + procedure declareInt(const name,description:string;value: longint=0);overload; + procedure declareFloat(const name,description:string;value: extended=0);overload; + + function readString(const name:string):string; overload; + function readInt(const name:string):longint;overload; + function readFloat(const name:string):extended; overload; + function readFlag(const name:string):boolean;overload; + + function existsProperty(const name:string):boolean; + + function readNamelessFiles():TStringArray; + function readNamelessString():TStringArray; + function readNamelessInt():TLongintArray; + function readNamelessFloat():TFloatArray; + function readNamelessFlag():TBooleanArray; + end; + +var + CmdLineReader: TCommandLineReader; + +implementation +uses Windows //for messages + ; + +constructor TCommandLineReader.create; +begin + parsed:=false; + {$IFDEF Win32} + allowDOSStyle:=true; + {$ELSE} + allowDOSStyle:=false; + {$ENDIF} + language:=clrlEnglish; + onShowError:=nil; + {searchNameLessFile:=false; + searchNameLessInt:=false; + searchNameLessFloat:=false; + searchNameLessFlag:=false;} + automaticalShowError:=not IsLibrary; +end; +destructor TCommandLineReader.destroy; +begin + inherited; +end; + +function TCommandLineReader.avaibleOptions: string; +var i:integer; +begin + result:=''; + for i:=0 to high(propertyArray) do begin + result:=result+'--'+propertyArray[i].name; + case propertyArray[i].kind of + kpFlag: if propertyArray[i].abbreviation<>#0 then + result:=result+' or -'+propertyArray[i].abbreviation; + else result:=result+'='; + end; + result:=result+#9+propertyArray[i].desc+#13#10; + end; +end; + +procedure TCommandLineReader.parse(); +var params: string; +begin + params:=string(cmdline);//string(getcommandline); + if params='' then exit; + if params[1]='"' then begin + params[1]:='X'; + delete(params,1,pos('"',params)); + end else delete(params,1,pos(' ',params)); + parse(params); +end; +procedure TCommandLineReader.parse(const s:string); +var cmd: pchar; + + procedure raiseError; + var errorMessage: string; + begin + if assigned(onShowError) or automaticalShowError then begin + errorMessage:='Parse error at this position: '+copy(string(cmd),1,100)+#13#10; + if length(propertyArray)=0 then + errorMessage:='you are not allowed to use command line options starting with -' + else + errorMessage:='The following command line options are valid: '#13#10+avaibleOptions; + end; + + if assigned(onShowError) then + onShowError(errorMessage); + if automaticalShowError then + if system.IsConsole then + writeln(errorMessage) + else + MessageBox(0, PChar(errorMessage), 'PyScripter Command Line Options', MB_ICONWARNING or MB_OK); + + raise ECommandLineParseException.create('Error before '+string(cmd)); + end; + + +var currentProperty:longint; + valueStart: pchar; + valueLength: longint; + flagValue: boolean; + stringStart: char; + i:integer; +begin + cmd:=pchar(s); + currentProperty:=-1; + SetLength(nameless,0); + for i:=0 to high(propertyArray) do + propertyArray[i].found:=false; + while cmd^<>#0 do begin + if (cmd^='-') or (allowDOSStyle and (cmd^='/')) then begin + //Start of property name + if (cmd^='/') or ((cmd+1)^='-') then begin //long property + if cmd^<>'/' then inc(cmd); + inc(cmd); + valueStart:=cmd; + while not (cmd^ in [' ',#0,'=']) do + inc(cmd); + currentProperty:=-1; + if (StrLIComp(valueStart,'enable-',7) = 0)or + (StrLIComp(valueStart,'disable-',8) = 0) then begin + flagValue:=valueStart^='e'; + if flagValue then inc(valueStart,7) + else inc(valueStart,8); + {while not (cmd^ in ['-',#0,'=']) do + inc(cmd);} + valueLength:=longint(cmd-valueStart); + for i:=0 to high(propertyArray) do + if (length(propertyArray[i].name)=valueLength) and + (StrLIComp(valueStart,@propertyArray[i].name[1],valueLength)=0) and + (propertyArray[i].kind=kpFlag) then begin + propertyArray[i].flagvalue:=flagValue; + propertyArray[i].found:=true; + break; + end; + end else begin + valueLength:=longint(cmd-valueStart); + for i:=0 to high(propertyArray) do + if (length(propertyArray[i].name)=valueLength) and + (StrLIComp(valueStart,@propertyArray[i].name[1],valueLength)=0) then begin + if propertyArray[i].kind=kpFlag then + propertyArray[i].flagvalue:=not propertyArray[i].flagdefault; + currentProperty:=i; + propertyArray[i].found:=true; + break; + end; + if currentProperty=-1 then raiseError; + if propertyArray[currentProperty].kind=kpFlag then + currentProperty:=-1; + end; + end else if (cmd+1)^ in [' ',#0] then raiseError //unknown format + else begin //flag abbreviation string + inc(cmd); + while not (cmd^ in [' ',#0]) do begin + for i:=0 to high(propertyArray) do + if (propertyArray[i].kind=kpFlag) and (propertyArray[i].abbreviation=cmd^) then begin + propertyArray[i].flagvalue:=not propertyArray[i].flagdefault; + propertyArray[i].found:=true; + end; + inc(cmd); + end; + end; + end else if cmd^ <> ' ' then begin + //Start of property value + if cmd^ in ['"',''''] then begin + stringStart:=cmd^; + inc(cmd); + valueStart:=cmd; + while not (cmd^ in [stringStart,#0]) do + inc(cmd); + valueLength:=longint(cmd-valueStart); + if currentProperty<>-1 then begin + setlength(propertyArray[currentProperty].strvalue,valueLength); + move(valueStart^,propertyArray[currentProperty].strvalue[1],valueLength); + case propertyArray[currentProperty].kind of + kpInt: propertyArray[currentProperty].intvalue:=StrToInt(propertyArray[currentProperty].strvalue); + kpFloat: propertyArray[currentProperty].floatvalue:=StrToFloat(propertyArray[currentProperty].strvalue); + end; + end else begin + SetLength(nameless,length(nameless)+1); + setlength(nameless[high(nameless)],valueLength); + move(valueStart^,nameless[high(nameless)][1],valueLength); + end; + end else begin + valueStart:=cmd; + while not (cmd^ in [' ',#0]) do inc(cmd); + valueLength:=longint(cmd-valueStart); + if currentProperty=-1 then begin + SetLength(nameless,length(nameless)+1); + setlength(nameless[high(nameless)],valueLength); + move(valueStart^,nameless[high(nameless)][1],valueLength); + end else begin + setlength(propertyArray[currentProperty].strvalue,valueLength); + move(valueStart^,propertyArray[currentProperty].strvalue[1],valueLength); + try + case propertyArray[currentProperty].kind of + kpInt: propertyArray[currentProperty].intvalue:=StrToInt(propertyArray[currentProperty].strvalue); + kpFloat: propertyArray[currentProperty].floatvalue:=StrToFloat(propertyArray[currentProperty].strvalue); + kpFile: with propertyArray[currentProperty] do begin + while not FileExists(strvalue) do begin + while cmd^ = ' ' do inc(cmd); + while not (cmd^ in [' ',#0]) do inc(cmd); + valueLength:=longint(cmd-valueStart); + setlength(strvalue,valueLength); + move(valueStart^,strvalue[1],valueLength); + if cmd^ = #0 then exit; + end; + end; + end; + except + raiseError(); + end; + end; + end; + currentProperty:=-1; + end; + if cmd^<>#0 then inc(cmd) + else break; + + end; + parsed:=true; +end; + +function TCommandLineReader.findProperty(name:string):PProperty; +var i:integer; +begin + name:=lowercase(name); + for i:=0 to high(propertyArray) do + if propertyArray[i].name=name then begin + result:=@propertyArray[i]; + exit; + end; + raise ECommandLineParseException.Create('Property not found: '+name); +end; + +function TCommandLineReader.declareProperty(name,description,default:string;kind: TKindOfProperty):PProperty; +begin + SetLength(propertyArray,length(propertyArray)+1); + result:=@propertyArray[high(propertyArray)]; + result^.name:=lowercase(name); + result^.desc:=description; + result^.strvalue:=default; + result^.kind:=kind; +end; +procedure TCommandLineReader.declareFlag(const name,description:string;flagNameAbbreviation:char;default:boolean=false); +begin + with declareProperty(name,description,'',kpFlag)^ do begin + flagvalue:=default; + flagdefault:=default; + abbreviation:=flagNameAbbreviation; + end; +end; +procedure TCommandLineReader.declareFlag(const name,description:string;default:boolean=false); +begin + declareFlag(name,description,#0,default); +end; + +procedure TCommandLineReader.declareFile(const name,description:string;default:string=''); +begin + declareProperty(name,description,'',kpFile); +end; + +procedure TCommandLineReader.declareString(const name,description:string;value: string=''); +begin + declareProperty(name,description,value,kpStr); +end; +procedure TCommandLineReader.declareInt(const name,description:string;value: longint=0); +begin + declareProperty(name,description,IntToStr(value),kpInt)^.intvalue:=value; +end; +procedure TCommandLineReader.declareFloat(const name,description:string;value: extended=0); +begin + declareProperty(name,description,FloatToStr(value),kpFloat)^.floatvalue:=value; +end; + +function TCommandLineReader.readString(const name:string):string; +begin + if not parsed then parse; + result:=findProperty(name)^.strvalue; +end; +function TCommandLineReader.readInt(const name:string):longint; +var prop: PProperty; +begin + if not parsed then parse; + prop:=findProperty(name); + if prop^.kind<>kpInt then raise ECommandLineParseException.create('No integer property: '+name); + result:=prop^.intvalue; +end; +function TCommandLineReader.readFloat(const name:string):extended; +var prop: PProperty; +begin + if not parsed then parse; + prop:=findProperty(name); + if prop^.kind<>kpFloat then raise ECommandLineParseException.create('No extended property: '+name); + result:=prop^.Floatvalue; +end; +function TCommandLineReader.readFlag(const name:string):boolean; +var prop: PProperty; +begin + if not parsed then parse; + prop:=findProperty(name); + if prop^.kind<>kpFlag then raise ECommandLineParseException.create('No flag property: '+name); + result:=prop^.flagvalue; +end; + +function TCommandLineReader.existsProperty(const name:string):boolean; +begin + if not parsed then parse; + result:=findProperty(name)^.found; +end; + +function TCommandLineReader.readNamelessFiles():TStringArray; +begin + Result:=nameless; +end; +function TCommandLineReader.readNamelessString():TStringArray; +begin + result:=nameless; +end; +function TCommandLineReader.readNamelessInt():TLongintArray; +var i,p:integer; +begin + SetLength(result,length(nameless)); + p:=0; + for i:=0 to high(nameless) do + try + result[p]:=StrToInt(nameless[i]); + inc(p); + except + end; + SetLength(result,p); +end; +function TCommandLineReader.readNamelessFloat():TFloatArray; +var i,p:integer; +begin + SetLength(result,length(nameless)); + p:=0; + for i:=0 to high(nameless) do + try + result[p]:=StrToFloat(nameless[i]); + inc(p); + except + end; + SetLength(result,p); +end; +function TCommandLineReader.readNamelessFlag():TBooleanArray; +var i,p:integer; +begin + SetLength(result,length(nameless)); + p:=0; + for i:=0 to high(nameless) do begin + if lowercase(nameless[i])='true' then Result[p]:=true + else if lowercase(nameless[i])='false' then Result[p]:=false + else dec(p); + inc(p); + end; + SetLength(result,p); +end; + +initialization + CmdLineReader := TCommandLineReader.Create; + CmdLineReader.allowDOSStyle:=true; + CmdLineReader.automaticalShowError := True; + CmdLineReader.declareFlag('NEWINSTANCE','Start a new instance of PyScripter', 'N',False); + CmdLineReader.declareFlag('DPIAWARE','Make PyScripter DPI aware in VISTA', 'D',False); + CmdLineReader.declareFlag('PYTHON23','Use Python version 2.3',False); + CmdLineReader.declareFlag('PYTHON23','Use Python version 2.3',False); + CmdLineReader.declareFlag('PYTHON24','Use Python version 2.4',False); + CmdLineReader.declareFlag('PYTHON25','Use Python version 2.5',False); + CmdLineReader.declareFile('PYTHONDLLPATH','Use a specific Pythonxx.dll'); +finalization + CmdLineReader.free; +end. + diff --git a/uCommonFunctions.pas b/uCommonFunctions.pas index acf4f4ebb..5dc7bb6de 100644 --- a/uCommonFunctions.pas +++ b/uCommonFunctions.pas @@ -142,10 +142,15 @@ function SortedIdentToInt(const Ident: string; var Int: Longint; function ComparePythonIdents(const S1, S2 : string): Integer; overload; function ComparePythonIdents(List: TStringList; Index1, Index2: Integer): Integer; overload; -implementation +(* Used to get Vista fonts *) +procedure SetDefaultFonts(const AFont: TFont); +procedure SetDesktopIconFonts(const AFont: TFont); +procedure SetVistaContentFonts(const AFont: TFont); + + implementation Uses Controls, Forms, StdCtrls, ShellApi, JclFileUtils, Math, VarPyth, - JclStrings, JclBase, SynRegExpr, Consts, TntDialogs; + JclStrings, JclBase, SynRegExpr, Consts, TntDialogs, TntSysUtils; function GetIconIndexFromFile(const AFileName: string; const ASmall: boolean): integer; @@ -1005,7 +1010,7 @@ function SyncWideInputQuery(const ACaption, APrompt: WideString; var Value: Wide function CleanEOLs(S: string): string; begin - Result := AdjustLineBreaks(S, tlbsLF) + Result := AdjustLineBreaks(S, System.tlbsLF) end; function SortedIdentToInt(const Ident: string; var Int: Longint; @@ -1055,6 +1060,35 @@ function ComparePythonIdents(List: TStringList; Index1, Index2: Integer): Intege Result := ComparePythonIdents(S1, S2); end; +procedure SetDefaultFonts(const AFont: TFont); +begin + AFont.Handle := GetStockObject(DEFAULT_GUI_FONT); +end; + +procedure SetDesktopIconFonts(const AFont: TFont); +var + LogFont: TLogFont; +begin + if SystemParametersInfo(SPI_GETICONTITLELOGFONT, SizeOf(LogFont), + @LogFont, 0) then + AFont.Handle := CreateFontIndirect(LogFont) + else + SetDefaultFonts(AFont); +end; + +procedure SetVistaContentFonts(const AFont: TFont); +Const + VistaContentFont = 'Calibri'; +begin + if Win32PlatformIsVista + and not SameText(AFont.Name, VistaContentFont) + and (Screen.Fonts.IndexOf(VistaContentFont) >= 0) then + begin + AFont.Size := AFont.Size + 1; + AFont.Name := VistaContentFont; + end; +end; + initialization (* default is to return text without translation *) Translate:= NoTranslate; diff --git a/uDpiAware.pas b/uDpiAware.pas new file mode 100644 index 000000000..fc596f281 --- /dev/null +++ b/uDpiAware.pas @@ -0,0 +1,29 @@ +{----------------------------------------------------------------------------- + Unit Name: cPyBaseDebugger + Author: uDpiAware + Date: 23-Apr-2007 + Purpose: + History: Call SetProcessDPIAware at initialization. +-----------------------------------------------------------------------------} +unit uDpiAware; + +interface + +implementation +Uses + Windows, SysUtils, uCmdLine; +type + TSetProcessDPIAware = function(): BOOL; stdcall; +var + SetDPI: TSetProcessDPIAware; + User32Dll: THandle; + +initialization +if CmdLineReader.readFlag('DPIAWARE') and (Win32MajorVersion >= 6) then +begin + User32Dll := GetModuleHandle('user32.dll'); + SetDPI := GetProcAddress(User32Dll, 'SetProcessDPIAware'); + if Assigned(SetDPI) then SetDPI; +end; + +end. diff --git a/uEditAppIntfs.pas b/uEditAppIntfs.pas index 47702aa64..9eb2ddcd6 100644 --- a/uEditAppIntfs.pas +++ b/uEditAppIntfs.pas @@ -112,6 +112,7 @@ TBreakPoint = class(TPersistent) procedure SetFileEncoding(FileEncoding : TFileSaveFormat); procedure OpenFile(const AFileName: string; HighlighterName : string = ''); function HasPythonFile : Boolean; + procedure ExecuteSelection; property FileName : string read GetFileName; property FileTitle : string read GetFileTitle; property Modified : boolean read GetModified; @@ -163,11 +164,13 @@ TBreakPoint = class(TPersistent) function CanPrint: boolean; function CanSave: boolean; function CanSaveAs: boolean; + function CanReload: boolean; procedure ExecClose; procedure ExecPrint; procedure ExecPrintPreview; procedure ExecSave; procedure ExecSaveAs; + procedure ExecReload(Quiet : Boolean = False); end; ISearchCommands = interface