Direct2D 缩放和平移

Question

一直在尝试将示例中的代码放在一起以使用 Direct2D 制作缩放/平移图像，但效果不佳。

基本上图片会拖过窗口，但是一旦我放开鼠标它就会回到原来的位置，我希望它保持在它被放下的位置。

所有图像也会超出客户端大小，所以我也想平移到这些区域。

缩放仍在进行中，但运气不佳。

这是我目前所处的位置：

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

试试这个，它创建一个 Direct2D 画布并绘制位图，您还可以平移和缩放视图。

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.

Answer 2

这段代码可以处理多个位图，测试一下:)

unit Unit1;

interface

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

type
  TIntArray = array of Integer;
  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
    FCanvas: TDirect2DCanvas;         // The Direct2D canvas
    FBitmaps: array of ID2D1Bitmap;   // Bitmaps
    FDragging: Boolean;               // Dragging state
    FOldMousePos: TPoint;             // Previous mouse position
    FBitmapTable: array of TIntArray; // Table, each item contain index to a bitmap
  protected
    procedure CreateWnd; override;
    procedure WMPaint(var Message: TWMPaint); message WM_PAINT;
    procedure WMSize(var Message: TWMSize); message WM_SIZE;
    procedure WMEraseBkGnd(var Message: TWMEraseBkGnd); message WM_ERASEBKGND;
  end;

var
  D2DForm: TD2DForm;

implementation

{$R *.dfm}

function GetD2D1Bitmap(RenderTarget: ID2D1RenderTarget; imgPath: string): ID2D1Bitmap;
var
  iWicFactory: IWICImagingFactory;
  iWICDecoder: IWICBitmapDecoder;
  iWICFrameDecode: IWICBitmapFrameDecode;
  iFormatConverter: IWICFormatConverter;
begin
  CoCreateInstance(CLSID_WICImagingFactory, nil, CLSCTX_INPROC_SERVER, IID_IWICImagingFactory, iWicFactory);
  iWicFactory.CreateDecoderFromFilename(PWideChar(imgPath), GUID_NULL, GENERIC_READ, WICDecodeMetadataCacheOnLoad, iWICDecoder);
  iWicDecoder.GetFrame(0, iWICFrameDecode);
  iWicFactory.CreateFormatConverter(iFormatConverter);
  iFormatConverter.Initialize(iWICFrameDecode, GUID_WICPixelFormat32bppPBGRA, WICBitmapDitherTypeNone, nil, 0, WICBitmapPaletteTypeMedianCut);
  RenderTarget.CreateBitmapFromWicBitmap(iFormatConverter, nil, Result);
end;

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
  LIndexX: Integer;
  LIndexY: Integer;
begin
  inherited;
  // TDirect2DCanvas.Create need a handle, so called from CreateWnd
  FCanvas := TDirect2DCanvas.Create(Handle);

  // Load bitmaps
  SetLength(FBitmaps, 3); // you can load more, if you want
  FBitmaps[0] := GetD2D1Bitmap(FCanvas.RenderTarget, 'c:\testb.bmp');
  FBitmaps[1] := GetD2D1Bitmap(FCanvas.RenderTarget, 'c:\bitmap.bmp');
  FBitmaps[2] := GetD2D1Bitmap(FCanvas.RenderTarget, 'c:\test.bmp');

  // Create a 4 x 3 sized table, you can increase the size, if you want
  SetLength(FBitmapTable, 4);
  for LIndexY := 0 to Length(FBitmapTable) - 1 do
  begin
    SetLength(FBitmapTable[LIndexY], 3);
    for LIndexX := 0 to Length(FBitmapTable[LIndexY]) - 1 do
      FBitmapTable[LIndexY, LIndexX] := Random( Length(FBitmaps) ); // set bitmap index, to each table item
  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 the our canvas too
  if Assigned(FCanvas) then
    ID2D1HwndRenderTarget(FCanvas.RenderTarget).Resize(D2D1SizeU(ClientWidth, ClientHeight));

  inherited;
end;

procedure TD2DForm.WMEraseBkGnd(var Message: TWMEraseBkGnd);
begin
  Message.Result := 1;
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
  LSize: TD2DSizeF;
  LRect: TD2D1RectF;
  LView: TD2DMatrix3x2F;
  LIndexX: Integer;
  LIndexY: Integer;
  LBitmap: ID2D1Bitmap;
  LMaxHeight: Single;
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 table
    LRect.Left := 0; LRect.Top := 0;
    for LIndexY := 0 to Length(FBitmapTable) - 1 do
    begin
      LMaxHeight := 0;
      for LIndexX := 0 to Length(FBitmapTable[LIndexY]) - 1 do
      begin
        // Get bitmap to draw
        LBitmap := FBitmaps[ FBitmapTable[LIndexY, LIndexX] ];

        // Get Bitmap Size
        LBitmap.GetSize(LSize);

        // Calc destination rect
        LRect.Right  := LRect.Left + LSize.Width;
        LRect.Bottom := LRect.Top  + LSize.Height;

        // Draw
        RenderTarget.DrawBitmap(LBitmap, @LRect);

        // Increment left position
        LRect.Left   := LRect.Left + LSize.Width;

        // Calc max bitmap height in this row
        if LSize.Height > LMaxHeight then
          LMaxHeight := LSize.Height;
      end;
      LRect.Left := 0;
      LRect.Top  := LRect.Top + LMaxHeight;
    end;
  end;
end;

end.