AAFont字体描边及32位图像处理

使用BeginPath, EndPath, FillPath函数
下载地址: [url]http://lqcros.go1.wy8.net/NewAAFont2.63.rar[/url]

我觉得要制作更多的字体效果的话，最好是用，32位图像来制作
TBitmap就支持这个功能，不过，图像合成时需要一个函数CombineAlphaPixel(函数附后，这个函数是FLib里的)
使用Bitmap时请把他设成32位的,如: PixelFormat := pf32Bit;

//===================================================================
// 计算两个32bit象素的等效象素，这个函数非常重要(speed)，安全检查就不做了
// cr1：背景    cr2：前景


// 这两个函数引用自FLIB //
// 只处理目标ALPHA通道时,两个函数可以替换到用 //

// :o 注意这里一下, 替换时请在DrawTo,DrawFrom 里面替换就可以了

//这个函数是以目标像素及源像素的Alpha通道合成
procedure  TBitmap32.CombineAlphaPixel(var pDest: TRGBQuad; cr1: TRGBQuad; nAlpha1: integer; cr2: TRGBQuad; nAlpha2: integer);
var
    nTmp1, nTmp12, nTemp, nTmp2: integer;
begin
        if ((nAlpha1 <> 0) or (nAlpha2 <> 0)) then
        begin
                if (nAlpha2 = 0) then
                begin
                        pDest.rgbBlue  := cr1.rgbBlue ;
                        pDest.rgbGreen := cr1.rgbGreen ;
                        pDest.rgbRed  := cr1.rgbRed ;
                        pDest.rgbReserved := nAlpha1 ;
                        exit;
                end;
                if ((nAlpha1 = 0) or (nAlpha2 = $FF)) then
                begin
                        pDest.rgbBlue  := cr2.rgbBlue ;
                        pDest.rgbGreen := cr2.rgbGreen ;
                        pDest.rgbRed   := cr2.rgbRed ;
                        pDest.rgbReserved := nAlpha2 ;
                        exit;
        end;


                // 以下用不着判断[0,0xFF]，我验算过了
                nTmp1 := $FF * nAlpha1;
        nTmp2 := $FF * nAlpha2 ;
                nTmp12 := nAlpha1 * nAlpha2;
                nTemp  := nTmp1 + nTmp2 - nTmp12 ;
                pDest.rgbBlue  := (nTmp2 * cr2.rgbBlue  + (nTmp1 - nTmp12) * cr1.rgbBlue)  div nTemp ;
                pDest.rgbGreen := (nTmp2 * cr2.rgbGreen + (nTmp1 - nTmp12) * cr1.rgbGreen) div nTemp ;
                pDest.rgbRed   := (nTmp2 * cr2.rgbRed   + (nTmp1 - nTmp12) * cr1.rgbRed)   div nTemp ;
                pDest.rgbReserved := nTemp div $FF ;


//                下面的代码是未优化过的，可读性更好些
{
                nTemp :=  $FF * (nAlpha1 + nAlpha2) - nAlpha1*nAlpha2 ;
                pDest.rgbBlue  := min($FF, ($FF * cr2.rgbBlue  * nAlpha2 + ($FF - nAlpha2) * cr1.rgbBlue  * nAlpha1) div nTemp) ;
                pDest.rgbGreen := min($FF, ($FF * cr2.rgbGreen * nAlpha2 + ($FF - nAlpha2) * cr1.rgbGreen * nAlpha1) div nTemp) ;
                pDest.rgbRed   := min($FF, ($FF * cr2.rgbRed   * nAlpha2 + ($FF - nAlpha2) * cr1.rgbRed   * nAlpha1) div nTemp) ;
                pDest.rgbReserved := nTemp div $FF ;
}
        end
        else
        begin
                pDest.rgbBlue  := $FF;
        pDest.rgbGreen := $FF;
        pDest.rgbRed   := $FF;
                pDest.rgbReserved := 0 ;
        end;
end;

如:
            CombineAlphaPixel(Target^[x], Target^[x], Target^[x].rgbReserved, Source^[x - DstX], Source^[x- DstX].rgbReserved);

// 这个函数就更重要了，安全检查当然不做了:-)，根据pSrc中的alpha计算，nAlphaSrc一定要保证在0，0xFF之间

