source: trunk/Packages/Graphics32/GR32_Image.pas

Last change on this file was 2, checked in by chronos, 6 years ago
File size: 68.3 KB
Line 
1unit GR32_Image;
2
3(* ***** BEGIN LICENSE BLOCK *****
4 * Version: MPL 1.1 or LGPL 2.1 with linking exception
5 *
6 * The contents of this file are subject to the Mozilla Public License Version
7 * 1.1 (the "License"); you may not use this file except in compliance with
8 * the License. You may obtain a copy of the License at
9 * http://www.mozilla.org/MPL/
10 *
11 * Software distributed under the License is distributed on an "AS IS" basis,
12 * WITHOUT WARRANTY OF ANY KIND, either express or implied. See the License
13 * for the specific language governing rights and limitations under the
14 * License.
15 *
16 * Alternatively, the contents of this file may be used under the terms of the
17 * Free Pascal modified version of the GNU Lesser General Public License
18 * Version 2.1 (the "FPC modified LGPL License"), in which case the provisions
19 * of this license are applicable instead of those above.
20 * Please see the file LICENSE.txt for additional information concerning this
21 * license.
22 *
23 * The Original Code is Graphics32
24 *
25 * The Initial Developer of the Original Code is
26 * Alex A. Denisov
27 *
28 * Portions created by the Initial Developer are Copyright (C) 2000-2009
29 * the Initial Developer. All Rights Reserved.
30 *
31 * Contributor(s):
32 * Mattias Andersson <mattias@centaurix.com>
33 * Andre Beckedorf <Andre@metaException.de>
34 * Andrew P. Rybin <aprybin@users.sourceforge.net>
35 * Dieter Köhler <dieter.koehler@philo.de>
36 * Michael Hansen <dyster_tid@hotmail.com>
37 *
38 * ***** END LICENSE BLOCK ***** *)
39
40interface
41
42{$I GR32.inc}
43
44uses
45{$IFDEF FPC}
46 LCLIntf, LCLType, LMessages, Types,
47{$ELSE}
48 Windows, Messages,
49{$ENDIF}
50 Graphics, Controls, Forms,
51 Classes, SysUtils, GR32, GR32_Layers, GR32_RangeBars, GR32_Containers,
52 GR32_RepaintOpt;
53
54const
55 { Paint Stage Constants }
56 PST_CUSTOM = 1; // Calls OnPaint with # of current stage in parameter
57 PST_CLEAR_BUFFER = 2; // Clears the buffer
58 PST_CLEAR_BACKGND = 3; // Clears a visible buffer area
59 PST_DRAW_BITMAP = 4; // Draws a bitmap
60 PST_DRAW_LAYERS = 5; // Draw layers (Parameter = Layer Mask)
61 PST_CONTROL_FRAME = 6; // Draws a dotted frame around the control
62 PST_BITMAP_FRAME = 7; // Draws a dotted frame around the scaled bitmap
63
64type
65 TPaintStageEvent = procedure(Sender: TObject; Buffer: TBitmap32; StageNum: Cardinal) of object;
66
67 { TPaintStage }
68 PPaintStage = ^TPaintStage;
69 TPaintStage = record
70 DsgnTime: Boolean;
71 RunTime: Boolean;
72 Stage: Cardinal; // a PST_* constant
73 Parameter: Cardinal; // an optional parameter
74 end;
75
76 { TPaintStages }
77 TPaintStages = class
78 private
79 FItems: array of TPaintStage;
80 function GetItem(Index: Integer): PPaintStage;
81 public
82 destructor Destroy; override;
83 function Add: PPaintStage;
84 procedure Clear;
85 function Count: Integer;
86 procedure Delete(Index: Integer);
87 function Insert(Index: Integer): PPaintStage;
88 property Items[Index: Integer]: PPaintStage read GetItem; default;
89 end;
90
91 { Alignment of the bitmap in TCustomImage32 }
92 TBitmapAlign = (baTopLeft, baCenter, baTile, baCustom);
93 TScaleMode = (smNormal, smStretch, smScale, smResize, smOptimal, smOptimalScaled);
94 TPaintBoxOptions = set of (pboWantArrowKeys, pboAutoFocus);
95
96 TRepaintMode = (rmFull, rmDirect, rmOptimizer);
97
98 { TCustomPaintBox32 }
99 TCustomPaintBox32 = class(TCustomControl)
100 private
101 FBuffer: TBitmap32;
102 FBufferOversize: Integer;
103 FBufferValid: Boolean;
104 FRepaintMode: TRepaintMode;
105 FInvalidRects: TRectList;
106 FForceFullRepaint: Boolean;
107 FRepaintOptimizer: TCustomRepaintOptimizer;
108 FOptions: TPaintBoxOptions;
109 FOnGDIOverlay: TNotifyEvent;
110 FMouseInControl: Boolean;
111 FOnMouseEnter: TNotifyEvent;
112 FOnMouseLeave: TNotifyEvent;
113 procedure SetBufferOversize(Value: Integer);
114{$IFDEF FPC}
115 procedure WMEraseBkgnd(var Message: TLMEraseBkgnd); message LM_ERASEBKGND;
116 procedure WMGetDlgCode(var Msg: TLMessage); message LM_GETDLGCODE;
117 procedure WMPaint(var Message: TLMPaint); message LM_PAINT;
118 procedure CMMouseEnter(var Message: TLMessage); message LM_MOUSEENTER;
119 procedure CMMouseLeave(var Message: TLMessage); message LM_MOUSELEAVE;
120{$ELSE}
121 procedure WMEraseBkgnd(var Message: TWmEraseBkgnd); message WM_ERASEBKGND;
122 procedure WMGetDlgCode(var Msg: TWmGetDlgCode); message WM_GETDLGCODE;
123 procedure WMPaint(var Message: TMessage); message WM_PAINT;
124 procedure CMMouseEnter(var Message: TMessage); message CM_MOUSEENTER;
125 procedure CMMouseLeave(var Message: TMessage); message CM_MOUSELEAVE;
126 procedure CMInvalidate(var Message: TMessage); message CM_INVALIDATE;
127{$ENDIF}
128 procedure DirectAreaUpdateHandler(Sender: TObject; const Area: TRect; const Info: Cardinal);
129 protected
130 procedure SetRepaintMode(const Value: TRepaintMode); virtual;
131 function CustomRepaint: Boolean; virtual;
132 function InvalidRectsAvailable: Boolean; virtual;
133 procedure DoPrepareInvalidRects; virtual;
134 procedure DoPaintBuffer; virtual;
135 procedure DoPaintGDIOverlay; virtual;
136 procedure DoBufferResized(const OldWidth, OldHeight: Integer); virtual;
137 procedure MouseDown(Button: TMouseButton; Shift: TShiftState; X, Y: Integer); override;
138 procedure MouseEnter; {$IFDEF FPC} override; {$ELSE} virtual; {$ENDIF}
139 procedure MouseLeave; {$IFDEF FPC} override; {$ELSE} virtual; {$ENDIF}
140 procedure Paint; override;
141 procedure ResetInvalidRects;
142 procedure ResizeBuffer;
143 property RepaintOptimizer: TCustomRepaintOptimizer read FRepaintOptimizer;
144 property BufferValid: Boolean read FBufferValid write FBufferValid;
145 property InvalidRects: TRectList read FInvalidRects;
146 public
147 constructor Create(AOwner: TComponent); override;
148 destructor Destroy; override;
149 function GetViewportRect: TRect; virtual;
150 procedure Flush; overload;
151 procedure Flush(const SrcRect: TRect); overload;
152 procedure Invalidate; override;
153 procedure ForceFullInvalidate; virtual;
154 procedure Loaded; override;
155 procedure Resize; override;
156 procedure SetBounds(ALeft, ATop, AWidth, AHeight: Integer); override;
157 procedure AssignTo(Dest: TPersistent); override;
158 property Buffer: TBitmap32 read FBuffer;
159 property BufferOversize: Integer read FBufferOversize write SetBufferOversize;
160 property Options: TPaintBoxOptions read FOptions write FOptions default [];
161 property MouseInControl: Boolean read FMouseInControl;
162 property RepaintMode: TRepaintMode read FRepaintMode write SetRepaintMode default rmFull;
163 property OnMouseEnter: TNotifyEvent read FOnMouseEnter write FOnMouseEnter;
164 property OnMouseLeave: TNotifyEvent read FOnMouseLeave write FOnMouseLeave;
165 property OnGDIOverlay: TNotifyEvent read FOnGDIOverlay write FOnGDIOverlay;
166 end;
167
168 { TPaintBox32 }
169 TPaintBox32 = class(TCustomPaintBox32)
170 private
171 FOnPaintBuffer: TNotifyEvent;
172 protected
173 procedure DoPaintBuffer; override;
174 public
175 property Canvas;
176 published
177 property Align;
178 property Anchors;
179 property AutoSize;
180 property Constraints;
181 property Cursor;
182 property DragCursor;
183 property DragMode;
184 property Options;
185 property ParentShowHint;
186 property PopupMenu;
187 property RepaintMode;
188 property ShowHint;
189 property TabOrder;
190 property TabStop;
191 property Visible;
192{$IFNDEF PLATFORM_INDEPENDENT}
193 property OnCanResize;
194{$ENDIF}
195 property OnClick;
196 property OnDblClick;
197 property OnDragDrop;
198 property OnDragOver;
199 property OnEndDrag;
200 property OnGDIOverlay;
201 property OnMouseDown;
202 property OnMouseMove;
203 property OnMouseUp;
204 property OnMouseWheel;
205 property OnMouseWheelDown;
206 property OnMouseWheelUp;
207 property OnMouseEnter;
208 property OnMouseLeave;
209 property OnPaintBuffer: TNotifyEvent read FOnPaintBuffer write FOnPaintBuffer;
210 property OnResize;
211 property OnStartDrag;
212 end;
213
214 { TCustomImage32 }
215 TImgMouseEvent = procedure(Sender: TObject; Button: TMouseButton;
216 Shift: TShiftState; X, Y: Integer; Layer: TCustomLayer) of object;
217 TImgMouseMoveEvent = procedure(Sender: TObject; Shift: TShiftState;
218 X, Y: Integer; Layer: TCustomLayer) of object;
219 TPaintStageHandler = procedure(Dest: TBitmap32; StageNum: Integer) of object;
220
221 TCustomImage32 = class(TCustomPaintBox32)
222 private
223 FBitmap: TBitmap32;
224 FBitmapAlign: TBitmapAlign;
225 FLayers: TLayerCollection;
226 FOffsetHorz: TFloat;
227 FOffsetVert: TFloat;
228 FPaintStages: TPaintStages;
229 FPaintStageHandlers: array of TPaintStageHandler;
230 FPaintStageNum: array of Integer;
231 FScaleX: TFloat;
232 FScaleY: TFloat;
233 FScaleMode: TScaleMode;
234 FUpdateCount: Integer;
235 FOnBitmapResize: TNotifyEvent;
236 FOnChange: TNotifyEvent;
237 FOnInitStages: TNotifyEvent;
238 FOnMouseDown: TImgMouseEvent;
239 FOnMouseMove: TImgMouseMoveEvent;
240 FOnMouseUp: TImgMouseEvent;
241 FOnPaintStage: TPaintStageEvent;
242 FOnScaleChange: TNotifyEvent;
243 procedure BitmapResizeHandler(Sender: TObject);
244 procedure BitmapChangeHandler(Sender: TObject);
245 procedure BitmapAreaChangeHandler(Sender: TObject; const Area: TRect; const Info: Cardinal);
246 procedure BitmapDirectAreaChangeHandler(Sender: TObject; const Area: TRect; const Info: Cardinal);
247 procedure LayerCollectionChangeHandler(Sender: TObject);
248 procedure LayerCollectionGDIUpdateHandler(Sender: TObject);
249 procedure LayerCollectionGetViewportScaleHandler(Sender: TObject; out ScaleX, ScaleY: TFloat);
250 procedure LayerCollectionGetViewportShiftHandler(Sender: TObject; out ShiftX, ShiftY: TFloat);
251 function GetOnPixelCombine: TPixelCombineEvent;
252 procedure SetBitmap(Value: TBitmap32);
253 procedure SetBitmapAlign(Value: TBitmapAlign);
254 procedure SetLayers(Value: TLayerCollection);
255 procedure SetOffsetHorz(Value: TFloat);
256 procedure SetOffsetVert(Value: TFloat);
257 procedure SetScale(Value: TFloat);
258 procedure SetScaleX(Value: TFloat);
259 procedure SetScaleY(Value: TFloat);
260 procedure SetOnPixelCombine(Value: TPixelCombineEvent);
261 protected
262 CachedBitmapRect: TRect;
263 CachedShiftX, CachedShiftY,
264 CachedScaleX, CachedScaleY,
265 CachedRecScaleX, CachedRecScaleY: TFloat;
266 CacheValid: Boolean;
267 OldSzX, OldSzY: Integer;
268 PaintToMode: Boolean;
269 procedure BitmapResized; virtual;
270 procedure BitmapChanged(const Area: TRect); reintroduce; virtual;
271 function CanAutoSize(var NewWidth, NewHeight: Integer): Boolean; override;
272 procedure DoInitStages; virtual;
273 procedure DoPaintBuffer; override;
274 procedure DoPaintGDIOverlay; override;
275 procedure DoScaleChange; virtual;
276 procedure InitDefaultStages; virtual;
277 procedure InvalidateCache;
278 function InvalidRectsAvailable: Boolean; override;
279 procedure MouseDown(Button: TMouseButton; Shift: TShiftState; X, Y: Integer); overload; override;
280 procedure MouseMove(Shift: TShiftState; X, Y: Integer); overload; override;
281 procedure MouseUp(Button: TMouseButton; Shift: TShiftState; X, Y: Integer); overload; override;
282 procedure MouseDown(Button: TMouseButton; Shift: TShiftState; X, Y: Integer; Layer: TCustomLayer); reintroduce; overload; virtual;
283 procedure MouseMove(Shift: TShiftState; X, Y: Integer; Layer: TCustomLayer); reintroduce; overload; virtual;
284 procedure MouseUp(Button: TMouseButton; Shift: TShiftState; X, Y: Integer; Layer: TCustomLayer); reintroduce; overload; virtual;
285 procedure MouseLeave; override;
286 procedure SetRepaintMode(const Value: TRepaintMode); override;
287 procedure SetScaleMode(Value: TScaleMode); virtual;
288 procedure SetXForm(ShiftX, ShiftY, ScaleX, ScaleY: TFloat);
289 procedure UpdateCache; virtual;
290 property UpdateCount: Integer read FUpdateCount;
291 public
292 constructor Create(AOwner: TComponent); override;
293 destructor Destroy; override;
294 procedure BeginUpdate; virtual;
295 function BitmapToControl(const APoint: TPoint): TPoint; overload;
296 function BitmapToControl(const APoint: TFloatPoint): TFloatPoint; overload;
297 procedure Changed; virtual;
298 procedure Update(const Rect: TRect); reintroduce; overload; virtual;
299 function ControlToBitmap(const APoint: TPoint): TPoint; overload;
300 function ControlToBitmap(const APoint: TFloatPoint): TFloatPoint; overload;
301 procedure EndUpdate; virtual;
302 procedure ExecBitmapFrame(Dest: TBitmap32; StageNum: Integer); virtual; // PST_BITMAP_FRAME
303 procedure ExecClearBuffer(Dest: TBitmap32; StageNum: Integer); virtual; // PST_CLEAR_BUFFER
304 procedure ExecClearBackgnd(Dest: TBitmap32; StageNum: Integer); virtual; // PST_CLEAR_BACKGND
305 procedure ExecControlFrame(Dest: TBitmap32; StageNum: Integer); virtual; // PST_CONTROL_FRAME
306 procedure ExecCustom(Dest: TBitmap32; StageNum: Integer); virtual; // PST_CUSTOM
307 procedure ExecDrawBitmap(Dest: TBitmap32; StageNum: Integer); virtual; // PST_DRAW_BITMAP
308 procedure ExecDrawLayers(Dest: TBitmap32; StageNum: Integer); virtual; // PST_DRAW_LAYERS
309 function GetBitmapRect: TRect; virtual;
310 function GetBitmapSize: TSize; virtual;
311 procedure Invalidate; override;
312 procedure Loaded; override;
313 procedure PaintTo(Dest: TBitmap32; DestRect: TRect); virtual;
314 procedure Resize; override;
315 procedure SetupBitmap(DoClear: Boolean = False; ClearColor: TColor32 = $FF000000); virtual;
316 property Bitmap: TBitmap32 read FBitmap write SetBitmap;
317 property BitmapAlign: TBitmapAlign read FBitmapAlign write SetBitmapAlign;
318 property Canvas;
319 property Layers: TLayerCollection read FLayers write SetLayers;
320 property OffsetHorz: TFloat read FOffsetHorz write SetOffsetHorz;
321 property OffsetVert: TFloat read FOffsetVert write SetOffsetVert;
322 property PaintStages: TPaintStages read FPaintStages;
323 property Scale: TFloat read FScaleX write SetScale;
324 property ScaleX: TFloat read FScaleX write SetScaleX;
325 property ScaleY: TFloat read FScaleY write SetScaleY;
326 property ScaleMode: TScaleMode read FScaleMode write SetScaleMode;
327 property OnBitmapResize: TNotifyEvent read FOnBitmapResize write FOnBitmapResize;
328 property OnBitmapPixelCombine: TPixelCombineEvent read GetOnPixelCombine write SetOnPixelCombine;
329 property OnChange: TNotifyEvent read FOnChange write FOnChange;
330 property OnInitStages: TNotifyEvent read FOnInitStages write FOnInitStages;
331 property OnMouseDown: TImgMouseEvent read FOnMouseDown write FOnMouseDown;
332 property OnMouseMove: TImgMouseMoveEvent read FOnMouseMove write FOnMouseMove;
333 property OnMouseUp: TImgMouseEvent read FOnMouseUp write FOnMouseUp;
334 property OnPaintStage: TPaintStageEvent read FOnPaintStage write FOnPaintStage;
335 property OnScaleChange: TNotifyEvent read FOnScaleChange write FOnScaleChange;
336 end;
337
338 TImage32 = class(TCustomImage32)
339 published
340 property Align;
341 property Anchors;
342 property AutoSize;
343 property Bitmap;
344 property BitmapAlign;
345 property Color;
346 property Constraints;
347 property Cursor;
348 property DragCursor;
349 property DragMode;
350 property ParentColor;
351 property ParentShowHint;
352 property PopupMenu;
353 property RepaintMode;
354 property Scale;
355 property ScaleMode;
356 property ShowHint;
357 property TabOrder;
358 property TabStop;
359 property Visible;
360 property OnBitmapResize;
361{$IFNDEF PLATFORM_INDEPENDENT}
362 property OnCanResize;
363{$ENDIF}
364 property OnClick;
365 property OnChange;
366 property OnContextPopup;
367 property OnDblClick;
368 property OnGDIOverlay;
369 property OnDragDrop;
370 property OnDragOver;
371 property OnEndDrag;
372 property OnInitStages;
373 property OnKeyDown;
374 property OnKeyPress;
375 property OnKeyUp;
376 property OnMouseDown;
377 property OnMouseMove;
378 property OnMouseUp;
379 property OnMouseWheel;
380 property OnMouseWheelDown;
381 property OnMouseWheelUp;
382 property OnMouseEnter;
383 property OnMouseLeave;
384 property OnPaintStage;
385 property OnResize;
386 property OnStartDrag;
387 end;
388
389 TCustomImgView32 = class;
390
391 TScrollBarVisibility = (svAlways, svHidden, svAuto);
392
393 { TIVScrollProperties }
394 TIVScrollProperties = class(TArrowBarAccess)
395 private
396 function GetIncrement: Integer;
397 function GetSize: Integer;
398 function GetVisibility: TScrollbarVisibility;
399 procedure SetIncrement(Value: Integer);
400 procedure SetSize(Value: Integer);
401 procedure SetVisibility(const Value: TScrollbarVisibility);
402 protected
403 ImgView: TCustomImgView32;
404 published
405 property Increment: Integer read GetIncrement write SetIncrement default 8;
406 property Size: Integer read GetSize write SetSize default 0;
407 property Visibility: TScrollBarVisibility read GetVisibility write SetVisibility default svAlways;
408 end;
409
410 TSizeGripStyle = (sgAuto, sgNone, sgAlways);
411
412 { TCustomImgView32 }
413 TCustomImgView32 = class(TCustomImage32)
414 private
415 FCentered: Boolean;
416 FScrollBarSize: Integer;
417 FScrollBarVisibility: TScrollBarVisibility;
418 FScrollBars: TIVScrollProperties;
419 FSizeGrip: TSizeGripStyle;
420 FOnScroll: TNotifyEvent;
421 FOverSize: Integer;
422 procedure SetCentered(Value: Boolean);
423 procedure SetScrollBars(Value: TIVScrollProperties);
424 procedure SetSizeGrip(Value: TSizeGripStyle);
425 procedure SetOverSize(const Value: Integer);
426 protected
427 DisableScrollUpdate: Boolean;
428 HScroll: TCustomRangeBar;
429 VScroll: TCustomRangeBar;
430 procedure AlignAll;
431 procedure BitmapResized; override;
432 procedure DoDrawSizeGrip(R: TRect);
433 procedure DoScaleChange; override;
434 procedure DoScroll; virtual;
435 function GetScrollBarsVisible: Boolean;
436 function GetScrollBarSize: Integer;
437 function GetSizeGripRect: TRect;
438 function IsSizeGripVisible: Boolean;
439 procedure MouseDown(Button: TMouseButton; Shift: TShiftState; X, Y: Integer); override;
440 procedure MouseMove(Shift: TShiftState; X, Y: Integer); override;
441 procedure Paint; override;
442 procedure Recenter;
443 procedure SetScaleMode(Value: TScaleMode); override;
444 procedure ScrollHandler(Sender: TObject); virtual;
445 procedure UpdateImage; virtual;
446 procedure UpdateScrollBars; virtual;
447 public
448 constructor Create(AOwner: TComponent); override;
449 destructor Destroy; override;
450 function GetViewportRect: TRect; override;
451 procedure Loaded; override;
452 procedure Resize; override;
453 procedure ScrollToCenter(X, Y: Integer);
454 procedure Scroll(Dx, Dy: Integer);
455 property Centered: Boolean read FCentered write SetCentered default True;
456 property ScrollBars: TIVScrollProperties read FScrollBars write SetScrollBars;
457 property SizeGrip: TSizeGripStyle read FSizeGrip write SetSizeGrip default sgAuto;
458 property OverSize: Integer read FOverSize write SetOverSize;
459 property OnScroll: TNotifyEvent read FOnScroll write FOnScroll;
460 end;
461
462 TImgView32 = class(TCustomImgView32)
463 property Align;
464 property Anchors;
465 property AutoSize;
466 property Bitmap;
467 property BitmapAlign;
468 property Centered;
469 property Color;
470 property Constraints;
471 property Cursor;
472 property DragCursor;
473 property DragMode;
474 property ParentColor;
475 property ParentShowHint;
476 property PopupMenu;
477 property RepaintMode;
478 property Scale;
479 property ScaleMode;
480 property ScrollBars;
481 property ShowHint;
482 property SizeGrip;
483 property OverSize;
484 property TabOrder;
485 property TabStop;
486 property Visible;
487 property OnBitmapResize;
488{$IFNDEF PLATFORM_INDEPENDENT}
489 property OnCanResize;
490{$ENDIF}
491 property OnClick;
492 property OnChange;
493 property OnDblClick;
494 property OnDragDrop;
495 property OnDragOver;
496 property OnEndDrag;
497 property OnGDIOverlay;
498 property OnInitStages;
499 property OnKeyDown;
500 property OnKeyPress;
501 property OnKeyUp;
502 property OnMouseDown;
503 property OnMouseEnter;
504 property OnMouseLeave;
505 property OnMouseMove;
506 property OnMouseUp;
507 property OnMouseWheel;
508 property OnMouseWheelDown;
509 property OnMouseWheelUp;
510 property OnPaintStage;
511 property OnResize;
512 property OnScroll;
513 property OnStartDrag;
514 end;
515
516 { TBitmap32Item }
517 { A bitmap container designed to be inserted into TBitmap32Collection }
518 TBitmap32Item = class(TCollectionItem)
519 private
520 FBitmap: TBitmap32;
521 procedure SetBitmap(ABitmap: TBitmap32);
522 protected
523 procedure AssignTo(Dest: TPersistent); override;
524 public
525 constructor Create(Collection: TCollection); override;
526 destructor Destroy; override;
527 published
528 property Bitmap: TBitmap32 read FBitmap write SetBitmap;
529 end;
530
531 TBitmap32ItemClass = class of TBitmap32Item;
532
533 { TBitmap32Collection }
534 { A collection of TBitmap32Item objects }
535 TBitmap32Collection = class(TCollection)
536 private
537 FOwner: TPersistent;
538 function GetItem(Index: Integer): TBitmap32Item;
539 procedure SetItem(Index: Integer; Value: TBitmap32Item);
540 protected
541 function GetOwner: TPersistent; override;
542 public
543 constructor Create(AOwner: TPersistent; ItemClass: TBitmap32ItemClass);
544 function Add: TBitmap32Item;
545 property Items[Index: Integer]: TBitmap32Item read GetItem write SetItem; default;
546 end;
547
548 { TBitmap32List }
549 { A component that stores TBitmap32Collection }
550 TBitmap32List = class(TComponent)
551 private
552 FBitmap32Collection: TBitmap32Collection;
553 procedure SetBitmap(Index: Integer; Value: TBitmap32);
554 function GetBitmap(Index: Integer): TBitmap32;
555 procedure SetBitmap32Collection(Value: TBitmap32Collection);
556 public
557 constructor Create(AOwner: TComponent); override;
558 destructor Destroy; override;
559 property Bitmap[Index: Integer]: TBitmap32 read GetBitmap write SetBitmap; default;
560 published
561 property Bitmaps: TBitmap32Collection read FBitmap32Collection write SetBitmap32Collection;
562 end;
563
564implementation
565
566uses
567 Math, TypInfo, GR32_MicroTiles, GR32_Backends, GR32_XPThemes;
568
569type
570 TLayerAccess = class(TCustomLayer);
571 TLayerCollectionAccess = class(TLayerCollection);
572 TRangeBarAccess = class(TRangeBar);
573
574const
575 DefaultRepaintOptimizerClass: TCustomRepaintOptimizerClass = TMicroTilesRepaintOptimizer;
576
577resourcestring
578 RCStrInvalidStageIndex = 'Invalid stage index';
579
580{ TPaintStages }
581
582function TPaintStages.Add: PPaintStage;
583var
584 L: Integer;
585begin
586 L := Length(FItems);
587 SetLength(FItems, L + 1);
588 Result := @FItems[L];
589 with Result^ do
590 begin
591 DsgnTime := False;
592 RunTime := True;
593 Stage := 0;
594 Parameter := 0;
595 end;
596end;
597
598procedure TPaintStages.Clear;
599begin
600 FItems := nil;
601end;
602
603function TPaintStages.Count: Integer;
604begin
605 Result := Length(FItems);
606end;
607
608procedure TPaintStages.Delete(Index: Integer);
609var
610 Count: Integer;
611begin
612 if (Index < 0) or (Index > High(FItems)) then
613 raise EListError.Create(RCStrInvalidStageIndex);
614 Count := Length(FItems) - Index - 1;
615 if Count > 0 then
616 Move(FItems[Index + 1], FItems[Index], Count * SizeOf(TPaintStage));
617 SetLength(FItems, High(FItems));
618end;
619
620destructor TPaintStages.Destroy;
621begin
622 Clear;
623 inherited;
624end;
625
626function TPaintStages.GetItem(Index: Integer): PPaintStage;
627begin
628 Result := @FItems[Index];
629end;
630
631function TPaintStages.Insert(Index: Integer): PPaintStage;
632var
633 Count: Integer;
634begin
635 if Index < 0 then Index := 0
636 else if Index > Length(FItems) then Index := Length(FItems);
637 Count := Length(FItems) - Index;
638 SetLength(FItems, Length(FItems) + 1);
639 if Count > 0 then
640 Move(FItems[Index], FItems[Index + 1], Count * SizeOf(TPaintStage));
641 Result := @FItems[Index];
642 with Result^ do
643 begin
644 DsgnTime := False;
645 RunTime := True;
646 Stage := 0;
647 Parameter := 0;
648 end;
649end;
650
651
652{ TCustomPaintBox32 }
653
654{$IFNDEF FPC}
655procedure TCustomPaintBox32.CMInvalidate(var Message: TMessage);
656begin
657 if CustomRepaint and HandleAllocated then
658 // we might have invalid rects, so just go ahead without invalidating
659 // the whole client area...
660 PostMessage(Handle, WM_PAINT, 0, 0)
661 else
662 // no invalid rects, so just invalidate the whole client area...
663 inherited;
664end;
665{$ENDIF}
666
667procedure TCustomPaintBox32.AssignTo(Dest: TPersistent);
668begin
669 inherited AssignTo(Dest);
670 if Dest is TCustomPaintBox32 then
671 begin
672 FBuffer.Assign(TCustomPaintBox32(Dest).FBuffer);
673 TCustomPaintBox32(Dest).FBufferOversize := FBufferOversize;
674 TCustomPaintBox32(Dest).FBufferValid := FBufferValid;
675 TCustomPaintBox32(Dest).FRepaintMode := FRepaintMode;
676 TCustomPaintBox32(Dest).FInvalidRects := FInvalidRects;
677 TCustomPaintBox32(Dest).FForceFullRepaint := FForceFullRepaint;
678 TCustomPaintBox32(Dest).FOptions := FOptions;
679 TCustomPaintBox32(Dest).FOnGDIOverlay := FOnGDIOverlay;
680 TCustomPaintBox32(Dest).FOnMouseEnter := FOnMouseEnter;
681 TCustomPaintBox32(Dest).FOnMouseLeave := FOnMouseLeave;
682 end;
683end;
684
685procedure TCustomPaintBox32.CMMouseEnter(var Message: {$IFDEF FPC}TLMessage{$ELSE}TMessage{$ENDIF});
686begin
687 inherited;
688 MouseEnter;
689end;
690
691procedure TCustomPaintBox32.CMMouseLeave(var Message: {$IFDEF FPC}TLMessage{$ELSE}TMessage{$ENDIF});
692begin
693 MouseLeave;
694 inherited;
695end;
696
697constructor TCustomPaintBox32.Create(AOwner: TComponent);
698begin
699 inherited;
700 FBuffer := TBitmap32.Create;
701 FBufferOversize := 40;
702 FForceFullRepaint := True;
703 FInvalidRects := TRectList.Create;
704 FRepaintOptimizer := DefaultRepaintOptimizerClass.Create(Buffer, InvalidRects);
705
706 { Setting a initial size here will cause the control to crash under LCL }
707{$IFNDEF FPC}
708 Height := 192;
709 Width := 192;
710{$ENDIF}
711end;
712
713destructor TCustomPaintBox32.Destroy;
714begin
715 FRepaintOptimizer.Free;
716 FInvalidRects.Free;
717 FBuffer.Free;
718 inherited;
719end;
720
721procedure TCustomPaintBox32.DoBufferResized(const OldWidth, OldHeight: Integer);
722begin
723 if FRepaintOptimizer.Enabled then
724 FRepaintOptimizer.BufferResizedHandler(FBuffer.Width, FBuffer.Height);
725end;
726
727function TCustomPaintBox32.CustomRepaint: Boolean;
728begin
729 Result := FRepaintOptimizer.Enabled and not FForceFullRepaint and
730 FRepaintOptimizer.UpdatesAvailable;
731end;
732
733procedure TCustomPaintBox32.DoPrepareInvalidRects;
734begin
735 if FRepaintOptimizer.Enabled and not FForceFullRepaint then
736 FRepaintOptimizer.PerformOptimization;
737end;
738
739function TCustomPaintBox32.InvalidRectsAvailable: Boolean;
740begin
741 Result := True;
742end;
743
744procedure TCustomPaintBox32.DoPaintBuffer;
745begin
746 // force full repaint, this is necessary when Buffer is invalid and was never painted
747 // This will omit calculating the invalid rects, thus we paint everything.
748 if FForceFullRepaint then
749 begin
750 FForceFullRepaint := False;
751 FInvalidRects.Clear;
752 end
753 else
754 DoPrepareInvalidRects;
755
756 // descendants should override this method for painting operations,
757 // not the Paint method!!!
758 FBufferValid := True;
759end;
760
761procedure TCustomPaintBox32.DoPaintGDIOverlay;
762begin
763 if Assigned(FOnGDIOverlay) then FOnGDIOverlay(Self);
764end;
765
766procedure TCustomPaintBox32.Flush;
767begin
768 if (FBuffer.Handle <> 0) then
769 begin
770 Canvas.Lock;
771 try
772 FBuffer.Lock;
773 try
774 if (Canvas.Handle <> 0) then
775 with GetViewportRect do
776 BitBlt(Canvas.Handle, Left, Top, Right - Left, Bottom - Top,
777 FBuffer.Handle, 0, 0, SRCCOPY);
778 finally
779 FBuffer.Unlock;
780 end;
781 finally
782 Canvas.Unlock;
783 end;
784 end;
785end;
786
787procedure TCustomPaintBox32.Flush(const SrcRect: TRect);
788var
789 R: TRect;
790begin
791 if (FBuffer.Handle <> 0) then
792 begin
793 Canvas.Lock;
794 try
795 FBuffer.Lock;
796 try
797 R := GetViewPortRect;
798 if (Canvas.Handle <> 0) then
799 with SrcRect do
800 BitBlt(Canvas.Handle, Left + R.Left, Top + R.Top, Right - Left,
801 Bottom - Top, FBuffer.Handle, Left, Top, SRCCOPY);
802 finally
803 FBuffer.Unlock;
804 end;
805 finally
806 Canvas.Unlock;
807 end;
808 end;
809end;
810
811function TCustomPaintBox32.GetViewportRect: TRect;
812begin
813 // returns position of the buffered area within the control bounds
814 // by default, the whole control is buffered
815 Result.Left := 0;
816 Result.Top := 0;
817 Result.Right := Width;
818 Result.Bottom := Height;
819end;
820
821procedure TCustomPaintBox32.Invalidate;
822begin
823 FBufferValid := False;
824 inherited;
825end;
826
827procedure TCustomPaintBox32.ForceFullInvalidate;
828begin
829 if FRepaintOptimizer.Enabled then FRepaintOptimizer.Reset;
830 FForceFullRepaint := True;
831 Invalidate;
832end;
833
834procedure TCustomPaintBox32.Loaded;
835begin
836 FBufferValid := False;
837 inherited;
838end;
839
840procedure TCustomPaintBox32.MouseDown(Button: TMouseButton; Shift: TShiftState;
841 X, Y: Integer);
842begin
843 if (pboAutoFocus in Options) and CanFocus then SetFocus;
844 inherited;
845end;
846
847procedure TCustomPaintBox32.MouseEnter;
848begin
849 FMouseInControl := True;
850 if Assigned(FOnMouseEnter) then
851 FOnMouseEnter(Self);
852end;
853
854procedure TCustomPaintBox32.MouseLeave;
855begin
856 FMouseInControl := False;
857 if Assigned(FOnMouseLeave) then
858 FOnMouseLeave(Self);
859end;
860
861procedure TCustomPaintBox32.Paint;
862begin
863 if not Assigned(Parent) then
864 Exit;
865
866 if FRepaintOptimizer.Enabled then
867 FRepaintOptimizer.BeginPaint;
868
869 if not FBufferValid then
870 begin
871 (FBuffer.Backend as IPaintSupport).ImageNeeded;
872 DoPaintBuffer;
873 (FBuffer.Backend as IPaintSupport).CheckPixmap;
874 end;
875
876 FBuffer.Lock;
877 with Canvas do
878 try
879 (FBuffer.Backend as IPaintSupport).DoPaint(FBuffer, FInvalidRects, Canvas, Self);
880 finally
881 FBuffer.Unlock;
882 end;
883
884 DoPaintGDIOverlay;
885
886 if FRepaintOptimizer.Enabled then
887 FRepaintOptimizer.EndPaint;
888
889 ResetInvalidRects;
890 FForceFullRepaint := False;
891end;
892
893procedure TCustomPaintBox32.ResetInvalidRects;
894begin
895 FInvalidRects.Clear;
896end;
897
898procedure TCustomPaintBox32.Resize;
899begin
900 ResizeBuffer;
901 BufferValid := False;
902 inherited;
903end;
904
905procedure TCustomPaintBox32.ResizeBuffer;
906var
907 NewWidth, NewHeight, W, H: Integer;
908 OldWidth, OldHeight: Integer;
909begin
910 // get the viewport parameters
911 with GetViewportRect do
912 begin
913 NewWidth := Right - Left;
914 NewHeight := Bottom - Top;
915 end;
916 if NewWidth < 0 then NewWidth := 0;
917 if NewHeight < 0 then NewHeight := 0;
918
919 W := FBuffer.Width;
920
921 if NewWidth > W then
922 W := NewWidth + FBufferOversize
923 else if NewWidth < W - FBufferOversize then
924 W := NewWidth;
925
926 if W < 1 then W := 1;
927
928 H := FBuffer.Height;
929
930 if NewHeight > H then
931 H := NewHeight + FBufferOversize
932 else if NewHeight < H - FBufferOversize then
933 H := NewHeight;
934
935 if H < 1 then H := 1;
936
937 if (W <> FBuffer.Width) or (H <> FBuffer.Height) then
938 begin
939 FBuffer.Lock;
940 OldWidth := Buffer.Width;
941 OldHeight := Buffer.Height;
942 FBuffer.SetSize(W, H);
943 FBuffer.Unlock;
944
945 DoBufferResized(OldWidth, OldHeight);
946 ForceFullInvalidate;
947 end;
948end;
949
950procedure TCustomPaintBox32.SetBounds(ALeft, ATop, AWidth, AHeight: Integer);
951begin
952 inherited;
953 if csDesigning in ComponentState then ResizeBuffer;
954 FBufferValid := False;
955end;
956
957procedure TCustomPaintBox32.SetBufferOversize(Value: Integer);
958begin
959 if Value < 0 then Value := 0;
960 if Value <> FBufferOversize then
961 begin
962 FBufferOversize := Value;
963 ResizeBuffer;
964 FBufferValid := False
965 end;
966end;
967
968procedure TCustomPaintBox32.WMEraseBkgnd(var Message: {$IFDEF FPC}TLmEraseBkgnd{$ELSE}TWmEraseBkgnd{$ENDIF});
969begin
970 Message.Result := 1;
971end;
972
973procedure TCustomPaintBox32.WMGetDlgCode(var Msg: {$IFDEF FPC}TLMessage{$ELSE}TWmGetDlgCode{$ENDIF});
974begin
975 with Msg do
976 if pboWantArrowKeys in Options then
977 Result:= Result or DLGC_WANTARROWS
978 else
979 Result:= Result and not DLGC_WANTARROWS;
980end;
981
982procedure TCustomPaintBox32.WMPaint(var Message: {$IFDEF FPC}TLMPaint{$ELSE}TMessage{$ENDIF});
983begin
984 if CustomRepaint then
985 begin
986 if InvalidRectsAvailable then
987 // BeginPaint deeper might set invalid clipping, so we call Paint here
988 // to force repaint of our invalid rects...
989 {$IFNDEF FPC}
990 Paint
991 {$ENDIF}
992 else
993 // no invalid rects available? Invalidate the whole client area
994 InvalidateRect(Handle, nil, False);
995 end;
996
997 {$IFDEF FPC}
998 { On FPC we need to specify the name of the ancestor here }
999 inherited WMPaint(Message);
1000 {$ELSE}
1001 inherited;
1002 {$ENDIF}
1003end;
1004
1005procedure TCustomPaintBox32.DirectAreaUpdateHandler(Sender: TObject;
1006 const Area: TRect; const Info: Cardinal);
1007begin
1008 FInvalidRects.Add(Area);
1009 if not(csCustomPaint in ControlState) then Repaint;
1010end;
1011
1012procedure TCustomPaintBox32.SetRepaintMode(const Value: TRepaintMode);
1013begin
1014 if Assigned(FRepaintOptimizer) then
1015 begin
1016 // setup event handler on change of area
1017 if (Value = rmOptimizer) and not(Self is TCustomImage32) then
1018 FBuffer.OnAreaChanged := FRepaintOptimizer.AreaUpdateHandler
1019 else if Value = rmDirect then
1020 FBuffer.OnAreaChanged := DirectAreaUpdateHandler
1021 else
1022 FBuffer.OnAreaChanged := nil;
1023
1024 FRepaintOptimizer.Enabled := Value = rmOptimizer;
1025
1026 FRepaintMode := Value;
1027 Invalidate;
1028 end;
1029end;
1030
1031
1032{ TPaintBox32 }
1033
1034procedure TPaintBox32.DoPaintBuffer;
1035begin
1036 if Assigned(FOnPaintBuffer) then FOnPaintBuffer(Self);
1037 inherited;
1038end;
1039
1040{ TCustomImage32 }
1041
1042constructor TCustomImage32.Create(AOwner: TComponent);
1043begin
1044 inherited;
1045 ControlStyle := [csAcceptsControls, csCaptureMouse, csClickEvents,
1046 csDoubleClicks, csReplicatable, csOpaque];
1047 FBitmap := TBitmap32.Create;
1048 FBitmap.OnResize := BitmapResizeHandler;
1049
1050 FLayers := TLayerCollection.Create(Self);
1051 with TLayerCollectionAccess(FLayers) do
1052 begin
1053 OnChange := LayerCollectionChangeHandler;
1054 OnGDIUpdate := LayerCollectionGDIUpdateHandler;
1055 OnGetViewportScale := LayerCollectionGetViewportScaleHandler;
1056 OnGetViewportShift := LayerCollectionGetViewportShiftHandler;
1057 end;
1058
1059 FRepaintOptimizer.RegisterLayerCollection(FLayers);
1060 RepaintMode := rmFull;
1061
1062 FPaintStages := TPaintStages.Create;
1063 FScaleX := 1;
1064 FScaleY := 1;
1065 SetXForm(0, 0, 1, 1);
1066
1067 InitDefaultStages;
1068end;
1069
1070destructor TCustomImage32.Destroy;
1071begin
1072 BeginUpdate;
1073 FPaintStages.Free;
1074 FRepaintOptimizer.UnregisterLayerCollection(FLayers);
1075 FLayers.Free;
1076 FBitmap.Free;
1077 inherited;
1078end;
1079
1080procedure TCustomImage32.BeginUpdate;
1081begin
1082 // disable OnChange & OnChanging generation
1083 Inc(FUpdateCount);
1084end;
1085
1086procedure TCustomImage32.BitmapResized;
1087var
1088 W, H: Integer;
1089begin
1090 if AutoSize then
1091 begin
1092 W := Bitmap.Width;
1093 H := Bitmap.Height;
1094 if ScaleMode = smScale then
1095 begin
1096 W := Round(W * Scale);
1097 H := Round(H * Scale);
1098 end;
1099 if AutoSize and (W > 0) and (H > 0) then SetBounds(Left, Top, W, H);
1100 end;
1101
1102 if (FUpdateCount = 0) and Assigned(FOnBitmapResize) then FOnBitmapResize(Self);
1103 InvalidateCache;
1104 ForceFullInvalidate;
1105end;
1106
1107procedure TCustomImage32.BitmapChanged(const Area: TRect);
1108begin
1109 Changed;
1110end;
1111
1112function TCustomImage32.BitmapToControl(const APoint: TPoint): TPoint;
1113begin
1114 // convert coordinates from bitmap's ref. frame to control's ref. frame
1115 UpdateCache;
1116 with APoint do
1117 begin
1118 Result.X := Trunc(X * CachedScaleX + CachedShiftX);
1119 Result.Y := Trunc(Y * CachedScaleY + CachedShiftY);
1120 end;
1121end;
1122
1123function TCustomImage32.BitmapToControl(const APoint: TFloatPoint): TFloatPoint;
1124begin
1125 // subpixel precision version
1126 UpdateCache;
1127 with APoint do
1128 begin
1129 Result.X := X * CachedScaleX + CachedShiftX;
1130 Result.Y := Y * CachedScaleY + CachedShiftY;
1131 end;
1132end;
1133
1134procedure TCustomImage32.BitmapResizeHandler(Sender: TObject);
1135begin
1136 BitmapResized;
1137end;
1138
1139procedure TCustomImage32.BitmapChangeHandler(Sender: TObject);
1140begin
1141 FRepaintOptimizer.Reset;
1142 BitmapChanged(Bitmap.Boundsrect);
1143end;
1144
1145procedure TCustomImage32.BitmapAreaChangeHandler(Sender: TObject;
1146 const Area: TRect; const Info: Cardinal);
1147var
1148 T, R: TRect;
1149 Width, Tx, Ty, I, J: Integer;
1150begin
1151 if Sender = FBitmap then
1152 begin
1153 T := Area;
1154 Width := Trunc(FBitmap.Resampler.Width) + 1;
1155 InflateArea(T, Width, Width);
1156 T.TopLeft := BitmapToControl(T.TopLeft);
1157 T.BottomRight := BitmapToControl(T.BottomRight);
1158
1159 if FBitmapAlign <> baTile then
1160 FRepaintOptimizer.AreaUpdateHandler(Self, T, AREAINFO_RECT)
1161 else
1162 begin
1163 with CachedBitmapRect do
1164 begin
1165 Tx := Buffer.Width div Right;
1166 Ty := Buffer.Height div Bottom;
1167 for J := 0 to Ty do
1168 for I := 0 to Tx do
1169 begin
1170 R := T;
1171 OffsetRect(R, Right * I, Bottom * J);
1172 FRepaintOptimizer.AreaUpdateHandler(Self, R, AREAINFO_RECT);
1173 end;
1174 end;
1175 end;
1176 end;
1177
1178 BitmapChanged(Area);
1179end;
1180
1181procedure TCustomImage32.BitmapDirectAreaChangeHandler(Sender: TObject;
1182 const Area: TRect; const Info: Cardinal);
1183var
1184 T, R: TRect;
1185 Width, Tx, Ty, I, J: Integer;
1186begin
1187 if Sender = FBitmap then
1188 begin
1189 T := Area;
1190 Width := Trunc(FBitmap.Resampler.Width) + 1;
1191 InflateArea(T, Width, Width);
1192 T.TopLeft := BitmapToControl(T.TopLeft);
1193 T.BottomRight := BitmapToControl(T.BottomRight);
1194
1195 if FBitmapAlign <> baTile then
1196 InvalidRects.Add(T)
1197 else
1198 begin
1199 with CachedBitmapRect do
1200 begin
1201 Tx := Buffer.Width div Right;
1202 Ty := Buffer.Height div Bottom;
1203 for J := 0 to Ty do
1204 for I := 0 to Tx do
1205 begin
1206 R := T;
1207 OffsetRect(R, Right * I, Bottom * J);
1208 InvalidRects.Add(R);
1209 end;
1210 end;
1211 end;
1212 end;
1213
1214 if FUpdateCount = 0 then
1215 begin
1216 if not(csCustomPaint in ControlState) then Repaint;
1217 if Assigned(FOnChange) then FOnChange(Self);
1218 end;
1219end;
1220
1221function TCustomImage32.CanAutoSize(var NewWidth, NewHeight: Integer): Boolean;
1222var
1223 W, H: Integer;
1224begin
1225 InvalidateCache;
1226 Result := True;
1227 W := Bitmap.Width;
1228 H := Bitmap.Height;
1229 if ScaleMode = smScale then
1230 begin
1231 W := Round(W * Scale);
1232 H := Round(H * Scale);
1233 end;
1234 if not (csDesigning in ComponentState) or (W > 0) and (H > 0) then
1235 begin
1236 if Align in [alNone, alLeft, alRight] then NewWidth := W;
1237 if Align in [alNone, alTop, alBottom] then NewHeight := H;
1238 end;
1239end;
1240
1241procedure TCustomImage32.Changed;
1242begin
1243 if FUpdateCount = 0 then
1244 begin
1245 Invalidate;
1246 if Assigned(FOnChange) then FOnChange(Self);
1247 end;
1248end;
1249
1250function TCustomImage32.ControlToBitmap(const APoint: TPoint): TPoint;
1251begin
1252 // convert point coords from control's ref. frame to bitmap's ref. frame
1253 // the coordinates are not clipped to bitmap image boundary
1254 UpdateCache;
1255 with APoint do
1256 begin
1257 if (CachedRecScaleX = 0) then
1258 Result.X := High(Result.X)
1259 else
1260 Result.X := Floor((X - CachedShiftX) * CachedRecScaleX);
1261
1262 if (CachedRecScaleY = 0) then
1263 Result.Y := High(Result.Y)
1264 else
1265 Result.Y := Floor((Y - CachedShiftY) * CachedRecScaleY);
1266 end;
1267end;
1268
1269function TCustomImage32.ControlToBitmap(const APoint: TFloatPoint): TFloatPoint;
1270begin
1271 // subpixel precision version
1272 UpdateCache;
1273 with APoint do
1274 begin
1275 if (CachedRecScaleX = 0) then
1276 Result.X := MaxInt
1277 else
1278 Result.X := (X - CachedShiftX) * CachedRecScaleX;
1279
1280 if (CachedRecScaleY = 0) then
1281 Result.Y := MaxInt
1282 else
1283 Result.Y := (Y - CachedShiftY) * CachedRecScaleY;
1284 end;
1285end;
1286
1287procedure TCustomImage32.DoInitStages;
1288begin
1289 if Assigned(FOnInitStages) then FOnInitStages(Self);
1290end;
1291
1292procedure TCustomImage32.DoPaintBuffer;
1293var
1294 PaintStageHandlerCount: Integer;
1295 I, J: Integer;
1296 DT, RT: Boolean;
1297begin
1298 if FRepaintOptimizer.Enabled then
1299 FRepaintOptimizer.BeginPaintBuffer;
1300
1301 UpdateCache;
1302
1303 SetLength(FPaintStageHandlers, FPaintStages.Count);
1304 SetLength(FPaintStageNum, FPaintStages.Count);
1305 PaintStageHandlerCount := 0;
1306
1307 DT := csDesigning in ComponentState;
1308 RT := not DT;
1309
1310 // compile list of paintstage handler methods
1311 for I := 0 to FPaintStages.Count - 1 do
1312 begin
1313 with FPaintStages[I]^ do
1314 if (DsgnTime and DT) or (RunTime and RT) then
1315 begin
1316 FPaintStageNum[PaintStageHandlerCount] := I;
1317 case Stage of
1318 PST_CUSTOM: FPaintStageHandlers[PaintStageHandlerCount] := ExecCustom;
1319 PST_CLEAR_BUFFER: FPaintStageHandlers[PaintStageHandlerCount] := ExecClearBuffer;
1320 PST_CLEAR_BACKGND: FPaintStageHandlers[PaintStageHandlerCount] := ExecClearBackgnd;
1321 PST_DRAW_BITMAP: FPaintStageHandlers[PaintStageHandlerCount] := ExecDrawBitmap;
1322 PST_DRAW_LAYERS: FPaintStageHandlers[PaintStageHandlerCount] := ExecDrawLayers;
1323 PST_CONTROL_FRAME: FPaintStageHandlers[PaintStageHandlerCount] := ExecControlFrame;
1324 PST_BITMAP_FRAME: FPaintStageHandlers[PaintStageHandlerCount] := ExecBitmapFrame;
1325 else
1326 Dec(PaintStageHandlerCount); // this should not happen .
1327 end;
1328 Inc(PaintStageHandlerCount);
1329 end;
1330 end;
1331
1332 Buffer.BeginUpdate;
1333 if FInvalidRects.Count = 0 then
1334 begin
1335 Buffer.ClipRect := GetViewportRect;
1336 for I := 0 to PaintStageHandlerCount - 1 do
1337 FPaintStageHandlers[I](Buffer, FPaintStageNum[I]);
1338 end
1339 else
1340 begin
1341 for J := 0 to FInvalidRects.Count - 1 do
1342 begin
1343 Buffer.ClipRect := FInvalidRects[J]^;
1344 for I := 0 to PaintStageHandlerCount - 1 do
1345 FPaintStageHandlers[I](Buffer, FPaintStageNum[I]);
1346 end;
1347
1348 Buffer.ClipRect := GetViewportRect;
1349 end;
1350 Buffer.EndUpdate;
1351
1352 if FRepaintOptimizer.Enabled then
1353 FRepaintOptimizer.EndPaintBuffer;
1354
1355 // avoid calling inherited, we have a totally different behaviour here...
1356 FBufferValid := True;
1357end;
1358
1359procedure TCustomImage32.DoPaintGDIOverlay;
1360var
1361 I: Integer;
1362begin
1363 for I := 0 to Layers.Count - 1 do
1364 if (Layers[I].LayerOptions and LOB_GDI_OVERLAY) <> 0 then
1365 TLayerAccess(Layers[I]).PaintGDI(Canvas);
1366 inherited;
1367end;
1368
1369procedure TCustomImage32.DoScaleChange;
1370begin
1371 if Assigned(FOnScaleChange) then FOnScaleChange(Self);
1372end;
1373
1374procedure TCustomImage32.EndUpdate;
1375begin
1376 // re-enable OnChange & OnChanging generation
1377 Dec(FUpdateCount);
1378 Assert(FUpdateCount >= 0, 'Unpaired EndUpdate call');
1379end;
1380
1381procedure TCustomImage32.ExecBitmapFrame(Dest: TBitmap32; StageNum: Integer);
1382begin
1383 Dest.Canvas.DrawFocusRect(CachedBitmapRect);
1384end;
1385
1386procedure TCustomImage32.ExecClearBackgnd(Dest: TBitmap32; StageNum: Integer);
1387var
1388 C: TColor32;
1389 I: Integer;
1390begin
1391 C := Color32(Color);
1392 if FInvalidRects.Count > 0 then
1393 begin
1394 for I := 0 to FInvalidRects.Count - 1 do
1395 with FInvalidRects[I]^ do
1396 Dest.FillRectS(Left, Top, Right, Bottom, C);
1397 end
1398 else
1399 begin
1400 if ((Bitmap.Empty) or (Bitmap.DrawMode <> dmOpaque)) and assigned(Dest) then
1401 Dest.Clear(C)
1402 else
1403 with CachedBitmapRect do
1404 begin
1405 if (Left > 0) or (Right < Self.Width) or (Top > 0) or (Bottom < Self.Height) and
1406 not (BitmapAlign = baTile) then
1407 begin
1408 // clean only the part of the buffer lying around image edges
1409 Dest.FillRectS(0, 0, Self.Width, Top, C); // top
1410 Dest.FillRectS(0, Bottom, Self.Width, Self.Height, C); // bottom
1411 Dest.FillRectS(0, Top, Left, Bottom, C); // left
1412 Dest.FillRectS(Right, Top, Self.Width, Bottom, C); // right
1413 end;
1414 end;
1415 end;
1416end;
1417
1418procedure TCustomImage32.ExecClearBuffer(Dest: TBitmap32; StageNum: Integer);
1419begin
1420 Dest.Clear(Color32(Color));
1421end;
1422
1423procedure TCustomImage32.ExecControlFrame(Dest: TBitmap32; StageNum: Integer);
1424begin
1425 DrawFocusRect(Dest.Handle, Rect(0, 0, Width, Height));
1426end;
1427
1428procedure TCustomImage32.ExecCustom(Dest: TBitmap32; StageNum: Integer);
1429begin
1430 if Assigned(FOnPaintStage) then FOnPaintStage(Self, Dest, StageNum);
1431end;
1432
1433procedure TCustomImage32.ExecDrawBitmap(Dest: TBitmap32; StageNum: Integer);
1434var
1435 I, J, Tx, Ty: Integer;
1436 R: TRect;
1437begin
1438 if Bitmap.Empty or IsRectEmpty(CachedBitmapRect) then Exit;
1439 Bitmap.Lock;
1440 try
1441 if BitmapAlign <> baTile then Bitmap.DrawTo(Dest, CachedBitmapRect)
1442 else with CachedBitmapRect do
1443 begin
1444 Tx := Dest.Width div Right;
1445 Ty := Dest.Height div Bottom;
1446 for J := 0 to Ty do
1447 for I := 0 to Tx do
1448 begin
1449 R := CachedBitmapRect;
1450 OffsetRect(R, Right * I, Bottom * J);
1451 Bitmap.DrawTo(Dest, R);
1452 end;
1453 end;
1454 finally
1455 Bitmap.Unlock;
1456 end;
1457end;
1458
1459procedure TCustomImage32.ExecDrawLayers(Dest: TBitmap32; StageNum: Integer);
1460var
1461 I: Integer;
1462 Mask: Cardinal;
1463begin
1464 Mask := PaintStages[StageNum]^.Parameter;
1465 for I := 0 to Layers.Count - 1 do
1466 if (Layers.Items[I].LayerOptions and Mask) <> 0 then
1467 TLayerAccess(Layers.Items[I]).DoPaint(Dest);
1468end;
1469
1470function TCustomImage32.GetBitmapRect: TRect;
1471var
1472 Size: TSize;
1473begin
1474 if Bitmap.Empty then
1475 with Result do
1476 begin
1477 Left := 0;
1478 Right := 0;
1479 Top := 0;
1480 Bottom := 0;
1481 end
1482 else
1483 begin
1484 Size := GetBitmapSize;
1485 Result := Rect(0, 0, Size.Cx, Size.Cy);
1486 if BitmapAlign = baCenter then
1487 OffsetRect(Result, (Width - Size.Cx) div 2, (Height - Size.Cy) div 2)
1488 else if BitmapAlign = baCustom then
1489 OffsetRect(Result, Round(OffsetHorz), Round(OffsetVert));
1490 end;
1491end;
1492
1493function TCustomImage32.GetBitmapSize: TSize;
1494var
1495 Mode: TScaleMode;
1496 ViewportWidth, ViewportHeight: Integer;
1497 RScaleX, RScaleY: TFloat;
1498begin
1499// with Result do
1500 begin
1501 if Bitmap.Empty or (Width = 0) or (Height = 0) then
1502 begin
1503 Result.Cx := 0;
1504 Result.Cy := 0;
1505 Exit;
1506 end;
1507
1508 with GetViewportRect do
1509 begin
1510 ViewportWidth := Right - Left;
1511 ViewportHeight := Bottom - Top;
1512 end;
1513
1514 // check for optimal modes as these are compounds of the other modes.
1515 case ScaleMode of
1516 smOptimal:
1517 if (Bitmap.Width > ViewportWidth) or (Bitmap.Height > ViewportHeight) then
1518 Mode := smResize
1519 else
1520 Mode := smNormal;
1521 smOptimalScaled:
1522 if (Round(Bitmap.Width * ScaleX) > ViewportWidth) or
1523 (Round(Bitmap.Height * ScaleY) > ViewportHeight) then
1524 Mode := smResize
1525 else
1526 Mode := smScale;
1527 else
1528 Mode := ScaleMode;
1529 end;
1530
1531 case Mode of
1532 smNormal:
1533 begin
1534 Result.Cx := Bitmap.Width;
1535 Result.Cy := Bitmap.Height;
1536 end;
1537 smStretch:
1538 begin
1539 Result.Cx := ViewportWidth;
1540 Result.Cy := ViewportHeight;
1541 end;
1542 smResize:
1543 begin
1544 Result.Cx := Bitmap.Width;
1545 Result.Cy := Bitmap.Height;
1546 RScaleX := ViewportWidth / Result.Cx;
1547 RScaleY := ViewportHeight / Result.Cy;
1548 if RScaleX >= RScaleY then
1549 begin
1550 Result.Cx := Round(Result.Cx * RScaleY);
1551 Result.Cy := ViewportHeight;
1552 end
1553 else
1554 begin
1555 Result.Cx := ViewportWidth;
1556 Result.Cy := Round(Result.Cy * RScaleX);
1557 end;
1558 end;
1559 else // smScale
1560 begin
1561 Result.Cx := Round(Bitmap.Width * ScaleX);
1562 Result.Cy := Round(Bitmap.Height * ScaleY);
1563 end;
1564 end;
1565 if Result.Cx <= 0 then Result.Cx := 0;
1566 if Result.Cy <= 0 then Result.Cy := 0;
1567 end;
1568end;
1569
1570function TCustomImage32.GetOnPixelCombine: TPixelCombineEvent;
1571begin
1572 Result := FBitmap.OnPixelCombine;
1573end;
1574
1575procedure TCustomImage32.InitDefaultStages;
1576begin
1577 // background
1578 with PaintStages.Add^ do
1579 begin
1580 DsgnTime := True;
1581 RunTime := True;
1582 Stage := PST_CLEAR_BACKGND;
1583 end;
1584
1585 // control frame
1586 with PaintStages.Add^ do
1587 begin
1588 DsgnTime := True;
1589 RunTime := False;
1590 Stage := PST_CONTROL_FRAME;
1591 end;
1592
1593 // bitmap
1594 with PaintStages.Add^ do
1595 begin
1596 DsgnTime := True;
1597 RunTime := True;
1598 Stage := PST_DRAW_BITMAP;
1599 end;
1600
1601 // bitmap frame
1602 with PaintStages.Add^ do
1603 begin
1604 DsgnTime := True;
1605 RunTime := False;
1606 Stage := PST_BITMAP_FRAME;
1607 end;
1608
1609 // layers
1610 with PaintStages.Add^ do
1611 begin
1612 DsgnTime := True;
1613 RunTime := True;
1614 Stage := PST_DRAW_LAYERS;
1615 Parameter := LOB_VISIBLE;
1616 end;
1617end;
1618
1619procedure TCustomImage32.Invalidate;
1620begin
1621 BufferValid := False;
1622 CacheValid := False;
1623 inherited;
1624end;
1625
1626procedure TCustomImage32.InvalidateCache;
1627begin
1628 if FRepaintOptimizer.Enabled and CacheValid then
1629 FRepaintOptimizer.Reset;
1630 CacheValid := False;
1631end;
1632
1633function TCustomImage32.InvalidRectsAvailable: Boolean;
1634begin
1635 // avoid calling inherited, we have a totally different behaviour here...
1636 DoPrepareInvalidRects;
1637 Result := FInvalidRects.Count > 0;
1638end;
1639
1640procedure TCustomImage32.LayerCollectionChangeHandler(Sender: TObject);
1641begin
1642 Changed;
1643end;
1644
1645procedure TCustomImage32.LayerCollectionGDIUpdateHandler(Sender: TObject);
1646begin
1647 Paint;
1648end;
1649
1650procedure TCustomImage32.LayerCollectionGetViewportScaleHandler(Sender: TObject;
1651 out ScaleX, ScaleY: TFloat);
1652begin
1653 UpdateCache;
1654 ScaleX := CachedScaleX;
1655 ScaleY := CachedScaleY;
1656end;
1657
1658procedure TCustomImage32.LayerCollectionGetViewportShiftHandler(Sender: TObject;
1659 out ShiftX, ShiftY: TFloat);
1660begin
1661 UpdateCache;
1662 ShiftX := CachedShiftX;
1663 ShiftY := CachedShiftY;
1664end;
1665
1666procedure TCustomImage32.Loaded;
1667begin
1668 inherited;
1669 DoInitStages;
1670end;
1671
1672procedure TCustomImage32.MouseDown(Button: TMouseButton; Shift: TShiftState; X, Y: Integer);
1673var
1674 Layer: TCustomLayer;
1675begin
1676 inherited;
1677
1678 if TabStop and CanFocus then SetFocus;
1679
1680 if Layers.MouseEvents then
1681 Layer := TLayerCollectionAccess(Layers).MouseDown(Button, Shift, X, Y)
1682 else
1683 Layer := nil;
1684
1685 // lock the capture only if mbLeft was pushed or any mouse listener was activated
1686 if (Button = mbLeft) or (TLayerCollectionAccess(Layers).MouseListener <> nil) then
1687 MouseCapture := True;
1688
1689 MouseDown(Button, Shift, X, Y, Layer);
1690end;
1691
1692procedure TCustomImage32.MouseMove(Shift: TShiftState; X, Y: Integer);
1693var
1694 Layer: TCustomLayer;
1695begin
1696 inherited;
1697 if Layers.MouseEvents then
1698 Layer := TLayerCollectionAccess(Layers).MouseMove(Shift, X, Y)
1699 else
1700 Layer := nil;
1701
1702 MouseMove(Shift, X, Y, Layer);
1703end;
1704
1705procedure TCustomImage32.MouseUp(Button: TMouseButton; Shift: TShiftState; X, Y: Integer);
1706var
1707 Layer: TCustomLayer;
1708 MouseListener: TCustomLayer;
1709begin
1710 MouseListener := TLayerCollectionAccess(Layers).MouseListener;
1711
1712 if Layers.MouseEvents then
1713 Layer := TLayerCollectionAccess(Layers).MouseUp(Button, Shift, X, Y)
1714 else
1715 Layer := nil;
1716
1717 // unlock the capture using same criteria as was used to acquire it
1718 if (Button = mbLeft) or ((MouseListener <> nil) and (TLayerCollectionAccess(Layers).MouseListener = nil)) then
1719 MouseCapture := False;
1720
1721 MouseUp(Button, Shift, X, Y, Layer);
1722end;
1723
1724procedure TCustomImage32.MouseDown(Button: TMouseButton;
1725 Shift: TShiftState; X, Y: Integer; Layer: TCustomLayer);
1726begin
1727 if Assigned(FOnMouseDown) then
1728 FOnMouseDown(Self, Button, Shift, X, Y, Layer);
1729end;
1730
1731procedure TCustomImage32.MouseMove(Shift: TShiftState; X, Y: Integer;
1732 Layer: TCustomLayer);
1733begin
1734 if Assigned(FOnMouseMove) then
1735 FOnMouseMove(Self, Shift, X, Y, Layer);
1736end;
1737
1738procedure TCustomImage32.MouseUp(Button: TMouseButton; Shift: TShiftState;
1739 X, Y: Integer; Layer: TCustomLayer);
1740begin
1741 if Assigned(FOnMouseUp) then
1742 FOnMouseUp(Self, Button, Shift, X, Y, Layer);
1743end;
1744
1745procedure TCustomImage32.MouseLeave;
1746begin
1747 if (Layers.MouseEvents) and (Layers.MouseListener = nil) then
1748 Screen.Cursor := crDefault;
1749 inherited;
1750end;
1751
1752procedure TCustomImage32.PaintTo(Dest: TBitmap32; DestRect: TRect);
1753var
1754 OldRepaintMode: TRepaintMode;
1755 I: Integer;
1756begin
1757 if not assigned(Dest)then exit;
1758 OldRepaintMode := RepaintMode;
1759 RepaintMode := rmFull;
1760
1761 CachedBitmapRect := DestRect;
1762
1763 with CachedBitmapRect do
1764 begin
1765 if (Right - Left <= 0) or (Bottom - Top <= 0) or Bitmap.Empty then
1766 SetXForm(0, 0, 1, 1)
1767 else
1768 SetXForm(Left, Top, (Right - Left) / Bitmap.Width, (Bottom - Top) / Bitmap.Height);
1769 end;
1770 CacheValid := True;
1771
1772 PaintToMode := True;
1773 try
1774 for I := 0 to FPaintStages.Count - 1 do
1775 with FPaintStages[I]^ do
1776 if RunTime then
1777 case Stage of
1778 PST_CUSTOM: ExecCustom(Dest, I);
1779 PST_CLEAR_BUFFER: ExecClearBuffer(Dest, I);
1780 PST_CLEAR_BACKGND: ExecClearBackgnd(Dest, I);
1781 PST_DRAW_BITMAP: ExecDrawBitmap(Dest, I);
1782 PST_DRAW_LAYERS: ExecDrawLayers(Dest, I);
1783 PST_CONTROL_FRAME: ExecControlFrame(Dest, I);
1784 PST_BITMAP_FRAME: ExecBitmapFrame(Dest, I);
1785 end;
1786 finally
1787 PaintToMode := False;
1788 end;
1789 CacheValid := False;
1790
1791 RepaintMode := OldRepaintMode;
1792end;
1793
1794procedure TCustomImage32.Resize;
1795begin
1796 InvalidateCache;
1797 inherited;
1798end;
1799
1800procedure TCustomImage32.SetBitmap(Value: TBitmap32);
1801begin
1802 InvalidateCache;
1803 FBitmap.Assign(Value);
1804end;
1805
1806procedure TCustomImage32.SetBitmapAlign(Value: TBitmapAlign);
1807begin
1808 InvalidateCache;
1809 FBitmapAlign := Value;
1810 Changed;
1811end;
1812
1813procedure TCustomImage32.SetLayers(Value: TLayerCollection);
1814begin
1815 FLayers.Assign(Value);
1816end;
1817
1818procedure TCustomImage32.SetOffsetHorz(Value: TFloat);
1819begin
1820 if Value <> FOffsetHorz then
1821 begin
1822 InvalidateCache;
1823 FOffsetHorz := Value;
1824 Changed;
1825 end;
1826end;
1827
1828procedure TCustomImage32.SetOffsetVert(Value: TFloat);
1829begin
1830 if Value <> FOffsetVert then
1831 begin
1832 FOffsetVert := Value;
1833 InvalidateCache;
1834 Changed;
1835 end;
1836end;
1837
1838procedure TCustomImage32.SetOnPixelCombine(Value: TPixelCombineEvent);
1839begin
1840 FBitmap.OnPixelCombine := Value;
1841 Changed;
1842end;
1843
1844procedure TCustomImage32.SetScale(Value: TFloat);
1845begin
1846 if Value < 0.001 then Value := 0.001;
1847 if Value <> FScaleX then
1848 begin
1849 InvalidateCache;
1850 FScaleX := Value;
1851 FScaleY := Value;
1852 CachedScaleX := FScaleX;
1853 CachedScaleY := FScaleY;
1854 CachedRecScaleX := 1 / Value;
1855 CachedRecScaleY := 1 / Value;
1856 DoScaleChange;
1857 Changed;
1858 end;
1859end;
1860
1861procedure TCustomImage32.SetScaleX(Value: TFloat);
1862begin
1863 if Value < 0.001 then Value := 0.001;
1864 if Value <> FScaleX then
1865 begin
1866 InvalidateCache;
1867 FScaleX := Value;
1868 CachedScaleX := Value;
1869 CachedRecScaleX := 1 / Value;
1870 DoScaleChange;
1871 Changed;
1872 end;
1873end;
1874
1875procedure TCustomImage32.SetScaleY(Value: TFloat);
1876begin
1877 if Value < 0.001 then Value := 0.001;
1878 if Value <> FScaleY then
1879 begin
1880 InvalidateCache;
1881 FScaleY := Value;
1882 CachedScaleY := Value;
1883 CachedRecScaleY := 1 / Value;
1884 DoScaleChange;
1885 Changed;
1886 end;
1887end;
1888
1889procedure TCustomImage32.SetScaleMode(Value: TScaleMode);
1890begin
1891 if Value <> FScaleMode then
1892 begin
1893 InvalidateCache;
1894 FScaleMode := Value;
1895 Changed;
1896 end;
1897end;
1898
1899procedure TCustomImage32.SetupBitmap(DoClear: Boolean = False; ClearColor: TColor32 = $FF000000);
1900begin
1901 FBitmap.BeginUpdate;
1902 with GetViewPortRect do
1903 FBitmap.SetSize(Right - Left, Bottom - Top);
1904 if DoClear then FBitmap.Clear(ClearColor);
1905 FBitmap.EndUpdate;
1906 InvalidateCache;
1907 Changed;
1908end;
1909
1910procedure TCustomImage32.SetXForm(ShiftX, ShiftY, ScaleX, ScaleY: TFloat);
1911begin
1912 CachedShiftX := ShiftX;
1913 CachedShiftY := ShiftY;
1914 CachedScaleX := ScaleX;
1915 CachedScaleY := ScaleY;
1916 if (ScaleX <> 0) then
1917 CachedRecScaleX := 1 / ScaleX
1918 else
1919 CachedRecScaleX := 0;
1920
1921 if (ScaleY <> 0) then
1922 CachedRecScaleY := 1 / ScaleY
1923 else
1924 CachedRecScaleY := 0;
1925end;
1926
1927procedure TCustomImage32.SetRepaintMode(const Value: TRepaintMode);
1928begin
1929 inherited;
1930
1931 case Value of
1932 rmOptimizer:
1933 begin
1934 FBitmap.OnAreaChanged := BitmapAreaChangeHandler;
1935 FBitmap.OnChange := nil;
1936 end;
1937 rmDirect:
1938 begin
1939 FBitmap.OnAreaChanged := BitmapDirectAreaChangeHandler;
1940 FBitmap.OnChange := nil;
1941 end;
1942 else
1943 FBitmap.OnAreaChanged := nil;
1944 FBitmap.OnChange := BitmapChangeHandler;
1945 end;
1946end;
1947
1948procedure TCustomImage32.Update(const Rect: TRect);
1949begin
1950 if FRepaintOptimizer.Enabled then
1951 FRepaintOptimizer.AreaUpdateHandler(Self, Rect, AREAINFO_RECT);
1952end;
1953
1954procedure TCustomImage32.UpdateCache;
1955begin
1956 if CacheValid then Exit;
1957 CachedBitmapRect := GetBitmapRect;
1958
1959 if Bitmap.Empty then
1960 SetXForm(0, 0, 1, 1)
1961 else
1962 SetXForm(
1963 CachedBitmapRect.Left, CachedBitmapRect.Top,
1964 (CachedBitmapRect.Right - CachedBitmapRect.Left) / Bitmap.Width,
1965 (CachedBitmapRect.Bottom - CachedBitmapRect.Top) / Bitmap.Height
1966 );
1967
1968 CacheValid := True;
1969end;
1970
1971
1972{ TIVScrollProperties }
1973
1974function TIVScrollProperties.GetIncrement: Integer;
1975begin
1976 Result := Round(TCustomRangeBar(Master).Increment);
1977end;
1978
1979function TIVScrollProperties.GetSize: Integer;
1980begin
1981 Result := ImgView.FScrollBarSize;
1982end;
1983
1984function TIVScrollProperties.GetVisibility: TScrollbarVisibility;
1985begin
1986 Result := ImgView.FScrollBarVisibility;
1987end;
1988
1989procedure TIVScrollProperties.SetIncrement(Value: Integer);
1990begin
1991 TCustomRangeBar(Master).Increment := Value;
1992 TCustomRangeBar(Slave).Increment := Value;
1993end;
1994
1995procedure TIVScrollProperties.SetSize(Value: Integer);
1996begin
1997 ImgView.FScrollBarSize := Value;
1998 ImgView.AlignAll;
1999 ImgView.UpdateImage;
2000end;
2001
2002procedure TIVScrollProperties.SetVisibility(const Value: TScrollbarVisibility);
2003begin
2004 if Value <> ImgView.FScrollBarVisibility then
2005 begin
2006 ImgView.FScrollBarVisibility := Value;
2007 ImgView.Resize;
2008 end;
2009end;
2010
2011{ TCustomImgView32 }
2012
2013procedure TCustomImgView32.AlignAll;
2014var
2015 ScrollbarVisible: Boolean;
2016begin
2017 if (Width > 0) and (Height > 0) then
2018 with GetViewportRect do
2019 begin
2020 ScrollbarVisible := GetScrollBarsVisible;
2021
2022 if Assigned(HScroll) then
2023 begin
2024 HScroll.BoundsRect := Rect(Left, Bottom, Right, Self.Height);
2025 HScroll.Visible := ScrollbarVisible;
2026 HScroll.Repaint;
2027 end;
2028
2029 if Assigned(VScroll) then
2030 begin
2031 VScroll.BoundsRect := Rect(Right, Top, Self.Width, Bottom);
2032 VScroll.Visible := ScrollbarVisible;
2033 VScroll.Repaint;
2034 end;
2035 end;
2036end;
2037
2038procedure TCustomImgView32.BitmapResized;
2039begin
2040 inherited;
2041 UpdateScrollBars;
2042 if Centered then
2043 ScrollToCenter(Bitmap.Width div 2, Bitmap.Height div 2)
2044 else
2045 begin
2046 HScroll.Position := 0;
2047 VScroll.Position := 0;
2048 UpdateImage;
2049 end;
2050end;
2051
2052constructor TCustomImgView32.Create(AOwner: TComponent);
2053begin
2054 inherited;
2055 FScrollBarSize := GetSystemMetrics(SM_CYHSCROLL);
2056
2057 HScroll := TCustomRangeBar.Create(Self);
2058 VScroll := TCustomRangeBar.Create(Self);
2059
2060 with HScroll do
2061 begin
2062 HScroll.Parent := Self;
2063 BorderStyle := bsNone;
2064 Centered := True;
2065 OnUserChange := ScrollHandler;
2066 end;
2067
2068 with VScroll do
2069 begin
2070 Parent := Self;
2071 BorderStyle := bsNone;
2072 Centered := True;
2073 Kind := sbVertical;
2074 OnUserChange := ScrollHandler;
2075 end;
2076
2077 FCentered := True;
2078 ScaleMode := smScale;
2079 BitmapAlign := baCustom;
2080 with GetViewportRect do
2081 begin
2082 OldSzX := Right - Left;
2083 OldSzY := Bottom - Top;
2084 end;
2085
2086 FScrollBars := TIVScrollProperties.Create;
2087 FScrollBars.ImgView := Self;
2088 FScrollBars.Master := HScroll;
2089 FScrollBars.Slave := VScroll;
2090
2091 AlignAll;
2092end;
2093
2094destructor TCustomImgView32.Destroy;
2095begin
2096 FreeAndNil(FScrollBars);
2097 inherited;
2098end;
2099
2100procedure TCustomImgView32.DoDrawSizeGrip(R: TRect);
2101begin
2102{$IFDEF Windows}
2103 if USE_THEMES then
2104 begin
2105 Canvas.Brush.Color := clBtnFace;
2106 Canvas.FillRect(R);
2107 DrawThemeBackground(SCROLLBAR_THEME, Canvas.Handle, SBP_SIZEBOX, SZB_RIGHTALIGN, R, nil);
2108 end
2109 else
2110 DrawFrameControl(Canvas.Handle, R, DFC_SCROLL, DFCS_SCROLLSIZEGRIP)
2111{$ENDIF}
2112end;
2113
2114procedure TCustomImgView32.DoScaleChange;
2115begin
2116 inherited;
2117 InvalidateCache;
2118 UpdateScrollBars;
2119 UpdateImage;
2120 Invalidate;
2121end;
2122
2123procedure TCustomImgView32.DoScroll;
2124begin
2125 if Assigned(FOnScroll) then FOnScroll(Self);
2126end;
2127
2128function TCustomImgView32.GetScrollBarSize: Integer;
2129begin
2130 if GetScrollBarsVisible then
2131 begin
2132 Result := FScrollBarSize;
2133 if Result = 0 then Result := GetSystemMetrics(SM_CYHSCROLL);
2134 end
2135 else
2136 Result := 0;
2137end;
2138
2139function TCustomImgView32.GetScrollBarsVisible: Boolean;
2140begin
2141 Result := True;
2142 if Assigned(FScrollBars) and Assigned(HScroll) and Assigned(VScroll) then
2143 case FScrollBars.Visibility of
2144 svAlways:
2145 Result := True;
2146 svHidden:
2147 Result := False;
2148 svAuto:
2149 Result := (HScroll.Range > (TRangeBarAccess(HScroll).EffectiveWindow + VScroll.Width)) or
2150 (VScroll.Range > (TRangeBarAccess(VScroll).EffectiveWindow + HScroll.Height));
2151 end;
2152end;
2153
2154function TCustomImgView32.GetSizeGripRect: TRect;
2155var
2156 Sz: Integer;
2157begin
2158 Sz := GetScrollBarSize;
2159
2160 if not Assigned(Parent) then
2161 Result := BoundsRect
2162 else
2163 Result := ClientRect;
2164
2165 with Result do
2166 begin
2167 Left := Right - Sz;
2168 Top := Bottom - Sz;
2169 end;
2170end;
2171
2172function TCustomImgView32.GetViewportRect: TRect;
2173var
2174 Sz: Integer;
2175begin
2176 Result := Rect(0, 0, Width, Height);
2177 Sz := GetScrollBarSize;
2178 Dec(Result.Right, Sz);
2179 Dec(Result.Bottom, Sz);
2180end;
2181
2182function TCustomImgView32.IsSizeGripVisible: Boolean;
2183var
2184 P: TWinControl;
2185begin
2186 case SizeGrip of
2187 sgAuto:
2188 begin
2189 Result := False;
2190 if Align <> alClient then Exit;
2191 P := Parent;
2192 while True do
2193 begin
2194 if P is TCustomForm then
2195 begin
2196 Result := True;
2197 Break;
2198 end
2199 else if not Assigned(P) or (P.Align <> alClient) then Exit;
2200 P := P.Parent;
2201 end;
2202 end;
2203
2204 sgNone: Result := False
2205
2206 else { sgAlways }
2207 Result := True;
2208 end;
2209end;
2210
2211procedure TCustomImgView32.Loaded;
2212begin
2213 AlignAll;
2214 Invalidate;
2215 UpdateScrollBars;
2216 if Centered then with Bitmap do ScrollToCenter(Width div 2, Height div 2);
2217 inherited;
2218end;
2219
2220procedure TCustomImgView32.MouseDown(Button: TMouseButton; Shift: TShiftState; X, Y: Integer);
2221{$IFNDEF PLATFORM_INDEPENDENT}
2222var
2223 Action: Cardinal;
2224 Msg: TMessage;
2225 P: TPoint;
2226{$ENDIF}
2227begin
2228{$IFNDEF PLATFORM_INDEPENDENT}
2229 if IsSizeGripVisible and (Owner is TCustomForm) then
2230 begin
2231 P.X := X; P.Y := Y;
2232 if PtInRect(GetSizeGripRect, P) then
2233 begin
2234 Action := HTBOTTOMRIGHT;
2235 Application.ProcessMessages;
2236 Msg.Msg := WM_NCLBUTTONDOWN;
2237 Msg.WParam := Action;
2238 SetCaptureControl(nil);
2239 with Msg do SendMessage(TCustomForm(Owner).Handle, Msg, wParam, lParam);
2240 Exit;
2241 end;
2242 end;
2243{$ENDIF}
2244 inherited;
2245end;
2246
2247procedure TCustomImgView32.MouseMove(Shift: TShiftState; X, Y: Integer);
2248var
2249 P: TPoint;
2250begin
2251 inherited;
2252 if IsSizeGripVisible then
2253 begin
2254 P.X := X; P.Y := Y;
2255 if PtInRect(GetSizeGripRect, P) then Screen.Cursor := crSizeNWSE;
2256 end;
2257end;
2258
2259procedure TCustomImgView32.Paint;
2260begin
2261 if not Assigned(Parent) then
2262 Exit;
2263
2264 if IsSizeGripVisible then
2265 DoDrawSizeGrip(GetSizeGripRect)
2266 else
2267 begin
2268 Canvas.Brush.Color := clBtnFace;
2269 Canvas.FillRect(GetSizeGripRect);
2270 end;
2271 inherited;
2272end;
2273
2274procedure TCustomImgView32.Resize;
2275begin
2276 AlignAll;
2277
2278 if Assigned(Parent) then
2279 begin
2280 if IsSizeGripVisible then
2281 DoDrawSizeGrip(GetSizeGripRect)
2282 else
2283 begin
2284 Canvas.Brush.Color := clBtnFace;
2285 Canvas.FillRect(GetSizeGripRect);
2286 end;
2287 end;
2288
2289 InvalidateCache;
2290 UpdateScrollBars;
2291 UpdateImage;
2292 Invalidate;
2293 inherited;
2294end;
2295
2296procedure TCustomImgView32.Scroll(Dx, Dy: Integer);
2297begin
2298 DisableScrollUpdate := True;
2299 HScroll.Position := HScroll.Position + Dx;
2300 VScroll.Position := VScroll.Position + Dy;
2301 DisableScrollUpdate := False;
2302 UpdateImage;
2303end;
2304
2305procedure TCustomImgView32.ScrollHandler(Sender: TObject);
2306begin
2307 if DisableScrollUpdate then Exit;
2308 if Sender = HScroll then HScroll.Repaint;
2309 if Sender = VScroll then VScroll.Repaint;
2310 UpdateImage;
2311 DoScroll;
2312 Repaint;
2313end;
2314
2315procedure TCustomImgView32.ScrollToCenter(X, Y: Integer);
2316var
2317 ScaledDOversize: Integer;
2318begin
2319 DisableScrollUpdate := True;
2320 AlignAll;
2321
2322 ScaledDOversize := Round(FOversize * Scale);
2323 with GetViewportRect do
2324 begin
2325 HScroll.Position := X * Scale - (Right - Left) * 0.5 + ScaledDOversize;
2326 VScroll.Position := Y * Scale - (Bottom - Top) * 0.5 + ScaledDOversize;
2327 end;
2328 DisableScrollUpdate := False;
2329 UpdateImage;
2330end;
2331
2332procedure TCustomImgView32.Recenter;
2333begin
2334 InvalidateCache;
2335 HScroll.Centered := FCentered;
2336 VScroll.Centered := FCentered;
2337 UpdateScrollBars;
2338 UpdateImage;
2339 if FCentered then
2340 with Bitmap do
2341 ScrollToCenter(Width div 2, Height div 2)
2342 else
2343 ScrollToCenter(0, 0);
2344end;
2345
2346procedure TCustomImgView32.SetCentered(Value: Boolean);
2347begin
2348 FCentered := Value;
2349 Recenter;
2350end;
2351
2352procedure TCustomImgView32.SetOverSize(const Value: Integer);
2353begin
2354 if Value <> FOverSize then
2355 begin
2356 FOverSize := Value;
2357 Invalidate;
2358 end;
2359end;
2360
2361procedure TCustomImgView32.SetScrollBars(Value: TIVScrollProperties);
2362begin
2363 FScrollBars.Assign(Value);
2364end;
2365
2366procedure TCustomImgView32.SetSizeGrip(Value: TSizeGripStyle);
2367begin
2368 if Value <> FSizeGrip then
2369 begin
2370 FSizeGrip := Value;
2371 Invalidate;
2372 end;
2373end;
2374
2375procedure TCustomImgView32.UpdateImage;
2376var
2377 Sz: TSize;
2378 W, H: Integer;
2379 ScaledOversize: Integer;
2380begin
2381 Sz := GetBitmapSize;
2382 ScaledOversize := Round(FOversize * Scale);
2383
2384 with GetViewportRect do
2385 begin
2386 W := Right - Left;
2387 H := Bottom - Top;
2388 end;
2389 BeginUpdate;
2390 if not Centered then
2391 begin
2392 OffsetHorz := -HScroll.Position + ScaledOversize;
2393 OffsetVert := -VScroll.Position + ScaledOversize;
2394 end
2395 else
2396 begin
2397 if W > Sz.Cx + 2 * ScaledOversize then // Viewport is bigger than scaled Bitmap
2398 OffsetHorz := (W - Sz.Cx) * 0.5
2399 else
2400 OffsetHorz := -HScroll.Position + ScaledOversize;
2401
2402 if H > Sz.Cy + 2 * ScaledOversize then // Viewport is bigger than scaled Bitmap
2403 OffsetVert := (H - Sz.Cy) * 0.5
2404 else
2405 OffsetVert := -VScroll.Position + ScaledOversize;
2406 end;
2407 InvalidateCache;
2408 EndUpdate;
2409 Changed;
2410end;
2411
2412procedure TCustomImgView32.UpdateScrollBars;
2413var
2414 Sz: TSize;
2415 ScaledDOversize: Integer;
2416begin
2417 if Assigned(HScroll) and Assigned(VScroll) then
2418 begin
2419 Sz := GetBitmapSize;
2420 ScaledDOversize := Round(2 * FOversize * Scale);
2421
2422 HScroll.Range := Sz.Cx + ScaledDOversize;
2423 VScroll.Range := Sz.Cy + ScaledDOversize;
2424
2425 // call AlignAll for Visibility svAuto, because the ranges of the scrollbars
2426 // may have just changed, thus we need to update the visibility of the scrollbars:
2427 if FScrollBarVisibility = svAuto then AlignAll;
2428 end;
2429end;
2430
2431procedure TCustomImgView32.SetScaleMode(Value: TScaleMode);
2432begin
2433 inherited;
2434 Recenter;
2435end;
2436
2437{ TBitmap32Item }
2438
2439procedure TBitmap32Item.AssignTo(Dest: TPersistent);
2440begin
2441 if Dest is TBitmap32Item then
2442 TBitmap32Item(Dest).Bitmap.Assign(Bitmap)
2443 else
2444 inherited;
2445end;
2446
2447constructor TBitmap32Item.Create(Collection: TCollection);
2448begin
2449 inherited;
2450 FBitmap := TBitmap32.Create;
2451end;
2452
2453destructor TBitmap32Item.Destroy;
2454begin
2455 FBitmap.Free;
2456 inherited;
2457end;
2458
2459procedure TBitmap32Item.SetBitmap(ABitmap: TBitmap32);
2460begin
2461 FBitmap.Assign(ABitmap)
2462end;
2463
2464
2465
2466
2467{ TBitmap32Collection }
2468
2469function TBitmap32Collection.Add: TBitmap32Item;
2470begin
2471 Result := TBitmap32Item(inherited Add);
2472end;
2473
2474constructor TBitmap32Collection.Create(AOwner: TPersistent; ItemClass: TBitmap32ItemClass);
2475begin
2476 inherited Create(ItemClass);
2477 FOwner := AOwner;
2478end;
2479
2480function TBitmap32Collection.GetItem(Index: Integer): TBitmap32Item;
2481begin
2482 Result := TBitmap32Item(inherited GetItem(Index));
2483end;
2484
2485function TBitmap32Collection.GetOwner: TPersistent;
2486begin
2487 Result := FOwner;
2488end;
2489
2490procedure TBitmap32Collection.SetItem(Index: Integer; Value: TBitmap32Item);
2491begin
2492 inherited SetItem(Index, Value);
2493end;
2494
2495
2496
2497
2498{ TBitmap32List }
2499
2500constructor TBitmap32List.Create(AOwner: TComponent);
2501begin
2502 inherited;
2503 FBitmap32Collection := TBitmap32Collection.Create(Self, TBitmap32Item);
2504end;
2505
2506destructor TBitmap32List.Destroy;
2507begin
2508 FBitmap32Collection.Free;
2509 inherited;
2510end;
2511
2512function TBitmap32List.GetBitmap(Index: Integer): TBitmap32;
2513begin
2514 Result := FBitmap32Collection.Items[Index].Bitmap;
2515end;
2516
2517procedure TBitmap32List.SetBitmap(Index: Integer; Value: TBitmap32);
2518begin
2519 FBitmap32Collection.Items[Index].Bitmap := Value;
2520end;
2521
2522procedure TBitmap32List.SetBitmap32Collection(Value: TBitmap32Collection);
2523begin
2524 FBitmap32Collection := Value;
2525end;
2526
2527end.
Note: See TracBrowser for help on using the repository browser.