I don't know if it is even possible, but what I need is to access (use and free) a TStream variable by it pointer, passed thought a string parameter to another function.
Here is a "not working" example of what I am trying to do:
procedure TForm1.Button1Click(Sender: TObject);
var
Stm: TMemoryStream;
begin
Stm := TMemoryStream.Create;
try
Memo.Lines.SaveToStream(Stm);
Stm.Position := 0;
Memo.Clear;
Edit.Text := IntToStr(Integer(#Stm));
except
Stm.Free;
end;
end;
procedure TForm1.Button2Click(Sender: TObject);
var
PStm: ^TMemoryStream;
begin
PStm := Pointer(StrToInt(Edit.Text));
try
Memo.Lines.LoadFromStream(PStm^); // <--- Access Violation
finally
PStm^.Free;
end;
end;
Thanks for any help to solve this!
TStream is a reference type. Your Stm variable holds a pointer to the stream object instance. You want to pass this pointer value, not the address of the local variable. Here's the fixed code:
procedure TForm1.Button1Click(Sender: TObject);
var
Stm: TMemoryStream;
begin
Stm := TMemoryStream.Create;
try
Memo.Lines.SaveToStream(Stm);
Stm.Position := 0;
Memo.Clear;
Edit.Text := IntToStr(Integer(Stm));
except
Stm.Free;
raise;
end;
end;
procedure TForm1.Button2Click(Sender: TObject);
var
Stm: TMemoryStream;
begin
Stm := Pointer(StrToInt(Edit.Text));
try
Memo.Lines.LoadFromStream(Stm);
finally
Stm.Free;
end;
end;
Related
Will the following code have a memory leak from the TStringlist?
function TDemo.GetList:TStringlist;
begin
Result:=TStringlist.Create;
{...}
end;
procedure TMain.Something;
Var
S:String;
begin
For S IN Demo.GetList do begin
end;
end;
Yes, the TStringList will leak. You must explicitly Free the TStringList when you are done using it, eg:
function TDemo.GetList: TStringList;
begin
Result := TStringlist.Create;
...
end;
procedure TMain.Something;
var
S: String;
SL: TStringList;
begin
SL := Demo.GetList;
try
for S in SL do begin
...
end;
finally
SL.Free;
end;
end;
This is why returning a Create'd object as a function return value is usually not a good idea. In this particular example, returning an array instead would be an alternative solution that doesn't require manual cleanup, eg:
function TDemo.GetList: TArray<String>;
begin
SetLength(Result, ...);
...
end;
procedure TMain.Something;
var
S: String;
begin
for S in Demo.GetList do begin
...
end;
end;
I am writing a client / server application. There is one server and several clients.
When connecting a client, the task is to add its IP address to the ListBox, and when disconnecting the client, remove it from the ListBox. Then exchange messages between the client and server.
Three questions arose: when a client connects, its IP address is added to the ListBox, but when disconnected, it is not deleted from there, here is the code:
type
TSimpleClient = class(TObject)
DNS,
Name : String;
ListLink : Integer;
Thread : Pointer;
end;
procedure TForm1.IdTCPServer1Connect(AContext: TIdContext);
var
Client: TSimpleClient;
begin
Client := TSimpleClient.Create;
Client.DNS := AContext.Connection.Socket.Binding.PeerIP;
Client.ListLink := ListBox1.Items.Count;
Client.Thread := AContext;
ListBox1.Items.Add(Client.DNS);
AContext.Data := Client;
Clients.Add(Client);
end;
procedure TForm1.IdTCPServer1Disconnect(AContext: TIdContext);
var
Client : TSimpleClient;
begin
sleep(2000);
Client :=Pointer (AContext.Data);
Clients.Delete(Client.ListLink);
ListBox1.Items.Delete(ListBox1.Items.IndexOf(Client.DNS));
Client.Free;
AContext.Data := nil;
end;
The second question, when exchanging messages, the letters in Cyrillic are given as "???", all Google went through it and it was not possible to find an error.
And the third question, on the client is a timer that listens to messages from the server, when the timer is turned on, the client application hangs tight, putting all this into the stream is the same trouble, the code:
if not IdTCPClient1.Connected then
Exit;
s := IdTCPClient1.Socket.ReadLn;
if s <> '' then
Label1.Text := s;
I see quite a few problems with your code.
On the server side, you need to get rid of the TSimpleClient.ListLink field. You are misusing it, causing bad behaviors in your code since you don't keep it updated as clients are added/removed. Think of what happens when you have 2 clients connected, where ListLink is 0 and 1 respectively, and then the 1st client disconnects. The ListLink for the 2nd client will become invalid since you don't decrement it from 1 to 0.
Also TIdTCPServer is a multi-threaded component, its events are fired in the context of worker threads, but your event handler code is not thread-safe. You MUST synchronize with the main UI thread when accessing UI controls from worker threads, and you MUST protect your Clients list from concurrent access across thread boundaries. In this case, you don't really need your own Clients list to begin with as TIdTCPServer has its own thread-safe Contexts list that you can use to access the connected clients.
You are also not handling Unicode at all. By default, Indy's default byte encoding for Unicode strings is US-ASCII, which is why you are getting ? for non-ASCII characters. You can use the IOHandler's DefStringEncoding property to set a different byte encoding, such as IndyTextEncoding_UTF8 (if you are using Delphi 2007 or earlier, you might need to also use the IOHandler's DefAnsiEncoding property to specify how your ANSI strings are converted to/from Unicode. By default, it is set to IndyTextEncoding_OSDefault).
Try something more like this:
type
TSimpleClient = class(TObject)
DNS,
Name : String;
Thread : Pointer;
OutgoingMsgs : TIdThreadSafeStringList;
HasOutgoingMsgs : Boolean;
constructor Create;
destructor Destroy; override;
procedure Queue(const Msg: string);
procedure FlushMsgs;
end;
constructor TSimpleClient.Create;
begin
inherited;
OutgoingMsgs := TIdThreadSafeStringList.Create;
end;
destructor TSimpleClient.Destroy;
begin
OutgoingMsgs.Free;
inherited;
end;
procedure TSimpleClient.Queue(const Msg: string);
var
List: TStringList;
begin
List := OutgoingMsgs.Lock;
try
List.Add(Msg);
HasOutgoingMsgs := True;
finally
OutgoingMsgs.Unlock;
end;
end;
procedure TSimpleClient.FlushMsgs;
var
List: TStringList;
begin
List := OutgoingMsgs.Lock;
try
while List.Count > 0 do
begin
TIdContext(Thread).Connection.IOHandler.WriteLn(List[0]);
List.Delete(0);
end;
HasOutgoingMsgs := False;
finally
OutgoingMsgs.Unlock;
end;
end;
procedure TForm1.IdTCPServer1Connect(AContext: TIdContext);
var
PeerIP: string;
Client: TSimpleClient;
begin
PeerIP := AContext.Binding.PeerIP;
Client := TSimpleClient.Create;
Client.DNS := PeerIP;
Client.Thread := AContext;
AContext.Data := Client;
TThread.Queue(nil,
procedure
begin
ListBox1.Items.AddObject(PeerIP, Client);
end
);
AContext.Connection.IOHandler.DefStringEncoding := IndyTextEncoding_UTF8;
end;
procedure TForm1.IdTCPServer1Disconnect(AContext: TIdContext);
var
Client : TSimpleClient;
begin
Client := TSimpleClient(AContext.Data);
try
TThread.Queue(nil,
procedure
var
Index: Integer;
begin
Index := ListBox1.Items.IndexOfObject(Client);
if Index <> -1 then
ListBox1.Items.Delete(Index);
end;
);
finally
{ The anonymous procedure being passed to TThread.Queue() above captures
the Client variable itself, not its value. On ARC platforms, we need to
prevent Free() setting the variable to nil before it can be passed to
IndexOfObject(), and also because IndexOfObject() expects a live object
anyway. ARC will free the object when the anonymous procedure exits. On
non-ARC platforms, it is OK to Free() the object here, the variable will
not change value, and IndexOfObject() does not need a live object... }
{$IFNDEF AUTOREFCOUNT}
Client.Free;
{$ENDIF}
AContext.Data := nil;
end;
end;
procedure TForm1.IdTCPServer1Execute(AContext: TIdContext);
var
Client: TSimpleClient;
begin
Client := TSimpleClient(AContext.Data);
if Client.HasOutgoingMsgs then
Client.FlushMsgs
else
Sleep(100);
end;
procedure TForm1.SendMessageToClient(Client: TSimpleClient; const Msg: string);
var
List: TIdContextList;
begin
List := IdTCPServer1.Contexts.LockList;
try
if List.IndexOf(TIdContext(Client.Thread)) <> -1 then // still connected?
Client.Queue(Msg);
finally
IdTCPServer1.Contexts.UnlockList;
end;
end;
procedure TForm1.Button1Click(Sender: TObject);
var
Index: Integer;
Msg: string;
Client: TSimpleClient;
begin
Index := ListBox1.ItemIndex;
if Index = -1 then Exit;
Msg := Edit1.Text;
if Msg = '' then Exit;
Client := TSimpleClient(ListBox1.Items.Objects[Index]);
SendMessageToClient(Client, Msg);
end;
Alternatively, you can derive TSimpleClient from TIdServerContext and get rid of the Thread field altogether:
type
TSimpleClient = class(TIdServerContext)
DNS,
Name : String;
OutgoingMsgs : TIdThreadSafeStringList;
HasOutgoingMsgs : Boolean;
constructor Create(AConnection: TIdTCPConnection; AYarn: TIdYarn; AList: TIdContextThreadList = nil); override;
destructor Destroy; override;
procedure Queue(const Msg: string);
procedure FlushMsgs;
end;
constructor TSimpleClient.Create(AConnection: TIdTCPConnection; AYarn: TIdYarn; AList: TIdContextThreadList = nil);
begin
inherited Create(AConnection, AYarn, AList);
OutgoingMsgs := TIdThreadSafeStringList.Create;
end;
destructor TSimpleClient.Destroy;
begin
OutgoingMsgs.Free;
inherited;
end;
procedure TSimpleClient.Queue(const Msg: string);
var
List: TStringList;
begin
List := OutgoingMsgs.Lock;
try
List.Add(Msg);
HasOutgoingMsgs := True;
finally
OutgoingMsgs.Unlock;
end;
end;
procedure TSimpleClient.FlushMsgs;
var
List: TStringList;
begin
List := OutgoingMsgs.Lock;
try
while List.Count > 0 do
begin
Self.Connection.IOHandler.WriteLn(List[0]);
List.Delete(0);
end;
HasOutgoingMsgs := False;
finally
OutgoingMsgs.Unlock;
end;
end;
procedure TForm1.FormCreate(Sender: TObject);
begin
IdTCPServer1.ContextClass := TSimpleClient;
end;
procedure TForm1.IdTCPServer1Connect(AContext: TIdContext);
var
PeerIP: string;
Client: TSimpleClient;
begin
PeerIP := AContext.Binding.PeerIP;
Client := TSimpleClient(AContext);
Client.DNS := PeerIP;
TThread.Queue(nil,
procedure
begin
ListBox1.Items.AddObject(PeerIP, Client);
end
);
AContext.Connection.IOHandler.DefStringEncoding := IndyTextEncoding_UTF8;
end;
procedure TForm1.IdTCPServer1Disconnect(AContext: TIdContext);
var
Client : TSimpleClient;
begin
Client := TSimpleClient(AContext);
TThread.Queue(nil,
procedure
var
Index: Integer;
begin
Index := ListBox1.Items.IndexOfObject(Client);
if Index <> -1 then
ListBox1.Items.Delete(Index);
end;
);
end;
procedure TForm1.IdTCPServer1Execute(AContext: TIdContext);
var
Client: TSimpleClient;
begin
Client := TSimpleClient(AContext);
if Client.HasOutgoingMsgs then
Client.FlushMsgs
else
Sleep(100);
end;
procedure TForm1.SendMessageToClient(Client: TSimpleClient; const Msg: string);
var
List: TIdContextList;
begin
List := IdTCPServer1.Contexts.LockList;
try
if List.IndexOf(TIdContext(Client)) <> -1 then // still connected?
Client.Queue(Msg);
finally
IdTCPServer1.Contexts.UnlockList;
end;
end;
procedure TForm1.Button1Click(Sender: TObject);
var
Index: Integer;
Msg: string;
Client: TSimpleClient;
begin
Index := ListBox1.ItemIndex;
if Index = -1 then Exit;
Msg := Edit1.Text;
if Msg = '' then Exit;
Client := TSimpleClient(ListBox1.Items.Objects[Index]);
SendMessageToClient(Client, Msg);
end;
On the client side, you are reading from the socket in the main UI thread, but Indy uses blocking sockets, and so its reading methods will block the calling thread until the requested data arrives. DON'T block the main UI thread! Read only if there is actually something available to read, or else move the reading into a separate worker thread. For example:
IdTCPClient1.Connect;
IdTCPClient1.IOHandler.DefStringEncoding := IndyTextEncoding_UTF8;
...
IdTCPClient1.Disconnect;
...
procedure TForm1.Timer1Timer(Sender: TObject);
var
s: string;
begin
if IdTCPClient1.Connected and (not IdTCPClient1.IOHandler.InputBufferIsEmpty) then
begin
s := IdTCPClient1.IOHandler.ReadLn;
if s <> '' then
Label1.Text := s;
end;
end;
Alternatively:
type
TReadingThread = class(TThread)
protected
procedure Execute; override;
end;
procedure TReadingThread.Execute;
var
s: String;
begin
while not Terminated do
begin
s := Form1.IdTCPClient1.IOHandler.ReadLn;
if s <> '' then
begin
TThread.Queue(nil,
procedure
begin
Form1.Label1.Text := s;
end
);
end;
end;
end;
...
var
ReadingThread: TReadingThread = nil;
...
IdTCPClient1.Connect;
IdTCPClient1.IOHandler.DefStringEncoding := IndyTextEncoding_UTF8;
ReadingThread := TReadingThread.Create(False);
...
ReadingThread.Terminate;
try
IdTCPClient1.Disconnect;
finally
ReadingThread.WaitFor;
ReadingThread.Free;
end;
Thank you so much Remy, your answer really helped me sort out my problem. I targeted Windows and Android platforms. I fixed your code a little and it worked for me:
type
TSimpleClient = class(TObject)
DNS,
Name : String;
Thread : Pointer;
OutgoingMsgs : TIdThreadSafeStringList;
HasOutgoingMsgs : Boolean;
constructor Create;
destructor Destroy; override;
procedure Queue(const Msg: string);
procedure FlushMsgs;
end;
constructor TSimpleClient.Create;
begin
inherited;
OutgoingMsgs := TIdThreadSafeStringList.Create;
end;
destructor TSimpleClient.Destroy;
begin
OutgoingMsgs.Free;
inherited;
end;
procedure TSimpleClient.Queue(const Msg: string);
var
List: TStringList;
Client: TSimpleClient;
begin
List := OutgoingMsgs.Lock;
try
List.Add(Msg);
HasOutgoingMsgs := True;
Client.FlushMsgs;
finally
OutgoingMsgs.Unlock;
end;
end;
procedure TSimpleClient.FlushMsgs;
var
List: TStringList;
begin
List := OutgoingMsgs.Lock;
try
while List.Count > 0 do
begin
TIdContext(Thread).Connection.IOHandler.WriteLn(List[0]);
List.Delete(0);
end;
HasOutgoingMsgs := False;
finally
OutgoingMsgs.Unlock;
end;
end;
procedure TForm1.IdTCPServer1Connect(AContext: TIdContext);
var
PeerIP: string;
Client: TSimpleClient;
begin
PeerIP := AContext.Binding.PeerIP;
Client := TSimpleClient.Create;
Client.DNS := PeerIP;
Client.Thread := AContext;
AContext.Data := Client;
TThread.Queue(nil,
procedure
begin
ListBox1.Items.AddObject(PeerIP, Client);
end
);
AContext.Connection.IOHandler.DefStringEncoding := IndyTextEncoding_UTF8;
end;
procedure TForm1.IdTCPServer1Disconnect(AContext: TIdContext);
var
Client : TSimpleClient;
begin
Client := TSimpleClient(AContext.Data);
try
TThread.Queue(nil,
procedure
var
Index: Integer;
begin
Index := ListBox1.Items.IndexOfObject(Client);
if Index <> -1 then
ListBox1.Items.Delete(Index);
end;
);
finally
{ The anonymous procedure being passed to TThread.Queue() above captures
the Client variable itself, not its value. On ARC platforms, we need to
prevent Free() setting the variable to nil before it can be passed to
IndexOfObject(), and also because IndexOfObject() expects a live object
anyway. ARC will free the object when the anonymous procedure exits. On
non-ARC platforms, it is OK to Free() the object here, the variable will
not change value, and IndexOfObject() does not need a live object... }
{$IFNDEF AUTOREFCOUNT}
Client.Free;
{$ENDIF}
AContext.Data := nil;
end;
end;
procedure TForm1.IdTCPServer1Execute(AContext: TIdContext);
var
Client: TSimpleClient;
begin
Client := TSimpleClient(AContext.Data);
if Client.HasOutgoingMsgs then
Client.FlushMsgs
else
Sleep(100);
end;
procedure TForm1.SendMessageToClient(Client: TSimpleClient; const Msg: string);
var
List: TIdContextList;
begin
List := IdTCPServer1.Contexts.LockList;
try
if List.IndexOf(TIdContext(Client.Thread)) <> -1 then // still connected?
Client.Queue(Msg);
finally
IdTCPServer1.Contexts.UnlockList;
end;
end;
procedure TForm1.Button1Click(Sender: TObject);
var
Index: Integer;
Msg: string;
Client: TSimpleClient;
begin
Index := ListBox1.ItemIndex;
if Index = -1 then Exit;
Msg := Edit1.Text;
if Msg = '' then Exit;
Client := TSimpleClient(ListBox1.Items.Objects[Index]);
SendMessageToClient(Client, Msg);
end;
I added a call to the FlushMsgs method from the TSimpleClient.Queue procedure and messages started to be sent, the list of clients is updated every time clients are connected and disconnected, and the server stopped hanging. Thanks again Remy, you helped a lot to speed up the development, golden man.
I'm using Delphi 5 Enterprise because that's what the program I'm working with was written in. I have written a procedure which saves bitmaps to an Access database quite happily. Now I want to be able to retrieve the bitmaps. Saving the bitmaps, I use SaveToStream. Retrieving them, I used LoadFromStream but the compiler tells me that it doesn't recognise that function. The code is below:
procedure TForm1.Button2Click(Sender: TObject);
var
Field : TBlobField;
Stream : TStream;
BMap : TBitMapImage;
begin
if BloBQuery.Active then
begin
Field := TBlobField(BlobQuery.FieldByName('Blob'));
Stream := BlobQuery.CreateBlobStream(Field, bmRead);
BMap := TBitMapImage.Create;
try
Image2.Picture.Graphic := BMap.LoadFromStream(Stream);
finally
BMap.Free;
Stream.Free;
end;
end;
end;
Can anyone tell me when LoadFromStream won't work? It seems odd! Thanks.
The code which wrote the bitmap was:
procedure TForm1.Button1Click(Sender: TObject);
var
Field : TBlobField;
Stream : TStream;
begin
if (BlobQuery.Active = True) and (Image1.Picture.Graphic <> nil) then begin
BlobQuery.Insert;
Field := TBlobField(BlobQuery.FieldByName('Blob'));
Stream := BlobQuery.CreateBlobStream(Field, bmWrite);
try
Image1.Picture.Graphic.SaveToStream(Stream);
finally
Stream.Free;
BlobQuery.Post;
end;
end;
end;
Assuming Image1.Picture.Graphic was pointing at a TBitmap object when you saved it to the DB, you need to use a TBitmap object instead of a TBitMapImage object when reading the image back out, eg:
procedure TForm1.Button2Click(Sender: TObject);
var
Field : TBlobField;
Stream : TStream;
BMap : TBitmap;
begin
if BlobQuery.Active then
begin
Field := TBlobField(BlobQuery.FieldByName('Blob'));
Stream := BlobQuery.CreateBlobStream(Field, bmRead);
try
BMap := TBitmap.Create;
try
BMap.LoadFromStream(Stream);
Image2.Picture.Graphic := BMap;
finally
BMap.Free;
end;
finally
Stream.Free;
end;
end;
end;
Alternatively:
procedure TForm1.Button2Click(Sender: TObject);
var
Field : TBlobField;
Stream : TStream;
begin
if BlobQuery.Active then
begin
Field := TBlobField(BlobQuery.FieldByName('Blob'));
Stream := BlobQuery.CreateBlobStream(Field, bmRead);
try
Image2.Picture.Bitmap.LoadFromStream(Stream);
finally
Stream.Free;
end;
end;
end;
I want to transfer data from the TIdTCPServer to the TIdTCPClient.
On the server side I have:
procedure TForm1.IdTCPServer1Execute(AContext: TIdContext);
var x:Integer;
Received:String;
SendBuff:TBytes;
hFile:THandle;
fSize:Int64;
begin
fSize:=0;
if MOpenFileForRead(hFile,MGetExePath+'\test.jpg') then begin
fSize:=MFileSize(hFile);
SetLength(SendBuff,fSize);
MReadFile(hFile,SendBuff[0],fSize);
MCloseFile(hFile);
end;
// ... here the SendBuff contains valid data, I checked.
repeat
Received:=AContext.Connection.Socket.ReadLn;
if not AContext.Connection.Connected then Exit;
if Received=CMD_TEST_FILE then begin
AContext.Connection.Socket.Write(fSize);
AContext.Connection.Socket.WriteBufferOpen;
AContext.Connection.Socket.Write(SendBuff);
AContext.Connection.Socket.WriteBufferClose;
end;
until False;
end;
And the client side:
procedure TForm1.Button2Click(Sender: TObject);
var fSize:Int64;
RecvBuff:TBytes;
hFile:THandle;
begin
IdTCPClient1.Socket.WriteLn(CMD_TEST_FILE);
fSize:=IdTCPClient1.Socket.ReadInt64;
SetLength(RecvBuff,fSize);
IdTCPClient1.Socket.ReadBytes(RecvBuff,fSize);
if MCreateFile(hFile, MGetExePath+'\new.jpg') then begin
MWriteFile(hFile,RecvBuff[0],fSize);
MCloseFile(hFile);
end;
Memo1.Lines.Add('ok');
end;
... but it's not working. I checked the read and write data functions used and they are ok. At the server the buffer is set ok, the file size arrives at client ok, but the content of the buffer at client is only zeros.
P.S: I want to send the file in this way not with stream or anything else.
If you look at the signature of ReadBytes(), it has an optional AAppend parameter that is True by default:
procedure ReadBytes(var VBuffer: TIdBytes; AByteCount: Integer; AAppend: Boolean = True); virtual;
When true, it reads bytes from the socket and appends them to the end of the existing byte array. Since you are pre-allocating the array, the initial bytes are undefined and the file bytes follow after the undefined bytes.
To fix this, you need to either:
Stop pre-allocating the byte array, let ReadBytes() allocate it for you.
procedure TForm1.Button2Click(Sender: TObject);
var
fSize: Int64;
RecvBuff: TBytes;
hFile: THandle;
begin
IdTCPClient1.Socket.WriteLn(CMD_TEST_FILE);
fSize := IdTCPClient1.Socket.ReadInt64;
// SetLength(RecvBuff,fSize); // <-- remove this line
IdTCPClient1.Socket.ReadBytes(RecvBuffer, fSize);
if MCreateFile(hFile, MGetExePath+'\new.jpg') then
begin
MWriteFile(haile, RecvBuff[0], fSize);
MCloseFile(hFile);
end;
Memo1.Lines.Add('ok');
end;
pre-allocate the array, but set AAppend to False so the bytes fill the existing array instead of append to it.
procedure TForm1.Button2Click(Sender: TObject);
var
fSize: Int64;
RecvBuff: TBytes;
hFile: THandle;
begin
IdTCPClient1.Socket.WriteLn(CMD_TEST_FILE);
fSize := IdTCPClient1.Socket.ReadInt64;
SetLength(RecvBuff, fSize);
IdTCPClient1.Socket.ReadBytes(RecvBuff, fSize, False);
if MCreateFile(hFile, MGetExePath+'\new.jpg') then
begin
MWriteFile(haile, RecvBuff[0], fSize);
MCloseFile(hFile);
end;
Memo1.Lines.Add('ok');
end;
Update: That being said, I strongly suggest you use a TStream instead, despite you saying you do not want to. It will greatly simplify the code and memory management, without breaking the communication protocol you have chosen to use:
procedure TForm1.IdTCPServer1Connect(AContext: TIdContext);
begin
AContext.Data := TFileStream.Create(MGetExePath+'\test.jpg', fmOpenRead or fmShareDenyWrite);
AContext.Connection.IOHandler.LargeStream := True;
end;
TForm1.IdTCPServer1Execute(AContext: TIdContext);
var
Received: String;
begin
Received := AContext.Connection.IOHandler.ReadLn;
if Received = CMD_TEST_FILE then
begin
AContext.Connection.IOHandler.Write(TStream(AContext.Data), 0, True);
end;
end;
procedure TForm1.Button2Click(Sender: TObject);
var
FileName: string;
Strm: TStream;
begin
FileName := MGetExePath+'\new.jpg';
Strm := TFileStream.Create(FileName, fmCreate);
try
try
IdTCPClient1.IOHandler.WriteLn
(CMD_TEST_FILE);
IdTCPClient1.IOHandler.ReadStream(Strm, -1, False);
finally
Strm.Free;
end;
except
DeleteFile(FileName);
raise;
end;
Memo1.Lines.Add('ok');
end;
I want to display a treeview with all the registry information in it ( i.e all the subkeys ). I have put together the following Fn to do the same. But i am getting the info of only one Key, not all. What is missing in my code ?
function TForm1.DisplayKeys(TreeNode : TTreeNode;KeyToSearch:String):String;
var
i: Integer;
RootKey : Integer;
NewTreeNode : TTreeNode;
str : TStringList;
// str2: TStringList;
begin
i:=0;
if reg.OpenKey(KeyToSearch,False) then
begin
str:=nil;
str:=TStringList.create;
reg.GetKeyNames(str);
//For all SubKeys
for i:=0 to str.Count-1 do
begin
NewTreeNode:=TreeView1.Items.AddChild(TreeNode, Str.Strings[i]);
if reg.HasSubKeys then
begin
DisplayKeys(NewTreeNode,Str.Strings[i]);
end;
end;
end;
the call to the Function is
procedure TForm1.FormCreate(Sender: TObject);
begin
reg:=nil;
reg:=TRegistry.create;
str2:=nil;
str2:=TStringList.create;
reg.RootKey:=HKEY_CURRENT_CONFIG;
TreeView1.Items.BeginUpdate; //prevents screen repaint every time node is added
DisplayKeys(nil,''); // call to fn here
TreeView1.Items.EndUpdate; // Nodes now have valid indexes
end;
Note that i am not getting any error, just that info is incomplete
Some problems:
You are using OpenKey which attempts to open the key with write access. Instead you should use OpenKeyReadOnly. If you really do mean to write to those keys then you will have to run elevated as an administrator.
You are failing to close the keys once you have finished with them.
More seriously, your use of relative registry keys is not sufficient. I believe you will need to pass around the full path to the key. I wrote a little demo console app to show what I mean:
program RegistryEnumerator;
{$APPTYPE CONSOLE}
uses
Classes, Windows, Registry;
var
Registry: TRegistry;
procedure DisplayKeys(const Key: string; const Depth: Integer);
var
i: Integer;
SubKeys: TStringList;
begin
if Registry.OpenKeyReadOnly(Key) then begin
Try
SubKeys := TStringList.Create;
Try
Registry.GetKeyNames(SubKeys);
for i := 0 to SubKeys.Count-1 do begin
Writeln(StringOfChar(' ', Depth*2) + SubKeys[i]);
DisplayKeys(Key + '\' + SubKeys[i], Depth+1);
end;
Finally
SubKeys.Free;
End;
Finally
Registry.CloseKey;
End;
end;
end;
begin
Registry := TRegistry.Create;
Try
Registry.RootKey := HKEY_CURRENT_CONFIG;
DisplayKeys('', 0);
Readln;
Finally
Registry.Free;
End;
end.
try this :-
procedure TForm1.Button1Click(Sender: TObject);
begin
TreeView1.Items.Clear;
path := Edit1.Text;
// reg.RootKey := HKEY_LOCAL_MACHINE ;
TreeView1.Items.BeginUpdate;
drawtreeview(nil, path);
TreeView1.Items.EndUpdate;
end;
procedure TForm1.drawtreeview( node: TTreeNode; name: string);
var
i: Integer;
NewTreeNode: TTreeNode;
str, str2 : TStringList;
reg : TRegistry;
begin
reg := TRegistry.Create;
reg.RootKey := HKEY_LOCAL_MACHINE;
i := 0;
if reg.OpenKeyReadOnly(name) then
begin
str := TStringList.create;
reg.GetKeyNames(str);
for i := 0 to str.Count - 1 do
begin
NewTreeNode := TreeView1.Items.AddChild(node, str.Strings[i]);
if reg.HasSubKeys then
begin
drawtreeview(NewTreeNode, name + '\' + str.Strings[i]);
end
else
ShowMessage('no sub keys');
end;
end;
reg.CloseKey;
reg.Free;
end;