unit Unit1;
interface
uses
Windows, Messages, SysUtils, {Variants,} Classes, Graphics, Controls, Forms,
Dialogs, {SHDocVW_TLB, MSHTML_TLB,} ActiveX, OleCtrls, SHDocVw, StdCtrls,
ComCtrls, ImgList, Buttons;
type
TForm1 = class(TForm)
SourceView: TMemo;
Button2: TButton;
FolderTree: TTreeView;
ImageList1: TImageList;
BtnFolderDlg: TSpeedButton;
Edit1: TEdit;
Button4: TButton;
//procedure Button1Click(Sender: TObject);
procedure Button2Click(Sender: TObject);
procedure FormCreate(Sender: TObject);
procedure BtnFolderDlgClick(Sender: TObject);
procedure FormClose(Sender: TObject; var Action: TCloseAction);
procedure FolderTreeClick(Sender: TObject);
procedure Button4Click(Sender: TObject);
private
{ Private declarations }
HtmTitle:string;
f:textfile;
RootNode:TTreeNode;
PersistFile: IPersistFile;
public
{ Public declarations }
procedure GetSource;
end;
var
Form1: TForm1;
MyDir,FileName,SaveToDir:string;
const
RSPSIMPLESERVICE = 1;
RSPUNREGISTERSERVICE = 0;
implementation
uses MSHTML,filectrl;
{$R *.dfm}
type
TObjectFromLResult = function(LRESULT: lResult; const IID: TIID; WPARAM: wParam; out pObject): HRESULT; stdcall;
//This function detects the Window
function GetIEFromHWND(WHandle: HWND; var IE: IWebbrowser2): HRESULT;
var
hInst: HWND;
lRes: Cardinal;
MSG: Integer;
pDoc: IHTMLDocument2;
ObjectFromLresult: TObjectFromLresult;
begin
hInst := LoadLibrary('Oleacc.dll');
@ObjectFromLresult := GetProcAddress(hInst, 'ObjectFromLresult');
if @ObjectFromLresult <> nil then begin
try
MSG := RegisterWindowMessage('WM_HTML_GETOBJECT');
SendMessageTimeOut(WHandle, MSG, 0, 0, SMTO_ABORTIFHUNG, 1000, lRes);
Result := ObjectFromLresult(lRes, IHTMLDocument2, 0, pDoc);
if Result = S_OK then
(pDoc.parentWindow as IServiceprovider).QueryService(IWebbrowserApp, IWebbrowser2, IE);
finally
FreeLibrary(hInst);
end;
end;
end;
procedure TForm1.GetSource;
var
//All: IHtmlElementCollection;
//HtmlElement: IHtmlElement;
//I: Integer;
Document: IHtmlDocument2;
IE: IWebBrowser2;
Wnd: HWND;
WndChild: HWND;
begin
Wnd := FindWindow('IEFrame', nil); //将IEFrame改成腾讯浏览器的类名
if Wnd = 0 then
begin
MessageDlg ('No Running instance of Internet Explorer!',mtError, [mbOK], 0);
end;
// walk Shell DocObject View->Internet Explorer_Server
WndChild := FindWindowEX(Wnd, 0, 'Shell DocObject View', nil);
if WndChild <> 0 then begin
WndChild := FindWindowEX(WndChild, 0, 'Internet Explorer_Server', nil);
if WndChild <> 0 then
begin
GetIEFromHWnd(WndChild, IE); //Get Iwebbrowser2 from Handle
Document := IE.Document as IHtmlDocument2;
if (assigned(Document)) then
begin
{All := Document.All;
for I := 0 to All.Length -1 do
begin
HtmlElement := All.item(i,0) as IhtmlElement;
if (assigned(Document)) then
SourceView.Lines.Add (HTmlElement.innerHTML);
end; }
HtmTitle:=Document.title;
Caption:=HtmTitle;
SourceView.Lines.clear;
{SourceView.Lines.Add('<html>');
SourceView.Lines.Add('<head>');
SourceView.Lines.Add('<title>'+HtmTitle+'</title>');
SourceView.Lines.Add('</head>'); }
SourceView.Lines.Add(IHtmlDocument2(Document).Body.innerHTML);
{SourceView.Lines.Add('</html>');}
PersistFile := IHtmlDocument2(Document) as IPersistFile;
end;
end;
end;
end;
procedure renf(var s1:string;s2:string);
begin
if pos(s2,s1)<>0 then
repeat
delete(s1,pos(s2,s1),1)
until pos(s2,s1)=0;
end;
procedure TForm1.Button2Click(Sender: TObject);
var tems:string;
begin
GetSource;
if FolderTree.Selected=nil then
begin
ShowMessage('请选择一个文件夹。');
exit;
end;
if trim(HtmTitle)='' then
begin
ShowMessage('请输入文件名');
exit;
end;
tems:= HtmTitle;
renf(tems,'/');
renf(tems,'/');
renf(tems,':');
renf(tems,'*');
renf(tems,'?');
renf(tems,'"');
renf(tems,'<');
renf(tems,'>');
renf(tems,'|');
SaveToDir:=FolderTree.Selected.Text;
Edit1.Text := SaveToDir+'/'+tems+'.htm';
SourceView.Lines.SaveToFile(Edit1.Text);
end;
procedure TForm1.FormCreate(Sender: TObject);
var s:string;
Node:TTreeNode;
begin
SetWindowPos(Handle, HWND_TOPMOST, 0, 0, 0, 0,
SWP_NOSIZE or SWP_NOMOVE or SWP_NOACTIVATE);
MyDir:=ExtractFilePath(ParamStr(0));
Caption:=MyDir;
SaveToDir:='';
RootNode:=FolderTree.Items[0];
if fileexists(MyDir+'dirlist.cfg') then
begin
assignfile(f,MyDir+'dirlist.cfg');
reset(f);
while not eof(f) do
begin
readln(f,s);
if trim(s)<>'' then
begin
Node:=FolderTree.Items.AddChild(RootNode,s);
Node.ImageIndex := 1;
Node.SelectedIndex := 1;
end;
end;
closefile(f);
end;
RootNode.Expanded := true;
end;
procedure TForm1.BtnFolderDlgClick(Sender: TObject);
var Sc:string;
Node:TTreeNode;
begin
Sc := '';
if SelectDirectory('Select Directory', '', Sc) then
begin
Node:=FolderTree.Items.AddChild(RootNode,sc);
Node.ImageIndex := 1;
Node.SelectedIndex := 1;
end;
RootNode.Expanded := true;
end;
procedure TForm1.FormClose(Sender: TObject; var Action: TCloseAction);
var Node:TTreeNode;
i:integer;
begin
if RootNode.HasChildren then
begin
assignfile(f,MyDir+'dirlist.cfg');
rewrite(f);
for i:=1 to RootNode.count do
begin
Node:= RootNode.Item[i-1];
writeln(f,Node.text);
end;
closefile(f);
end;
end;
procedure TForm1.FolderTreeClick(Sender: TObject);
begin
if FolderTree.Selected=nil then
begin
ShowMessage('请选择一个文件夹。');
exit;
end;
SaveToDir:=FolderTree.Selected.Text;
if trim(HtmTitle)<>'' then
begin
Edit1.Text := SaveToDir+'/'+HtmTitle+'.htm';
end
else
begin
Edit1.Text := SaveToDir+'/';
end;
end;
procedure TForm1.Button4Click(Sender: TObject);
begin
GetSource;
PersistFile.Save(StringToOleStr(Edit1.Text), system.True);
end;
end.
