unit WBPages2;
interface
{var
FURLString: string;
wb: IWebBrowser2; // бразуер
wHandle: HWND; // handle созданного окна
}
uses
Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, StdCtrls,
ActiveX, OleCtrls, SHDocVw, MSHTML, HttpApp;
var
wb: IWebBrowser2; // бразуер
wHandle: HWND; // handle созданного окна
function GetWBHtml2(url: String): String;
implementation
const
CLSID_InternetExplorer: TGUID = '{8856F961-340A-11D0-A96B-00C04FD705A2}';
function AtlAxAttachControl(const pControl: IUnknown;
hWnd: HWND; ppUnkContainer: IUnknown): DWORD; stdcall; external 'ATL.DLL';
function GetWBHtml2(url: String): String;
const
UserAgents: array [0..7] of String=
('Mozilla/5.0 (Windows; U; Windows NT 5.1; ru; rv:1.9.2.22) Gecko/20110902 Firefox/3.6.22',
'Mozilla/5.0 (Windows; U; Windows NT 6.1; ru; rv:1.9.2.22) Gecko/20110902 Firefox/3.6.22',
'Mozilla/5.0 (Windows NT 6.1; WOW64) AppleWebKit/535.1 (KHTML, like Gecko) Chrome/14.0.835.202 Safari/535.1',
'Mozilla/4.0 (compatible; MSIE 6.0; Windows NT 5.1; SV1; EmbeddedWB 14.52 from: http://www.bsalsa.com/ EmbeddedWB 14.52; .NET CLR 2.0.50727)',
'Mozilla/5.0 (compatible; MSIE 9.0; Windows NT 6.1; Win64; x64; Trident/5.0)',
'Mozilla/5.0 (compatible; MSIE 9.0; Windows NT 6.1; WOW64; Trident/5.0)',
'Mozilla/5.0 (Windows NT 6.1; WOW64; rv:7.0.1) Gecko/20100101 Firefox/7.0.1',
'Mozilla/5.0 (Windows NT 6.1; WOW64) AppleWebKit/534.50 (KHTML, like Gecko) Version/5.1 Safari/534.50'
);
var
WndClass: TWndClassEx;
pData, Headers, Flags: OleVariant;
Msg: tagMSG;
HTMLDocument: IHTMLDocument2;
PersistFile: IPersistFile;
ss: TStringStream;
PersistStream: IPersistStreamInit;
Stream: IStream;
res: String;
begin
Randomize;
FillChar(WndClass, SizeOf(WndClass), 0);
with WndClass do
begin
cbSize := SizeOf(WndClass);
lpszClassName := 'MESSAGE_ONLY_WINDOW';
lpfnWndProc := @DefWindowProc;
end;
RegisterClassEx(WndClass);
wHandle := CreateWindowEx(0, WndClass.lpszClassName, nil,
0, 0, 0, 0, 0, DWORD(HWND_MESSAGE), 0, 0, nil);
if (wHandle = 0) then
raise Exception.Create('CreateWindowEx');
try
CoInitializeEx(nil, COINIT_APARTMENTTHREADED);
if (CoCreateInstance(CLSID_InternetExplorer, nil, CLSCTX_INPROC_SERVER,
IID_IWebBrowser2, wb) <> S_OK) then
raise Exception.Create('CoCreateInstance');
try
AtlAxAttachControl(wb, wHandle, nil);
Headers := 'User-Agent: '+UserAgents[Random(Length(UserAgents))]+#10#13#0;
pData := EmptyParam;
Flags := NavNoHistory or NavNoReadFromCache or NavNoWriteToCache;
wb.Navigate(url, Flags, EmptyParam, pData, Headers) ;
while (wb.ReadyState <> READYSTATE_COMPLETE) do
begin
while PeekMessage(Msg, 0, 0, 0, PM_REMOVE) do
DispatchMessage(Msg);
Sleep(1);
end;
HTMLDocument := (wb.Document) as IHTMLDocument2;
PersistStream := HTMLDocument as IPersistStreamInit;
ss := TStringStream.Create;
try
Stream := TStreamAdapter.Create(ss, soReference) as IStream;
PersistStream.Save(Stream, True);
//Result := ss.DataString;
Result := StringOf(TEncoding.Convert(TEncoding.UTF8,
TEncoding.GetEncoding(1251), BytesOf(ss.DataString)));
finally
ss.Free;
end;
//MessageBoxW(0, PWideChar((wb.Document as IHTMLDocument2).title), '', 0);
finally
wb := nil;
end;
finally
DestroyWindow(wHandle);
CoUnInitialize;
end;
end;
end.
Утечка памяти (IWebBrowser2, PeekMessage)
Была проблема с загрузкой полного исходного кода с помощью TWebBrowser (в отдельном потоке). Проблему решил благодаря обсуждению http://forum.codenet.ru/threads/59960-TWebBrowser-%D0%B2-Thread
В итоге был получен код:
Код:
Но идет сильная утечка памяти. На одной машине с Win7x64 этого не наблюдается, зато на другой c Win7x64 и виртуальной WinXP c 250 МБ (изначально такой большой объем из-за таблицы TAdvStringGrid c 9000 строками) за минуты увеличивается до 400 МБ и выше.
Опытным путем было установлено, что проблема в этом участке:
Код:
while (wb.ReadyState <> READYSTATE_COMPLETE) do
begin
while PeekMessage(Msg, 0, 0, 0, PM_REMOVE) do
DispatchMessage(Msg);
Sleep(1);
end;
begin
while PeekMessage(Msg, 0, 0, 0, PM_REMOVE) do
DispatchMessage(Msg);
Sleep(1);
end;
Если его убрать, то память в порядке.
В программе запускается дочерний поток и в Execute вызывается GetWBHtml2(url);
Как можно поправить?
И если убрать этот кусок то все работает?
Цитата: Phodopus
И если убрать этот кусок то все работает?
Если убрать, то утечки нет, но тогда страница (и сопутствующие файлы) не скачивается.
Мне вообще не нравится там этот цикл посреди сада. Стоило бы вынести его граммотно и полноценно в основную часть и сделать обработку на событиях оконной процедуры.
Поподробнее, пожалуйста :)
Сделать для треда отдельную полноценную петлю сообщений и все-такое-прочее как в обычном WinAPI приложении