帮帮我。在处理时，老是出错或无响应或是CPU占用率高达100% (100分)

在处理时，老是出错或无响应或是CPU占用率高达100%
以下是完整源码，使用了Indy9的IdUDPServer

unit UnitUDPThread;
//管理收发UDP信息
interface
Uses
Windows ,Classes, StdCtrls, SysUtils, SyncObjs ,CmdDefs,
IdUDPServer,IdSocketHandle;

Type
TCatUDPStat = (csSendOK,csSendTimeOut,csRevcBack,csRevcNew);
//收到消息事件
TStatProc = procedure(Sender:TObject;
ABinding:TIdSocketHandle;
AUDPHeaderSmsHeader; //请求消息的头
AData: TMemoryStream; //返回消息
Stat:TCatUDPStat) //状态 如 发送成功 发送失败 返回消息等
of object;

TCatUDPPack = packed record
sendcount:integer; //发送次数
sendtime:integer; //多长时间发送一次
fsendtime:integer; //临时记数
msgointer; //发送的消息体
msglen:Integer; //消息长度
sequence_no:integer; //包序号
ip:String; //目的地IP
port:Word; //端口
StatProc:TStatProc; //回调函数
cmd_Type:Byte;
End;
PCatUDPPack = ^TCatUDPPack;

TUDPMsgProc = procedure(Sender:TObject;Msg:String)of object;
TUDPSendRecvProc = procedure(Sender:TObject;IsIn:Boolean; Const IP:String;Const Port:Word;Const AHeadSmsHeader;Const Msg:String)of object;
//LQ短信流量控制进程，每秒只能有5条发出哟。
TCatUDPThread = class(TThread)
private
{ Private declarations }
IdUDPServer: TIdUDPServer;
FLock: TCriticalSection;
FSendPackList:TList;
FSequence_NoWord;
FRecvNewPack:TStatProc;
FUDPMsgProc :TUDPMsgProc;
FUDPSendRecvProc : TUDPSendRecvProc;

procedure DoSendOver(ACatUDPPackCatUDPPack ;ABinding: TIdSocketHandle);
procedure DoTimeOut(ACatUDPPackCatUDPPack);
procedure DoRevcBack(ACatUDPPackCatUDPPack;AData:TMemoryStream;ABinding: TIdSocketHandle);
procedure DoRevcNew(AData:TMemoryStream;ABinding: TIdSocketHandle);
procedure DoShowMsg(Msg:String;ProcName:String);
procedure FreeUDPPack(ACatUDPPackCatUDPPack);
protected
procedure Execute; override;
procedure SendUDP(ACatUDPPackCatUDPPack);
procedure IdUDPServerUDPRead(Sender: TObject; AData: TStream; ABinding: TIdSocketHandle);
public
constructor Create(CreateSuspended: Boolean; FIdUDPServer:TIdUDPServer;ARecvNewPack:TStatProc);
destructor Destroy; override;
Function Lock:TList;
procedure UnLock;
procedure Clear;
procedure ReMove(ACatUDPPackCatUDPPack);
Function Add(StatProc:TStatProc;Msg: Pointer; MsgLen: Integer; IP: String;
Port: Word;sendtime:Integer=5000;SendCount: Integer=3)CatUDPPack;
Function FindUDPPack(Sequence_No:Integer)CatUDPPack;//查找包
procedure NSendBack(ADataointer;ABinding: TIdSocketHandle); //一般回复类消息
property OnRecvNewPack:TStatProc Read FRecvNewPack Write FRecvNewPack;
property OnUDPMsgProc: TUDPMsgProc Read FUDPMsgProc Write FUDPMsgProc;
property OnUDPSendRecvProc:TUDPSendRecvProc Read FUDPSendRecvProc Write FUDPSendRecvProc;
End;

implementation

{ TCatUDPThread }

function TCatUDPThread.Add(StatProc:TStatProc;Msg: Pointer; MsgLen: Integer; IP: String;
Port: Word;sendtime:Integer=5000;SendCount: Integer=3): PCatUDPPack;
begin
Try
With Lock do
Try
GetMem(result,SizeOf(TCatUDPPack));
FillChar(result^,SizeOf(result^),0);
result^.sendcount := SendCount;
GetMem(result^.msg,MsgLen);
Windows.CopyMemory(Pointer(result^.msg),Pointer(Msg),MsgLen);
//result^.msg^ := PChar(Msg)^;
//result^.msg := Msg;
result^.msglen := MsgLen;
result^.sendtime := SendTime;
result^.fsendtime := GETTICKCOUNT;
result^.ip := ip;
result^.port := Port;
result^.StatProc := StatProc;
result^.cmd_Type := PSmsHeader(Msg)^.cmd_type;
With PSmsHeader(Msg)^ Do Begin
if cmd_type <> 1 then Begin
inc(FSequence_No);
result^.sequence_no := FSequence_No;
sequence_no := FSequence_No;
End;
End;
//追加到发送列表中
if Add(result) >= 0 then begin
SendUDP(result); //第一次发送
end else begin
Self.FreeUDPPack(result);
end;
Finally
UnLock;
End;
Except
FreeMem(result^.msg);
FreeMem(result);
result := nil;
End;
end;

