Delphi QQ表情的实现

Delphi QQ表情的实现

QQ表情描述

1. 蓝框
2. 提示信息
3. 鼠标在这个表情上面 这个表情才动
4. 可以增加表情
5. 表情打包
6. 单击这个表情插入表情 关闭本窗体

 

主要使用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="%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
的事件


的方法

通过 为知笔记 发布

附件列表

 

转载于:https://www.cnblogs.com/xe2011/p/3149643.html