Delphi QQ表情的实现
![](https://i-blog.csdnimg.cn/blog_migrate/23154210a3bf8f4c0cda962118d308c9.jpeg)
QQ表情描述
- 蓝框
- 提示信息
- 鼠标在这个表情上面 这个表情才动
- 可以增加表情
- 表情打包
- 单击这个表情插入表情 关闭本窗体
![](https://i-blog.csdnimg.cn/blog_migrate/5e3cc90a47df2f5a07d1efc0138b2aa2.jpeg)
主要使用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
的事件
的方法
附件列表