procedure TCatUDPThread.Clear;
Var
I:Integer;
begin
with Lock do
Try
For I:= 0 to Count -1 do
Self.FreeUDPPack(Items);
Clear;
Finally
UnLock;
End;
end;

constructor TCatUDPThread.Create(CreateSuspended: Boolean;
FIdUDPServer: TIdUDPServer;ARecvNewPack:TStatProc);
begin
inherited Create(CreateSuspended);
FLock := TCriticalSection.Create;
FSendPackList := TList.Create;
IdUDPServer := FIdUDPServer;
IdUDPServer.OnUDPRead := IdUDPServerUDPRead;
FRecvNewPack := ARecvNewPack;
FSequence_No := 0;
//Add(nil,nil,0,'127.0.0.1',8090);
end;

procedure TCatUDPThread.FreeUDPPack(ACatUDPPack: PCatUDPPack);
begin
if Not Assigned(ACatUDPPack) then Exit;
//Lock;
Try
if FSendPackList.Remove(ACatUDPPack) >= 0 then Begin
//FreeMem(ACatUDPPack^.msg);
FreeMem(Pointer(ACatUDPPack));
End;
Finally
//UnLock;
End;
end;

destructor TCatUDPThread.Destroy;
begin
Try
Clear;
FLock.Free;
FSendPackList.Free;
IdUDPServer.Active := False;
Finally
inherited;
End;
end;

procedure TCatUDPThread.DoRevcBack(ACatUDPPack: PCatUDPPack; AData: TMemoryStream; ABinding: TIdSocketHandle);
begin
try
if assigned(ACatUDPPack^.StatProc) Then
//ACatUDPPack^.StatProc(self,ABinding,ACatUDPPack.msg,AData,csRevcBack);
ACatUDPPack^.StatProc(self,ABinding,PSmsHeader(AData.Memory),AData,csRevcBack);
Finally
End;
end;

procedure TCatUDPThread.DoRevcNew(AData: TMemoryStream;ABinding: TIdSocketHandle);
begin
//新消息
Try
if Assigned(FRecvNewPack) Then
FRecvNewPack(self,ABinding,PSmsHeader(AData.Memory),AData,csRevcNew);
Finally
End;
end;

procedure TCatUDPThread.DoSendOver(ACatUDPPack: PCatUDPPack; ABinding: TIdSocketHandle);
begin
Try
if assigned(ACatUDPPack^.StatProc) Then
ACatUDPPack^.StatProc(self,ABinding,Pointer(ACatUDPPack.msg),nil,csSendOK);
Finally
End;
end;

procedure TCatUDPThread.DoShowMsg(Msg, ProcName: String);
begin
if Assigned(FUDPMsgProc) then
FUDPMsgProc(self,Format('[%s]%s (%s)',[
FormatDateTime('yyyy/mm/dd hh:nn:ss',Now),
Msg,ProcName
]));
end;

procedure TCatUDPThread.DoTimeOut(ACatUDPPack: PCatUDPPack);
begin
Try
if assigned(ACatUDPPack^.StatProc) Then
ACatUDPPack^.StatProc(self,nil,Pointer(ACatUDPPack.msg),nil,csSendTimeOut);
Finally
End;
end;

procedure TCatUDPThread.Execute;
Const
TimeSleep = 100; //1秒
cansendpack = 5; //TimeSleep 时间内可发包数
var
I,II:Integer;
ACatUDPPackCatUDPPack;
begin
inherited;
II := 0;
While Not Terminated Do begin
I := 0;
with FSendPackList do
/// with Lock do
/// Try
while (I< cansendpack) and (Count>0) do begin
ACatUDPPack := Items[II];
with ACatUDPPack^ do begin
//检查时间
if (GETTICKCOUNT-FSendTime) >= SendTime Then Begin
//超时了
FLock.Enter;
Try
if SendCount <= 0 then Begin
//if SendCount <> -2 then
DoTimeOut(ACatUDPPack);
// 如果SendCount = -2 ，则是删除包
//Self.ReMove(ACatUDPPack); //删除包
Self.FreeUDPPack(ACatUDPPack);
End Else Begin
SendUDP(ACatUDPPack);
inc(ii); //当前发送
End;
Finally
FLock.Leave;
End;
inc(i); //每秒发送记数加1
if ii >= count then ii := 0; //如果发送到最后一个了，从头开始
End;
End;//with
end;//for
/// Finally
/// unlock;
/// end;
Sleep(TimeSleep);
end;//while
FreeOnTerminate := True;
end;