//这个函数只是以源像素的Alpha通道合成
procedure TBitmap32.AlphaBlendPixel(var pDest: TRGBQuad; pSrc: TRGBQuad);
begin
    if (pSrc.rgbReserved = $FF) then
    begin
        PRGBArray(pDest) := PRGBArray(pSrc);
        exit;
    end;

    if (pSrc.rgbReserved = 0) then
    exit;
    // 以下用不着判断[0,0xFF]，我验算过了

    if (PRGBArray(pSrc) <> PRGBArray(pDest)) then
    begin
        pDest.rgbBlue := (PSrc.rgbBlue - pDest.rgbBlue) * pSrc.rgbReserved div $FF + pDest.rgbBlue;
        pDest.rgbGreen := (PSrc.rgbGreen - pDest.rgbGreen) * pSrc.rgbReserved div $FF + pDest.rgbGreen;
        pDest.rgbRed := (PSrc.rgbRed - pDest.rgbRed) * pSrc.rgbReserved div $FF + pDest.rgbRed;
    end;
end;

如:
    AlphaBlendPixel(Target^[x], Source^[x]);


    //:o:o:o:o:o:o:o//
{    把这个函数写到DrawTo函数以替换CombineAlphaPiexl
     
图层的概念
[
最下层是画布(就是一个TBitmap32对像,也可以是Image1.Picture.Bitmap)
跟着上面的就是图层啦,文字层什么的
]


从最下层的32位图像画起
就可以把许多个32位图层到画布上,显示出来


procedure TBitmap32.DrawTo(DstX, DstY: Integer; Tge: TBitmap);
var
    x, y: integer;
    TR, SR: TRect;
    Source, Target: pRGBQuadArray;
begin
    Tge.PixelFormat := pf32bit;
    SetAlphaChannels(Tge, $FF);

    Tr := Rect(0, 0, Tge.Width, Tge.Height);
    SR := Rect(DstX, DstY, DstX + Width, DstY + Height);

    if IntersectRect(Tr, Tr, SR) = false then
    exit;

    for y := Tr.Top to Tr.Bottom - 1 do
    begin
        Target := Tge.ScanLine[y];
        Source := ScanLine[y - Dsty];


        for x := Tr.Left to Tr.Right - 1 do
        begin
//这里替换了
//            CombineAlphaPixel(Target^[x], Target^[x], Target^[x].rgbReserved, Source^[x - DstX], Source^[x- DstX].rgbReserved);
            AlphaBlendPixel(Target^[x], Source^[x]);
        end;


    end;

end;

for i := 0 to LayerList.Count -1 do
begin
    TBitmap32(LayerList.Items[i ]).DrawTo(0,0, Image1.Picture.Bitmap);
end;

}


    //:o:o:o:o:o:o//

[[i] Last edited by croslq on 2005-10-15 at 14:39 [/i]]

请高手把上面哪个函数MMX优化一下

请高手把上面哪个函数MMX优化一下,不然哪个性能就有点差了哈

TBitmap32的可以这样实现

type
   TBitmap32 := class(TBitmap)


   end;

哈哈这样就可以处理32位图像了三

type
  TBitmap32 = class(TBitmap)
  private

  protected
  public
    constructor Create; override;
    destructor Destroy; override;

    procedure Assign(Source: TPersistent); override;                //重载，设置为32位
    procedure LoadFromFile(const Filename: string); override;       //重载，设置为32位
  end;



constructor TBitmap32.Create;
begin
    inherited Create;
    PixelFormat := pf32bit;
end;

destructor TBitmap32.Destroy;
begin
    inherited Destroy;
end;

procedure TBitmap32.LoadFromFile(const Filename: string);
begin
    inherited LoadFromFile(FileName);
    PixelFormat := pf32bit;
end;

procedure TBitmap32.Assign(Source: TPersistent);
begin
    inherited Assign(Source);
    PixelFormat := pf32bit;
end;

TBitmap32的可以这样实现

TBitmap32的FillRect不要使用，因为处理的颜色不是32位

procedure FillLongword(var X; Count: Integer; Value: Longword);
asm
// EAX = X
// EDX = Count
// ECX = Value
        PUSH    EDI

        MOV     EDI,EAX  // Point EDI to destination              
        MOV     EAX,ECX
        MOV     ECX,EDX
        TEST    ECX,ECX
        JS      @exit

        REP     STOSD    // Fill count dwords
