多线程 程序退出报错 :system error:code:5 拒绝访问 -附代码

Question

启用了线程,代码如下 
unit Unit1;interfaceuses
  Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms,
  Dialogs, StdCtrls,  
   IdHTTP, ComCtrls, IdAntiFreezeBase, IdAntiFreeze, jpeg, ExtCtrls,
  ImgList, XPMenu,activex, dxCntner, dxEditor, dxExEdtr, dxEdLib,
    shellapi,pagerank,   PerlRegEx,StrUtils,  dxStatusBar,  SUITabControl,  cxControls,
   OleCtrls, cxGraphics, SUIPageControl, dxGDIPlusClasses,
  IdBaseComponent, Menus;
type
  TDatabaseThread = class(TThread)
  private
    idhttp1:Tidhttp;
     protected
    procedure Execute; override;  public
      idx1,total1:integer;
    constructor Create(idx,total:integer); overload;
end;
type  TForm1 = class(TForm)
    ImageList1: TImageList;
    XPMenu1: TXPMenu;
    save1: TSaveDialog;
    Panel1: TPanel;
    Label3: TLabel;
    dxHyperLinkEdit1: TdxHyperLinkEdit;
    Panel2: TPanel;
    Label1: TLabel;
    Panel3: TPanel;
    Panel4: TPanel;
    Label2: TLabel;
    Label4: TLabel;
    Button3: TButton;
    Button4: TButton;
    Edit2: TEdit;
    UpDown1: TUpDown;
    Image2: TImage;
    Splitter1: TSplitter;
    Image1: TImage;
    UpDown2: TUpDown;
    Edit4: TEdit;
    Label5: TLabel;
    edit1: TdxHyperLinkEdit;
    st: TdxStatusBar;
    suiPageControl1: TsuiPageControl;
    suiTabSheet1: TsuiTabSheet;
    suiTabSheet2: TsuiTabSheet;
    suiTabSheet3: TsuiTabSheet;
    listv1: TListView;
    GroupBox1: TGroupBox;
    Button1: TButton;
    suiTabSheet4: TsuiTabSheet;
    dxMemo1: TdxMemo;
    listv2: TListView;
    listv3: TListView;
    CheckPR: TCheckBox;
    Checkbd: TCheckBox;
    Checkbdrq: TCheckBox;
    Combobdfw: TComboBox;
    Image3: TImage;
    Checkwww: TCheckBox;
    Button2: TButton;
    suiTabSheet5: TsuiTabSheet;
    Listv4: TListView;
    Timer1: TTimer;
    procedure Button1Click(Sender: TObject);
    procedure Button3Click(Sender: TObject);
    procedure HttpScan(idhttp1:TIDHTTP; row:integer);
    procedure Addlistitem(List1:Tlistview;f1:string;f2:string;f3:string;f4:string;f5:string;f6:string;f7:string;f8:string;f9:string;imgidx:integer);
    procedure listv1DblClick(Sender: TObject);
    procedure CheckbdClick(Sender: TObject);
    function  SetBaiduDays():string;
    procedure SaveScanData(listvew:tlistview;filename:string);
    procedure listv1CustomDrawSubItem(Sender: TCustomListView;
      Item: TListItem; SubItem: Integer; State: TCustomDrawState;
      var DefaultDraw: Boolean);
    procedure InitSearchData();
    procedure FormClose(Sender: TObject; var Action: TCloseAction);
    procedure Button4Click(Sender: TObject);
    procedure Button2Click(Sender: TObject);
    procedure Timer1Timer(Sender: TObject);  private
    { Private declarations }
  public
  end;var
  Form1: TForm1;
  RunState:boolean;
  runtime,chktotal:longint;implementationuses Unit2;
{$R *.dfm}
constructor TDatabaseThread.Create(idx,total:integer);
begin
  idx1:=idx;
  total1:=total;
  inherited Create(false);
end;
procedure TDatabaseThread.Execute;
var i:integer;
begin
  FreeOnTerminate := true;
  while not (Terminated or Application.Terminated) do
  begin
  try
      CoInitialize(nil);
      RunState:=true;
      idhttp1:=tidhttp.Create(nil);
      for i:=0 to chktotal-1 do
      begin
         if RunState=false then begin  break; end ;
         if ((idx1<>total1) and (I mod total1=idx1) or (idx1=total1) and (I mod total1=0))   then
             Synchronize(form1.HttpScan(idhttp1,i));
      end;
      if Terminated then  exit;
    finally
        idhttp1.Disconnect;
        idhttp1.Free;
        CoUninitialize;
      Application.ProcessMessages;
    end;
  end;
