如何在Image中画类似photoshop中选择的蚂蚁线 |
|
尚未結案
|
|
wlkgood
一般會員   發表：6 回覆：3 積分：1 註冊：2003-03-30 發送簡訊給我 |
|
|
Chance36
版主  發表：31 回覆：1033 積分：792 註冊：2002-12-31 發送簡訊給我 |
|
|
wlkgood
一般會員 發表：6 回覆：3 積分：1 註冊：2003-03-30 發送簡訊給我 |
|
|
wameng
版主 發表：31 回覆：1336 積分：1188 註冊：2004-09-16 發送簡訊給我 |
偷懶 找來的！ var
FFlowPointIndexBase:integer=0;
FCurrentRect:TRect; procedure CanvasDrawFlowRect(Canvas:TCanvas);
var
PointIndex:integer;
procedure DrawFlowLine(X,Y,DeltaX,DeltaY,PointCount,PenColor:integer);
var
i:integer;
begin
for i:=0 to PointCount-1 do
begin
if Odd(PointIndex shr 2) then
Canvas.Pixels[X,Y]:=PenColor xor Canvas.Pixels[X,Y];
Inc(X,DeltaX);
Inc(Y,DeltaY);
Inc(PointIndex);
end;
end;
begin
with Canvas,FCurrentRect do
begin
Pen.Color:=Brush.Color;
PointIndex:=FFlowPointIndexBase;
DrawFlowLine(Left,Top,1,0,Right-Left,Pen.Color);
DrawFlowLine(Right,Top,0,1,Bottom-Top,Pen.Color);
DrawFlowLine(Right,Bottom,-1,0,Right-Left,Pen.Color);
DrawFlowLine(Left,Bottom,0,-1,Bottom-Top,Pen.Color);
end;
end; procedure TForm1.Timer1Timer(Sender: TObject);
begin
CanvasDrawFlowRect(Canvas);
Dec(FFlowPointIndexBase);
if FFlowPointIndexBase mod 8=0 then FFlowPointIndexBase:=0;
CanvasDrawFlowRect(Canvas);
end; procedure TForm1.FormCreate(Sender: TObject);
begin
FCurrentRect := Rect(100,100,300,300);
Timer1.Interval := 50;
end; 利用 FCurrentRect 決定曲線範圍。
不過是方形的。 以上範例，使用的效率可能較差。
改成 圆形 因該也不難。
|
|
wlkgood
一般會員 發表：6 回覆：3 積分：1 註冊：2003-03-30 發送簡訊給我 |
wameng，非常感谢您，不过代码效率很差。
各位大大：
不好意思，我出贴一段代码，其中form上有一image,timer组件，无特别属性。诸位请看 unit ScreenMarchingAnts; interface uses
Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs,
ExtCtrls, StdCtrls; type
TFormMarchingAnts = class(TForm)
Timer1: TTimer;
Image1: TImage;
procedure FormCreate(Sender: TObject);
procedure Timer1Timer(Sender: TObject); procedure ImageMouseDown(Sender: TObject; Button: TMouseButton;
Shift: TShiftState; X, Y: Integer);
procedure ImageMouseMove(Sender: TObject; Shift: TShiftState; X,
Y: Integer);
procedure ImageMouseUp(Sender: TObject; Button: TMouseButton;
Shift: TShiftState; X, Y: Integer);
private
X1,Y1,X2,Y2 : Integer; procedure RemoveTheRect;
procedure DrawTheRect;
public
{ Public declarations }
end; var
FormMarchingAnts: TFormMarchingAnts;
Counter : Byte;
CounterStart : Byte;
Looper : LongInt; implementation
{$R *.DFM} PROCEDURE RestrictCursorToDrawingArea (CONST Image: TImage);
VAR
CursorClipArea: TRect;
BEGIN
CursorClipArea := Bounds(Image.ClientOrigin.X, Image.ClientOrigin.Y,
Image.Width, Image.Height);
Windows.ClipCursor(@CursorClipArea)
END {RestrictCursorToDrawingArea}; PROCEDURE RemoveCursorRestrictions;
BEGIN
Windows.ClipCursor(NIL)
END {RemoveCursorRestrictions}; procedure MovingDots(X,Y: Integer; TheCanvas: TCanvas); stdcall;
begin
Inc(Looper);
{$R-}
Counter := Counter shl 1;
{$R }
if Counter = 0
then Counter := 1;
if (Counter and 224) > 0
then TheCanvas.Pixels[X,Y] := clWhite
else TheCanvas.Pixels[X,Y] := clBlack;
end; function NormalizeRect(R: TRect): TRect;
begin with R do
BEGIN
if Left > Right
then
if Top > Bottom
then Result := Rect(Right,Bottom,Left,Top)
else Result := Rect(Right,Top,Left,Bottom)
else
if Top > Bottom
then Result := Rect(Left,Bottom,Right,Top)
else Result := Rect(Left,Top,Right,Bottom);
END
end; procedure TFormMarchingAnts.FormCreate(Sender: TObject);
begin
X1 := 0;
Y1 := 0;
X2 := 0;
Y2 := 0;
Canvas.Pen.Color := Color;
Canvas.Brush.Color := Color;
CounterStart := 128;
Timer1.Interval := 100;
Timer1.Enabled := True;
Looper := 0; FormMarchingAnts.ControlStyle := FormMarchingAnts.ControlStyle [csOpaque];
end; procedure TFormMarchingAnts.RemoveTheRect;
var
R : TRect;
begin
R := NormalizeRect(Rect(X1,Y1,X2,Y2));
InflateRect(R,1,1);
InvalidateRect(Handle,@R,True);
InflateRect(R,-2,-2);
ValidateRect(Handle,@R);
UpdateWindow(Handle);
end; procedure TFormMarchingAnts.DrawTheRect;
begin
Counter := CounterStart;
LineDDA(X1,Y1,X2,Y1,@MovingDots,LongInt(Canvas));
LineDDA(X2,Y1,X2,Y2,@MovingDots,LongInt(Canvas));
LineDDA(X2,Y2,X1,Y2,@MovingDots,LongInt(Canvas));
LineDDA(X1,Y2,X1,Y1,@MovingDots,LongInt(Canvas));
end; procedure TFormMarchingAnts.Timer1Timer(Sender: TObject);
begin
CounterStart := CounterStart shr 2;
if CounterStart = 0
then CounterStart := 128;
DrawTheRect
end; procedure TFormMarchingAnts.ImageMouseDown(Sender: TObject; Button: TMouseButton;
Shift: TShiftState; X, Y: Integer);
begin
X := X (Sender AS TImage).Left;
Y := Y (Sender AS TImage).Top; RemoveTheRect;
X1 := X;
Y1 := Y; X2 := X;
Y2 := Y; RestrictCursorToDrawingArea( (Sender AS TImage) )
end; procedure TFormMarchingAnts.ImageMouseMove(Sender: TObject; Shift: TShiftState; X,
Y: Integer);
begin
if ssLeft in Shift
then begin
X := X (Sender AS TImage).Left;
Y := Y (Sender AS TImage).top; RemoveTheRect;
X2 := X; Y2 := Y;
DrawTheRect;
end;
end; procedure TFormMarchingAnts.ImageMouseUp(Sender: TObject;
Button: TMouseButton; Shift: TShiftState; X, Y: Integer);
begin
RemoveCursorRestrictions
end; end. 我在想，如果想实现类似photoshop中的魔棒选择区域效果，该对代码作些什么修改呢？麻烦各位前辈看看先！
|
|
bugmans
高階會員 發表：95 回覆：322 積分：188 註冊：2003-04-12 發送簡訊給我 |
樓上網友將程式碼開頭的版權宣告刪掉了
// Extended from "How to Draw Marching Ants" // Robert Vivrette, www.undu.co/DN960901/00000008.htm // // efg, May 1999. // Modified Nov 1999. 完整範例下載 http://www.efg2.com/Lab/Library/Delphi/Graphics/Algorithms.htm#RubberBanding efg's sample project of how to use "Marching Ants" over a TImage 直接連結 http://www.efg2.com/Lab/Library/Delphi/Graphics/MarchingAntsOverTImage.ZIP http://homepages.borland.com/efg2lab/Library/Delphi/Graphics/MarchingAntsOverTImage.ZIP |
|
h@visli
資深會員  發表：103 回覆：429 積分：431 註冊：2004-02-13 發送簡訊給我 |
發表時間：2004-10-02 20:28:52
IP:221.229.xxx.xxx 未訂閱
系統時間：2024-04-26 6:22:50
聯絡我們 | Delphi K.Top討論版
| 本站聲明 |
|
1. 本論壇為無營利行為之開放平台，所有文章都是由網友自行張貼，如牽涉到法律糾紛一切與本站無關。 2. 假如網友發表之內容涉及侵權，而損及您的利益，請立即通知版主刪除。 3. 請勿批評中華民國元首及政府或批評各政黨，是藍是綠本站無權干涉，但這裡不是政治性論壇！ |