aafont.pas

平滑字体控件 版 本： 文件大小：388.445Kb 软件语言：简体中文 授权方式：免费版 相关链接：程序演示

  S := Round(Sd * HSLRange);
  L := Round(Ld * HSLRange);
end;

procedure StrectchDrawGraphic(ACanvas: TCanvas; ARect: TRect; AGraphic: TGraphic;
  BkColor: TColor);
var
  Bmp: TBitmap;
begin
  if AGraphic is TIcon then
  begin
    // TIcon 不支持缩放绘制，通过 TBitmap 中转
    Bmp := TBitmap.Create;
    try
      Bmp.Canvas.Brush.Color := BkColor;
      Bmp.Canvas.Brush.Style := bsSolid;
      Bmp.Width := AGraphic.Width;
      Bmp.Height := AGraphic.Height;
      //Bmp.Canvas.FillRect(Rect(0, 0, Bmp.Width, Bmp.Height));
      Bmp.Canvas.Draw(0, 0, AGraphic);
      ACanvas.StretchDraw(ARect, Bmp);
    finally
      Bmp.Free;
    end;
  end
  else
    ACanvas.StretchDraw(ARect, AGraphic);
end;

type
  TLogPal = record
    lpal: TLogPalette;
    dummy: array[0..255] of TPaletteEntry;
  end;

var
  HGrayPal: HPALETTE = 0;
  LogPal: TLogPal;

//初始化灰度位图
procedure InitGrayPal;
var
  i: Integer;
begin
  LogPal.lpal.palVersion := $300;
  LogPal.lpal.palNumEntries := 256;
  for i := 0 to 255 do
  begin
    LogPal.dummy[i].peRed := i;
    LogPal.dummy[i].peGreen := i;
    LogPal.dummy[i].peBlue := i;
    LogPal.dummy[i].peFlags := 0;
  end;
  HGrayPal := CreatePalette(LogPal.lpal);
end;

{ TAAMask }

//--------------------------------------------------------//
//平滑字体蒙板类                                          //
//--------------------------------------------------------//

//赋值
procedure TAAMask.Assign(Source: TPersistent);
begin
  if Source is TAAMask then
  begin
    FWidth := TAAMask(Source).Width;
    FHeight := TAAMask(Source).Height;
    Quality := TAAMask(Source).Quality;
    BytesLineGray := TAAMask(Source).BytesLineGray;
    BytesLineMask := TAAMask(Source).BytesLineMask;
    ReAllocMem(FpMaskBuff, FHeight * BytesLineMask);
    CopyMemory(FpMaskBuff, TAAMask(Source).FpMaskBuff, FHeight * BytesLineMask);
  end
  else
  begin
    inherited Assign(Source);
  end;
end;

//初始化
constructor TAAMask.Create(AOwner: TAAFont);
begin
  AAFont := AOwner;
  FpMaskBuff := nil;
  Quality := aqNormal;
end;

//释放
destructor TAAMask.Destroy;
begin
  FreeGrayBmp;
  FreeMem(FpMaskBuff);
  inherited;
end;

procedure TAAMask.InitGrayBmp;
begin
  if GrayBmp = nil then
  begin
    GrayBmp := TBitmap.Create;
    GrayBmp.PixelFormat := pf8bit;
    GrayBmp.Canvas.Brush.Style := bsSolid;
    GrayBmp.Canvas.Brush.Color := clBlack;
    GrayBmp.Palette := CopyPalette(HGrayPal);
  end;
end;

procedure TAAMask.FreeGrayBmp;
var
  P: HPALETTE;
begin
  if GrayBmp <> nil then
  begin
    P := GrayBmp.Palette;
    GrayBmp.Palette := 0;
    FreeAndNil(GrayBmp);
    DeleteObject(P);
  end;
end;

//绘制平滑字体蒙板
procedure TAAMask.DrawMaskEx(Text: string; Extend: TSize; Point: TPoint);
var
  i, j: Integer;
  pS1, pS2, pS3, pS4: PByteArray;
  pDes: PByteArray;
  x, y: Integer;
  P: TPoint;
  LogFont: TLogFont;
  Beta: Double;
  TextSize: TSize;
  R: TRect;
