Delphi QQ表情的实现-木庄网络博客

本文整理自网络，侵删。
 Delphi QQ表情的实现

QQ表情描述
蓝框
提示信息
鼠标在这个表情上面 这个表情才动
可以增加表情
表情打包
单击这个表情插入表情 关闭本窗体

 
主要使用Webbrowsr来实现的
 
--------------------------------------------------------------------------------

//调用过程
unit Unit1;

interface

uses
  Winapi.Windows, Winapi.Messages, System.SysUtils, System.Variants, System.Classes, Vcl.Graphics,
  Vcl.Controls, Vcl.Forms, Vcl.Dialogs, Vcl.OleCtrls, SHDocVw, Vcl.StdCtrls,
  Vcl.Menus, Vcl.AppEvnts;

type
  TForm1 = class(TForm)
    Button1: TButton;
    WebBrowser1: TWebBrowser;
    procedure Button1Click(Sender: TObject);
    procedure FormCreate(Sender: TObject);
    procedure WebBrowser1ProgressChange(ASender: TObject; Progress,
      ProgressMax: Integer);
  private
    { Private declarations }
  public
    { Public declarations }
  end;

var
  Form1: TForm1;

implementation

{$R *.dfm}
uses 
    MSHTML,ActiveX, Unit2;


procedure  InsertImage(fileName:string);
var
  s:string;
begin
  s:=Format('<IMG src="http://ypimg.muzhuangnet.com/Collect/delphi%s">',[fileName]);
( (Form1.WebBrowser1.Document as IHTMLDocument2).selection.createRange as IHtmlTxtRange).pasteHTML(s);

end;


procedure TForm1.Button1Click(Sender: TObject);
var
  frm2:TForm2;
begin
  frm2:=TForm2.Create(nil); 
  frm2.Left:=Form1.Left+Button1.Left+2;
  frm2.Top:=Form1.Top-Button1.Top+Button1.Height;
  frm2.ShowModal;//show method
  Caption:=frm2.SelGifPath;

  //插入图片
  if FileExists(frm2.SelGifPath) then
     InsertImage(frm2.SelGifPath);
     (WebBrowser1.Document as IHTMLDocument2).parentWindow.focus; 
end;

procedure TForm1.FormCreate(Sender: TObject);
begin
   WebBrowser1.Navigate('about:blank');
   if WebBrowser1.Document<>nil then  
      WebBrowser1.OleObject.document.designMode:='on';

end;

procedure TForm1.WebBrowser1ProgressChange(ASender: TObject; Progress,
  ProgressMax: Integer);
begin
    (WebBrowser1.Document as IHTMLDocument2).parentWindow.focus; 
end;

end.

--------------------------------------------------------------------------------
//实现过程

unit Unit2;

interface

uses
  Winapi.Windows, Winapi.Messages, System.SysUtils, System.Variants, System.Classes, Vcl.Graphics,
  Vcl.Controls, Vcl.Forms, Vcl.Dialogs, Vcl.AppEvnts, Vcl.OleCtrls, SHDocVw,
  Vcl.StdCtrls;

type
  TForm2 = class(TForm)
    ApplicationEvents1: TApplicationEvents;
    WebBrowser1: TWebBrowser;
    procedure FormCreate(Sender: TObject);
    procedure ApplicationEvents1Message(var Msg: tagMSG; var Handled: Boolean);
    procedure WebBrowser1StatusTextChange(ASender: TObject;
      const Text: WideString);
    procedure WebBrowser1DocumentComplete(ASender: TObject;
      const pDisp: IDispatch; const URL: OleVariant);
  private
    { Private declarations }
  public
    { Public declarations }
    SelGifPath:WideString;
    Execute:Boolean;
  end;

var
  Form2: TForm2;
  GifPath:WideString;
implementation
uses ActiveX;
{$R *.dfm}
{
1  WebBrowser1.Navigate一个html网页
2  单击 获得这个GIF的文件路径
       1 获得这个GIF的文件路径
       2 单击这个GIF关闭窗体
其他
  单击这个Gif连接时 禁止新在本Webbrowser中打开

}



procedure TForm2.ApplicationEvents1Message(var Msg: tagMSG;
  var Handled: Boolean);
var
  fileName:string;
begin
  Handled := IsDialogMessage(Webbrowser1.Handle, msg) = True;
  if handled then
  begin              //WM_LBUTTONDOWN
   if (Msg.Message = WM_LBUTTONDOWN)  then
    begin
        fileName:=StringReplace(GifPath,'file:///','',[rfReplaceAll]) ;
        if FileExists(fileName) then
        begin
           SelGifPath:=fileName;
           Execute:=True;
        end;
         Close;
    end
   else
   handled := false;//Disable Webbrowser Default PopMenu
  end;
end;

procedure TForm2.FormCreate(Sender: TObject);
var
  path:string;
begin
    BorderStyle:=bsNone;
    Width:=460;
    Height:=240;
//    TransparentColor:=True;
//    TransparentColorValue:=clPurple;
    WebBrowser1.Left:=-2;
    WebBrowser1.Top:=0;

    //WebBrowser1.Align:=alClient;

     //C:\QQ表情框\Win32\Release\Face.html;
     path:=ExtractFilePath(Application.ExeName)+'face.html';
     if not FileExists(path) then Exit;

     WebBrowser1.Navigate(path);
end;


procedure TForm2.WebBrowser1DocumentComplete(ASender: TObject;
  const pDisp: IDispatch; const URL: OleVariant);
begin
     WebBrowser1.OleObject.Document.Body.style.border := 'none';
     WebBrowser1.OleObject.Document.Body.scroll := 'no';
end;

procedure TForm2.WebBrowser1StatusTextChange(ASender: TObject;
  const Text: WideString);
begin
    GifPath:=Text; //URL 的路径 如 file:///C:/1.gif
   // Caption:=Text; //Test

end;

end.


的属性


1获得单击的GIF路径
2GIF打包
3
的事件


的方法
Delphi QQ表情的实现

相关推荐

评论
