~ubuntu-branches/ubuntu/saucy/lazarus/saucy

« back to all changes in this revision

Viewing changes to lcl/graphics.pp

  • Committer: Package Import Robot
  • Author(s): Paul Gevers, Abou Al Montacir, Bart Martens, Paul Gevers
  • Date: 2013-06-08 14:12:17 UTC
  • mfrom: (1.1.9)
  • Revision ID: package-import@ubuntu.com-20130608141217-7k0cy9id8ifcnutc
Tags: 1.0.8+dfsg-1
[ Abou Al Montacir ]
* New upstream major release and multiple maintenace release offering many
  fixes and new features marking a new milestone for the Lazarus development
  and its stability level.
  - The detailed list of changes can be found here:
    http://wiki.lazarus.freepascal.org/Lazarus_1.0_release_notes
    http://wiki.lazarus.freepascal.org/Lazarus_1.0_fixes_branch
* LCL changes:
  - LCL is now a normal package.
      + Platform independent parts of the LCL are now in the package LCLBase
      + LCL is automatically recompiled when switching the target platform,
        unless pre-compiled binaries for this target are already installed.
      + No impact on existing projects.
      + Linker options needed by LCL are no more added to projects that do
        not use the LCL package.
  - Minor changes in LCL basic classes behaviour
      + TCustomForm.Create raises an exception if a form resource is not
        found.
      + TNotebook and TPage: a new implementation of these classes was added.
      + TDBNavigator: It is now possible to have focusable buttons by setting
        Options = [navFocusableButtons] and TabStop = True, useful for
        accessibility and for devices with neither mouse nor touch screen.
      + Names of TControlBorderSpacing.GetSideSpace and GetSpace were swapped
        and are now consistent. GetSideSpace = Around + GetSpace.
      + TForm.WindowState=wsFullscreen was added
      + TCanvas.TextFitInfo was added to calculate how many characters will
        fit into a specified Width. Useful for word-wrapping calculations.
      + TControl.GetColorResolvingParent and
        TControl.GetRGBColorResolvingParent were added, simplifying the work
        to obtain the final color of the control while resolving clDefault
        and the ParentColor.
      + LCLIntf.GetTextExtentExPoint now has a good default implementation
        which works in any platform not providing a specific implementation.
        However, Widgetset specific implementation is better, when available.
      + TTabControl was reorganized. Now it has the correct class hierarchy
        and inherits from TCustomTabControl as it should.
  - New unit in the LCL:
      + lazdialogs.pas: adds non-native versions of various native dialogs,
        for example TLazOpenDialog, TLazSaveDialog, TLazSelectDirectoryDialog.
        It is used by widgetsets which either do not have a native dialog, or
        do not wish to use it because it is limited. These dialogs can also be
        used by user applications directly.
      + lazdeviceapis.pas: offers an interface to more hardware devices such
        as the accelerometer, GPS, etc. See LazDeviceAPIs
      + lazcanvas.pas: provides a TFPImageCanvas descendent implementing
        drawing in a LCL-compatible way, but 100% in Pascal.
      + lazregions.pas. LazRegions is a wholly Pascal implementation of
        regions for canvas clipping, event clipping, finding in which control
        of a region tree one an event should reach, for drawing polygons, etc.
      + customdrawncontrols.pas, customdrawndrawers.pas,
        customdrawn_common.pas, customdrawn_android.pas and
        customdrawn_winxp.pas: are the Lazarus Custom Drawn Controls -controls
        which imitate the standard LCL ones, but with the difference that they
        are non-native and support skinning.
  - New APIs added to the LCL to improve support of accessibility software
    such as screen readers.
* IDE changes:
  - Many improvments.
  - The detailed list of changes can be found here:
    http://wiki.lazarus.freepascal.org/New_IDE_features_since#v1.0_.282012-08-29.29
    http://wiki.lazarus.freepascal.org/Lazarus_1.0_release_notes#IDE_Changes
* Debugger / Editor changes:
  - Added pascal sources and breakpoints to the disassembler
  - Added threads dialog.