begin
  if (AAFont = nil) or (AAFont.Canvas = nil) then
    Exit;

  InitGrayBmp;
  FWidth := Extend.cx;                  //大小
  FHeight := Extend.cy;
  if GrayBmp.Width < Width * Scale then //放大
    GrayBmp.Width := Width * Scale;
  if GrayBmp.Height < Height * Scale then
    GrayBmp.Height := Height * Scale;

  GetObject(AAFont.Canvas.Font.Handle, SizeOf(TLogFont), @LogFont);
  with LogFont do
  begin
    lfHeight := lfHeight * Scale;
    lfWidth := lfWidth * Scale;
    Beta := lfEscapement * Pi / 1800;
  end;
  GrayBmp.Canvas.Font.Handle := CreateFontIndirect(LogFont);
  GrayBmp.Canvas.Font.Color := clWhite;
  FillRect(GrayBmp.Canvas.Handle, Bounds(0, 0, GrayBmp.Width, GrayBmp.Height), 0);
  x := Point.x * Scale;
  y := Point.y * Scale;
  if Beta <> 0 then      // 考虑字体旋转
  begin
    TextSize := TextExtentEx(Text, P);
    Inc(x, P.x * Scale);
    Inc(y, P.y * Scale);
  end;
  R := Bounds(0, 0, GrayBmp.Width, GrayBmp.Height);
  Windows.TextOut(GrayBmp.Canvas.Handle, x, y, PChar(Text), Length(Text));

  BytesLineGray := (GrayBmp.Width + 3) div 4 * 4; //扫描线宽度
  BytesLineMask := (Width + 3) div 4 * 4;
  ReAllocMem(FpMaskBuff, BytesLineMask * Height);

  pS1 := GrayBmp.ScanLine[0];           //源灰度图
  pS2 := PByteArray(Integer(pS1) - BytesLineGray);
  pS3 := PByteArray(Integer(pS2) - BytesLineGray);
  pS4 := PByteArray(Integer(pS3) - BytesLineGray);
  pDes := PByteArray(Integer(pMaskBuff) + (Height - 1) * BytesLineMask);
    //目标灰度为源矩形块的平均值
  case Quality of
    aqHigh:
      begin                             //高精度4X4采样
        for i := 0 to Height - 1 do
        begin
          for j := 0 to Width - 1 do
          begin
            x := j * 4;
            pDes^[j] :=
              (pS1^[x] + pS1^[x + 1] + pS1^[x + 2] + pS1^[x + 3] +
              pS2^[x] + pS2^[x + 1] + pS2^[x + 2] + pS2^[x + 3] +
              pS3^[x] + pS3^[x + 1] + pS3^[x + 2] + pS3^[x + 3] +
              pS4^[x] + pS4^[x + 1] + pS4^[x + 2] + pS4^[x + 3]) shr 4;
          end;
          pS1 := PByteArray(Integer(pS4) - BytesLineGray);
          pS2 := PByteArray(Integer(pS1) - BytesLineGray);
          pS3 := PByteArray(Integer(pS2) - BytesLineGray);
          pS4 := PByteArray(Integer(pS3) - BytesLineGray);
          pDes := PByteArray(Integer(pDes) - BytesLineMask);
        end;
      end;
    aqNormal:
      begin                             //普通精度3X3采样
        for i := 0 to Height - 1 do
        begin
          for j := 0 to Width - 1 do
          begin
            x := j * 3;
            pDes^[j] :=
              (pS1^[x] + pS1^[x + 1] + pS1^[x + 2] shr 1 +
              pS2^[x] + pS2^[x + 1] + pS2^[x + 2] +
              pS3^[x] shr 1 + pS3^[x + 1] + pS3^[x + 2]) shr 3;
          end;
          pS1 := PByteArray(Integer(pS3) - BytesLineGray);
          pS2 := PByteArray(Integer(pS1) - BytesLineGray);
          pS3 := PByteArray(Integer(pS2) - BytesLineGray);
          pDes := PByteArray(Integer(pDes) - BytesLineMask);
        end;
      end;
    aqLow:
      begin                             //低精度2X2采样
        for i := 0 to Height - 1 do
        begin
          for j := 0 to Width - 1 do
          begin
            x := j * 2;
            pDes^[j] :=
              (pS1^[x] + pS1^[x + 1] +
              pS2^[x] + pS2^[x + 1]) shr 2;
          end;
          pS1 := PByteArray(Integer(pS2) - BytesLineGray);
          pS2 := PByteArray(Integer(pS1) - BytesLineGray);
          pDes := PByteArray(Integer(pDes) - BytesLineMask);
        end;
      end;
    aqNone:
      begin                             //无平滑效果
        for i := 0 to Height - 1 do
        begin
          CopyMemory(pDes, pS1, Width);
          pS1 := PByteArray(Integer(pS1) - BytesLineGray);
          pDes := PByteArray(Integer(pDes) - BytesLineMask);
        end;
      end;
  end;
  FreeGrayBmp;
end;

//绘制平滑字体
procedure TAAMask.DrawMask(Text: string);
begin
  DrawMaskEx(Text, TextExtent(Text), Point(0, 0));
end;

//边缘检测
procedure TAAMask.Outline;
var
  x, y: Integer;
  s1, s2, s3, s4, Sum: Integer;
  pTempBuff: PByteArray;
  pDes: PByteArray;
  pUp, pMiddle, pDown: PByteArray;      //卷积用指针
