类似PhotoSHop那样的流动选取框，同时根据字体获取字体的边框Path

来自CSDN开发高手，整理By Zswang

unit Unit1 ;

interface

uses

  Windows , Messages , SysUtils , Variants , Classes , Graphics , Controls , Forms ,

  Dialogs , ExtCtrls , StdCtrls ;

type

  TForm1 = class ( TForm )

    Timer1 : TTimer ;

    Button1 : TButton ;

    procedure Timer1Timer ( Sender : TObject );

    procedure Button1Click ( Sender : TObject );

    procedure FormCreate ( Sender : TObject );

  private

    { private declarations }

    FPathPoints : array of TPoint ;

    FPathTypes : array of Byte ;

    FNumber : Integer ;

    FCounter : Byte ;

  public

    { public declarations }

  end ;

var

  Form1 : TForm1 ;

implementation

{$R *.dfm}

procedure MovingDots ( X , Y : Integer ; mForm : TForm1 ); stdcall ;

begin

  if mForm . FCounter = 15 then mForm . FCounter := 0 ;

  if mForm . FCounter < 5 then

    mForm . Canvas . Pixels [ X , Y ] := clWhite

  else if mForm . FCounter < 12 then

    mForm . Canvas . Pixels [ X , Y ] := clRed

  else

    mForm . Canvas . Pixels [ X , Y ] := clBlue ;

  Inc ( mForm . FCounter );

end ;

procedure TForm1 . Timer1Timer ( Sender : TObject );

var

  J , K : Integer ;

begin

  for J := 0 to Pred ( FNumber ) do

  begin

    if FPathTypes [ J ] = PT_CLOSEFIGURE or PT_LINETO then

    begin

      for K := J downto 0 do

        if FPathTypes [ K ] = PT_MOVETO then

        begin

          LineDDA ( FPathPoints [ J ]. X , FPathPoints [ J ]. Y ,

            FPathPoints [ K ]. X , FPathPoints [ K ]. Y , @ MovingDots , Longint ( self ));

          Break ;

        end ;

      Continue ;

    end ;

    LineDDA ( FPathPoints [ J ]. X , FPathPoints [ J ]. Y ,

      FPathPoints [ J + 1 ]. X , FPathPoints [ J + 1 ]. Y , @ MovingDots , Longint ( self ));

  end ;

end ;

procedure TForm1 . Button1Click ( Sender : TObject );

begin

  Canvas . Font . Name := ' 隶书 ' ;

  Canvas . Font . Style := [ fsItalic , fsBold ];

  Canvas . Font . Size := 120 ;

  BeginPath ( Canvas . Handle );

  SetBkMode ( Canvas . Handle , TRANSPARENT );

  Canvas . TextOut ( 120 , 20 , ' 中文，测试！Test! ' );

  Canvas . Rectangle ( Rect ( 10 , 10 , 100 , 100 ));

  EndPath ( Canvas . Handle );

  if not FlattenPath ( Canvas . Handle ) then Exit ;

  FNumber := GetPath ( Canvas . Handle , Pointer ( nil ^), Pointer ( nil ^), 0 );

  SetLength ( FPathPoints , FNumber );

  SetLength ( FPathTypes , FNumber );

  FNumber := GetPath ( Canvas . Handle , FPathPoints [ 0 ], FPathTypes [ 0 ], FNumber );

  Timer1 . Enabled := True ;

end ;

procedure TForm1 . FormCreate ( Sender : TObject );

begin

  Timer1 . Enabled := False ;

  Timer1 . Interval := 100 ;

end ;

end .