在使用多线程方式访问COM对象接口（如IXMLDocument和IXMLNode等）时，Delphi7存在一些内存问题。其他COM接口也可能存在此问题，但我的“研究”并不深入，因为我还要继续进行当前的项目。在单线程中创建TXMLDocument并通过IXMLDocument和IXMLNode等接口进行操作是可以的，但在多线程方法中，当一个线程创建TXMLDocument对象并且其他线程进行操作时，会使用越来越多的内存。每个线程都调用CoInitializeEx(nil, COINIT_MULTITHREADED)，但无济于事。似乎每个线程在获取接口时都会分配一些内存并且不会释放它，但每个线程至少为某个接口（例如DocumentElement或ChildNodes）分配一次 - 因此除了创建对象的工作线程之外的一个工作线程不会导致可见的内存泄漏。但是动态创建的线程都以相同的方式行事，并最终消耗掉进程内存。以下是完整的测试应用程序Delphi7表单，作为显示上述三种不同情况的简化代码示例 - 单线程、一个工作线程和动态创建的线程。
unit uComTest;
interface
uses
Windows, SysUtils, Classes, Forms, ExtCtrls, Controls, StdCtrls, XMLDoc, XMLIntf, ActiveX;
type
TMyThread = class(TThread)
procedure Execute;override;
end;
TForm1 = class(TForm)
btnMainThread: TButton;
edtText: TEdit;
Timer1: TTimer;
btnOneThread: TButton;
btnMultiThread: TButton;
Timer2: TTimer;
chkXMLUse: TCheckBox;
procedure FormCreate(Sender: TObject);
procedure btnMainThreadClick(Sender: TObject);
procedure Timer1Timer(Sender: TObject);
procedure FormDestroy(Sender: TObject);
procedure btnOneThreadClick(Sender: TObject);
procedure btnMultiThreadClick(Sender: TObject);
procedure Timer2Timer(Sender: TObject);
private
fXML:TXMLDocument;
fXMLDocument:IXMLDocument;
fThread:TMyThread;
fCount:Integer;
fLoop:Boolean;
procedure XMLCreate;
function XMLGetItfc:IXMLDocument;
procedure XMLUse;
public
end;
var
Form1: TForm1;
implementation
{$R *.dfm}
procedure TForm1.FormCreate(Sender: TObject);
begin
CoinitializeEx(nil, COINIT_MULTITHREADED);
XMLCreate; //XML is created on MainThread;
Timer1.Enabled := false;
Timer2.Enabled := false;
end;
procedure TForm1.FormDestroy(Sender: TObject);
begin
fIXMLDocument := nil;
CoUninitialize;
end;
procedure TForm1.XMLCreate;
begin
fXML := TXMLDocument.Create('.\try.xml');
fXML.Active;
fXML.GetInterface(IXMLDocument, fIXMLDocument);
end;
function TForm1.XMLGetItfc:IXMLDocument;
begin
fXML.GetInterface(IXMLDocument, Result);
end;
procedure TForm1.XMLUse;
begin
Inc(fCount);
if chkXMLUse.Checked then
begin
XMLGetItfc.DocumentElement;
edtText.Text := IntToStr(GetCurrentThreadId) + ': ' + 'XML access ' + IntToStr(fCount);
end
else
edtText.Text := IntToStr(GetCurrentThreadId) + ': ' + 'NO XML access ' + IntToStr(fCount)
end;
procedure TForm1.btnMainThreadClick(Sender: TObject);
begin
fCount := 0;
fLoop := false;
Timer1.Enabled := not Timer1.Enabled;
end;
procedure TForm1.btnOneThreadClick(Sender: TObject);
begin
if fLoop then
fLoop := false
else
begin
fCount := 0;
fLoop := true;
fThread := TMyThread.Create(FALSE);
end;
end;
procedure TForm1.btnMultiThreadClick(Sender: TObject);
begin
fCount := 0;
fLoop := false;
Timer2.Enabled := not Timer2.Enabled;
end;
procedure TForm1.Timer1Timer(Sender: TObject);
begin
XMLUse;
end;
procedure TForm1.Timer2Timer(Sender: TObject);
begin
TMyThread.Create(FALSE);
end;
//this procedure executes in every thread
procedure TMyThread.Execute;
begin
FreeOnTerminate := TRUE;
CoinitializeEx(nil, COINIT_MULTITHREADED);
try
repeat
Form1.XMLUse;
if Form1.floop then
sleep(100);
until not Form1.floop;
finally
CoUninitialize;
end;
end;
end.
嗯，这很必要，因为这是一个带有按钮和定时器的工作Delphi表单，但你不能只是复制和编译它。这里也有form的dfm：
object Form1: TForm1
Left = 54
Top = 253
Width = 337
Height = 250
Caption = 'Form1'
Color = clBtnFace
Font.Charset = DEFAULT_CHARSET
Font.Color = clWindowText
Font.Height = -11
Font.Name = 'MS Sans Serif'
Font.Style = []
OldCreateOrder = False
OnCreate = FormCreate
OnDestroy = FormDestroy
PixelsPerInch = 96
TextHeight = 13
object btnMainThread: TButton
Left = 24
Top = 32
Width = 75
Height = 25
Caption = 'MainThread'
TabOrder = 0
OnClick = btnMainThreadClick
end
object edtText: TEdit
Left = 24
Top = 8
Width = 257
Height = 21
TabOrder = 1
end
object btnOneThread: TButton
Left = 24
Top = 64
Width = 75
Height = 25
Caption = 'One Thread'
TabOrder = 2
OnClick = btnOneThreadClick
end
object btnMultiThread: TButton
Left = 24
Top = 96
Width = 75
Height = 25
Caption = 'MultiThread'
TabOrder = 3
OnClick = btnMultiThreadClick
end
object chkXMLUse: TCheckBox
Left = 112
Top = 88
Width = 97
Height = 17
Caption = 'XML use'
Checked = True
State = cbChecked
TabOrder = 4
end
object Timer1: TTimer
Interval = 100
OnTimer = Timer1Timer
end
object Timer2: TTimer
Interval = 100
OnTimer = Timer2Timer
Left = 32
end
end
下面是一个控制台应用程序。只需运行它，看看是否发生了任何内存消耗。如果您认为可以以保留多线程但不占用内存的方式编写，请随意修改它：
program ConsoleTest;
{$APPTYPE CONSOLE}
uses
Windows, SysUtils, Classes, XMLDoc, XMLIntf, ActiveX;
type
TMyThread = class(TThread)
procedure Execute;override;
end;
var
fCriticalSection:TRTLCriticalSection;
fIXMLDocument:IXMLDocument;
i:Integer;
//--------- Globals -------------------------------
procedure XMLCreate;
begin
fIXMLDocument := TXMLDocument.Create('.\try.xml');
fIXMLDocument.Active;
end;
procedure XMLUse;
begin
fIXMLDocument.DocumentElement;
end;
//------- TMyThread ------------------------------
procedure TMyThread.Execute;
begin
FreeOnTerminate := TRUE;
EnterCriticalSection(fCriticalSection);
try
CoinitializeEx(nil, COINIT_MULTITHREADED);
try
XMLUse;
finally
CoUninitialize;
end;
finally
LeaveCriticalSection(fCriticalSection);
end;
end;
//------------ Main -------------------------
begin
InitializeCriticalSection(fCriticalSection);
CoinitializeEx(nil, COINIT_MULTITHREADED);
try
XMLCreate;
try
for i := 0 to 100000 do
begin
TMyThread.Create(FALSE);
sleep(100);
end;
finally
fIXMLDocument := nil;
end;
finally
CoUninitialize;
DeleteCriticalSection(fCriticalSection);
end;
end.
我正在使用Windows7上的Delphi7企业版。 非常欢迎任何帮助。
XML := TXMLDocument.Create('.\try.xml');应该是fXMLDocument := TXMLDocument.Create('.\try.xml');，并且不需要GetInterface代码。 - whosrdaddyTMyThread.Execute中的Form1.XMLUse是不行的，因为XMLUse函数正在设置TEdit文本。我认为你需要正确掌握线程的基础知识。我建议阅读这篇关于Delphi多线程的优秀指南：http://web.archive.org/web/20060305174604/http://www.pergolesi.demon.co.uk/prog/threads/ToC.html - whosrdaddy