提供一段代码给你：
unit main;
interface
uses Windows, Messages, ActiveX, SysUtils, CommDlg, myshdocvw;
function dlgproc(const hDlg, uMsg, wParam, lParam: Cardinal): BOOL;stdcall;
implementation
uses trmhSvr, async, trmnsh, commvar;
procedure trm1About;
resourcestring
resAbout = ' ╭⌒╮┅~ ¤ ╭⌒╮ '#10#13+
' ╭⌒╭⌒╮╭⌒╮～╭⌒╮ ︶ ,︶︶ '#10#13+
' ,︶︶︶︶,''︶~~ ,''~︶︶ ,'' '#10#13+
' ╔ ╱◥███◣═╬╬╬╬╬╬╬╬╬╬╗'#10#13+
' ╬ ︱田︱田 田 ︱ ╬'#10#13+
' ╬ Author: TrustMe ╬'#10#13+
' ╬ ╭○╮● Email: yu3350@sina.com ╬'#10#13+
' ╬ /■//■/ QQ: 22627167 ╬'#10#13+
' ╬ <| || TrustMe制作,必属精品! ╬'#10#13+
' ╬ ╬'#10#13+
' ╚╬╬╬╬╬╬╬╬╬╬╗ ╔╬╬╬╬╬╝'#0;
begin
MessageBox(GetActiveWindow, PChar(resAbout), '关于...', MB_OK or MB_ICONINFORMATION);
end;
function createComObj(const clsid: TGuid): IUnknown;
var
cf: IClassFactory;
begin
CoGetClassObject(clsid, CLSCTX_INPROC_SERVER or CLSCTX_LOCAL_SERVER, nil, IClassFactory, cf);
if cf <> nil then try
cf.CreateInstance(nil, iUnknown, result);
finally
cf:= nil;
end;
end;
type
TempObj = object
procedure onProtocolAccept(Sender: TObject;const URL: String; var Accept: Boolean);
procedure onProtocolContent(Sender: TObject;const URL: String;const Stream: IStream);
end;
procedure TempObj.onProtocolAccept(Sender: TObject;const URL: String; var Accept: Boolean);
begin
Accept:= Pos(gtrmh.ProtocolName, LowerCase(url)) = 1;
end;
procedure TempObj.onProtocolContent(Sender: TObject;const URL: String;const Stream: IStream);
var
svr: TSimpleHttpSvrObj;
s: string;
begin
svr:= queueSimpleHttpSvr(Stream);
try
s:= 'GET ' + Copy(url, Length(gtrmh.ProtocolName) + 2, Length(url));
svr.processRequest(@s[1], Length(s));
finally
freeSimpleHttpSvr(svr);
end;
end;
var
web: IWebBrowser2;
t: Tempobj;
procedure goHome(const hdlg: Cardinal);
var
url: OleVariant;
ev: OleVariant;
begin
url:= gtrmh.ProtocolName + ':/';
web.Navigate2(url, ev, ev, ev, ev);
// 标题
SetWindowText(hdlg, @gTitle[1]);
end;
procedure openTrm(const hdlg: Cardinal);
var
fn: tagOFNA;
bu: array[0..9999]of Char;
begin
ZeroMemory(@fn, SizeOf(fn));
ZeroMemory(@bu[0], SizeOf(bu));
fn.lStructSize:= SizeOf(fn);
fn.hWndOwner:= hdlg;
fn.hInstance:= hInstance;
fn.lpstrFilter:= 'TRM文件'#0'*.trm;*.trm1;*.archive'#0'可执行文件(EXE)'#0'*.exe'#0#0;
fn.lpstrFile:= @bu[0];
fn.nMaxFile:= SizeOf(bu);
if GetOpenFileName(fn) and openTrmFile(@bu[0]) then
goHome(hdlg);
end;
procedure saveAs(const hdlg: Cardinal);
begin
if saveTrmFile(gtrm, nil) then
MessageBox(hdlg, '保存成功！', '提示', MB_OK or MB_ICONINFORMATION);
end;
function dlgproc(const hDlg, uMsg, wParam, lParam: Cardinal): BOOL;
var
ii: IUnknown;
hm: HMENU;
begin
case uMsg of
WM_CLOSE
ostQuitMessage(0);
WM_INITDIALOG:begin
CoInitialize(nil);
// 菜单
hm:= LoadMenu(hInstance, 'MAINMENU');
SetMenu(hdlg, hm);
SendMessage(hdlg, WM_SETICON, ICON_SMALL, LoadIcon(hInstance, 'MAINICON'));
web:= createComObj(CLASS_WebBrowser) as IWebBrowser2;
AtlAxAttachControl(web, hDlg, ii);
gContentTypeLock:= criticalSectionNew;
gQueueLock:= criticalSectionNew;
gtrmh.OnAccept:= t.onProtocolAccept;
gtrmh.OnGetContent:= t.onProtocolContent;
gtrmh.ProtocolName:= 'trmh';
gtrmh.Enabled:= True;
goHome(hdlg);
end;
WM_DESTROY:begin
gContentTypeLock.Free;
gContentTypeLock:= nil;
gQueueLock.Free;
gQueueLock:= nil;
end;
WM_COMMAND:case wParam of
// 文件
101
penTrm(hdlg);
102:saveAs(hdlg);
103:SendMessage(hdlg, WM_CLOSE, 0, 0);
// 导航
201:try web.GoBack;except end;
202:try web.GoForward;except end;
203:web.Stop;
204:web.Refresh;
205:goHome(hdlg);
// 帮助
301:trm1About;
end;
end;
result:= False;
end;
end.
http://free5.ys168.com/?trustme
