delphi 绘制精美的签名图片


Project1.dpr

program Project1;

uses
  Forms,
  Unit1 in 'Unit1.pas' {Form1},
  DrawPicMessage in 'DrawPicMessage.pas';

{$R *.res}

begin
  Application.Initialize;
  Application.Title := '绘制精美的签名图片';
  Application.CreateForm(TForm1, Form1);
  Application.Run;
end.

Unit1.pas

{*******************************************************}
{    }
{    绘制精美的签名图片的一种方法 Demo    }
{    }
{    作 者  :  LAHCS    }
{    }
{    Windows7 + Delphi7 编译    }
{    }
{    E-Mail:lahcs@qq.com  QQ:307643816    }
{    }
{*******************************************************}

unit Unit1;

interface

uses
  Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms,
  Dialogs, StdCtrls, ExtCtrls,Clipbrd,DrawPicMessage, XPMan;

type
  TForm1 = class(TForm)
   Panel1: TPanel;
   Image1: TImage;
   Edit1: TEdit;
   Label1: TLabel;
   Button1: TButton;
   Edit2: TEdit;
   Label2: TLabel;
   Label3: TLabel;
   Edit3: TEdit;
   Label4: TLabel;
   Edit4: TEdit;
   Memo1: TMemo;
   Label5: TLabel;
   Button2: TButton;
   Button3: TButton;
   OpenDialog1: TOpenDialog;
   SaveDialog1: TSaveDialog;
   Edit5: TEdit;
   Label6: TLabel;
   CheckBox1: TCheckBox;
   FontDialog1: TFontDialog;
   Button4: TButton;
   Edit6: TEdit;
   Button5: TButton;
   XPManifest1: TXPManifest;
   procedure Button1Click(Sender: TObject);
   procedure Button2Click(Sender: TObject);
   procedure FormCreate(Sender: TObject);
   procedure Button4Click(Sender: TObject);
   procedure Button3Click(Sender: TObject);
   procedure Button5Click(Sender: TObject);
   procedure Image1MouseDown(Sender: TObject; Button: TMouseButton;
   Shift: TShiftState; X, Y: Integer);
   procedure Image1MouseMove(Sender: TObject; Shift: TShiftState; X,
   Y: Integer);
   procedure Image1MouseUp(Sender: TObject; Button: TMouseButton;
   Shift: TShiftState; X, Y: Integer);
  private
   { Private declarations }
  public
   { Public declarations }
  end;

var
  Form1: TForm1;
  CanMove : Boolean;
  OldX,OldY: Integer;
 
implementation

{$R *.dfm}

procedure TForm1.Image1MouseDown(Sender: TObject; Button: TMouseButton;
  Shift: TShiftState; X, Y: Integer);
begin
  CanMove:=True;
  OldX:=X;
  OldY:=y;
end;

procedure TForm1.Image1MouseMove(Sender: TObject; Shift: TShiftState; X,
  Y: Integer);
begin
  if CanMove then
  begin
   Image1.Left := image1.Left+(X-OldX);
   Image1.Top := Image1.Top+(Y-OldY);
  end;
end;

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

procedure TForm1.Button1Click(Sender: TObject);
begin
  OpenDialog1.InitialDir:=ExtractFilePath(ParamStr(0))+'\';
  if OpenDialog1.Execute then
   Edit1.Text:=OpenDialog1.FileName;
end;

procedure TForm1.Button2Click(Sender: TObject);
var
  P:TPicMSG;
begin
  P.FacePath:=Edit1.Text;
  P.Height:=StrToInt(Edit5.Text);
  P.Width:=StrToInt(Edit2.Text);
  P.Nick:=Edit3.Text;
  P.Sign:=Edit4.Text;
  P.MSG:=Memo1.Text;
  P.Font:=Edit6.Text;
  Image1.Picture.Bitmap.Assign(DrawMessage(P,CheckBox1.Checked));
end;

