I'm want write name of my pc to a txt file using SysUtils.FileWrite api, in my last attempt is wrote with sucess, but the trouble is that visually is cutting some characters, but size of text inside file have exactly the same size as if string is complete visually.
Eg: My pc is called of "TESTE-PC" (Without double quotes). The string "TESTE-PC" (Without double quotes) have exactly 8 bits, but SysUtils.FileWrite writes only "TEST" and size of file after is 8 bits. Very strange! :(
Thank you for any suggestion.
uses
Registry;
...
function GetCompName: string;
var
Reg: TRegistry;
begin
Reg := TRegistry.Create;
try
Reg.rootKey := HKEY_LOCAL_MACHINE;
if Reg.OpenKey('SYSTEM\CurrentControlSet\Control\ComputerName\ActiveComputerName', false) then
begin
Result := Reg.ReadString('ComputerName');
Reg.CloseKey;
end;
finally
Reg.Free;
end;
end;
procedure TForm1.FormCreate(Sender: TObject);
var
hFile: THandle;
Str: PWideChar;
begin
if not fileexists('test.txt') then
begin
Str := PWideChar(GetCompName);
hFile:= CreateFile('test.txt', GENERIC_WRITE, 0, nil, OPEN_ALWAYS, FILE_FLAG_WRITE_THROUGH, 0);
FileWrite(hFile, Str^, Length(Str));
CloseHandle(hFile);
end;
end;
First off, using the Registry to get the computer name is wrong. Use the GetComputerName() function instead:
uses
Windows;
...
function GetCompName: string;
var
CompName: array[0..MAX_COMPUTERNAME_LENGTH] of Char;
Size: DWORD;
begin
Size := Length(CompName);
if GetComputerName(CompName, Size) then
SetString(Result, CompName, Size-1)
else
Result := '';
end;
Second, your FileWrite() code fails because you are not handling character encodings correctly. FileWrite() operates on raw bytes only, but you are working with Unicode strings and not taking into account that SizeOf(WideChar) is 2, not 1 like your code assumes.
You should also be using the RTL's FileCreate() function with FileWrite(). If you use the Win32 CreateFile() function directly, you should be using the Win32 API WriteFile() directly as well.
And no matter how you choose to write the file, you should be using an absolute path to the file, never a relative path.
Try something more like this:
procedure TForm1.FormCreate(Sender: TObject);
var
FileName: string
hFile: THandle;
Str: string;
begin
FileName := 'C:\path to\test.txt';
if not FileExists(FileName) then
begin
Str := GetCompName;
hFile := FileCreate(FileName);
if hFile <> INVALID_HANDLE_VALUE then
begin
FileWrite(hFile, PChar(Str)^, Length(Str) * SizeOf(Char));
FileClose(hFile);
end;
end;
Note that the code above will create the file in UTF-16 encoding. If you wanted to use UTF-8 instead, it would look like this:
procedure TForm1.FormCreate(Sender: TObject);
var
FileName: string;
hFile: THandle;
Str: UTF8String;
begin
FileName := 'C:\path to\test.txt';
if not FileExists(FileName) then
begin
Str := UTF8String(GetCompName);
hFile := FileCreate(FileName);
if hFile <> INVALID_HANDLE_VALUE then
begin
FileWrite(hFile, PAnsiChar(Str)^, Length(Str));
FileClose(hFile);
end;
end;
Or any other encoding, for that matter:
procedure TForm1.FormCreate(Sender: TObject);
var
FileName: string;
hFile: THandle;
Enc: TEncoding;
Str: TBytes;
begin
FileName := 'C:\path to\test.txt';
if not FileExists(FileName) then
begin
Enc := TEncoding.GetEncoding('desired encoding');
try
Str := Enc.GetBytes(GetCompName);
finally
Enc.Free;
end;
hFile := FileCreate(FileName);
if hFile <> INVALID_HANDLE_VALUE then
begin
FileWrite(hFile, PByte(Str)^, Length(Str));
FileClose(hFile);
end;
end;
Whatever encoding you decide to use, a simpler solution would be to use the IOUtils.TFile.WriteAllText() method instead:
uses
IOUtils;
procedure TForm1.FormCreate(Sender: TObject);
var
FileName: string;
begin
FileName := 'C:\path to\test.txt';
if not FileExists(FileName) then
begin
TFile.WriteAllText(FileName, GetCompName, TEncoding.UTF8); // or TEncoding.Unicode, etc...
end;
end;
If you need to write wide chars, take their size into account:
FileWrite(hFile, Str^, Length(Str) * SizeOf(Char));
Change the type of str to RawByteString instead of PWideChar
procedure TForm1.FormCreate(Sender: TObject);
var
hFile: THandle;
sFileName: string;
Str: RawByteString;
begin
Str := PWideChar(GetCompName);
sFileName := 'Test.txt';
if fileExists(sFileName) then
hFile := fileOpen(sFileName,fmOpenReadWrite)
else
hFile := fileCreate(sFileName);
try
FileWrite(hFile,
PChar(Str)^, Length(Str));
finally
FileClose(hFile);
end;
end;
Related
Thanks to the below functions, I am succesfully retrieving, from a Word document stored locally (synced with the Server through OneDrive), its Server properties (those which are stored as SharePoint columns), all this without Ole automation. The functions' structure is:
Since the Word document is a zipped file, unzip the file where such properties are stored.
Extract the contents of the file into a string.
Load the string into an XML document.
Feed the field names and their contents into a StringList.
``
function WordGetServerProperties (FName:string):TStringList;
var
s,ss:string;
i,ii:integer;
St:TStringList;
XML:IXMLDocument;
N,NN: IXMLNode;
begin
s:=ExtractZipToStr(FName,'customXml/item1.xml',ExtractFilePath(FName));
if StrContains('<p:properties',s)=False then
s:=ExtractZipToStr(FName,'customXml/item2.xml',ExtractFilePath(FName));
if StrContains('<p:properties',s)=False then
s:=ExtractZipToStr(FName,'customXml/item3.xml',ExtractFilePath(FName));
XML:=NewXMLDocument;
St:=TStringList.Create;
XML.Active := True;
XML.LoadFromXML(s);
N:=xml.DocumentElement;
try
for i := 0 to N.ChildNodes.Count -1 do
begin
if N.ChildNodes[i].NodeName = 'documentManagement' then
begin
NN:=N.ChildNodes[i];
for ii := 0 to NN.ChildNodes.Count -1 do
begin
ss:=AnsiReplaceStr(NN.ChildNodes[ii].NodeName,'_x0020_',' ');
if ss='SharedWithUsers' then continue;
ss:=ss+'='+NN.ChildNodes[ii].Text;
st.Add(ss)
end;
end;
end;
finally
XML.Active := False;
end;
Result:=st;
end;
function ExtractZipToStr(const ZipFileName: string; const ZippedFileName, ExtractedFileName: string): widestring;
var
ZipFile: TZipFile;
F,s:string;
i:integer;
Exists:Boolean;
LStream: TStream;
FStream:TFileStream;
LocalHeader: TZipHeader;
begin
Exists:=False;
ZipFile := TZipFile.Create;
LStream := TStream.Create;
try
try
ZipFile.Open(ZipFileName,zmRead);
except on EZipException do begin Result:='noprops'; ZipFile.Close; ZipFile.Free; LStream.Free; exit; end; end;
for i := 0 to ZipFile.FileCount - 1 do
begin
F:= ZipFile.FileNames[i];
if F='docProps/custom.xml' then begin Exists:=True; system.Break; end;
end;
if exists=True then
begin
ZipFile.Read(ZippedFileName, LStream, LocalHeader);
LStream.Position:=0;
Result:=StreamToString(LStream);
end
else Result:='noprops';
finally
ZipFile.Close;
ZipFile.Free;
LStream.Free;
end;
end;
function StreamToString(aStream: TStream): widestring;
var
SS: TStringStream;
begin
if aStream <> nil then
begin
SS := TStringStream.Create('');
try
SS.CopyFrom(aStream, 0);
Result := SS.DataString;
finally
SS.Free;
end;
end else
begin
Result := '';
end;
end;
This is relatively fast but as not as much as I would like. Hopefully I have shown that (being amateur at this) I am at the end of my wits. Would you see any way to either improve or utterly replace these routines by something more efficient?
I am trying to get the reg_binary as string from a registry key.
This is my function
function ReadBinString(key: string; AttrName: string): string;
var
ReadStr: TRegistry;
begin
// Result := '';
ReadStr := TRegistry.Create(KEY_WRITE OR KEY_WOW64_64KEY);
ReadStr.RootKey := HKEY_LOCAL_MACHINE;
if ReadStr.OpenKey(key, true) then
begin
Result := ReadStr.GetDataAsString(AttrName);
end;
ReadStr.CloseKey;
ReadStr.Free;
end;
and here is my registry key Export :
Windows Registry Editor Version 5.00
[HKEY_LOCAL_MACHINE\SOFTWARE\ZES\ACINFO]
"iamthere"=dword:00000001
"ArrayOrder"=hex:4d,79,45,78,63,6c,75,64,65
the problem is , the function returns empty string
I even tried running as administrator to make sure that it is not permissions.
Any help ?
Expanding on my comment to the question, I'd use code like so:
function ReadBinString(RootKey: HKEY; Access: LongWord; const KeyName,
ValueName: string; Encoding: TEncoding): string;
var
Registry: TRegistry;
Bytes: TBytes;
begin
Registry := TRegistry.Create(Access);
try
Registry.RootKey := RootKey;
if Registry.OpenKeyReadOnly(KeyName) then begin
SetLength(Bytes, Registry.GetDataSize(ValueName));
Registry.ReadBinaryData(ValueName, Pointer(Bytes)^, Length(Bytes));
Result := Encoding.GetString(Bytes);
end else begin
Result := '';
end;
finally
Registry.Free;
end;
end;
For your data you would call it like so:
Value := ReadBinString(HKEY_LOCAL_MACHINE, KEY_WOW64_64KEY, 'Software\ZES\ACINFO',
'ArrayOrder', TEncoding.ANSI);
Notes:
I have avoided hard-coding the root key.
I have used TEncoding to decode the byte array to text. This is far more effective than GetDataAsString.
I have allowed the caller to specify the encoding to be used.
I have allowed the caller to specify the access flags.
I have used OpenKeyReadOnly because we do not require write access.
Thanks to David Heffernan I came with this solution:
function ReadBinString(key: string; AttrName: string): string;
var
ReadStr: TRegistry;
hexStr : string;
I : Integer;
begin
// Result := '';
ReadStr := TRegistry.Create(KEY_READ OR KEY_WOW64_64KEY);
ReadStr.RootKey := HKEY_LOCAL_MACHINE;
if ReadStr.OpenKey(key, true) then
begin
hexStr := ReadStr.GetDataAsString(AttrName);
hexStr := hexStr.Replace(',','');
for I := 1 to length (hexStr) div 2 do
Result:= Result+Char(StrToInt('$'+Copy(hexStr,(I-1)*2+1,2)));
end;
ReadStr.CloseKey;
ReadStr.Free;
end;
Thanks to David Heffernan again ... this worked for me :
function ReadBinString(key: string; AttrName: string): string;
var
ReadStr: TRegistry;
hexStr: string;
I: Integer;
Bytes: TBytes;
Encoding: TEncoding;
begin
Encoding := TEncoding.ANSI;
Result := '';
ReadStr := TRegistry.Create(KEY_READ OR KEY_WOW64_64KEY);
ReadStr.RootKey := HKEY_LOCAL_MACHINE;
try
if ReadStr.OpenKeyReadOnly(key ) then
begin
SetLength(Bytes, ReadStr.GetDataSize(AttrName));
ReadStr.ReadBinaryData(AttrName, Pointer(Bytes)^, Length(Bytes));
Result := Encoding.GetString(Bytes);
// hexStr := ReadStr.GetDataAsString(AttrName);
//
// hexStr := hexStr.Replace(',','');
// for I := 1 to length (hexStr) div 2 do
// Result:= Result+Char(StrToInt('$'+Copy(hexStr,(I-1)*2+1,2)));
end;
except
end;
ReadStr.CloseKey;
ReadStr.Free;
end;
I have this basic code that should encode a string and then get it back. However, the decoded text is garbage.
procedure TForm5.Button2Click(Sender: TObject);
VAR s1, s2, s3: String;
i: Integer;
begin
for i:= 1 to 200
DO s1:= s1+ char(Random(255));
s1:= EncdDecd.EncodeString(s1);
s3:= EncdDecd.DecodeString(s2);
if s1= s3
then Caption:= 'Equal'
else Caption:= 'Not equal';
end;
Update:
It works if I do char(Random(128)) instead of 255!
The problem is here, in the Soap.EncdDecd unit:
function EncodeString(const Input: string): string;
var
InStr, OutStr: TStringStream;
begin
InStr := TStringStream.Create(Input);
try
OutStr := TStringStream.Create('');
try
EncodeStream(InStr, OutStr);
Result := OutStr.DataString;
finally
OutStr.Free;
end;
finally
InStr.Free;
end;
end;
This code has not been updated for Unicode. The use of TStringStream for InStr without specifying an encoding is the problem. With no encoding specified, ANSI is used to decode to a byte array. And so only characters in the local ANSI code page are decoded correctly.
The same mistake is made in the other direction in DecodeString.
You can fix this readily enough by creating variants that specify a full Unicode encoding. For example:
function EncodeString(const Input: string): string;
var
InStr, OutStr: TStringStream;
begin
InStr := TStringStream.Create(Input, TEncoding.UTF8);
try
OutStr := TStringStream.Create('');
try
EncodeStream(InStr, OutStr);
Result := OutStr.DataString;
finally
OutStr.Free;
end;
finally
InStr.Free;
end;
end;
function DecodeString(const Input: string): string;
var
InStr, OutStr: TStringStream;
begin
InStr := TStringStream.Create(Input);
try
OutStr := TStringStream.Create('', TEncoding.UTF8);
try
DecodeStream(InStr, OutStr);
Result := OutStr.DataString;
finally
OutStr.Free;
end;
finally
InStr.Free;
end;
end;
It doesn't matter which encoding you specify so long as it is a full Unicode encoding, and you use the same encoding in both directions!
Clearly Embarcadero should be encouraged to make this change to their code.
This program demonstrates that the fix works:
{$APPTYPE CONSOLE}
uses
System.SysUtils, System.Classes, Soap.EncdDecd;
function EncodeString(const Input: string): string;
var
InStr, OutStr: TStringStream;
begin
InStr := TStringStream.Create(Input, TEncoding.UTF8);
try
OutStr := TStringStream.Create('');
try
EncodeStream(InStr, OutStr);
Result := OutStr.DataString;
finally
OutStr.Free;
end;
finally
InStr.Free;
end;
end;
function DecodeString(const Input: string): string;
var
InStr, OutStr: TStringStream;
begin
InStr := TStringStream.Create(Input);
try
OutStr := TStringStream.Create('', TEncoding.UTF8);
try
DecodeStream(InStr, OutStr);
Result := OutStr.DataString;
finally
OutStr.Free;
end;
finally
InStr.Free;
end;
end;
const
N = 256;
var
i: Integer;
s1, s2: string;
begin
SetLength(s1, N);
for i := 1 to N do
s1[i] := Chr(i-1);
s2 := Soap.EncdDecd.EncodeString(s1);
s2 := Soap.EncdDecd.DecodeString(s2);
Writeln(s1=s2);
s2 := EncodeString(s1);
s2 := DecodeString(s2);
Writeln(s1=s2);
end.
Output:
FALSE
TRUE
Quick fix:
ANSI is enough for me since the text resulted after encoding must be as short as possible (easy to send via email). So, I put my ANSI string into a stream and encoded/decoded the stream. It worked!
Jesus. Some documentation (at least a single comment line) would have been nice!
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;
I am trying to use Huffman algorithm from http://www.explainth.at/downloads/huff.zip
There are two function in the unit :
function Compress(ASource:TMemoryStream):TMemoryStream;
function DeCompress(ASource:TMemoryStream):TMemoryStream;
I've successfully compressed each lines from a file onto an another file.
function StreamToString(const stream: TStream) : string;
var
Size: Integer;
begin
result:='';
Size := Stream.Size - Stream.Position;
SetString(result, nil, Size);
Stream.Read(Pointer(result)^, Size);
end;
procedure TMaster.Button1Click(Sender: TObject);
var
list,list_:TStringlist;
AStream:TMemoryStream;
BStream:TMemoryStream;
s:string;
i,j:integer;
begin
list := TStringList.Create;
list_:= TStringList.Create;
list.LoadFromFile('d:\input.txt');
for j := 0 to List.Count - 1 do
begin
s:=list[j];
if (Length(s) = 0) then exit;
{i:=Pos(#13#10,s);
while (i > 0) do
begin
Delete(s,i,2);
i:=Pos(#13#10,s);
end;}
AStream:=TMemoryStream.Create;
with AStream do WriteBuffer(s[1],Length(s));
with THuffman.Create do
try
BStream:=Compress(AStream);
finally
Free;
AStream.Free;
end;
with THuffman.Create do
try
AStream:=ProcessToDecrypt (BStream);
list_.Add(StreamToString(BStream));
finally
BStream.Free;
end
end; //for j := 0 to List.Count - 1 do
list_.SaveToFile('d:\output.txt');
list_.free;
list.free;
end;
function THuffman.ProcessToDecrypt(ASource:TMemoryStream):TMemoryStream;
var ASize:Integer;
begin
ASize:=ReBuildTree(ASource);
exit;
end;
I also want to decompress each compressed line from a file to string.
Here's what I done to decompress the string
procedure TMaster.Button2Click(Sender: TObject);
var i:Integer;
AText:String;
AStream:TMemoryStream;
BStream:TMemoryStream;
begin
AText:='È1ëz-';
BStream:=TMemoryStream.Create;
with BStream do WriteBuffer(AText[1],Length(AText));
with THuffman.Create do
try
AStream:=ProcessToDecrypt (BStream);
AStream:=Decompress(BStream);
memoOut.Lines.add.StreamToString(BStream);
finally
BStream.Free;
end;
end;
Button2Click procedure doesn't work. The short question is how do I decompress the compressed string?
The parameter of DeCompress is TMemoryStream, How do I use a string as the parameter?
How to make the output of DeCompress as string?
In addition to my comments above, just looking at your code, the value in AText is likely not a correct representation of the compressed string. The following very simple program (based on yours) works:
uses Huffman;
procedure TForm1.UncompressButtonClick(Sender: TObject);
var
AStream:TMemoryStream;
BStream:TMemoryStream;
begin
BStream:=TMemoryStream.Create;
with BStream do LoadFromFile('c:\temp\in.txt');
with THuffman.Create do
try
AStream:=Decompress(BStream);
AStream.SaveToFile('c:\temp\out.txt');
finally
BStream.Free;
end;
end;
procedure TForm1.CompressButtonClick(Sender: TObject);
var
AText:String;
AStream:TMemoryStream;
BStream:TMemoryStream;
begin
AText := Edit1.Text;
BStream:=TMemoryStream.Create;
with BStream do WriteBuffer(AText[1],Length(AText));
with THuffman.Create do
try
AStream:=Compress(BStream);
AStream.SaveToFile('c:\temp\in.txt');
finally
BStream.Free;
end;
end;