全國最多中醫師線上諮詢網站-台灣中醫網
發文 回覆 瀏覽次數:2945
推到 Plurk!
推到 Facebook!

请问哪位尊敬的大侠有dephi抗锯齿的函数啊?

答題得分者是:RootKit
rainxie
一般會員


發表:20
回覆:27
積分:14
註冊:2008-03-13

發送簡訊給我
#1 引用回覆 回覆 發表時間:2008-04-14 10:27:00 IP:58.37.xxx.xxx 訂閱
我用delphi的lineto画曲线,锯齿很严重,但在ppt放映里画,锯齿却处理得很好,如图

请问哪位尊敬的大侠能给一个类似的函数啊,不胜感激!
不胜感激!
我找了很久,也没有好的,曾看到一个抗直线锯齿的,但没有曲线的。
graphics32里可以,但要在它的image32上画,我希望有一个单独的function能处理锯齿问题。
非常期待您的指教!
RootKit
資深會員


發表:16
回覆:357
積分:419
註冊:2008-01-02

發送簡訊給我
#2 引用回覆 回覆 發表時間:2008-04-15 01:26:17 IP:61.222.xxx.xxx 訂閱
參考這裡
http://www.planetsourcecode.com/vb/scripts/ShowCode.asp?txtCodeId=1425&lngWId=7

http://www.swissdelphicenter.ch/torry/showcode.php?id=1812
rainxie
一般會員


發表:20
回覆:27
積分:14
註冊:2008-03-13

發送簡訊給我
#3 引用回覆 回覆 發表時間:2008-04-16 09:30:47 IP:58.37.xxx.xxx 訂閱
 非常感谢Rootkit!
第一个网址可能失效了,显示找不到网页
第二个是可以的,但是我怎么画不出线来,我dephi掌握不够,能麻烦您帮我看看吗?谢谢了!!
这是我写的调用代码:

Bitmap:=TBitmap.create;
Bitmap.width:=300;
Bitmap.height:=500;
Image1.Picture.Graphic:=Bitmap;
Image1.Picture.Bitmap.canvas.pen.color:=clRed;
Image1.Picture.Bitmap.canvas.moveto(10,10);
WuLine(Bitmap,point(0,0),point(300,500),clred);
Image1.Picture.Bitmap.canvas.lineto(100,150);

最后一行的lineto可以画出线来,但倒数第二行却画不出来,不知道是什么原因
編輯記錄
rainxie 重新編輯於 2008-04-16 09:31:34, 註解 無‧
rainxie 重新編輯於 2008-04-16 09:32:47, 註解 無‧
rainxie 重新編輯於 2008-04-16 09:33:05, 註解 無‧
system72
中階會員


發表:15
回覆:114
積分:55
註冊:2005-08-17

發送簡訊給我
#4 引用回覆 回覆 發表時間:2008-04-16 10:33:52 IP:219.81.xxx.xxx 未訂閱
這個如果有修過相關科目,如計算機圖學,演算法....的,
程度不錯的大概就會,

也許可以考慮發包給 研究生,或資訊相關科系大4學生來處理.
算是給他們賺零用錢跟練習的機會.

至於 尊敬的大侠 這個稱號,
好像對他們比較抽象,沒現金實用.





===================引 用 rainxie 文 章===================
非常感谢Rootkit!
第一个网址可能失效了,显示找不到网页
第二个是可以的,但是我怎么画不出线来,我dephi掌握不够,能麻烦您帮我看看吗?谢谢了!!
这是我写的调用代码:

Bitmap:=TBitmap.create;
Bitmap.width:=300;
Bitmap.height:=500;
Image1.Picture.Graphic:=Bitmap;
Image1.Picture.Bitmap.canvas.pen.color:=clRed;
Image1.Picture.Bitmap.canvas.moveto(10,10);
WuLine(Bitmap,point(0,0),point(300,500),clred);
Image1.Picture.Bitmap.canvas.lineto(100,150);

最后一行的lineto可以画出线来,但倒数第二行却画不出来,不知道是什么原因
編輯記錄
system72 重新編輯於 2008-04-16 10:39:22, 註解 無‧
system72 重新編輯於 2008-04-16 10:40:58, 註解 無‧
RootKit
資深會員


發表:16
回覆:357
積分:419
註冊:2008-01-02

發送簡訊給我
#5 引用回覆 回覆 發表時間:2008-04-17 21:07:26 IP:61.222.xxx.xxx 訂閱
Google Search 一下就有很多資料。

