unit MainUnit; (* ***** BEGIN LICENSE BLOCK ***** * Version: MPL 1.1 or LGPL 2.1 with linking exception * * The contents of this file are subject to the Mozilla Public License Version * 1.1 (the "License"); you may not use this file except in compliance with * the License. You may obtain a copy of the License at * http://www.mozilla.org/MPL/ * * Software distributed under the License is distributed on an "AS IS" basis, * WITHOUT WARRANTY OF ANY KIND, either express or implied. See the License * for the specific language governing rights and limitations under the * License. * * Alternatively, the contents of this file may be used under the terms of the * Free Pascal modified version of the GNU Lesser General Public License * Version 2.1 (the "FPC modified LGPL License"), in which case the provisions * of this license are applicable instead of those above. * Please see the file LICENSE.txt for additional information concerning this * license. * * The Original Code is Image View Layers Example * * The Initial Developer of the Original Code is * Alex A. Denisov * * Portions created by the Initial Developer are Copyright (C) 2000-2005 * the Initial Developer. All Rights Reserved. * * Contributor(s): * Andre Beckedorf * Christian-W. Budde * * ***** END LICENSE BLOCK ***** *) interface {$I GR32.inc} uses {$IFDEF FPC}LCLIntf, LResources, LCLType, {$ELSE} Windows, {$ENDIF} SysUtils, Classes, Graphics, Controls, Forms, Dialogs, Menus, ExtCtrls, ExtDlgs, StdCtrls, Buttons, GR32, GR32_Image, GR32_Layers, GR32_RangeBars, GR32_Filters, GR32_Transforms, GR32_Resamplers; type { TMainForm } TMainForm = class(TForm) BtnLayerRescale: TButton; BtnLayerResetScale: TButton; CbxCropped: TCheckBox; CbxImageInterpolate: TCheckBox; CbxLayerInterpolate: TCheckBox; CbxMagnInterpolate: TCheckBox; CbxOptRedraw: TCheckBox; GbrBorderRadius: TGaugeBar; GbrBorderWidth: TGaugeBar; GbrLayerOpacity: TGaugeBar; GbrMagnMagnification: TGaugeBar; GbrMagnOpacity: TGaugeBar; GbrMagnRotation: TGaugeBar; ImgView: TImgView32; LblBorderRadius: TLabel; LblBorderWidth: TLabel; LblMagifierOpacity: TLabel; LblMagnification: TLabel; LblOpacity: TLabel; LblRotation: TLabel; LblScale: TLabel; MainMenu: TMainMenu; MimArrange: TMenuItem; MnuBringFront: TMenuItem; MnuButtonMockup: TMenuItem; MnuDelete: TMenuItem; MnuFile: TMenuItem; MnuFileNew: TMenuItem; MnuFileOpen: TMenuItem; MnuFlatten: TMenuItem; MnuFlipHorz: TMenuItem; MnuFlipVert: TMenuItem; MnuLayers: TMenuItem; MnuLevelDown: TMenuItem; MnuLevelUp: TMenuItem; MnuMagnifier: TMenuItem; MnuNewBitmapLayer: TMenuItem; MnuNewBitmapRGBA: TMenuItem; MnuNewCustomLayer: TMenuItem; MnuPrint: TMenuItem; MnuRotate180: TMenuItem; MnuRotate270: TMenuItem; MnuRotate90: TMenuItem; MnuScaled: TMenuItem; MnuSendBack: TMenuItem; MnuSimpleDrawing: TMenuItem; N1: TMenuItem; N2: TMenuItem; N3: TMenuItem; N4: TMenuItem; N5: TMenuItem; N6: TMenuItem; OpenPictureDialog: TOpenPictureDialog; PnlBitmapLayer: TPanel; PnlBitmapLayerHeader: TPanel; PnlButtonMockup: TPanel; PnlButtonMockupHeader: TPanel; PnlControl: TPanel; PnlImage: TPanel; PnlImageHeader: TPanel; PnlMagnification: TPanel; PnlMagnificationHeader: TPanel; SaveDialog: TSaveDialog; ScaleCombo: TComboBox; N7: TMenuItem; procedure FormCreate(Sender: TObject); procedure FormDestroy(Sender: TObject); procedure BtnLayerRescaleClick(Sender: TObject); procedure BtnLayerResetScaleClick(Sender: TObject); procedure CbxCroppedClick(Sender: TObject); procedure CbxImageInterpolateClick(Sender: TObject); procedure CbxLayerInterpolateClick(Sender: TObject); procedure CbxOptRedrawClick(Sender: TObject); procedure ImgViewKeyDown(Sender: TObject; var Key: Word; Shift: TShiftState); procedure ImgViewMouseDown(Sender: TObject; Button: TMouseButton; Shift: TShiftState; X, Y: Integer; Layer: TCustomLayer); procedure ImgViewMouseWheelDown(Sender: TObject; Shift: TShiftState; MousePos: TPoint; var Handled: Boolean); procedure ImgViewMouseWheelUp(Sender: TObject; Shift: TShiftState; MousePos: TPoint; var Handled: Boolean); procedure ImgViewPaintStage(Sender: TObject; Buffer: TBitmap32; StageNum: Cardinal); procedure LayerOpacityChanged(Sender: TObject); procedure MimArrangeClick(Sender: TObject); procedure MnuButtonMockupClick(Sender: TObject); procedure MnuDeleteClick(Sender: TObject); procedure MnuFileClick(Sender: TObject); procedure MnuFileNewClick(Sender: TObject); procedure MnuFileOpenClick(Sender: TObject); procedure MnuFlattenClick(Sender: TObject); procedure MnuFlipHorzClick(Sender: TObject); procedure MnuFlipVertClick(Sender: TObject); procedure MnuLayersClick(Sender: TObject); procedure MnuMagnifierClick(Sender: TObject); procedure MnuNewBitmapLayerClick(Sender: TObject); procedure MnuNewBitmapRGBAClick(Sender: TObject); procedure MnuPrintClick(Sender: TObject); procedure MnuReorderClick(Sender: TObject); procedure MnuRotate180Click(Sender: TObject); procedure MnuRotate270Click(Sender: TObject); procedure MnuRotate90Click(Sender: TObject); procedure MnuScaledClick(Sender: TObject); procedure MnuSimpleDrawingClick(Sender: TObject); procedure PropertyChange(Sender: TObject); procedure ScaleComboChange(Sender: TObject); private FSelection: TPositionedLayer; procedure SetSelection(Value: TPositionedLayer); protected RBLayer: TRubberbandLayer; function CreatePositionedLayer: TPositionedLayer; procedure LayerDblClick(Sender: TObject); procedure LayerMouseDown(Sender: TObject; Buttons: TMouseButton; Shift: TShiftState; X, Y: Integer); procedure RBResizing(Sender: TObject; const OldLocation: TFloatRect; var NewLocation: TFloatRect; DragState: TRBDragState; Shift: TShiftState); procedure PaintMagnifierHandler(Sender: TObject; Buffer: TBitmap32); procedure PaintSimpleDrawingHandler(Sender: TObject; Buffer: TBitmap32); procedure PaintButtonMockupHandler(Sender: TObject; Buffer: TBitmap32); public procedure CreateNewImage(AWidth, AHeight: Integer; FillColor: TColor32); procedure OpenImage(const FileName: string); property Selection: TPositionedLayer read FSelection write SetSelection; end; var MainForm: TMainForm; implementation {$IFDEF FPC} {$R *.lfm} {$ELSE} {$R *.dfm} {$ENDIF} uses {$IFDEF Darwin} MacOSAll, {$ENDIF} {$IFNDEF FPC} JPEG, {$ELSE} LazJPG, {$ENDIF} NewImageUnit, RGBALoaderUnit, Math, Printers, GR32_LowLevel, GR32_Paths, GR32_VectorUtils, GR32_Backends, GR32_Text_VCL, GR32_ColorGradients, GR32_Polygons, GR32_Geometry; const RESAMPLER: array [Boolean] of TCustomResamplerClass = (TNearestResampler, TDraftResampler); { TMainForm } procedure TMainForm.FormCreate(Sender: TObject); begin // by default, PST_CLEAR_BACKGND is executed at this stage, // which, in turn, calls ExecClearBackgnd method of ImgView. // Here I substitute PST_CLEAR_BACKGND with PST_CUSTOM, so force ImgView // to call the OnPaintStage event instead of performing default action. with ImgView.PaintStages[0]^ do begin if Stage = PST_CLEAR_BACKGND then Stage := PST_CUSTOM; end; ImgView.RepaintMode := rmOptimizer; ImgView.Options := ImgView.Options + [pboWantArrowKeys]; end; procedure TMainForm.FormDestroy(Sender: TObject); begin Selection := nil; RBLayer := nil; end; procedure TMainForm.CreateNewImage(AWidth, AHeight: Integer; FillColor: TColor32); begin with ImgView do begin Selection := nil; RBLayer := nil; Layers.Clear; Scale := 1; Bitmap.SetSize(AWidth, AHeight); Bitmap.Clear(FillColor); pnlImage.Visible := not Bitmap.Empty; end; end; function TMainForm.CreatePositionedLayer: TPositionedLayer; var P: TPoint; begin // get coordinates of the center of viewport with ImgView.GetViewportRect do P := ImgView.ControlToBitmap(GR32.Point((Right + Left) div 2, (Top + Bottom) div 2)); Result := TPositionedLayer.Create(ImgView.Layers); Result.Location := FloatRect(P.X - 32, P.Y - 32, P.X + 32, P.Y + 32); Result.Scaled := True; Result.MouseEvents := True; Result.OnMouseDown := LayerMouseDown; Result.OnDblClick := LayerDblClick; end; procedure TMainForm.CbxCroppedClick(Sender: TObject); begin if Selection is TBitmapLayer then TBitmapLayer(Selection).Cropped := CbxCropped.Checked; end; procedure TMainForm.CbxImageInterpolateClick(Sender: TObject); begin RESAMPLER[CbxImageInterpolate.Checked].Create(ImgView.Bitmap); end; procedure TMainForm.CbxLayerInterpolateClick(Sender: TObject); begin if Selection is TBitmapLayer then begin RESAMPLER[CbxLayerInterpolate.Checked].Create(TBitmapLayer(Selection).Bitmap); end; end; procedure TMainForm.LayerDblClick(Sender: TObject); begin if Sender is TRubberbandLayer then TRubberbandLayer(Sender).Quantize; end; procedure TMainForm.LayerMouseDown(Sender: TObject; Buttons: TMouseButton; Shift: TShiftState; X, Y: Integer); begin if Sender <> nil then Selection := TPositionedLayer(Sender); end; procedure TMainForm.LayerOpacityChanged(Sender: TObject); begin if Selection is TBitmapLayer then TBitmapLayer(Selection).Bitmap.MasterAlpha := GbrLayerOpacity.Position; end; procedure TMainForm.BtnLayerRescaleClick(Sender: TObject); var T: TBitmap32; begin // resize the layer's bitmap to the size of the layer if Selection is TBitmapLayer then with TBitmapLayer(Selection) do begin T := TBitmap32.Create; T.Assign(Bitmap); with MakeRect(Location) do Bitmap.SetSize(Right - Left, Bottom - Top); T.Resampler := TNearestResampler.Create(T); T.DrawMode := dmOpaque; T.DrawTo(Bitmap, Classes.Rect(0, 0, Bitmap.Width, Bitmap.Height)); T.Free; BtnLayerResetScaleClick(Self); end; ImgView.GetBitmapRect end; procedure TMainForm.BtnLayerResetScaleClick(Sender: TObject); var L: TFloatRect; begin // resize the layer to the size of its bitmap if Selection is TBitmapLayer then with RBLayer, TBitmapLayer(Selection).Bitmap do begin L := Location; L.Right := L.Left + Width; L.Bottom := L.Top + Height; Location := L; Changed; end; end; procedure TMainForm.PropertyChange(Sender: TObject); begin ImgView.Invalidate; end; procedure TMainForm.MimArrangeClick(Sender: TObject); var B: Boolean; begin B := Selection <> nil; MnuBringFront.Enabled := B and (Selection.Index < ImgView.Layers.Count - 2); MnuSendBack.Enabled := B and (Selection.Index > 0); MnuLevelUp.Enabled := B and (Selection.Index < ImgView.Layers.Count - 2); MnuLevelDown.Enabled := B and (Selection.Index > 0); MnuScaled.Enabled := B; MnuScaled.Checked := B and Selection.Scaled; MnuDelete.Enabled := B; B := B and (Selection is TBitmapLayer); MnuFlipHorz.Enabled := B; MnuFlipVert.Enabled := B; MnuRotate90.Enabled := B; MnuRotate180.Enabled := B; MnuRotate270.Enabled := B; end; procedure TMainForm.MnuButtonMockupClick(Sender: TObject); var L: TPositionedLayer; begin L := CreatePositionedLayer; L.OnPaint := PaintButtonMockupHandler; L.Tag := 2; Selection := L; end; procedure TMainForm.MnuDeleteClick(Sender: TObject); var ALayer: TPositionedLayer; begin if Selection <> nil then begin ALayer := Selection; Selection := nil; ALayer.Free; end; end; procedure TMainForm.MnuFileNewClick(Sender: TObject); begin with FrmNewImage do begin ShowModal; if ModalResult = mrOK then CreateNewImage(BtnUpDownWidth.Position, BtnUpDownHeight.Position, Color32(PnlColor.Color)); end; end; procedure TMainForm.MnuFileOpenClick(Sender: TObject); begin with OpenPictureDialog do if Execute then OpenImage(FileName); end; procedure TMainForm.MnuLayersClick(Sender: TObject); var B: Boolean; begin B := not ImgView.Bitmap.Empty; MnuNewBitmapLayer.Enabled := B; MnuNewBitmapRGBA.Enabled := B; MnuNewCustomLayer.Enabled := B; MnuFlatten.Enabled := B and (ImgView.Layers.Count > 0); end; procedure TMainForm.MnuMagnifierClick(Sender: TObject); var L: TPositionedLayer; begin L := CreatePositionedLayer; L.OnPaint := PaintMagnifierHandler; L.Tag := 3; Selection := L; end; procedure TMainForm.MnuNewBitmapLayerClick(Sender: TObject); var B: TBitmapLayer; P: TPoint; W, H: Single; begin with OpenPictureDialog do if Execute then begin B := TBitmapLayer.Create(ImgView.Layers); with B do try Bitmap.LoadFromFile(FileName); Bitmap.DrawMode := dmBlend; with ImgView.GetViewportRect do P := ImgView.ControlToBitmap(GR32.Point((Right + Left) div 2, (Top + Bottom) div 2)); W := Bitmap.Width * 0.5; H := Bitmap.Height * 0.5; with ImgView.Bitmap do Location := GR32.FloatRect(P.X - W, P.Y - H, P.X + W, P.Y + H); Scaled := True; OnMouseDown := LayerMouseDown; except Free; raise; end; Selection := B; end; end; procedure TMainForm.MnuNewBitmapRGBAClick(Sender: TObject); var B: TBitmapLayer; P: TPoint; Tmp: TBitmap32; W, H: Single; begin with RGBALoaderForm do begin ImgRGB.Bitmap.Delete; ImgRGB.Scale := 1; ImgAlpha.Bitmap.Delete; ImgAlpha.Scale := 1; ShowModal; if (ModalResult = mrOK) and not ImgRGB.Bitmap.Empty then begin B := TBitmapLayer.Create(ImgView.Layers); B.Bitmap := ImgRGB.Bitmap; B.Bitmap.DrawMode := dmBlend; if not ImgAlpha.Bitmap.Empty then begin Tmp := TBitmap32.Create; try Tmp.SetSize(B.Bitmap.Width, B.Bitmap.Height); ImgAlpha.Bitmap.DrawTo(Tmp, Classes.Rect(0, 0, Tmp.Width, Tmp.Height)); // combine Alpha into already loaded RGB colors IntensityToAlpha(B.Bitmap, Tmp); finally Tmp.Free; end; end; with ImgView.GetViewportRect do P := ImgView.ControlToBitmap(GR32.Point((Right + Left) div 2, (Top + Bottom) div 2)); with B do begin W := Bitmap.Width * 0.5; H := Bitmap.Height * 0.5; with ImgView.Bitmap do Location := GR32.FloatRect(P.X - W, P.Y - H, P.X + W, P.Y + H); Scaled := True; OnMouseDown := LayerMouseDown; end; Selection := B; end; end; end; procedure TMainForm.MnuReorderClick(Sender: TObject); begin // note that the top-most layer is occupied with the rubber-banding layer if Selection <> nil then case TMenuItem(Sender).Tag of 1: // Bring to front, do not use BringToFront here, see note above Selection.Index := ImgView.Layers.Count - 2; 2: Selection.SendToBack; 3: Selection.Index := Selection.Index + 1; // up one level 4: Selection.Index := Selection.Index - 1; // down one level end; end; procedure TMainForm.MnuSimpleDrawingClick(Sender: TObject); var L: TPositionedLayer; begin L := CreatePositionedLayer; L.OnPaint := PaintSimpleDrawingHandler; L.Tag := 1; Selection := L; end; procedure TMainForm.OpenImage(const FileName: string); begin with ImgView do try Selection := nil; RBLayer := nil; Layers.Clear; Scale := 1; Bitmap.LoadFromFile(FileName); finally pnlImage.Visible := not Bitmap.Empty; end; end; procedure TMainForm.PaintButtonMockupHandler(Sender: TObject; Buffer: TBitmap32); var RoundPoly: TArrayOfFloatPoint; TextPoly: TArrayOfArrayOfFloatPoint; Bounds, Dst: TFloatRect; Path: TFlattenedPath; Intf: ITextToPathSupport; ColorGradient: TLinearGradientPolygonFiller; const CScale = 1 / 200; begin if Sender is TPositionedLayer then with TPositionedLayer(Sender) do begin Bounds := GetAdjustedLocation; InflateRect(Bounds, -1, -1); RoundPoly := RoundRect(Bounds, GbrBorderRadius.Position); ColorGradient := TLinearGradientPolygonFiller.Create; try ColorGradient.SetPoints(FloatPoint(0, Bounds.Top), FloatPoint(0, Bounds.Bottom)); ColorGradient.Gradient.StartColor := $FFE2E2E2; ColorGradient.Gradient.AddColorStop(0.499, $FFD3D3D3); ColorGradient.Gradient.AddColorStop(0.501, $FFDBDBDB); ColorGradient.Gradient.EndColor := $FFFDFDFD; PolygonFS(Buffer, RoundPoly, ColorGradient, pfAlternate); finally ColorGradient.Free; end; PolyPolygonFS(Buffer, BuildPolyPolyLine(PolyPolygon(RoundPoly), True, 0.1 * GbrBorderWidth.Position), clGray32, pfAlternate); Path := TFlattenedPath.Create; try // Buffer.Font.Assign(FFont); Buffer.Font.Size := 12; if Supports(Buffer.Backend, ITextToPathSupport, Intf) then begin Intf.TextToPath(Path, 0, 0, 'Button'); TextPoly := Path.Path; if Length(TextPoly) > 0 then begin Dst := PolypolygonBounds(TextPoly); TextPoly := TranslatePolyPolygon(TextPoly, 0.5 * (Bounds.Left + Bounds.Right - (Dst.Right - Dst.Left)), 0.5 * (Bounds.Bottom + Bounds.Top - Dst.Bottom)); PolyPolygonFS_LCD2(Buffer, TextPoly, clBlack32, pfAlternate); end; end; finally Path.Free; end; end; end; procedure TMainForm.PaintMagnifierHandler(Sender: TObject; Buffer: TBitmap32); var Magnification, Rotation: Single; SrcRect, DstRect: TFloatRect; R: TRect; T: TAffineTransformation; B: TBitmap32; W2, H2: Single; I: Integer; begin if Sender is TPositionedLayer then with TPositionedLayer(Sender) do begin DstRect := GetAdjustedLocation; R := MakeRect(DstRect); if not Buffer.MeasuringMode then begin Magnification := Power(10, (GbrMagnMagnification.Position * 0.02)); Rotation := -GbrMagnRotation.Position; B := TBitmap32.Create; try with R do begin B.SetSize(Right - Left, Bottom - Top); W2 := (Right - Left) * 0.5; H2 := (Bottom - Top) * 0.5; end; SrcRect := DstRect; with SrcRect do begin Left := Left - H2; Right := Right + H2; Top := Top - W2; Bottom := Bottom + W2; end; T := TAffineTransformation.Create; try T.SrcRect := SrcRect; T.Translate(-R.Left, -R.Top); T.Translate(-W2, -H2); T.Scale(Magnification, Magnification); T.Rotate(0, 0, Rotation); T.Translate(W2, H2); if CbxMagnInterpolate.Checked then begin TLinearResampler.Create(Buffer); Transform(B, Buffer, T); end else begin TNearestResampler.Create(Buffer); Transform(B, Buffer, T); end; B.ResetAlpha; B.DrawMode := dmBlend; B.MasterAlpha := GbrMagnOpacity.Position; B.DrawTo(Buffer, R); // draw frame for I := 0 to 4 do begin with R do Buffer.RaiseRectTS(Left, Top, Right, Bottom, 35 - I * 8); InflateRect(R, -1, -1); end; finally T.Free; end; finally B.Free; end; end; Buffer.Changed; end; end; procedure TMainForm.PaintSimpleDrawingHandler(Sender: TObject; Buffer: TBitmap32); var Cx, Cy: Single; W2, H2: Single; I: Integer; const CScale = 1 / 200; begin if Sender is TPositionedLayer then with TPositionedLayer(Sender).GetAdjustedLocation do begin W2 := (Right - Left) * 0.5; H2 := (Bottom - Top) * 0.5; Cx := Left + W2; Cy := Top + H2; W2 := W2 * CScale; H2 := H2 * CScale; Buffer.PenColor := clRed32; Buffer.MoveToF(Cx, Cy); for I := 0 to 240 do Buffer.LineToFS( Cx + W2 * I * Cos(I * 0.125), Cy + H2 * I * Sin(I * 0.125)); end; end; procedure TMainForm.ScaleComboChange(Sender: TObject); var S: string; I: Integer; begin S := ScaleCombo.Text; S := StringReplace(S, '%', '', [rfReplaceAll]); S := StringReplace(S, ' ', '', [rfReplaceAll]); if S = '' then Exit; I := StrToIntDef(S, -1); if (I < 1) or (I > 2000) then I := Round(ImgView.Scale * 100) else ImgView.Scale := I * 0.01; ScaleCombo.Text := IntToStr(I) + '%'; ScaleCombo.SelStart := Length(ScaleCombo.Text) - 1; end; procedure TMainForm.SetSelection(Value: TPositionedLayer); begin if Value <> FSelection then begin if RBLayer <> nil then begin RBLayer.ChildLayer := nil; RBLayer.LayerOptions := LOB_NO_UPDATE; pnlBitmapLayer.Visible := False; pnlButtonMockup.Visible := False; pnlMagnification.Visible := False; ImgView.Invalidate; end; FSelection := Value; if Value <> nil then begin if RBLayer = nil then begin RBLayer := TRubberBandLayer.Create(ImgView.Layers); RBLayer.MinHeight := 1; RBLayer.MinWidth := 1; end else RBLayer.BringToFront; RBLayer.ChildLayer := Value; RBLayer.LayerOptions := LOB_VISIBLE or LOB_MOUSE_EVENTS or LOB_NO_UPDATE; RBLayer.OnResizing := RBResizing; RBLayer.OnDblClick := LayerDblClick; if Value is TBitmapLayer then with TBitmapLayer(Value) do begin pnlBitmapLayer.Visible := True; GbrLayerOpacity.Position := Bitmap.MasterAlpha; CbxLayerInterpolate.Checked := Bitmap.Resampler.ClassType = TDraftResampler; end else if Value.Tag = 2 then begin // tag = 2 for button mockup pnlButtonMockup.Visible := True; end else if Value.Tag = 3 then begin // tag = 3 for magnifiers pnlMagnification.Visible := True; end; end; end; end; procedure TMainForm.MnuScaledClick(Sender: TObject); begin if Selection <> nil then Selection.Scaled := not Selection.Scaled; RBLayer.Scaled := Selection.Scaled; end; procedure TMainForm.ImgViewKeyDown(Sender: TObject; var Key: Word; Shift: TShiftState); var Location: TFloatRect; begin if Assigned(FSelection) then case Key of VK_LEFT: begin Location := OffsetRect(FSelection.Location, -1, 0); FSelection.Location := Location; RBLayer.Location := Location; end; VK_RIGHT: begin Location := OffsetRect(FSelection.Location, 1, 0); FSelection.Location := Location; RBLayer.Location := Location; end; VK_UP: begin Location := OffsetRect(FSelection.Location, 0, -1); FSelection.Location := Location; RBLayer.Location := Location; end; VK_DOWN: begin Location := OffsetRect(FSelection.Location, 0, 1); FSelection.Location := Location; RBLayer.Location := Location; end; VK_DELETE: begin FreeAndNil(FSelection); RBLayer.ChildLayer := nil; RBLayer.LayerOptions := LOB_NO_UPDATE; end; end; end; procedure TMainForm.ImgViewMouseDown(Sender: TObject; Button: TMouseButton; Shift: TShiftState; X, Y: Integer; Layer: TCustomLayer); begin if Layer = nil then begin Selection := nil; end; end; procedure TMainForm.ImgViewPaintStage(Sender: TObject; Buffer: TBitmap32; StageNum: Cardinal); const //0..1 Colors: array [Boolean] of TColor32 = ($FFFFFFFF, $FFB0B0B0); var R: TRect; I, J: Integer; OddY: Integer; TilesHorz, TilesVert: Integer; TileX, TileY: Integer; TileHeight, TileWidth: Integer; begin TileHeight := 13; TileWidth := 13; TilesHorz := Buffer.Width div TileWidth; TilesVert := Buffer.Height div TileHeight; TileY := 0; for J := 0 to TilesVert do begin TileX := 0; OddY := J and $1; for I := 0 to TilesHorz do begin R.Left := TileX; R.Top := TileY; R.Right := TileX + TileWidth; R.Bottom := TileY + TileHeight; Buffer.FillRectS(R, Colors[I and $1 = OddY]); Inc(TileX, TileWidth); end; Inc(TileY, TileHeight); end; end; procedure TMainForm.RBResizing(Sender: TObject; const OldLocation: TFloatRect; var NewLocation: TFloatRect; DragState: TRBDragState; Shift: TShiftState); var w, h, cx, cy: Single; nw, nh: Single; begin if DragState = dsMove then Exit; // we are interested only in scale operations if Shift = [] then Exit; // special processing is not required if ssCtrl in Shift then begin { make changes symmetrical } with OldLocation do begin cx := (Left + Right) / 2; cy := (Top + Bottom) / 2; w := Right - Left; h := Bottom - Top; end; with NewLocation do begin nw := w / 2; nh := h / 2; case DragState of dsSizeL: nw := cx - Left; dsSizeT: nh := cy - Top; dsSizeR: nw := Right - cx; dsSizeB: nh := Bottom - cy; dsSizeTL: begin nw := cx - Left; nh := cy - Top; end; dsSizeTR: begin nw := Right - cx; nh := cy - Top; end; dsSizeBL: begin nw := cx - Left; nh := Bottom - cy; end; dsSizeBR: begin nw := Right - cx; nh := Bottom - cy; end; end; if nw < 2 then nw := 2; if nh < 2 then nh := 2; Left := cx - nw; Right := cx + nw; Top := cy - nh; Bottom := cy + nh; end; end; end; procedure TMainForm.MnuFlattenClick(Sender: TObject); var B: TBitmap32; W, H: Integer; begin { deselect everything } Selection := nil; W := ImgView.Bitmap.Width; H := ImgView.Bitmap.Height; { Create a new bitmap to store a flattened image } B := TBitmap32.Create; try B.SetSize(W, H); ImgView.PaintTo(B, Classes.Rect(0, 0, W, H)); { destroy all the layers of the original image... } ImgView.Layers.Clear; RBLayer := nil; // note that RBLayer reference is destroyed here as well. // The rubber band will be recreated during the next // SetSelection call. Alternatively, you can delete // all the layers except the rubber band. { ...and overwrite it with the flattened one } ImgView.Bitmap := B; finally B.Free; end; end; procedure TMainForm.MnuPrintClick(Sender: TObject); var B: TBitmap32; W, H: Integer; R: TRect; function GetCenteredRectToFit(const src, dst: TRect): TRect; var srcWidth, srcHeight, dstWidth, dstHeight, ScaledSide: Integer; begin with src do begin srcWidth := Right - Left; srcHeight := Bottom - Top; end; with dst do begin dstWidth := Right - Left; dstHeight := Bottom - Top; end; if (srcWidth = 0) or (srcHeight = 0) then exit; if srcWidth / srcHeight > dstWidth / dstHeight then begin ScaledSide := Round(dstWidth * srcHeight / srcWidth); with Result do begin Left := dst.Left; Top := dst.Top + (dstHeight - ScaledSide) div 2; Right := dst.Right; Bottom := Top + ScaledSide; end; end else begin ScaledSide := Round(dstHeight * srcWidth / srcHeight); with Result do begin Left := dst.Left + (dstWidth - ScaledSide) div 2; Top := dst.Top; Right := Left + ScaledSide; Bottom := dst.Bottom; end; end; end; begin { deselect everything } Selection := nil; W := ImgView.Bitmap.Width; H := ImgView.Bitmap.Height; { Create a new bitmap to store a flattened image } B := TBitmap32.Create; Screen.Cursor := crHourGlass; try B.SetSize(W, H); ImgView.PaintTo(B, Classes.Rect(0, 0, W, H)); Printer.BeginDoc; Printer.Title := 'Image View Layers Example'; B.Resampler := TLinearResampler.Create(B); R := GetCenteredRectToFit(Classes.Rect(0, 0, W, H), Classes.Rect(0, 0, Printer.PageWidth, Printer.PageHeight)); B.TileTo(Printer.Canvas.Handle, R, Classes.Rect(0, 0, W, H)); Printer.EndDoc; finally B.Free; Screen.Cursor := crDefault; end; end; procedure TMainForm.ImgViewMouseWheelUp(Sender: TObject; Shift: TShiftState; MousePos: TPoint; var Handled: Boolean); var s: Single; begin s := ImgView.Scale / 1.1; if s < 0.2 then s := 0.2; ImgView.Scale := s; ScaleCombo.Text := IntToStr(Round(s * 100)) + '%'; end; procedure TMainForm.ImgViewMouseWheelDown(Sender: TObject; Shift: TShiftState; MousePos: TPoint; var Handled: Boolean); var s: Single; begin s := ImgView.Scale * 1.1; if s > 20 then s := 20; ImgView.Scale := s; ScaleCombo.Text := IntToStr(Round(s * 100)) + '%'; end; procedure TMainForm.MnuFlipHorzClick(Sender: TObject); begin if Selection is TBitmapLayer then TBitmapLayer(Selection).Bitmap.FlipHorz; end; procedure TMainForm.MnuFlipVertClick(Sender: TObject); begin if Selection is TBitmapLayer then TBitmapLayer(Selection).Bitmap.FlipVert; end; procedure TMainForm.MnuRotate90Click(Sender: TObject); var R: TFloatRect; Cx, Cy, W2, H2: Single; begin if Selection is TBitmapLayer then begin R := Selection.Location; TBitmapLayer(Selection).Bitmap.Rotate90; Cx := (R.Left + R.Right) * 0.5; Cy := (R.Top + R.Bottom) * 0.5; W2 := (R.Right - R.Left) * 0.5; H2 := (R.Bottom - R.Top) * 0.5; RBLayer.Location := FloatRect(Cx - H2, Cy - W2, Cx + H2, Cy + W2); end; end; procedure TMainForm.MnuRotate180Click(Sender: TObject); begin if Selection is TBitmapLayer then TBitmapLayer(Selection).Bitmap.Rotate180; end; procedure TMainForm.MnuRotate270Click(Sender: TObject); var R: TFloatRect; Cx, Cy, W2, H2: Single; begin if Selection is TBitmapLayer then begin R := Selection.Location; TBitmapLayer(Selection).Bitmap.Rotate270; Cx := (R.Left + R.Right) * 0.5; Cy := (R.Top + R.Bottom) * 0.5; W2 := (R.Right - R.Left) * 0.5; H2 := (R.Bottom - R.Top) * 0.5; RBLayer.Location := FloatRect(Cx - H2, Cy - W2, Cx + H2, Cy + W2); end; end; procedure TMainForm.MnuFileClick(Sender: TObject); begin MnuPrint.Enabled := not ImgView.Bitmap.Empty; end; procedure TMainForm.CbxOptRedrawClick(Sender: TObject); const RepaintMode: array[Boolean] of TRepaintMode = (rmFull, rmOptimizer); begin ImgView.RepaintMode := RepaintMode[CbxOptRedraw.Checked]; end; end.