1 | unit 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 |
|
---|
40 | interface
|
---|
41 |
|
---|
42 | {$I GR32.inc}
|
---|
43 |
|
---|
44 | uses
|
---|
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 |
|
---|
54 | const
|
---|
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 |
|
---|
64 | type
|
---|
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 |
|
---|
564 | implementation
|
---|
565 |
|
---|
566 | uses
|
---|
567 | Math, TypInfo, GR32_MicroTiles, GR32_Backends, GR32_XPThemes;
|
---|
568 |
|
---|
569 | type
|
---|
570 | TLayerAccess = class(TCustomLayer);
|
---|
571 | TLayerCollectionAccess = class(TLayerCollection);
|
---|
572 | TRangeBarAccess = class(TRangeBar);
|
---|
573 |
|
---|
574 | const
|
---|
575 | DefaultRepaintOptimizerClass: TCustomRepaintOptimizerClass = TMicroTilesRepaintOptimizer;
|
---|
576 |
|
---|
577 | resourcestring
|
---|
578 | RCStrInvalidStageIndex = 'Invalid stage index';
|
---|
579 |
|
---|
580 | { TPaintStages }
|
---|
581 |
|
---|
582 | function TPaintStages.Add: PPaintStage;
|
---|
583 | var
|
---|
584 | L: Integer;
|
---|
585 | begin
|
---|
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;
|
---|
596 | end;
|
---|
597 |
|
---|
598 | procedure TPaintStages.Clear;
|
---|
599 | begin
|
---|
600 | FItems := nil;
|
---|
601 | end;
|
---|
602 |
|
---|
603 | function TPaintStages.Count: Integer;
|
---|
604 | begin
|
---|
605 | Result := Length(FItems);
|
---|
606 | end;
|
---|
607 |
|
---|
608 | procedure TPaintStages.Delete(Index: Integer);
|
---|
609 | var
|
---|
610 | Count: Integer;
|
---|
611 | begin
|
---|
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));
|
---|
618 | end;
|
---|
619 |
|
---|
620 | destructor TPaintStages.Destroy;
|
---|
621 | begin
|
---|
622 | Clear;
|
---|
623 | inherited;
|
---|
624 | end;
|
---|
625 |
|
---|
626 | function TPaintStages.GetItem(Index: Integer): PPaintStage;
|
---|
627 | begin
|
---|
628 | Result := @FItems[Index];
|
---|
629 | end;
|
---|
630 |
|
---|
631 | function TPaintStages.Insert(Index: Integer): PPaintStage;
|
---|
632 | var
|
---|
633 | Count: Integer;
|
---|
634 | begin
|
---|
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;
|
---|
649 | end;
|
---|
650 |
|
---|
651 |
|
---|
652 | { TCustomPaintBox32 }
|
---|
653 |
|
---|
654 | {$IFNDEF FPC}
|
---|
655 | procedure TCustomPaintBox32.CMInvalidate(var Message: TMessage);
|
---|
656 | begin
|
---|
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;
|
---|
664 | end;
|
---|
665 | {$ENDIF}
|
---|
666 |
|
---|
667 | procedure TCustomPaintBox32.AssignTo(Dest: TPersistent);
|
---|
668 | begin
|
---|
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;
|
---|
683 | end;
|
---|
684 |
|
---|
685 | procedure TCustomPaintBox32.CMMouseEnter(var Message: {$IFDEF FPC}TLMessage{$ELSE}TMessage{$ENDIF});
|
---|
686 | begin
|
---|
687 | inherited;
|
---|
688 | MouseEnter;
|
---|
689 | end;
|
---|
690 |
|
---|
691 | procedure TCustomPaintBox32.CMMouseLeave(var Message: {$IFDEF FPC}TLMessage{$ELSE}TMessage{$ENDIF});
|
---|
692 | begin
|
---|
693 | MouseLeave;
|
---|
694 | inherited;
|
---|
695 | end;
|
---|
696 |
|
---|
697 | constructor TCustomPaintBox32.Create(AOwner: TComponent);
|
---|
698 | begin
|
---|
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}
|
---|
711 | end;
|
---|
712 |
|
---|
713 | destructor TCustomPaintBox32.Destroy;
|
---|
714 | begin
|
---|
715 | FRepaintOptimizer.Free;
|
---|
716 | FInvalidRects.Free;
|
---|
717 | FBuffer.Free;
|
---|
718 | inherited;
|
---|
719 | end;
|
---|
720 |
|
---|
721 | procedure TCustomPaintBox32.DoBufferResized(const OldWidth, OldHeight: Integer);
|
---|
722 | begin
|
---|
723 | if FRepaintOptimizer.Enabled then
|
---|
724 | FRepaintOptimizer.BufferResizedHandler(FBuffer.Width, FBuffer.Height);
|
---|
725 | end;
|
---|
726 |
|
---|
727 | function TCustomPaintBox32.CustomRepaint: Boolean;
|
---|
728 | begin
|
---|
729 | Result := FRepaintOptimizer.Enabled and not FForceFullRepaint and
|
---|
730 | FRepaintOptimizer.UpdatesAvailable;
|
---|
731 | end;
|
---|
732 |
|
---|
733 | procedure TCustomPaintBox32.DoPrepareInvalidRects;
|
---|
734 | begin
|
---|
735 | if FRepaintOptimizer.Enabled and not FForceFullRepaint then
|
---|
736 | FRepaintOptimizer.PerformOptimization;
|
---|
737 | end;
|
---|
738 |
|
---|
739 | function TCustomPaintBox32.InvalidRectsAvailable: Boolean;
|
---|
740 | begin
|
---|
741 | Result := True;
|
---|
742 | end;
|
---|
743 |
|
---|
744 | procedure TCustomPaintBox32.DoPaintBuffer;
|
---|
745 | begin
|
---|
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;
|
---|
759 | end;
|
---|
760 |
|
---|
761 | procedure TCustomPaintBox32.DoPaintGDIOverlay;
|
---|
762 | begin
|
---|
763 | if Assigned(FOnGDIOverlay) then FOnGDIOverlay(Self);
|
---|
764 | end;
|
---|
765 |
|
---|
766 | procedure TCustomPaintBox32.Flush;
|
---|
767 | begin
|
---|
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;
|
---|
785 | end;
|
---|
786 |
|
---|
787 | procedure TCustomPaintBox32.Flush(const SrcRect: TRect);
|
---|
788 | var
|
---|
789 | R: TRect;
|
---|
790 | begin
|
---|
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;
|
---|
809 | end;
|
---|
810 |
|
---|
811 | function TCustomPaintBox32.GetViewportRect: TRect;
|
---|
812 | begin
|
---|
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;
|
---|
819 | end;
|
---|
820 |
|
---|
821 | procedure TCustomPaintBox32.Invalidate;
|
---|
822 | begin
|
---|
823 | FBufferValid := False;
|
---|
824 | inherited;
|
---|
825 | end;
|
---|
826 |
|
---|
827 | procedure TCustomPaintBox32.ForceFullInvalidate;
|
---|
828 | begin
|
---|
829 | if FRepaintOptimizer.Enabled then FRepaintOptimizer.Reset;
|
---|
830 | FForceFullRepaint := True;
|
---|
831 | Invalidate;
|
---|
832 | end;
|
---|
833 |
|
---|
834 | procedure TCustomPaintBox32.Loaded;
|
---|
835 | begin
|
---|
836 | FBufferValid := False;
|
---|
837 | inherited;
|
---|
838 | end;
|
---|
839 |
|
---|
840 | procedure TCustomPaintBox32.MouseDown(Button: TMouseButton; Shift: TShiftState;
|
---|
841 | X, Y: Integer);
|
---|
842 | begin
|
---|
843 | if (pboAutoFocus in Options) and CanFocus then SetFocus;
|
---|
844 | inherited;
|
---|
845 | end;
|
---|
846 |
|
---|
847 | procedure TCustomPaintBox32.MouseEnter;
|
---|
848 | begin
|
---|
849 | FMouseInControl := True;
|
---|
850 | if Assigned(FOnMouseEnter) then
|
---|
851 | FOnMouseEnter(Self);
|
---|
852 | end;
|
---|
853 |
|
---|
854 | procedure TCustomPaintBox32.MouseLeave;
|
---|
855 | begin
|
---|
856 | FMouseInControl := False;
|
---|
857 | if Assigned(FOnMouseLeave) then
|
---|
858 | FOnMouseLeave(Self);
|
---|
859 | end;
|
---|
860 |
|
---|
861 | procedure TCustomPaintBox32.Paint;
|
---|
862 | begin
|
---|
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;
|
---|
891 | end;
|
---|
892 |
|
---|
893 | procedure TCustomPaintBox32.ResetInvalidRects;
|
---|
894 | begin
|
---|
895 | FInvalidRects.Clear;
|
---|
896 | end;
|
---|
897 |
|
---|
898 | procedure TCustomPaintBox32.Resize;
|
---|
899 | begin
|
---|
900 | ResizeBuffer;
|
---|
901 | BufferValid := False;
|
---|
902 | inherited;
|
---|
903 | end;
|
---|
904 |
|
---|
905 | procedure TCustomPaintBox32.ResizeBuffer;
|
---|
906 | var
|
---|
907 | NewWidth, NewHeight, W, H: Integer;
|
---|
908 | OldWidth, OldHeight: Integer;
|
---|
909 | begin
|
---|
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;
|
---|
948 | end;
|
---|
949 |
|
---|
950 | procedure TCustomPaintBox32.SetBounds(ALeft, ATop, AWidth, AHeight: Integer);
|
---|
951 | begin
|
---|
952 | inherited;
|
---|
953 | if csDesigning in ComponentState then ResizeBuffer;
|
---|
954 | FBufferValid := False;
|
---|
955 | end;
|
---|
956 |
|
---|
957 | procedure TCustomPaintBox32.SetBufferOversize(Value: Integer);
|
---|
958 | begin
|
---|
959 | if Value < 0 then Value := 0;
|
---|
960 | if Value <> FBufferOversize then
|
---|
961 | begin
|
---|
962 | FBufferOversize := Value;
|
---|
963 | ResizeBuffer;
|
---|
964 | FBufferValid := False
|
---|
965 | end;
|
---|
966 | end;
|
---|
967 |
|
---|
968 | procedure TCustomPaintBox32.WMEraseBkgnd(var Message: {$IFDEF FPC}TLmEraseBkgnd{$ELSE}TWmEraseBkgnd{$ENDIF});
|
---|
969 | begin
|
---|
970 | Message.Result := 1;
|
---|
971 | end;
|
---|
972 |
|
---|
973 | procedure TCustomPaintBox32.WMGetDlgCode(var Msg: {$IFDEF FPC}TLMessage{$ELSE}TWmGetDlgCode{$ENDIF});
|
---|
974 | begin
|
---|
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;
|
---|
980 | end;
|
---|
981 |
|
---|
982 | procedure TCustomPaintBox32.WMPaint(var Message: {$IFDEF FPC}TLMPaint{$ELSE}TMessage{$ENDIF});
|
---|
983 | begin
|
---|
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}
|
---|
1003 | end;
|
---|
1004 |
|
---|
1005 | procedure TCustomPaintBox32.DirectAreaUpdateHandler(Sender: TObject;
|
---|
1006 | const Area: TRect; const Info: Cardinal);
|
---|
1007 | begin
|
---|
1008 | FInvalidRects.Add(Area);
|
---|
1009 | if not(csCustomPaint in ControlState) then Repaint;
|
---|
1010 | end;
|
---|
1011 |
|
---|
1012 | procedure TCustomPaintBox32.SetRepaintMode(const Value: TRepaintMode);
|
---|
1013 | begin
|
---|
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;
|
---|
1029 | end;
|
---|
1030 |
|
---|
1031 |
|
---|
1032 | { TPaintBox32 }
|
---|
1033 |
|
---|
1034 | procedure TPaintBox32.DoPaintBuffer;
|
---|
1035 | begin
|
---|
1036 | if Assigned(FOnPaintBuffer) then FOnPaintBuffer(Self);
|
---|
1037 | inherited;
|
---|
1038 | end;
|
---|
1039 |
|
---|
1040 | { TCustomImage32 }
|
---|
1041 |
|
---|
1042 | constructor TCustomImage32.Create(AOwner: TComponent);
|
---|
1043 | begin
|
---|
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;
|
---|
1068 | end;
|
---|
1069 |
|
---|
1070 | destructor TCustomImage32.Destroy;
|
---|
1071 | begin
|
---|
1072 | BeginUpdate;
|
---|
1073 | FPaintStages.Free;
|
---|
1074 | FRepaintOptimizer.UnregisterLayerCollection(FLayers);
|
---|
1075 | FLayers.Free;
|
---|
1076 | FBitmap.Free;
|
---|
1077 | inherited;
|
---|
1078 | end;
|
---|
1079 |
|
---|
1080 | procedure TCustomImage32.BeginUpdate;
|
---|
1081 | begin
|
---|
1082 | // disable OnChange & OnChanging generation
|
---|
1083 | Inc(FUpdateCount);
|
---|
1084 | end;
|
---|
1085 |
|
---|
1086 | procedure TCustomImage32.BitmapResized;
|
---|
1087 | var
|
---|
1088 | W, H: Integer;
|
---|
1089 | begin
|
---|
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;
|
---|
1105 | end;
|
---|
1106 |
|
---|
1107 | procedure TCustomImage32.BitmapChanged(const Area: TRect);
|
---|
1108 | begin
|
---|
1109 | Changed;
|
---|
1110 | end;
|
---|
1111 |
|
---|
1112 | function TCustomImage32.BitmapToControl(const APoint: TPoint): TPoint;
|
---|
1113 | begin
|
---|
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;
|
---|
1121 | end;
|
---|
1122 |
|
---|
1123 | function TCustomImage32.BitmapToControl(const APoint: TFloatPoint): TFloatPoint;
|
---|
1124 | begin
|
---|
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;
|
---|
1132 | end;
|
---|
1133 |
|
---|
1134 | procedure TCustomImage32.BitmapResizeHandler(Sender: TObject);
|
---|
1135 | begin
|
---|
1136 | BitmapResized;
|
---|
1137 | end;
|
---|
1138 |
|
---|
1139 | procedure TCustomImage32.BitmapChangeHandler(Sender: TObject);
|
---|
1140 | begin
|
---|
1141 | FRepaintOptimizer.Reset;
|
---|
1142 | BitmapChanged(Bitmap.Boundsrect);
|
---|
1143 | end;
|
---|
1144 |
|
---|
1145 | procedure TCustomImage32.BitmapAreaChangeHandler(Sender: TObject;
|
---|
1146 | const Area: TRect; const Info: Cardinal);
|
---|
1147 | var
|
---|
1148 | T, R: TRect;
|
---|
1149 | Width, Tx, Ty, I, J: Integer;
|
---|
1150 | begin
|
---|
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);
|
---|
1179 | end;
|
---|
1180 |
|
---|
1181 | procedure TCustomImage32.BitmapDirectAreaChangeHandler(Sender: TObject;
|
---|
1182 | const Area: TRect; const Info: Cardinal);
|
---|
1183 | var
|
---|
1184 | T, R: TRect;
|
---|
1185 | Width, Tx, Ty, I, J: Integer;
|
---|
1186 | begin
|
---|
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;
|
---|
1219 | end;
|
---|
1220 |
|
---|
1221 | function TCustomImage32.CanAutoSize(var NewWidth, NewHeight: Integer): Boolean;
|
---|
1222 | var
|
---|
1223 | W, H: Integer;
|
---|
1224 | begin
|
---|
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;
|
---|
1239 | end;
|
---|
1240 |
|
---|
1241 | procedure TCustomImage32.Changed;
|
---|
1242 | begin
|
---|
1243 | if FUpdateCount = 0 then
|
---|
1244 | begin
|
---|
1245 | Invalidate;
|
---|
1246 | if Assigned(FOnChange) then FOnChange(Self);
|
---|
1247 | end;
|
---|
1248 | end;
|
---|
1249 |
|
---|
1250 | function TCustomImage32.ControlToBitmap(const APoint: TPoint): TPoint;
|
---|
1251 | begin
|
---|
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;
|
---|
1267 | end;
|
---|
1268 |
|
---|
1269 | function TCustomImage32.ControlToBitmap(const APoint: TFloatPoint): TFloatPoint;
|
---|
1270 | begin
|
---|
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;
|
---|
1285 | end;
|
---|
1286 |
|
---|
1287 | procedure TCustomImage32.DoInitStages;
|
---|
1288 | begin
|
---|
1289 | if Assigned(FOnInitStages) then FOnInitStages(Self);
|
---|
1290 | end;
|
---|
1291 |
|
---|
1292 | procedure TCustomImage32.DoPaintBuffer;
|
---|
1293 | var
|
---|
1294 | PaintStageHandlerCount: Integer;
|
---|
1295 | I, J: Integer;
|
---|
1296 | DT, RT: Boolean;
|
---|
1297 | begin
|
---|
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;
|
---|
1357 | end;
|
---|
1358 |
|
---|
1359 | procedure TCustomImage32.DoPaintGDIOverlay;
|
---|
1360 | var
|
---|
1361 | I: Integer;
|
---|
1362 | begin
|
---|
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;
|
---|
1367 | end;
|
---|
1368 |
|
---|
1369 | procedure TCustomImage32.DoScaleChange;
|
---|
1370 | begin
|
---|
1371 | if Assigned(FOnScaleChange) then FOnScaleChange(Self);
|
---|
1372 | end;
|
---|
1373 |
|
---|
1374 | procedure TCustomImage32.EndUpdate;
|
---|
1375 | begin
|
---|
1376 | // re-enable OnChange & OnChanging generation
|
---|
1377 | Dec(FUpdateCount);
|
---|
1378 | Assert(FUpdateCount >= 0, 'Unpaired EndUpdate call');
|
---|
1379 | end;
|
---|
1380 |
|
---|
1381 | procedure TCustomImage32.ExecBitmapFrame(Dest: TBitmap32; StageNum: Integer);
|
---|
1382 | begin
|
---|
1383 | Dest.Canvas.DrawFocusRect(CachedBitmapRect);
|
---|
1384 | end;
|
---|
1385 |
|
---|
1386 | procedure TCustomImage32.ExecClearBackgnd(Dest: TBitmap32; StageNum: Integer);
|
---|
1387 | var
|
---|
1388 | C: TColor32;
|
---|
1389 | I: Integer;
|
---|
1390 | begin
|
---|
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;
|
---|
1416 | end;
|
---|
1417 |
|
---|
1418 | procedure TCustomImage32.ExecClearBuffer(Dest: TBitmap32; StageNum: Integer);
|
---|
1419 | begin
|
---|
1420 | Dest.Clear(Color32(Color));
|
---|
1421 | end;
|
---|
1422 |
|
---|
1423 | procedure TCustomImage32.ExecControlFrame(Dest: TBitmap32; StageNum: Integer);
|
---|
1424 | begin
|
---|
1425 | DrawFocusRect(Dest.Handle, Rect(0, 0, Width, Height));
|
---|
1426 | end;
|
---|
1427 |
|
---|
1428 | procedure TCustomImage32.ExecCustom(Dest: TBitmap32; StageNum: Integer);
|
---|
1429 | begin
|
---|
1430 | if Assigned(FOnPaintStage) then FOnPaintStage(Self, Dest, StageNum);
|
---|
1431 | end;
|
---|
1432 |
|
---|
1433 | procedure TCustomImage32.ExecDrawBitmap(Dest: TBitmap32; StageNum: Integer);
|
---|
1434 | var
|
---|
1435 | I, J, Tx, Ty: Integer;
|
---|
1436 | R: TRect;
|
---|
1437 | begin
|
---|
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;
|
---|
1457 | end;
|
---|
1458 |
|
---|
1459 | procedure TCustomImage32.ExecDrawLayers(Dest: TBitmap32; StageNum: Integer);
|
---|
1460 | var
|
---|
1461 | I: Integer;
|
---|
1462 | Mask: Cardinal;
|
---|
1463 | begin
|
---|
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);
|
---|
1468 | end;
|
---|
1469 |
|
---|
1470 | function TCustomImage32.GetBitmapRect: TRect;
|
---|
1471 | var
|
---|
1472 | Size: TSize;
|
---|
1473 | begin
|
---|
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;
|
---|
1491 | end;
|
---|
1492 |
|
---|
1493 | function TCustomImage32.GetBitmapSize: TSize;
|
---|
1494 | var
|
---|
1495 | Mode: TScaleMode;
|
---|
1496 | ViewportWidth, ViewportHeight: Integer;
|
---|
1497 | RScaleX, RScaleY: TFloat;
|
---|
1498 | begin
|
---|
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;
|
---|
1568 | end;
|
---|
1569 |
|
---|
1570 | function TCustomImage32.GetOnPixelCombine: TPixelCombineEvent;
|
---|
1571 | begin
|
---|
1572 | Result := FBitmap.OnPixelCombine;
|
---|
1573 | end;
|
---|
1574 |
|
---|
1575 | procedure TCustomImage32.InitDefaultStages;
|
---|
1576 | begin
|
---|
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;
|
---|
1617 | end;
|
---|
1618 |
|
---|
1619 | procedure TCustomImage32.Invalidate;
|
---|
1620 | begin
|
---|
1621 | BufferValid := False;
|
---|
1622 | CacheValid := False;
|
---|
1623 | inherited;
|
---|
1624 | end;
|
---|
1625 |
|
---|
1626 | procedure TCustomImage32.InvalidateCache;
|
---|
1627 | begin
|
---|
1628 | if FRepaintOptimizer.Enabled and CacheValid then
|
---|
1629 | FRepaintOptimizer.Reset;
|
---|
1630 | CacheValid := False;
|
---|
1631 | end;
|
---|
1632 |
|
---|
1633 | function TCustomImage32.InvalidRectsAvailable: Boolean;
|
---|
1634 | begin
|
---|
1635 | // avoid calling inherited, we have a totally different behaviour here...
|
---|
1636 | DoPrepareInvalidRects;
|
---|
1637 | Result := FInvalidRects.Count > 0;
|
---|
1638 | end;
|
---|
1639 |
|
---|
1640 | procedure TCustomImage32.LayerCollectionChangeHandler(Sender: TObject);
|
---|
1641 | begin
|
---|
1642 | Changed;
|
---|
1643 | end;
|
---|
1644 |
|
---|
1645 | procedure TCustomImage32.LayerCollectionGDIUpdateHandler(Sender: TObject);
|
---|
1646 | begin
|
---|
1647 | Paint;
|
---|
1648 | end;
|
---|
1649 |
|
---|
1650 | procedure TCustomImage32.LayerCollectionGetViewportScaleHandler(Sender: TObject;
|
---|
1651 | out ScaleX, ScaleY: TFloat);
|
---|
1652 | begin
|
---|
1653 | UpdateCache;
|
---|
1654 | ScaleX := CachedScaleX;
|
---|
1655 | ScaleY := CachedScaleY;
|
---|
1656 | end;
|
---|
1657 |
|
---|
1658 | procedure TCustomImage32.LayerCollectionGetViewportShiftHandler(Sender: TObject;
|
---|
1659 | out ShiftX, ShiftY: TFloat);
|
---|
1660 | begin
|
---|
1661 | UpdateCache;
|
---|
1662 | ShiftX := CachedShiftX;
|
---|
1663 | ShiftY := CachedShiftY;
|
---|
1664 | end;
|
---|
1665 |
|
---|
1666 | procedure TCustomImage32.Loaded;
|
---|
1667 | begin
|
---|
1668 | inherited;
|
---|
1669 | DoInitStages;
|
---|
1670 | end;
|
---|
1671 |
|
---|
1672 | procedure TCustomImage32.MouseDown(Button: TMouseButton; Shift: TShiftState; X, Y: Integer);
|
---|
1673 | var
|
---|
1674 | Layer: TCustomLayer;
|
---|
1675 | begin
|
---|
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);
|
---|
1690 | end;
|
---|
1691 |
|
---|
1692 | procedure TCustomImage32.MouseMove(Shift: TShiftState; X, Y: Integer);
|
---|
1693 | var
|
---|
1694 | Layer: TCustomLayer;
|
---|
1695 | begin
|
---|
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);
|
---|
1703 | end;
|
---|
1704 |
|
---|
1705 | procedure TCustomImage32.MouseUp(Button: TMouseButton; Shift: TShiftState; X, Y: Integer);
|
---|
1706 | var
|
---|
1707 | Layer: TCustomLayer;
|
---|
1708 | MouseListener: TCustomLayer;
|
---|
1709 | begin
|
---|
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);
|
---|
1722 | end;
|
---|
1723 |
|
---|
1724 | procedure TCustomImage32.MouseDown(Button: TMouseButton;
|
---|
1725 | Shift: TShiftState; X, Y: Integer; Layer: TCustomLayer);
|
---|
1726 | begin
|
---|
1727 | if Assigned(FOnMouseDown) then
|
---|
1728 | FOnMouseDown(Self, Button, Shift, X, Y, Layer);
|
---|
1729 | end;
|
---|
1730 |
|
---|
1731 | procedure TCustomImage32.MouseMove(Shift: TShiftState; X, Y: Integer;
|
---|
1732 | Layer: TCustomLayer);
|
---|
1733 | begin
|
---|
1734 | if Assigned(FOnMouseMove) then
|
---|
1735 | FOnMouseMove(Self, Shift, X, Y, Layer);
|
---|
1736 | end;
|
---|
1737 |
|
---|
1738 | procedure TCustomImage32.MouseUp(Button: TMouseButton; Shift: TShiftState;
|
---|
1739 | X, Y: Integer; Layer: TCustomLayer);
|
---|
1740 | begin
|
---|
1741 | if Assigned(FOnMouseUp) then
|
---|
1742 | FOnMouseUp(Self, Button, Shift, X, Y, Layer);
|
---|
1743 | end;
|
---|
1744 |
|
---|
1745 | procedure TCustomImage32.MouseLeave;
|
---|
1746 | begin
|
---|
1747 | if (Layers.MouseEvents) and (Layers.MouseListener = nil) then
|
---|
1748 | Screen.Cursor := crDefault;
|
---|
1749 | inherited;
|
---|
1750 | end;
|
---|
1751 |
|
---|
1752 | procedure TCustomImage32.PaintTo(Dest: TBitmap32; DestRect: TRect);
|
---|
1753 | var
|
---|
1754 | OldRepaintMode: TRepaintMode;
|
---|
1755 | I: Integer;
|
---|
1756 | begin
|
---|
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;
|
---|
1792 | end;
|
---|
1793 |
|
---|
1794 | procedure TCustomImage32.Resize;
|
---|
1795 | begin
|
---|
1796 | InvalidateCache;
|
---|
1797 | inherited;
|
---|
1798 | end;
|
---|
1799 |
|
---|
1800 | procedure TCustomImage32.SetBitmap(Value: TBitmap32);
|
---|
1801 | begin
|
---|
1802 | InvalidateCache;
|
---|
1803 | FBitmap.Assign(Value);
|
---|
1804 | end;
|
---|
1805 |
|
---|
1806 | procedure TCustomImage32.SetBitmapAlign(Value: TBitmapAlign);
|
---|
1807 | begin
|
---|
1808 | InvalidateCache;
|
---|
1809 | FBitmapAlign := Value;
|
---|
1810 | Changed;
|
---|
1811 | end;
|
---|
1812 |
|
---|
1813 | procedure TCustomImage32.SetLayers(Value: TLayerCollection);
|
---|
1814 | begin
|
---|
1815 | FLayers.Assign(Value);
|
---|
1816 | end;
|
---|
1817 |
|
---|
1818 | procedure TCustomImage32.SetOffsetHorz(Value: TFloat);
|
---|
1819 | begin
|
---|
1820 | if Value <> FOffsetHorz then
|
---|
1821 | begin
|
---|
1822 | InvalidateCache;
|
---|
1823 | FOffsetHorz := Value;
|
---|
1824 | Changed;
|
---|
1825 | end;
|
---|
1826 | end;
|
---|
1827 |
|
---|
1828 | procedure TCustomImage32.SetOffsetVert(Value: TFloat);
|
---|
1829 | begin
|
---|
1830 | if Value <> FOffsetVert then
|
---|
1831 | begin
|
---|
1832 | FOffsetVert := Value;
|
---|
1833 | InvalidateCache;
|
---|
1834 | Changed;
|
---|
1835 | end;
|
---|
1836 | end;
|
---|
1837 |
|
---|
1838 | procedure TCustomImage32.SetOnPixelCombine(Value: TPixelCombineEvent);
|
---|
1839 | begin
|
---|
1840 | FBitmap.OnPixelCombine := Value;
|
---|
1841 | Changed;
|
---|
1842 | end;
|
---|
1843 |
|
---|
1844 | procedure TCustomImage32.SetScale(Value: TFloat);
|
---|
1845 | begin
|
---|
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;
|
---|
1859 | end;
|
---|
1860 |
|
---|
1861 | procedure TCustomImage32.SetScaleX(Value: TFloat);
|
---|
1862 | begin
|
---|
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;
|
---|
1873 | end;
|
---|
1874 |
|
---|
1875 | procedure TCustomImage32.SetScaleY(Value: TFloat);
|
---|
1876 | begin
|
---|
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;
|
---|
1887 | end;
|
---|
1888 |
|
---|
1889 | procedure TCustomImage32.SetScaleMode(Value: TScaleMode);
|
---|
1890 | begin
|
---|
1891 | if Value <> FScaleMode then
|
---|
1892 | begin
|
---|
1893 | InvalidateCache;
|
---|
1894 | FScaleMode := Value;
|
---|
1895 | Changed;
|
---|
1896 | end;
|
---|
1897 | end;
|
---|
1898 |
|
---|
1899 | procedure TCustomImage32.SetupBitmap(DoClear: Boolean = False; ClearColor: TColor32 = $FF000000);
|
---|
1900 | begin
|
---|
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;
|
---|
1908 | end;
|
---|
1909 |
|
---|
1910 | procedure TCustomImage32.SetXForm(ShiftX, ShiftY, ScaleX, ScaleY: TFloat);
|
---|
1911 | begin
|
---|
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;
|
---|
1925 | end;
|
---|
1926 |
|
---|
1927 | procedure TCustomImage32.SetRepaintMode(const Value: TRepaintMode);
|
---|
1928 | begin
|
---|
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;
|
---|
1946 | end;
|
---|
1947 |
|
---|
1948 | procedure TCustomImage32.Update(const Rect: TRect);
|
---|
1949 | begin
|
---|
1950 | if FRepaintOptimizer.Enabled then
|
---|
1951 | FRepaintOptimizer.AreaUpdateHandler(Self, Rect, AREAINFO_RECT);
|
---|
1952 | end;
|
---|
1953 |
|
---|
1954 | procedure TCustomImage32.UpdateCache;
|
---|
1955 | begin
|
---|
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;
|
---|
1969 | end;
|
---|
1970 |
|
---|
1971 |
|
---|
1972 | { TIVScrollProperties }
|
---|
1973 |
|
---|
1974 | function TIVScrollProperties.GetIncrement: Integer;
|
---|
1975 | begin
|
---|
1976 | Result := Round(TCustomRangeBar(Master).Increment);
|
---|
1977 | end;
|
---|
1978 |
|
---|
1979 | function TIVScrollProperties.GetSize: Integer;
|
---|
1980 | begin
|
---|
1981 | Result := ImgView.FScrollBarSize;
|
---|
1982 | end;
|
---|
1983 |
|
---|
1984 | function TIVScrollProperties.GetVisibility: TScrollbarVisibility;
|
---|
1985 | begin
|
---|
1986 | Result := ImgView.FScrollBarVisibility;
|
---|
1987 | end;
|
---|
1988 |
|
---|
1989 | procedure TIVScrollProperties.SetIncrement(Value: Integer);
|
---|
1990 | begin
|
---|
1991 | TCustomRangeBar(Master).Increment := Value;
|
---|
1992 | TCustomRangeBar(Slave).Increment := Value;
|
---|
1993 | end;
|
---|
1994 |
|
---|
1995 | procedure TIVScrollProperties.SetSize(Value: Integer);
|
---|
1996 | begin
|
---|
1997 | ImgView.FScrollBarSize := Value;
|
---|
1998 | ImgView.AlignAll;
|
---|
1999 | ImgView.UpdateImage;
|
---|
2000 | end;
|
---|
2001 |
|
---|
2002 | procedure TIVScrollProperties.SetVisibility(const Value: TScrollbarVisibility);
|
---|
2003 | begin
|
---|
2004 | if Value <> ImgView.FScrollBarVisibility then
|
---|
2005 | begin
|
---|
2006 | ImgView.FScrollBarVisibility := Value;
|
---|
2007 | ImgView.Resize;
|
---|
2008 | end;
|
---|
2009 | end;
|
---|
2010 |
|
---|
2011 | { TCustomImgView32 }
|
---|
2012 |
|
---|
2013 | procedure TCustomImgView32.AlignAll;
|
---|
2014 | var
|
---|
2015 | ScrollbarVisible: Boolean;
|
---|
2016 | begin
|
---|
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;
|
---|
2036 | end;
|
---|
2037 |
|
---|
2038 | procedure TCustomImgView32.BitmapResized;
|
---|
2039 | begin
|
---|
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;
|
---|
2050 | end;
|
---|
2051 |
|
---|
2052 | constructor TCustomImgView32.Create(AOwner: TComponent);
|
---|
2053 | begin
|
---|
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;
|
---|
2092 | end;
|
---|
2093 |
|
---|
2094 | destructor TCustomImgView32.Destroy;
|
---|
2095 | begin
|
---|
2096 | FreeAndNil(FScrollBars);
|
---|
2097 | inherited;
|
---|
2098 | end;
|
---|
2099 |
|
---|
2100 | procedure TCustomImgView32.DoDrawSizeGrip(R: TRect);
|
---|
2101 | begin
|
---|
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}
|
---|
2112 | end;
|
---|
2113 |
|
---|
2114 | procedure TCustomImgView32.DoScaleChange;
|
---|
2115 | begin
|
---|
2116 | inherited;
|
---|
2117 | InvalidateCache;
|
---|
2118 | UpdateScrollBars;
|
---|
2119 | UpdateImage;
|
---|
2120 | Invalidate;
|
---|
2121 | end;
|
---|
2122 |
|
---|
2123 | procedure TCustomImgView32.DoScroll;
|
---|
2124 | begin
|
---|
2125 | if Assigned(FOnScroll) then FOnScroll(Self);
|
---|
2126 | end;
|
---|
2127 |
|
---|
2128 | function TCustomImgView32.GetScrollBarSize: Integer;
|
---|
2129 | begin
|
---|
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;
|
---|
2137 | end;
|
---|
2138 |
|
---|
2139 | function TCustomImgView32.GetScrollBarsVisible: Boolean;
|
---|
2140 | begin
|
---|
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;
|
---|
2152 | end;
|
---|
2153 |
|
---|
2154 | function TCustomImgView32.GetSizeGripRect: TRect;
|
---|
2155 | var
|
---|
2156 | Sz: Integer;
|
---|
2157 | begin
|
---|
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;
|
---|
2170 | end;
|
---|
2171 |
|
---|
2172 | function TCustomImgView32.GetViewportRect: TRect;
|
---|
2173 | var
|
---|
2174 | Sz: Integer;
|
---|
2175 | begin
|
---|
2176 | Result := Rect(0, 0, Width, Height);
|
---|
2177 | Sz := GetScrollBarSize;
|
---|
2178 | Dec(Result.Right, Sz);
|
---|
2179 | Dec(Result.Bottom, Sz);
|
---|
2180 | end;
|
---|
2181 |
|
---|
2182 | function TCustomImgView32.IsSizeGripVisible: Boolean;
|
---|
2183 | var
|
---|
2184 | P: TWinControl;
|
---|
2185 | begin
|
---|
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;
|
---|
2209 | end;
|
---|
2210 |
|
---|
2211 | procedure TCustomImgView32.Loaded;
|
---|
2212 | begin
|
---|
2213 | AlignAll;
|
---|
2214 | Invalidate;
|
---|
2215 | UpdateScrollBars;
|
---|
2216 | if Centered then with Bitmap do ScrollToCenter(Width div 2, Height div 2);
|
---|
2217 | inherited;
|
---|
2218 | end;
|
---|
2219 |
|
---|
2220 | procedure TCustomImgView32.MouseDown(Button: TMouseButton; Shift: TShiftState; X, Y: Integer);
|
---|
2221 | {$IFNDEF PLATFORM_INDEPENDENT}
|
---|
2222 | var
|
---|
2223 | Action: Cardinal;
|
---|
2224 | Msg: TMessage;
|
---|
2225 | P: TPoint;
|
---|
2226 | {$ENDIF}
|
---|
2227 | begin
|
---|
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;
|
---|
2245 | end;
|
---|
2246 |
|
---|
2247 | procedure TCustomImgView32.MouseMove(Shift: TShiftState; X, Y: Integer);
|
---|
2248 | var
|
---|
2249 | P: TPoint;
|
---|
2250 | begin
|
---|
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;
|
---|
2257 | end;
|
---|
2258 |
|
---|
2259 | procedure TCustomImgView32.Paint;
|
---|
2260 | begin
|
---|
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;
|
---|
2272 | end;
|
---|
2273 |
|
---|
2274 | procedure TCustomImgView32.Resize;
|
---|
2275 | begin
|
---|
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;
|
---|
2294 | end;
|
---|
2295 |
|
---|
2296 | procedure TCustomImgView32.Scroll(Dx, Dy: Integer);
|
---|
2297 | begin
|
---|
2298 | DisableScrollUpdate := True;
|
---|
2299 | HScroll.Position := HScroll.Position + Dx;
|
---|
2300 | VScroll.Position := VScroll.Position + Dy;
|
---|
2301 | DisableScrollUpdate := False;
|
---|
2302 | UpdateImage;
|
---|
2303 | end;
|
---|
2304 |
|
---|
2305 | procedure TCustomImgView32.ScrollHandler(Sender: TObject);
|
---|
2306 | begin
|
---|
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;
|
---|
2313 | end;
|
---|
2314 |
|
---|
2315 | procedure TCustomImgView32.ScrollToCenter(X, Y: Integer);
|
---|
2316 | var
|
---|
2317 | ScaledDOversize: Integer;
|
---|
2318 | begin
|
---|
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;
|
---|
2330 | end;
|
---|
2331 |
|
---|
2332 | procedure TCustomImgView32.Recenter;
|
---|
2333 | begin
|
---|
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);
|
---|
2344 | end;
|
---|
2345 |
|
---|
2346 | procedure TCustomImgView32.SetCentered(Value: Boolean);
|
---|
2347 | begin
|
---|
2348 | FCentered := Value;
|
---|
2349 | Recenter;
|
---|
2350 | end;
|
---|
2351 |
|
---|
2352 | procedure TCustomImgView32.SetOverSize(const Value: Integer);
|
---|
2353 | begin
|
---|
2354 | if Value <> FOverSize then
|
---|
2355 | begin
|
---|
2356 | FOverSize := Value;
|
---|
2357 | Invalidate;
|
---|
2358 | end;
|
---|
2359 | end;
|
---|
2360 |
|
---|
2361 | procedure TCustomImgView32.SetScrollBars(Value: TIVScrollProperties);
|
---|
2362 | begin
|
---|
2363 | FScrollBars.Assign(Value);
|
---|
2364 | end;
|
---|
2365 |
|
---|
2366 | procedure TCustomImgView32.SetSizeGrip(Value: TSizeGripStyle);
|
---|
2367 | begin
|
---|
2368 | if Value <> FSizeGrip then
|
---|
2369 | begin
|
---|
2370 | FSizeGrip := Value;
|
---|
2371 | Invalidate;
|
---|
2372 | end;
|
---|
2373 | end;
|
---|
2374 |
|
---|
2375 | procedure TCustomImgView32.UpdateImage;
|
---|
2376 | var
|
---|
2377 | Sz: TSize;
|
---|
2378 | W, H: Integer;
|
---|
2379 | ScaledOversize: Integer;
|
---|
2380 | begin
|
---|
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;
|
---|
2410 | end;
|
---|
2411 |
|
---|
2412 | procedure TCustomImgView32.UpdateScrollBars;
|
---|
2413 | var
|
---|
2414 | Sz: TSize;
|
---|
2415 | ScaledDOversize: Integer;
|
---|
2416 | begin
|
---|
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;
|
---|
2429 | end;
|
---|
2430 |
|
---|
2431 | procedure TCustomImgView32.SetScaleMode(Value: TScaleMode);
|
---|
2432 | begin
|
---|
2433 | inherited;
|
---|
2434 | Recenter;
|
---|
2435 | end;
|
---|
2436 |
|
---|
2437 | { TBitmap32Item }
|
---|
2438 |
|
---|
2439 | procedure TBitmap32Item.AssignTo(Dest: TPersistent);
|
---|
2440 | begin
|
---|
2441 | if Dest is TBitmap32Item then
|
---|
2442 | TBitmap32Item(Dest).Bitmap.Assign(Bitmap)
|
---|
2443 | else
|
---|
2444 | inherited;
|
---|
2445 | end;
|
---|
2446 |
|
---|
2447 | constructor TBitmap32Item.Create(Collection: TCollection);
|
---|
2448 | begin
|
---|
2449 | inherited;
|
---|
2450 | FBitmap := TBitmap32.Create;
|
---|
2451 | end;
|
---|
2452 |
|
---|
2453 | destructor TBitmap32Item.Destroy;
|
---|
2454 | begin
|
---|
2455 | FBitmap.Free;
|
---|
2456 | inherited;
|
---|
2457 | end;
|
---|
2458 |
|
---|
2459 | procedure TBitmap32Item.SetBitmap(ABitmap: TBitmap32);
|
---|
2460 | begin
|
---|
2461 | FBitmap.Assign(ABitmap)
|
---|
2462 | end;
|
---|
2463 |
|
---|
2464 |
|
---|
2465 |
|
---|
2466 |
|
---|
2467 | { TBitmap32Collection }
|
---|
2468 |
|
---|
2469 | function TBitmap32Collection.Add: TBitmap32Item;
|
---|
2470 | begin
|
---|
2471 | Result := TBitmap32Item(inherited Add);
|
---|
2472 | end;
|
---|
2473 |
|
---|
2474 | constructor TBitmap32Collection.Create(AOwner: TPersistent; ItemClass: TBitmap32ItemClass);
|
---|
2475 | begin
|
---|
2476 | inherited Create(ItemClass);
|
---|
2477 | FOwner := AOwner;
|
---|
2478 | end;
|
---|
2479 |
|
---|
2480 | function TBitmap32Collection.GetItem(Index: Integer): TBitmap32Item;
|
---|
2481 | begin
|
---|
2482 | Result := TBitmap32Item(inherited GetItem(Index));
|
---|
2483 | end;
|
---|
2484 |
|
---|
2485 | function TBitmap32Collection.GetOwner: TPersistent;
|
---|
2486 | begin
|
---|
2487 | Result := FOwner;
|
---|
2488 | end;
|
---|
2489 |
|
---|
2490 | procedure TBitmap32Collection.SetItem(Index: Integer; Value: TBitmap32Item);
|
---|
2491 | begin
|
---|
2492 | inherited SetItem(Index, Value);
|
---|
2493 | end;
|
---|
2494 |
|
---|
2495 |
|
---|
2496 |
|
---|
2497 |
|
---|
2498 | { TBitmap32List }
|
---|
2499 |
|
---|
2500 | constructor TBitmap32List.Create(AOwner: TComponent);
|
---|
2501 | begin
|
---|
2502 | inherited;
|
---|
2503 | FBitmap32Collection := TBitmap32Collection.Create(Self, TBitmap32Item);
|
---|
2504 | end;
|
---|
2505 |
|
---|
2506 | destructor TBitmap32List.Destroy;
|
---|
2507 | begin
|
---|
2508 | FBitmap32Collection.Free;
|
---|
2509 | inherited;
|
---|
2510 | end;
|
---|
2511 |
|
---|
2512 | function TBitmap32List.GetBitmap(Index: Integer): TBitmap32;
|
---|
2513 | begin
|
---|
2514 | Result := FBitmap32Collection.Items[Index].Bitmap;
|
---|
2515 | end;
|
---|
2516 |
|
---|
2517 | procedure TBitmap32List.SetBitmap(Index: Integer; Value: TBitmap32);
|
---|
2518 | begin
|
---|
2519 | FBitmap32Collection.Items[Index].Bitmap := Value;
|
---|
2520 | end;
|
---|
2521 |
|
---|
2522 | procedure TBitmap32List.SetBitmap32Collection(Value: TBitmap32Collection);
|
---|
2523 | begin
|
---|
2524 | FBitmap32Collection := Value;
|
---|
2525 | end;
|
---|
2526 |
|
---|
2527 | end.
|
---|