Hi,各位先進大家好:
有一個很奇怪的問題,實在是被打敗了,如下的程式,
使用 Button click的情況下啟動的BuildXML可以;正常跑完產生XML,
但,若是由 IdHTTPServer 的 CommandOther 啟動的BuildXML卻會出現未安裝MSXML,
Q1:雖然安裝MSXML是可以解決,但實在不解為何會有如此差異,且由於要作成Package,不使用MSXML,
Q2:如果 DOMVendor 設為 ADOM XML v4,在RootNode := XML.AddChild('D:multistatus');又會出現 Namespace 未設定,不知該如何設定
以上,謝謝!

function BuildXML(HomeDir: String; StartDir: String; Stream: TStream): Boolean;
var
SRec: System.SysUtils.TSearchRec;
XML : TXMLDocument;
RootNode, RespNode, PSNode, PropNode, {RTypeNode,} CNode : IXMLNode;
begin
if not Assigned(Stream) then begin
Result := False;
Exit;
end;
try
fmWebServer.Memo1.Lines.Add('Build folder list-1:' HomeDir StartDir);
// XML := NewXMLDocument; //initializate the interface
XML := TXMLDocument.Create(nil); //initializate the interface
fmWebServer.Memo1.Lines.Add('Build folder list-2:' HomeDir StartDir);
// XML.DOMVendor := GetDomVendor('ADOM XML v4');
XML.Active := True;
fmWebServer.Memo1.Lines.Add('Build folder list-3:' HomeDir StartDir);
XML.Options := [doNodeAutoIndent];//activate the auto indentation
fmWebServer.Memo1.Lines.Add('Build folder list-4:' HomeDir StartDir);
XML.Encoding := 'utf-8';
fmWebServer.Memo1.Lines.Add('Build folder list-5:' HomeDir StartDir);
RootNode := XML.AddChild('D:multistatus');
RootNode.Attributes['xmlns:D'] := 'DAV:';
fmWebServer.Memo1.Lines.Add('Build folder list-6:' HomeDir StartDir);
Stream.Position := 0;
except
on E : Exception do
fmWebServer.Memo1.Lines.Add('Build folder error...............' E.Message);
end;
if FindFirst(HomeDir StartDir '*.*', faAnyfile, SRec) = 0 then
try
repeat
if (SRec.Name <> '.') and (SRec.Name <> '..') then begin
fmWebServer.Memo1.Lines.Add('file:' SRec.Name);
RespNode := RootNode.AddChild('D:response');
RespNode.Attributes['xmlns:lp1'] := 'DAV:';
RespNode.Attributes['xmlns:lp2'] := 'http://apache.org/dav/props/';
CNode := RespNode.AddChild('D:href');
CNode.Text := StringReplace(StartDir SRec.Name, '\', '/', [rfreplaceall, rfignorecase]);
PSNode := RespNode.AddChild('D:propstat');
PropNode := PSNode.AddChild('D:prop');
PropNode.AddChild('lp1:resourcetype').AddChild('D:collection');
CNode := PropNode.AddChild('lp1:creationdate');
CNode.Text := '2016-08-22T07:33:39Z';
CNode := PropNode.AddChild('lp1:getlastmodified');
CNode.Text := 'Mon, 22 Aug 2016 07:33:39 GMT';
if ((SRec.Attr and faDirectory) = faDirectory) then begin
CNode := PropNode.AddChild('D:getcontenttype');
CNode.Text := 'httpd/unix-directory';
end;
CNode := RespNode.AddChild('D:status');
CNode.Text := 'HTTP/1.1 200 OK';
end;
until FindNext(SRec) <> 0;
finally
System.SysUtils.FindClose(SRec)
end;
XML.SaveToStream(Stream);
Result := (Stream.Size > 0);
end;

procedure TfmWebServer.Button1Click(Sender: TObject);
var
Stream: TMemoryStream;
begin
Stream := TMemoryStream.Create();
try
BuildXML(ExcludeTrailingPathDelimiter('C:\Temp\'), StringReplace('\Data\', '/', '\', [rfreplaceall, rfignorecase]), Stream);
except
ShowMessage('Error');
end;
end;

procedure TfmWebServer.IdHTTPServer1CommandOther(AContext: TIdContext;
ARequestInfo: TIdHTTPRequestInfo; AResponseInfo: TIdHTTPResponseInfo);
var
Stream: TMemoryStream;
begin
Memo1.Lines.Add(DateTimeToStr(Now()) ': Other:' ARequestInfo.Command);
Memo1.Lines.Add(DateTimeToStr(Now()) ': Other:' ARequestInfo.Document);
if ARequestInfo.Command = 'PROPFIND' then begin
// 取資料夾
try
// GetFiles(gDocRoot ARequestInfo.Document, FileList);
AResponseInfo.ContentStream := TMemoryStream.Create;
Stream := TMemoryStream.Create;
// try
BuildXML(ExcludeTrailingPathDelimiter('C:\Temp\'), StringReplace('\Data\', '/', '\', [rfreplaceall, rfignorecase]), Stream);
AResponseInfo.ContentType := 'text/html';
AResponseInfo.CharSet := 'utf-8';
AResponseInfo.ContentStream.Position := 0;
// AResponseInfo.ResponseNo := 200;
// AResponseInfo.ContentText := 'HTTP/1.1 207 Multi-Status';
AResponseInfo.WriteHeader();
AResponseInfo.WriteContent();
except
AResponseInfo.ContentType := 'text/html';
AResponseInfo.CharSet := 'utf-8';
AResponseInfo.ResponseNo := 500;
AResponseInfo.ContentText := 'HTTP/1.1 500 Internal server error';
AResponseInfo.ResponseText := 'Internal server error';
Memo1.Lines.Add('Error.......................................');
end;
finally
end;
end;
end;

在 thread 裏, 要使用 COM, 都必需要呼叫 CoInitialize() 和 CoUninitialize()

試試加上 CoInitialize() 和 CoUninitialize() 看看.

procedure TfmWebServer.IdHTTPServer1CommandOther(AContext: TIdContext; ARequestInfo: TIdHTTPRequestInfo; AResponseInfo: TIdHTTPResponseInfo);
begin
CoInitialize(nil);
try
// your codes ...
finally
CoUninitialize();
end;
end;

編輯記錄

Hi,感謝 tick228 先進的指導:
使用 CoInitialize() 和 CoUninitialize() 後可以正常 Work 了,
只是:
1.訊息也太牛頭不對馬嘴了,
2.我在開發的電腦上沒有加CoInitialize() 和 CoUninitialize()卻是可以正常工作的
總之,問題解決了,謝謝!

===================引 用 tick228 文 章===================
在 thread 裏, 要使用 COM, 都必需要呼叫 CoInitialize() 和 CoUninitialize()

試試加上 CoInitialize() 和 CoUninitialize() 看看.

procedure TfmWebServer.IdHTTPServer1CommandOther(AContext: TIdContext; ARequestInfo: TIdHTTPRequestInfo; AResponseInfo: TIdHTTPResponseInfo);
begin
CoInitialize(nil);
try
// your codes ...
finally
CoUninitialize();
end;
end;