why when we do ttexture.assign(aTBitmap) then the bitmap data is not copied in the texture if TCanvasStyle.NeedGPUSurface is set. If we do the same with a TBitmapSurface then the data is copied... why such strange behavior ?
procedure TTexture.Assign(Source: TPersistent);
var
M: TBitmapData;
begin
if Source is TBitmap then
begin
if FHandle <> 0 then
TContextManager.DefaultContextClass.FinalizeTexture(Self);
FPixelFormat := TBitmap(Source).PixelFormat;
FStyle := [TTextureStyle.Dynamic];
FTextureScale := TBitmap(Source).BitmapScale;
SetSize(TBitmap(Source).Width, TBitmap(Source).Height);
if not (TCanvasStyle.NeedGPUSurface in TBitmap(Source).CanvasClass.GetCanvasStyle) then
begin
if TBitmap(Source).Map(TMapAccess.Read, M) then
try
UpdateTexture(M.Data, M.Pitch);
finally
TBitmap(Source).Unmap(M);
end;
end;
end else if Source is TBitmapSurface then
begin
if FHandle <> 0 then
TContextManager.DefaultContextClass.FinalizeTexture(Self);
FStyle := [TTextureStyle.Dynamic];
SetSize(TBitmapSurface(Source).Width, TBitmapSurface(Source).Height);
UpdateTexture(TBitmapSurface(Source).Bits, TBitmapSurface(Source).Pitch);
end else
inherited ;
end;
Related
This code generates an error:
Debugger Exception Notification
Project Project3.exe raised exception class $C0000005 with message 'access violation at 0x7757e12c: write of address 0x00000014'.
if Fowner_draw then
begin
canvas.CopyRect(ClientRect, FOD_canvas, ClientRect);
end
I found the solution by deleting pasteBmp.free; line from the code below. It seems like each time copyRect is called the value of FOD_canvas field is assigned again.
procedure Tncrtile.copy_rect(Cimage:timage; source:trect; dest:trect);
var
copyBmp,pasteBmp: TBitmap;
begin
if (Cimage.Picture.Graphic <> nil) and not Cimage.Picture.Graphic.Empty then
begin
copyBmp:=TBitmap.Create;
pasteBmp:=TBitmap.Create;
try
copyBmp.Height:=Cimage.Height;
copyBmp.Width:=Cimage.Width;
pasteBmp.Height:=source.Height;
pasteBmp.Width:=source.Width;
copyBmp.canvas.Draw(0, 0, Cimage.Picture.Graphic);
pasteBmp.Canvas.CopyRect(rect(0, 0, source.Width, source.Height), copyBmp.Canvas, source);
FOD_canvas:=pasteBmp.Canvas;
finally
copyBmp.free;
pasteBmp.free;
end;
Fdrawing_rect:=dest;
Fowner_draw:=true;
invalidate;
end;
end;
Why is this happening? I tried googling and the Delphi help.
As stated in comments, the error is because you are keeping a reference to a destroyed TCanvas and then trying to draw with it. You need to keep a copy of the actual TBitmap instead and then you can draw with it when needed:
constructor Tncrtile.Create(AOwner: TComponent);
begin
inherited;
FOD_Bmp := TBitmap.Create;
end;
destructor Tncrtile.Destroy;
begin
FOD_Bmp.Free;
inherited;
end;
procedure Tncrtile.copy_rect(Cimage: TImage; Source, Dest: TRect);
var
copyBmp, pasteBmp: TBitmap;
begin
if (Cimage.Picture.Graphic <> nil) and (not Cimage.Picture.Graphic.Empty) then
begin
copyBmp := TBitmap.Create;
pasteBmp := TBitmap.Create;
try
copyBmp.Height := Cimage.Height;
copyBmp.Width := Cimage.Width;
pasteBmp.Height := Source.Height;
pasteBmp.Width := Source.Width;
copyBmp.Canvas.Draw(0, 0, Cimage.Picture.Graphic);
pasteBmp.Canvas.CopyRect(Rect(0, 0, Source.Width, Source.Height), copyBmp.Canvas, Source);
FOD_Bmp.Assign(pasteBmp);
finally
copyBmp.Free;
pasteBmp.Free;
end;
Fdrawing_rect := Dest;
Fowner_draw := True;
Invalidate;
end;
end;
...
if Fowner_draw and (not FOD_BMP.Empty) then
begin
Canvas.CopyRect(ClientRect, FOD_Bmp.Canvas, ClientRect);
end
How a FMX.Graphics.TBitmap can be converted to VCL.Graphics.TBitmap or Vcl.Imaging.PngImage.TPngImage?
I have both FMX form and VCL form in my project.
Thanks to David Heffernan and some search I wrote these functions as following.
I first come up with the function that doesn't support Alpha
function ConvertFmxBitmapToVclBitmap(b:FMX.Graphics.TBitmap):Vcl.Graphics.TBitmap;
var
data:FMX.Graphics.TBitmapData;
i,j:Integer;
AlphaColor:TAlphaColor;
begin
Result:=VCL.Graphics.TBitmap.Create;
Result.SetSize(b.Width,b.Height);
if(b.Map(TMapAccess.Readwrite,data))then
try
for i := 0 to data.Height-1 do begin
for j := 0 to data.Width-1 do begin
AlphaColor:=data.GetPixel(i,j);
Result.Canvas.Pixels[i,j]:=
RGB(
TAlphaColorRec(AlphaColor).R,
TAlphaColorRec(AlphaColor).G,
TAlphaColorRec(AlphaColor).B);
end;
end;
finally
b.Unmap(data);
end;
end;
and I wrote the second function to convert FMX.Graphics.TBitmap to Vcl.Imaging.PngImage.TPngImage and it supports Alpha.
function ConvertFmxBitmapToPng(b:FMX.Graphics.TBitmap):Vcl.Imaging.PngImage.TPngImage;
var
data:FMX.Graphics.TBitmapData;
i,j:Integer;
AlphaColor:TAlphaColor;
AlphaLine:VCL.Imaging.PngImage.pByteArray;
begin
result:=TPngImage.CreateBlank(COLOR_RGBALPHA, 8, b.Width, b.Height);;
if(b.Map(TMapAccess.Readwrite,data))then
try
for i := 0 to data.Height-1 do begin
AlphaLine:=Result.AlphaScanline[i];
for j := 0 to data.Width-1 do begin
AlphaColor:=data.GetPixel(j,i);
AlphaLine^[j]:=TAlphaColorRec(AlphaColor).A;
Result.Pixels[j,i]:=
RGB(
TAlphaColorRec(AlphaColor).R,
TAlphaColorRec(AlphaColor).G,
TAlphaColorRec(AlphaColor).B);
end;
end;
finally
b.Unmap(data);
end;
end;
Correction to work with rectangular images:
function
ConvertFmxBitmapToVclBitmap(b:FMX.Graphics.TBitmap):Vcl.Graphics.TBitmap;
var
data:FMX.Graphics.TBitmapData;
i,j:Integer;
AlphaColor:TAlphaColor;
begin
Result:=VCL.Graphics.TBitmap.Create;
Result.SetSize(b.Width,b.Height);
if(b.Map(TMapAccess.Readwrite,data))then
try
for i := 0 to data.Height-1 do begin
for j := 0 to data.Width-1 do begin
AlphaColor:=data.GetPixel(j,i);
Result.Canvas.Pixels[j,i]:=
RGB(
TAlphaColorRec(AlphaColor).R,
TAlphaColorRec(AlphaColor).G,
TAlphaColorRec(AlphaColor).B);
end;
end;
finally
b.Unmap(data);
end;
end;
I useSHGetFileInfo('', 0, aFileInfo, SizeOf(TSHFileInfo), SHGFI_ICON or SHGFI_SYSICONINDEX) to extract an icon list in TImageList and then associate index with TListView. Which flag I must use to get hidden style like Explorer?
To the best of my knowledge, the system does not offer such functionality. You need to create faded icons yourself, based on the original icon. You can use a function along these lines to do that:
function CreateFadedIcon(Icon: HICON): HICON;
type
TRGBA = record
B,G,R,A: Byte
end;
procedure InitialiseBitmapInfoHeader(Width, Height: Integer; var bih: BITMAPINFOHEADER);
begin
bih.biSize := SizeOf(BITMAPINFOHEADER);
bih.biWidth := Width;
bih.biHeight := 2*Height;//height of xor bitmap plus height of and bitmap
bih.biPlanes := 1;
bih.biBitCount := 32;
bih.biCompression := BI_RGB;
end;
procedure CreateXORbitmap(const sbih, dbih: BITMAPINFOHEADER; sptr, dptr: PDWORD);
var
i, j: Integer;
begin
for i := 0 to sbih.biHeight-1 do begin
for j := 0 to sbih.biWidth-1 do begin
dptr^ := sptr^;
TRGBA(dptr^).A := TRGBA(dptr^).A div 3;
inc(dptr);//relies on the fact that no padding is needed for RGBA scanlines
inc(sptr);//likewise
end;
end;
end;
var
IconInfo: TIconInfo;
sBits, xorBits: PDWORD;
xorScanSize, andScanSize: Integer;
xorBitsSize, andBitsSize: Integer;
sbih: BITMAPINFOHEADER;
dbih: ^BITMAPINFOHEADER;
resbitsSize: DWORD;
resbits: Pointer;
begin
Result := 0;
Try
if not GetIconInfo(Icon, IconInfo) then begin
exit;
end;
Try
GetDIBheaderAndBits(IconInfo.hbmColor, sbih, Pointer(sBits));
if Assigned(sBits) then begin
Try
if (sbih.biPlanes<>1) or (sbih.biBitCount<>32) then begin
exit;
end;
xorScanSize := BytesPerScanline(sbih.biWidth, 32, 32);
Assert(xorScanSize=SizeOf(DWORD)*sbih.biWidth);
andScanSize := BytesPerScanline(sbih.biWidth, 1, 32);
xorBitsSize := sbih.biHeight*xorScanSize;
andBitsSize := sbih.biHeight*andScanSize;
resbitsSize := SizeOf(BITMAPINFOHEADER) + xorBitsSize + andBitsSize;
resbits := AllocMem(resbitsSize);//AllocMem zeroises the memory
Try
dbih := resbits;
InitialiseBitmapInfoHeader(sbih.biWidth, sbih.biHeight, dbih^);
xorBits := resbits;
inc(PByte(xorBits), SizeOf(BITMAPINFOHEADER));
CreateXORbitmap(sbih, dbih^, sBits, xorBits);
//don't need to fill in the mask bitmap when using RGBA
Result := CreateIconFromResourceEx(resbits, resbitsSize, True, $00030000, sbih.biWidth, sbih.biHeight, LR_DEFAULTCOLOR);
Finally
FreeMem(resbits);
End;
Finally
FreeMem(sBits);
End;
end;
Finally
if IconInfo.hbmMask<>0 then begin
DeleteObject(IconInfo.hbmMask);
end;
if IconInfo.hbmColor<>0 then begin
DeleteObject(IconInfo.hbmColor);
end;
End;
Finally
DestroyIcon(Icon);
End;
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 got the following code from a newsgroup posting. Strangely, it isn't working for me in Delphi 2010; An exception is being thrown at the LsaOpenPolicy function call:
function AddLogonAsAService(ID: pchar): boolean;
const
Right: PChar = 'SeServiceLogonRight';
var
FResult: NTSTATUS;
//szSystemName: LPTSTR;
FObjectAttributes: TLSAObjectAttributes;
FPolicyHandle: LSA_HANDLE;
Server, Privilege: TLSAUnicodeString;
FSID: PSID;
cbSid: DWORD;
ReferencedDomain: LPTSTR;
cchReferencedDomain: DWORD;
peUse: SID_NAME_USE;
PrivilegeString: String;
begin
Result := false;
try
ZeroMemory(#FObjectAttributes, sizeof(FObjectAttributes));
Server.Buffer := nil;
Server.Length := 0;
Server.MaximumLength := 256;
PrivilegeString := Right; //or some other privilege
Privilege.Buffer := PChar(PrivilegeString);
Privilege.Length := 38;
Privilege.MaximumLength := 256;
FResult := LsaOpenPolicy(
#Server, //this machine, because the Buffer is NIL
#FObjectAttributes,
POLICY_ALL_ACCESS,
FPolicyHandle);
if FResult = STATUS_SUCCESS then begin
cbSid := 128;
cchReferencedDomain := 16;
GetMem(FSID, cbSid);
//FSID:=PSID(HeapAlloc(GetProcessHeap(), 0, cbSid));
GetMem(ReferencedDomain, cchReferencedDomain);
//ReferencedDomain := LPTSTR(HeapAlloc(GetProcessHeap(), 0, cchReferencedDomain * sizeof(ReferencedDomain^)));
if LookupAccountName(nil, ID, FSID, cbSid, ReferencedDomain,
cchReferencedDomain, peUse) then begin
FResult := LsaAddAccountRights(FPolicyHandle, FSID, #Privilege, 1);
Result := FResult = STATUS_SUCCESS;
end;
FreeMem(FSID, cbSid);
FreeMem(ReferencedDomain, cchReferencedDomain);
end;
except
Result := false;
end;
end;
Original posting may be found at Google Groups archive:
From: "andrew"
Newsgroups:
borland.public.delphi.winapi
Subject: NetUserAdd and assigning user
rights
Date: Tue, 25 Sep 2001 10:08:35 +1000
Thanks in advance for any answers.
According to the MSDN docs you should not use an LSA_UNICODE_STRING with the Buffer set to nil but pass nil instead: LsaOpenPolicy(nil, ...
/EDIT:
The code below works fine for me using Jedi Apilib so I think something might be wrong with your definition (maybe calling convention?), so please add this to your code.
Also you are specifying maximum buffer size of 256 in the LSA_UNICODE_STRING's which is incorrect, in the first case the maximum buffer is 0.
uses
JwaWinType, JwaNtSecApi;
procedure TForm1.Button1Click(Sender: TObject);
var
ObjectAttribs: LSA_OBJECT_ATTRIBUTES;
PolicyHandle: LSA_HANDLE;
nts: NTSTATUS;
begin
ZeroMemory(#ObjectAttribs, SizeOf(ObjectAttribs));
nts := LsaOpenPolicy(nil, ObjectAttribs, POLICY_ALL_ACCESS, PolicyHandle);
Memo1.Lines.Add(Format('nts=%.8x', [nts]));
end;
Fixed/changed function, tested on Win7 under D2009 (but should work on older/newer too). Of course app. must be running with admin rights.
uses
JwaWinNT, JwaWinType, JwaNtStatus, JwaNtSecApi, JwaLmCons;
function AddPrivilegeToAccount(AAccountName, APrivilege: String): DWORD;
var
lStatus: TNTStatus;
lObjectAttributes: TLsaObjectAttributes;
lPolicyHandle: TLsaHandle;
lPrivilege: TLsaUnicodeString;
lSid: PSID;
lSidLen: DWORD;
lTmpDomain: String;
lTmpDomainLen: DWORD;
lTmpSidNameUse: TSidNameUse;
{$IFDEF UNICODE}
lPrivilegeWStr: String;
{$ELSE}
lPrivilegeWStr: WideString;
{$ENDIF}
begin
ZeroMemory(#lObjectAttributes, SizeOf(lObjectAttributes));
lStatus := LsaOpenPolicy(nil, lObjectAttributes, POLICY_LOOKUP_NAMES, lPolicyHandle);
if lStatus <> STATUS_SUCCESS then
begin
Result := LsaNtStatusToWinError(lStatus);
Exit;
end;
try
lTmpDomainLen := JwaLmCons.DNLEN; // In 'clear code' this should be get by LookupAccountName
SetLength(lTmpDomain, lTmpDomainLen);
lSidLen := SECURITY_MAX_SID_SIZE;
GetMem(lSid, lSidLen);
try
if LookupAccountName(nil, PChar(AAccountName), lSid, lSidLen, PChar(lTmpDomain),
lTmpDomainLen, lTmpSidNameUse) then
begin
lPrivilegeWStr := APrivilege;
lPrivilege.Buffer := PWideChar(lPrivilegeWStr);
lPrivilege.Length := Length(lPrivilegeWStr) * SizeOf(Char);
lPrivilege.MaximumLength := lPrivilege.Length;
lStatus := LsaAddAccountRights(lPolicyHandle, lSid, #lPrivilege, 1);
Result := LsaNtStatusToWinError(lStatus);
end else
Result := GetLastError;
finally
FreeMem(lSid);
end;
finally
LsaClose(lPolicyHandle);
end;
end;
procedure TForm2.Button1Click(Sender: TObject);
var
lStatus: DWORD;
begin
lStatus := AddPrivilegeToAccount('Administrators'{or any account/group name}, 'SeServiceLogonRight');
if lStatus = ERROR_SUCCESS then
Caption := 'OK'
else
Caption := SysErrorMessage(lStatus);
end;