Changeset 522 for GraphicTest/Packages/Graphics32/GR32_Image.pas

Timestamp:

Apr 17, 2019, 10:42:18 AM (5 years ago)

Author:

chronos

Message:

• Modified: Updated Graphics32 library.

Location:

GraphicTest/Packages/Graphics32

Files:

• . (modified) (1 prop)
• GR32_Image.pas (modified) (24 diffs)

GraphicTest/Packages/Graphics32/GR32_Image.pas

@@ -49 +49 @@
 {$ENDIF}
   Graphics, Controls, Forms,
-  Classes, SysUtils, GR32, GR32_Layers, GR32_RangeBars, GR32_LowLevel,
-  GR32_System, GR32_Containers, GR32_RepaintOpt;
+  Classes, SysUtils, GR32, GR32_Layers, GR32_RangeBars, GR32_Containers,
+  GR32_RepaintOpt;
 
 const
@@ -118 +118 @@
     procedure CMMouseEnter(var Message: TLMessage); message LM_MOUSEENTER;
     procedure CMMouseLeave(var Message: TLMessage); message LM_MOUSELEAVE;
-    procedure CMInvalidate(var Message: TLMessage); message CM_INVALIDATE;
 {$ELSE}
     procedure WMEraseBkgnd(var Message: TWmEraseBkgnd); message WM_ERASEBKGND;
@@ -278 +277 @@
     procedure InvalidateCache;
     function  InvalidRectsAvailable: Boolean; override;
-    procedure DblClick; override;
     procedure MouseDown(Button: TMouseButton; Shift: TShiftState; X, Y: Integer); overload; override;
     procedure MouseMove(Shift: TShiftState; X, Y: Integer); overload; override;
@@ -366 +364 @@
     property OnClick;
     property OnChange;
+    property OnContextPopup;
     property OnDblClick;
     property OnGDIOverlay;
@@ -653 +652 @@
 { TCustomPaintBox32 }
 
-{$IFDEF FPC}
-procedure TCustomPaintBox32.CMInvalidate(var Message: TLMessage);
-begin
-  if CustomRepaint and HandleAllocated then
-    PostMessage(Handle, LM_PAINT, 0, 0)
-  else
-    inherited;
-end;
-{$ELSE}
-
+{$IFNDEF FPC}
 procedure TCustomPaintBox32.CMInvalidate(var Message: TMessage);
 begin
@@ -848 +838 @@
 end;
 
-procedure TCustomPaintBox32.MouseDown(Button: TMouseButton; Shift: TShiftState; X, Y: Integer);
+procedure TCustomPaintBox32.MouseDown(Button: TMouseButton; Shift: TShiftState;
+  X, Y: Integer);
 begin
   if (pboAutoFocus in Options) and CanFocus then SetFocus;
@@ -874 +865 @@
 
   if FRepaintOptimizer.Enabled then
-  begin
     FRepaintOptimizer.BeginPaint;
-  end;
 
   if not FBufferValid then
@@ -984 +973 @@
 procedure TCustomPaintBox32.WMGetDlgCode(var Msg: {$IFDEF FPC}TLMessage{$ELSE}TWmGetDlgCode{$ENDIF});
 begin
-  with Msg do if pboWantArrowKeys in Options then
-    Result:= Result or DLGC_WANTARROWS
-  else
-    Result:= Result and not DLGC_WANTARROWS;
+  with Msg do
+    if pboWantArrowKeys in Options then
+      Result:= Result or DLGC_WANTARROWS
+    else
+      Result:= Result and not DLGC_WANTARROWS;
 end;
 
@@ -1050 +1040 @@
 { TCustomImage32 }
 
