delphi 绘制精美的签名图片

网络 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

相关阅读 >>

Delphi 10.3 断点调试相关快捷键

Delphi delete 删除字符串中指定的字符串

Delphi获取操作系统已运行的所有窗口程序

Delphi图像处理 -- 图像卷积

橙子作品 bds/cds 下的 web deploy 工具

Delphi mscomm控件串口收发程序

Delphi中实现全角转半角

Delphi中exit,abort,break,continue,halt,runerro 的区别

Delphi inc函数和dec函数的用法

Delphi 复制文件到全盘

更多相关阅读请进入《Delphi》频道 >>



标签：

打赏

取消

感谢您的支持，我会继续努力的!

扫码支持
扫码打赏，您说多少就多少

打开支付宝扫一扫，即可进行扫码打赏哦

分享从这里开始，精彩与您同在

相关推荐

评论

管理员已关闭评论功能...