@exit:
        POP     EDI
end;

procedure  TBitmap32.Clear(color: TColor32);
var
    x, y: integer;
    t1: int64;
begin

    t1 := timegettime;
    {
    for y := 0 to Height-1 do
    for x := 0 to Width-1 do
    SetPixel(x, y, Color);
    }
//    ZeroMemory(GetBits, Height* width *4);


    FillLongword(GetBits^[0], Width * Height, Color);

    TraceString(IntToStr(timegettime-t1));

end;

有个开放源码的 Graphi32 项目就是专门做 32 位位图处理的，里面有 MMX 优化的。
[url]http://www.graphics32.org/[/url]

没地方上传，也可以用附件放到论坛上来。

这样的说。好的

OK，知道了

这个是你们网站的AAFont,我加了描边的

这个是你们网站的AAFont,我加了描边的,因为上次给你发了一个，不过性能不佳，
终于找到哪个原因，是因为StrokePath这个微软的函数本身就性能差

好，那我把那些链接不能下载的帖子删除吧？

我用G32库里的BlendLine函数(MMX优化)测试了一下，性能没有明显的提高
可能是DELPHI的编译本身就带有pentium优化

上面这个３２位图像处理的方法，可以开发字体特效（抗锯齿，字体的纹理填充，阴影，描边及描边的纹理填充），也可以开发其他的如图像处理软件（图层什么的），只要再在里面加入一部分功能（如：画线、矩形，非规则区域选择<ALPHA通道(把ALPHA作为一个MASK处理就行)>......）。。。。。。

刘 强 2005.10.13
邮箱地址：[email]lqcros@163.com[/email]
主页地址：[url]http://lqcros.go1.wy8.net[/url]

[[i] Last edited by croslq on 2005-10-13 at 14:06 [/i]]

font32image.rar包里面一个GraphicEx库，通过他可以打开TGA,PSD,BMP,TIFF等图像文件。
我一般是用他来打开３２位TGA图像或３２位BMP图像，然后通过３２位图像处理函数里的DrawTo函数输出到屏幕，DrawTo有２个重载函数,一个是把self写到３２位图像，一个是把self写到一般的Tbitmap。
例：
    Bitmap.DrawTo(0,0,Image1.Picture.Bitmap);


刘 强 2005.10.13
邮箱地址：[email]lqcros@163.com[/email]
主页地址：[url]http://lqcros.go1.wy8.net[/url]

[[i] Last edited by croslq on 2005-10-13 at 14:07 [/i]]

刘 强 2005.10.13
邮箱地址：[email]lqcros@163.com[/email]
主页地址：[url]http://lqcros.go1.wy8.net[/url]

[[i] Last edited by croslq on 2005-10-13 at 14:07 [/i]]

其实　CreateFontIndirect　这个函数就能输出抗锯齿的字体啦

Delphi这样使用：

procedure TForm1.Button1Click(Sender: TObject);
var
  lf : TLogFont;
  Bitmap: TBitmap;
begin
    Bitmap := TBitmap.create;
    Bitmap.Width := 400;
    Bitmap.Height := 200;

    Bitmap.Canvas.Font.Name := '华文行楷';
    Bitmap.Canvas.Font.Size := 72;
    Bitmap.Canvas.Font.Style := [fsBold, fsItalic, fsUnderline, fsStrikeOut];
    GetObject(Bitmap.Canvas.Font.Handle, SizeOf(TLogFont), @lf);
    lf.lfQuality := ANTIALIASED_QUALITY;   //设置输出质量（抗锯齿）
    Bitmap.Canvas.Font.Handle := CreateFontIndirect(lf);
    Bitmap.Canvas.TextOut(0,0,'平滑字体');
    Image1.Picture.Bitmap.Assign(Bitmap);
    Bitmap.Free;
end;


刘 强 2005.10.13
邮箱地址：[email]lqcros@163.com[/email]
主页地址：[url]http://lqcros.go1.wy8.net[/url]

[[i] Last edited by croslq on 2005-10-13 at 14:13 [/i]]

通过函数 GetGlyphOutline 可以取得 TrueType　字体的轮廓，就可以描边啦
可以参考网址:[url]http://www.legalsoft.com.cn/articles/show.asp?id=269[/url]

