{$IFDEF REGION}{$REGION '<!-- ExportToInfoPath -->'}{$ENDIF}
function TForm1.ExportToInfoPath(FileName,
NewFileName: string): Boolean;
var
p, temp: record
L, T, P, O, C, D: Integer;
S: string;
end;
procedure DeletePos(Index, Count: Integer);
begin
if p.L > Index then Dec(p.L, Count);
if p.T > Index then Dec(p.T, Count);
if p.P > Index then Dec(p.P, Count);
if p.O > Index then Dec(p.O, Count);
if p.C > Index then Dec(p.C, Count);
if p.D > Index then Dec(p.D, Count);
end;
procedure InsertPos(Index, Count: Integer);
begin
DeletePos(Index, -Count);
end;
procedure DoDelete(const nName: string; var pI: Integer);
var
I, J: Integer;
begin
I := Pos('<my:'+nName+'>', LowerCase(p.S));
J := Pos('</my:'+nName+'>', LowerCase(p.S));
if (I>0) and (J>I) then
begin
pI := I+5+Length(nName);
Delete(p.S, pI, J-pI);
DeletePos(pI, J-pI);
end;
end;
procedure DoInsert(const nXml: string; pI: Integer);
begin
if pI > 0 then
begin
Insert(nXml, p.S, pI);
InsertPos(pI, Length(nXml));
end;
end;
procedure DoInsertText(nXml: string; pI: Integer);
const
div_Start = '<div xmlns="http://www.w3.org/1999/xhtml">';
div_Stop = '</div>';
var
L: TStringList;
S: string;
I, P: Integer;
begin
nXml := StringReplace(nXml, '&', '&', [rfReplaceAll]);
nXml := StringReplace(nXml, '<', '<', [rfReplaceAll]);
nXml := StringReplace(nXml, '>', '>', [rfReplaceAll]);
L := TStringList.Create;
try
L.Text := nXml;
for I := 0 to L.Count-1 do
begin
S := L[I];
P := Pos(' ', S);
while P > 0 do
begin
Delete(S, P, 1);
Insert(#$C2#$A0, S, P);
P := Pos(' ', S);
end;
if S = '' then S := #$C2#$A0;
L[I] := Concat(div_Start, S, div_Stop);
end;
nXml := L.Text;
finally
L.Free;
end;
DoInsert(nXml, pI);
end;
function DoSave(docXml: string; const nodesXml: string): Boolean;
var
I: Integer;
L: TStringList;
begin
Result := False;
{$IFDEF CIL}
I := Pos('<my:item />', LowerCase(docXml));
{$ELSE}
I := Pos('<my:item/>', LowerCase(docXml));
{$ENDIF}
if I <= 0 then Exit;
Delete(docXml, I, 10);
Insert(nodesXml, docXml, I);
L := TStringList.Create;
try
L.Text := docXml;
L.SaveToFile(NewFileName);
Result := True;
finally
L.Free;
end;
end;
function DoExport: Boolean;
var
ADoc: TXMLDocument;
ANodeF, ANodeN, ANodeL: IXMLNode;
I: Integer;
S: string;
ATodoItem: IMyItem;
begin
Result := False;
ADoc := TXMLDocument.Create(Self);
try
ADoc.Active := True;
ADoc.LoadFromFile(FileName);
ADoc.Active := True;
ANodeF := FindXMLRecurse(ADoc.DocumentElement, 'my:item');
if Assigned(ANodeF) then
begin
ANodeN := ANodeF;
while Assigned(ANodeN) do
begin
ANodeL := ANodeN;
ANodeN := FindXMLRecurse(ANodeN, 'my:item');
end;
ANodeN := ANodeL.ParentNode.AddChild(ANodeL.NodeName);
p.S := (ANodeF.DOMNode as IDOMNodeEx).xml;
p.L := -1; p.T := -1; p.P := -1;
p.O := -1; p.C := -1; p.D := -1;
DoDelete('tag1', p.L);
DoDelete('tag2', p.T);
DoDelete('tag3', p.P);
DoDelete('tag4', p.O);
DoDelete('tag5', p.C);
DoDelete('tag6', p.D);
temp := p;
S := '';
for I := Items.TopItem to Items.Count-1 do
begin
DoInsert(AItem.Get1k, p.L);
DoInsertText(AItem.Get2, p.T);
DoInsert(IntToStr(AItem.Get3), p.P);
DoInsert(AItem.Get4, p.O);
DoInsert(AItem.Get5, p.C);
if AItem.GetItem2 then
DoInsert('true', p.D) else
DoInsert('false', p.D);
S := S+p.S;
p := temp;
end;
Result := DoSave(ADoc.XML.Text, S);
end else
ShowQuestDlg(
'Impossible do export, because form ''%s'''#13#10+
'is empty.', [FileName], 'Unknown append format');
finally
ADoc.Free;
end;
end;
begin
Result := FileExists(FileName);
if Result then
Result := DoExport;
end;
{$IFDEF REGION}{$ENDREGION}{$ENDIF}
|