以下參考 TAntialiasedLine 元件中函數做成的範例。
[code delphi]
procedure AntialiasedLine(c: TCanvas; x0, y0, x1, y1: Integer; caler: array of TColor);
const
BaseColor = 0;
NumLevels = 256;
IntensityBits = 8;
var
IntensityShift, ErrorAdj, ErrorAcc: Word;
ErrorAccTemp, Weighting, WeightingComplementMask: Word;
DeltaX, DeltaY, Temp, XDir: Integer;
begin
if y0 > y1 then begin
Temp := y0; y0 := y1; y1 := Temp;
Temp := x0; x0 := x1; x1 := Temp;
end;

c.Pixels[x0,y0] := Caler[BaseColor];

DeltaX := x1-x0;

if DeltaX >= 0 then
XDir := 1
else begin
XDir := -1;
DeltaX := -DeltaX;
end;

DeltaY := y1 - y0;

// special case some lineses...

if deltaY = 0 then begin
// hoizontal
while deltaX <> 0 do begin
Dec(DeltaX);
Inc(x0,xDir);
c.Pixels[x0,y0] := Caler[BaseColor];
end;
Exit;
end;

if deltaX = 0 then begin
// vertical
repeat
Inc(y0);
c.Pixels[x0,y0] := Caler[BaseColor];
Dec(deltaY);
until deltaY = 0;
Exit;
end;

if deltaX = deltaY then begin
// diagonal
repeat
Inc(x0,xDir);
Inc(y0);
c.Pixels[x0,y0] := Caler[BaseColor];
Dec(deltaY);
until deltaY = 0;
Exit;
end;

// normal odd cases

ErrorAcc := 0;

IntensityShift := 16 - IntensityBits;

WeightingComplementMask := NumLevels - 1;

if deltaY > deltaX then begin
// y-maj line
ErrorAdj := (deltaX shl 16) div deltaY;

while deltaY > 1 do begin
Dec(deltaY);
ErrorAccTemp := ErrorAcc;
Inc(ErrorAcc, ErrorAdj);
if ErrorAcc <= ErrorAccTemp then
Inc(x0,XDir);

Inc(y0);

Weighting := ErrorAcc shr IntensityShift;

c.Pixels[x0, y0] := Caler[BaseColor Weighting];
c.Pixels[x0 XDir,y0] := Caler[BaseColor (Weighting xor WeightingComplementMask)];
end;

end else begin

// x-major

ErrorAdj := (deltaY shl 16) div deltaX;

while deltaX > 1 do begin
Dec(deltaX);
ErrorAccTemp := ErrorAcc;
Inc(ErrorAcc, ErrorAdj);
if ErrorAcc <= ErrorAccTemp then
Inc(y0);

Inc(x0,XDir);

Weighting := ErrorAcc shr IntensityShift;

c.Pixels[x0, y0] := Caler[BaseColor Weighting];
c.Pixels[x0,y0 1] := Caler[BaseColor Weighting xor WeightingComplementMask];
end;

end;

// final pixel
c.Pixels[x1,y1] := Caler[BaseColor];
end;


procedure ThickAntialiasedLine(th: Integer; c: TCanvas; x0, y0, x1, y1: Integer; caler: array of TColor);
const
BaseColor = 0;
NumLevels = 256;
IntensityBits = 8;
var
IntensityShift, ErrorAdj, ErrorAcc: Word;
ErrorAccTemp, Weighting, WeightingComplementMask: Word;
DeltaX, DeltaY, Temp, XDir: Integer;
i,OldX0: Integer;
begin
if y0 > y1 then
begin
Temp := y0; y0 := y1; y1 := Temp;
Temp := x0; x0 := x1; x1 := Temp;
end;

DeltaX := x1-x0;

if DeltaX >= 0 then
XDir := 1
else begin
XDir := -1;
DeltaX := -DeltaX;
end;

DeltaY := y1 - y0;


ErrorAcc := 0;

IntensityShift := 16 - IntensityBits;

WeightingComplementMask := NumLevels - 1;

if deltaY > deltaX then
begin
OldX0 := X0;
// y-maj line

if XDir > 0 then begin
Dec( x0, th div 2 );
for i := x0 to x0 th do
c.Pixels[i,y0] := Caler[BaseColor];
end else begin
Inc( x0, th div 2 );
for i := x0 downto x0-th do
c.Pixels[i,y0] := Caler[BaseColor];
end;

ErrorAdj := (deltaX shl 16) div deltaY;

while deltaY > 0 do begin
Dec(deltaY);
ErrorAccTemp := ErrorAcc;
Inc(ErrorAcc, ErrorAdj);
if (x1<>OldX0) and (ErrorAcc <= ErrorAccTemp) then Inc(x0,XDir);

Inc(y0);

Weighting := ErrorAcc shr IntensityShift;

c.Pixels[x0, y0] := Caler[BaseColor Weighting];
if XDir > 0 then
for i := x0 1 to x0 th do
c.Pixels[i,y0] := Caler[BaseColor]
else
for i := x0-1 downto x0-th do
c.Pixels[i,y0] := Caler[BaseColor];
c.Pixels[i,y0] := Caler[BaseColor (Weighting xor WeightingComplementMask)];
end;