也可以使用beginPath, EndPath, GetPath　提取


        FPathPoints: array of TPoint;
        FPathTypes: array of Byte;
        FNumber: Integer;
        PointIdx: integer;

  BeginPath(GrayBmp.Canvas.Handle);
    SetBkMode(GrayBmp.Canvas.Handle, TRANSPARENT);
    GrayBmp.Canvas.TextOut(0, 0, Text);
  EndPath(GrayBmp.Canvas.Handle);

  FNumber := GetPath(GrayBmp.Canvas.Handle, Pointer(nil^), Pointer(nil^), 0);
  SetLength(FPathPoints, FNumber);
  SetLength(FPathTypes, FNumber);
  FNumber := GetPath(GrayBmp.Canvas.Handle, FPathPoints[0], FPathTypes[0], FNumber);

  PointIdx := 0;  

//+++  描边//
    while PointIdx < FNumber do begin

    case FPathTypes[PointIdx] of PT_MOVETO:
        begin
            GrayBmp.Canvas.MoveTo(FPathPoints[PointIdx].X, FPathPoints[PointIdx].Y);
            LastMove := FPathPoints[PointIdx];
            inc(PointIdx, 1);
        end;
        PT_LINETO:
        begin
            GrayBmp.Canvas.LineTo(FPathPoints[PointIdx].X, FPathPoints[PointIdx].Y);
            inc(PointIdx, 1);
        end;
        PT_BEZIERTO:
        begin
            PolyBezierTo(GrayBmp.Canvas.Handle, FPathPoints[PointIdx], 3);
            inc(PointIdx, 3);
        end;
        PT_LINETO or PT_CLOSEFIGURE:
        begin
            GrayBmp.Canvas.LineTo(FPathPoints[PointIdx].X, FPathPoints[PointIdx].y);
            GrayBmp.Canvas.LineTo(LastMove.x, LastMove.y);
            inc(PointIdx, 1);
        end;
        PT_BEZIERTO or PT_CLOSEFIGURE:
        begin
            PolyBezierTo(GrayBmp.Canvas.Handle, FPathPoints[PointIdx], 3);
            GrayBmp.Canvas.LineTo(LastMove.x, LastMove.y);
            inc(PointIdx, 3);
        end;
    end;
    end;


  SetLength(FPathPoints, 0);
  SetLength(FPathTypes, 0);

刘 强 2005.10.13
邮箱地址：[email]lqcros@163.com[/email]
主页地址：[url]http://lqcros.go1.wy8.net[/url]

[[i] Last edited by croslq on 2005-10-13 at 14:07 [/i]]

32位图层(随手写的,没测试,你们看一下原理就行了哈:P)

type
   TLayerList = class(TList)
   private

   end;

Bitmap32 : TBitmap32;
LayerList := TLayerList.Create;

Bitmap32 := TBitmap32.Create;
Bitmap32.LoadFromFile('1.tga');
LayerList.Items.add(Bitmap32);


for i := 0 to LayerList.Count -1 do
begin
    TBitmap32(LayerList.Items[i ]).DrawTo(0,0, Image1.Picture.Bitmap);
end;


for i := 0 to LayerList.Count -1 do
begin
TBitmap32(LayerList.Items[i ]).Free;
end;
LayerList.Free;

刘 强 2005.10.13
邮箱地址：[email]lqcros@163.com[/email]
主页地址：[url]http://lqcros.go1.wy8.net[/url]

[[i] Last edited by croslq on 2005-10-15 at 14:45 [/i]]

MMX优化AlphaBlendPixel

//                             TColor32(AARRGGBB)     TColor32        0 .. 255
//                                 |            |                |
//               AlphaBlendPixel(Source^[x], Target^[x], AlphaComponent(Source^[x]));
procedure AlphaBlendPixel(Source: TColor32; var Target: TColor32; Alpha: DWORD);
asm
    MOVD            MM1, EAX        // MM1 = 00 00 00 00 ** Fr Fg Fb
    MOVD            MM2,[EDX]      // MM2 = 00 00 00 00 ** Br Bg Bb
    PUNPCKLBW MM1, MM0       // MM1 = 00 ** 00 Fr 00 Fg 00 Fb
    MOVD            MM3, ECX       // MM3 = 00 00 00 00 00 00 00 AA  
    PUNPCKLBW MM2, MM0       // MM2 = 00 ** 00 Br 00 Bg 00 Bb
    PSHUFW       MM3, MM3, 0   // MM3 = 00 AA 00 AA 00 AA 00 AA
    PSUBW         MM1, MM2
    PSLLW          MM2, 8
    PMULLW       MM1, MM3
    PADDW         MM1, MM2
    PSRLW          MM1, 8
    PACKUSWB   MM1, MM0
    MOVD           [EDX],MM1
    emms