+constructor TCustomImage32.Create(AOwner: TComponent);
+begin
+  inherited;
+  ControlStyle := [csAcceptsControls, csCaptureMouse, csClickEvents,
+    csDoubleClicks, csReplicatable, csOpaque];
+  FBitmap := TBitmap32.Create;
+  FBitmap.OnResize := BitmapResizeHandler;
+
+  FLayers := TLayerCollection.Create(Self);
+  with TLayerCollectionAccess(FLayers) do
+  begin
+    OnChange := LayerCollectionChangeHandler;
+    OnGDIUpdate := LayerCollectionGDIUpdateHandler;
+    OnGetViewportScale := LayerCollectionGetViewportScaleHandler;
+    OnGetViewportShift := LayerCollectionGetViewportShiftHandler;
+  end;
+
+  FRepaintOptimizer.RegisterLayerCollection(FLayers);
+  RepaintMode := rmFull;
+
+  FPaintStages := TPaintStages.Create;
+  FScaleX := 1;
+  FScaleY := 1;
+  SetXForm(0, 0, 1, 1);
+
+  InitDefaultStages;
+end;
+
+destructor TCustomImage32.Destroy;
+begin
+  BeginUpdate;
+  FPaintStages.Free;
+  FRepaintOptimizer.UnregisterLayerCollection(FLayers);
+  FLayers.Free;
+  FBitmap.Free;
+  inherited;
+end;
+
 procedure TCustomImage32.BeginUpdate;
 begin
@@ -1104 +1132 @@
 end;
 
-function TCustomImage32.CanAutoSize(var NewWidth, NewHeight: Integer): Boolean;
-var
-  W, H: Integer;
-begin
-  InvalidateCache;
-  Result := True;
-  W := Bitmap.Width;
-  H := Bitmap.Height;
-  if ScaleMode = smScale then
-  begin
-    W := Round(W * Scale);
-    H := Round(H * Scale);
-  end;
-  if not (csDesigning in ComponentState) or (W > 0) and (H > 0) then
-  begin
-    if Align in [alNone, alLeft, alRight] then NewWidth := W;
-    if Align in [alNone, alTop, alBottom] then NewHeight := H;
-  end;
-end;
-
-procedure TCustomImage32.Changed;
-begin
-  if FUpdateCount = 0 then
-  begin
-    Invalidate;
-    if Assigned(FOnChange) then FOnChange(Self);
-  end;
-end;
-
-procedure TCustomImage32.Update(const Rect: TRect);
-begin
-  if FRepaintOptimizer.Enabled then
-    FRepaintOptimizer.AreaUpdateHandler(Self, Rect, AREAINFO_RECT);
-end;
-
 procedure TCustomImage32.BitmapResizeHandler(Sender: TObject);
 begin
@@ -1150 +1143 @@
 end;
 
-procedure TCustomImage32.BitmapAreaChangeHandler(Sender: TObject; const Area: TRect; const Info: Cardinal);
+procedure TCustomImage32.BitmapAreaChangeHandler(Sender: TObject;
+  const Area: TRect; const Info: Cardinal);
 var
   T, R: TRect;
@@ -1185 +1179 @@
 end;
 
-procedure TCustomImage32.BitmapDirectAreaChangeHandler(Sender: TObject; const Area: TRect; const Info: Cardinal);
+procedure TCustomImage32.BitmapDirectAreaChangeHandler(Sender: TObject;
+  const Area: TRect; const Info: Cardinal);
 var
   T, R: TRect;
@@ -1224 +1219 @@
 end;
 
-procedure TCustomImage32.LayerCollectionChangeHandler(Sender: TObject);
-begin
-  Changed;
-end;
-
-procedure TCustomImage32.LayerCollectionGDIUpdateHandler(Sender: TObject);
-begin
-  Paint;
-end;
-
-procedure TCustomImage32.LayerCollectionGetViewportScaleHandler(Sender: TObject;
-  out ScaleX, ScaleY: TFloat);
-begin
-  UpdateCache;
-  ScaleX := CachedScaleX;
-  ScaleY := CachedScaleY;
-end;
-
-procedure TCustomImage32.LayerCollectionGetViewportShiftHandler(Sender: TObject;
-  out ShiftX, ShiftY: TFloat);
-begin
-  UpdateCache;
-  ShiftX := CachedShiftX;
-  ShiftY := CachedShiftY;
+function TCustomImage32.CanAutoSize(var NewWidth, NewHeight: Integer): Boolean;
+var
+  W, H: Integer;
+begin
+  InvalidateCache;
+  Result := True;
+  W := Bitmap.Width;
+  H := Bitmap.Height;
+  if ScaleMode = smScale then
+  begin
+    W := Round(W * Scale);
+    H := Round(H * Scale);
+  end;
+  if not (csDesigning in ComponentState) or (W > 0) and (H > 0) then
+  begin
+    if Align in [alNone, alLeft, alRight] then NewWidth := W;
+    if Align in [alNone, alTop, alBottom] then NewHeight := H;
+  end;
+end;
+
+procedure TCustomImage32.Changed;
+begin
+  if FUpdateCount = 0 then
+  begin
+    Invalidate;
+    if Assigned(FOnChange) then FOnChange(Self);
+  end;
 end;
 
