Direct2D Zoom and Pan

Question

Been trying to put code together from samples to make a zoom/pan image with Direct2D but not really working well.

Basically the picture will drag across the window, but once i let go of the mouse it falls back to its original place, i want it to stay in the position it was dropped.

All the images will go outside the client size as well, so i want to pan to those areas also.

The zoom is still work in progress, but not having much luck.

This is where i am at so far:

procedure TForm1.FormMouseWheel(Sender: TObject; Shift: TShiftState;
  WheelDelta: Integer; MousePos: TPoint; var Handled: Boolean);
const
  ZoomFactor: array[Boolean] of Single = (0.9, 1.1);
begin
  if WheelDelta = 120 then
  begin
    if PtInRect(ClientRect, MousePos) then
    begin
      R.Left := Left + MousePos.X - Round(ZoomFactor[WheelDelta > 0] * MousePos.X);
      R.Top := Top + MousePos.Y - Round(ZoomFactor[WheelDelta > 0] * MousePos.Y);
      FRenderTarget.SetTransform(TD2DMatrix3x2F.Translation(R.Left,R.Top));
      //Invalidate;
    end;
  end;
  if WheelDelta = -120 then
  begin
   exit;
  end;
  Handled := True;
end;

procedure TForm1.FormMouseDown(Sender: TObject; Button: TMouseButton;
  Shift: TShiftState; X, Y: Integer);
begin
  FDraging := True;
  OldPosX:=X;
  OldPosY:=Y;
end;

procedure TForm1.FormMouseMove(Sender: TObject; Shift: TShiftState; X,
  Y: Integer);
begin
  S1:='Position X: '+IntToStr(X)+' Position Y: '+IntToStr(Y);
  if FDraging and (OldPosX <> X) and (OldPosY <> Y) then
  begin
    NewPosX:=Left + X - OldPosX;
    NewPosY:=Top + Y - OldPosY;
  end;
end;

procedure TForm1.FormMouseUp(Sender: TObject; Button: TMouseButton;
  Shift: TShiftState; X, Y: Integer);
begin
  FDraging := False;
  CurrentPosX:=X - NewPosX;
  CurrentPosY:=Y - NewPosX;
end;

procedure TForm1.FormPaint(Sender: TObject);
begin
  b0:=GetD2D1Bitmap(FRenderTarget, Caly_00);
  FRenderTarget.BeginDraw;
  try
    if FDraging then
    begin
      FRenderTarget.SetTransform(TD2DMatrix3x2F.Translation(NewPosX, NewPosY));
      FRenderTarget.DrawBitmap(b0, nil, 1, D2D1_BITMAP_INTERPOLATION_MODE_LINEAR, nil);
    end else begin
      FRenderTarget.SetTransform(TD2DMatrix3x2F.Translation(CurrentPosX, CurrentPosY));
      FRenderTarget.DrawBitmap(b0, nil, 1, D2D1_BITMAP_INTERPOLATION_MODE_LINEAR, nil);
    end;
  end;
end;

Answer 1

Try this, its create a Direct2D canvas and draw a bitmap, also you can pan and zoom the view.

unit D2DForm;

interface

uses
  Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms,
  Direct2D, D2D1;

type
  TD2DForm = class(TForm)
    procedure FormCreate(Sender: TObject);
    procedure FormDestroy(Sender: TObject);
    procedure FormPaint(Sender: TObject);
    procedure FormMouseDown(Sender: TObject; Button: TMouseButton;
      Shift: TShiftState; X, Y: Integer);
    procedure FormMouseUp(Sender: TObject; Button: TMouseButton;
      Shift: TShiftState; X, Y: Integer);
    procedure FormMouseMove(Sender: TObject; Shift: TShiftState; X, Y: Integer);
    procedure FormMouseWheel(Sender: TObject; Shift: TShiftState;
      WheelDelta: Integer; MousePos: TPoint; var Handled: Boolean);
  private
    FZoom: D2D_SIZE_F;          // Zoom level
    FView: TD2DPoint2f;         // Transaltion
    FBitmap: ID2D1Bitmap;       // A bitmap
    FCanvas: TDirect2DCanvas;   // The Direct2D canvas
    FDragging: Boolean;         // Dragging state
    FOldMousePos: TPoint;       // Previous mouse position
  protected
    procedure CreateWnd; override;
    procedure WMPaint(var Message: TWMPaint); message WM_PAINT;
    procedure WMSize(var Message: TWMSize); message WM_SIZE;
  end;

