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