1{ 2 /*************************************************************************** 3 graphics.pp 4 ----------- 5 Graphic Controls 6 Initial Revision : Mon Jul 26 0:02:58 1999 7 8 ***************************************************************************/ 9 10 ***************************************************************************** 11 This file is part of the Lazarus Component Library (LCL) 12 13 See the file COPYING.modifiedLGPL.txt, included in this distribution, 14 for details about the license. 15 ***************************************************************************** 16} 17unit Graphics; 18 19{$mode objfpc}{$H+} 20{$I lcl_defines.inc} 21 22interface 23 24{$ifdef Trace} 25{$ASSERTIONS ON} 26{$endif} 27 28{$IF FPC_FULLVERSION>=20601} 29{$DEFINE HasFPCanvas1} 30{$ENDIF} 31 32{$IF FPC_FULLVERSION>=20603} 33{$DEFINE HasFPEndCap} 34{$ENDIF} 35 36{$IF FPC_FULLVERSION>=20603} 37{$DEFINE HasFPJoinStyle} 38{$ENDIF} 39 40uses 41 // RTL + FCL 42 SysUtils, Math, Types, Classes, Contnrs, Laz_AVL_Tree, 43 FPImage, FPCanvas, 44 FPWriteBMP, // bmp support 45 FPWritePNG, PNGComn, // png support 46 {$IFNDEF DisableLCLPNM} 47 FPReadPNM, FPWritePNM, // PNM (Portable aNyMap) support 48 {$ENDIF} 49 {$IFNDEF DisableLCLJPEG} 50 FPReadJpeg, FPWriteJpeg, // jpg support 51 {$ENDIF} 52 {$IFNDEF DisableLCLTIFF} 53 FPReadTiff, FPTiffCmn, // tiff support 54 {$ENDIF} 55 {$IFNDEF DisableLCLGIF} 56 FPReadGif, 57 {$ENDIF} 58 // LazUtils 59 FPCAdds, LazUTF8Classes, LazLoggerBase, LazUtilities, 60 // LCL 61 LCLVersion, LCLStrConsts, LCLType, LCLProc, LMessages, LResources, LCLResCache, 62 IntfGraphics, GraphType, IcnsTypes, GraphMath, WSReferences; 63 64type 65 PColor = ^TColor; 66 TColor = TGraphicsColor; 67 68 TFontPitch = (fpDefault, fpVariable, fpFixed); 69 TFontName = string; 70 TFontDataName = string[LF_FACESIZE -1]; 71 TFontStyle = (fsBold, fsItalic, fsUnderline, fsStrikeOut); 72 TFontStyles = set of TFontStyle; 73 TFontStylesbase = set of TFontStyle; 74 TFontCharSet = 0..255; 75 TFontQuality = (fqDefault, fqDraft, fqProof, fqNonAntialiased, fqAntialiased, 76 fqCleartype, fqCleartypeNatural); 77 78 TFontData = record 79 Handle: HFont; 80 Height: Integer; 81 Pitch: TFontPitch; 82 Style: TFontStylesBase; 83 CharSet: TFontCharSet; 84 Quality: TFontQuality; 85 Name: TFontDataName; 86 Orientation: Integer; 87 end; 88 89const 90 // New TFont instances are initialized with the values in this structure. 91 // About font default values: The default font is chosen by the interfaces 92 // depending on the context. For example, there can be a different default 93 // font for a button and a groupbox. 94 DefFontData: TFontData = ( 95 Handle: 0; 96 Height: 0; 97 Pitch: fpDefault; 98 Style: []; 99 Charset: DEFAULT_CHARSET; 100 Quality: fqDefault; 101 Name: 'default'; 102 Orientation: 0; 103 ); 104 105type 106 { Reflects text style when drawn in a rectangle } 107 108 TTextLayout = (tlTop, tlCenter, tlBottom); 109 TTextStyle = packed record 110 Alignment : TAlignment; // TextRect Only: horizontal alignment 111 112 Layout : TTextLayout; // TextRect Only: vertical alignment 113 114 SingleLine: boolean; // If WordBreak is false then process #13, #10 as 115 // standard chars and perform no Line breaking. 116 117 Clipping : boolean; // TextRect Only: Clip Text to passed Rectangle 118 119 ExpandTabs: boolean; // Replace #9 by apropriate amount of spaces (default is usually 8) 120 121 ShowPrefix: boolean; // TextRect Only: Process first single '&' per 122 // line as an underscore and draw '&&' as '&' 123 124 Wordbreak : boolean; // TextRect Only: If line of text is too long 125 // too fit between left and right boundaries 126 // try to break into multiple lines between 127 // words 128 // See also EndEllipsis. 129 130 Opaque : boolean; // TextRect: Fills background with current Brush 131 // TextOut : Fills background with current 132 // foreground color 133 134 SystemFont: Boolean; // Use the system font instead of Canvas Font 135 136 RightToLeft: Boolean; //For RightToLeft text reading (Text Direction) 137 138 EndEllipsis: Boolean; // TextRect Only: If line of text is too long 139 // to fit between left and right boundaries 140 // truncates the text and adds "..." 141 // If Wordbreak is set as well, Workbreak will 142 // dominate. 143 end; 144 145const 146 psSolid = FPCanvas.psSolid; 147 psDash = FPCanvas.psDash; 148 psDot = FPCanvas.psDot; 149 psDashDot = FPCanvas.psDashDot; 150 psDashDotDot = FPCanvas.psDashDotDot; 151 psClear = FPCanvas.psClear; 152 psInsideframe = FPCanvas.psInsideframe; 153 psPattern = FPCanvas.psPattern; 154 155 pmBlack = FPCanvas.pmBlack; 156 pmWhite = FPCanvas.pmWhite; 157 pmNop = FPCanvas.pmNop; 158 pmNot = FPCanvas.pmNot; 159 pmCopy = FPCanvas.pmCopy; 160 pmNotCopy = FPCanvas.pmNotCopy; 161 pmMergePenNot = FPCanvas.pmMergePenNot; 162 pmMaskPenNot = FPCanvas.pmMaskPenNot; 163 pmMergeNotPen = FPCanvas.pmMergeNotPen; 164 pmMaskNotPen = FPCanvas.pmMaskNotPen; 165 pmMerge = FPCanvas.pmMerge; 166 pmNotMerge = FPCanvas.pmNotMerge; 167 pmMask = FPCanvas.pmMask; 168 pmNotMask = FPCanvas.pmNotMask; 169 pmXor = FPCanvas.pmXor; 170 pmNotXor = FPCanvas.pmNotXor; 171 172 bsSolid = FPCanvas.bsSolid; 173 bsClear = FPCanvas.bsClear; 174 bsHorizontal = FPCanvas.bsHorizontal; 175 bsVertical = FPCanvas.bsVertical; 176 bsFDiagonal = FPCanvas.bsFDiagonal; 177 bsBDiagonal = FPCanvas.bsBDiagonal; 178 bsCross = FPCanvas.bsCross; 179 bsDiagCross = FPCanvas.bsDiagCross; 180 181 {$IFDEF HasFPEndCap} 182 pecRound = FPCanvas.pecRound; 183 pecSquare = FPCanvas.pecSquare; 184 pecFlat = FPCanvas.pecFlat; 185 {$ENDIF} 186 187 {$IFDEF HasFPJoinStyle} 188 pjsRound = FPCanvas.pjsRound; 189 pjsBevel = FPCanvas.pjsBevel; 190 pjsMiter =FPCanvas.pjsMiter; 191 {$ENDIF} 192 193type 194 TFillStyle = TGraphicsFillStyle; 195 TFillMode = (fmAlternate, fmWinding); 196 197 TCopymode = longint; 198 199 TCanvasStates = (csHandleValid, 200 csFontValid, // true if Font properties correspond to 201 // selected Font Handle in DC 202 csPenvalid, csBrushValid, csRegionValid); 203 TCanvasState = set of TCanvasStates; 204 TCanvasOrientation = (csLefttoRight, coRighttoLeft); 205 206 { TProgressEvent } 207 TProgressStage = TFPImgProgressStage; 208 TProgressEvent = TFPImgProgressEvent; 209 210 { For Delphi compatibility } 211 TPixelFormat = ( 212 pfDevice, 213 pf1bit, 214 pf4bit, 215 pf8bit, 216 pf15bit, 217 pf16bit, 218 pf24bit, 219 pf32bit, 220 pfCustom 221 ); 222 223const 224 PIXELFORMAT_BPP: array[TPixelFormat] of Byte = ( 225 0, 1, 4, 8, 15, 16, 24, 32, 0 226 ); 227 228 229type 230 TTransparentMode = ( 231 tmAuto, 232 tmFixed 233 ); 234 235const 236 // The following colors match the predefined Delphi Colors 237 238 // standard colors 239 clBlack = TColor($000000); 240 clMaroon = TColor($000080); 241 clGreen = TColor($008000); 242 clOlive = TColor($008080); 243 clNavy = TColor($800000); 244 clPurple = TColor($800080); 245 clTeal = TColor($808000); 246 clGray = TColor($808080); 247 clSilver = TColor($C0C0C0); 248 clRed = TColor($0000FF); 249 clLime = TColor($00FF00); 250 clYellow = TColor($00FFFF); 251 clBlue = TColor($FF0000); 252 clFuchsia = TColor($FF00FF); 253 clAqua = TColor($FFFF00); 254 clLtGray = TColor($C0C0C0); // clSilver alias 255 clDkGray = TColor($808080); // clGray alias 256 clWhite = TColor($FFFFFF); 257 StandardColorsCount = 16; 258 259 // extended colors 260 clMoneyGreen = TColor($C0DCC0); 261 clSkyBlue = TColor($F0CAA6); 262 clCream = TColor($F0FBFF); 263 clMedGray = TColor($A4A0A0); 264 ExtendedColorCount = 4; 265 266 // special colors 267 clNone = TColor($1FFFFFFF); 268 clDefault = TColor($20000000); 269 270 // system colors 271 clScrollBar = TColor(SYS_COLOR_BASE or COLOR_SCROLLBAR); 272 clBackground = TColor(SYS_COLOR_BASE or COLOR_BACKGROUND); 273 clActiveCaption = TColor(SYS_COLOR_BASE or COLOR_ACTIVECAPTION); 274 clInactiveCaption = TColor(SYS_COLOR_BASE or COLOR_INACTIVECAPTION); 275 clMenu = TColor(SYS_COLOR_BASE or COLOR_MENU); 276 clWindow = TColor(SYS_COLOR_BASE or COLOR_WINDOW); 277 clWindowFrame = TColor(SYS_COLOR_BASE or COLOR_WINDOWFRAME); 278 clMenuText = TColor(SYS_COLOR_BASE or COLOR_MENUTEXT); 279 clWindowText = TColor(SYS_COLOR_BASE or COLOR_WINDOWTEXT); 280 clCaptionText = TColor(SYS_COLOR_BASE or COLOR_CAPTIONTEXT); 281 clActiveBorder = TColor(SYS_COLOR_BASE or COLOR_ACTIVEBORDER); 282 clInactiveBorder = TColor(SYS_COLOR_BASE or COLOR_INACTIVEBORDER); 283 clAppWorkspace = TColor(SYS_COLOR_BASE or COLOR_APPWORKSPACE); 284 clHighlight = TColor(SYS_COLOR_BASE or COLOR_HIGHLIGHT); 285 clHighlightText = TColor(SYS_COLOR_BASE or COLOR_HIGHLIGHTTEXT); 286 clBtnFace = TColor(SYS_COLOR_BASE or COLOR_BTNFACE); 287 clBtnShadow = TColor(SYS_COLOR_BASE or COLOR_BTNSHADOW); 288 clGrayText = TColor(SYS_COLOR_BASE or COLOR_GRAYTEXT); 289 clBtnText = TColor(SYS_COLOR_BASE or COLOR_BTNTEXT); 290 clInactiveCaptionText = TColor(SYS_COLOR_BASE or COLOR_INACTIVECAPTIONTEXT); 291 clBtnHighlight = TColor(SYS_COLOR_BASE or COLOR_BTNHIGHLIGHT); 292 cl3DDkShadow = TColor(SYS_COLOR_BASE or COLOR_3DDKSHADOW); 293 cl3DLight = TColor(SYS_COLOR_BASE or COLOR_3DLIGHT); 294 clInfoText = TColor(SYS_COLOR_BASE or COLOR_INFOTEXT); 295 clInfoBk = TColor(SYS_COLOR_BASE or COLOR_INFOBK); 296 297 clHotLight = TColor(SYS_COLOR_BASE or COLOR_HOTLIGHT); 298 clGradientActiveCaption = TColor(SYS_COLOR_BASE or COLOR_GRADIENTACTIVECAPTION); 299 clGradientInactiveCaption = TColor(SYS_COLOR_BASE or COLOR_GRADIENTINACTIVECAPTION); 300 clMenuHighlight = TColor(SYS_COLOR_BASE or COLOR_MENUHILIGHT); 301 clMenuBar = TColor(SYS_COLOR_BASE or COLOR_MENUBAR); 302 clForm = TColor(SYS_COLOR_BASE or COLOR_FORM); 303 304 // synonyms: do not show them in color lists 305 clColorDesktop = TColor(SYS_COLOR_BASE or COLOR_DESKTOP); 306 cl3DFace = TColor(SYS_COLOR_BASE or COLOR_3DFACE); 307 cl3DShadow = TColor(SYS_COLOR_BASE or COLOR_3DSHADOW); 308 cl3DHiLight = TColor(SYS_COLOR_BASE or COLOR_3DHIGHLIGHT); 309 clBtnHiLight = TColor(SYS_COLOR_BASE or COLOR_BTNHILIGHT); 310 311 clFirstSpecialColor = clBtnHiLight; 312 313 clMask = clWhite; 314 clDontMask = clBlack; 315 316 // !! deprecated colors !! 317 {$warnings off} 318 // CLX base, mapped, pseudo, rgb values 319 clForeground = TColor(-1) deprecated; 320 clButton = TColor(-2) deprecated; 321 clLight = TColor(-3) deprecated; 322 clMidlight = TColor(-4) deprecated; 323 clDark = TColor(-5) deprecated; 324 clMid = TColor(-6) deprecated; 325 clText = TColor(-7) deprecated; 326 clBrightText = TColor(-8) deprecated; 327 clButtonText = TColor(-9) deprecated; 328 clBase = TColor(-10) deprecated; 329 clxBackground = TColor(-11) deprecated; 330 clShadow = TColor(-12) deprecated; 331 clxHighlight = TColor(-13) deprecated; 332 clHighlightedText = TColor(-14) deprecated; 333 334 // CLX mapped role offsets 335 cloNormal = 32 deprecated; 336 cloDisabled = 64 deprecated; 337 cloActive = 96 deprecated; 338 339 // CLX normal, mapped, pseudo, rgb values 340 clNormalForeground = TColor(clForeground - cloNormal) deprecated; 341 clNormalButton = TColor(clButton - cloNormal) deprecated; 342 clNormalLight = TColor(clLight - cloNormal) deprecated; 343 clNormalMidlight = TColor(clMidlight - cloNormal) deprecated; 344 clNormalDark = TColor(clDark - cloNormal) deprecated; 345 clNormalMid = TColor(clMid - cloNormal) deprecated; 346 clNormalText = TColor(clText - cloNormal) deprecated; 347 clNormalBrightText = TColor(clBrightText - cloNormal) deprecated; 348 clNormalButtonText = TColor(clButtonText - cloNormal) deprecated; 349 clNormalBase = TColor(clBase - cloNormal) deprecated; 350 clNormalBackground = TColor(clxBackground - cloNormal) deprecated; 351 clNormalShadow = TColor(clShadow - cloNormal) deprecated; 352 clNormalHighlight = TColor(clxHighlight - cloNormal) deprecated; 353 clNormalHighlightedText = TColor(clHighlightedText - cloNormal) deprecated; 354 355 // CLX disabled, mapped, pseudo, rgb values 356 clDisabledForeground = TColor(clForeground - cloDisabled) deprecated; 357 clDisabledButton = TColor(clButton - cloDisabled) deprecated; 358 clDisabledLight = TColor(clLight - cloDisabled) deprecated; 359 clDisabledMidlight = TColor(clMidlight - cloDisabled) deprecated; 360 clDisabledDark = TColor(clDark - cloDisabled) deprecated; 361 clDisabledMid = TColor(clMid - cloDisabled) deprecated; 362 clDisabledText = TColor(clText - cloDisabled) deprecated; 363 clDisabledBrightText = TColor(clBrightText - cloDisabled) deprecated; 364 clDisabledButtonText = TColor(clButtonText - cloDisabled) deprecated; 365 clDisabledBase = TColor(clBase - cloDisabled) deprecated; 366 clDisabledBackground = TColor(clxBackground - cloDisabled) deprecated; 367 clDisabledShadow = TColor(clShadow - cloDisabled) deprecated; 368 clDisabledHighlight = TColor(clxHighlight - cloDisabled) deprecated; 369 clDisabledHighlightedText = TColor(clHighlightedText - cloDisabled) deprecated; 370 371 // CLX active, mapped, pseudo, rgb values 372 clActiveForeground = TColor(clForeground - cloActive) deprecated; 373 clActiveButton = TColor(clButton - cloActive) deprecated; 374 clActiveLight = TColor(clLight - cloActive) deprecated; 375 clActiveMidlight = TColor(clMidlight - cloActive) deprecated; 376 clActiveDark = TColor(clDark - cloActive) deprecated; 377 clActiveMid = TColor(clMid - cloActive) deprecated; 378 clActiveText = TColor(clText - cloActive) deprecated; 379 clActiveBrightText = TColor(clBrightText - cloActive) deprecated; 380 clActiveButtonText = TColor(clButtonText - cloActive) deprecated; 381 clActiveBase = TColor(clBase - cloActive) deprecated; 382 clActiveBackground = TColor(clxBackground - cloActive) deprecated; 383 clActiveShadow = TColor(clShadow - cloActive) deprecated; 384 clActiveHighlight = TColor(clxHighlight - cloActive) deprecated; 385 clActiveHighlightedText = TColor(clHighlightedText - cloActive) deprecated; 386 387type 388 TMappedColor = clActiveHighlightedText..clNormalForeground; 389 390 TColorGroup = (cgInactive, cgDisabled, cgActive); 391 TColorRole = (crForeground, crButton, crLight, crMidlight, crDark, crMid, 392 crText, crBrightText, crButtonText, crBase, crBackground, crShadow, 393 crHighlight, crHighlightText, crNoRole); 394 {$warnings on} 395 396const 397 cmBlackness = BLACKNESS; 398 cmDstInvert = DSTINVERT; 399 cmMergeCopy = MERGECOPY; 400 cmMergePaint = MERGEPAINT; 401 cmNotSrcCopy = NOTSRCCOPY; 402 cmNotSrcErase = NOTSRCERASE; 403 cmPatCopy = PATCOPY; 404 cmPatInvert = PATINVERT; 405 cmPatPaint = PATPAINT; 406 cmSrcAnd = SRCAND; 407 cmSrcCopy = SRCCOPY; 408 cmSrcErase = SRCERASE; 409 cmSrcInvert = SRCINVERT; 410 cmSrcPaint = SRCPAINT; 411 cmWhiteness = WHITENESS; 412 413 414type 415 TCanvas = class; 416 417 // base class 418 TRasterImage = class; 419 TRasterImageClass = class of TRasterImage; 420 TCustomBitmap = class; 421 TCustomBitmapClass = class of TCustomBitmap; 422 // standard LCL graphic formats 423 TBitmap = class; // bmp 424 TPixmap = class; // xpm 425 TIcon = class; // ico 426 TPortableNetworkGraphic = class; // png 427 {$IFNDEF DisableLCLPNM} 428 TPortableAnyMapGraphic = class; // pnm formats: pbm, pgm and ppm 429 {$ENDIF} 430 {$IFNDEF DisableLCLJPEG} 431 TJpegImage = class; // jpg 432 {$ENDIF} 433 {$IFNDEF DisableLCLGIF} 434 TGIFImage = class; // gif (read only) 435 {$ENDIF} 436 437 { TGraphicsObject 438 In Delphi VCL this is the ancestor of TFont, TPen and TBrush. 439 Since FPC 2.0 the LCL uses TFPCanvasHelper as ancestor. } 440 441 TGraphicsObject = class(TPersistent) 442 private 443 FOnChanging: TNotifyEvent; 444 FOnChange: TNotifyEvent; 445 procedure DoChange(var Msg); message LM_CHANGED; 446 protected 447 procedure Changing; virtual; 448 procedure Changed; virtual; 449 procedure Lock; 450 procedure UnLock; 451 public 452 property OnChanging: TNotifyEvent read FOnChanging write FOnChanging; 453 property OnChange: TNotifyEvent read FOnChange write FOnChange; 454 end; 455 456 { TFontHandleCacheDescriptor } 457 458 TFontHandleCacheDescriptor = class(TResourceCacheDescriptor) 459 public 460 LogFont: TLogFont; 461 LongFontName: string; 462 end; 463 464 { TFontHandleCache } 465 466 TFontHandleCache = class(TResourceCache) 467 protected 468 procedure RemoveItem(Item: TResourceCacheItem); override; 469 public 470 constructor Create; 471 function CompareDescriptors(Tree: TAvlTree; Desc1, Desc2: Pointer): integer; override; 472 function FindFont(TheFont: TLCLHandle): TResourceCacheItem; 473 function FindFontDesc(const LogFont: TLogFont; 474 const LongFontName: string): TFontHandleCacheDescriptor; 475 function Add(TheFont: TLCLHandle; const LogFont: TLogFont; 476 const LongFontName: string): TFontHandleCacheDescriptor; 477 end; 478 479 { TFont } 480 481 TFont = class(TFPCustomFont) 482 private 483 FCanUTF8: boolean; 484 FCanUTF8Valid: boolean; 485 FIsMonoSpace: boolean; 486 FIsMonoSpaceValid: boolean; 487 FOrientation: Integer; 488 FPitch: TFontPitch; 489 FQuality: TFontQuality; 490 FStyle: TFontStylesBase; 491 FCharSet: TFontCharSet; 492 FPixelsPerInch: Integer; 493 FUpdateCount: integer; 494 FChanged: boolean; 495 FFontHandleCached: boolean; 496 FColor: TColor; 497 FHeight: integer; // FHeight = -(FSize * FPixelsPerInch) div 72 498 FReference: TWSFontReference; 499 procedure FreeReference; 500 function GetCanUTF8: boolean; 501 function GetHandle: HFONT; 502 function GetData: TFontData; 503 function GetIsMonoSpace: boolean; 504 function GetReference: TWSFontReference; 505 function IsHeightStored: boolean; 506 function IsNameStored: boolean; 507 procedure SetData(const FontData: TFontData); 508 procedure SetHandle(const Value: HFONT); 509 procedure ReferenceNeeded; 510 procedure SetPixelsPerInch(const APixelsPerInch: Integer); 511 protected 512 function GetCharSet: TFontCharSet; 513 function GetHeight: Integer; 514 function GetName: string; 515 function GetOrientation: Integer; 516 function GetPitch: TFontPitch; 517 function GetSize: Integer; 518 function GetStyle: TFontStyles; 519 procedure Changed; override; 520 procedure DoAllocateResources; override; 521 procedure DoCopyProps(From: TFPCanvasHelper); override; 522 procedure DoDeAllocateResources; override; 523 procedure SetCharSet(const AValue: TFontCharSet); 524 procedure SetColor(const NewColor: TColor; const NewFPColor: TFPColor); virtual; 525 procedure SetColor(Value: TColor); 526 function GetColor: TColor; 527 procedure SetFlags(Index: integer; AValue: boolean); override; 528 procedure SetFPColor(const AValue: TFPColor); override; 529 procedure SetHeight(Avalue: Integer); 530 procedure SetName(AValue: string); override; 531 procedure SetOrientation(AValue: Integer); override; // 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 532 procedure SetPitch(Value: TFontPitch); 533 procedure SetSize(AValue: integer); override; 534 procedure SetStyle(Value: TFontStyles); 535 procedure SetQuality(const AValue: TFontQuality); 536 public 537 constructor Create; override; 538 destructor Destroy; override; 539 procedure Assign(Source: TPersistent); override; 540 procedure Assign(const ALogFont: TLogFont); 541 procedure BeginUpdate; 542 procedure EndUpdate; 543 property FontData: TFontData read GetData write SetData; 544 function HandleAllocated: boolean; 545 property Handle: HFONT read GetHandle write SetHandle; 546 function IsDefault: boolean; 547 function IsEqual(AFont: TFont): boolean; virtual; 548 property IsMonoSpace: boolean read GetIsMonoSpace; 549 procedure SetDefault; 550 property CanUTF8: boolean read GetCanUTF8; deprecated; 551 property PixelsPerInch: Integer read FPixelsPerInch write SetPixelsPerInch; 552 property Reference: TWSFontReference read GetReference; 553 published 554 property CharSet: TFontCharSet read GetCharSet write SetCharSet default DEFAULT_CHARSET; 555 property Color: TColor read FColor write SetColor default {$ifdef UseCLDefault}clDefault{$else}clWindowText{$endif}; 556 property Height: Integer read GetHeight write SetHeight stored IsHeightStored; 557 property Name: string read GetName write SetName stored IsNameStored; 558 property Orientation: Integer read GetOrientation write SetOrientation default 0; 559 property Pitch: TFontPitch read GetPitch write SetPitch default fpDefault; 560 property Quality: TFontQuality read FQuality write SetQuality default fqDefault; 561 property Size: Integer read GetSize write SetSize stored false; 562 property Style: TFontStyles read GetStyle write SetStyle default []; 563 end; 564 565 { TPen } 566 567 TPenStyle = TFPPenStyle; 568 TPenMode = TFPPenMode; 569 570 // pen end caps. valid only for geometric pens 571 {$IFDEF HasFPEndCap} 572 TPenEndCap = TFPPenEndCap; 573 {$ELSE} 574 TPenEndCap = ( 575 pecRound, 576 pecSquare, 577 pecFlat 578 ); 579 {$ENDIF} 580 581 // join style. valid only for geometric pens 582 {$IFDEF HasFPJoinStyle} 583 TPenJoinStyle = FPCanvas.TFPPenJoinStyle; 584 {$ELSE} 585 TPenJoinStyle = ( 586 pjsRound, 587 pjsBevel, 588 pjsMiter 589 ); 590 {$ENDIF} 591 592 TPenPattern = array of LongWord; 593 594 { TPenHandleCacheDescriptor } 595 596 TPenHandleCacheDescriptor = class(TResourceCacheDescriptor) 597 public 598 ExtPen: TExtLogPen; 599 Pattern: TPenPattern; 600 end; 601 602 { TPenHandleCache } 603 604 TPenHandleCache = class(TResourceCache) 605 protected 606 procedure RemoveItem(Item: TResourceCacheItem); override; 607 public 608 constructor Create; 609 function CompareDescriptors(Tree: TAvlTree; Desc1, Desc2: Pointer): integer; override; 610 function FindPen(APen: TLCLHandle): TResourceCacheItem; 611 function FindPenDesc(const AExtPen: TExtLogPen; 612 const APattern: TPenPattern): TPenHandleCacheDescriptor; 613 function Add(APen: TLCLHandle; const AExtPen: TExtLogPen; 614 const APattern: TPenPattern): TPenHandleCacheDescriptor; 615 end; 616 617 TPen = class(TFPCustomPen) 618 private 619 FColor: TColor; 620 {$IFNDEF HasFPEndCap} 621 FEndCap: TPenEndCap; 622 {$ENDIF} 623 FCosmetic: Boolean; 624 {$IFNDEF HasFPJoinStyle} 625 FJoinStyle: TPenJoinStyle; 626 {$ENDIF} 627 FPattern: TPenPattern; 628 FPenHandleCached: boolean; 629 FReference: TWSPenReference; 630 procedure FreeReference; 631 function GetHandle: HPEN; 632 function GetReference: TWSPenReference; 633 procedure ReferenceNeeded; 634 procedure SetCosmetic(const AValue: Boolean); 635 procedure SetHandle(const Value: HPEN); 636 protected 637 procedure DoAllocateResources; override; 638 procedure DoDeAllocateResources; override; 639 procedure DoCopyProps(From: TFPCanvasHelper); override; 640 procedure SetColor(const NewColor: TColor; const NewFPColor: TFPColor); virtual; 641 procedure SetFPColor(const AValue: TFPColor); override; 642 procedure SetColor(Value: TColor); 643 procedure SetEndCap(AValue: TPenEndCap); {$IFDEF HasFPEndCap}override;{$ENDIF} 644 procedure SetJoinStyle(AValue: TPenJoinStyle); {$IFDEF HasFPJoinStyle}override;{$ENDIF} 645 procedure SetMode(Value: TPenMode); override; 646 procedure SetStyle(Value: TPenStyle); override; 647 procedure SetWidth(value: Integer); override; 648 public 649 constructor Create; override; 650 destructor Destroy; override; 651 procedure Assign(Source: TPersistent); override; 652 property Handle: HPEN read GetHandle write SetHandle; deprecated; 653 property Reference: TWSPenReference read GetReference; 654 655 function GetPattern: TPenPattern; 656 procedure SetPattern(APattern: TPenPattern); reintroduce; 657 published 658 property Color: TColor read FColor write SetColor default clBlack; 659 property Cosmetic: Boolean read FCosmetic write SetCosmetic default True; 660 {$IFDEF HasFPEndCap} 661 property EndCap default pecRound; 662 {$ELSE} 663 property EndCap: TPenEndCap read FEndCap write SetEndCap default pecRound; 664 {$ENDIF} 665 {$IFDEF HasFPJoinStyle} 666 property JoinStyle default pjsRound; 667 {$ELSE} 668 property JoinStyle: TPenJoinStyle read FJoinStyle write SetJoinStyle default pjsRound; 669 {$ENDIF} 670 property Mode default pmCopy; 671 property Style default psSolid; 672 property Width default 1; 673 end; 674 675 { TBrush } 676 677 TBrushStyle = TFPBrushStyle; 678 679 TBrushHandleCache = class(TBlockResourceCache) 680 protected 681 procedure RemoveItem(Item: TResourceCacheItem); override; 682 public 683 constructor Create; 684 end; 685 686 TBrush = class(TFPCustomBrush) 687 private 688 FBrushHandleCached: boolean; 689 FColor: TColor; 690 FBitmap: TCustomBitmap; 691 FReference: TWSBrushReference; 692 FInternalUpdateIndex: Integer; 693 procedure FreeReference; 694 function GetHandle: HBRUSH; 695 function GetReference: TWSBrushReference; 696 function GetColor: TColor; 697 procedure ReferenceNeeded; 698 procedure SetHandle(const Value: HBRUSH); 699 procedure DoChange(var Msg); message LM_CHANGED; 700 protected 701 procedure DoAllocateResources; override; 702 procedure DoDeAllocateResources; override; 703 procedure DoCopyProps(From: TFPCanvasHelper); override; 704 procedure SetColor(const NewColor: TColor; const NewFPColor: TFPColor); virtual; 705 procedure SetFPColor(const AValue: TFPColor); override; 706 procedure SetBitmap(Value: TCustomBitmap); 707 procedure SetColor(Value: TColor); 708 procedure SetStyle(Value: TBrushStyle); override; 709 public 710 procedure Assign(Source: TPersistent); override; 711 constructor Create; override; 712 destructor Destroy; override; 713 function EqualsBrush(ABrush: TBrush): boolean; 714 property Bitmap: TCustomBitmap read FBitmap write SetBitmap; 715 property Handle: HBRUSH read GetHandle write SetHandle; deprecated; // use instead Reference.Handle 716 property Reference: TWSBrushReference read GetReference; 717 published 718 property Color: TColor read FColor write SetColor default clWhite; 719 property Style default bsSolid; 720 end; 721 722 TRegionCombineMode = (rgnAnd, rgnCopy, rgnDiff, rgnOr, rgnXOR); 723 724 TRegionOperationType = (rgnNewRect, rgnCombine); 725 726 TRegionOperation = record 727 ROType: TRegionOperationType; 728 Source1, Source2, Dest: Integer; // Index to the list of sub-regions, -1 indicates the main region 729 CombineMode: TRegionCombineMode; // Used only if ROType=rgnCombine 730 Rect: TRect; // Used for ROType=rgnNewRect 731 end; 732 733 TRegionOperations = array of TRegionOperation; 734 735 { TRegion } 736 737 TRegion = class(TGraphicsObject) 738 private 739 FReference: TWSRegionReference; 740 // Description of the region 741 //RegionOperations: TRegionOperations; 742 //SubRegions: array of HRGN; 743 procedure AddOperation(AOp: TRegionOperation); 744 procedure ClearSubRegions(); 745 procedure AddSubRegion(AHandle: HRGN); 746 // 747 procedure FreeReference; 748 function GetReference: TWSRegionReference; 749 function GetHandle: HRGN; 750 procedure ReferenceNeeded; 751 procedure SetHandle(const Value: HRGN); 752 protected 753 procedure SetClipRect(value: TRect); 754 function GetClipRect: TRect; 755 public 756 constructor Create; 757 destructor Destroy; override; 758 procedure Assign(Source: TPersistent); override; 759 760 // Convenience routines to add elements to the region 761 procedure AddRectangle(X1, Y1, X2, Y2: Integer); 762 763 property ClipRect: TRect read GetClipRect write SetClipRect; 764 property Handle: HRGN read GetHandle write SetHandle; deprecated; 765 property Reference: TWSRegionReference read GetReference; 766 end; 767 768 769 { TGraphic } 770 771 { TGraphic is an abstract base class for images like TRasterImage, 772 TCustomBitmap, TBitmap, etc. } 773 774 TGraphic = class(TPersistent) 775 private 776 FModified: Boolean; 777 FOnChange: TNotifyEvent; 778 FOnProgress: TProgressEvent; 779 FPaletteModified: Boolean; 780 protected 781 procedure Changed(Sender: TObject); virtual; 782 function Equals(Graphic: TGraphic): Boolean; virtual; {$IF declared(vmtEquals)}overload;{$ENDIF} 783 procedure DefineProperties(Filer: TFiler); override; 784 procedure Draw(ACanvas: TCanvas; const Rect: TRect); virtual; abstract; 785 function GetEmpty: Boolean; virtual; abstract; 786 function GetHeight: Integer; virtual; abstract; 787 function GetMimeType: string; virtual; 788 function GetPalette: HPALETTE; virtual; 789 function GetTransparent: Boolean; virtual; abstract; 790 function GetWidth: Integer; virtual; abstract; 791 procedure Progress(Sender: TObject; Stage: TProgressStage; 792 PercentDone: Byte; RedrawNow: Boolean; const R: TRect; 793 const Msg: string; var DoContinue: boolean); virtual; 794 procedure Progress(Sender: TObject; Stage: TProgressStage; 795 PercentDone: Byte; RedrawNow: Boolean; const R: TRect; 796 const Msg: string); virtual; 797 procedure ReadData(Stream: TStream); virtual; // used by Filer 798 procedure SetHeight(Value: Integer); virtual; abstract; 799 procedure SetPalette(Value: HPALETTE); virtual; 800 procedure SetTransparent(Value: Boolean); virtual; abstract; 801 procedure SetWidth(Value: Integer); virtual; abstract; 802 procedure SetModified(Value: Boolean); 803 procedure WriteData(Stream: TStream); virtual; // used by filer 804 public 805 procedure Assign(ASource: TPersistent); override; 806 constructor Create; virtual; 807 procedure Clear; virtual; 808 {$IF declared(vmtEquals)} 809 function Equals(Obj: TObject): Boolean; override; overload; 810 {$ENDIF} 811 function LazarusResourceTypeValid(const AResourceType: string): boolean; virtual; 812 procedure LoadFromFile(const Filename: string); virtual; 813 procedure LoadFromStream(Stream: TStream); virtual; abstract; 814 procedure LoadFromMimeStream(AStream: TStream; const AMimeType: string); virtual; 815 procedure LoadFromLazarusResource(const ResName: String); virtual; 816 procedure LoadFromResourceName(Instance: THandle; const ResName: String); virtual; 817 procedure LoadFromResourceID(Instance: THandle; ResID: PtrInt); virtual; 818 procedure LoadFromClipboardFormat(FormatID: TClipboardFormat); virtual; 819 procedure LoadFromClipboardFormatID(ClipboardType: TClipboardType; 820 FormatID: TClipboardFormat); virtual; 821 procedure SaveToFile(const Filename: string); virtual; 822 procedure SaveToStream(Stream: TStream); virtual; abstract; 823 procedure SaveToClipboardFormat(FormatID: TClipboardFormat); virtual; 824 procedure SaveToClipboardFormatID(ClipboardType: TClipboardType; 825 FormatID: TClipboardFormat); virtual; 826 procedure GetSupportedSourceMimeTypes(List: TStrings); virtual; 827 function GetResourceType: TResourceType; virtual; 828 class function GetFileExtensions: string; virtual; 829 class function IsStreamFormatSupported(Stream: TStream): Boolean; virtual; 830 public 831 property Empty: Boolean read GetEmpty; 832 property Height: Integer read GetHeight write SetHeight; 833 property Modified: Boolean read FModified write SetModified; 834 property MimeType: string read GetMimeType; 835 property OnChange: TNotifyEvent read FOnChange write FOnChange; 836 property OnProgress: TProgressEvent read FOnProgress write FOnProgress; 837 property Palette: HPALETTE read GetPalette write SetPalette; 838 property PaletteModified: Boolean read FPaletteModified write FPaletteModified; 839 property Transparent: Boolean read GetTransparent write SetTransparent; 840 property Width: Integer read GetWidth write SetWidth; 841 end; 842 843 TGraphicClass = class of TGraphic; 844 845 846 { TPicture } 847 848 TPicture = class(TPersistent) 849 private 850 FGraphic: TGraphic; 851 FOnChange: TNotifyEvent; 852 //FNotify: IChangeNotifier; 853 FOnProgress: TProgressEvent; 854 procedure ForceType(GraphicType: TGraphicClass); 855 function GetBitmap: TBitmap; 856 function GetIcon: TIcon; 857 {$IFNDEF DisableLCLJPEG} 858 function GetJpeg: TJpegImage; 859 {$ENDIF} 860 function GetPNG: TPortableNetworkGraphic; 861 {$IFNDEF DisableLCLPNM} 862 function GetPNM: TPortableAnyMapGraphic; 863 {$ENDIF} 864 function GetPixmap: TPixmap; 865 function GetHeight: Integer; 866 function GetWidth: Integer; 867 procedure ReadData(Stream: TStream); 868 procedure SetBitmap(Value: TBitmap); 869 procedure SetIcon(Value: TIcon); 870 {$IFNDEF DisableLCLJPEG} 871 procedure SetJpeg(Value: TJpegImage); 872 {$ENDIF} 873 procedure SetPNG(const AValue: TPortableNetworkGraphic); 874 {$IFNDEF DisableLCLPNM} 875 procedure SetPNM(const AValue: TPortableAnyMapGraphic); 876 {$ENDIF} 877 procedure SetPixmap(Value: TPixmap); 878 procedure SetGraphic(Value: TGraphic); 879 procedure WriteData(Stream: TStream); 880 protected 881 procedure AssignTo(Dest: TPersistent); override; 882 procedure Changed(Sender: TObject); virtual; 883 procedure DefineProperties(Filer: TFiler); override; 884 procedure Progress(Sender: TObject; Stage: TProgressStage; 885 PercentDone: Byte; RedrawNow: Boolean; const R: TRect; 886 const Msg: string; var DoContinue: boolean); virtual; 887 procedure LoadFromStreamWithClass(Stream: TStream; AClass: TGraphicClass); 888 public 889 constructor Create; 890 destructor Destroy; override; 891 892 procedure Clear; virtual; 893 // load methods 894 procedure LoadFromClipboardFormat(FormatID: TClipboardFormat); 895 procedure LoadFromClipboardFormatID(ClipboardType: TClipboardType; FormatID: TClipboardFormat); 896 procedure LoadFromFile(const Filename: string); 897 procedure LoadFromResourceName(Instance: THandle; const ResName: String); 898 procedure LoadFromResourceName(Instance: THandle; const ResName: String; AClass: TGraphicClass); 899 procedure LoadFromLazarusResource(const AName: string); 900 procedure LoadFromStream(Stream: TStream); 901 procedure LoadFromStreamWithFileExt(Stream: TStream; const FileExt: string); 902 // save methods 903 procedure SaveToClipboardFormat(FormatID: TClipboardFormat); 904 procedure SaveToFile(const Filename: string; const FileExt: string = ''); 905 procedure SaveToStream(Stream: TStream); 906 procedure SaveToStreamWithFileExt(Stream: TStream; const FileExt: string); 907 908 class function SupportsClipboardFormat(FormatID: TClipboardFormat): Boolean; 909 procedure Assign(Source: TPersistent); override; 910 class procedure RegisterFileFormat(const AnExtension, ADescription: string; 911 AGraphicClass: TGraphicClass); 912 class procedure RegisterClipboardFormat(FormatID: TClipboardFormat; 913 AGraphicClass: TGraphicClass); 914 class procedure UnregisterGraphicClass(AClass: TGraphicClass); 915 class function FindGraphicClassWithFileExt(const Ext: string; 916 ExceptionOnNotFound: boolean = true): TGraphicClass; 917 public 918 property Bitmap: TBitmap read GetBitmap write SetBitmap; 919 property Icon: TIcon read GetIcon write SetIcon; 920 {$IFNDEF DisableLCLJPEG} 921 property Jpeg: TJpegImage read GetJpeg write SetJpeg; 922 {$ENDIF} 923 property Pixmap: TPixmap read GetPixmap write SetPixmap; 924 property PNG: TPortableNetworkGraphic read GetPNG write SetPNG; 925 {$IFNDEF DisableLCLPNM} 926 property PNM: TPortableAnyMapGraphic read GetPNM write SetPNM; 927 {$ENDIF} 928 property Graphic: TGraphic read FGraphic write SetGraphic; 929 //property PictureAdapter: IChangeNotifier read FNotify write FNotify; 930 property Height: Integer read GetHeight; 931 property Width: Integer read GetWidth; 932 property OnChange: TNotifyEvent read FOnChange write FOnChange; 933 property OnProgress: TProgressEvent read FOnProgress write FOnProgress; 934 end; 935 936 937 EGraphicException = class(Exception); 938 EInvalidGraphic = class(EGraphicException); 939 EInvalidGraphicOperation = class(EGraphicException); 940 941type 942 TGradientDirection = ( 943 gdVertical, // Fill vertical 944 gdHorizontal // Fill Horizontal 945 ); 946 947 TAntialiasingMode = ( 948 amDontCare, // default antialiasing 949 amOn, // enabled 950 amOff // disabled 951 ); 952 953 TLCLTextMetric = record 954 Ascender: Integer; 955 Descender: Integer; 956 Height: Integer; 957 end; 958 959 TDefaultColorType = ( 960 dctBrush, 961 dctFont 962 ); 963 964 { TCanvas } 965 966 TCanvas = class(TFPCustomCanvas) 967 private 968 FAntialiasingMode: TAntialiasingMode; 969 FAutoRedraw: Boolean; 970 FState: TCanvasState; 971 FSavedFontHandle: HFont; 972 FSavedPenHandle: HPen; 973 FSavedBrushHandle: HBrush; 974 FSavedRegionHandle: HRGN; 975 FCopyMode: TCopyMode; 976 FHandle: HDC; 977 FOnChange: TNotifyEvent; 978 FOnChanging: TNotifyEvent; 979 FTextStyle: TTextStyle; 980 FLock: TCriticalSection;// FLock is initialized on demand 981 FRegion: TRegion; 982 FLazPen: TPen; 983 FLazFont: TFont; 984 FLazBrush: TBrush; 985 FSavedHandleStates: TFPList; 986 procedure BrushChanged(ABrush: TObject); 987 procedure FontChanged(AFont: TObject); 988 procedure PenChanged(APen: TObject); 989 procedure RegionChanged(ARegion: TObject); 990 function GetHandle: HDC; 991 procedure SetAntialiasingMode(const AValue: TAntialiasingMode); 992 procedure SetAutoRedraw(Value: Boolean); virtual; 993 procedure SetLazFont(Value: TFont); 994 procedure SetLazPen(Value: TPen); 995 procedure SetLazBrush(Value: TBrush); 996 procedure SetRegion(Value: TRegion); 997 protected 998 function DoCreateDefaultFont: TFPCustomFont; override; 999 function DoCreateDefaultPen: TFPCustomPen; override; 1000 function DoCreateDefaultBrush: TFPCustomBrush; override; 1001 procedure SetColor(x, y: integer; const Value: TFPColor); override; 1002 function GetColor(x, y: integer): TFPColor; override; 1003 procedure SetHeight(AValue: integer); override; 1004 function GetHeight: integer; override; 1005 procedure SetWidth(AValue: integer); override; 1006 function GetWidth: integer; override; 1007 procedure SetPenPos(const AValue: TPoint); override; 1008 procedure DoLockCanvas; override; 1009 procedure DoUnlockCanvas; override; 1010 procedure DoTextOut(x, y: integer; Text: string); override; 1011 procedure DoGetTextSize(Text: string; var w,h:integer); override; 1012 function DoGetTextHeight(Text: string): integer; override; 1013 function DoGetTextWidth(Text: string): integer; override; 1014 procedure DoRectangle(const Bounds: TRect); override; 1015 procedure DoRectangleFill(const Bounds: TRect); override; 1016 procedure DoRectangleAndFill(const Bounds: TRect); override; 1017 procedure DoEllipse(const Bounds: TRect); override; 1018 procedure DoEllipseFill(const Bounds: TRect); override; 1019 procedure DoEllipseAndFill(const Bounds: TRect); override; 1020 procedure DoPolygon(const Points: array of TPoint); override; 1021 procedure DoPolygonFill(const Points: array of TPoint); override; 1022 procedure DoPolygonAndFill(const Points: array of TPoint); override; 1023 procedure DoPolyline(const Points: array of TPoint); override; 1024 procedure DoPolyBezier(Points: PPoint; NumPts: Integer; 1025 Filled: boolean = False; 1026 Continuous: boolean = False); override; 1027 procedure DoFloodFill(x, y: integer); override; 1028 procedure DoMoveTo(x, y: integer); override; 1029 procedure DoLineTo(x, y: integer); override; 1030 procedure DoLine(x1, y1, x2, y2: integer); override; 1031 procedure DoCopyRect(x, y: integer; SrcCanvas: TFPCustomCanvas; 1032 const SourceRect: TRect); override; 1033 procedure DoDraw(x, y: integer; const Image: TFPCustomImage); override; 1034 procedure CheckHelper(AHelper: TFPCanvasHelper); override; 1035 function GetDefaultColor(const ADefaultColorType: TDefaultColorType): TColor; virtual; 1036 protected 1037 function GetClipRect: TRect; override; 1038 procedure SetClipRect(const ARect: TRect); override; 1039 function GetClipping: Boolean; override; 1040 procedure SetClipping(const AValue: boolean); override; 1041 function GetPixel(X,Y: Integer): TColor; virtual; 1042 procedure CreateBrush; virtual; 1043 procedure CreateFont; virtual; 1044 procedure CreateHandle; virtual; 1045 procedure CreatePen; virtual; 1046 procedure CreateRegion; virtual; 1047 procedure DeselectHandles; virtual; 1048 procedure PenChanging(APen: TObject); virtual; 1049 procedure FontChanging(AFont: TObject); virtual; 1050 procedure BrushChanging(ABrush: TObject); virtual; 1051 procedure RegionChanging(ARegion: TObject); virtual; 1052 procedure RealizeAutoRedraw; virtual; 1053 procedure RealizeAntialiasing; virtual; 1054 procedure RequiredState(ReqState: TCanvasState); virtual; 1055 procedure SetHandle(NewHandle: HDC); virtual; 1056 procedure SetInternalPenPos(const Value: TPoint); virtual; 1057 procedure SetPixel(X,Y: Integer; Value: TColor); virtual; 1058 procedure FreeHandle;virtual; 1059 public 1060 constructor Create; 1061 destructor Destroy; override; 1062 procedure Lock; virtual; 1063 function TryLock: Boolean; 1064 procedure Unlock; virtual; 1065 procedure Refresh; virtual; 1066 procedure Changing; virtual; 1067 procedure Changed; virtual; 1068 procedure SaveHandleState; virtual; 1069 procedure RestoreHandleState; virtual; 1070 1071 // extra drawing methods (there are more in the ancestor TFPCustomCanvas) 1072 procedure Arc(ALeft, ATop, ARight, ABottom, Angle16Deg, Angle16DegLength: Integer); virtual; {$IFDEF HasFPCanvas1}reintroduce;{$ENDIF} 1073 procedure Arc(ALeft, ATop, ARight, ABottom, SX, SY, EX, EY: Integer); virtual; {$IFDEF HasFPCanvas1}reintroduce;{$ENDIF} 1074 procedure ArcTo(ALeft, ATop, ARight, ABottom, SX, SY, EX, EY: Integer); virtual; //As Arc(), but updates pen position 1075 procedure AngleArc(X, Y: Integer; Radius: Longword; StartAngle, SweepAngle: Single); 1076 procedure BrushCopy(ADestRect: TRect; ABitmap: TBitmap; ASourceRect: TRect; 1077 ATransparentColor: TColor); virtual; 1078 procedure Chord(x1, y1, x2, y2, 1079 Angle16Deg, Angle16DegLength: Integer); virtual; {$IFDEF HasFPCanvas1}reintroduce;{$ENDIF} 1080 procedure Chord(x1, y1, x2, y2, SX, SY, EX, EY: Integer); virtual; {$IFDEF HasFPCanvas1}reintroduce;{$ENDIF} 1081 procedure CopyRect(const Dest: TRect; SrcCanvas: TCanvas; 1082 const Source: TRect); virtual; 1083 procedure Draw(X,Y: Integer; SrcGraphic: TGraphic); virtual; 1084 procedure DrawFocusRect(const ARect: TRect); virtual; 1085 procedure StretchDraw(const DestRect: TRect; SrcGraphic: TGraphic); virtual; 1086 procedure Ellipse(const ARect: TRect); {$IFDEF HasFPCanvas1}reintroduce;{$ENDIF} 1087 procedure Ellipse(x1, y1, x2, y2: Integer); virtual; {$IFDEF HasFPCanvas1}reintroduce;{$ENDIF} 1088 procedure FillRect(const ARect: TRect); virtual; {$IFDEF HasFPCanvas1}reintroduce;{$ENDIF} 1089 procedure FillRect(X1,Y1,X2,Y2: Integer); {$IFDEF HasFPCanvas1}reintroduce;{$ENDIF} 1090 procedure FloodFill(X, Y: Integer; FillColor: TColor; 1091 FillStyle: TFillStyle); virtual; {$IFDEF HasFPCanvas1}reintroduce;{$ENDIF} 1092 procedure Frame3d(var ARect: TRect; const FrameWidth: integer; 1093 const Style: TGraphicsBevelCut); virtual; 1094 procedure Frame3D(var ARect: TRect; TopColor, BottomColor: TColor; 1095 const FrameWidth: integer); overload; 1096 procedure Frame(const ARect: TRect); virtual; // border using pen 1097 procedure Frame(X1,Y1,X2,Y2: Integer); // border using pen 1098 procedure FrameRect(const ARect: TRect); virtual; // border using brush 1099 procedure FrameRect(X1,Y1,X2,Y2: Integer); // border using brush 1100 function GetTextMetrics(out TM: TLCLTextMetric): boolean; virtual; 1101 procedure GradientFill(ARect: TRect; AStart, AStop: TColor; ADirection: TGradientDirection); 1102 procedure RadialPie(x1, y1, x2, y2, 1103 StartAngle16Deg, Angle16DegLength: Integer); virtual; {$IFDEF HasFPCanvas1}reintroduce;{$ENDIF} 1104 procedure Pie(EllipseX1,EllipseY1,EllipseX2,EllipseY2, 1105 StartX,StartY,EndX,EndY: Integer); virtual; 1106 procedure PolyBezier(Points: PPoint; NumPts: Integer; 1107 Filled: boolean = False; 1108 Continuous: boolean = False); virtual; {$IFDEF HasFPCanvas1}reintroduce;{$ENDIF} 1109 procedure PolyBezier(const Points: array of TPoint; 1110 Filled: boolean = False; 1111 Continuous: boolean = False); {$IFDEF HasFPCanvas1}reintroduce;{$ENDIF} 1112 procedure Polygon(const Points: array of TPoint; 1113 Winding: Boolean; 1114 StartIndex: Integer = 0; 1115 NumPts: Integer = -1); 1116 procedure Polygon(Points: PPoint; NumPts: Integer; 1117 Winding: boolean = False); virtual; 1118 procedure Polygon(const Points: array of TPoint); {$IFDEF HasFPCanvas1}reintroduce;{$ENDIF} 1119 procedure Polyline(const Points: array of TPoint; 1120 StartIndex: Integer; 1121 NumPts: Integer = -1); 1122 procedure Polyline(Points: PPoint; NumPts: Integer); virtual; 1123 procedure Polyline(const Points: array of TPoint); {$IFDEF HasFPCanvas1}reintroduce;{$ENDIF} 1124 procedure Rectangle(X1,Y1,X2,Y2: Integer); virtual; {$IFDEF HasFPCanvas1}reintroduce;{$ENDIF} 1125 procedure Rectangle(const ARect: TRect); {$IFDEF HasFPCanvas1}reintroduce;{$ENDIF} 1126 procedure RoundRect(X1, Y1, X2, Y2: Integer; RX,RY: Integer); virtual; 1127 procedure RoundRect(const Rect: TRect; RX,RY: Integer); 1128 procedure TextOut(X,Y: Integer; const Text: String); virtual; {$IFDEF HasFPCanvas1}reintroduce;{$ENDIF} 1129 procedure TextRect(const ARect: TRect; X, Y: integer; const Text: string); 1130 procedure TextRect(ARect: TRect; X, Y: integer; const Text: string; 1131 const Style: TTextStyle); virtual; 1132 function TextExtent(const Text: string): TSize; virtual; {$IFDEF HasFPCanvas1}reintroduce;{$ENDIF} 1133 function TextHeight(const Text: string): Integer; virtual; {$IFDEF HasFPCanvas1}reintroduce;{$ENDIF} 1134 function TextWidth(const Text: string): Integer; virtual; {$IFDEF HasFPCanvas1}reintroduce;{$ENDIF} 1135 function TextFitInfo(const Text: string; MaxWidth: Integer): Integer; 1136 function HandleAllocated: boolean; virtual; 1137 function GetUpdatedHandle(ReqState: TCanvasState): HDC; virtual; 1138 public 1139 property Pixels[X, Y: Integer]: TColor read GetPixel write SetPixel; 1140 property Handle: HDC read GetHandle write SetHandle; 1141 property TextStyle: TTextStyle read FTextStyle write FTextStyle; 1142 published 1143 property AntialiasingMode: TAntialiasingMode read FAntialiasingMode write SetAntialiasingMode default amDontCare; 1144 property AutoRedraw: Boolean read FAutoRedraw write SetAutoRedraw; 1145 property Brush: TBrush read FLazBrush write SetLazBrush; 1146 property CopyMode: TCopyMode read FCopyMode write FCopyMode default cmSrcCopy; 1147 property Font: TFont read FLazFont write SetLazFont; 1148 property Height: integer read GetHeight; 1149 property Pen: TPen read FLazPen write SetLazPen; 1150 property Region: TRegion read FRegion write SetRegion; 1151 property Width: integer read GetWidth; 1152 property OnChange: TNotifyEvent read FOnChange write FOnChange; 1153 property OnChanging: TNotifyEvent read FOnChanging write FOnChanging; 1154 end; 1155 1156 1157 { TSharedImage - base class for reference counted images } 1158 1159 TSharedImage = class 1160 private 1161 FRefCount: Integer; 1162 protected 1163 procedure Reference; // increase reference count 1164 procedure Release; // decrease reference count 1165 procedure FreeHandle; virtual; abstract; 1166 property RefCount: Integer read FRefCount; 1167 public 1168 function HandleAllocated: boolean; virtual; abstract; 1169 end; 1170 1171 1172 { TCustomBitmapImage 1173 1174 Descendent of TSharedImage for TCustomBitmap. If a TCustomBitmap is assigned to another 1175 TCustomBitmap, only the reference count will be increased and both will share the 1176 same TCustomBitmapImage } 1177 1178 TBitmapHandleType = (bmDIB, bmDDB); 1179 1180 { TSharedCustomBitmap } 1181 1182 { TSharedCustomBitmap is base class used for sharing imagedata for derived 1183 classes of TCustomBitmap. Data can only be shared between classes of the 1184 same type. IE. TBitmap data can only be shared with (descendant of) TBitmap. 1185 Therefore each graphic "end" class should define its own share class. 1186 } 1187 1188 TSharedRasterImage = class(TSharedImage) 1189 private 1190 FHandle: THandle; // generic type, can be HBITMAP or HICON or .... 1191 FBitmapCanvas: TCanvas; // current canvas selected into 1192 FSaveStream: TMemoryStream; 1193 protected 1194 procedure FreeHandle; override; 1195 function ReleaseHandle: THandle; virtual; 1196 function IsEmpty: boolean; virtual; 1197 public 1198 constructor Create; virtual; 1199 procedure CreateDefaultHandle(AWidth, AHeight: Integer; ABPP: Byte); virtual; abstract; 1200 destructor Destroy; override; 1201 function HandleAllocated: boolean; override; 1202 property BitmapCanvas: TCanvas read FBitmapCanvas write FBitmapCanvas; 1203 property SaveStream: TMemoryStream read FSaveStream write FSaveStream; 1204 end; 1205 1206 TSharedRasterImageClass = class of TSharedRasterImage; 1207 1208 { TRasterImage } 1209 1210 TRasterImage = class(TGraphic) 1211 private 1212 FCanvas: TCanvas; 1213 FTransparentColor: TColor; 1214 FTransparentMode: TTransparentMode; 1215 FUpdateCount: Integer; 1216 FUpdateCanvasOnly: Boolean; 1217 FMasked: Boolean; 1218 1219 procedure CanvasChanging(Sender: TObject); 1220 procedure CreateCanvas; 1221 procedure CreateMask(AColor: TColor = clDefault); 1222 procedure FreeCanvasContext; 1223 function GetCanvas: TCanvas; 1224 function GetRawImage: TRawImage; 1225 function GetScanline(ARow: Integer): Pointer; 1226 function GetTransparentColor: TColor; 1227 procedure SetTransparentColor(AValue: TColor); 1228 protected 1229 FSharedImage: TSharedRasterImage; 1230 function CanShareImage(AClass: TSharedRasterImageClass): Boolean; virtual; 1231 procedure Changed(Sender: TObject); override; 1232 function CreateDefaultBitmapHandle(const ADesc: TRawImageDescription): HBITMAP; virtual; 1233 procedure Draw(DestCanvas: TCanvas; const DestRect: TRect); override; 1234 function GetEmpty: Boolean; override; 1235 function GetHandle: THandle; 1236 function GetBitmapHandle: HBITMAP; virtual; abstract; 1237 function GetMasked: Boolean; virtual; 1238 function GetMaskHandle: HBITMAP; virtual; abstract; 1239 function GetMimeType: string; override; 1240 function GetPixelFormat: TPixelFormat; virtual; abstract; 1241 function GetRawImagePtr: PRawImage; virtual; abstract; 1242 function GetRawImageDescriptionPtr: PRawImageDescription; virtual; abstract; 1243 function GetTransparent: Boolean; override; 1244 class function GetSharedImageClass: TSharedRasterImageClass; virtual; 1245 function GetHeight: Integer; override; 1246 function GetWidth: Integer; override; 1247 procedure BitmapHandleNeeded; virtual; 1248 procedure HandleNeeded; virtual; abstract; 1249 procedure MaskHandleNeeded; virtual; abstract; 1250 procedure PaletteNeeded; virtual; abstract; 1251 function InternalReleaseBitmapHandle: HBITMAP; virtual; abstract; 1252 function InternalReleaseMaskHandle: HBITMAP; virtual; abstract; 1253 function InternalReleasePalette: HPALETTE; virtual; abstract; 1254 procedure SetBitmapHandle(AValue: HBITMAP); 1255 procedure SetMasked(AValue: Boolean); virtual; 1256 procedure SetMaskHandle(AValue: HBITMAP); 1257 procedure SetTransparent(AValue: Boolean); override; 1258 procedure UnshareImage(CopyContent: boolean); virtual; abstract; 1259 function UpdateHandles(ABitmap, AMask: HBITMAP): Boolean; virtual; abstract; // called when handles are created from rawimage (true when handle changed) 1260 procedure SaveStreamNeeded; 1261 procedure FreeSaveStream; 1262 procedure ReadData(Stream: TStream); override; 1263 procedure ReadStream(AStream: TMemoryStream; ASize: Longint); virtual; abstract; // loads imagedata into rawimage, this method shouldn't call changed(). 1264 procedure SetSize(AWidth, AHeight: integer); virtual; abstract; 1265 procedure SetHandle(AValue: THandle); virtual; 1266 procedure SetHeight(AHeight: Integer); override; 1267 procedure SetWidth(AWidth: Integer); override; 1268 procedure SetTransparentMode(AValue: TTransparentMode); 1269 procedure SetPixelFormat(AValue: TPixelFormat); virtual; abstract; 1270 procedure WriteData(Stream: TStream); override; 1271 procedure WriteStream(AStream: TMemoryStream); virtual; abstract; 1272 function RequestTransparentColor: TColor; 1273 public 1274 constructor Create; override; 1275 destructor Destroy; override; 1276 procedure Assign(Source: TPersistent); override; 1277 procedure Clear; override; 1278 procedure BeginUpdate(ACanvasOnly: Boolean = False); 1279 procedure EndUpdate(AStreamIsValid: Boolean = False); 1280 procedure FreeImage; virtual; 1281 function BitmapHandleAllocated: boolean; virtual; abstract; 1282 function MaskHandleAllocated: boolean; virtual; abstract; 1283 function PaletteAllocated: boolean; virtual; abstract; 1284 procedure LoadFromBitmapHandles(ABitmap, AMask: HBitmap; ARect: PRect = nil); 1285 procedure LoadFromDevice(DC: HDC); virtual; 1286 procedure LoadFromStream(AStream: TStream); overload; override; 1287 procedure LoadFromStream(AStream: TStream; ASize: Cardinal); overload; virtual; 1288 procedure LoadFromMimeStream(AStream: TStream; const AMimeType: string); override; 1289 procedure LoadFromRawImage(const AIMage: TRawImage; ADataOwner: Boolean); 1290 procedure LoadFromIntfImage(IntfImage: TLazIntfImage); 1291 procedure SaveToStream(AStream: TStream); override; 1292 procedure GetSupportedSourceMimeTypes(List: TStrings); override; 1293 procedure GetSize(out AWidth, AHeight: Integer); 1294 procedure Mask(ATransparentColor: TColor); 1295 procedure SetHandles(ABitmap, AMask: HBITMAP); virtual; abstract; // called when handles are set by user 1296 function ReleaseBitmapHandle: HBITMAP; 1297 function ReleaseMaskHandle: HBITMAP; 1298 function ReleasePalette: HPALETTE; 1299 function CreateIntfImage: TLazIntfImage; 1300 public 1301 property Canvas: TCanvas read GetCanvas; 1302 function HandleAllocated: boolean; 1303 property BitmapHandle: HBITMAP read GetBitmapHandle write SetBitmapHandle; 1304 property Masked: Boolean read GetMasked write SetMasked; 1305 property MaskHandle: HBITMAP read GetMaskHandle write SetMaskHandle; 1306 property PixelFormat: TPixelFormat read GetPixelFormat write SetPixelFormat default pfDevice; 1307 property RawImage: TRawImage read GetRawImage; // be carefull with this, modify only within a begin/endupdate 1308 property ScanLine[Row: Integer]: Pointer read GetScanLine; platform; // Use only when wrpped by a begin/endupdate 1309 property TransparentColor: TColor read GetTransparentColor 1310 write SetTransparentColor default clDefault; 1311 property TransparentMode: TTransparentMode read FTransparentMode 1312 write SetTransparentMode default tmAuto; 1313 end; 1314 1315 TSharedCustomBitmap = class(TSharedRasterImage) 1316 private 1317 FHandleType: TBitmapHandleType; 1318 FImage: TRawImage; 1319 FHasMask: Boolean; // set if atleast one maskpixel is set 1320 FPalette: HPALETTE; 1321 function GetHeight: Integer; 1322 function GetWidth: Integer; 1323 protected 1324 procedure FreeHandle; override; 1325 procedure FreePalette; 1326 procedure FreeImage; 1327 function ReleasePalette: HPALETTE; 1328 function GetPixelFormat: TPixelFormat; 1329 function IsEmpty: boolean; override; 1330 public 1331 constructor Create; override; 1332 destructor Destroy; override; 1333 function HandleAllocated: boolean; override; 1334 function ImageAllocated: boolean; 1335 property HandleType: TBitmapHandleType read FHandleType write FHandleType; 1336 property Height: Integer read GetHeight; 1337 property PixelFormat: TPixelFormat read GetPixelFormat; 1338 property Width: Integer read GetWidth; 1339 end; 1340 1341 { TCustomBitmap 1342 is the data of an image. The image can be loaded from a file, 1343 stream or resource in .bmp (windows bitmap format) or .xpm (XPixMap format) 1344 The loading routine automatically recognizes the format, so it is also used 1345 to load the imagess from Delphi form streams (e.g. .dfm files). 1346 When the handle is created, it is up to the interface (gtk, win32, ...) 1347 to convert it automatically to the best internal format. That is why the 1348 Handle is interface dependent. 1349 To access the raw data, see TLazIntfImage in IntfGraphics.pas } 1350 1351 TCustomBitmap = class(TRasterImage) 1352 private 1353 FPixelFormat: TPixelFormat; 1354 FPixelFormatNeedsUpdate: Boolean; 1355 FMaskHandle: HBITMAP; // mask is not part of the image, so not shared 1356 function GetHandleType: TBitmapHandleType; 1357 function GetMonochrome: Boolean; 1358 procedure SetBitmapHandle(const AValue: HBITMAP); 1359 procedure SetHandleType(AValue: TBitmapHandleType); 1360 procedure SetMonochrome(AValue: Boolean); 1361 procedure UpdatePixelFormat; 1362 protected 1363 procedure MaskHandleNeeded; override; 1364 procedure PaletteNeeded; override; 1365 function CanShareImage(AClass: TSharedRasterImageClass): Boolean; override; 1366 procedure Changed(Sender: TObject); override; 1367 function CreateDefaultBitmapHandle(const ADesc: TRawImageDescription): HBITMAP; override; 1368 procedure FreeMaskHandle; 1369 function GetBitmapHandle: HBITMAP; override; 1370 function GetMaskHandle: HBITMAP; override; 1371 function GetPalette: HPALETTE; override; 1372 function GetPixelFormat: TPixelFormat; override; 1373 function GetRawImagePtr: PRawImage; override; 1374 function GetRawImageDescriptionPtr: PRawImageDescription; override; 1375 procedure HandleNeeded; override; 1376 function InternalReleaseBitmapHandle: HBITMAP; override; 1377 function InternalReleaseMaskHandle: HBITMAP; override; 1378 function InternalReleasePalette: HPALETTE; override; 1379 procedure RawimageNeeded(ADescOnly: Boolean); 1380 procedure SetHandle(AValue: THandle); override; 1381 procedure SetPixelFormat(AValue: TPixelFormat); override; 1382 procedure UnshareImage(CopyContent: boolean); override; 1383 function UpdateHandles(ABitmap, AMask: HBITMAP): Boolean; override; 1384 public 1385 constructor Create; override; 1386 destructor Destroy; override; 1387 procedure Assign(Source: TPersistent); override; 1388 procedure Clear; override; 1389 procedure FreeImage; override; 1390 function LazarusResourceTypeValid(const ResourceType: string): Boolean; override; 1391 function BitmapHandleAllocated: boolean; override; 1392 function MaskHandleAllocated: boolean; override; 1393 function PaletteAllocated: boolean; override; 1394 function ReleaseHandle: HBITMAP; 1395 1396 procedure SetHandles(ABitmap, AMask: HBITMAP); override; 1397 procedure SetSize(AWidth, AHeight: integer); override; 1398 1399 property Handle: HBITMAP read GetBitmapHandle write SetBitmapHandle; // for custombitmap handle = bitmaphandle 1400 property HandleType: TBitmapHandleType read GetHandleType write SetHandleType; 1401 property Monochrome: Boolean read GetMonochrome write SetMonochrome; 1402 end; 1403 1404 { TFPImageBitmap } 1405 { Use this class to easily create a TCustomBitmap descendent for FPImage 1406 reader and writer } 1407 1408 TFPImageBitmap = class(TCustomBitmap) 1409 private 1410 protected 1411 function GetMimeType: string; override; 1412 class function GetReaderClass: TFPCustomImageReaderClass; virtual; abstract; 1413 class function GetWriterClass: TFPCustomImageWriterClass; virtual; abstract; 1414 procedure InitializeReader(AImage: TLazIntfImage; AReader: TFPCustomImageReader); virtual; 1415 procedure InitializeWriter(AImage: TLazIntfImage; AWriter: TFPCustomImageWriter); virtual; 1416 procedure FinalizeReader(AReader: TFPCustomImageReader); virtual; 1417 procedure FinalizeWriter(AWriter: TFPCustomImageWriter); virtual; 1418 procedure ReadStream(AStream: TMemoryStream; ASize: Longint); override; 1419 procedure WriteStream(AStream: TMemoryStream); override; 1420 public 1421 class function GetFileExtensions: string; override; 1422 class function IsStreamFormatSupported(Stream: TStream): Boolean; override; 1423 class function IsFileExtensionSupported(const FileExtension: string): boolean; 1424 function LazarusResourceTypeValid(const ResourceType: string): boolean; override; 1425 end; 1426 1427 TFPImageBitmapClass = class of TFPImageBitmap; 1428 1429 1430 { TSharedBitmap } 1431 1432 TSharedBitmap = class(TSharedCustomBitmap) 1433 end; 1434 1435 { TBitmap } 1436 1437 TBitmap = class(TFPImageBitmap) 1438 protected 1439 procedure InitializeReader(AImage: TLazIntfImage; AReader: TFPCustomImageReader); override; 1440 class function GetReaderClass: TFPCustomImageReaderClass; override; 1441 class function GetWriterClass: TFPCustomImageWriterClass; override; 1442 class function GetSharedImageClass: TSharedRasterImageClass; override; 1443 public 1444 class function GetFileExtensions: string; override; 1445 function GetResourceType: TResourceType; override; 1446 procedure LoadFromStream(AStream: TStream; ASize: Cardinal); override; 1447 end; 1448 1449 1450 { TSharedPixmap } 1451 1452 TSharedPixmap = class(TSharedCustomBitmap) 1453 end; 1454 1455 { TPixmap } 1456 1457 TPixmap = class(TFPImageBitmap) 1458 protected 1459 class function GetReaderClass: TFPCustomImageReaderClass; override; 1460 class function GetWriterClass: TFPCustomImageWriterClass; override; 1461 class function GetSharedImageClass: TSharedRasterImageClass; override; 1462 public 1463 function LazarusResourceTypeValid(const ResourceType: string): boolean; override; 1464 class function GetFileExtensions: string; override; 1465 end; 1466 1467 { TSharedPortableNetworkGraphic } 1468 1469 TSharedPortableNetworkGraphic = class(TSharedCustomBitmap) 1470 end; 1471 1472 { TPortableNetworkGraphic } 1473 1474 TPortableNetworkGraphic = class(TFPImageBitmap) 1475 protected 1476 class function GetReaderClass: TFPCustomImageReaderClass; override; 1477 class function GetWriterClass: TFPCustomImageWriterClass; override; 1478 procedure InitializeWriter(AImage: TLazIntfImage; AWriter: TFPCustomImageWriter); override; 1479 class function GetSharedImageClass: TSharedRasterImageClass; override; 1480 public 1481 class function IsStreamFormatSupported(Stream: TStream): Boolean; override; 1482 class function GetFileExtensions: string; override; 1483 end; 1484 1485 1486 {$IFNDEF DisableLCLPNM} 1487 { TSharedPortableAnyMapGraphic } 1488 1489 TSharedPortableAnyMapGraphic = class(TSharedCustomBitmap) 1490 end; 1491 1492 { TPortableAnyMapGraphic } 1493 1494 TPortableAnyMapGraphic = class(TFPImageBitmap) 1495 protected 1496 class function GetReaderClass: TFPCustomImageReaderClass; override; 1497 class function GetWriterClass: TFPCustomImageWriterClass; override; 1498 class function GetSharedImageClass: TSharedRasterImageClass; override; 1499 public 1500 class function IsStreamFormatSupported(Stream: TStream): Boolean; override; 1501 class function GetFileExtensions: string; override; 1502 end; 1503 {$ENDIF} 1504 1505 TIconImage = class; 1506 TIconImageClass = class of TIconImage; 1507 1508 { TSharedIcon } 1509 1510 TSharedIcon = class(TSharedRasterImage) 1511 private 1512 FImages: TFPList; 1513 protected 1514 procedure FreeHandle; override; 1515 procedure UpdateFromHandle(NewHandle: THandle); virtual; 1516 function IsEmpty: boolean; override; 1517 function GetImage(const AIndex: Integer): TIconImage; 1518 public 1519 constructor Create; override; 1520 destructor Destroy; override; 1521 procedure Clear; 1522 procedure Delete(AIndex: Integer); 1523 function GetIndex(AFormat: TPixelFormat; AHeight, AWidth: Word): Integer; 1524 class function GetImagesClass: TIconImageClass; virtual; 1525 procedure Add(AIconImage: TIconImage); 1526 procedure Sort; 1527 function Count: Integer; 1528 property Images[AIndex: Integer]: TIconImage read GetImage; 1529 end; 1530 1531 { TIconImage } 1532 1533 TIconImage = class 1534 private 1535 FHeight: Word; 1536 FPixelFormat: TPixelFormat; 1537 FWidth: Word; 1538 FImage: TRawImage; 1539 FHandle: HBITMAP; 1540 FMaskHandle: HBITMAP; 1541 FPalette: HPALETTE; 1542 function GetPalette: HPALETTE; 1543 protected 1544 procedure RawImageNeeded(ADescOnly: Boolean); 1545 procedure UpdateFromImage(const AImage: TRawImage); 1546 public 1547 constructor Create(AFormat: TPixelFormat; AHeight, AWidth: Word); 1548 constructor Create(const AImage: TRawImage); 1549 constructor Create(const AInfo: TIconInfo); virtual; 1550 destructor Destroy; override; 1551 1552 function ReleaseHandle: HBITMAP; 1553 function ReleaseMaskHandle: HBITMAP; 1554 function ReleasePalette: HPALETTE; 1555 function UpdateHandles(ABitmap, AMask: HBITMAP): Boolean; 1556 1557 property Height: Word read FHeight; 1558 property Width: Word read FWidth; 1559 property PixelFormat: TPixelFormat read FPixelFormat; 1560 property Handle: HBITMAP read FHandle; 1561 property MaskHandle: HBITMAP read FMaskHandle; 1562 property Palette: HPALETTE read GetPalette; 1563 property RawImage: TRawImage read FImage; 1564 end; 1565 1566 1567 { TIcon } 1568 { 1569 TIcon reads and writes .ICO file format. 1570 A .ico file typically contains several versions of the same image. When loading, 1571 the largest/most colourful image is loaded as the TCustomBitmap and so can be handled 1572 as any other bitmap. Any other versions of the images are available via the 1573 Bitmaps property 1574 Writing is not (yet) implemented. 1575 } 1576 1577 1578 { TCustomIcon } 1579 1580 TCustomIcon = class(TRasterImage) 1581 private 1582 function GetCount: Integer; 1583 procedure SetCurrent(const AValue: Integer); 1584 protected 1585 FCurrent: Integer; 1586 FRequestedSize: TSize; 1587 procedure MaskHandleNeeded; override; 1588 procedure PaletteNeeded; override; 1589 function CanShareImage(AClass: TSharedRasterImageClass): Boolean; override; 1590 procedure CheckRequestedSize; 1591 function GetIndex(AFormat: TPixelFormat; AHeight, AWidth: Word): Integer; 1592 function GetBitmapHandle: HBITMAP; override; 1593 class function GetDefaultSize: TSize; virtual; 1594 function GetMaskHandle: HBITMAP; override; 1595 function GetPalette: HPALETTE; override; 1596 function GetPixelFormat: TPixelFormat; override; 1597 function GetRawImagePtr: PRawImage; override; 1598 function GetRawImageDescriptionPtr: PRawImageDescription; override; 1599 function GetTransparent: Boolean; override; 1600 class function GetSharedImageClass: TSharedRasterImageClass; override; 1601 class function GetStreamSignature: Cardinal; virtual; 1602 class function GetTypeID: Word; virtual; 1603 procedure HandleNeeded; override; 1604 function InternalReleaseBitmapHandle: HBITMAP; override; 1605 function InternalReleaseMaskHandle: HBITMAP; override; 1606 function InternalReleasePalette: HPALETTE; override; 1607 procedure ReadData(Stream: TStream); override; 1608 procedure ReadStream(AStream: TMemoryStream; ASize: Longint); override; 1609 procedure SetMasked(AValue: Boolean); override; 1610 procedure SetPixelFormat(AValue: TPixelFormat); override; 1611 procedure SetTransparent(Value: Boolean); override; 1612 procedure UnshareImage(CopyContent: boolean); override; 1613 procedure UpdateCurrentView; 1614 procedure SetHandle(AValue: THandle); override; 1615 function UpdateHandle(AValue: HICON): Boolean; virtual; 1616 function UpdateHandles(ABitmap, AMask: HBITMAP): Boolean; override; 1617 procedure WriteStream(AStream: TMemoryStream); override; 1618 public 1619 constructor Create; override; 1620 1621 procedure Add(AFormat: TPixelFormat; AHeight, AWidth: Word); 1622 procedure Assign(Source: TPersistent); override; 1623 procedure AssignImage(ASource: TRasterImage); virtual; 1624 procedure Clear; override; 1625 procedure Delete(Aindex: Integer); 1626 procedure Remove(AFormat: TPixelFormat; AHeight, AWidth: Word); 1627 procedure GetDescription(Aindex: Integer; out AFormat: TPixelFormat; out AHeight, AWidth: Word); 1628 procedure SetSize(AWidth, AHeight: integer); override; 1629 class function GetFileExtensions: string; override; 1630 function LazarusResourceTypeValid(const ResourceType: string): boolean; override; 1631 procedure LoadFromResourceName(Instance: THandle; const ResName: String); override; 1632 procedure LoadFromResourceID(Instance: THandle; ResID: PtrInt); override; 1633 procedure LoadFromResourceHandle(Instance: THandle; ResHandle: TFPResourceHandle); virtual; 1634 function BitmapHandleAllocated: boolean; override; 1635 function MaskHandleAllocated: boolean; override; 1636 function PaletteAllocated: boolean; override; 1637 procedure SetHandles(ABitmap, AMask: HBITMAP); override; 1638 procedure Sort; 1639 function GetBestIndexForSize(ASize: TSize): Integer; 1640 1641 property Current: Integer read FCurrent write SetCurrent; 1642 property Count: Integer read GetCount; 1643 end; 1644 1645 { TIcon } 1646 1647 TIcon = class(TCustomIcon) 1648 private 1649 function GetIconHandle: HICON; 1650 procedure SetIconHandle(const AValue: HICON); 1651 protected 1652 class function GetStreamSignature: Cardinal; override; 1653 class function GetTypeID: Word; override; 1654 procedure HandleNeeded; override; 1655 public 1656 procedure LoadFromResourceHandle(Instance: THandle; ResHandle: TFPResourceHandle); override; 1657 function ReleaseHandle: HICON; 1658 function GetResourceType: TResourceType; override; 1659 property Handle: HICON read GetIconHandle write SetIconHandle; 1660 end; 1661 1662 TIcnsRec = record 1663 IconType: TicnsIconType; 1664 RawImage: TRawImage; 1665 end; 1666 PIcnsRec = ^TIcnsRec; 1667 1668 { TIcnsList } 1669 1670 TIcnsList = class(TList) 1671 private 1672 function GetItem(Index: Integer): PIcnsRec; 1673 procedure SetItem(Index: Integer; const AValue: PIcnsRec); 1674 protected 1675 procedure Notify(Ptr: Pointer; Action: TListNotification); override; 1676 public 1677 function Add(AIconType: TicnsIconType; ARawImage: TRawImage): Integer; reintroduce; 1678 property Items[Index: Integer]: PIcnsRec read GetItem write SetItem; default; 1679 end; 1680 1681 TSharedIcnsIcon = class(TSharedIcon) 1682 end; 1683 1684 { TIcnsIcon } 1685 1686 TIcnsIcon = class(TCustomIcon) 1687 private 1688 FImageList: TIcnsList; 1689 FMaskList: TIcnsList; 1690 procedure IcnsAdd(AIconType: TicnsIconType; ARawImage: TRawImage); 1691 procedure IcnsProcess; 1692 protected 1693 class function GetSharedImageClass: TSharedRasterImageClass; override; 1694 procedure ReadData(Stream: TStream); override; 1695 procedure ReadStream(AStream: TMemoryStream; ASize: Longint); override; 1696 procedure WriteStream(AStream: TMemoryStream); override; 1697 public 1698 constructor Create; override; 1699 destructor Destroy; override; 1700 1701 class function GetFileExtensions: string; override; 1702 function LazarusResourceTypeValid(const ResourceType: string): boolean; override; 1703 end; 1704 1705 { TSharedCursorImage } 1706 1707 TSharedCursorImage = class(TSharedIcon) 1708 protected 1709 procedure FreeHandle; override; 1710 public 1711 class function GetImagesClass: TIconImageClass; override; 1712 end; 1713 1714 { TCursorImageImage } 1715 1716 TCursorImageImage = class(TIconImage) 1717 private 1718 FHotSpot: TPoint; 1719 public 1720 constructor Create(const AInfo: TIconInfo); override; 1721 property HotSpot: TPoint read FHotSpot write FHotSpot; 1722 end; 1723 1724 { TCursorImage } 1725 TCursorImage = class(TCustomIcon) 1726 private 1727 function GetHotSpot: TPoint; 1728 procedure SetHotSpot(const P: TPoint); 1729 function GetCursorHandle: HCURSOR; 1730 procedure SetCursorHandle(AValue: HCURSOR); 1731 protected 1732 procedure HandleNeeded; override; 1733 class function GetDefaultSize: TSize; override; 1734 class function GetStreamSignature: Cardinal; override; 1735 class function GetSharedImageClass: TSharedRasterImageClass; override; 1736 class function GetTypeID: Word; override; 1737 public 1738 class function GetFileExtensions: string; override; 1739 function GetResourceType: TResourceType; override; 1740 procedure LoadFromResourceHandle(Instance: THandle; ResHandle: TFPResourceHandle); override; 1741 function LazarusResourceTypeValid(const ResourceType: string): boolean; override; 1742 function ReleaseHandle: HCURSOR; 1743 procedure SetCenterHotSpot; 1744 property HotSpot: TPoint read GetHotSpot write SetHotSpot; 1745 property Handle: HCURSOR read GetCursorHandle write SetCursorHandle; 1746 end; 1747 1748 1749 {$IFNDEF DisableLCLJPEG} 1750 { TSharedJpegImage } 1751 1752 TSharedJpegImage = class(TSharedCustomBitmap) 1753 end; 1754 1755 { TJpegImage } 1756 1757 TJPEGQualityRange = TFPJPEGCompressionQuality; 1758 TJPEGPerformance = TJPEGReadPerformance; 1759 1760 TJPEGImage = class(TFPImageBitmap) 1761 private 1762 FGrayScale: Boolean; 1763 FPerformance: TJPEGPerformance; 1764 FProgressiveEncoding: boolean; 1765 FQuality: TJPEGQualityRange; 1766 protected 1767 procedure InitializeReader(AImage: TLazIntfImage; AReader: TFPCustomImageReader); override; 1768 procedure InitializeWriter(AImage: TLazIntfImage; AWriter: TFPCustomImageWriter); override; 1769 procedure FinalizeReader(AReader: TFPCustomImageReader); override; 1770 class function GetReaderClass: TFPCustomImageReaderClass; override; 1771 class function GetWriterClass: TFPCustomImageWriterClass; override; 1772 class function GetSharedImageClass: TSharedRasterImageClass; override; 1773 public 1774 constructor Create; override; 1775 class function IsStreamFormatSupported(Stream: TStream): Boolean; override; 1776 class function GetFileExtensions: string; override; 1777 public 1778 property CompressionQuality: TJPEGQualityRange read FQuality write FQuality; 1779 property GrayScale: Boolean read FGrayScale; 1780 property ProgressiveEncoding: boolean read FProgressiveEncoding; 1781 property Performance: TJPEGPerformance read FPerformance write FPerformance; 1782 end; 1783 {$ENDIF} 1784 1785 {$IFNDEF DisableLCLTIFF} 1786 { TSharedTiffImage } 1787 1788 TSharedTiffImage = class(TSharedCustomBitmap) 1789 end; 1790 1791 { TTiffImage } 1792 1793 TTiffUnit = ( 1794 tuUnknown, 1795 tuNone, // No absolute unit of measurement. Used for images that may have a non-square 1796 // aspect ratio, but no meaningful absolute dimensions. 1797 tuInch, 1798 tuCentimeter 1799 ); 1800 1801 TTiffImage = class(TFPImageBitmap) 1802 private 1803 FArtist: string; 1804 FCopyright: string; 1805 FDateTime: TDateTime; 1806 FDocumentName: string; 1807 FHostComputer: string; 1808 FImageDescription: string; 1809 FMake: string; {ScannerManufacturer} 1810 FModel: string; {Scanner} 1811 FResolutionUnit: TTiffUnit; 1812 FSoftware: string; 1813 FXResolution: TTiffRational; 1814 FYResolution: TTiffRational; 1815 protected 1816 procedure InitializeReader(AImage: TLazIntfImage; AReader: TFPCustomImageReader); override; 1817 procedure InitializeWriter(AImage: TLazIntfImage; AWriter: TFPCustomImageWriter); override; 1818 procedure FinalizeReader(AReader: TFPCustomImageReader); override; 1819 class function GetReaderClass: TFPCustomImageReaderClass; override; 1820 class function GetWriterClass: TFPCustomImageWriterClass; override; 1821 class function GetSharedImageClass: TSharedRasterImageClass; override; 1822 public 1823 constructor Create; override; 1824 class function GetFileExtensions: string; override; 1825 public 1826 property Artist: string read FArtist write FArtist; 1827 property Copyright: string read FCopyright write FCopyright; 1828 property DateTime: TDateTime read FDateTime write FDateTime; 1829 property DocumentName: string read FDocumentName write FDocumentName; 1830 property HostComputer: string read FHostComputer write FHostComputer; 1831 property ImageDescription: string read FImageDescription write FImageDescription; 1832// property ImageIsMask: Boolean; 1833// property ImageIsPage: Boolean; 1834// property ImageIsThumbNail: Boolean; 1835 property Make: string read FMake write FMake; 1836 property Model: string read FModel write FModel; 1837 property ResolutionUnit: TTiffUnit read FResolutionUnit write FResolutionUnit; 1838 property Software: string read FSoftware write FSoftware; 1839 property XResolution: TTiffRational read FXResolution write FXResolution; 1840 property YResolution: TTiffRational read FYResolution write FYResolution; 1841 end; 1842 {$ENDIF} 1843 1844 {$IFNDEF DisableLCLGIF} 1845 { TSharedGIFImage } 1846 1847 TSharedGIFImage = class(TSharedCustomBitmap) 1848 end; 1849 1850 { TGIFImage } 1851 1852 TGIFImage = class(TFPImageBitmap) 1853 private 1854 FTransparent: Boolean; 1855 FInterlaced: Boolean; 1856 FBitsPerPixel: byte; 1857 protected 1858 procedure InitializeReader(AImage: TLazIntfImage; AReader: TFPCustomImageReader); override; 1859 procedure FinalizeReader(AReader: TFPCustomImageReader); override; 1860 class function GetReaderClass: TFPCustomImageReaderClass; override; 1861 class function GetSharedImageClass: TSharedRasterImageClass; override; 1862 public 1863 constructor Create; override; 1864 class function IsStreamFormatSupported(Stream: TStream): Boolean; override; 1865 class function GetFileExtensions: string; override; 1866 public 1867 property Transparent: Boolean read FTransparent; 1868 property Interlaced: Boolean read FInterlaced; 1869 property BitsPerPixel: byte read FBitsPerPixel; 1870 end; 1871 {$ENDIF} 1872 1873function GraphicFilter(GraphicClass: TGraphicClass): string; 1874function GraphicExtension(GraphicClass: TGraphicClass): string; 1875function GraphicFileMask(GraphicClass: TGraphicClass): string; 1876function GetGraphicClassForFileExtension(const FileExt: string): TGraphicClass; 1877 1878type 1879 // Color / Identifier mapping 1880 TGetColorStringProc = procedure(const s: AnsiString) of object; 1881 1882function IdentEntry(Entry: Longint; out MapEntry: TIdentMapEntry): boolean; 1883function ColorToIdent(Color: Longint; out Ident: String): Boolean; 1884function IdentToColor(const Ident: string; out Color: Longint): Boolean; 1885function ColorIndex(Color: Longint; out Index: Integer): Boolean; 1886function SysColorToSysColorIndex(Color: TColor): integer; 1887function ColorToRGB(Color: TColor): Longint; 1888function ColorToString(Color: TColor): AnsiString; 1889function StringToColor(const S: shortstring): TColor; 1890function StringToColorDef(const S: shortstring; const DefaultValue: TColor): TColor; 1891procedure GetColorValues(Proc: TGetColorStringProc); 1892function InvertColor(AColor: TColor): TColor; 1893function DecColor(AColor: TColor; AQuantity: Byte): TColor; 1894function IsSysColor(AColor: TColorRef): Boolean; 1895 1896function Blue(rgb: TColorRef): BYTE; // does not work on system color 1897function Green(rgb: TColorRef): BYTE; // does not work on system color 1898function Red(rgb: TColorRef): BYTE; // does not work on system color 1899function RGBToColor(R, G, B: Byte): TColor; 1900procedure RedGreenBlue(rgb: TColorRef; out Red, Green, Blue: Byte); // does not work on system color 1901function FPColorToTColorRef(const FPColor: TFPColor): TColorRef; 1902function FPColorToTColor(const FPColor: TFPColor): TColor; 1903function TColorToFPColor(const c: TColorRef): TFPColor; overload; 1904function TColorToFPColor(const c: TColor): TFPColor; overload; // does not work on system color 1905 1906// fonts 1907procedure GetCharsetValues(Proc: TGetStrProc); 1908function CharsetToIdent(Charset: Longint; out Ident: string): Boolean; 1909function IdentToCharset(const Ident: string; out Charset: Longint): Boolean; 1910function GetFontData(Font: HFont): TFontData; 1911 1912function GetDefFontCharSet: TFontCharSet; 1913function IsFontNameXLogicalFontDesc(const LongFontName: string): boolean; 1914function XLFDNameToLogFont(const XLFDName: string): TLogFont; 1915function ExtractXLFDItem(const XLFDName: string; Index: integer): string; 1916function ExtractFamilyFromXLFDName(const XLFDName: string): string; 1917function ClearXLFDItem(const LongFontName: string; Index: integer): string; 1918function ClearXLFDHeight(const LongFontName: string): string; 1919function ClearXLFDPitch(const LongFontName: string): string; 1920function ClearXLFDStyle(const LongFontName: string): string; 1921function XLFDHeightIsSet(const LongFontName: string): boolean; 1922procedure FontNameToPangoFontDescStr(const LongFontName: string; 1923 out aFamily,aStyle:String; out aSize: Integer; out aSizeInPixels: Boolean); 1924 1925// graphics 1926type 1927 TOnLoadGraphicFromClipboardFormat = 1928 procedure(Dest: TGraphic; ClipboardType: TClipboardType; 1929 FormatID: TClipboardFormat); 1930 TOnSaveGraphicToClipboardFormat = 1931 procedure(Src: TGraphic; ClipboardType: TClipboardType; 1932 FormatID: TClipboardFormat); 1933 TOnGetSystemFont = function: HFONT; 1934 1935var 1936 OnLoadSaveClipBrdGraphicValid: boolean = false; 1937 OnLoadGraphicFromClipboardFormat: TOnLoadGraphicFromClipboardFormat=nil; 1938 OnSaveGraphicToClipboardFormat: TOnSaveGraphicToClipboardFormat=nil; 1939 OnGetSystemFont: TOnGetSystemFont = nil; 1940 1941function TestStreamIsBMP(const AStream: TStream): boolean; 1942function TestStreamIsXPM(const AStream: TStream): boolean; 1943function TestStreamIsIcon(const AStream: TStream): boolean; 1944function TestStreamIsCursor(const AStream: TStream): boolean; 1945 1946function XPMToPPChar(const XPM: string): PPChar; 1947function LazResourceXPMToPPChar(const ResourceName: string): PPChar; 1948function ReadXPMFromStream(Stream: TStream; Size: integer): PPChar; 1949function ReadXPMSize(XPM: PPChar; var Width, Height, ColorCount: integer): boolean; 1950function LoadCursorFromLazarusResource(ACursorName: String): HCursor; 1951function LoadBitmapFromLazarusResource(const ResourceName: String): TBitmap; deprecated; 1952function LoadBitmapFromLazarusResourceHandle(Handle: TLResource): TBitmap; deprecated; 1953 1954// technically a bitmap is created and not loaded 1955function CreateGraphicFromResourceName(Instance: THandle; const ResName: String): TGraphic; 1956function CreateBitmapFromResourceName(Instance: THandle; const ResName: String): TCustomBitmap; 1957function CreateBitmapFromLazarusResource(const AName: String): TCustomBitmap; 1958function CreateBitmapFromLazarusResource(const AName: String; AMinimumClass: TCustomBitmapClass): TCustomBitmap; 1959function CreateBitmapFromLazarusResource(AHandle: TLResource): TCustomBitmap; 1960function CreateBitmapFromLazarusResource(AHandle: TLResource; AMinimumClass: TCustomBitmapClass): TCustomBitmap; 1961 1962function CreateCompatibleBitmaps(const ARawImage: TRawImage; out ABitmap, AMask: HBitmap; ASkipMask: Boolean = False): Boolean; 1963 1964function CreateBitmapFromFPImage(Img: TFPCustomImage): TBitmap; 1965function AllocPatternBitmap(colorBG, colorFG: TColor): TBitmap; 1966 1967 1968var 1969 { Stores information about the current screen 1970 - initialized on Interface startup } 1971 ScreenInfo: TScreenInfo = ( 1972 PixelsPerInchX: 72; 1973 PixelsPerInchY: 72; 1974 ColorDepth: 24; 1975 Initialized: False; 1976 ); 1977 1978 FontResourceCache: TFontHandleCache; 1979 PenResourceCache: TPenHandleCache; 1980 BrushResourceCache: TBrushHandleCache; 1981 1982const 1983 FontCharsets: array[0..18] of TIdentMapEntry = ( 1984 (Value: ANSI_CHARSET; Name: 'ANSI_CHARSET'), 1985 (Value: DEFAULT_CHARSET; Name: 'DEFAULT_CHARSET'), 1986 (Value: SYMBOL_CHARSET; Name: 'SYMBOL_CHARSET'), 1987 (Value: MAC_CHARSET; Name: 'MAC_CHARSET'), 1988 (Value: SHIFTJIS_CHARSET; Name: 'SHIFTJIS_CHARSET'), 1989 (Value: HANGEUL_CHARSET; Name: 'HANGEUL_CHARSET'), 1990 (Value: JOHAB_CHARSET; Name: 'JOHAB_CHARSET'), 1991 (Value: GB2312_CHARSET; Name: 'GB2312_CHARSET'), 1992 (Value: CHINESEBIG5_CHARSET; Name: 'CHINESEBIG5_CHARSET'), 1993 (Value: GREEK_CHARSET; Name: 'GREEK_CHARSET'), 1994 (Value: TURKISH_CHARSET; Name: 'TURKISH_CHARSET'), 1995 (Value: VIETNAMESE_CHARSET; Name: 'VIETNAMESE_CHARSET'), 1996 (Value: HEBREW_CHARSET; Name: 'HEBREW_CHARSET'), 1997 (Value: ARABIC_CHARSET; Name: 'ARABIC_CHARSET'), 1998 (Value: BALTIC_CHARSET; Name: 'BALTIC_CHARSET'), 1999 (Value: RUSSIAN_CHARSET; Name: 'RUSSIAN_CHARSET'), 2000 (Value: THAI_CHARSET; Name: 'THAI_CHARSET'), 2001 (Value: EASTEUROPE_CHARSET; Name: 'EASTEUROPE_CHARSET'), 2002 (Value: OEM_CHARSET; Name: 'OEM_CHARSET')); 2003 2004 2005(*************************************************************************** 2006 ***************************************************************************) 2007 2008function DbgS(const Style: TFontStyles): string; overload; 2009 2010function ScaleX(const SizeX, FromDPI: Integer): Integer; 2011function ScaleY(const SizeY, FromDPI: Integer): Integer; 2012 2013procedure Register; 2014procedure UpdateHandleObjects; 2015 2016implementation 2017 2018uses 2019 SyncObjs, LCLIntf, InterfaceBase; 2020 2021var 2022 GraphicsUpdateCount: Integer = 0; 2023 UpdateLock: TCriticalSection; 2024 2025procedure UpdateHandleObjects; 2026begin 2027 // renew all brushes, pens, fonts, ... 2028 UpdateLock.Enter; 2029 try 2030 if GraphicsUpdateCount=High(GraphicsUpdateCount) then 2031 GraphicsUpdateCount:=Low(GraphicsUpdateCount); 2032 inc(GraphicsUpdateCount); 2033 // at moment update only brushes, but later maybe we will need to update others 2034 // don't clear BrushResourceCache because TBrush instances have references to cache items 2035 // BrushResourceCache.Clear; 2036 finally 2037 UpdateLock.Leave; 2038 end; 2039end; 2040 2041function DbgS(const Style: TFontStyles): string; 2042 2043 procedure Add(const s: string); 2044 begin 2045 if Result<>'' then Result:=Result+','; 2046 Result:=Result+s; 2047 end; 2048 2049begin 2050 Result:=''; 2051 if fsBold in Style then Add('fsBold'); 2052 if fsItalic in Style then Add('fsItalic'); 2053 if fsStrikeOut in Style then Add('fsStrikeOut'); 2054 if fsUnderline in Style then Add('fsUnderline'); 2055 Result:='['+Result+']'; 2056end; 2057 2058function LoadCursorFromLazarusResource(ACursorName: String): HCursor; 2059var 2060 CursorImage: TCursorImage; 2061begin 2062 CursorImage := TCursorImage.Create; 2063 try 2064 CursorImage.LoadFromLazarusResource(ACursorName); 2065 Result := CursorImage.ReleaseHandle; 2066 finally 2067 CursorImage.Free; 2068 end; 2069end; 2070 2071function LocalLoadBitmap(hInstance: THandle; lpBitmapName: PChar): HBitmap; 2072var 2073 Bmp: TBitmap; 2074begin 2075 Bmp := TBitmap.Create; 2076 try 2077 if PtrUInt(lpBitmapName) > High(Word) 2078 then Bmp.LoadFromResourceName(hInstance, lpBitmapName) 2079 else Bmp.LoadFromResourceID(hInstance, PtrInt(lpBitmapName)); 2080 Result := Bmp.ReleaseHandle; 2081 finally 2082 Bmp.Free; 2083 end; 2084end; 2085 2086function LocalLoadCursor(hInstance: THandle; lpCursorName: PChar): HCursor; 2087var 2088 Cur: TCursorImage; 2089begin 2090 Cur := TCursorImage.Create; 2091 try 2092 if PtrUInt(lpCursorName) > High(Word) 2093 then Cur.LoadFromResourceName(hInstance, lpCursorName) 2094 else Cur.LoadFromResourceID(hInstance, PtrInt(lpCursorName)); 2095 Result := Cur.ReleaseHandle; 2096 finally 2097 Cur.Free; 2098 end; 2099end; 2100 2101function LocalLoadIcon(hInstance: THandle; lpIconName: PChar): HIcon; 2102var 2103 Ico: TIcon; 2104begin 2105 Ico := TIcon.Create; 2106 try 2107 if PtrUInt(lpIconName) > High(Word) 2108 then Ico.LoadFromResourceName(hInstance, lpIconName) 2109 else Ico.LoadFromResourceID(hInstance, PtrInt(lpIconName)); 2110 Result := Ico.ReleaseHandle; 2111 finally 2112 Ico.Free; 2113 end; 2114end; 2115 2116function CreateBitmapFromLazarusResource(AStream: TLazarusResourceStream; AMinimumClass: TCustomBitmapClass): TCustomBitmap; 2117var 2118 GraphicClass: TGraphicClass; 2119begin 2120 Result := nil; 2121 if AStream = nil then Exit; 2122 2123 GraphicClass := GetGraphicClassForFileExtension(AStream.Res.ValueType); 2124 if GraphicClass = nil then Exit; 2125 if not GraphicClass.InheritsFrom(AMinimumClass) then Exit; 2126 2127 Result := TCustomBitmap(GraphicClass.Create); 2128 try 2129 Result.LoadFromStream(AStream); 2130 except 2131 Result.Free; 2132 Result := nil; 2133 raise; 2134 end; 2135end; 2136 2137function CreateBitmapFromLazarusResource(const AName: String): TCustomBitmap; 2138begin 2139 Result := CreateBitmapFromLazarusResource(AName, TCustomBitmap); 2140end; 2141 2142function CreateBitmapFromLazarusResource(const AName: String; AMinimumClass: TCustomBitmapClass): TCustomBitmap; 2143var 2144 Stream: TLazarusResourceStream; 2145begin 2146 Stream := TLazarusResourceStream.Create(AName, nil); 2147 try 2148 Result := CreateBitmapFromLazarusResource(Stream, AMinimumClass); 2149 finally 2150 Stream.Free; 2151 end; 2152end; 2153 2154function CreateBitmapFromLazarusResource(AHandle: TLResource): TCustomBitmap; 2155begin 2156 Result := CreateBitmapFromLazarusResource(AHandle, TCustomBitmap); 2157end; 2158 2159function CreateBitmapFromLazarusResource(AHandle: TLResource; AMinimumClass: TCustomBitmapClass): TCustomBitmap; 2160var 2161 Stream: TLazarusResourceStream; 2162begin 2163 Stream := TLazarusResourceStream.CreateFromHandle(AHandle); 2164 try 2165 Result := CreateBitmapFromLazarusResource(Stream, AMinimumClass); 2166 finally 2167 Stream.Free; 2168 end; 2169end; 2170 2171function LoadBitmapFromLazarusResourceHandle(Handle: TLResource): TBitmap; 2172var 2173 CB: TCustomBitmap; 2174begin 2175 CB := CreateBitmapFromLazarusResource(Handle, TCustomBitmap); 2176 if CB is TBitmap 2177 then begin 2178 Result := TBitmap(CB); 2179 Exit; 2180 end; 2181 2182 Result := TBitmap.Create; 2183 Result.Assign(CB); 2184 CB.Free; 2185end; 2186 2187function LoadBitmapFromLazarusResource(const ResourceName: String): TBitmap; 2188var 2189 CB: TCustomBitmap; 2190begin 2191 CB := CreateBitmapFromLazarusResource(ResourceName, TCustomBitmap); 2192 2193 if CB is TBitmap 2194 then begin 2195 Result := TBitmap(CB); 2196 Exit; 2197 end; 2198 2199 Result := TBitmap.Create; 2200 Result.Assign(CB); 2201 CB.Free; 2202end; 2203 2204//TODO: publish ?? (as RawImage_CreateCompatibleBitmaps) 2205function CreateCompatibleBitmaps(const ARawImage: TRawImage; out ABitmap, AMask: HBitmap; ASkipMask: Boolean = False): Boolean; 2206var 2207 Desc: TRawImageDescription absolute ARawimage.Description; 2208 2209 ImagePtr: PRawImage; 2210 DevImage: TRawImage; 2211 DevDesc: TRawImageDescription; 2212 SrcImage, DstImage: TLazIntfImage; 2213 QueryFlags: TRawImageQueryFlags; 2214 W, H: Integer; 2215begin 2216 W := Desc.Width; 2217 if W < 1 then W := 1; 2218 H := Desc.Height; 2219 if H < 1 then H := 1; 2220 2221 if Desc.Depth = 1 2222 then QueryFlags := [riqfMono] 2223 else QueryFlags := [riqfRGB]; 2224 if Desc.AlphaPrec <> 0 2225 then Include(QueryFlags, riqfAlpha); 2226 if Desc.MaskBitsPerPixel <> 0 2227 then Include(QueryFlags, riqfMask); 2228 QueryDescription(DevDesc, QueryFlags, W, H); 2229 2230 if DevDesc.IsEqual(Desc) 2231 then begin 2232 // image is compatible, so use it 2233 DstImage := nil; 2234 ImagePtr := @ARawImage; 2235 end 2236 else begin 2237 // create compatible copy 2238 SrcImage := TLazIntfImage.Create(ARawImage, False); 2239 DstImage := TLazIntfImage.Create(0,0,[]); 2240 // create mask for alphachannel when device has no alpha support 2241 if (DevDesc.AlphaPrec = 0) and (riqfAlpha in QueryFlags) 2242 then begin 2243 //add mask if not already queried 2244 if not (riqfMask in QueryFlags) 2245 then QueryDescription(DevDesc, [riqfMask, riqfUpdate]); 2246 DstImage.DataDescription := DevDesc; 2247 DstImage.CopyPixels(SrcImage, 0, 0, True, $8000); 2248 end 2249 else begin 2250 // update DevDesc because of unusual bitmaps. issue #12362 2251 // widgetset can provide same DevDesc, but also can change it 2252 // like gtk/gtk2 does since it expects XBM format for mono bitmaps. 2253 if DevDesc.Depth = 1 then 2254 begin 2255 QueryFlags := QueryFlags + [riqfUpdate]; 2256 QueryDescription(DevDesc, QueryFlags); 2257 end; 2258 DstImage.DataDescription := DevDesc; 2259 DstImage.CopyPixels(SrcImage); 2260 end; 2261 SrcImage.Free; 2262 DstImage.GetRawImage(DevImage); 2263 ImagePtr := @DevImage; 2264 end; 2265 2266 try 2267 Result := RawImage_CreateBitmaps(ImagePtr^, ABitmap, AMask, ASkipMask); 2268 finally 2269 DstImage.Free; 2270 end; 2271end; 2272 2273function CreateBitmapFromFPImage(Img: TFPCustomImage): TBitmap; 2274var 2275 IntfImg: TLazIntfImage; 2276 ok: Boolean; 2277begin 2278 Result:=nil; 2279 IntfImg:=nil; 2280 ok:=false; 2281 try 2282 Result:=TBitmap.Create; 2283 IntfImg:=Result.CreateIntfImage; 2284 IntfImg.SetSize(Img.Width,Img.Height); 2285 IntfImg.CopyPixels(Img); 2286 Result.LoadFromIntfImage(IntfImg); 2287 ok:=true; 2288 finally 2289 if not ok then FreeAndNil(Result); 2290 IntfImg.Free; 2291 end; 2292end; 2293 2294function ScaleX(const SizeX, FromDPI: Integer): Integer; 2295begin 2296 Result := MulDiv(SizeX, ScreenInfo.PixelsPerInchX, FromDPI); 2297end; 2298 2299function ScaleY(const SizeY, FromDPI: Integer): Integer; 2300begin 2301 Result := MulDiv(SizeY, ScreenInfo.PixelsPerInchY, FromDPI); 2302end; 2303 2304procedure Register; 2305begin 2306 RegisterClasses([TBitmap,TPixmap,TPortableNetworkGraphic, 2307 {$IFNDEF DisableLCLPNM}TPortableAnyMapGraphic,{$ENDIF} 2308 {$IFNDEF DisableLCLJPEG}TJpegImage,{$ENDIF} 2309 {$IFNDEF DisableLCLGIF}TGIFImage,{$ENDIF} 2310 TPicture, 2311 TFont,TPen,TBrush,TRegion]); 2312end; 2313 2314const 2315 GraphicsFinalized: boolean = false; 2316 2317type 2318 TBitmapCanvas = class(TCanvas) 2319 private 2320 FImage: TRasterImage; 2321 FOldBitmap: HBITMAP; 2322 FOldPalette: HPALETTE; 2323 procedure FreeDC; // called by TCustomBitmap.FreeCanvasContext 2324 protected 2325 procedure CreateHandle; override; 2326 public 2327 constructor Create(AImage: TRasterImage); 2328 destructor Destroy; override; 2329 end; 2330 2331 2332{ Color mapping routines } 2333 2334const 2335 FirstDeprecatedColorIndex = 53; 2336 LastDeprecatedColorIndex = 106; 2337 Colors: array[0..106] of TIdentMapEntry = ( 2338 // standard colors 2339 (Value: clBlack; Name: 'clBlack'), 2340 (Value: clMaroon; Name: 'clMaroon'), 2341 (Value: clGreen; Name: 'clGreen'), 2342 (Value: clOlive; Name: 'clOlive'), 2343 (Value: clNavy; Name: 'clNavy'), 2344 (Value: clPurple; Name: 'clPurple'), 2345 (Value: clTeal; Name: 'clTeal'), 2346 (Value: clGray; Name: 'clGray'), 2347 (Value: clSilver; Name: 'clSilver'), 2348 (Value: clRed; Name: 'clRed'), 2349 (Value: clLime; Name: 'clLime'), 2350 (Value: clYellow; Name: 'clYellow'), 2351 (Value: clBlue; Name: 'clBlue'), 2352 (Value: clFuchsia; Name: 'clFuchsia'), 2353 (Value: clAqua; Name: 'clAqua'), 2354 (Value: clWhite; Name: 'clWhite'), 2355 2356 // extended colors 2357 (Value: clMoneyGreen; Name: 'clMoneyGreen'), 2358 (Value: clSkyBlue; Name: 'clSkyBlue'), 2359 (Value: clCream; Name: 'clCream'), 2360 (Value: clMedGray; Name: 'clMedGray'), 2361 2362 // special colors 2363 (Value: clNone; Name: 'clNone'), 2364 (Value: clDefault; Name: 'clDefault'), 2365 2366 // system colors 2367 (Value: clScrollBar; Name: 'clScrollBar'), 2368 (Value: clBackground; Name: 'clBackground'), 2369 (Value: clActiveCaption; Name: 'clActiveCaption'), 2370 (Value: clInactiveCaption; Name: 'clInactiveCaption'), 2371 (Value: clMenu; Name: 'clMenu'), 2372 (Value: clMenuBar; Name: 'clMenuBar'), 2373 (Value: clMenuHighlight; Name: 'clMenuHighlight'), 2374 (Value: clMenuText; Name: 'clMenuText'), 2375 (Value: clWindow; Name: 'clWindow'), 2376 (Value: clWindowFrame; Name: 'clWindowFrame'), 2377 (Value: clWindowText; Name: 'clWindowText'), 2378 (Value: clCaptionText; Name: 'clCaptionText'), 2379 (Value: clActiveBorder; Name: 'clActiveBorder'), 2380 (Value: clInactiveBorder; Name: 'clInactiveBorder'), 2381 (Value: clAppWorkspace; Name: 'clAppWorkspace'), 2382 (Value: clHighlight; Name: 'clHighlight'), 2383 (Value: clHighlightText; Name: 'clHighlightText'), 2384 (Value: clBtnFace; Name: 'clBtnFace'), 2385 (Value: clBtnShadow; Name: 'clBtnShadow'), 2386 (Value: clGrayText; Name: 'clGrayText'), 2387 (Value: clBtnText; Name: 'clBtnText'), 2388 (Value: clInactiveCaptionText; Name: 'clInactiveCaptionText'), 2389 (Value: clBtnHighlight; Name: 'clBtnHighlight'), 2390 (Value: cl3DDkShadow; Name: 'cl3DDkShadow'), 2391 (Value: cl3DLight; Name: 'cl3DLight'), 2392 (Value: clInfoText; Name: 'clInfoText'), 2393 (Value: clInfoBk; Name: 'clInfoBk'), 2394 2395 (Value: clHotLight; Name: 'clHotLight'), 2396 (Value: clGradientActiveCaption; Name: 'clGradientActiveCaption'), 2397 (Value: clGradientInactiveCaption; Name: 'clGradientInactiveCaption'), 2398 2399 // one our special color 2400 (Value: clForm; Name: 'clForm'), 2401 2402 {$warnings off} 2403 // CLX base, mapped, pseudo, rgb values 2404 (Value: clForeground; Name: 'clForeground'), 2405 (Value: clButton; Name: 'clButton'), 2406 (Value: clLight; Name: 'clLight'), 2407 (Value: clMidlight; Name: 'clMidlight'), 2408 (Value: clDark; Name: 'clDark'), 2409 (Value: clMid; Name: 'clMid'), 2410 (Value: clText; Name: 'clText'), 2411 (Value: clBrightText; Name: 'clBrightText'), 2412 (Value: clButtonText; Name: 'clButtonText'), 2413 (Value: clBase; Name: 'clBase'), 2414 //clBackground 2415 (Value: clShadow; Name: 'clShadow'), 2416 //clHighlight 2417 (Value: clHighlightedText; Name: 'clHighlightedText'), 2418 2419 // CLX normal, mapped, pseudo, rgb values 2420 (Value: clNormalForeground; Name: 'clNormalForeground'), 2421 (Value: clNormalButton; Name: 'clNormalButton'), 2422 (Value: clNormalLight; Name: 'clNormalLight'), 2423 (Value: clNormalMidlight; Name: 'clNormalMidlight'), 2424 (Value: clNormalDark; Name: 'clNormalDark'), 2425 (Value: clNormalMid; Name: 'clNormalMid'), 2426 (Value: clNormalText; Name: 'clNormalText'), 2427 (Value: clNormalBrightText; Name: 'clNormalBrightText'), 2428 (Value: clNormalButtonText; Name: 'clNormalButtonText'), 2429 (Value: clNormalBase; Name: 'clNormalBase'), 2430 (Value: clNormalBackground; Name: 'clNormalBackground'), 2431 (Value: clNormalShadow; Name: 'clNormalShadow'), 2432 (Value: clNormalHighlight; Name: 'clNormalHighlight'), 2433 (Value: clNormalHighlightedText; Name: 'clNormalHighlightedText'), 2434 2435 // CLX disabled, mapped, pseudo, rgb values 2436 (Value: clDisabledForeground; Name: 'clDisabledForeground'), 2437 (Value: clDisabledButton; Name: 'clDisabledButton'), 2438 (Value: clDisabledLight; Name: 'clDisabledLight'), 2439 (Value: clDisabledMidlight; Name: 'clDisabledMidlight'), 2440 (Value: clDisabledDark; Name: 'clDisabledDark'), 2441 (Value: clDisabledMid; Name: 'clDisabledMid'), 2442 (Value: clDisabledText; Name: 'clDisabledText'), 2443 (Value: clDisabledBrightText; Name: 'clDisabledBrightText'), 2444 (Value: clDisabledButtonText; Name: 'clDisabledButtonText'), 2445 (Value: clDisabledBase; Name: 'clDisabledBase'), 2446 (Value: clDisabledBackground; Name: 'clDisabledBackground'), 2447 (Value: clDisabledShadow; Name: 'clDisabledShadow'), 2448 (Value: clDisabledHighlight; Name: 'clDisabledHighlight'), 2449 (Value: clDisabledHighlightedText; Name: 'clDisabledHighlightedText'), 2450 2451 // CLX active, mapped, pseudo, rgb values 2452 (Value: clActiveForeground; Name: 'clActiveForeground'), 2453 (Value: clActiveButton; Name: 'clActiveButton'), 2454 (Value: clActiveLight; Name: 'clActiveLight'), 2455 (Value: clActiveMidlight; Name: 'clActiveMidlight'), 2456 (Value: clActiveDark; Name: 'clActiveDark'), 2457 (Value: clActiveMid; Name: 'clActiveMid'), 2458 (Value: clActiveText; Name: 'clActiveText'), 2459 (Value: clActiveBrightText; Name: 'clActiveBrightText'), 2460 (Value: clActiveButtonText; Name: 'clActiveButtonText'), 2461 (Value: clActiveBase; Name: 'clActiveBase'), 2462 (Value: clActiveBackground; Name: 'clActiveBackground'), 2463 (Value: clActiveShadow; Name: 'clActiveShadow'), 2464 (Value: clActiveHighlight; Name: 'clActiveHighlight'), 2465 (Value: clActiveHighlightedText; Name: 'clActiveHighlightedText') 2466 {$warnings on} 2467 ); 2468 2469function IdentEntry(Entry: Longint; out MapEntry: TIdentMapEntry): boolean; 2470begin 2471 Result := False; 2472 if (Entry >= 0) and (Entry <= High(Colors)) then 2473 begin 2474 MapEntry := Colors[Entry]; 2475 Result := True; 2476 end; 2477end; 2478 2479function ColorToIdent(Color: Longint; out Ident: String): Boolean; 2480begin 2481 Result := IntToIdent(Color, Ident, Colors); 2482end; 2483 2484function IdentToColor(const Ident: string; out Color: Longint): Boolean; 2485begin 2486 Result := IdentToInt(Ident, Color, Colors); 2487end; 2488 2489function ColorIndex(Color: Longint; out Index: Integer): Boolean; 2490var 2491 i: integer; 2492begin 2493 for i := Low(Colors) to High(Colors) do 2494 if Colors[i].Value = Color then 2495 begin 2496 Result := True; 2497 Index := i; 2498 exit; 2499 end; 2500 Result := False; 2501end; 2502 2503function SysColorToSysColorIndex(Color: TColor): integer; 2504begin 2505 if (Cardinal(Color) and Cardinal(SYS_COLOR_BASE)) <> 0 then begin 2506 case Color of 2507 {$warnings off} 2508 clHighlightedText..clForeground: // Deprecated values! 2509 Result:=clForeground+COLOR_clForeground-Color; 2510 clNormalHighlightedText..clNormalForeground: 2511 Result:=clNormalForeground+COLOR_clNormalForeground-Color; 2512 clDisabledHighlightedText..clDisabledForeground: 2513 Result:=clDisabledForeground+COLOR_clDisabledForeground-Color; 2514 clActiveHighlightedText..clActiveForeground: 2515 Result:=clActiveForeground+COLOR_clActiveForeground-Color; 2516 {$warnings on} 2517 else 2518 Result:=Color and $FF; 2519 end; 2520 end else begin 2521 Result:=-1; 2522 end; 2523end; 2524 2525function ColorToRGB(Color: TColor): Longint; 2526var 2527 i: integer; 2528begin 2529 i := SysColorToSysColorIndex(Color); 2530 if i <> -1 then 2531 Result := GetSysColor(i) 2532 else 2533 Result := Color; 2534 Result := Result and $FFFFFF; 2535end; 2536 2537function ColorToString(Color: TColor): AnsiString; 2538begin 2539 Result := ''; 2540 if not ColorToIdent(Color, Result) then 2541 Result:='$'+HexStr(Color,8); 2542end; 2543 2544function StringToColor(const S: shortstring): TColor; 2545begin 2546 Result := clNone; 2547 if not IdentToColor(S, Longint(Result)) then 2548 Result := TColor(StrToInt(S)); 2549end; 2550 2551function StringToColorDef(const S: shortstring; const DefaultValue: TColor): TColor; 2552begin 2553 Result := DefaultValue; 2554 if not IdentToColor(S, Longint(Result)) then 2555 Result := TColor(StrToIntDef(S,DefaultValue)); 2556end; 2557 2558procedure GetColorValues(Proc: TGetColorStringProc); 2559var 2560 I: Integer; 2561begin 2562 for I := Low(Colors) to High(Colors) do 2563 if (I >= FirstDeprecatedColorIndex) and (I <= LastDeprecatedColorIndex) then 2564 Continue 2565 else 2566 Proc(Colors[I].Name); 2567end; 2568 2569function InvertColor(AColor: TColor): TColor; 2570var 2571 R, G, B: Integer; 2572begin 2573 R := AColor and $ff; 2574 G := (AColor shr 8) and $ff; 2575 B := (AColor shr 16) and $ff; 2576 2577 if Abs($80 - R) + Abs($80 - G) + Abs($80 - B) < $140 then 2578 begin 2579 if R<$80 then 2580 R:=Min($ff,R+$a0) 2581 else 2582 R:=Max(0,R-$a0); 2583 if G<$80 then 2584 G:=Min($ff,G+$a0) 2585 else 2586 G:=Max(0,G-$a0); 2587 if B<$80 then 2588 B:=Min($ff,B+$a0) 2589 else 2590 B:=Max(0,B-$a0); 2591 end 2592 else 2593 begin 2594 R := $ff - R; 2595 G := $ff - G; 2596 B := $ff - B; 2597 end; 2598 2599 Result := ((B and $ff) shl 16) or ((G and $ff) shl 8) or (R and $ff); 2600end; 2601 2602function Blue(rgb: TColorRef): BYTE; 2603begin 2604 Result := (rgb shr 16) and $000000ff; 2605end; 2606 2607function Green(rgb: TColorRef): BYTE; 2608begin 2609 Result := (rgb shr 8) and $000000ff; 2610end; 2611 2612function Red(rgb: TColorRef): BYTE; 2613begin 2614 Result := rgb and $000000ff; 2615end; 2616 2617function RGBToColor(R, G, B: Byte): TColor; 2618begin 2619 Result := (B shl 16) or (G shl 8) or R; 2620end; 2621 2622procedure RedGreenBlue(rgb: TColorRef; out Red, Green, Blue: Byte); 2623begin 2624 Red := rgb and $000000ff; 2625 Green := (rgb shr 8) and $000000ff; 2626 Blue := (rgb shr 16) and $000000ff; 2627end; 2628 2629function FPColorToTColorRef(const FPColor: TFPColor): TColorRef; 2630begin 2631 Result:=((FPColor.Red shr 8) and $ff) 2632 or (FPColor.Green and $ff00) 2633 or ((FPColor.Blue shl 8) and $ff0000); 2634end; 2635 2636function FPColorToTColor(const FPColor: TFPColor): TColor; 2637begin 2638 Result:=TColor(FPColorToTColorRef(FPColor)); 2639end; 2640 2641function TColorToFPColor(const c: TColorRef): TFPColor; 2642begin 2643 Result.Red:=(c and $ff); 2644 Result.Red:=Result.Red+(Result.Red shl 8); 2645 Result.Green:=(c and $ff00); 2646 Result.Green:=Result.Green+(Result.Green shr 8); 2647 Result.Blue:=(c and $ff0000) shr 8; 2648 Result.Blue:=Result.Blue+(Result.Blue shr 8); 2649 Result.Alpha:=FPImage.alphaOpaque; 2650end; 2651 2652function TColorToFPColor(const c: TColor): TFPColor; 2653begin 2654 Result:=TColorToFPColor(TColorRef(c)); 2655end; 2656 2657// ------------------------------------------------------------------ 2658// Decrease the component RGBs of a color of the quantity' passed 2659// 2660// Color : Color to decrease 2661// Quantity : Decrease quantity 2662// ------------------------------------------------------------------ 2663function DecColor(AColor: TColor; AQuantity: Byte) : TColor; 2664var 2665 R, G, B : Byte; 2666begin 2667 RedGreenBlue(ColorToRGB(AColor), R, G, B); 2668 R := Max(0, Integer(R) - AQuantity); 2669 G := Max(0, Integer(G) - AQuantity); 2670 B := Max(0, Integer(B) - AQuantity); 2671 Result := RGBToColor(R, G, B); 2672end; 2673 2674function IsSysColor(AColor: TColorRef): Boolean; 2675begin 2676 Result := (AColor and SYS_COLOR_BASE) <> 0; 2677end; 2678 2679 2680{$I graphicsobject.inc} 2681{$I graphic.inc} 2682{$I picture.inc} 2683{$I sharedimage.inc} 2684{$I sharedrasterimage.inc} 2685{$I sharedcustombitmap.inc} 2686{$I rasterimage.inc} 2687{$I custombitmap.inc} 2688{$I bitmapcanvas.inc} 2689{$I pen.inc} 2690{$I brush.inc} 2691{$I region.inc} 2692{$I font.inc} 2693{$I canvas.inc} 2694{$I pixmap.inc} 2695{$I png.inc} 2696{$IFNDEF DisableLCLPNM} 2697{$I pnm.inc} 2698{$ENDIF} 2699{$IFNDEF DisableLCLJPEG} 2700{$I jpegimage.inc} 2701{$ENDIF} 2702{$I icon.inc} 2703{$I icnsicon.inc} 2704{$I cursorimage.inc} 2705{$I fpimagebitmap.inc} 2706{$I bitmap.inc} 2707{$IFNDEF DisableLCLTIFF} 2708{$I tiffimage.inc} 2709{$ENDIF} 2710{$IFNDEF DisableLCLGIF} 2711{$I gifimage.inc} 2712{$ENDIF} 2713{$I patternbitmap.inc} 2714 2715function CreateGraphicFromResourceName(Instance: THandle; const ResName: String): TGraphic; 2716var 2717 ResHandle: TFPResourceHandle; 2718begin 2719 // test Icon 2720 ResHandle := FindResource(Instance, PChar(ResName), PChar(RT_GROUP_ICON)); 2721 if ResHandle <> 0 then 2722 begin 2723 Result := TIcon.Create; 2724 TIcon(Result).LoadFromResourceHandle(Instance, ResHandle); 2725 Exit; 2726 end; 2727 // test Cursor 2728 ResHandle := FindResource(Instance, PChar(ResName), PChar(RT_GROUP_CURSOR)); 2729 if ResHandle <> 0 then 2730 begin 2731 Result := TCursorImage.Create; 2732 TCursorImage(Result).LoadFromResourceHandle(Instance, ResHandle); 2733 end 2734 else 2735 Result := CreateBitmapFromResourceName(Instance, ResName) 2736end; 2737 2738function CreateBitmapFromResourceName(Instance: THandle; const ResName: String): TCustomBitmap; 2739var 2740 ResHandle: TFPResourceHandle; 2741 Stream: TResourceStream; 2742 GraphicClass: TGraphicClass; 2743begin 2744 ResHandle := FindResource(Instance, PChar(ResName), PChar(RT_BITMAP)); 2745 if ResHandle <> 0 then 2746 begin 2747 Result := TBitmap.Create; 2748 Result.LoadFromResourceName(Instance, ResName); 2749 Exit; 2750 end; 2751 ResHandle := FindResource(Instance, PChar(ResName), PChar(RT_RCDATA)); 2752 if ResHandle <> 0 then 2753 begin 2754 Stream := TResourceStream.Create(Instance, ResName, RT_RCDATA); 2755 try 2756 GraphicClass := GetPicFileFormats.FindByStreamFormat(Stream); 2757 if Assigned(GraphicClass) and GraphicClass.InheritsFrom(TCustomBitmap) then 2758 begin 2759 Result := TCustomBitmap(GraphicClass.Create); 2760 Result.LoadFromStream(Stream); 2761 end 2762 else 2763 Result := nil; 2764 finally 2765 Stream.Free; 2766 end; 2767 end 2768 else 2769 Result := nil; 2770end; 2771 2772function LocalGetSystemFont: HFont; 2773begin 2774 Result := GetStockObject(DEFAULT_GUI_FONT); 2775end; 2776 2777procedure InterfaceInit; 2778begin 2779 //debugln('Graphics.InterfaceInit'); 2780 FontResourceCache:=TFontHandleCache.Create; 2781 PenResourceCache:=TPenHandleCache.Create; 2782 BrushResourceCache:=TBrushHandleCache.Create; 2783 PatternBitmapCache := TPatternBitmapCache.Create; 2784end; 2785 2786procedure InterfaceFinal; 2787begin 2788 //debugln('Graphics.InterfaceFinal'); 2789 FreeAndNil(PatternBitmapCache); 2790 FreeAndNil(FontResourceCache); 2791 FreeAndNil(PenResourceCache); 2792 FreeAndNil(BrushResourceCache); 2793end; 2794 2795{ TCursorImageImage } 2796 2797constructor TCursorImageImage.Create(const AInfo: TIconInfo); 2798begin 2799 inherited Create(AInfo); 2800 FHotSpot.x := AInfo.xHotspot; 2801 FHotSpot.y := AInfo.yHotspot; 2802end; 2803 2804initialization 2805 UpdateLock := TCriticalSection.Create; 2806 OnGetSystemFont := @LocalGetSystemFont; 2807 LoadBitmapFunction := @LocalLoadBitmap; 2808 LoadCursorFunction := @LocalLoadCursor; 2809 LoadIconFunction := @LocalLoadIcon; 2810 RegisterIntegerConsts(TypeInfo(TColor), TIdentToInt(@IdentToColor), TIntToIdent(@ColorToIdent)); 2811 RegisterIntegerConsts(TypeInfo(TFontCharset), TIdentToInt(@IdentToCharset), TIntToIdent(@CharsetToIdent)); 2812 RegisterInterfaceInitializationHandler(@InterfaceInit); 2813 RegisterInterfaceFinalizationHandler(@InterfaceFinal); 2814 2815finalization 2816 GraphicsFinalized:=true; 2817 OnLoadSaveClipBrdGraphicValid:=false; 2818 FreeAndNil(PicClipboardFormats); 2819 FreeAndNil(PicFileFormats); 2820 UpdateLock.Free; 2821 2822end. 2823