end;
procedure TForm1.HttpScan(idhttp1:TIDHTTP;row:integer);
var
 dns,HtmBuf,PR,BaiDuSl,baidurq,baiduwz:String;
 LinkStr,NoLinkstr:TStringList;
 fdate,Linktitle,NoLinkcounts,chkurl:string;
begin
  asm
    db $EB,$10,'VMProtect begin',0
  end;
  if RunState=false then exit;
  Linkstr:=TStringList.create;
  NoLinkstr:=TStringList.Create;
  IdHTTP1.HandleRedirects:=true  ;
  IdHTTP1.Request.Connection:='Keep-Alive';
  IdHTTP1.Request.UserAgent:='Mozilla/4.0 (compatible; MSIE 6.0; Windows NT 5.1; SV1; Maxthon)';
  IdHTTP1.Request.ContentType:='application/x-www-form-urlencoded';
  IdHTTP1.Request.Accept:='image/gif, image/x-xbitmap, image/jpeg, image/pjpeg, application/x-shockwave-flash, application/vnd.ms-excel, application/msword, */*';
  IdHTTP1.Request.CacheControl:='no-cache';
  IdHTTP1.ConnectTimeout:=30000;
  IdHTTP1.ReadTimeout:=40000;
  IdHTTP1.HTTPOptions:=IdHTTP1.HTTPOptions+[hoKeepOrigProtocol];
  IdHTTP1.ProtocolVersion:=pv1_1;
  try
      //regex current dns
      chkurl:=trim(dxmemo1.lines[row]);
      dns:=Regexreplace(Regexreplace(chkurl,'http://'),'/');      if  chkurl='' then exit;
      HtmBuf:=IdHTTP1.Get(Sethttp(chkurl));
以下略...................

Answer 1

看看错误出在哪，多数是IdHTTP1.Get的问题，没有注意同步造成，要保证一个读取完了，在进行下一个读取

Answer 2