var
  D2DForm: TD2DForm;

implementation

{$R *.dfm}

procedure TD2DForm.FormCreate(Sender: TObject);
begin
  FZoom := D2D1SizeF(1, 1);  // Zoom level, start from 1x
  FView := D2D1PointF(0, 0); // Translation
end;

procedure TD2DForm.FormDestroy(Sender: TObject);
begin
  FreeAndNil(FCanvas);
end;

// CreateWnd is called when the form is created
procedure TD2DForm.CreateWnd;
var
  LBitmap: TBitmap;
begin
  inherited;
  // TDirect2DCanvas.Create need a handle, so called from CreateWnd
  FCanvas := TDirect2DCanvas.Create(Handle);

  // Load a bitmap
  LBitmap := TBitmap.Create;
  LBitmap.LoadFromFile('c:\testb.bmp');   // Load your bitmap
  try
    FBitmap := FCanvas.CreateBitmap(LBitmap);
  finally
    FreeAndNil(LBitmap);
  end;
end;

// WMPaint is called when need to repaint the window
// this will call our FormPaint()
procedure TD2DForm.WMPaint(var Message: TWMPaint);
var
  LPaintStruct: TPaintStruct;
begin
  // This will render the canvas

  BeginPaint(Handle, LPaintStruct);
  try
    FCanvas.BeginDraw;
    try
      Paint;
    finally
      FCanvas.EndDraw;
    end;
  finally
    EndPaint(Handle, LPaintStruct);
  end;
end;

// WMSize is called when resizing the window
procedure TD2DForm.WMSize(var Message: TWMSize);
begin
  // here we resize our canvas to the same size of the window
  if Assigned(FCanvas) then
    ID2D1HwndRenderTarget(FCanvas.RenderTarget).Resize(
      D2D1SizeU(ClientWidth,       ClientHeight));

  inherited;
end;

procedure TD2DForm.FormMouseDown(Sender: TObject; Button: TMouseButton;
  Shift: TShiftState; X, Y: Integer);
begin
  FDragging := True;
  FOldMousePos := Point(X, Y);
end;

procedure TD2DForm.FormMouseMove(Sender: TObject; Shift: TShiftState; X,
  Y: Integer);
begin
  if FDragging then
  begin
    // Translate the view
    // its depend from zoom level
    FView.X := FView.X + ((X - FOldMousePos.X) / FZoom.Width );
    FView.Y := FView.Y + ((Y - FOldMousePos.Y) / FZoom.Height);
    FOldMousePos := Point(X, Y);
    RePaint;
  end;
end;

procedure TD2DForm.FormMouseUp(Sender: TObject; Button: TMouseButton;
  Shift: TShiftState; X, Y: Integer);
begin
  FDragging := False;
end;

procedure TD2DForm.FormMouseWheel(Sender: TObject; Shift: TShiftState;
  WheelDelta: Integer; MousePos: TPoint; var Handled: Boolean);
begin
  // Update zoom level
  if WheelDelta > 0 then
  begin
    // Zoom in
    FZoom.Width  := FZoom.Width  * 1.1;
    FZoom.Height := FZoom.Height * 1.1;
  end
  else
  begin
    // Zoom Out
    FZoom.Width  := FZoom.Width  * 0.9;
    FZoom.Height := FZoom.Height * 0.9;
  end;
  Handled := True;
  RePaint;
end;

// Main painting routine
procedure TD2DForm.FormPaint(Sender: TObject);
var
  LView: TD2DMatrix3x2F;
begin
  // Paint canvas
  with FCanvas do
  begin
    // Clear
    RenderTarget.Clear(D2D1ColorF(clBlack));

    // Create view matrix
    // we create a translation and zoom(scale) matrix
    // and combine them
    LView := TD2DMatrix3x2F.SetProduct(
      TD2DMatrix3x2F.Translation(FView),
      TD2DMatrix3x2F.Scale(FZoom, D2D1PointF(ClientWidth / 2, ClientHeight / 2)));

    // Set the view matrix
    RenderTarget.SetTransform(LView);

    // Draw the bitmap
    RenderTarget.DrawBitmap(FBitmap);
  end;
end;

end.