@@ -1285 +1283 @@
       Result.Y := (Y - CachedShiftY) * CachedRecScaleY;
   end;
-end;
-
-
-constructor TCustomImage32.Create(AOwner: TComponent);
-begin
-  inherited;
-  ControlStyle := [csAcceptsControls, csCaptureMouse, csClickEvents,
-    csDoubleClicks, csReplicatable, csOpaque];
-  FBitmap := TBitmap32.Create;
-  FBitmap.OnResize := BitmapResizeHandler;
-
-  FLayers := TLayerCollection.Create(Self);
-  with TLayerCollectionAccess(FLayers) do
-  begin
-    OnChange := LayerCollectionChangeHandler;
-    OnGDIUpdate := LayerCollectionGDIUpdateHandler;
-    OnGetViewportScale := LayerCollectionGetViewportScaleHandler;
-    OnGetViewportShift := LayerCollectionGetViewportShiftHandler;
-  end;
-
-  FRepaintOptimizer.RegisterLayerCollection(FLayers);
-  RepaintMode := rmFull;
-
-  FPaintStages := TPaintStages.Create;
-  FScaleX := 1;
-  FScaleY := 1;
-  SetXForm(0, 0, 1, 1);
-
-  InitDefaultStages;
-end;
-
-procedure TCustomImage32.DblClick;
-begin
-  Layers.MouseListener := nil;
-  MouseUp(mbLeft, [], 0, 0);
-  inherited;
-end;
-
-destructor TCustomImage32.Destroy;
-begin
-  BeginUpdate;
-  FPaintStages.Free;
-  FRepaintOptimizer.UnregisterLayerCollection(FLayers);
-  FLayers.Free;
-  FBitmap.Free;
-  inherited;
 end;
 
@@ -1674 +1626 @@
 procedure TCustomImage32.InvalidateCache;
 begin
-  if FRepaintOptimizer.Enabled then FRepaintOptimizer.Reset;
+  if FRepaintOptimizer.Enabled and CacheValid then
+    FRepaintOptimizer.Reset;
   CacheValid := False;
 end;
 
+function TCustomImage32.InvalidRectsAvailable: Boolean;
+begin
+  // avoid calling inherited, we have a totally different behaviour here...
+  DoPrepareInvalidRects;
+  Result := FInvalidRects.Count > 0;
+end;
+
+procedure TCustomImage32.LayerCollectionChangeHandler(Sender: TObject);
+begin
+  Changed;
+end;
+
+procedure TCustomImage32.LayerCollectionGDIUpdateHandler(Sender: TObject);
+begin
+  Paint;
+end;
+
+procedure TCustomImage32.LayerCollectionGetViewportScaleHandler(Sender: TObject;
+  out ScaleX, ScaleY: TFloat);
+begin
+  UpdateCache;
+  ScaleX := CachedScaleX;
+  ScaleY := CachedScaleY;
+end;
+
+procedure TCustomImage32.LayerCollectionGetViewportShiftHandler(Sender: TObject;
+  out ShiftX, ShiftY: TFloat);
+begin
+  UpdateCache;
+  ShiftX := CachedShiftX;
+  ShiftY := CachedShiftY;
+end;
+
 procedure TCustomImage32.Loaded;
 begin
@@ -1691 +1677 @@
 
   if TabStop and CanFocus then SetFocus;
-  
+
   if Layers.MouseEvents then
     Layer := TLayerCollectionAccess(Layers).MouseDown(Button, Shift, X, Y)
@@ -1720 +1706 @@
 var
   Layer: TCustomLayer;
-begin
+  MouseListener: TCustomLayer;
+begin
+  MouseListener := TLayerCollectionAccess(Layers).MouseListener;
+
   if Layers.MouseEvents then
     Layer := TLayerCollectionAccess(Layers).MouseUp(Button, Shift, X, Y)