begin
  GetMem(pTempBuff, BytesLineMask * Height); //临时缓冲区
  try
    CopyMemory(pTempBuff, pMaskBuff, BytesLineMask * Height);
    for y := 1 to Height - 2 do
    begin
      pUp := ScanLine(y - 1, pTempBuff);
      pMiddle := ScanLine(y, pTempBuff);
      pDown := ScanLine(y + 1, pTempBuff);
      pDes := ScanLine(y);
      for x := 1 to Width - 2 do
      begin
        s1 := Abs(pDown^[x] - pUp^[x]);
        s2 := Abs(pMiddle^[x + 1] - pMiddle^[x - 1]);
        s3 := Abs(pDown^[x - 1] - pUp^[x + 1]);
        s4 := Abs(pDown^[x + 1] - pUp^[x - 1]);
        Sum := (s1 + s2 + s3 + s4) shr 2;
        if Sum > 255 then
          pDes^[x] := 255
        else
          pDes^[x] := Sum;
      end;
    end;
  finally
    FreeMem(pTempBuff);
  end;
end;

//字体模糊
procedure TAAMask.Blur(Blur: TBlurStrength);
type
  TLine = array[0..4] of Integer;
const
  csLine: array[0..4] of TLine = (
    (0, 0, 0, 1, 2), (-1, -1, 0, 1, 2), (-2, -1, 0, 1, 2),
    (-2, -1, 0, 1, 1), (-2, -1, 0, 0, 0)); //边界处理常量
var
  pTempBuff: PByteArray;
  pSour: array[0..4] of PByteArray;
  pDes: PByteArray;
  xLine: TLine;
  yLine: TLine;
  x, y, i: Integer;
  Sum: Integer;
  ABlur: Byte;
begin
  GetMem(pTempBuff, BytesLineMask * Height); //临时缓冲区
  try
    CopyMemory(pTempBuff, pMaskBuff, BytesLineMask * Height);
    ABlur := Round(Blur * 255 / 100);
    for y := 0 to Height - 1 do         //边界处理
    begin
      if y = 0 then
        yLine := csLine[0]
      else if y = 1 then
        yLine := csLine[1]
      else if y = Height - 2 then
        yLine := csLine[3]
      else if y = Height - 1 then
        yLine := csLine[4]
      else
        yLine := csLine[2];
      for i := 0 to 4 do
        pSour[i] := ScanLine(yLine[i] + y, pTempBuff);
      pDes := ScanLine(y, pMaskBuff);
      for x := 0 to Width - 1 do        //边界处理
      begin
        if x = 0 then
          xLine := csLine[0]
        else if x = 1 then
          xLine := csLine[1]
        else if x = Width - 2 then
          xLine := csLine[3]
        else if x = Width - 1 then
          xLine := csLine[4]
        else
          xLine := csLine[2];
        Sum := 0;
        for i := 0 to 4 do              //5X5均值处理
          Inc(Sum, pSour[i]^[x + xLine[0]] + pSour[i]^[x + xLine[1]] +
            pSour[i]^[x + xLine[2]] + pSour[i]^[x + xLine[3]] +
            pSour[i]^[x + xLine[3]]);
        if ABlur = 255 then             //模糊度
          pDes^[x] := Round(Sum / 25)
        else
          pDes^[x] := (Round(Sum / 25) - pDes^[x]) * ABlur shr 8 + pDes^[x];
      end;
    end;
  finally
    FreeMem(pTempBuff);
  end;
end;

// 喷溅效果
procedure TAAMask.Spray(Amount: Integer);
var
  r, x, y, ax, ay: Integer;
  pDes: PByteArray;
begin
  pDes := ScanLine(0);
  for y := 0 to FHeight - 1 do
  begin
    for x := 0 to FWidth - 1 do
    begin
      r := Random(Amount + 1);
      ax := x + r - Random(r * 2);
      if ax < 0 then
        ax := 0
      else if ax > FWidth - 1 then
        ax := FWidth - 1;
      ay := y + r - Random(r * 2);
      if ay < 0 then
        ay := 0
      else if ay > FHeight - 1 then
        ay := FHeight - 1;
      pDes^[x] := PByteArray(ScanLine(ay))[ax];
    end;
    pDes := PByteArray(Integer(pDes) - BytesLineMask);
  end;
end;

//对蒙板图进行水平镜象处理
procedure TAAMask.HorzMirror;
var
  x, y: Integer;
  c: Byte;
  pLine: PByteArray;
begin
  for y := 0 to FHeight - 1 do
  begin
    pLine := ScanLine(y);
    for x := 0 to FWidth div 2 - 1 do
    begin
      c := pLine[x];
      pLine[x] := pLine[FWidth - 1 - x];
      pLine[FWidth - 1 - x] := c;