先看动画：
代码：
1 unit uFrmTransform;
2
3 interface
4
5 uses
6 Winapi.Windows, Winapi.Messages, System.SysUtils, System.Variants,
7 System.Types, System.Classes, Vcl.Graphics, Vcl.Controls, Vcl.Forms,
8 Vcl.Dialogs, Vcl.Menus, Vcl.ComCtrls, Vcl.ExtCtrls, Vcl.Buttons, Vcl.StdCtrls, //
9 Img32, Img32.Layers, uLayerDefines;
10
11 type
12 TfrmTransform = class(TForm)
13 StatusBar1: TStatusBar;
14 OpenDialog1: TOpenDialog;
15 SaveDialog1: TSaveDialog;
16 pnlTop: TPanel;
17 btnOpen: TSpeedButton;
18 btnSaveAs: TSpeedButton;
19 btnCopy: TSpeedButton;
20 btnPaste: TSpeedButton;
21 btnReset: TSpeedButton;
22 cbType: TComboBox;
23 btnAddControlPoint: TSpeedButton;
24 PaintBox1: TPaintBox;
25 btnHideDesigners: TSpeedButton;
26 procedure FormCreate(Sender: TObject);
27 procedure FormResize(Sender: TObject);
28 procedure PaintBox1Paint(Sender: TObject);
29 procedure FormDestroy(Sender: TObject);
30 procedure btnAddControlPointClick(Sender: TObject);
31 procedure PaintBox1DblClick(Sender: TObject);
32 procedure PaintBox1MouseDown(Sender: TObject; Button: TMouseButton; Shift: TShiftState; X, Y: Integer);
33 procedure PaintBox1MouseMove(Sender: TObject; Shift: TShiftState; X, Y: Integer);
34 procedure btnOpenClick(Sender: TObject);
35 procedure btnPasteClick(Sender: TObject);
36 procedure btnSaveAsClick(Sender: TObject);
37 procedure btnCopyClick(Sender: TObject);
38 procedure btnResetClick(Sender: TObject);
39 procedure cbTypeChange(Sender: TObject);
40 private
41 layeredImage: TLayeredImage32;
42 buttonGroup: TButtonGroupLayer32;
43 rotateGroup: TRotatingGroupLayer32;
44 transformLayer: TTransformLayer32;
45 clickedLayer: TLayer32;
46
47 popupPoint: TPoint;
48 clickPoint: TPoint;
49 ctrlPoints: TPathD;
50 transformType: TTransformType;
51 doTransformOnIdle: Boolean;
52 allowRotatePivotMove: Boolean;
53 procedure ResetSpline(vert: Boolean);
54 procedure ResetVertProjective;
55 procedure ResetSkew(isVerticalSkew: Boolean);
56 procedure ResetRotate;
57 procedure DoTransform;
58 procedure AppIdle(Sender: TObject; var Done: Boolean);
59 public
60 procedure ExcuteTransform();
61 procedure WMERASEBKGND(var message: TMessage); message WM_ERASEBKGND;
62 end;
63
64 var
65 frmTransform: TfrmTransform;
66
67 implementation
68
69 {$R *.dfm}
70
71 uses
72 Img32.Fmt.BMP, Img32.Fmt.PNG, Img32.Fmt.JPG, Img32.Draw, Img32.Vector,
73 Img32.Extra, Img32.Resamplers, Img32.Transform;
74
75 procedure TfrmTransform.AppIdle(Sender: TObject; var Done: Boolean);
76 begin
77 if doTransformOnIdle then
78 begin
79 doTransformOnIdle := false;
80 DoTransform;
81 end;
82 btnPaste.Enabled := TImage32.CanPasteFromClipboard; //是否允许粘贴(会检查剪切板中是否有内容)
83 end;
84
85 procedure TfrmTransform.btnAddControlPointClick(Sender: TObject);
86 var
87 len: Integer;
88 begin
89 // add an extra spline control point
90 if not Assigned(buttonGroup) then
91 Exit;
92 if Sender <> nil then
93 begin
94 popupPoint := Point(transformLayer.MidPoint);
95 end;
96
97 len := Length(ctrlPoints);
98 SetLength(ctrlPoints, len + 1);
99 ctrlPoints[len] := PointD(popupPoint);
100 with buttonGroup.AddButton(PointD(popupPoint)) do
101 CursorId := crSizeAll;
102 DoTransform;
103 end;
104
105 procedure TfrmTransform.btnCopyClick(Sender: TObject);
106 begin
107 transformLayer.Image.CopyToClipBoard;
108 end;
109
110 procedure TfrmTransform.ExcuteTransform;
111 begin //根据类别执行不同的变换
112 case transformType of
113 ttAffineSkewV: //垂直倾斜
114 ResetSkew(True);
115 ttAffineSkewH: //水平倾斜
116 ResetSkew(False);
117 ttProjective: //垂直投影
118 ResetVertProjective;
119 ttSplineV: //垂直样条线
120 ResetSpline(true);
121 ttSplineH: //水平样条线
122 ResetSpline(false);
123 ttAffineRotate:
124 ResetRotate; //仿射旋转
125 end;
126 btnAddControlPoint.Enabled := (transformType = ttSplineV) or (transformType = ttSplineH);
127 end;
128
129 procedure TfrmTransform.btnOpenClick(Sender: TObject);
130 begin //打开图片
131 if not OpenDialog1.Execute then
132 Exit;
133 transformLayer.Image.LoadFromFile(OpenDialog1.FileName);
134 transformLayer.Image.CropTransparentPixels;
135 ExcuteTransform;
136 end;
137
138 procedure TfrmTransform.btnPasteClick(Sender: TObject);
139 begin //从系统剪切板粘贴图片
140 if TImage32.CanPasteFromClipboard and transformLayer.Image.PasteFromClipboard then
141 begin
142 transformLayer.Image.CropTransparentPixels;
143 ExcuteTransform;
144 end;
145 end;
146
147 procedure TfrmTransform.btnResetClick(Sender: TObject);
148 begin //重置
149 transformLayer.Image.LoadFromResource('beetle', 'PNG');
150 transformLayer.ImageBak.Assign(transformLayer.Image);
151 transformLayer.UpdateHitTestMask;
152 transformLayer.AutoPivot := true;
153 transformLayer.PositionCenteredAt(PointD(ClientWidth / 2, ClientHeight / 2));
154 cbType.ItemIndex := 0;
155 cbTypeChange(nil);
156 end;
157
158 procedure TfrmTransform.btnSaveAsClick(Sender: TObject);
159 begin //另存为
160 if SaveDialog1.Execute then
161 transformLayer.Image.SaveToFile(SaveDialog1.FileName);
162 end;
163
164 procedure TfrmTransform.cbTypeChange(Sender: TObject);
165 var
166 pt: TPointD;
167 begin //转换类型发生变化
168 // make each transform additive
169
170 case cbType.ItemIndex of
171 0:
172 transformType := ttAffineSkewV; //1.Vertical Skew
173 1:
174 transformType := ttAffineSkewH; //2.Horizontal Skew
175 2:
176 transformType := ttProjective; //3.Vertical Projective
177 3:
178 transformType := ttSplineV; //4.Vertical Spline
179 4:
180 transformType := ttSplineH; //5.Horizontal Spline
181 5:
182 transformType := ttAffineRotate; //6.Rotate
183 end;
184
185 with transformLayer do
186 begin
187 pt := MidPoint;
188 Image.CropTransparentPixels;
189 PositionCenteredAt(pt);
190 ImageBak.Assign(Image);
191 end;
192 ExcuteTransform;
193 end;
194
195 procedure TfrmTransform.DoTransform;
196 var
197 pt: TPoint;
198 mat: TMatrixD;
199 delta: double;
200 begin
201 // except for rotation, use ctrlPoints to update the 'transformed' layer
202 with transformLayer do
203 begin
204 if (Image.Width = 0) or (Image.Height = 0) then
205 Exit;
206 case transformType of
207 ttAffineSkewV, ttAffineSkewH:
208 begin
209 Image.Assign(ImageBak);
210 mat := IdentityMatrix;
211 if transformType = ttAffineSkewV then
212 begin
213 delta := (ctrlPoints[1].Y - Image.Height) - ctrlPoints[0].Y;
214 mat[0][1] := delta / Image.Width;
215 end
216 else
217 begin
218 delta := (ctrlPoints[1].X - Image.Width) - ctrlPoints[0].X;
219 mat[1][0] := delta / Image.Height;
220 end;
221 // the returned pt states the offset of the new (transformed) image
222 pt := AffineTransformImage(Image, mat);
223 with Point(ctrlPoints[0]) do
224 PositionAt(X + pt.X, Y + pt.Y);
225 end;
226 ttAffineRotate:
227 begin
228 transformLayer.Angle := UpdateRotatingButtonGroup(rotateGroup);
229 StatusBar1.SimpleText := Format(' ROTATE TRANSFORM - angle:%1.0n', [transformLayer.Angle * 180 / PI]);
230 end;
231 ttProjective:
232 begin
233 Image.Assign(ImageBak);
234 if not ProjectiveTransform(Image, Rectangle(Image.Bounds), ctrlPoints, NullRect) then
235 Exit;
236 pt := GetBounds(ctrlPoints).TopLeft;
237 PositionAt(pt.X, pt.Y);
238 end;
239 ttSplineV:
240 begin
241 Image.Assign(ImageBak);
242 if not SplineVertTransform(Image, ctrlPoints, stQuadratic, clRed32, pt) then
243 Exit;
244 PositionAt(pt.X, pt.Y);
245 end;
246 ttSplineH:
247 begin
248 Image.Assign(ImageBak);
249 if not SplineHorzTransform(Image, ctrlPoints, stQuadratic, clRed32, pt) then
250 Exit;
251 PositionAt(pt.X, pt.Y);
252 end;
253 end;
254 UpdateHitTestMask;
255 end;
256 PaintBox1.Invalidate;
257
258 end;
259
260 procedure TfrmTransform.FormCreate(Sender: TObject);
261 begin
262 self.BorderStyle := bsNone;
263
264 // DefaultResampler := rNearestResampler;
265 // DefaultResampler := rBilinearResampler;
266 DefaultResampler := rBicubicResampler; //设置默认采样方式
267
268 // SETUP THE LAYERED IMAGE
269 DefaultButtonSize := DPIAware(10); //设置默认按钮大小(控制点吗？？？)
270 allowRotatePivotMove := true; // false;//
271
272 Application.OnIdle := AppIdle;
273
274 layeredImage := TLayeredImage32.Create;
275 layeredImage.BackgroundColor := Color32(clBtnFace);
276
277 // Layer 0: bottom 'hatched' design layer
278 layeredImage.AddLayer(TLayer32, nil, 'hatched');
279
280 // Layer 1: for the transformed image
281 transformLayer := TTransformLayer32(layeredImage.AddLayer(TTransformLayer32));
282 // transformLayer.MasterImage.LoadFromResource('GRADIENT', 'PNG');
283
284 transformLayer.Image.LoadFromResource('beetle', 'PNG');
285 transformLayer.ImageBak.Assign(transformLayer.Image);
286
287 transformLayer.CursorId := crHandPoint;
288 transformLayer.AutoPivot := true;
289 transformLayer.UpdateHitTestMask;
290
291 cbType.ItemIndex := 0;
292 cbTypeChange(nil);
293 end;
294
295 procedure TfrmTransform.FormDestroy(Sender: TObject);
296 begin
297 layeredImage.Free;
298 Application.OnIdle := nil;
299 end;
300
301 procedure TfrmTransform.FormResize(Sender: TObject);
302 var
303 w, h: Integer;
304 mp: TPointD;
305 dx, dy: double;
306 begin //尺寸变化时
307 if csDestroying in ComponentState then
308 Exit;
309 if not Assigned(layeredImage) then
310 Exit;
311
312 w := PaintBox1.ClientWidth; // ClientWidth;
313 h := PaintBox1.ClientHeight; // ClientHeight;
314
315 // resize layeredImage and the background hatch layer //背景重绘
316 layeredImage.SetSize(w, h);
317 with layeredImage[0] do
318 begin
319 SetSize(w, h);
320 HatchBackground(Image, clWhite32, $FFE0E0E0);
321 end;
322 // and center transformlayer
323 mp := transformLayer.MidPoint;
324 transformLayer.PositionCenteredAt(PointD(w / 2, h / 2));
325
326 // and offset everything else
327 with transformLayer.MidPoint do
328 begin
329 dx := X - mp.X;
330 dy := Y - mp.Y;
331 end;
332 if Assigned(buttonGroup) then //尺寸控制
333 buttonGroup.Offset(Round(dx), Round(dy))
334 else if Assigned(rotateGroup) then //旋转控制
335 rotateGroup.Offset(Round(dx), Round(dy));
336 ctrlPoints := TranslatePath(ctrlPoints, dx, dy);
337 PaintBox1.Invalidate;
338 end;
339
340 procedure TfrmTransform.PaintBox1DblClick(Sender: TObject);
341 begin //双击，添加控制点
342 if (transformType <> ttSplineV) and (transformType <> ttSplineH) then
343 Exit;
344 GetCursorPos(popupPoint);
345 popupPoint := PaintBox1.ScreenToClient(popupPoint);
346 btnAddControlPointClick(nil);
347 end;
348
349 procedure TfrmTransform.PaintBox1MouseDown(Sender: TObject; Button: TMouseButton; Shift: TShiftState; X, Y: Integer);
350 begin
351 if (ssRight in Shift) then
352 Exit; // popup menu
353
354 clickPoint := System.Types.Point(X, Y);
355 clickedLayer := layeredImage.GetLayerAt(clickPoint);
356 end;
357
358 procedure TfrmTransform.PaintBox1MouseMove(Sender: TObject; Shift: TShiftState; X, Y: Integer);
359 var
360 dx, dy, idx, altIdx: Integer;
361 pt: TPoint;
362 layer: TLayer32;
363 begin
364 pt := System.Types.Point(X, Y);
365
366 // if not clicked-moving a layer, then update the cursor and exit.
367 if not (ssLeft in Shift) then
368 begin
369 // get the top-most 'clickable' layer under the mouse cursor
370 layer := layeredImage.GetLayerAt(pt);
371 if Assigned(layer) then
372 Cursor := layer.CursorId
373 else
374 Cursor := crDefault;
375 Exit;
376 end;
377 if not Assigned(clickedLayer) then
378 Exit;
379
380 if clickedLayer = transformLayer then
381 begin
382 dx := pt.X - clickPoint.X;
383 dy := pt.Y - clickPoint.Y;
384 clickPoint := pt;
385 ctrlPoints := TranslatePath(ctrlPoints, dx, dy);
386 clickedLayer.Offset(dx, dy);
387 if Assigned(buttonGroup) then
388 buttonGroup.Offset(dx, dy);
389 if Assigned(rotateGroup) and not allowRotatePivotMove then
390 rotateGroup.Offset(dx, dy);
391 PaintBox1.Invalidate;
392 end
393 else if clickedLayer.parent = rotateGroup then
394 begin
395 if clickedLayer = rotateGroup.PivotButton then
396 begin
397 // moving the pivot button in the rotation group
398 dx := pt.X - clickPoint.X;
399 dy := pt.Y - clickPoint.Y;
400 clickPoint := pt;
401 rotateGroup.Offset(dx, dy);
402 transformLayer.PivotPt := rotateGroup.PivotButton.MidPoint;
403 end
404 else
405 begin
406 // moving the angle button in the rotation group
407 clickedLayer.PositionCenteredAt(pt.X, pt.Y);
408 // we could do the rotation here, but it's
409 // much smoother when done via the AppIdle event.
410 doTransformOnIdle := true;
411 end;
412 PaintBox1.Invalidate;
413 end
414 else if clickedLayer.parent = buttonGroup then
415 begin
416 // clicking a general purpose button (layer)
417
418 // if skewing, keep the buttons axis aligned
419 if transformType = ttAffineSkewV then
420 pt.X := Round(clickedLayer.MidPoint.X);
421 if transformType = ttAffineSkewH then
422 pt.Y := Round(clickedLayer.MidPoint.Y);
423
424 idx := clickedLayer.Index;
425 if transformType = ttProjective then
426 begin
427 // get the index of the moving button's vertical partner
428 // noting that there are 4 buttons in the group ...
429 altIdx := 3 - idx;
430 ctrlPoints[altIdx].X := pt.X;
431 buttonGroup[altIdx].PositionCenteredAt(ctrlPoints[altIdx]);
432 end;
433 clickedLayer.PositionCenteredAt(pt.X, pt.Y);
434 ctrlPoints[idx] := PointD(pt);
435 doTransformOnIdle := true;
436 end;
437
438 end;
439
440 procedure TfrmTransform.PaintBox1Paint(Sender: TObject);
441 var
442 updateRect: TRect;
443 begin
444 // nb: layeredImage32.GetMergedImage returns the rectangular region of the
445 // image that has changed since the last GetMergedImage call.
446 // This accommodates updating just the region that's changed. This is
447 // generally a lot faster than updating the whole merged image).
448 with layeredImage.GetMergedImage(btnHideDesigners.Down, updateRect) do
449 begin
450 // now we just refresh the 'updateRect' region
451 CopyToDc(updateRect, updateRect, PaintBox1.Canvas.Handle, false);
452 end;
453 end;
454
455 procedure TfrmTransform.ResetRotate;
456 begin //仿射旋转
457 FreeAndNil(buttonGroup); //移出尺寸控制点
458 FreeAndNil(rotateGroup); //移出旋转控制点
459
460 transformLayer.UpdateHitTestMask;
461 transformLayer.ResetAngle;
462
463 transformLayer.AutoPivot := not allowRotatePivotMove;
464 if allowRotatePivotMove then
465 transformLayer.PivotPt := transformLayer.MidPoint;
466
467 // create rotate button group while also disabling pivot button moves
468 rotateGroup := CreateRotatingButtonGroup(transformLayer, DefaultButtonSize, clWhite32, clAqua32, 0, -Angle90);
469 rotateGroup.AngleButton.CursorId := crSizeWE;
470
471 PaintBox1.Invalidate;
472 StatusBar1.SimpleText := ' ROTATE TRANSFORM';
473 end;
474
475 procedure TfrmTransform.ResetSkew(isVerticalSkew: Boolean);
476 begin
477 FreeAndNil(buttonGroup);
478 FreeAndNil(rotateGroup);
479
480 SetLength(ctrlPoints, 2);
481 with transformLayer.InnerRect do
482 begin
483 ctrlPoints[0] := TopLeft;
484 ctrlPoints[1] := BottomRight;
485 end;
486 // now make fPts relative to the canvas surface
487 with transformLayer do
488 ctrlPoints := TranslatePath(ctrlPoints, Left, Top);
489
490 buttonGroup := CreateButtonGroup(layeredImage.Root, ctrlPoints, bsRound, DefaultButtonSize, clGreen32);
491
492 PaintBox1.Invalidate;
493 if isVerticalSkew then
494 StatusBar1.SimpleText := ' VERTICAL SKEW'
495 else
496 StatusBar1.SimpleText := ' HORIZONTAL SKEW';
497 end;
498
499 procedure TfrmTransform.ResetSpline(vert: Boolean);
500 begin
501 FreeAndNil(buttonGroup);
502 FreeAndNil(rotateGroup);
503
504 if vert then
505 begin
506 with transformLayer.Image do
507 ctrlPoints := MakePath([0, 0, Width div 2, 0, Width, 0]);
508 StatusBar1.SimpleText := ' VERT SPLINE TRANSFORM: Right click to add control points';
509 end
510 else
511 begin
512 with transformLayer.Image do
513 ctrlPoints := MakePath([0, 0, 0, Height div 2, 0, Height]);
514 StatusBar1.SimpleText := ' HORZ SPLINE TRANSFORM: Right click to add control points';
515 end;
516
517 // now make fPts relative to the canvas surface
518 with transformLayer do
519 ctrlPoints := TranslatePath(ctrlPoints, Left, Top);
520 buttonGroup := CreateButtonGroup(layeredImage.Root, ctrlPoints, bsRound, DefaultButtonSize, clGreen32);
521
522 PaintBox1.Invalidate;
523 end;
524
525 procedure TfrmTransform.ResetVertProjective;
526 begin
527 FreeAndNil(buttonGroup);
528 FreeAndNil(rotateGroup);
529
530 ctrlPoints := Rectangle(transformLayer.InnerRect);
531 // now make fPts relative to the canvas surface
532 with transformLayer do
533 ctrlPoints := TranslatePath(ctrlPoints, Left, Top);
534
535 buttonGroup := CreateButtonGroup(layeredImage.Root, ctrlPoints, bsRound, DefaultButtonSize, clGreen32);
536
537 PaintBox1.Invalidate;
538 StatusBar1.SimpleText := ' PROJECTIVE TRANSFORM';
539 end;
540
541 procedure TfrmTransform.WMERASEBKGND(var message: TMessage);
542 begin
543 // Since we want full control of painting (see FormPaint below),
544 // we'll stops Windows unhelpfully erasing the form's canvas.
545 message.Result := 1;
546 end;
547
548 end.
标签：begin,end,pt,变形,delphi,Image32,ctrlPoints,transformLayer,procedure From： https://www.cnblogs.com/bluejade/p/18279004