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="%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表情框Win32ReleaseFace.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
的事件
的方法