@@ -1727 +1716 @@
 
   // unlock the capture using same criteria as was used to acquire it
-  if (Button = mbLeft) or (TLayerCollectionAccess(Layers).MouseListener <> nil) then
+  if (Button = mbLeft) or ((MouseListener <> nil) and (TLayerCollectionAccess(Layers).MouseListener = nil)) then
     MouseCapture := False;
 
@@ -1736 +1725 @@
   Shift: TShiftState; X, Y: Integer; Layer: TCustomLayer);
 begin
-  if Assigned(FOnMouseDown) then FOnMouseDown(Self, Button, Shift, X, Y, Layer);
+  if Assigned(FOnMouseDown) then
+    FOnMouseDown(Self, Button, Shift, X, Y, Layer);
 end;
 
@@ -1742 +1732 @@
   Layer: TCustomLayer);
 begin
-  if Assigned(FOnMouseMove) then FOnMouseMove(Self, Shift, X, Y, Layer);
+  if Assigned(FOnMouseMove) then
+    FOnMouseMove(Self, Shift, X, Y, Layer);
 end;
 
@@ -1748 +1739 @@
   X, Y: Integer; Layer: TCustomLayer);
 begin
-  if Assigned(FOnMouseUp) then FOnMouseUp(Self, Button, Shift, X, Y, Layer);
+  if Assigned(FOnMouseUp) then
+    FOnMouseUp(Self, Button, Shift, X, Y, Layer);
 end;
 
@@ -1933 +1925 @@
 end;
 
-procedure TCustomImage32.UpdateCache;
-begin
-  if CacheValid then Exit;
-  CachedBitmapRect := GetBitmapRect;
-
-  if Bitmap.Empty then
-    SetXForm(0, 0, 1, 1)
-  else
-    SetXForm(
-      CachedBitmapRect.Left, CachedBitmapRect.Top,
-      (CachedBitmapRect.Right - CachedBitmapRect.Left) / Bitmap.Width,
-      (CachedBitmapRect.Bottom - CachedBitmapRect.Top) / Bitmap.Height
-    );
-
-  CacheValid := True;
-end;
-
-function TCustomImage32.InvalidRectsAvailable: Boolean;
-begin
-  // avoid calling inherited, we have a totally different behaviour here...
-  DoPrepareInvalidRects;
-  Result := FInvalidRects.Count > 0;
-end;
-
 procedure TCustomImage32.SetRepaintMode(const Value: TRepaintMode);
 begin
@@ -1977 +1945 @@
   end;
 end;
+
+procedure TCustomImage32.Update(const Rect: TRect);
+begin
+  if FRepaintOptimizer.Enabled then
+    FRepaintOptimizer.AreaUpdateHandler(Self, Rect, AREAINFO_RECT);
+end;
+
+procedure TCustomImage32.UpdateCache;
+begin
+  if CacheValid then Exit;
+  CachedBitmapRect := GetBitmapRect;
+
+  if Bitmap.Empty then
+    SetXForm(0, 0, 1, 1)
+  else
+    SetXForm(
+      CachedBitmapRect.Left, CachedBitmapRect.Top,
+      (CachedBitmapRect.Right - CachedBitmapRect.Left) / Bitmap.Width,
+      (CachedBitmapRect.Bottom - CachedBitmapRect.Top) / Bitmap.Height
+    );
+
+  CacheValid := True;
+end;
+
 
 { TIVScrollProperties }
@@ -2404 +2396 @@
   begin
     if W > Sz.Cx + 2 * ScaledOversize then // Viewport is bigger than scaled Bitmap
-      OffsetHorz := (W - Sz.Cx) / 2
+      OffsetHorz := (W - Sz.Cx) * 0.5
     else
       OffsetHorz := -HScroll.Position + ScaledOversize;
 
     if H > Sz.Cy + 2 * ScaledOversize then // Viewport is bigger than scaled Bitmap
-      OffsetVert := (H - Sz.Cy) / 2
+      OffsetVert := (H - Sz.Cy) * 0.5
     else
       OffsetVert := -VScroll.Position + ScaledOversize;