procedure TForm1.FormCreate(Sender: TObject);
begin
  Edit1.Text:=ExtractFilePath(ParamStr(0))+'\Face.bmp';
  Edit2.Text:='400';
  Edit5.Text:='300';
  Edit3.Text:='LAHCS';
  Edit4.Text:='人生总是起起伏伏,曲曲折折,但是未来终究是好的!';
  Edit6.Text:='宋体';
  Memo1.Lines.Add('欢迎大家访问我的博客');
  Memo1.Lines.Add('http://lahcs.cnblogs.com/');
  Button2.Click;
end;

procedure TForm1.Button4Click(Sender: TObject);
begin
  if FontDialog1.Execute then
   Edit6.Text:=FontDialog1.Font.Name;
end;

procedure TForm1.Button3Click(Sender: TObject);
begin
  if SaveDialog1.Execute then
   Image1.Picture.Bitmap.SaveToFile(SaveDialog1.FileName+'.bmp');
end;

procedure TForm1.Button5Click(Sender: TObject);
var
  Format: Word;
  Data: Cardinal;
  APalette: HPALETTE;
begin
  Image1.Picture.Bitmap.SaveToClipboardFormat(Format, Data, APalette);
  Clipboard.SetAsHandle(Format, Data);
end;

end.

DrawPicMessage.pas

{*******************************************************}
{    }
{    绘制精美的签名档的一种方法    }
{    }
{    作 者  :  LAHCS    }
{    }
{    Windows7 + Delphi7 编译    }
{    }
{    E-Mail:lahcs@qq.com  QQ:307643816    }
{    }
{*******************************************************}
unit DrawPicMessage;

interface

uses
  Windows, SysUtils, Classes, Graphics;

type
  TPicMSG = record
  FacePath:string;
  Height:Integer;
  Width:Integer;
  Nick:string;
  Sign:string;
  MSG:string;
  Font:string;
end;

  function DrawMessage(PicMsg:TPicMSG;AutoMode:Boolean):TBitmap;

implementation

procedure DrawFace(Canvas:TCanvas;X,Y,FaceRect:Integer;PicPath:string);
var
  BImage:TBitmap;
  BrushBmp,BMP:TBitmap;
  FRect:TRect;
begin
  {Load Image}
  BImage:=TBitmap.Create;
  BImage.LoadFromFile(PicPath);

  {Create Rect}
  FRect:=Rect(0,0,FaceRect,FaceRect);

  {Create Brush}
  BrushBmp:=TBitmap.Create;
  BrushBmp.Width:=FaceRect;
  BrushBmp.Height:=FaceRect;
  BrushBmp.Canvas.StretchDraw(FRect,BImage);

  {Create Texture}
  BMP:=TBitmap.Create;
  BMP.Width:=FaceRect;
  BMP.Height:=FaceRect;
  BMP.Canvas.Brush.Color:=RGB(247,247,247);
  BMP.Canvas.FillRect(FRect);
  BMP.Canvas.Pen.Width:=1;
  BMP.Canvas.Pen.Color:=RGB(0,153,255);//RGB(193,225,250);
  BMP.Canvas.Brush.Bitmap:=BrushBmp;
  RoundRect(BMP.Canvas.Handle,FRect.Left,FRect.Top,FRect.Right,FRect.Bottom,5,5);

  {Draw To Item}
  Canvas.Draw(X,Y,BMP);

  {Free}
  FreeAndNil(BMP);
  FreeAndNil(BrushBmp);
  FreeAndNil(BImage);
end;

procedure DrawBackAndMSG(Canvas:TCanvas;RT:TRect;Nick,Sign,MSG,Font:string);
var
  BrushBmp,Bmp:TBitmap;
  R:TRect;
