I have an assignment in "project management". I have to assign modules which can also be sub-modules, so I want to append recursively sub-modules to modules.
Example:
P(project) Modules(M1,M2,M3,M4). Under M1 Module there will be sub-modules(M1S1,M1S2,M1S3), and under sub-module1 (M1S1) there can be many sub-modules (M1S1S1, M1S1S2, M1S1S3) and so on.
I have done this code using Recursion and TTreeNode but i feel the problem is with condition statement.
procedure TForm2.BitBtn1Click(Sender: TObject);
begin
lGlblProjID := 1;
lGlblProjName := 'Project';
ADOConnectionListner.Connected := true;
try
if ADOConnectionListner.Connected then
begin
RootNode := TreeView2.Items.Add(nil, lGlblProjName);
getSubChild(lGlblProjID, RootNode);
end;
except
on E: Exception do
begin
ShowMessage('Exception Class = ' + E.ClassName);
end;
end;
end;
procedure TForm2.getSubChild(var Pid: Integer; var SubRoot: TTreeNode);
var
lcount, I, lcurrentID: Integer;
lcurrentName: String;
lModuleNode: TTreeNode;
begin
// ShowMessage(IntToStr(Pid)+ ' '+SubRoot.Text);
ADOQuery1.SQL.Clear;
ADOQuery1.SQL.Add('SELECT * FROM treetab Where parent_id =:value1');
ADOQuery1.Parameters.ParamByName('value1').Value := Pid;
ADOQuery1.Active := true;
lcount := ADOQuery1.RecordCount;
for I := 0 to lcount - 1 do
begin
lcurrentID := ADOQuery1.FieldByName('id').AsInteger;
lcurrentName := ADOQuery1.FieldByName('name').AsString;
ShowMessage(' id ' + IntToStr(lcurrentID) + ' dd ' + lcurrentName); // print valu of i
if ((lcurrentID <> 0)and (SubRoot.Text <> '') ) then //or
begin
lModuleNode := TreeView1.Items.AddChild(SubRoot, lcurrentName);
getSubChild(lcurrentID, lModuleNode);
end else // if
// lcurrentID = 0
ShowMessage('end reached');
// TreeView1.Items.AddChild(SubRoot, ADOQuery1.FieldByName('name').AsString);
ADOQuery1.Next;
//*********
end;
end;
I want to retrieve all the sub-modules for a particular project like in this case project with id=1 only.
Your problem seems to be the non-local ADOQuery1 which gets cleared at entry on each recursive call. Therefore you loose all remaining records from a previous query. You should arrange a local storage for the query results.
Something like (untested):
procedure GetSubChild()
type
TTempRecord = record
id: integer;
name: string;
end;
TTempArray = array of TTempRecord;
var
lcount, I, lcurrentID: Integer;
lcurrentName: String;
lModuleNode: TTreeNode;
recs: TTempArray
begin
// ...
// query the db
// ...
lcount := ADOQuery1.RecordCount;
SetLength(recs, lcount);
for i := 0 to lcount-1 do
begin
recs[i].id := ADOQuery1.FieldByName('id').AsInteger;
recs[i].name := ADOQuery1.FieldByName('name').AsString;
ADOQuery1.Next;
end;
for i := 0 to lcount-1 do
begin
lcurrentID := recs[i].id;
lcurrentname := recs[i].name;
// ...
// add to treeview
// call recursively GetSubChild()
// ...
end;
end;
Related
How to switch two nodes in a singly linked list in pascal?
procedure List.switch(var n1,n2 : pNode);
var aux : pNode;
begin
aux := n1;
p1:= n2;
n2 := aux;
end;
(Here pNode is a pointer on a node in the list.)
Nodes are defined like this:
pNode = ^Node;
Node = record
data : data;
next : pNode;
end;
This code doesn't work. It either doesn't compile, saying "Can't take the address of constant expressions", or just doesn't do anything. I guess it has to do with how pointers work...
I found relevant information here, but I don't read C.
Thanks for any advice!
I think something like this would work:
function SwapNodes(first: pNode): pNode;
begin
Result := first.next;
first.next := Result.next;
Result.next := first;
end;
Something like this should work for you. It uses a local variable of type Node (which is presumably what PNode is a pointer to) as a placeholder.
procedure List.Switch(NodeA, NodeB: PNode);
var
Temp: Node;
begin
Temp.Data := NodeB^.Data;
Temp.Next := NodeB^.Next;
NodeB^.Data := NodeA^.Data;
NodeB^.Next := NodeA^.Next;
NodeA^.Data := Temp.Data;
NodeA^.Next := Temp.Next;
end;
Here's a version of it that isn't an object method, with a console app that tests it:
program Project1;
uses
System.SysUtils;
type
PNode = ^Node;
Node = record
Data: Integer;
Next: PNode;
end;
procedure Swap(NodeA, NodeB: PNode);
var
Temp: Node;
begin
Temp.Data := NodeB^.Data;
Temp.Next := NodeB^.Next;
NodeB^.Data := NodeA^.Data;
NodeB^.Next := NodeA^.Next;
NodeA^.Data := Temp.Data;
NodeA^.Next := Temp.Next;
end;
var
A, B: Node;
pA, pB: PNode;
begin
New(pA);
pA^.Data := 1;
pA^.Next := nil;
New(pB);
pB^.Data := 2;
pB^.Next := #A;
WriteLn('Before - pA^.Data: ', pA^.Data, ' pB^.Data: ', pB^.Data);
Swap(pA, pB);
WriteLn('After - pA^.Data: ', pA^.Data, ' pB^.Data: ', pB^.Data); // Outputs 2 and 1
Readln;
Dispose(pA);
Dispose(pB);
end.
I need to browse items of a treeview, without using recursion, for performance reasons.
TTreeview provides GlobalCount and ItemByGlobalIndex methods, but it only returns visible items
I searched the root class code without finding a private list of all nodes, FGlobalItems seems to only holds items that need to be rendered
Is there a way to sequentially browse all items (including not visible and collapsed nodes) of a treeview?
This question applies to Delphi XE3 / FM2
Thanks,
[Edit Feb 3]
I accepted the default answer (not possible out of the box), despite I was looking for a way to patch the firemonkey treeview on this aspect.
After more analysis, I found out that the FGlobalItems list only holds expanded items and is maintained in the method TCustomTreeView.UpdateGlobalIndexes;
Commenting line 924 of FMX.TreeView (if AItem.IsExpanded then...) leads to building a full index of nodes, and allows to browse all nodes sequentially using ItemByGlobalIndex(), BUT could lead to other performance issues and bugs...Without any more clue, I'll keep my recursive code.
Here are my functions for walking a treeview in a non-recursive manner. Simple to use if you have a node and want to move to the next or previous one without having to walk the entire tree.
GetNextItem functions by looking at it's first child, or if no children, looking at it's parent for the next child after itself (and going further through parents as necessary).
GetPrevItem looks at the parent to find the previous item, and uses GetLastChild to find the last child of that item (which does use recursion, BTW).
Note that the code as written only walk Expanded nodes, but can easily be modified to walk all nodes (just remove references to IsExpanded).
function GetLastChild(Item: TTreeViewItem): TTreeViewItem;
begin
if (Item.IsExpanded) and (Item.Count > 0) then
Result := GetLastChild(Item.Items[Item.Count-1])
else
Result := Item;
end;
function GetNextItem(Item: TTreeViewItem): TTreeViewItem;
var ItemParent: TTreeViewItem;
I: Integer;
TreeViewParent: TTreeView;
Parent: TFMXObject;
Child: TFMXObject;
begin
if Item = nil then
Result := nil
else if (Item.IsExpanded) and (Item.Count > 0) then
Result := Item.Items[0]
else
begin
Parent := Item.Parent;
Child := Item;
while (Parent <> nil) and not (Parent is TTreeView) do
begin
while (Parent <> nil) and not (Parent is TTreeView) and not (Parent is TTreeViewItem) do
Parent := Parent.Parent;
if (Parent <> nil) and (Parent is TTreeViewItem) then
begin
ItemParent := TTreeViewItem(Parent);
I := 0;
while (I < ItemParent.Count) and (ItemParent.Items[I] <> Child) do
inc(I);
inc(I);
if I < ItemParent.Count then
begin
Result := ItemParent.Items[I];
EXIT;
end;
Child := Parent;
Parent := Parent.Parent
end;
end;
if (Parent <> nil) and (Parent is TTreeView) then
begin
TreeViewParent := TTreeView(Parent);
I := 0;
while (I < TreeViewParent.Count) and (TreeViewParent.Items[I] <> Item) do
inc(I);
inc(I);
if I < TreeViewParent.Count then
Result := TreeViewParent.Items[I]
else
begin
Result := Item;
EXIT;
end;
end
else
Result := Item
end
end;
function GetPrevItem(Item: TTreeViewItem): TTreeViewItem;
var Parent: TFMXObject;
ItemParent: TTreeViewItem;
TreeViewParent: TTreeView;
I: Integer;
begin
if Item = nil then
Result := nil
else
begin
Parent := Item.Parent;
while (Parent <> nil) and not (Parent is TTreeViewItem) and not (Parent is TTreeView) do
Parent := Parent.Parent;
if (Parent <> nil) and (Parent is TTreeViewItem) then
begin
ItemParent := TTreeViewItem(Parent);
I := 0;
while (I < ItemParent.Count) and (ItemParent.Items[I] <> Item) do
inc(I);
dec(I);
if I >= 0 then
Result := GetLastChild(ItemParent.Items[I])
else
Result := ItemParent;
end
else if (Parent <> nil) and (Parent is TTreeView) then
begin
TreeViewParent := TTreeView(Parent);
I := 0;
while (I < TreeViewParent.Count) and (TreeViewParent.Items[I] <> Item) do
inc(I);
dec(I);
if I >= 0 then
Result := GetLastChild(TreeViewParent.Items[I])
else
Result := Item
end
else
Result := Item;
end;
end;
The question essentially asks how to traverse a tree without recursion. There are many ways to traverse a tree; the fact that your tree happens to be represented with nodes in a visual control is irrelevant.
For some algorithms, it's easier to think of the traversal in recursive terms. That way, you let the programming language keep track of where in the tree you are by keeping the currently active node as an argument on the stack. If you don't want to use recursion, then you simply have to keep track of the progress yourself. Common tools for that include stacks and queues.
A preorder traversal means that when you visit a node, you do your action on that node's data before doing the action on the node's children. It corresponds to visiting each node of a tree-view control from top to bottom. You could implement it like this with a stack:
procedure PreorderVisit(Node: TTreeNode; Action: TNodeAction);
var
Worklist: TStack<TTreeNode>;
i: Integer;
begin
Worklist := TStack<TTreeNode>.Create;
try
Worklist.Push(Node);
repeat
Node := Worklist.Pop;
for i := Pred(Node.Items.Count) downto 0 do
Worklist.Push(Node.Items[i]);
Action(Node);
until Worklist.Empty;
finally
Worklist.Free;
end;
end;
Push the children onto the stack in reverse order so they'll be popped off in the desired order.
In that code, Action stands for whatever task you need to do with each node. You can either use it as specified in the code, as an external function, or you can write a specialized version of PreorderVisit that includes the task-specific code.
TTreeView doesn't actually represent a tree, though. It's really a forest (a collection of trees). That's because there is no single node that represents the root. You can easily use the function above to process all the nodes in a tree, though:
procedure PreorderVisitTree(Tree: TTreeView; Action: TNodeAction);
var
i: Integer;
begin
for i := 0 to Pred(Tree.Items.Count) do
PreorderVisit(Tree.Items[i], Action);
end;
Another way of doing a preorder traversal that takes advantage of the specific structure of TTreeView is to use the built-in GetNext method of each node:
procedure PreorderVisitTree(Tree: TTreeView; Action: TNodeAction);
var
Node: TTreeNode;
begin
if Tree.Items.Count = 0 then
exit;
Node := Tree.Items[0];
repeat
Action(Node);
Node := Node.GetNext;
until not Assigned(Node);
end;
There appears to be no way of getting hidden nodes of a Firemonkey tree view. You might find better results by iterating over your internal tree data structure instead of trying to extract information from the GUI.
In XE8 this works for me:
function GetNextItem(Item: TTreeViewItem): TTreeViewItem;
var
Parent: TFMXObject;
Child: TTreeViewItem;
begin
Result := nil;
if Item.Count > 0 then
Result := Item.Items[0]
else
begin
Parent := Item.ParentItem;
Child := Item;
while (Result = nil) and (Parent <> nil) do
begin
if Parent is TTreeViewItem then
begin
if TTreeViewItem(Parent).Count > (Child.Index + 1) then
Result := TTreeViewItem(Parent).Items[Child.Index + 1]
else
begin
Child := TTreeViewItem(Parent);
if Child.ParentItem <> nil then
Parent := Child.ParentItem
else
Parent := Child.TreeView;
end;
end
else
begin
if TTreeView(Parent).Count > Child.Index + 1 then
Result := TTreeView(Parent).Items[Child.Index + 1]
else
Parent := nil;
end;
end;
end;
end;
The Item.ParentItem can also be nil! That is why I had replaced the line Parent := Item.ParentItem with the following lines:
if Item.ParentItem <> nil then
Parent := Item.ParentItem
else
Parent := Item.TreeView;
The complete function GetNextItem after the correction:
function GetNextItem(Item: TTreeViewItem): TTreeViewItem;
var
Parent: TFMXObject;
Child: TTreeViewItem;
begin
Result := nil;
if Item.Count > 0 then
Result := Item.Items[0]
else begin
if Item.ParentItem <> nil then
Parent := Item.ParentItem
else
Parent := Item.TreeView;
Child := Item;
while (Result = nil) and (Parent <> nil) do
begin
if Parent is TTreeViewItem then
begin
if TTreeViewItem(Parent).Count > (Child.Index + 1) then
Result := TTreeViewItem(Parent).Items[Child.Index + 1]
else begin
Child := TTreeViewItem(Parent);
if Child.ParentItem <> nil then
Parent := Child.ParentItem
else
Parent := Child.TreeView;
end;
end else begin
if TTreeView(Parent).Count > Child.Index + 1 then
Result := TTreeView(Parent).Items[Child.Index + 1]
else
Parent := nil;
end;
end;
end;
end;
Tested at Delphi 10.3.2
I would add a function to SEARCH PARTIALLY a text into a TreeView, from a TEdit (Search) placed up from the TreeView (TV). (special thank to the previous post which this answer is based from)
This work perfectly using Enter to start the search and F3 to continue searching.
// SEARCH ITEM (text partially or by particular ID in item.tag)
function GetNextItem(Item: TTreeViewItem): TTreeViewItem;
var
Parent: TFMXObject;
Child: TTreeViewItem;
begin
Result := nil;
if Item.Count > 0 then
Result := Item.Items[0]
else begin
if Item.ParentItem <> nil then
Parent := Item.ParentItem
else
Parent := Item.TreeView;
Child := Item;
while (Result = nil) and (Parent <> nil) do
begin
if Parent is TTreeViewItem then
begin
if TTreeViewItem(Parent).Count > (Child.Index + 1) then
Result := TTreeViewItem(Parent).Items[Child.Index + 1]
else begin
Child := TTreeViewItem(Parent);
if Child.ParentItem <> nil then
Parent := Child.ParentItem
else
Parent := Child.TreeView;
end;
end else begin
if TTreeView(Parent).Count > Child.Index + 1 then
Result := TTreeView(Parent).Items[Child.Index + 1]
else
Parent := nil;
end;
end;
end;
end;
function FindItem(aFromItem : TTreeViewItem ; Value: String = '' ; aID : integer = -1) : TTreeViewItem;
var I: Integer;
begin
Result := nil;
while aFromItem.Index < aFromITem.TreeView.Count do
begin
aFromItem := GetNextItem(aFromItem);
if aFromItem <> nil then
begin
if (aID <> -1) and (aFromItem.Tag = aID) then
begin
Result := aFromItem;
EXIT;
end
else if pos(Value, uppercase(aFromItem.Text)) > 0 then
begin
Result := aFromItem;
EXIT;
end;
end
else
exit;
end;
end;
procedure TCListeMedia.SearchKeyDown(Sender: TObject; var Key: Word; var KeyChar: Char; Shift: TShiftState);
var
i : integer;
vSearch : string;
begin
if (Key = 13) or (Key = vkF3) then
begin
// Search or continue to search
vSearch := Uppercase(Search.Text);
if Key = 13 then
begin
i := 0;
if TV.Count > 0 then
begin
if pos(vSearch, uppercase(TV.Items[0].Text)) > 0 then
TV.Selected := TV.Items[0]
else
TV.Selected := FindItem(TV.Items[0], vSearch);
end;
end
else if TV.Selected <> nil then
begin
i := 1 + TV.Selected.Index;
TV.Selected := FindItem(TV.Selected, vSearch);
end;
end;
end;
procedure TCListeMedia.TVKeyDown(Sender: TObject; var Key: Word; var KeyChar: Char; Shift: TShiftState);
begin
if (Key = vkF3) then
SearchKeyDown(Sender, Key, KeyChar, Shift);
end;
I have made this function for my project is fast and easy you can try it
function FindItem(const TreeView: TTreeView; const Value: Variant): TTreeViewItem;
function ItemExist(const AItem: TTreeViewItem): Boolean;
begin
Result:= False;
if AItem <> nil then
begin
{Set your condition here}
if AItem.Text = Value then
begin
FindItem:= AItem;
Exit(True);
end;
var I: Integer;
for I := 0 to AItem.Count - 1 do
begin
if ItemExist( AItem.ItemByIndex(I)) then
Break;
end;
end;
end;
var
AItem: TTreeViewItem;
I: Integer;
begin
Result:= nil;
for I := 0 to TreeView.Count - 1 do
begin
AItem:= TreeView.ItemByIndex(I);
if ItemExist(AItem) or (Result <> nil) then Break;
end;
end;
I take advantage of class helpers and anonymous procedures in Delphi to loop through items in a TreeView. This can be easilly extended to build an index list.
My class helper goes like this:
{ TTreeViewHelper }
TTreeViewHelper
= Class helper for FMX.TreeView.TTreeView
Public
Procedure LoopThroughItems(const Func: TProc<TTreeViewItem>; const AExpandedOnly: Boolean);
End;
Procedure TTreeViewHelper.LoopThroughItems(const Func: TProc<TTreeViewItem>; const AExpandedOnly: Boolean);
var
i : integer;
procedure ProcessItem(const AItem: TTreeViewItem);
var
I: Integer;
begin
if(AItem=nil) then exit;
Func(AItem);
for I := 0 to AItem.Count - 1 do ProcessItem(AItem.ItemByIndex(I));
end;
begin
if not Assigned(Func)then exit;
if(GlobalCount<1)then exit;
if(AExpandedOnly)
then for i:=0 to Count-1 do Func(self.Items[i])
else for i:=0 to Count-1 do ProcessItem(ItemByGlobalIndex(i));
end;
And I am using it like this:
TreeView1.LoopThroughItems(
procedure(E: TTreeViewItem)
begin
if Assigned(E)and(E is TTreeNode)
then TN := E as TTreeNode { My own subclass }
else exit;
if Assigned(TN.DataObject)and(TN.DataObject is TIOTSensorData)
then IOT := TN.DataObject as TIOTSensorData
else exit;
if(IOT<>AFormula)then exit;
TreeView1.Selected := TN;
end,
False
);
The sample above is from my actual project, you would use your own logic in the anonymous procedure, but the really neat part is the last TreeView1.Selected := TN;, becasue even if the TN is a non-visible item, the TreeView will select it and expand all its parent nodes.
Now, you say you want to avoid recursion, but actually you want to avoid a recursive recursion. Because you'll have to build your index first, and while building it is okay to use recursion one time in there.
Following the same approach, just go ahead and add a new method to your class helper:
{ TTreeViewHelper }
TTreeViewHelper
= Class helper for FMX.TreeView.TTreeView
Public
Procedure LoopThroughItems(const Func: TProc<TTreeViewItem>; const AExpandedOnly: Boolean);
Function BuildFullIndex: TList<TTreeViewItem>;
End;
Function TTreeViewHelper.BuildFullIndex: TList<TTreeViewItem>;
var
i : integer;
procedure Publish(const AItem: TTreeViewItem);
var
I: Integer;
begin
if(AItem=nil) then exit;
Result.Add(AItem);
for I := 0 to AItem.Count - 1 do Publish(AItem.ItemByIndex(I));
end;
begin
Result := TList<TTreeViewItem>.Create;
if(GlobalCount<1)then exit;
for i:=0 to Count-1 do Publish(ItemByGlobalIndex(i))
end;
And use it like this:
uses
System.Generics.Collections;
var
Index : TList<TTreeViewItem>;
begin
Index := Formulas.BuildFullIndex;
try
if(Index.Count<1)then exit;
for i:=0 to Index.Count-1 do
begin
{ do your thing here }
end;
finally
FreeAndNil(Index);
end;
end;
Cheers!
I have a function declare like this :
function execProc(ProcName,InValues:PChar;out OutValues:PChar):integer; //The "OutValues" is a out parameter.
And I call this function like this:
procedure TForm1.Button6Click(Sender: TObject);
var
v:integer;
s:pchar;
begin
Memo1.Clear;
v := execProc(pchar('PROC_TEST'),pchar('aaa'),s);
showmessage(inttostr(v)); //mark line
Memo1.Lines.Add(strpas(s));
end;
when i delete the mark line(showmessage(inttostr(v))),i will have a correct result display in the Memo1,but if i keep use the showmessage(), the memo1 will dispaly an error string : "Messag" ,Why?
Thanks for any help!
function execProc(ProcName,InValues:PChar;out OutValues:PChar):integer;
var
str: TStrings;
InValue,OutValue: string;
i,j,scount: integer;
begin
Result := -100;
i := 0;
j := 0;
str := TStringList.Create;
try
sCount := ExtractStrings(['|'], [], InValues, str);
with kbmMWClientStoredProc1 do
begin
Close;
Params.Clear;
StoredProcName := StrPas(ProcName);
FieldDefs.Updated := False;
FieldDefs.Update;
for i := 0 to Params.Count - 1 do
begin
if (Params[i].ParamType = ptUnknown) or
(Params[i].ParamType = ptInput) or
(Params[i].ParamType = ptInputOutput) then
begin
inc(j);
InValue := str[j-1];
Params[i].Value := InValue;
end;
end;
try
ExecProc;
for i := 0 to Params.Count - 1 do
begin
if (Params[i].ParamType = ptOutput) or
(Params[i].ParamType = ptInputOutput) then
OutValue := OutValue + '|' + Params[i].AsString;
end;
OutValues := PChar(Copy(OutValue,2,Length(OutValue)-1));
Result := 0;
except
on E:Exception do
begin
if E.Message = 'Connection lost.' then Result := -101;//服务器连接失败
if E.Message = 'Authorization failed.' then Result := -102;//身份验证失败
Writelog(E.Message);
end;
end;
end;
finally
str.Free;
end;
end;
The problem is in the design of your interface and the use of PChar.
OutValues := PChar(Copy(OutValue,2,Length(OutValue)-1));
This is implemented by making an implicit, hidden, local string variable which holds the value
Copy(OutValue,2,Length(OutValue)-1)
When the function returns, that string variable is destroyed and so OutValues points at deallocated memory. Sometimes your program appears to work but that's really just down to chance. Any small change can disturb that, as you have observed.
The problem is easy enough to fix. Simply use string parameters rather than PChar. This will make the code easier to read as well as making it work correctly.
function execProc(ProcName, InValues: string; out OutValues: string): integer;
I am pretty "green" at programming and I've to bring assignment tomorrow. It is almost complete but there is a slight problem. I cannot remove the first element and if after trying to delete first element I input
a new one in its place mmm.... lets just say I input infinitely many of them instead. I cant seem to find what is the problem. Thanks in advance
program dvipsar;
type duomenys = integer;
sarasas = ^elementas;
elementas = record
info: duomenys;
anks: sarasas;
tolsn: sarasas
end;
procedure sukurtiTuscia(var s: sarasas); {creates empty list}
begin
s := nil
end;
function tuscias(s: sarasas): boolean; {checks if list is empty}
begin
tuscias := s = nil
end;
function elmSk(s: sarasas): integer; {counts elements}
var kiek: integer;
begin
kiek := 0;
while s <> nil do
begin
kiek := kiek + 1;
s := s^.tolsn
end;
elmSk := kiek
end;
function gautiRodN(s: sarasas; n:integer): sarasas; {Arrow to n-th element}
var i: integer;
begin
i := 1;
while (s <> nil) and (i<n) do
begin
i := i + 1;
s := s^.tolsn
end;
if i = n then gautiRodN := s
else gautiRodN := nil
end;
function gautiN(s: sarasas; n:integer): duomenys; {gets n-th element data}
var elem: sarasas;
begin
elem := gautiRodN(s,n);
if elem <> nil then gautiN := elem^.info
end;
procedure iterptiPries(s:sarasas; n: integer; duom: duomenys); {adds new element before n-th element}
var nElem: sarasas;
naujas: sarasas;
begin
nElem := gautiRodN(s,n);
if nElem <> nil then begin
new (naujas);
naujas^.info := duom;
naujas^.tolsn := nElem;
naujas^.anks := nElem^.anks;
if nElem^.anks <> nil then nElem^.anks^.tolsn := naujas;
nElem^.anks := naujas;
end
end;
procedure panaikintiN(s: sarasas; n: integer); {removes element from n-th place}
var nElem: sarasas;
begin
nElem := gautiRodN(s,n);
if nElem <> nil then begin
if nElem^.anks <> nil then nElem^.anks^.tolsn := nElem^.tolsn;
if nElem^.tolsn <> nil then nElem^.tolsn^.anks := nElem^.anks;
dispose(nElem);
end;
end;
function rasti(s: sarasas; duom: duomenys): sarasas; {finds element}
begin
while (s <> nil) and (s^.info <> duom) do s := s^.tolsn;
rasti := s
end;
procedure spausdinti(s: sarasas); {prints list}
begin
while (s <> nil) do begin
write(s^.info,' ');
s := s^.tolsn
end;
writeln
end;
procedure panaikintiP(var s: sarasas); {removes first element}
var pirmas: sarasas;
begin
pirmas := s;
s := s^.tolsn;
dispose (pirmas)
end;
procedure panaikinti(var s: sarasas); {deletes list}
begin
while s <> nil do panaikintiP(s)
end;
procedure prideti(var s: sarasas; duom: duomenys); {add element at the end of the list}
var kiek: integer;
paskutinis,naujas: sarasas;
begin
kiek := elmSk(s);
paskutinis := gautiRodN(s,kiek);
new(naujas);
naujas^.info := duom;
naujas^.tolsn := nil;
naujas^.anks := paskutinis;
if paskutinis <> nil then paskutinis^.tolsn := naujas
else s := naujas
end;
procedure menu;
begin
writeln;
writeln;
writeln ('1 Creat a list');
writeln ('2 Count the elements');
writeln ('3 Check if list is empty');
writeln ('4 Print an element');
writeln ('5 Print the list');
writeln ('6 Remove an element')
writeln ('7 Add an element');
writeln ('8 Search in the list');
writeln;
writeln ('0 End');
writeln;
writeln;
end;
var s: sarasas;
i,j: integer;
t: sarasas;
c: char;
veiksmas: integer;
begin
sukurtiTuscia(s);
repeat
menu;
write('Input action number : ');
readln(veiksmas);
case veiksmas of
1:
repeat
write('input a number which you want to add to the list: ');
readln(i);
prideti(s,i);
write('Add new number? (t/n)? ');
read(c);
until (c='N') or (c='n');
2: writeln ('List is not empty: ',elmSk(s));
3: if tuscias(s) then writeln ('List is empty')
else writeln ('List is not empty');
4: begin
write ('Which element to print?: ');
readln(i);
writeln(i,'-th list element?: ',gautiN(s,i));
end;
5: spausdinti(s);
6: begin
write ('which element to remove?: ');
readln(i);
panaikintiN(s,i);
end;
7:begin
write ('What to add to the list?: ');
readln(i);
write ('Before which element?: ');
readln(j);
iterptiPries(s,j,i);
end;
8: begin
write ('What element to look for?: ');
readln(i);
t := rasti(s,i);
if t <> nil then writeln (i, ' exists in the list')
else writeln (i, ' does not exists in the list');
end;
0: writeln ('Ending');
else writeln('Incorrect action');
end;
until veiksmas = 0;
panaikinti(s); {deletes list}
end.
http://en.wikipedia.org/wiki/Doubly_linked_list#Removing_a_node
Removal of a node is easier than insertion, but requires special handling if the node to be removed is the firstNode or lastNode:
function remove(List list, Node node)
if node.prev == null
list.firstNode := node.next
else
node.prev.next := node.next
if node.next == null
list.lastNode := node.prev
else
node.next.prev := node.prev
destroy node
One subtle consequence of the above procedure is that deleting the last node of a list sets both firstNode and lastNode to null, and so it handles removing the last node from a one-element list correctly.
Notice that we also don't need separate "removeBefore" or "removeAfter" methods, because in a doubly linked list we can just use "remove(node.prev)" or "remove(node.next)" where these are valid.
This also assumes that the node being removed is guaranteed to exist.
If the node does not exist in this list, then some error handling would be required.
I am trying to find out which form and element belongs too. The code that I now understand from this website:
http://www.cryer.co.uk/brian/delphi/twebbrowser/read_write_form_elements.htm
containing this code
function GetFormFieldNames(fromForm: IHTMLFormElement): TStringList;
var
index: integer;
field: IHTMLElement;
input: IHTMLInputElement;
select: IHTMLSelectElement;
text: IHTMLTextAreaElement;
begin
result := TStringList.Create;
for index := 0 to fromForm.length do
begin
field := fromForm.Item(index,'') as IHTMLElement;
if Assigned(field) then
begin
if field.tagName = 'INPUT' then
begin
// Input field.
input := field as IHTMLInputElement;
result.Add(input.name);
end
else if field.tagName = 'SELECT' then
begin
// Select field.
select := field as IHTMLSelectElement;
result.Add(select.name);
end
else if field.tagName = 'TEXTAREA' then
begin
// TextArea field.
text := field as IHTMLTextAreaElement;
result.Add(text.name);
end;
end;
end;
end;
seems to be working fine for most sites. However there are a few websites such as this one:
http://service.mail.com/registration.html#.1258-bluestripe-product1-undef
By looking at that code and comparing it with the active id, I can find the form it is in. However it does not work for that website. for some reason I think it has to do with htmldocument3 adn that this code is for htmldocument2. But I am not sure.
so my question is How can I extract a tstringlist from this website with all the elements names in them? hope you can help!
Edited: Added some code
begin
theForm := GetFormByNumber(webbrowser1.document as IHTMLDocument2,
0);
fields := GetFormFieldNames(theForm);
num := fields.IndexOf(theid);
end;
until (num <> -1);
One complication with locating form elements in a web page is that the page may contain frames and there may be forms in any of the frames. Basically, you have to iterate through all the frames and the forms in each frame. Once you get the form as an IHTMLFormElement, use Cryer's function to get the form element names.
The example link you gave does not have any frames and you should have had no problems getting your list of form elements, unless you tried to get the form by name because it had no name assigned. I had no problem getting the form element names and values using the following procedure
procedure GetForms(doc1: IHTMLDocument2; var sl: TStringList);
var
i, j, n: integer;
docForm: IHTMLFormElement;
slt: TStringList;
s: string;
begin
if doc1 = nil then
begin
ShowMessage('doc1 is empty [GetForms]');
Exit;
end;
slt := TStringList.Create;
n := NumberOfForms(doc1);
sl.Add('Forms: ' + IntToStr(n));
for i := 0 to n - 1 do
begin
docForm := GetFormByNumber(doc1, i);
sl.Add('Form Name: ' + docForm.Name);
slt.Clear;
slt := GetFormFieldNames(docForm);
for j := 0 to slt.Count - 1 do
begin
s := GetFieldValue(docForm, slt[j]);
sl.Add('Field Name: ' + slt[j] + ' value: "' + s + '"');
end;
end;
sl.Add('');
slt.Free;
end;
Cryer's example for navigating a frameset will not work for all web sites, see http://support.microsoft.com/support/kb/articles/Q196/3/40.ASP. The following function successfuly extracts a frame as an IHTMLDocument2 on all sites I have tried
function GetFrameByNumber(Doc:IHTMLDocument2; n:integer):IHTMLDocument2;
var
Container: IOleContainer;
Enumerator: ActiveX.IEnumUnknown;
Unknown: IUnknown;
Browser: IWebBrowser2;
Fetched: Longint;
NewDoc: IHTMLDocument2;
i : integer;
begin
// We cannot use the document's frames collection here, because
// it does not work in every case (i.e. Documents from a foreign domain).
// From: http://support.microsoft.com/support/kb/articles/Q196/3/40.ASP
i := 0;
if (Supports(Doc, IOleContainer, Container)) and
(Container.EnumObjects(OLECONTF_EMBEDDINGS, Enumerator) = S_OK) then
begin
while Enumerator.Next(1, Unknown, #Fetched) = S_OK do
begin
if (Supports(Unknown, IWebBrowser2, Browser)) and
(Supports(Browser.Document, IHTMLDocument2, NewDoc)) then
begin
// Here, NewDoc is an IHTMLDocument2 that you can query for
// all the links, text edits, etc.
if i=n then
begin
Result := NewDoc;
Exit;
end;
i := i+1;
end;
end;
end;
end;
Here is an example of how I have used GetForms and GetFrameByNumber
// from the TForm1 declaration
{ Public declarations }
wdoc: IHTMLDocument2;
procedure TForm1.btnAnalyzeClick(Sender: TObject);
begin
wdoc := WebBrowser.Document as IHTMLDocument2;
GetDoc(wdoc);
end;
procedure TForm1.GetDoc(doc1: IHTMLDocument2);
var
i, n: integer;
doc2: IHTMLDocument2;
frame_dispatch: IDispatch;
frame_win: IHTMLWindow2;
ole_index: olevariant;
sl: TStringList;
begin
if doc1 = nil then
begin
ShowMessage('Web doc is empty');
Exit;
end;
Form2.Memo1.Lines.Clear;
sl := TStringList.Create;
n := doc1.frames.length;
sl.Add('Frames: ' + IntToStr(n));
// check each frame for the data
if n = 0 then
GetForms(doc1, sl)
else
for i := 0 to n - 1 do
begin
sl.Add('--Frame: ' + IntToStr(i));
ole_index := i;
frame_dispatch := doc1.Frames.Item(ole_index);
if frame_dispatch <> nil then
begin
frame_win := frame_dispatch as IHTMLWindow2;
doc2 := frame_win.document;
// sl.Add(doc2.body.outerHTML);
GetForms(doc2,sl);
GetDoc(doc2);
end;
end;
// Form2 just contains a TMemo
Form2.Memo1.Lines.AddStrings(sl);
Form2.Show;
sl.Free;
end;
The logic in your example is faulty, 1. when there is only 1 form on the web page the list of form elements is never extracted, 2. the repeat loop will result in a access violation unless the the tag in "theid" is found
Here is your example cut down to successfully extract the form elements.
var
i : integer;
nforms : integer;
document : IHTMLDocument2;
theForm : IHTMLFormElement;
fields : TStringList;
theform1 : integer;
num : integer;
theid : string;
begin
fields := TStringList.Create;
theid := 'xx';
// original code follows
i := -1;
// nforms := NumberOfForms(webbrowser1.document as IHTMLDocument2);
// document := webbrowser1.document as IHTMLDocument2;
// if nforms = 1 then
// begin
// theForm := GetFormByNumber(webbrowser1.document as IHTMLDocument2, 0);
// theform1 := 0;
// end
// else
begin
// repeat
begin
inc(i);
theForm := GetFormByNumber(webbrowser1.document as IHTMLDocument2,
i);
fields := GetFormFieldNames(theForm);
num := fields.IndexOf(theid);
theform1 := i;
end;
// until (num <> -1);
end;
// end of original code
Memo1.Lines.Text := fields.Text;
fields.Free;
end;
Hm, are you sure this link contains any form elements? At least I did not see any visible ones. Perhaps they are hidden - did not check this myself, however.
Michael