end;

[[i] Last edited by croslq on 2005-10-15 at 20:30 [/i]]

抗锯齿直线的实现

附件里的自定义的画笔(掩码图)，它本身边缘就是羽化了的，所以就能抗锯齿
下面画线函数，首先确定直线的每一点的坐标，然后把自定义画笔画到这个坐标上，直到画完线
:P:P:P（这个抗锯齿直线就画起了三）

这个方法还可以反走样字体的边缘啦
在哪个EndPath后面
加一个FlattenPath函数（平整为直线的）
16楼哪个画直线函数用这个函数替换


procedure DrawMaskPen(TargetBitmap: TBitmap; DstX, DstY: Integer; Mask8: TBitmap);
var
    Source, Target: PByteArray;
    TR, SR: TRect;
    x, y: integer;   
begin

    TR := Rect(0, 0, TargetBitmap.Width, TargetBitmap.Height);
    SR := Rect(DstX, DstY, DstX + Mask8.Width, DstY + Mask8.Height);

    if IntersectRect(TR, TR, SR) = false then
    exit;

    for y := Tr.Top to Tr.Bottom - 1 do
    begin
        Target := TargetBitmap.ScanLine[y];
        Source := Mask8.ScanLine[y - Dsty];
        for x := TR.Left to Tr.Right - 1 do
        begin
            if (Target^[x] + Source^[x - Dstx]) > 255 then
            Target^[x] := 255
            else
            Target^[x] := Target^[x] + Source^[x - Dstx];
        end;
    end;   
end;


//采用Bresenham算法绘制一条颜色相同的直线
//将Bresenham算法写成统一的形式
//x1, y1, x2, y2直线的起点和端点
//通过附件里自定义的画笔,实现了8位蒙板图画抗锯齿直线

procedure LineMaskPen(Target8: TBitmap; x1, y1, x2, y2: integer; MaskPen8: TBitmap);
var
    nDx, nDy: integer;
    nIx, nIy: integer;
    nInc: integer;
    nJudgeX, nJudgeY: integer;
    x, y: integer;
    nTwoIx, nTwoIy: integer;
    i: integer;
    bPlot: boolean;

begin
        //两端点间的水平偏移量和垂直偏移量
        nDx := x2 - x1;
        nDy := y2 - y1;

        //两端点间的水平距离和垂直距离
        nIx := ABS(nDx);
        nIy := ABS(nDy);

        //描点步数(增量总值)
        nInc := MAX(nIx, nIy);

        //绘制第一个点, 即, 直线的起点
//        SetPixel(hdc, x1, y1, clr);
    DrawMaskPen(Target, x1- MaskPen8.Width div 2, y1 - MaskPen8.Height div 2, MaskPen8);

        //不包含终点
        if(nInc < 2) then
    exit;

        //用于判断是否在nJudgeX, nJudgeY方向上向前进
        nJudgeX := -nIy;
    nJudgeY := -nIx;

        //通过增量计算得到的当前点
        x := x1;
    y := y1;
       
        //开始进行增量计算
        //采用Bresenham算法.在这里, 我们将算法进行改进,
        //使其对于任意斜率的直线都能绘制, 而且绘制方向始终为从起点绘制到终点

        //注意, 整数乘2在计算机中采用移位实现
        //Bresenham算法
        nTwoIx := 2 * nIx;
    nTwoIy := 2 * nIy;

        //与Windows相对应, 该算法也不包含最后一个点(x2, y2)
        dec(nInc);

        //开始增量计算
        for i := 0  to nInc -1 do
    begin
                nJudgeX := nJudgeX + nTwoIx;
                nJudgeY := nJudgeY + nTwoIy;

                //通过增量法计算的当前点是否属于直线上的点
                bPlot := FALSE;

                //检测 X 方向
                if(nJudgeX >= 0) then
                begin
                        bPlot := TRUE;
                        nJudgeX := nJudgeX - nTwoIy;

                        //将任意走向的直线统一起来
                        if(nDx > 0) then
            inc(x)
                        else if(nDx < 0) then
            dec(x)
                end;

                //检测 Y 方向
                if(nJudgeY >= 0) then
                begin
                        bPlot := TRUE;
                        nJudgeY := nJudgeY - nTwoIx;

                        //将任意走向的直线统一起来
                        if(nDy > 0) then
            inc(y)
                        else if(nDy < 0) then
            dec(y);
                end;
                //如果当前点在直线上, 则绘制当前点
                if(bPlot) then