end else begin

// x-major

Dec( x0, th div 2 );
for i := y0 to y0 th do
c.Pixels[x0,i] := Caler[BaseColor];

ErrorAdj := (deltaY shl 16) div deltaX;

while deltaX > 0 do begin
Dec(deltaX);
ErrorAccTemp := ErrorAcc;
Inc(ErrorAcc, ErrorAdj);
if (y1<>y0) and (ErrorAcc <= ErrorAccTemp) then Inc(y0);

Inc(x0,XDir);

Weighting := ErrorAcc shr IntensityShift;

c.Pixels[x0, y0] := Caler[BaseColor Weighting];
for i := y0 1 to y0 th do
c.Pixels[x0,i] := Caler[BaseColor];
c.Pixels[x0,i] := Caler[BaseColor Weighting xor WeightingComplementMask];
end;

end;

end;

procedure Gradiate(Begindex, Endex: Integer; var Rainbo: array of TColor);
var
i: Integer;
reds, greens, blues, steps: Integer;
peRed, peGreen, peBlue: Integer;
begR, begG, begB: Integer;
begin
if (Begindex = Endex) or (Begindex < 0) or (Endex < 0) then Exit;

begR := Rainbo[Begindex] and $FF;
begG := (Rainbo[Begindex] and $FF00) shr 8;
begB := (Rainbo[Begindex] and $FF0000) shr 16;

reds := (Rainbo[Endex] and $FF) -
begR;
greens := ((Rainbo[Endex] and $FF00) shr 8) -
begG;
blues := ((Rainbo[Endex] and $FF0000) shr 16) -
begB;
steps := Endex - Begindex;

for i := Begindex 1 to Endex - 1 do
begin
peRed := begR (reds * (i-Begindex)) div steps;
peGreen := begG (greens * (i-Begindex)) div steps;
peBlue := begB (blues * (i-Begindex)) div steps;
Rainbo[i] := peRed (peGreen shl 8) (peBlue shl 16);
end;
end;

procedure AntialiasedLineTo(Canvas: TCanvas; X, Y: Integer);
var
caler: array[0..255] of TColor;
begin
caler[0] := Canvas.Pen.Color;
caler[255] := Canvas.Brush.Color;
Gradiate(0,255,caler);

if Canvas.Pen.Width > 1 then
ThickAntialiasedLine( Canvas.Pen.Width,
Canvas,
Canvas.PenPos.X, Canvas.PenPos.Y,
X, Y, caler )
else
AntialiasedLine( Canvas,
Canvas.PenPos.X, Canvas.PenPos.Y,
X, Y, caler );

// Canvas.MoveTo(X,Y);
end;


procedure TForm1.FormCreate(Sender: TObject);
begin
Canvas.Brush.Color := $00C8D0D4;
Canvas.Pen.Color := clBlue;
Canvas.Pen.Width := 1;
MouseDn := False;

end;

procedure TForm1.FormMouseDown(Sender: TObject; Button: TMouseButton;Shift: TShiftState; X, Y: Integer);
begin
if Button = mbLeft then
begin
MouseDn := True;
Canvas.PenPos := Point(X,Y);
end;
end;

procedure TForm1.FormMouseMove(Sender: TObject; Shift: TShiftState; X,Y: Integer);
begin
if MouseDn and (ssLeft in Shift) then
begin
AntialiasedLineTo(Canvas,X,Y);
Canvas.PenPos := Point(X,Y);
end;
end;

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

[/code]

不過原始函數在處理 PenWidth>1 時會有亂畫。
我已修改。由於沒有太多時間去改善,所以畫上去還不是很順暢。自己改吧!
不過畫直線還是很OK。
rainxie
一般會員


發表:20
回覆:27
積分:14
註冊:2008-03-13

發送簡訊給我
#6 引用回覆 回覆 發表時間:2008-04-18 16:52:13 IP:58.37.xxx.xxx 訂閱
谢谢热心的Rootkit!
非常感谢您帮我去花时间改代码!!

画的效果还可以,呵呵呵,我再看能否改进?不过能力比较差,期望能看懂这些代码,呵呵呵

再一次感谢您!rootkit
系統時間:2017-10-24 1:08:37
聯絡我們 | Delphi K.Top討論版
本站聲明
1. 本論壇為無營利行為之開放平台,所有文章都是由網友自行張貼,如牽涉到法律糾紛一切與本站無關。
2. 假如網友發表之內容涉及侵權,而損及您的利益,請立即通知版主刪除。
3. 請勿批評中華民國元首及政府或批評各政黨,是藍是綠本站無權干涉,但這裡不是政治性論壇!