初步估計是線程未同步造成程序退出出錯，不知道LZ想實現什麼效果？跟蹤一下代碼看一下呢...
提供一ithttp線程下載的demo,供參考unit Unit1;interfaceuses
Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms,
Dialogs, ComCtrls, StdCtrls, IdComponent, IdTCPConnection, IdTCPClient,
IdHTTP, IdBaseComponent, IdAntiFreezeBase, IdAntiFreeze,
IdThreadComponent, IdFTP;type
TThread1 = class(TThread)private
fCount, tstart, tlast: integer;
tURL, tFile, temFileName: string;
tResume: Boolean;
tStream: TFileStream;
protected
procedure Execute; override;
public
constructor create1(aURL, aFile, fileName: string; bResume: Boolean; Count,
start, last: integer);
procedure DownLodeFile(); //下載檔案
end;type
TForm1 = class(TForm)
IdAntiFreeze1: TIdAntiFreeze;
IdHTTP1: TIdHTTP;
Button1: TButton;
ProgressBar1: TProgressBar;
IdThreadComponent1: TIdThreadComponent;
Label1: TLabel;
Label2: TLabel;
Button2: TButton;
Button3: TButton;
ListBox1: TListBox;
Edit1: TEdit;
Edit2: TEdit;
Label3: TLabel;
Label4: TLabel;procedure Button1Click(Sender: TObject);
procedure IdHTTP1WorkBegin(Sender: TObject; AWorkMode: TWorkMode;
const AWorkCountMax: Integer);
procedure IdHTTP1Work(Sender: TObject; AWorkMode: TWorkMode;
const AWorkCount: Integer);
procedure Button2Click(Sender: TObject);
procedure IdHTTP1Status(ASender: TObject; const AStatus: TIdStatus;
const AStatusText: string);
procedure Button3Click(Sender: TObject);
private
public
nn, aFileSize, avg: integer;
MyThread: array[1..10] of TThread;
procedure GetThread();
procedure AddFile();
function GetURLFileName(aURL: string): string;
function GetFileSize(aURL: string): integer;
end;var
Form1: TForm1;implementation
var
AbortTransfer: Boolean;
aURL, aFile: string;tcount: integer; //檢查檔是否全部下載完畢
{$R *.dfm}//get FileNamefunction TForm1.GetURLFileName(aURL: string): string;
var
i: integer;
s: string;
begin //返回下載地址的檔案名s := aURL;
i := Pos('/', s);
while i <> 0 do //去掉"/"前面的內容剩下的就是檔案名了
begin
Delete(s, 1, i);
i := Pos('/', s);
end;
Result := s;
end;//get FileSizefunction TForm1.GetFileSize(aURL: string): integer;
var
FileSize: integer;
begin
IdHTTP1.Head(aURL);
FileSize := IdHTTP1.Response.ContentLength;
IdHTTP1.Disconnect;
Result := FileSize;
end;//執行下載procedure TForm1.Button1Click(Sender: TObject);
var
j: integer;
begin
tcount := 0;
Showmessage('OK!主執行緒在執行，獲得檔案名並顯示在Edit2中');
aURL := Edit1.Text; //下載地址
aFile := GetURLFileName(Edit1.Text); //得到檔案名
nn := StrToInt(Edit2.Text); //執行緒數
j := 1;
aFileSize := GetFileSize(aURL);
avg := trunc(aFileSize / nn);
begin
try
GetThread();
while j <= nn do
begin
MyThread[j].Resume; //喚醒執行緒
j := j + 1;
end;
except
Showmessage('創建執行緒失敗!');
Exit;
end;
end;
end;//開始下載前,將ProgressBar1的最大值設置為需要接收的資料大小.procedure TForm1.IdHTTP1WorkBegin(Sender: TObject; AWorkMode: TWorkMode;
const AWorkCountMax: Integer);
begin
AbortTransfer := False;
ProgressBar1.Max := AWorkCountMax;
ProgressBar1.Min := 0;
ProgressBar1. 0;
end;//接收資料的時候,進度將在ProgressBar1顯示出來.procedure TForm1.IdHTTP1Work(Sender: TObject; AWorkMode: TWorkMode;
const AWorkCount: Integer);
begin
if AbortTransfer then
begin
IdHTTP1.Disconnect; //中斷下載
end;
ProgressBar1. AWorkCount;
//ProgressBar1.; //*******顯示速度極快
Application.ProcessMessages;
//***********************************這樣使用不知道對不對end;//中斷下載procedure TForm1.Button2Click(Sender: TObject);
begin
AbortTransfer := True;
IdHTTP1.Disconnect;
end;//狀態顯示procedure TForm1.IdHTTP1Status(ASender: TObject; const AStatus: TIdStatus;
const AStatusText: string);
begin
ListBox1.ItemIndex := ListBox1.Items.Add(AStatusText);
end;//退出程式procedure TForm1.Button3Click(Sender: TObject);
begin
application.Terminate;end;//迴圈產生執行緒procedure TForm1.GetThread();
var
i: integer;
start: array[1..100] of integer;
last: array[1..100] of integer; //改用了陣列，也可不用
fileName: string;
begin
i := 1;
while i <= nn do
begin
start[i] := avg * (i - 1);
last[i] := avg * i -1; //這裡原先是last:=avg*i;
if i = nn then
begin
last[i] := avg*i + aFileSize-avg*nn; //這裡原先是aFileSize
end;
fileName := aFile + IntToStr(i);
MyThread[i] := TThread1.create1(aURL, aFile, fileName, false, i, start[i],
last[i]);
i := i + 1;
end;
end;procedure TForm1.AddFile(); //合併檔
var
mStream1, mStream2: TMemoryStream;
i: integer;
begin
i := 1;
mStream1 := TMemoryStream.Create;
mStream2 := TMemoryStream.Create;mStream1.loadfromfile('設備工程進度管理前期規劃.doc' + '1');
while i < nn do
begin
mStream2.loadfromfile('設備工程進度管理前期規劃.doc' + IntToStr(i + 1));
mStream1.seek(mStream1.size, soFromBeginning);
mStream1.copyfrom(mStream2, mStream2.size);
mStream2.clear;
i := i + 1;
end;
mStream2.free;
mStream1.SaveToFile('設備工程進度管理前期規劃.doc');
mStream1.free;
//刪除暫存檔案
i:=1;
while i <= nn do
begin
deletefile('設備工程進度管理前期規劃.doc' + IntToStr(i));
i := i + 1;
end;
Form1.ListBox1.ItemIndex := Form1.ListBox1.Items.Add('下在成功');end;//構造函數constructor TThread1.create1(aURL, aFile, fileName: string; bResume: Boolean;
Count, start, last: integer);
begin
inherited create(true);
FreeOnTerminate := true;
tURL := aURL;
tFile := aFile;
fCount := Count;
tResume := bResume;
tstart := start;
tlast := last;
temFileName := fileName;
end;
//下載檔案函數procedure TThread1.DownLodeFile();
var
temhttp: TIdHTTP;
begintemhttp := TIdHTTP.Create(nil);
temhttp.onWorkBegin := Form1.IdHTTP1WorkBegin;
temhttp.onwork := Form1.IdHTTP1work;
temhttp.onStatus := Form1.IdHTTP1Status;
Form1.IdAntiFreeze1.OnlyWhenIdle := False; //設置使程式有反應.
if FileExists(temFileName) then //如果檔已經存在
tStream := TFileStream.Create(temFileName, fmOpenWrite)
else
tStream := TFileStream.Create(temFileName, fmCreate);if tResume then //續傳方式
begin
exit;
end
else //覆蓋或新建方式
begin
temhttp.Request.ContentRangeStart := tstart;
temhttp.Request.ContentRangeEnd := tlast;
end;try
temhttp.Get(tURL, tStream); //開始下載
Form1.ListBox1.ItemIndex := Form1.ListBox1.Items.Add(temFileName +
'download');finally
//tStream.Free;
freeandnil(tstream);
temhttp.Disconnect;
end;end;procedure TThread1.Execute;
begin
if Form1.Edit1.Text <> '' then
//synchronize(DownLodeFile)
DownLodeFile
else
exit;
inc(tcount);
if tcount = Form1.nn then //當tcount=nn時代表全部下載成功
begin
//Showmessage('全部下載成功!');
Form1.ListBox1.ItemIndex := Form1.ListBox1.Items.Add('正在合併刪除暫存檔案');
Form1.AddFile;
end;
end;end.