//        SetPixel(hdc, x, y, clr);
        DrawMaskPen(Target, x- MaskPen8.Width div 2, y- MaskPen8.Height div 2, MaskPen8);
        end;//end for  
end;

//画32位色直线这样画啦
var
   Bitmap: TBitmap32;
   Mask: TBitmap;
begin
   Bitmap := TBitmap32.Create;
   Bitmap.Width := 500;
   Bitmap.Height := 500;
   Mask := TBitmap.Create;
   Mask.Width := 500;
   Mask.Height := 500;
   
   Image1.Picture.Bitmap.PixelFormat := pf8bit;
   LineMaskPen(Mask, 0, 0, 200, 200, Image1.Picture.Bitmap);  //Image1.Picture.Bitmap 这里保存的是附件里的8位自定义画笔

   Bitmap.Clear($FFFF0000);         //设为红色
   Bitmap.SetAlphaChannels(Mask);   //只有线条显示

   Bitmap.Free;
end;

[[i] Last edited by croslq on 2005-10-17 at 15:53 [/i]]

定义一个画笔类

定义画笔公用类，就像Windows里的CreatePen，
通过这个函数直接生成自定义大小的反走样8位Bitmap。

//生成掩码灰度画笔

TPenMaskBitmap = class(TBitmap)
public
    constructor Create; override;
    destructor Destroy; override;
    procedure CreateMaskBitmap(w, h: integer);
end;

constructor TPenMaskBitmap.Create;
begin
    inherited Create;
    PixelFormat := pf8bit;
end;

destructor TPenMaskBitmap.Destroy;
begin
    inherited Destroy;
end;

procedure TPenMaskBitmap.CreateMaskBitmap(w, h: integer);
begin
    //这里省了哈

end;

// 这个类在程序启动时就运行，在程序完了时就释放；
// 这个类直接生成32位色画笔，可以设定颜色，纹理，大小，透明度什么的。

TPenBitmap = class(TBitmap)  // class(TBitmap32)

public
    constructor Create; override;
    destructor Destroy; override;
    procedure CreateBitmap(w, h: integer);
end;

constructor TPenBitmap.Create;
begin
    inherited Create;
    PixelFormat := pf32bit;
end;

destructor TPenBitmap.Destroy;
begin
    inherited Destroy;
end;

procedure TPenMaskBitmap.CreateMaskBitmap(w, h: integer);
begin
    //这里省了哈

end;

反走样直线

unit Unit1;

interface

uses
  Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms,
  Dialogs, StdCtrls, ExtCtrls, Image32;

type
  TForm1 = class(TForm)
    Image1: TImage;
    Button1: TButton;
    procedure Button1Click(Sender: TObject);
  private
    { Private declarations }
  public
    { Public declarations }
  end;

var
  Form1: TForm1;

procedure AALine(x1,y1,x2,y2 : single; color: TColor32; Bitmap: TBitmap32);



implementation

{$R *.dfm}

procedure AALine(x1, y1, x2, y2: single; color: TColor32; Bitmap: TBitmap32);

    function CrossFadeColor(FromColor, ToColor: TColor32; Rate: Single) : TColor32;
    var
        R,G,B,A: BYTE;
    begin