function TCatUDPThread.FindUDPPack(Sequence_No: Integer): PCatUDPPack;
Var
I:Integer;
begin
result := nil;
with FSendPackList do
For I := 0 to Count -1 do
if (PCatUDPPack(Items)^.sequence_no = Sequence_No) And
(PCatUDPPack(Items)^.cmd_Type <> 1) then begin
result := Items;
Break;
end;
end;

procedure TCatUDPThread.IdUDPServerUDPRead(Sender: TObject; AData: TStream;
ABinding: TIdSocketHandle);
Var
AUDPHeaderSmsHeader;
ACatUDPPackCatUDPPack;
begin
if AData.Size > 0 Then
Try
AUDPHeader := TMemoryStream(AData).Memory;
if AUDPHeader^.cmd_len <> AData.Size Then exit;
if AUDPHeader^.cmd_type = 1 Then Begin// =1 为返回消息
ACatUDPPack := FindUDPPack(AUDPHeader^.sequence_no);
//是返回消息包
if assigned(ACatUDPPack) then begin
//DoSendOver(ACatUDPPack);
DoRevcBack(ACatUDPPack,TMemoryStream(AData),ABinding); //返回消息
Self.FreeUDPPack(ACatUDPPack);
// FreeMem(ACatUDPPack);
//FLock.Enter;
//Try
// ACatUDPPack.sendcount := -2;
//Finally
// FLock.Leave;
//End;
//Remove(ACatUDPPack);
end;
End Else Begin
//是新消息
DoRevcNew(TMemoryStream(AData),ABinding);
End;

if Assigned(FUDPSendRecvProc) then
FUDPSendRecvProc(Self,True,ABinding.PeerIP,ABinding.PeerPort,PSmsHeader(TMemoryStream(AData).Memory),'');

Except
On E:Exception do
DoShowMsg(E.Message,'UDPRead');
End;
//ACatUDPPack

end;

function TCatUDPThread.Lock: TList;
begin
FLock.Enter;
result := FSendPackList;
end;

//通用消息回复
procedure TCatUDPThread.NSendBack(AData: Pointer;
ABinding: TIdSocketHandle);
Var
AUDPHeaderSmsHeader;
OutHeader:TSmsHeader;
begin
AUDPHeader := AData;
OutHeader := AUDPHeader^;
OutHeader.cmd_len:= SizeOf(TSmsHeader);
OutHeader.cmd_type := 1;
Add(nil,@OutHeader,OutHeader.cmd_len,ABinding.PeerIP,ABinding.PeerPort,1,1); //只发送一次，并且不等候
end;

procedure TCatUDPThread.ReMove(ACatUDPPack: PCatUDPPack);
begin
if Not Assigned(ACatUDPPack) then Exit;
Lock;
Try
if FSendPackList.Remove(ACatUDPPack) >= 0 then Begin
FreeMem(ACatUDPPack^.msg);
FreeMem(ACatUDPPack);
ACatUDPPack := nil;
End;
Finally
UnLock;
End;
end;

procedure TCatUDPThread.SendUDP(ACatUDPPack: PCatUDPPack);
begin
//准备发送
Try
with ACatUDPPack^ do
Try
dec(SendCount);
IdUDPServer.ReceiveTimeout := 0;
IdUDPServer.Binding.SendTo(IP,Port,Msg^,MsgLen);
Finally
FSendTime := GETTICKCOUNT; //重新记时
if Assigned(FUDPSendRecvProc) then
FUDPSendRecvProc(Self,False,IP,Port,PSmsHeader(ACatUDPPack^.msg),Format('%d,%d',[ACatUDPPack^.sequence_no,ACatUDPPack^.sendcount]));
End;
Except
On E:Exception do Begin
DoShowMsg(E.Message,'UDPRead');
IdUDPServer.Binding.Reset(True);
End;
End;
end;

procedure TCatUDPThread.UnLock;
begin
FLock.Leave;
end;

end.

我帮助你ding!

接受答案了.