关于网友提出的“ delphi 多线程网页采集退出出错 求助”问题疑问，本网通过在网上对“ delphi 多线程网页采集退出出错 求助”有关的相关答案进行了整理，供用户进行参考，详细问题解答如下：
问题： delphi 多线程网页采集退出出错 求助
描述:delphi源码采集
http://download.csdn.net/detail/u012762790/6593959
源码地址
不用多线程没什么问题，使用多线程退出时出错，不知道哪个资源没有释放，帮我一下，谢谢大家了
100分不够可以再加，我只有160分
unit UI_Less;
interface
uses
Windows, Classes, Messages, Forms, MsHtml, Urlmon, ActiveX;
const
WM_USER_STARTWALKING = WM_USER + 1;
DISPID_AMBIENT_DLCONTROL = (-5512);
READYSTATE_COMPLETE = $00000004;
DLCTL_DLIMAGES = $00000010;
DLCTL_VIDEOS = $00000020;
DLCTL_BGSOUNDS = $00000040;
DLCTL_NO_SCRIPTS = $00000080;
DLCTL_NO_JAVA = $00000100;
DLCTL_NO_RUNACTIVEXCTLS = $00000200;
DLCTL_NO_DLACTIVEXCTLS = $00000400;
DLCTL_DOWNLOADONLY = $00000800;
DLCTL_NO_FRAMEDOWNLOAD = $00001000;
DLCTL_RESYNCHRONIZE = $00002000;
DLCTL_PRAGMA_NO_CACHE = $00004000;
DLCTL_NO_BEHAVIORS = $00008000;
DLCTL_NO_METACHARSET = $00010000;
DLCTL_URL_ENCODING_DISABLE_UTF8 = $00020000;
DLCTL_URL_ENCODING_ENABLE_UTF8 = $00040000;
DLCTL_FORCEOFFLINE = $10000000;
DLCTL_NO_CLIENTPULL = $20000000;
DLCTL_SILENT = $40000000;
DLCTL_OFFLINEIFNOTCONNECTED = $80000000;
DLCTL_OFFLINE = DLCTL_OFFLINEIFNOTCONNECTED;
type
TUILess = class(TComponent, IUnknown, IDispatch, IPropertyNotifySink,
IOleClientSite)
private
FDocTitle: string;
FBodyText: TStrings;
FBodyHtml: TStrings;
protected
/// IDISPATCH
function Invoke(DispID: Integer; const IID: TGUID; LocaleID: Integer;
Flags: Word; var Params; VarResult, ExcepInfo, ArgErr: Pointer): HResult;
stdcall;
/// IPROPERTYNOTIFYSINK
function OnChanged(DispID: TDispID): HResult; stdcall;
function OnRequestEdit(DispID: TDispID): HResult; stdcall;
/// IOLECLIENTSITE
function SaveObject: HResult; stdcall;
function GetMoniker(dwAssign: Longint; dwWhichMoniker: Longint;
out mk: IMoniker): HResult; stdcall;
function GetContainer(out container: IOleContainer): HResult; stdcall;
function ShowObject: HResult; stdcall;
function OnShowWindow(fShow: BOOL): HResult; stdcall;
function RequestNewObjectLayout: HResult; stdcall;
///
function LoadUrlFromMoniker: HResult;
function LoadUrlFromFile: HResult;
// * We only use LoadUrlFromMoniker, but we could use LoadUrlFromFile instead.
public
constructor Create(AOwner: TComponent); override;
destructor Destroy; override;
property DocTitle: string read FDocTitle;
property BodyText: TStrings read FBodyText write FBodyText;
property BodyHtml: TStrings read FBodyHtml write FBodyHtml;
function Get(URL: PWidechar; var IsSucceed: Boolean; IsStop: Boolean)
: IHTMLELEMENTCollection;
procedure GetAnchorList(IC: IHTMLELEMENTCollection; Anchorlist: TStrings);
procedure GetImageList(IC: IHTMLELEMENTCollection; ImageList: TStrings);
end;
implementation
var
Doc: IhtmlDocument2;
_URL: PWidechar;
constructor TUILess.Create(AOwner: TComponent);
begin
inherited Create(AOwner);
FBodyText := TStringList.Create;
FBodyHtml := TStringList.Create;
end;
destructor TUILess.Destroy;
begin
if Assigned(FBodyText) then
FBodyText.Free;
if Assigned(FBodyHtml) then
FBodyHtml.Free;
inherited Destroy;
end;
/// CORE ---->>>>>>>>>
function TUILess.Get(URL: PWidechar; var IsSucceed: Boolean; IsStop: Boolean)
: IHTMLELEMENTCollection;
var
Cookie: Integer;
CP: IConnectionPoint;
OleObject: IOleObject;
OleControl: IOleControl;
CPC: IConnectionPointContainer;
All: IHTMLElement;
Msg: TMsg;
hr: HResult;
begin
_URL := URL;
IsSucceed := false;
try
CoCreateInstance(CLASS_HTMLDocument, nil, CLSCTX_INPROC_SERVER,
IID_IHTMLDocument2, Doc);
OleObject := Doc as IOleObject;
OleObject.SetClientSite(self);
OleControl := Doc as IOleControl;
OleControl.OnAmbientPropertyChange(DISPID_AMBIENT_DLCONTROL);
CPC := Doc as IConnectionPointContainer;
CPC.FindConnectionPoint(IPropertyNotifySink, CP);
CP.Advise(self, Cookie);
hr := LoadUrlFromMoniker; // alternative: Hr:= LoadUrlFromFile;
if ((SUCCEEDED(hr)) or (hr = E_PENDING)) then
while (GetMessage(Msg, 0, 0, 0)) do
begin
if ((Msg.message = WM_USER_STARTWALKING) and (Msg.hwnd = 0)) then
begin
PostQuitMessage(0);
result := Doc.Get_all;
All := Doc.Get_body;
FDocTitle := string(Doc.nameProp);
FBodyText.Text := string(All.outerText);
FBodyHtml.Text := string(All.outerHTML);
IsSucceed := true;
end
else
DispatchMessage(Msg);
if IsStop then
Exit;
end;
except
Exit;
end;
end;
function TUILess.Invoke(DispID: Integer; const IID: TGUID; LocaleID: Integer;
Flags: Word; var Params; VarResult, ExcepInfo, ArgErr: Pointer): HResult;
var
I: Integer;
begin
if DISPID_AMBIENT_DLCONTROL = DispID then
begin
I := DLCTL_DOWNLOADONLY + DLCTL_NO_SCRIPTS + DLCTL_NO_JAVA +
DLCTL_NO_DLACTIVEXCTLS + DLCTL_NO_RUNACTIVEXCTLS;
PVariant(VarResult)^ := I;
result := S_OK;
end
else
result := DISP_E_MEMBERNOTFOUND;
end;
function TUILess.OnChanged(DispID: TDispID): HResult;
var
dp: TDispParams;
vResult: OleVariant;
begin
if (DISPID_READYSTATE = DispID) then
if SUCCEEDED((Doc as IhtmlDocument2).Invoke(DISPID_READYSTATE, GUID_null,
LOCALE_SYSTEM_DEFAULT, DISPATCH_PROPERTYGET, dp, @vResult, nil, nil))
then
if Integer(vResult) = READYSTATE_COMPLETE then
PostThreadMessage(GetCurrentThreadId(), WM_USER_STARTWALKING, 0, 0);
end;
function TUILess.LoadUrlFromMoniker: HResult;
var
Moniker: IMoniker;
BindCtx: IBindCTX;
PM: IPersistMoniker;
begin
createURLMoniker(nil, _URL, Moniker);
CreateBindCtx(0, BindCtx);
PM := Doc as IPersistMoniker;
result := PM.Load(LongBool(0), Moniker, BindCtx, STGM_READ)
end;
function TUILess.LoadUrlFromFile: HResult;
var
PF: IPersistfile;
begin
PF := Doc as IPersistfile;
result := PF.Load(_URL, 0);
end;
// 获取图像链接
procedure TUILess.GetImageList(IC: IHTMLELEMENTCollection; ImageList: TStrings);
var
Image: IHTMLImgElement;
Disp: IDispatch;
x: Integer;
begin
if IC <> nil then
begin
for x := 0 to IC.Length - 1 do
begin
application.ProcessMessages;
Disp := IC.item(x, 0);
if SUCCEEDED(Disp.QueryInterface(IHTMLImgElement, Image)) then
ImageList.add(string(Image.src));
end;
end;
end;
// 获取链接
procedure TUILess.GetAnchorList(IC: IHTMLELEMENTCollection;
Anchorlist: TStrings);
var
anchor: IHTMLAnchorElement;
Disp: IDispatch;
x: Integer;
begin
if IC <> nil then
begin
for x := 0 to IC.Length - 1 do
begin
application.ProcessMessages;
Disp := IC.item(x, 0);
if (SUCCEEDED(Disp.QueryInterface(IHTMLAnchorElement, anchor)) and
(anchor.href <> '')) then
Anchorlist.add(string(anchor.href));
end;
end;
end;
/// Don't Care ------>>>>>>>>>>>
function TUILess.OnRequestEdit(DispID: TDispID): HResult;
begin
result := E_NOTIMPL;
end;
function TUILess.SaveObject: HResult;
begin
result := E_NOTIMPL;
end;
function TUILess.GetMoniker(dwAssign: Longint; dwWhichMoniker: Longint;
out mk: IMoniker): HResult;
begin
result := E_NOTIMPL;
end;
function TUILess.GetContainer(out container: IOleContainer): HResult;
begin
result := E_NOTIMPL;
end;
function TUILess.ShowObject: HResult;
begin
result := E_NOTIMPL;
end;
function TUILess.OnShowWindow(fShow: BOOL): HResult;
begin
result := E_NOTIMPL;
end;
function TUILess.RequestNewObjectLayout: HResult;
begin
result := E_NOTIMPL;
end;
end.
unit Unit3;
interface
uses
Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms, ActiveX,
Dialogs, StdCtrls;
type
Mythread = class(TThread)
private
procedure into(i: Word);
{ Private declarations }
protected
procedure Execute; override;
end;
type
TForm3 = class(TForm)
Button1: TButton;
Edit1: TEdit;
Memo1: TMemo;
Button2: TButton;
Button3: TButton;
Button4: TButton;
procedure Button1Click(Sender: TObject);
procedure Button2Click(Sender: TObject);
procedure Button3Click(Sender: TObject);
procedure Button4Click(Sender: TObject);
private
{ Private declarations }
public
{ Public declarations }
end;
var
Form3: TForm3;
implementation
uses UI_Less;
{$R *.dfm} var n:Word;
function DoStrToWideChar(s: string): PWideChar;
var
// s:sting;
pwc: PWidechar;
len: integer;
begin
// s:= 'abcdefg ';
len := length(s) + 1;
pwc := AllocMem(len * sizeof(widechar));
stringtowidechar(s, pwc, len);
// showmessage(widechartostring(pwc));
result := pwc;
// FreeMem(pwc);
end;
procedure Mythread.into(i: Word);
var
sh: TUILess;
su: boolean; // 是否获取成功
// isstop: boolean; //设全局变量可以中断连接 ,避免出错
surl: PWideChar;
begin CoInitialize(nil);
surl := DoStrToWideChar(Trim(Form3.Edit1.Text));
sh := TUILess.Create(nil);
try
Form3.Memo1.Clear;
case i of
1:
sh.GetAnchorList(sh.get(surl, su, False), Form3.Memo1.Lines);
2:
sh.GetImageList(sh.get(surl, su, False), Form3.Memo1.Lines);
3:
begin
sh.get(surl, su, False);
Form3.Memo1.Lines := sh.BodyText;
end;
4:
begin
sh.get(surl, su, False);
Form3.Memo1.Lines := sh.BodyHtml;
end;
end;
finally
//sh.Free;
end;
CoUninitialize();
end;
procedure Mythread.Execute;
begin
Into(n);
end;
procedure TForm3.Button1Click(Sender: TObject);
begin
n:=1;Mythread.Create(False);
end;
procedure TForm3.Button2Click(Sender: TObject);
begin
n:=2;Mythread.Create(False);
end;
procedure TForm3.Button3Click(Sender: TObject);
begin
n:=3;Mythread.Create(False);
end;
procedure TForm3.Button4Click(Sender: TObject);
begin
n:=4;Mythread.Create(False);
end;
end.
解决方案1: 发到你QQ了
以上介绍了“ delphi 多线程网页采集退出出错 求助”的问题解答，希望对有需要的网友有所帮助。
本文网址链接：http://www.codes51.com/itwd/2192238.html