//      r := Round(RedComponent(FromColor) * Rate + RedComponent(ToColor) * (1 - Rate));
//      g := Round(GreenComponent(FromColor) * Rate + GreenComponent(ToColor) * (1 - Rate));
//      b := Round(BlueComponent(FromColor) * Rate + BlueComponent(ToColor) * (1 - Rate));
//      a := Round(AlphaComponent(FromColor) * Rate + AlphaComponent(ToColor) * (1 - Rate));
        r := RedComponent(FromColor);
        g := GreenComponent(FromColor);
        b := BlueComponent(FromColor);
        a := Round(AlphaComponent(FromColor) * Rate);

      Result := RGBA(r,g,b,a); //RGB(b,g,r);
    end;

//    type
//      intarray = array[0..1] of integer;
//      pintarray = ^intarray;

procedure hpixel(x : single; y : integer);
var
  FadeRate : single;
begin
  FadeRate := x - trunc(x);
  with bitmap do
  begin
    if (x>=0) and (y>=0) and (height>y) and (width>x) then
          pColor32array(bitmap.ScanLine[y])[trunc(x)] := CrossFadeColor(Color,pColor32array(bitmap.ScanLine[y])[trunc(x)],1-FadeRate);

    if (trunc(x)+1>=0) and (y>=0) and (height>y) and (width>trunc(x)+1) then
          pColor32array(bitmap.ScanLine[y])[trunc(x)+1]:=CrossFadeColor(Color,pColor32array(bitmap.ScanLine[y])[trunc(x)+1],FadeRate);
  end;
end;

procedure vpixel(x : integer; y : single);
var
  FadeRate : single;
begin
  FadeRate:=y-trunc(y);
  with bitmap do
  begin
    if (x>=0) and (trunc(y)>=0) and (height>trunc(y)) and (width>x) then
                        pColor32array(bitmap.ScanLine[trunc(y)])[x]:=CrossFadeColor(Color,pColor32array(bitmap.ScanLine[trunc(y)])[x],1-FadeRate);

         if (x>=0) and (trunc(y)+1>=0) and (height>trunc(y)+1) and (width>x) then
         pColor32array(bitmap.ScanLine[trunc(y)+1])[x]:=CrossFadeColor(Color,pColor32array(bitmap.ScanLine[trunc(y)+1])[x],FadeRate);
         end;
end;

var i: integer;
    ly, lx, currentx, currenty, deltax, deltay, l, skipl: single;
begin
  if (x1 <> x2) or (y1 <> y2) then
  begin
//    bitmap.PixelFormat := pf32Bit;
//    Bitmap.Clear($00000000);

    currentx := x1;
    currenty := y1;
    lx := abs(x2 - x1);
    ly := abs(y2 - y1);

    if lx > ly then
    begin
      l := trunc(lx);
      deltay := (y2-y1)/l;
      if x1 > x2 then
      begin
        deltax := -1;
        skipl  := (currentx - trunc(currentx));
      end
      else
      begin
        deltax := 1;
        skipl  := 1- (currentx - trunc(currentx));
      end;
    end
    else
    begin
      l      :=  trunc(ly);
      deltax := (x2-x1)/l;
      if y1 > y2 then
      begin
        deltay := -1;
        skipl := (currenty-trunc(currenty));
      end
      else
      begin
        deltay := 1;
        skipl  := 1-(currenty-trunc(currenty));
      end;
    end;

    currentx := currentx+deltax*skipl;
    currenty := currenty+deltay*skipl;{}

    for i := 1 to trunc(l) do
    begin
      if lx > ly then
        vpixel(trunc(currentx), currenty)
      else
        hpixel(currentx, trunc(currenty));
        
      currentx := currentx + deltax;
      currenty := currenty + deltay;
    end;
end;
end;

procedure TForm1.Button1Click(Sender: TObject);
var
    bitmap: TBitmap32;
begin
    Bitmap := TBitmap32.Create;
    Bitmap.Width := 400;
    Bitmap.Height := 400;

    Image1.picture.Bitmap.Width := 400;
    Image1.picture.Bitmap.Height := 400;

    AALine(0,0, 300,100, $FFFF0000, Bitmap);
    Bitmap.DrawTo(0,0,Image1.Picture.Bitmap);


    Bitmap.Free;
end;

end.

影音风暴开源项目：guliverkli
里面Subtitles有实现字幕描边，阴影代码(我觉得性能还是很好的啦）



附件里有摘录的部分代码,是关于实现字幕的（C++）

字幕编辑器（Subresync）：字体输出效果