paweld/lazarus
1
0
Fork 0
mirror of https://gitlab.com/freepascal.org/lazarus/lazarus.git synced 2025-09-12 10:59:20 +02:00
Code Issues Packages Projects Releases Wiki Activity

Various improvements to fpgui

Browse Source 
git-svn-id: trunk@15025 -
This commit is contained in:
sekelsenmat 2008-05-01 15:54:53 +00:00
parent c04f23e310
commit 1736824df9
10 changed files with 283 additions and 18 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

3
.gitattributes vendored
View File

@ -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

4
lcl/interfaces/fpgui/fpguiint.pp
View File

@ -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}

45
lcl/interfaces/fpgui/fpguilclintf.inc Normal file
View File

@ -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

68
lcl/interfaces/fpgui/fpguilclintfh.inc Normal file
View File

@ -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

56
lcl/interfaces/fpgui/fpguiproc.pas Normal file
View File

@ -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.

68
lcl/interfaces/fpgui/fpguiwinapi.inc
View File

@ -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;

8
lcl/interfaces/fpgui/fpguiwinapih.inc
View File

@ -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;

16
lcl/interfaces/fpgui/fpguiwscontrols.pp
View File

@ -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

7
lcl/interfaces/fpgui/fpguiwsforms.pp
View File

@ -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;
{------------------------------------------------------------------------------

26
lcl/interfaces/fpgui/fpguiwsprivate.pp
View File

@ -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;