diff --git a/.gitattributes b/.gitattributes index 3af3af23d3..ab690b2aae 100644 --- a/.gitattributes +++ b/.gitattributes @@ -3072,8 +3072,11 @@ lcl/interfaces/cocoa/Makefile.fpc svneol=native#text/plain lcl/interfaces/fpgui/Makefile.fpc svneol=native#text/plain lcl/interfaces/fpgui/README.txt svneol=native#text/plain lcl/interfaces/fpgui/fpguiint.pp svneol=native#text/pascal +lcl/interfaces/fpgui/fpguilclintf.inc svneol=native#text/plain +lcl/interfaces/fpgui/fpguilclintfh.inc svneol=native#text/plain lcl/interfaces/fpgui/fpguiobject.inc svneol=native#text/pascal lcl/interfaces/fpgui/fpguiobjects.pas svneol=native#text/plain +lcl/interfaces/fpgui/fpguiproc.pas svneol=native#text/plain lcl/interfaces/fpgui/fpguiwinapi.inc svneol=native#text/plain lcl/interfaces/fpgui/fpguiwinapih.inc svneol=native#text/plain lcl/interfaces/fpgui/fpguiwsactnlist.pp svneol=native#text/pascal diff --git a/lcl/interfaces/fpgui/fpguiint.pp b/lcl/interfaces/fpgui/fpguiint.pp index 63cfb941c9..e18a8e742a 100644 --- a/lcl/interfaces/fpgui/fpguiint.pp +++ b/lcl/interfaces/fpgui/fpguiint.pp @@ -84,7 +84,7 @@ type function IsValidGDIObject(const GDIObject: HGDIOBJ): Boolean; virtual; public {$I fpguiwinapih.inc} - {.$I fpguilclintfh.inc} + {$I fpguilclintfh.inc} end; @@ -129,7 +129,7 @@ uses {$I fpguiobject.inc} {$I fpguiwinapi.inc} -{.$I fpguilclintf.inc} +{$I fpguilclintf.inc} {.$I fpguicallback.inc} diff --git a/lcl/interfaces/fpgui/fpguilclintf.inc b/lcl/interfaces/fpgui/fpguilclintf.inc new file mode 100644 index 0000000000..448e6e9235 --- /dev/null +++ b/lcl/interfaces/fpgui/fpguilclintf.inc @@ -0,0 +1,45 @@ +{%MainUnit fpguiint.pp} + +{****************************************************************************** + All FPGUI interface communication implementations. + Initial Revision : Sun Nov 23 23:53:53 2003 + + + !! Keep alphabetical !! + + Support routines go to gtkproc.pp + + ****************************************************************************** + Implementation + ****************************************************************************** + + ***************************************************************************** + * * + * This file is part of the Lazarus Component Library (LCL) * + * * + * See the file COPYING.modifiedLGPL, included in this distribution, * + * for details about the copyright. * + * * + * 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. * + * * + ***************************************************************************** +} + +//##apiwiz##sps## // Do not remove + +{------------------------------------------------------------------------------ + function FontCanUTF8(Font: HFont): boolean; + + True if font recognizes Unicode UTF8 encoding. + + FPGUI supports only Unicode + ------------------------------------------------------------------------------} +function TFpGuiWidgetSet.FontCanUTF8(Font: HFont): boolean; +begin + Result := True; +end; + +//##apiwiz##eps## // Do not remove, no wizard declaration after this line + diff --git a/lcl/interfaces/fpgui/fpguilclintfh.inc b/lcl/interfaces/fpgui/fpguilclintfh.inc new file mode 100644 index 0000000000..f50622596a --- /dev/null +++ b/lcl/interfaces/fpgui/fpguilclintfh.inc @@ -0,0 +1,68 @@ +{%MainUnit fpguiint.pp} + +{****************************************************************************** + All FPGUI interface communication implementations. + Initial Revision : Sun Nov 23 23:53:53 2003 + + + !! Keep alphabetical !! + + ****************************************************************************** + Interface + ****************************************************************************** + + ***************************************************************************** + * * + * This file is part of the Lazarus Component Library (LCL) * + * * + * See the file COPYING.modifiedLGPL, included in this distribution, * + * for details about the copyright. * + * * + * 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. * + * * + ***************************************************************************** +} + +//##apiwiz##sps## // Do not remove + +{function AddEventHandler(AHandle: THandle; AFlags: dword; + AEventHandler: TWaitHandleEvent; AData: PtrInt): PEventHandler; override; +function AddPipeEventHandler(AHandle: THandle; + AEventHandler: TPipeEvent; AData: PtrInt): PPipeEventHandler; override; +function AddProcessEventHandler(AHandle: THandle; + AEventHandler: TChildExitEvent; AData: PtrInt): PProcessEventHandler; override; +function AllocateHWnd(Method: TLCLWndMethod): HWND; override; + +function CreateStandardCursor(ACursor: SmallInt): hCursor; override; + +procedure DeallocateHWnd(Wnd: HWND); override; +procedure DrawArrow(Arrow: TComponent; Canvas: TPersistent); override; +procedure DrawDefaultDockImage(AOldRect, ANewRect: TRect; AOperation: TDockImageOperation); override; + +function ExtUTF8Out(DC: HDC; X, Y: Integer; Options: Longint; Rect: PRect; + Str: PChar; Count: Longint; Dx: PInteger): Boolean; override;} + +function FontCanUTF8(Font: HFont): boolean; override; + +{function GetAcceleratorString(const AVKey: Byte; const AShiftState: TShiftState): String; override; +function GetControlConstraints(Constraints: TObject): boolean; override; + +function IntfSendsUTF8KeyPress: boolean; override; + +function LoadStockPixmap(StockID: longint; var Mask: HBitmap) : HBitmap; override; + +function RawImage_CreateBitmaps(const ARawImage: TRawImage; out ABitmap, AMask: HBitmap; ASkipMask: Boolean = False): Boolean; override; +function RawImage_DescriptionFromBitmap(ABitmap: HBITMAP; out ADesc: TRawImageDescription): Boolean; override; +function RawImage_DescriptionFromDevice(ADC: HDC; out ADesc: TRawImageDescription): Boolean; override; +function RawImage_FromBitmap(out ARawImage: TRawImage; ABitmap, AMask: HBITMAP; const ARect: TRect): Boolean; override; +function RawImage_FromDevice(out ARawImage: TRawImage; ADC: HDC; const ARect: TRect): Boolean; override; + +procedure RemoveEventHandler(var AHandler: PEventHandler); override; +procedure RemovePipeEventHandler(var AHandler: PPipeEventHandler); override; +procedure RemoveProcessEventHandler(var AHandler: PProcessEventHandler); override;} + + +//##apiwiz##eps## // Do not remove, no wizard declaration after this line + diff --git a/lcl/interfaces/fpgui/fpguiproc.pas b/lcl/interfaces/fpgui/fpguiproc.pas new file mode 100644 index 0000000000..c80a24b22e --- /dev/null +++ b/lcl/interfaces/fpgui/fpguiproc.pas @@ -0,0 +1,56 @@ +{ + ***************************************************************************** + * FpGuiProc.pp * + * --------------- * + * * + * * + ***************************************************************************** + + ***************************************************************************** + * * + * This file is part of the Lazarus Component Library (LCL) * + * * + * See the file COPYING.LCL, included in this distribution, * + * for details about the copyright. * + * * + * 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. * + * * + ***************************************************************************** +} +unit fpguiproc; + +{$mode objfpc}{$H+} + +interface + +uses + Classes, SysUtils, gfxbase, Graphics; + +function TColorToTfpgColor(AColor: TColor): TfpgColor; + +implementation + +{ + Converts from TColor to TfpgColor + + TfpgColor = type longword; // Always in RRGGBB (Alpha, Red, Green, Blue) format!! +} +function TColorToTfpgColor(AColor: TColor): TfpgColor; +var + RGBColor: TColor; + RGBTriple: TRGBTriple; +begin + RGBColor := ColorToRGB(AColor); + + RGBTriple.Alpha := 0; + RGBTriple.Red := Graphics.Red(RGBColor); + RGBTriple.Green := Graphics.Green(RGBColor); + RGBTriple.Blue := Graphics.Blue(RGBColor); + + Result := RGBTripleTofpgColor(RGBTriple); +end; + +end. + diff --git a/lcl/interfaces/fpgui/fpguiwinapi.inc b/lcl/interfaces/fpgui/fpguiwinapi.inc index c5dd913615..f52080c93d 100644 --- a/lcl/interfaces/fpgui/fpguiwinapi.inc +++ b/lcl/interfaces/fpgui/fpguiwinapi.inc @@ -70,6 +70,74 @@ begin DC.Free; end; +function TFpGuiWidgetSet.ExtTextOut(DC: HDC; X, Y: Integer; Options: Longint; + Rect: PRect; Str: PChar; Count: Longint; Dx: PInteger): Boolean; +var + ADC: TFpGuiDeviceContext absolute DC; + AStr: string; +begin + AStr := string(Str); + + ADC.fpgCanvas.DrawText(X, Y, AStr, [txtLeft]); +end; + +function TFpGuiWidgetSet.GetSysColor(nIndex: Integer): DWORD; +begin + if (nIndex < 0) or (nIndex > MAX_SYS_COLORS) then + begin + {$ifdef VerboseFPGUIWinAPI} + WriteLn('Trace:Unknown lcl system color: [TFpGuiWidgetSet.GetSysColor]'); + {$endif} + exit; + end; + + case nIndex of +{ COLOR_SCROLLBAR : Result:=clGray; + COLOR_BACKGROUND : Result:=; + COLOR_ACTIVECAPTION : Result:=; + COLOR_INACTIVECAPTION : Result:=; + COLOR_MENU : Result:=;} + COLOR_WINDOW : Result:=clWhite; +{ COLOR_WINDOWFRAME : Result:=; + COLOR_MENUTEXT : Result:=; + COLOR_WINDOWTEXT : Result:=; + COLOR_CAPTIONTEXT : Result:=GetColor(QPaletteActive, QPaletteText); + COLOR_ACTIVEBORDER : Result:=GetColor(QPaletteActive, QPaletteWindow); + COLOR_INACTIVEBORDER : Result:=GetColor(QPaletteInactive, QPaletteWindow); + COLOR_APPWORKSPACE : Result:=GetColor(QPaletteActive, QPaletteWindow); + COLOR_HIGHLIGHT : Result:=GetColor(QPaletteActive, QPaletteHighlight); + COLOR_HIGHLIGHTTEXT : Result:=GetColor(QPaletteActive, QPaletteHighlightedText);} + COLOR_BTNFACE : Result:=clLtGray; +{ COLOR_BTNSHADOW : Result:=GetColor(QPaletteActive, QPaletteDark); + COLOR_GRAYTEXT : Result:=GetColor(QPaletteActive, QPaletteText); + COLOR_BTNTEXT : Result:=GetColor(QPaletteActive, QPaletteButtonText); + COLOR_INACTIVECAPTIONTEXT : Result:=GetColor(QPaletteInactive, QPaletteText); + COLOR_BTNHIGHLIGHT : Result:=GetColor(QPaletteActive, QPaletteLight); + COLOR_3DDKSHADOW : Result:=GetColor(QPaletteActive, QPaletteShadow); + COLOR_3DLIGHT : Result:=GetColor(QPaletteActive, QPaletteMidlight); + COLOR_INFOTEXT : Result:=GetClInfo(False); + COLOR_INFOBK : Result:=GetClInfo(True); + // PBD: 25 is unassigned in all the docs I can find + // if someone finds what this is supposed to be then fill it in + // note defaults below, and cl[ColorConst] in graphics + COLOR_HOTLIGHT : Result:=GetColor(QPaletteActive, QPaletteLight); + COLOR_GRADIENTACTIVECAPTION : Result:=GetColor(QPaletteActive, QPaletteHighlight); + COLOR_GRADIENTINACTIVECAPTION : Result:=GetColor(QPaletteInactive, QPaletteBase); + COLOR_FORM : Result:=GetColor(QPaletteActive, QPaletteWindow); + + COLOR_clForeground..COLOR_clHighlightedText + : Result:=GetColor(QPaletteActive, nIndex - COLOR_clForeground); + COLOR_clNormalForeground..COLOR_clNormalHighlightedText + : Result:=GetColor(QPaletteInactive, nIndex - COLOR_clNormalForeground); + COLOR_clDisabledForeground..COLOR_clDisabledHighlightedText + : Result:=GetColor(QPaletteDisabled, nIndex - COLOR_clDisabledForeground); + COLOR_clActiveForeground..COLOR_clActiveHighlightedText + : Result:=GetColor(QPaletteActive, nIndex - COLOR_clActiveForeground);} + else + Result:=0; + end; +end; + function TFpGuiWidgetSet.Rectangle(DC: HDC; X1, Y1, X2, Y2: Integer): Boolean; var ADC: TFpGuiDeviceContext absolute DC; diff --git a/lcl/interfaces/fpgui/fpguiwinapih.inc b/lcl/interfaces/fpgui/fpguiwinapih.inc index a2e832fdc3..94a0cacfcb 100644 --- a/lcl/interfaces/fpgui/fpguiwinapih.inc +++ b/lcl/interfaces/fpgui/fpguiwinapih.inc @@ -80,10 +80,10 @@ function EndPaint(Handle: hwnd; var PS: TPaintStruct): Integer; override; {procedure EnterCriticalSection(var CritSection: TCriticalSection); override; function EnumFontFamiliesEx(DC: HDC; lpLogFont: PLogFont; Callback: FontEnumExProc; Lparam: LParam; Flags: dword): longint; override; function ExcludeClipRect(dc: hdc; Left, Top, Right, Bottom : Integer) : Integer; override; -function ExtSelectClipRGN(dc: hdc; rgn : hrgn; Mode : Longint) : Integer; override; +function ExtSelectClipRGN(dc: hdc; rgn : hrgn; Mode : Longint) : Integer; override;} function ExtTextOut(DC: HDC; X, Y: Integer; Options: Longint; Rect: PRect; Str: PChar; Count: Longint; Dx: PInteger): Boolean; override; -function FillRect(DC: HDC; const Rect: TRect; Brush: HBRUSH): Boolean; override; +{function FillRect(DC: HDC; const Rect: TRect; Brush: HBRUSH): Boolean; override; function FillRgn(DC: HDC; RegionHnd: HRGN; hbr: HBRUSH): Bool; override; function Frame(DC: HDC; const ARect: TRect): Integer; override; function Frame3d(DC: HDC; var ARect: TRect; const FrameWidth : integer; const Style : TBevelCut): Boolean; override; @@ -114,9 +114,9 @@ function GetROP2(DC: HDC): Integer; override; function GetScrollBarSize(Handle: HWND; BarKind: Integer): integer; override; function GetScrollbarVisible(Handle: HWND; SBStyle: Integer): boolean; override; function GetScrollInfo(Handle: HWND; BarFlag: Integer; Var ScrollInfo: TScrollInfo): Boolean; override; -function GetStockObject(Value: Integer): THandle; override; +function GetStockObject(Value: Integer): THandle; override;} function GetSysColor(nIndex: Integer): DWORD; override; -function GetSystemMetrics(nIndex: Integer): Integer; override; +{function GetSystemMetrics(nIndex: Integer): Integer; override; function GetTextColor(DC: HDC) : TColorRef; Override; function GetTextExtentPoint(DC: HDC; Str: PChar; Count: Integer; var Size: TSize): Boolean; override; function GetTextMetrics(DC: HDC; var TM: TTextMetric): Boolean; override; diff --git a/lcl/interfaces/fpgui/fpguiwscontrols.pp b/lcl/interfaces/fpgui/fpguiwscontrols.pp index d5b750d472..40f63a8f1d 100644 --- a/lcl/interfaces/fpgui/fpguiwscontrols.pp +++ b/lcl/interfaces/fpgui/fpguiwscontrols.pp @@ -32,7 +32,7 @@ uses // LCL Controls, LCLType, // Widgetset - WSControls, WSLCLClasses; + fpguiproc, WSControls, WSLCLClasses; type @@ -67,7 +67,7 @@ type class procedure SetPos(const AWinControl: TWinControl; const ALeft, ATop: Integer); override; class procedure SetSize(const AWinControl: TWinControl; const AWidth, AHeight: Integer); override; class procedure ShowHide(const AWinControl: TWinControl); override; //TODO: rename to SetVisible(control, visible) -// class procedure SetColor(const AWinControl: TWinControl); override; + class procedure SetColor(const AWinControl: TWinControl); override; class procedure SetCursor(const AWinControl: TWinControl; const ACursor: HCursor); override; { class function GetText(const AWinControl: TWinControl; var AText: String): Boolean; override; @@ -138,9 +138,9 @@ end; ------------------------------------------------------------------------------} class procedure TFpGuiWSWinControl.DestroyHandle(const AWinControl: TWinControl); begin -// TFPGUIPrivateWidget(AWinControl.Handle).Free; + TFPGUIPrivateWidget(AWinControl.Handle).Free; -// AWinControl.Handle := 0; + AWinControl.Handle := 0; end; {------------------------------------------------------------------------------ @@ -223,6 +223,14 @@ begin FPWidget.Visible := not FPWidget.Visible; end; +class procedure TFpGuiWSWinControl.SetColor(const AWinControl: TWinControl); +var + FPWidget: TfpgWidget; +begin + FPWidget := TFPGUIPrivateWidget(AWinControl.Handle).Widget; + FPWidget.BackgroundColor := TColorToTfpgColor(AWinControl.Color); +end; + {------------------------------------------------------------------------------ Method: TFpGuiWSWinControl.SetCursor Params: AWinControl - the calling object diff --git a/lcl/interfaces/fpgui/fpguiwsforms.pp b/lcl/interfaces/fpgui/fpguiwsforms.pp index e22f641446..2f869a456c 100644 --- a/lcl/interfaces/fpgui/fpguiwsforms.pp +++ b/lcl/interfaces/fpgui/fpguiwsforms.pp @@ -146,15 +146,14 @@ end; Returns: Nothing ------------------------------------------------------------------------------} class procedure TFpGuiWSCustomForm.DestroyHandle(const AWinControl: TWinControl); -var - FPForm: TFPGUIPrivateWindow; begin {$ifdef VerboseFPGUIIntf} WriteLn('TFpGuiWSCustomForm.DestroyHandle'); {$endif} - FPForm := TFPGUIPrivateWindow(AWinControl.Handle); - FPForm.Free; + TFPGUIPrivateWindow(AWinControl.Handle).Free; + + AWinControl.Handle := 0; end; {------------------------------------------------------------------------------ diff --git a/lcl/interfaces/fpgui/fpguiwsprivate.pp b/lcl/interfaces/fpgui/fpguiwsprivate.pp index 86efee0fb1..f5b457b73c 100644 --- a/lcl/interfaces/fpgui/fpguiwsprivate.pp +++ b/lcl/interfaces/fpgui/fpguiwsprivate.pp @@ -120,6 +120,7 @@ type private { Event Handlers } procedure PaintHandler(Sender: TObject{; const ARect: TfpgRect}); + procedure CloseHandler(Sender: TObject; var CloseAction: TCloseAction); protected public { Constructors / Destructors } @@ -291,7 +292,7 @@ end; destructor TFPGUIPrivateWidget.Destroy; begin - FreeAndNil(Widget); + if (Widget <> nil) then FreeAndNil(Widget); inherited Destroy; end; @@ -409,6 +410,12 @@ begin end; end; +procedure TFPGUIPrivateWindow.CloseHandler(Sender: TObject; + var CloseAction: TCloseAction); +begin + CloseAction := caFree; +end; + {------------------------------------------------------------------------------ Method: TFPGUIPrivateWindow.Create Params: None @@ -428,9 +435,10 @@ end; ------------------------------------------------------------------------------} procedure TFPGUIPrivateWindow.CreateWidget(const AParams: TCreateParams); begin -{$IFDEF VerboseFPGUIPrivate} - WriteLn('[TFPGUIPrivateWindow.CreateWidget]'); -{$ENDIF} + {$IFDEF VerboseFPGUIPrivate} + WriteLn('[TFPGUIPrivateWindow.CreateWidget]'); + {$ENDIF} + Widget := TfpgForm.Create(nil); Form.SetPosition(AParams.X, AParams.Y, AParams.Width, AParams.Height); end; @@ -445,6 +453,7 @@ begin inherited SetEvents; Form.OnPaint := PaintHandler; + Form.OnClose := CloseHandler; end; {------------------------------------------------------------------------------ @@ -458,6 +467,15 @@ begin WriteLn('[TFPGUIPrivateWindow.Destroy]'); {$ENDIF} + // Instead of destroying the form immediately, we call Close + // and set CloseAction to caFree in OnClose, + // which will do a delayed close + Form.Close; + + // By setting the Widget to nil we prevent it's future + // destruction + Widget := nil; + inherited Destroy; end;