begin
  {Draw Upper}
  BrushBmp:=TBitmap.Create;
  with BrushBmp do
  begin
   Width:=RT.Right-Rt.Left;
   Height:=RT.Bottom-RT.Top;
   Canvas.Brush.Color:=RGB(247,247,247);
   Canvas.FillRect(Rect(0,0,Width,57));
   Canvas.Brush.Style:=bsClear;
   Canvas.Font.Name:=Font;
   Canvas.Font.Size:=11;
   Canvas.Font.Color:=clBlack;
   SetRect(R,57,5,Width,Height);
   DrawText(Canvas.Handle,PChar(Nick),Length(Nick),R,DT_LEFT or DT_WORD_ELLIPSIS);
   Canvas.Font.Color:=clGrayText;
   Canvas.Font.Size:=9;
   SetRect(R,57,24,Width,Height);
   DrawText(Canvas.Handle,PChar(Sign),Length(Sign),R,DT_LEFT or DT_WORD_ELLIPSIS);
   SetRect(R,57,40,Width,Height);
   DrawText(Canvas.Handle,PChar(DateTimeToStr(Now)),Length(DateTimeToStr(Now)),R,DT_LEFT or DT_WORD_ELLIPSIS);
  end;

  {Draw Lower}
  BMP:=TBitmap.Create;
  with Bmp do
  begin
   Width:=RT.Right-Rt.Left;
   Height:=RT.Bottom-RT.Top;
   Canvas.Brush.Color:=clBtnFace;
   Canvas.FillRect(Canvas.ClipRect);
   Canvas.Pen.Color:=RGB(252,233,160);
   Canvas.Brush.Bitmap:=BrushBmp;
   RoundRect(Canvas.Handle,0,0,Width,Height,8,8);

   Canvas.Brush.Style:=bsClear;
   Canvas.Font.Name:=Font;
   Canvas.Font.Size:=10;
   Canvas.Font.Color:=clBlack;
   SetRect(R,10,57+5,Width-10,Height);
   DrawText(Canvas.Handle,PChar(MSG),Length(MSG),R,DT_LEFT or DT_WORDBREAK);
  end;

  Canvas.Draw(RT.Left,RT.Top,Bmp);
  FreeAndNil(Bmp);
  FreeAndNil(BrushBmp);
end;

function CalcWidth(Canvas:TCanvas;RT:TRect;Nick,Sign,Font:string):Integer;
begin
  {Calc Pic Width in Auto Mode}
  RT.Left:=57;
  RT.Top:=5;
  RT.Right:=0;
  Canvas.Font.Name:=Font;
  Canvas.Font.Size:=11;
  DrawText(Canvas.Handle,PChar(Nick),Length(Nick),RT,DT_CALCRECT or DT_LEFT);
  Result:=RT.Right;
  Canvas.Font.Size:=9;
  RT.Top:=24;
  RT.Right:=0;
  DrawText(Canvas.Handle,PChar(Sign),Length(Sign),RT,DT_CALCRECT or DT_LEFT);
  if Result<=RT.Right then
   Result:=RT.Right;
end;

function CalcHeight(Canvas:TCanvas;RT:TRect;MSG,Font:string):Integer;
begin
  {Calc Pic Height in Auto Mode}
  RT.Left:=10;
  RT.Top:=57+5;
  Canvas.Font.Name:=Font;
  Canvas.Font.Size:=10;
  DrawText(Canvas.Handle,PChar(MSG),Length(MSG),RT,DT_CALCRECT or DT_LEFT or DT_WORDBREAK);
  Result:=RT.Bottom;
end;

function DrawMessage(PicMsg:TPicMSG;AutoMode:Boolean):TBitmap;
begin
  Result:=TBitmap.Create;

  if AutoMode then
   begin
   Result.Height:=CalcHeight(Result.Canvas,Rect(0,0,PicMsg.Width,0),PicMsg.MSG,PicMsg.Font);
   Result.Width:=CalcWidth(Result.Canvas,Rect(0,0,PicMsg.Width,0),PicMsg.Nick,PicMsg.Sign,PicMsg.Font);
   end
  else
   begin
   Result.Height:=PicMsg.Height;
   Result.Width:=PicMsg.Width;
   end; 

  DrawBackAndMSG(Result.Canvas,Rect(0,0,Result.Width,Result.Height),PicMsg.Nick,PicMsg.Sign,PicMsg.MSG,PicMsg.Font);
  DrawFace(Result.Canvas,5,5,47,PicMsg.FacePath);
end;

end.

完整源代码:http://pan.baidu.com/s/1l91Ya


联系电话:
020-00000000
联系电话:
020-00000000
联系电话:
020-12345678