Answer 3

同步主线程的HttpScan方法，而且发现你的代码
  while not (Terminated or Application.Terminated) do
中有
  idhttp1:=tidhttp.Create(nil);
好家伙，只要线程不停，就一直创建idhttp这得创建多少啊

Answer 4

 1、
 "CoInitialize(nil);
  RunState:=true;
  idhttp1:=tidhttp.Create(nil);"
怎么能放在执行函数里呢，这个习惯不好。2、你这个红叉是系统资源同步问题。
光靠Synchronize方法来同步主线程中的方法不够的。

Answer 5

你这里增加信号量比较合适的，D中好象是TEvent吧,自有信号举起和放下的，然后用WaitForSingleObject来同步主线程和工作线程。

Answer 6

改线程同步后,运行起来和一个线程一样了,超慢,不知道怎么回事,我现在的代码查询速度特别快,在XP下没有问题,在win7下会出来程序无响应,或者是riched20.dll溢出错误,请高手指点:
程序原理是:开10个线程,处理1000个数据,依次将1000个数据依据余数关系分配给10个线程工作.
比如1号线程处理 1,11,21,31,41,51,61,71,81,91 这10 个数据,2 号依次类推现在在XP下运行不会出现无响应或溢出错误,但有时退出时提示上边的system error:code:5 拒绝访问,
而win7下会导致程序无响应,无法继续工作....

Answer 7

procedure   TDatabaseThread.vclcreate;
 var i:integer;
begin
      idhttp1:=tidhttp.Create(nil);
      for i:=0 to chktotal-1 do
      begin
         if RunState=false then begin  break; end ;
         if   ((form1.dxMemo1.Lines[i]<>'' )and (idx1<>total1) and (I mod total1=idx1) or (idx1=total1) and (I mod total1=0) )    then
           form1.HttpScan(idhttp1,i);
       end;
     idhttp1.Free;
end;
procedure TDatabaseThread.Execute;
var i:integer;
begin
  try
      CoInitialize(nil);
      RunState:=true;
      if Terminated then  exit;
      synchronize(vclcreate); 
    finally
        CoUninitialize;
    end;
       Application.ProcessMessages;
end;
是这样来保护线程吗???????

Answer 8

哎，还不行啊，没治了我，delphi调试状态运行，一点问题都没有，10个线程检测1000条数据，但程序放到win7下，运行一段时间界面就没有响应了，CPU占用80%以上，哪位给出出着啊。。

Answer 9

你先确定下哪些任务在界面上操作，哪些任务在后台操作。
...
synchronize(vclcreate); //这些代码工作在主线程，所以你的工作线程没有任何效率。
... 

Answer 10

这个函数：procedure TForm1.HttpScan(idhttp1:TIDHTTP;row:integer);
改为：TDatabaseThread.HttpScan(idhttp1:TIDHTTP;row:integer);
把相关数据成员都移到线程中去。