* Components changes:
  - TAChart: many fixes and new features
  - CodeTool: support Delphi style generics and new syntax extensions.
  - AggPas: removed to honor free licencing. (Closes: Bug#708695)
[Bart Martens]
* New debian/watch file fixing issues with upstream RC release.
[Abou Al Montacir]
* Avoid changing files in .pc hidden directory, these are used by quilt for
  internal purpose and could lead to surprises during build.
[Paul Gevers]
* Updated get-orig-source target and it compinion script orig-tar.sh so that they
  repack the source file, allowing bug 708695 to be fixed.

Show diffs side-by-side

added added

removed removed

Lines of Context:
1
 
{  $Id: graphics.pp 28343 2010-11-19 10:46:12Z paul $  }
 
1
{  $Id: graphics.pp 37764 2012-06-24 17:31:53Z martin $  }
2
2
{
3
3
 /***************************************************************************
4
4
                                graphics.pp
32
32
{$ASSERTIONS ON}
33
33
{$endif}
34
34
 
 
35
{$IF FPC_FULLVERSION>=20601}
 
36
{$DEFINE HasFPCanvas1}
 
37
{$ENDIF}
 
38
 
35
39
uses
36
 
  SysUtils, Math, Types, Classes, FPCAdds, LCLversion,
 
40
  SysUtils, Math, Types, Classes, Contnrs, FPCAdds, LCLversion,
37
41
  FileUtil,
38
42
  FPImage, FPCanvas,
39
43
  FPWriteBMP,              // bmp support
44
48
  FPReadGif,
45
49
  IntfGraphics,
46
50
  AvgLvlTree,
47
 
  LCLStrConsts, LCLType, LCLProc, LMessages, LCLIntf, LResources, LCLResCache,
48
 
  GraphType, IcnsTypes, GraphMath, InterfaceBase, WSReferences;
 
51
  LCLStrConsts, LCLType, LCLProc, LMessages, LResources, LCLResCache,
 
52
  GraphType, IcnsTypes, GraphMath, WSReferences;
49
53
 
50
54
type
51
55
  PColor = ^TColor;
111
115
                             //    too fit between left and right boundaries
112
116
                             //    try to break into multiple lines between
113
117
                             //    words
 
118
                             //    See also EndEllipsis.
114
119
 
115
120
    Opaque    : boolean;     // TextRect: Fills background with current Brush
116
121
                             // TextOut : Fills background with current
119
124
    SystemFont: Boolean;     // Use the system font instead of Canvas Font
120
125
    
121
126
    RightToLeft: Boolean;    //For RightToLeft text reading (Text Direction)
 
127
 
 
128
    EndEllipsis: Boolean;    // TextRect Only: If line of text is too long
 
129
                             //    to fit between left and right boundaries
 
130
                             //    truncates the text and adds "..."
 
131
                             //    If Wordbreak is set as well, Workbreak will
 
132
                             //    dominate.
122
133
  end;
123
134
 
124
135
const
302
313
  clMenuBar                 = TColor(SYS_COLOR_BASE or COLOR_MENUBAR);
303
314
  clForm                    = TColor(SYS_COLOR_BASE or COLOR_FORM);
304
315
 
305
 
  // synonims: do not show them in color lists
 
316
  // synonyms: do not show them in color lists
306
317
  clColorDesktop            = TColor(SYS_COLOR_BASE or COLOR_DESKTOP);
307
318
  cl3DFace                  = TColor(SYS_COLOR_BASE or COLOR_3DFACE);
308
319
  cl3DShadow                = TColor(SYS_COLOR_BASE or COLOR_3DSHADOW);
522
533
    procedure SetFPColor(const AValue: TFPColor); override;
523
534
    procedure SetHeight(Avalue: Integer);
524
535
    procedure SetName(AValue: string); override;
525
 
    procedure SetOrientation(AValue: Integer);
 
536
    procedure SetOrientation(AValue: Integer);{$IFNDEF VER2_4}{$IFNDEF VER2_5}override;{$ENDIF}{$ENDIF}// This was introduced in 2.5 quite late, and the Android pre-compiled compiler was before this, so I prefer to let it only for 2.6
526
537
    procedure SetPitch(Value: TFontPitch);
527
538
    procedure SetSize(AValue: integer); override;
528
539
    procedure SetStyle(Value: TFontStyles);
541
552
    function IsEqual(AFont: TFont): boolean; virtual;
542
553
    property IsMonoSpace: boolean read GetIsMonoSpace;
543
554
    procedure SetDefault;
544
 
    property CanUTF8: boolean read GetCanUTF8;
 
555
    property CanUTF8: boolean read GetCanUTF8; deprecated;
545
556
    property PixelsPerInch: Integer read FPixelsPerInch write FPixelsPerInch;
546
557
    property Reference: TWSFontReference read GetReference;
547
558
  published
685
696
    constructor Create; override;
686
697
    destructor Destroy; override;
687
698
    property Bitmap: TCustomBitmap read FBitmap write SetBitmap;
688
 
    property Handle: HBRUSH read GetHandle write SetHandle; deprecated;
 
699
    property Handle: HBRUSH read GetHandle write SetHandle; deprecated; // use instead Reference.Handle
689
700
    property Reference: TWSBrushReference read GetReference;
690
701
  published
691
702
    property Color: TColor read FColor write SetColor default clWhite;
692
703
    property Style default bsSolid;
693
704
  end;
694
705
 
 
706
  TRegionCombineMode = (rgnAnd, rgnCopy, rgnDiff, rgnOr, rgnXOR);
 
707
 
 
708
  TRegionOperationType = (rgnNewRect, rgnCombine);
 
709
 
 
710
  TRegionOperation = record
 
711
    ROType: TRegionOperationType;
 
712
    Source1, Source2, Dest: Integer; // Index to the list of sub-regions, -1 indicates the main region
 
713
    CombineMode: TRegionCombineMode; // Used only if ROType=rgnCombine
 
714
    Rect: TRect; // Used for ROType=rgnNewRect
 
715
  end;
 
716
 
 
717
  TRegionOperations = array of TRegionOperation;
695
718
 
696
719
  { TRegion }
697
720
 
698
 
  TRegionData = record
699
 
    Reference: TWSRegionReference;
700
 
    Rect: TRect;
701
 
    {Polygon Region Info - not used yet}
702
 
    Polygon: PPoint;    //Polygon Points
703
 
    NumPoints: Longint; //Number of Points
704
 
    Winding: Boolean;   //Use Winding mode
705
 
  end;
706
 
 
707
721
  TRegion = class(TGraphicsObject)
708
722
  private
709
 
    FRegionData: TRegionData;
 
723
    FReference: TWSRegionReference;
 
724
    // Description of the region
 
725
    RegionOperations: TRegionOperations;
 
726
    SubRegions: array of HRGN;
 
727
    procedure AddOperation(AOp: TRegionOperation);
 
728
    procedure ClearSubRegions();
 
729
    procedure AddSubRegion(AHandle: HRGN);
 
730
    //
710
731
    procedure FreeReference;
711
732
    function GetReference: TWSRegionReference;
712
733
    function GetHandle: HRGN;
720
741
    destructor Destroy; override;
721
742
    procedure Assign(Source: TPersistent); override;
722
743
 
 
744
    // Convenience routines to add elements to the region
 
745
    procedure AddRectangle(X1, Y1, X2, Y2: Integer);
 
746
 
723
747
    property ClipRect: TRect read GetClipRect write SetClipRect;
724
748
    property Handle: HRGN read GetHandle write SetHandle; deprecated;
725
749
    property Reference: TWSRegionReference read GetReference;
1051
1075
  protected
1052
1076
    function GetClipRect: TRect; override;
1053
1077
    procedure SetClipRect(const ARect: TRect); override;
1054
 
    function GetClipping: Boolean; {$ifndef ver2_2}override;{$endif}
1055
 
    procedure SetClipping(const AValue: boolean); {$ifndef ver2_2}override;{$endif}
 
1078
    function GetClipping: Boolean; override;
 
1079
    procedure SetClipping(const AValue: boolean); override;
1056
1080
    function GetPixel(X,Y: Integer): TColor; virtual;
1057
1081
    procedure CreateBrush; virtual;
1058
1082
    procedure CreateFont; virtual;
1084
1108
    procedure RestoreHandleState; virtual;
1085
1109
 
1086
1110
    // extra drawing methods (there are more in the ancestor TFPCustomCanvas)
1087
 
    procedure Arc(ALeft, ATop, ARight, ABottom, Angle16Deg, Angle16DegLength: Integer); virtual;
1088
 
    procedure Arc(ALeft, ATop, ARight, ABottom, SX, SY, EX, EY: Integer); virtual;
1089
 
    //procedure BrushCopy(Dest: TRect; InternalImages: TBitmap; Src: TRect;
1090
 
    //                    TransparentColor: TColor); virtual;
 
1111
    procedure Arc(ALeft, ATop, ARight, ABottom, Angle16Deg, Angle16DegLength: Integer); virtual; {$IFDEF HasFPCanvas1}reintroduce;{$ENDIF}
 
1112
    procedure Arc(ALeft, ATop, ARight, ABottom, SX, SY, EX, EY: Integer); virtual; {$IFDEF HasFPCanvas1}reintroduce;{$ENDIF}
 
1113
    procedure BrushCopy(ADestRect: TRect; ABitmap: TBitmap; ASourceRect: TRect;
 
1114
                        ATransparentColor: TColor); virtual;
1091
1115
    procedure Chord(x1, y1, x2, y2,
1092
 
                    Angle16Deg, Angle16DegLength: Integer); virtual;
1093
 
    procedure Chord(x1, y1, x2, y2, SX, SY, EX, EY: Integer); virtual;
 
1116
                    Angle16Deg, Angle16DegLength: Integer); virtual; {$IFDEF HasFPCanvas1}reintroduce;{$ENDIF}
 
1117
    procedure Chord(x1, y1, x2, y2, SX, SY, EX, EY: Integer); virtual; {$IFDEF HasFPCanvas1}reintroduce;{$ENDIF}
1094
1118
    procedure CopyRect(const Dest: TRect; SrcCanvas: TCanvas;
1095
1119
                       const Source: TRect); virtual;
1096
1120
    procedure Draw(X,Y: Integer; SrcGraphic: TGraphic); virtual;
1097
1121
    procedure DrawFocusRect(const ARect: TRect); virtual;
1098
1122
    procedure StretchDraw(const DestRect: TRect; SrcGraphic: TGraphic); virtual;
1099
 
    procedure Ellipse(const ARect: TRect); // already in fpcanvas
1100
 
    procedure Ellipse(x1, y1, x2, y2: Integer); virtual; // already in fpcanvas
1101
 
    procedure FillRect(const ARect: TRect); virtual;
1102
 
    procedure FillRect(X1,Y1,X2,Y2: Integer);
 
1123
    procedure Ellipse(const ARect: TRect); {$IFDEF HasFPCanvas1}reintroduce;{$ENDIF}
 
1124
    procedure Ellipse(x1, y1, x2, y2: Integer); virtual; {$IFDEF HasFPCanvas1}reintroduce;{$ENDIF}
 
1125
    procedure FillRect(const ARect: TRect); virtual; {$IFDEF HasFPCanvas1}reintroduce;{$ENDIF}
 
1126
    procedure FillRect(X1,Y1,X2,Y2: Integer); {$IFDEF HasFPCanvas1}reintroduce;{$ENDIF}
1103
1127
    procedure FloodFill(X, Y: Integer; FillColor: TColor;
1104
 
                        FillStyle: TFillStyle); virtual;
 
1128
                        FillStyle: TFillStyle); virtual; {$IFDEF HasFPCanvas1}reintroduce;{$ENDIF}
1105
1129
    procedure Frame3d(var ARect: TRect; const FrameWidth: integer;
1106
1130
                      const Style: TGraphicsBevelCut); virtual;
 
1131
    procedure Frame3D(var ARect: TRect; TopColor, BottomColor: TColor;
 
1132
                      const FrameWidth: integer); overload;
1107
1133
    procedure Frame(const ARect: TRect); virtual; // border using pen
1108
1134
    procedure Frame(X1,Y1,X2,Y2: Integer);     // border using pen
1109
1135
    procedure FrameRect(const ARect: TRect); virtual; // border using brush
1111
1137
    function  GetTextMetrics(out TM: TLCLTextMetric): boolean; virtual;
1112
1138
    procedure GradientFill(ARect: TRect; AStart, AStop: TColor; ADirection: TGradientDirection);
1113
1139
    procedure RadialPie(x1, y1, x2, y2,
1114
 
                        StartAngle16Deg, Angle16DegLength: Integer); virtual;
 
1140
                        StartAngle16Deg, Angle16DegLength: Integer); virtual; {$IFDEF HasFPCanvas1}reintroduce;{$ENDIF}
1115
1141
    procedure Pie(EllipseX1,EllipseY1,EllipseX2,EllipseY2,
1116
1142
                  StartX,StartY,EndX,EndY: Integer); virtual;
1117
1143
    procedure PolyBezier(Points: PPoint; NumPts: Integer;
1118
1144
                         Filled: boolean = False;
1119
 
                         Continuous: boolean = False); virtual;
 
1145
                         Continuous: boolean = False); virtual; {$IFDEF HasFPCanvas1}reintroduce;{$ENDIF}
1120
1146
    procedure PolyBezier(const Points: array of TPoint;
1121
1147
                         Filled: boolean = False;
1122
 
                         Continuous: boolean = False);
 
1148
                         Continuous: boolean = False); {$IFDEF HasFPCanvas1}reintroduce;{$ENDIF}
1123
1149
    procedure Polygon(const Points: array of TPoint;
1124
1150
                      Winding: Boolean;
1125
1151
                      StartIndex: Integer = 0;
1126
1152
                      NumPts: Integer = -1);
1127
1153
    procedure Polygon(Points: PPoint; NumPts: Integer;
1128
1154
                      Winding: boolean = False); virtual;
1129
 
    procedure Polygon(const Points: array of TPoint); // already in fpcanvas
 
1155
    procedure Polygon(const Points: array of TPoint); {$IFDEF HasFPCanvas1}reintroduce;{$ENDIF}
1130
1156
    procedure Polyline(const Points: array of TPoint;
1131
1157
                       StartIndex: Integer;
1132
1158
                       NumPts: Integer = -1);
1133
1159
    procedure Polyline(Points: PPoint; NumPts: Integer); virtual;
1134
 
    procedure Polyline(const Points: array of TPoint); // already in fpcanvas
1135
 
    procedure Rectangle(X1,Y1,X2,Y2: Integer); virtual; // already in fpcanvas
1136
 
    procedure Rectangle(const ARect: TRect); // already in fpcanvas
 
1160
    procedure Polyline(const Points: array of TPoint); {$IFDEF HasFPCanvas1}reintroduce;{$ENDIF}
 
1161
    procedure Rectangle(X1,Y1,X2,Y2: Integer); virtual; {$IFDEF HasFPCanvas1}reintroduce;{$ENDIF}
 
1162
    procedure Rectangle(const ARect: TRect); {$IFDEF HasFPCanvas1}reintroduce;{$ENDIF}
1137
1163
    procedure RoundRect(X1, Y1, X2, Y2: Integer; RX,RY: Integer); virtual;
1138
1164
    procedure RoundRect(const Rect: TRect; RX,RY: Integer);
1139
 
    procedure TextOut(X,Y: Integer; const Text: String); virtual; // already in fpcanvas
 
1165
    procedure TextOut(X,Y: Integer; const Text: String); virtual; {$IFDEF HasFPCanvas1}reintroduce;{$ENDIF}
1140
1166
    procedure TextRect(const ARect: TRect; X, Y: integer; const Text: string);
1141
1167
    procedure TextRect(ARect: TRect; X, Y: integer; const Text: string;
1142
1168
                       const Style: TTextStyle); virtual;
1143
 
    function TextExtent(const Text: string): TSize; virtual;
1144
 
    function TextHeight(const Text: string): Integer; virtual;
1145
 
    function TextWidth(const Text: string): Integer; virtual;
 
1169
    function TextExtent(const Text: string): TSize; virtual; {$IFDEF HasFPCanvas1}reintroduce;{$ENDIF}
 
1170
    function TextHeight(const Text: string): Integer; virtual; {$IFDEF HasFPCanvas1}reintroduce;{$ENDIF}
 
1171
    function TextWidth(const Text: string): Integer; virtual; {$IFDEF HasFPCanvas1}reintroduce;{$ENDIF}
 
1172
    function TextFitInfo(const Text: string; MaxWidth: Integer): Integer;
1146
1173
    function HandleAllocated: boolean; virtual;
1147
1174
    function GetUpdatedHandle(ReqState: TCanvasState): HDC; virtual;
1148
1175
  public
1217
1244
 
1218
1245
  { TRasterImage }
1219
1246
 
1220
 
  { TCustomBitmap is the data of an image. The image can be loaded from a file,
1221
 
    stream or resource in .bmp (windows bitmap format) or .xpm (XPixMap format)
1222
 
    The loading routine automatically recognizes the format, so it is also used
1223
 
    to load the imagess from Delphi form streams (e.g. .dfm files).
1224
 
    When the handle is created, it is up to the interface (gtk, win32, ...)
1225
 
    to convert it automatically to the best internal format. That is why the
1226
 
    Handle is interface dependent.
1227
 
    To access the raw data, see TLazIntfImage in IntfGraphics.pas }
1228
 
 
1229
 
  { TRasterImage }
1230
 
 
1231
1247
  TRasterImage = class(TGraphic)
1232
1248
  private
1233
1249
    FCanvas: TCanvas;
1297
1313
    procedure Clear; override;
1298
1314
    procedure BeginUpdate(ACanvasOnly: Boolean = False);
1299
1315
    procedure EndUpdate(AStreamIsValid: Boolean = False);
1300
 
    procedure FreeImage;
 
1316
    procedure FreeImage; virtual;
1301
1317
    function BitmapHandleAllocated: boolean; virtual; abstract;
1302
1318
    function MaskHandleAllocated: boolean; virtual; abstract;
1303
1319
    function PaletteAllocated: boolean; virtual; abstract;
1358
1374
    property Width: Integer read GetWidth;
1359
1375
  end;
1360
1376
 
1361
 
  { TCustomBitmap }
1362
 
  
 
1377
  { TCustomBitmap
 
1378
    is the data of an image. The image can be loaded from a file,
 
1379
    stream or resource in .bmp (windows bitmap format) or .xpm (XPixMap format)
 
1380
    The loading routine automatically recognizes the format, so it is also used
 
1381
    to load the imagess from Delphi form streams (e.g. .dfm files).
 
1382
    When the handle is created, it is up to the interface (gtk, win32, ...)
 
1383
    to convert it automatically to the best internal format. That is why the
 
1384
    Handle is interface dependent.
 
1385
    To access the raw data, see TLazIntfImage in IntfGraphics.pas }
 
1386
 
1363
1387
  TCustomBitmap = class(TRasterImage)
1364
1388
  private
1365
1389
    FPixelFormat: TPixelFormat;
1396
1420
  public
1397
1421
    constructor Create; override;
1398
1422
    destructor Destroy; override;
1399
 
 
 
1423
    procedure Assign(Source: TPersistent); override;
1400
1424
    procedure Clear; override;
 
1425
    procedure FreeImage; override;
1401
1426
    function GetResourceType: TResourceType; override;
1402
1427
    function LazarusResourceTypeValid(const ResourceType: string): Boolean; override;
1403
1428
    function BitmapHandleAllocated: boolean; override;
1524
1549
    procedure FreeHandle; override;
1525
1550
    procedure UpdateFromHandle(NewHandle: THandle); virtual;
1526
1551
    function IsEmpty: boolean; override;
 
1552
    function GetImage(const AIndex: Integer): TIconImage;
1527
1553
  public
1528
1554
    constructor Create; override;
1529
1555
    destructor Destroy; override;
1530
1556
    procedure Clear;
1531
 
    procedure Delete(Aindex: Integer);
 
1557
    procedure Delete(AIndex: Integer);
1532
1558
    function GetIndex(AFormat: TPixelFormat; AHeight, AWidth: Word): Integer;
1533
1559
    class function GetImagesClass: TIconImageClass; virtual;
1534
1560
    procedure Add(AIconImage: TIconImage);
1535
1561
    function Count: Integer;
 
1562
    property Images[AIndex: Integer]: TIconImage read GetImage;
1536
1563
  end;
1537
1564
 
1538
1565
  { TIconImage }
1567
1594
    property Handle: HBITMAP read FHandle;
1568
1595
    property MaskHandle: HBITMAP read FMaskHandle;
1569
1596
    property Palette: HPALETTE read GetPalette;
 
1597
    property RawImage: TRawImage read FImage;
1570
1598
  end;
1571
1599
 
1572
1600
 
1597
1625
    function GetIndex(AFormat: TPixelFormat; AHeight, AWidth: Word): Integer;
1598
1626
    function GetBitmapHandle: HBITMAP; override;
1599
1627
    class function GetDefaultSize: TSize; virtual;
1600
 
    function GetMasked: Boolean; override;
1601
1628
    function GetMaskHandle: HBITMAP; override;
1602
1629
    function GetPalette: HPALETTE; override;
1603
1630
    function GetPixelFormat: TPixelFormat; override;
1604
1631
    function GetRawImagePtr: PRawImage; override;
1605
1632
    function GetRawImageDescriptionPtr: PRawImageDescription; override;
1606
1633
    function GetTransparent: Boolean; override;
 
1634
    class function GetSharedImageClass: TSharedRasterImageClass; override;
 
1635
    class function GetStreamSignature: Cardinal; virtual;
1607
1636
    class function GetTypeID: Word; virtual;
1608
 
    class function GetSharedImageClass: TSharedRasterImageClass; override;
1609
1637
    procedure HandleNeeded; override;
1610
1638
    function InternalReleaseBitmapHandle: HBITMAP; override;
1611
1639
    function InternalReleaseMaskHandle: HBITMAP; override;
1636
1664
    function LazarusResourceTypeValid(const ResourceType: string): boolean; override;
1637
1665
    procedure LoadFromResourceName(Instance: THandle; const ResName: String); override;
1638
1666
    procedure LoadFromResourceID(Instance: THandle; ResID: PtrInt); override;
1639
 
    procedure LoadFromResourceHandle(Instance: THandle; ResHandle: TFPResourceHandle);
 
1667
    procedure LoadFromResourceHandle(Instance: THandle; ResHandle: TFPResourceHandle); virtual;
1640
1668
    function BitmapHandleAllocated: boolean; override;
1641
1669
    function MaskHandleAllocated: boolean; override;
1642
1670
    function PaletteAllocated: boolean; override;
1654
1682
    function GetIconHandle: HICON;
1655
1683
    procedure SetIconHandle(const AValue: HICON);
1656
1684
  protected
 
1685
    class function GetStreamSignature: Cardinal; override;
1657
1686
    class function GetTypeID: Word; override;
1658
1687
    procedure HandleNeeded; override;
1659
1688
  public
 
1689
    procedure LoadFromResourceHandle(Instance: THandle; ResHandle: TFPResourceHandle); override;
1660
1690
    function ReleaseHandle: HICON;
1661
1691
    function GetResourceType: TResourceType; override;
1662
1692
    property Handle: HICON read GetIconHandle write SetIconHandle;
1733
1763
  protected
1734
1764
    procedure HandleNeeded; override;
1735
1765
    class function GetDefaultSize: TSize; override;
 
1766
    class function GetStreamSignature: Cardinal; override;
1736
1767
    class function GetSharedImageClass: TSharedRasterImageClass; override;
1737
1768
    class function GetTypeID: Word; override;
1738
1769
  public
1739
1770
    class function GetFileExtensions: string; override;
1740
1771
    function GetResourceType: TResourceType; override;
 
1772
    procedure LoadFromResourceHandle(Instance: THandle; ResHandle: TFPResourceHandle); override;
1741
1773
    function LazarusResourceTypeValid(const ResourceType: string): boolean; override;
1742
1774
    function ReleaseHandle: HCURSOR;
1743
1775
    property HotSpot: TPoint read GetHotSpot;
1872
1904
  // Color / Identifier mapping
1873
1905
  TGetColorStringProc = procedure(const s: AnsiString) of object;
1874
1906
 
1875
 
function IdentEntry(Entry: Longint; var MapEntry: TIdentMapEntry): boolean;
1876
 
function ColorToIdent(Color: Longint; var Ident: String): Boolean;
1877
 
function IdentToColor(const Ident: string; var Color: Longint): Boolean;
1878
 
function ColorIndex(Color: Longint; var Index: Integer): Boolean;
 
1907
function IdentEntry(Entry: Longint; out MapEntry: TIdentMapEntry): boolean;
 
1908
function ColorToIdent(Color: Longint; out Ident: String): Boolean;
 
1909
function IdentToColor(const Ident: string; out Color: Longint): Boolean;
 
1910
function ColorIndex(Color: Longint; out Index: Integer): Boolean;
1879
1911
function SysColorToSysColorIndex(Color: TColor): integer;
1880
 
function ColorToRGB(Color: TColor): TColor;
 
1912
function ColorToRGB(Color: TColor): Longint;
1881
1913
function ColorToString(Color: TColor): AnsiString;
1882
1914
function StringToColor(const S: shortstring): TColor;
 
1915
function StringToColorDef(const S: shortstring; const DefaultValue: TColor): TColor;
1883
1916
procedure GetColorValues(Proc: TGetColorStringProc);
1884
1917
function InvertColor(AColor: TColor): TColor;
1885
1918
function DecColor(AColor: TColor; AQuantity: Byte): TColor;
1886
 
function IsSysColor(AColor: TColor): Boolean;
 
1919
function IsSysColor(AColor: TColorRef): Boolean;
1887
1920
 
1888
 
function Blue(rgb: TColor): BYTE; // does not work on system color
1889
 
function Green(rgb: TColor): BYTE; // does not work on system color
1890
 
function Red(rgb: TColor): BYTE; // does not work on system color
 
1921
function Blue(rgb: TColorRef): BYTE; // does not work on system color
 
1922
function Green(rgb: TColorRef): BYTE; // does not work on system color
 
1923
function Red(rgb: TColorRef): BYTE; // does not work on system color
1891
1924
function RGBToColor(R, G, B: Byte): TColor;
1892
 
procedure RedGreenBlue(rgb: TColor; out Red, Green, Blue: Byte); // does not work on system color
 
1925
procedure RedGreenBlue(rgb: TColorRef; out Red, Green, Blue: Byte); // does not work on system color
 
1926
function FPColorToTColorRef(const FPColor: TFPColor): TColorRef;
1893
1927
function FPColorToTColor(const FPColor: TFPColor): TColor;
1894
 
function TColorToFPColor(const c: TColor): TFPColor; // does not work on system color
 
1928
function TColorToFPColor(const c: TColorRef): TFPColor; overload;
 
1929
function TColorToFPColor(const c: TColor): TFPColor; overload; // does not work on system color
1895
1930
 
1896
1931
// fonts
1897
1932
procedure GetCharsetValues(Proc: TGetStrProc);
1898
 
function CharsetToIdent(Charset: Longint; var Ident: string): Boolean;
1899
 
function IdentToCharset(const Ident: string; var Charset: Longint): Boolean;
 
1933
function CharsetToIdent(Charset: Longint; out Ident: string): Boolean;
 
1934
function IdentToCharset(const Ident: string; out Charset: Longint): Boolean;
1900
1935
function GetFontData(Font: HFont): TFontData;
1901
1936
 
1902
1937
function GetDefFontCharSet: TFontCharSet;
1938
1973
function ReadXPMFromStream(Stream: TStream; Size: integer): PPChar;
1939
1974
function ReadXPMSize(XPM: PPChar; var Width, Height, ColorCount: integer): boolean;
1940
1975
function LoadCursorFromLazarusResource(ACursorName: String): HCursor;
 
1976
// for winapi compatibility
 
1977
function LoadBitmap(hInstance: THandle; lpBitmapName: PChar): HBitmap;
 
1978
function LoadCursor(hInstance: THandle; lpCursorName: PChar): HCursor;
 
1979
function LoadIcon(hInstance: THandle; lpIconName: PChar): HIcon;
1941
1980
 
1942
1981
function LoadBitmapFromLazarusResource(const ResourceName: String): TBitmap; deprecated;
1943
1982
function LoadBitmapFromLazarusResourceHandle(Handle: TLResource): TBitmap; deprecated;
2001
2040
procedure UpdateHandleObjects;
2002
2041
 
2003
2042
implementation
 
2043
 
2004
2044
uses
2005
 
  SyncObjs;
 
2045
  SyncObjs, LCLIntf, InterfaceBase;
2006
2046
 
2007
2047
var
2008
2048
  GraphicsUpdateCount: Integer = 0;
2041
2081
  Result:='['+Result+']';
2042
2082
end;
2043
2083
 
2044
 
 
2045
2084
function LoadCursorFromLazarusResource(ACursorName: String): HCursor;
2046
2085
var
2047
2086
  CursorImage: TCursorImage;
2048
2087
begin
2049
2088
  CursorImage := TCursorImage.Create;
2050
 
  CursorImage.LoadFromLazarusResource(ACursorName);
2051
 
  Result := CursorImage.ReleaseHandle;
2052
 
  CursorImage.Free;
2053
 
end;
2054
 
 
 
2089
  try
 
2090
    CursorImage.LoadFromLazarusResource(ACursorName);
 
2091
    Result := CursorImage.ReleaseHandle;
 
2092
  finally
 
2093
    CursorImage.Free;
 
2094
  end;
 
2095
end;
 
2096
 
 
2097
function LoadBitmap(hInstance: THandle; lpBitmapName: PChar): HBitmap;
 
2098
var
 
2099
  Bmp: TBitmap;
 
2100
begin
 
2101
  Bmp := TBitmap.Create;
 
2102
  try
 
2103
    if PtrUInt(lpBitmapName) > High(Word)
 
2104
    then Bmp.LoadFromResourceName(hInstance, lpBitmapName)
 
2105
    else Bmp.LoadFromResourceID(hInstance, PtrInt(lpBitmapName));
 
2106
    Result := Bmp.ReleaseHandle;
 
2107
  finally
 
2108
    Bmp.Free;
 
2109
  end;
 
2110
end;
 
2111
 
 
2112
function LoadCursor(hInstance: THandle; lpCursorName: PChar): HCursor;
 
2113
var
 
2114
  Cur: TCursorImage;
 
2115
begin
 
2116
  Cur := TCursorImage.Create;
 
2117
  try
 
2118
    if PtrUInt(lpCursorName) > High(Word)
 
2119
    then Cur.LoadFromResourceName(hInstance, lpCursorName)
 
2120
    else Cur.LoadFromResourceID(hInstance, PtrInt(lpCursorName));
 
2121
    Result := Cur.ReleaseHandle;
 
2122
  finally
 
2123
    Cur.Free;
 
2124
  end;
 
2125
end;
 
2126
 
 
2127
function LoadIcon(hInstance: THandle; lpIconName: PChar): HIcon;
 
2128
var
 
2129
  Ico: TIcon;
 
2130
begin
 
2131
  Ico := TIcon.Create;
 
2132
  try
 
2133
    if PtrUInt(lpIconName) > High(Word)
 
2134
    then Ico.LoadFromResourceName(hInstance, lpIconName)
 
2135
    else Ico.LoadFromResourceID(hInstance, PtrInt(lpIconName));
 
2136
    Result := Ico.ReleaseHandle;
 
2137
  finally
 
2138
    Ico.Free;
 
2139
  end;
 
2140
end;
2055
2141
 
2056
2142
function CreateBitmapFromLazarusResource(AStream: TLazarusResourceStream; AMinimumClass: TCustomBitmapClass): TCustomBitmap;
2057
2143
var
2187
2273
      DstImage.CopyPixels(SrcImage, 0, 0, True, $8000);
2188
2274
    end
2189
2275
    else begin
 
2276
      // update DevDesc because of unusual bitmaps. issue #12362
 
2277
      // widgetset can provide same DevDesc, but also can change it
 
2278
      // like gtk/gtk2 does since it expects XBM format for mono bitmaps.
 
2279
      if DevDesc.Depth = 1 then
 
2280
      begin
 
2281
        QueryFlags := QueryFlags + [riqfUpdate];
 
2282
        QueryDescription(DevDesc, QueryFlags);
 
2283
      end;
2190
2284
      DstImage.DataDescription := DevDesc;
2191
2285
      DstImage.CopyPixels(SrcImage);
2192
2286
    end;
2395
2489
    {$warnings on}
2396
2490
    );
2397
2491
 
2398
 
function IdentEntry(Entry: Longint; var MapEntry: TIdentMapEntry): boolean;
 
2492
function IdentEntry(Entry: Longint; out MapEntry: TIdentMapEntry): boolean;
2399
2493
begin
2400
2494
  Result := False;
2401
2495
  if (Entry >= 0) and (Entry <= High(Colors)) then
2405
2499
  end;
2406
2500
end;
2407
2501
 
2408
 
function ColorToIdent(Color: Longint; var Ident: String): Boolean;
 
2502
function ColorToIdent(Color: Longint; out Ident: String): Boolean;
2409
2503
begin
2410
2504
  Result := IntToIdent(Color, Ident, Colors);
2411
2505
end;
2412
2506
 
2413
 
function IdentToColor(const Ident: string; var Color: Longint): Boolean;
 
2507
function IdentToColor(const Ident: string; out Color: Longint): Boolean;
2414
2508
begin
2415
2509
  Result := IdentToInt(Ident, Color, Colors);
2416
2510
end;
2417
2511
 
2418
 
function ColorIndex(Color: Longint; var Index: Integer): Boolean;
 
2512
function ColorIndex(Color: Longint; out Index: Integer): Boolean;
2419
2513
var
2420
2514
  i: integer;
2421
2515
begin
2434
2528
  if (Cardinal(Color) and Cardinal(SYS_COLOR_BASE)) <> 0 then begin
2435
2529
    case Color of
2436
2530
    {$warnings off}
2437
 
    clHighlightedText..clForeground:
 
2531
    clHighlightedText..clForeground:   // Deprecated values!
2438
2532
      Result:=clForeground+COLOR_clForeground-Color;
2439
2533
    clNormalHighlightedText..clNormalForeground:
2440
2534
      Result:=clNormalForeground+COLOR_clNormalForeground-Color;
2451
2545
  end;
2452
2546
end;
2453
2547
 
2454
 
function ColorToRGB(Color: TColor): TColor;
 
2548
function ColorToRGB(Color: TColor): Longint;
 
2549
var
 
2550
  i: integer;
2455
2551
begin
2456
 
  if (Cardinal(Color) and Cardinal(SYS_COLOR_BASE)) <> 0
2457
 
  then Result := GetSysColor(SysColorToSysColorIndex(Color))
2458
 
  else Result := Color;
 
2552
  i := SysColorToSysColorIndex(Color);
 
2553
  if i <> -1 then
 
2554
    Result := GetSysColor(i)
 
2555
  else
 
2556
    Result := Color;
2459
2557
  Result := Result and $FFFFFF;
2460
2558
end;
2461
2559
 
2473
2571
    Result := TColor(StrToInt(S));
2474
2572
end;
2475
2573
 
 
2574
function StringToColorDef(const S: shortstring; const DefaultValue: TColor): TColor;
 
2575
begin
 
2576
  Result := DefaultValue;
 
2577
  if not IdentToColor(S, Longint(Result)) then
 
2578
    Result := TColor(StrToIntDef(S,DefaultValue));
 
2579
end;
 
2580
 
2476
2581
procedure GetColorValues(Proc: TGetColorStringProc);
2477
2582
var
2478
2583
  I: Integer;
2517
2622
  Result := ((B and $ff) shl 16) or ((G and $ff) shl 8) or (R and $ff);
2518
2623
end;
2519
2624
 
2520
 
function Blue(rgb: TColor): BYTE;
 
2625
function Blue(rgb: TColorRef): BYTE;
2521
2626
begin
2522
2627
  Result := (rgb shr 16) and $000000ff;
2523
2628
end;
2524
2629
 
2525
 
function Green(rgb: TColor): BYTE;
 
2630
function Green(rgb: TColorRef): BYTE;
2526
2631
begin
2527
2632
  Result := (rgb shr 8) and $000000ff;
2528
2633
end;
2529
2634
 
2530
 
function Red(rgb: TColor): BYTE;
 
2635
function Red(rgb: TColorRef): BYTE;
2531
2636
begin
2532
2637
  Result := rgb and $000000ff;
2533
2638
end;
2537
2642
  Result := (B shl 16) or (G shl 8) or R;
2538
2643
end;
2539
2644
 
2540
 
procedure RedGreenBlue(rgb: TColor; out Red, Green, Blue: Byte);
 
2645
procedure RedGreenBlue(rgb: TColorRef; out Red, Green, Blue: Byte);
2541
2646
begin
2542
2647
  Red := rgb and $000000ff;
2543
2648
  Green := (rgb shr 8) and $000000ff;
2544
2649
  Blue := (rgb shr 16) and $000000ff;
2545
2650
end;
2546
2651
 
2547
 
function FPColorToTColor(const FPColor: TFPColor): TColor;
 
2652
function FPColorToTColorRef(const FPColor: TFPColor): TColorRef;
2548
2653
begin
2549
2654
  Result:=((FPColor.Red shr 8) and $ff)
2550
2655
       or (FPColor.Green and $ff00)
2551
2656
       or ((FPColor.Blue shl 8) and $ff0000);
2552
2657
end;
2553
2658
 
2554
 
function TColorToFPColor(const c: TColor): TFPColor;
 
2659
function FPColorToTColor(const FPColor: TFPColor): TColor;
 
2660
begin
 
2661
  Result:=TColor(FPColorToTColorRef(FPColor));
 
2662
end;
 
2663
 
 
2664
function TColorToFPColor(const c: TColorRef): TFPColor;
2555
2665
begin
2556
2666
  Result.Red:=(c and $ff);
2557
2667
  Result.Red:=Result.Red+(Result.Red shl 8);
2562
2672
  Result.Alpha:=FPImage.alphaOpaque;
2563
2673
end;
2564
2674
 
 
2675
function TColorToFPColor(const c: TColor): TFPColor;
 
2676
begin
 
2677
  Result:=TColorToFPColor(TColorRef(c));
 
2678
end;
 
2679
 
2565
2680
// ------------------------------------------------------------------
2566
2681
// Decrease the component RGBs of a color of the quantity' passed
2567
2682
//
2579
2694
  Result := RGBToColor(R, G, B);
2580
2695
end;
2581
2696
 
2582
 
function IsSysColor(AColor: TColor): Boolean;
 
2697
function IsSysColor(AColor: TColorRef): Boolean;
2583
2698
begin
2584
 
  Result := (Cardinal(AColor) and Cardinal(SYS_COLOR_BASE)) <> 0;
 
2699
  Result := (AColor and SYS_COLOR_BASE) <> 0;
2585
2700
end;
2586
2701
 
2587
2702
 
2603
2718
{$I png.inc}
2604
2719
{$I pnm.inc}
2605
2720
{$I jpegimage.inc}
2606
 
{$I cursorimage.inc}
2607
2721
{$I icon.inc}
2608
2722
{$I icnsicon.inc}
 
2723
{$I cursorimage.inc}
2609
2724
{$I fpimagebitmap.inc}
2610
2725
{$I bitmap.inc}
2611
2726
{$I tiffimage.inc}
2644
2759
initialization
2645
2760
  UpdateLock := TCriticalSection.Create;
2646
2761
  OnGetSystemFont := @LocalGetSystemFont;
2647
 
  RegisterIntegerConsts(TypeInfo(TColor), @IdentToColor, @ColorToIdent);
2648
 
  RegisterIntegerConsts(TypeInfo(TFontCharset), @IdentToCharset, @CharsetToIdent);
 
2762
  RegisterIntegerConsts(TypeInfo(TColor), TIdentToInt(@IdentToColor), TIntToIdent(@ColorToIdent));
 
2763
  RegisterIntegerConsts(TypeInfo(TFontCharset), TIdentToInt(@IdentToCharset), TIntToIdent(@CharsetToIdent));
2649
2764
  RegisterInterfaceInitializationHandler(@InterfaceInit);
2650
2765
  RegisterInterfaceFinalizationHandler(@InterfaceFinal);
2651
2766