Decompress compressed string with Huffman algorithm - delphi

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;

Related

Retrieve Word server properties with Delphi

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?

delphi THashSHA2 return a wrong SHA256 on huge file

Data.Cloud.CloudAPI.pas has class function TCloudSHA256Authentication.GetStreamToHashSHA256Hex(const Content: TStream): string; that return wrong SHA 256 on some file.
class function TCloudSHA256Authentication.GetStreamToHashSHA256Hex(const Content: TStream): string;
var
LBytes : TBytes;
Hash: THashSHA2;
begin
LBytes := TBytesStream(Content).Bytes;
//Hash bytes
Hash := THashSHA2.Create;
Hash.Update(LBytes);
Result := Hash.HashAsString;
end;
AWS S3 return error:
The provided x-amz-content-sha256 header does not match what was computed
GetStreamToHashSHA256Hex seems produce a different sha256 from amazon:
<ClientComputedContentSHA256>f43ee89e2b7758057bb1f33eb8546d4c2c118f2ab932de89dbd74aabc0651053</ClientComputedContentSHA256>
<S3ComputedContentSHA256>3bbf5f864cc139cf6392b4623bd782a69d16929db713bffaa68035f8a5c3c0ce</S3ComputedContentSHA256>
I have made some tests wit a myfile.zip (600 MB) ...
TIdHashSHA256 an alternative from Indy return the right SHA256 (same of aws s3), eg.:
var
aFileStream: TFileStream;
aHash: TIdHashSHA256;
begin
aFileStream := TFileStream.Create('C:\myfile.zip', fmOpenRead or fmShareDenyWrite);
aHash := TIdHashSHA256.Create;
try
Result := aHash.HashStreamAsHex(aFileStream).ToLower;
finally
aFileStream.Free;
aHash.Free;
end;
end;
hash_file() from PHP return the right SHA256 (same of aws s3), eg.:
hash_file('sha256', 'C:\myfile.zip');
but THashSHA2 return a wrong sha256, eg.:
var
LBytes : TBytes;
Hash: THashSHA2;
begin
LBytes := TFile.ReadAllBytes('C:\myfile.zip');
Hash := THashSHA2.Create;
Hash.Update(LBytes);
Result := Hash.HashAsString;
end;
why?
UPDATE
this is my bug fix. Import Data.Cloud.CloudAPI.pas into the project and rewrite these function:
uses IdHash, IdHashSHA, IdSSLOpenSSL;
class function TCloudSHA256Authentication.GetHashSHA256Hex( HashString: string): string;
var
aHash: TIdHashSHA256;
begin
LoadOpenSSLLibrary;
try
if not(TIdHashSHA256.IsAvailable) then
raise Exception.Create('HashSHA256 Isn''t available!');
aHash := TIdHashSHA256.Create;
try
Result := aHash.HashStringAsHex(HashString).ToLower;
finally
aHash.Free;
end;
finally
UnLoadOpenSSLLibrary;
end;
end;
class function TCloudSHA256Authentication.GetStreamToHashSHA256Hex(const Content: TStream): string;
var
aHash: TIdHashSHA256;
begin
LoadOpenSSLLibrary;
try
if not(TIdHashSHA256.IsAvailable) then
raise Exception.Create('HashSHA256 Isn''t available!');
aHash := TIdHashSHA256.Create;
try
Result := aHash.HashStreamAsHex(Content).ToLower;
finally
aHash.Free;
end;
finally
UnLoadOpenSSLLibrary;
end;
end;
UPDATE 2
i have also try to implement the FredS suggestion, it works:
class function TCloudSHA256Authentication.GetHashSHA256Hex( HashString: string): string;
var
Content: TStringStream;
Hash: THashSHA2;
LBytes: TArray<Byte>;
Buffer: PByte;
BufLen: Integer;
Readed: Integer;
begin
BufLen := 16 * 1024;
Buffer := AllocMem(BufLen);
Hash := THashSHA2.Create;
Content := TStringStream.Create(HashString);
try
while Content.Position < Content.Size do
begin
Readed := Content.Read(Buffer^, BufLen);
if Readed > 0 then
Hash.update(Buffer^, Readed);
end;
finally
Content.Free;
FreeMem(Buffer);
end;
Result := Hash.HashAsString;
end;
class function TCloudSHA256Authentication.GetStreamToHashSHA256Hex(const Content: TStream): string;
var
LBytes : TBytes;
Hash: THashSHA2;
Buffer: PByte;
BufLen: Integer;
Readed: Integer;
begin
BufLen := 16 * 1024;
Buffer := AllocMem(BufLen);
Hash := THashSHA2.Create;
try
Content.Seek(0, soFromBeginning);
while Content.Position < Content.Size do
begin
Readed := Content.Read(Buffer^, BufLen);
if Readed > 0 then
Hash.update(Buffer^, Readed);
end;
Content.Seek(0, soFromBeginning);
finally
FreeMem(Buffer);
end;
Result := Hash.HashAsString;
end;
I just tested a +1.5 GB file using MS Cyrpto and THashSHA2 on Berlin, they both returned the same hash but MS Crypto like OpenSSL is much faster.
The problem is that the file is too large to hold in TBytes in one chunk.
My record helper has TBytes.MaxLen = $F000; {61440} so you need to use a TFileStream and read the file in chunks into HashSHA2.Update instead.
Update:
As per David Heffernan's comment I retested TBytes.MaxLen and it appears to be only limited by available memory.
Practical Example and Speed comparison between MS Crypto and Delphi HashSha2
Note: Requires Jedi API
program SHA2SpeedTest;
{$APPTYPE CONSOLE}
{$R *.res}
uses
JwaWindows, Winapi.Windows, System.SysUtils, System.Classes, System.Diagnostics, System.Hash;
const
SHA256_LEN = 256 div 8;
ChunkSize = $F000;
type
TBytesHelper = record helper for TBytes
public
function BinToHex: string;
end;
function TBytesHelper.BinToHex: string;
var
Len : Integer;
begin
Len := Length(Self);
SetLength(Result, Len * 2));
System.Classes.BinToHex(Self, PChar(Result), Len);
end;
procedure DelphiHash256(const AStream: TStream; out Bytes: TBytes);
var
HashSHA2: THashSHA2;
BytesRead: Integer;
begin
HashSHA2 := THashSHA2.create;
SetLength(Bytes, ChunkSize);
AStream.Position := 0;
repeat
BytesRead := AStream.Read(Bytes, ChunkSize);
if (BytesRead = 0) then Break; // Done
HashSHA2.Update(Bytes, BytesRead);
until False;
Bytes := HashSHA2.HashAsBytes;
end;
function CryptoHash256(const AStream: TStream; out Bytes: TBytes): Boolean;
var
SigLen : Cardinal;
hHash : HCRYPTHASH;
hProv : HCRYPTPROV;
BytesRead: Integer;
begin
hProv := 0; hHash := 0;
Result := False;
If not CryptAcquireContext(hProv, nil, nil, PROV_RSA_AES, CRYPT_VERIFYCONTEXT) then Exit;
try
if not CryptCreateHash(hProv, CALG_SHA_256, 0, 0, hHash) then Exit;
try
SetLength(Bytes, ChunkSize);
AStream.Position := 0;
repeat
BytesRead := AStream.Read(Bytes, ChunkSize);
if (BytesRead = 0) then Break; // Done
if not CryptHashData(hHash, #Bytes[0], BytesRead, 0) then Exit;
until False;
SigLen := SHA256_LEN;
SetLength(Bytes, SigLen);
Result := CryptGetHashParam(hHash, HP_HASHVAL, #Bytes[0], SigLen, 0);
finally
CryptDestroyHash(hHash);
end;
finally
CryptReleaseContext(hProv, 0);
end;
end;
var
Stream: TStream;
Bytes : TBytes;
sw : TStopwatch;
CryptoTicks : int64;
FileName : string;
{* CheckFileName *}
function CheckFileName: boolean;
begin
if (FileName='') then FileName := ParamStr(0);
Result := FileExists(FileName);
if not Result then Writeln('Invalid File name');
end;
begin
repeat
Writeln('Please Enter a valid File name, empty for this Executable');
Readln(FileName);
until CheckFileName;
try
Stream := TFileStream.Create(FileName, fmOpenRead + fmShareDenyNone);
try
WriteLn('Crypto - Calculating Checksum');
sw.Start;
if not CryptoHash256(Stream, Bytes) then raise Exception.Create('Something Happened :)');
sw.Stop;
Writeln(Bytes.BinToHex);
WriteLn('Elapsed: ' + sw.Elapsed.ToString);
CryptoTicks := sw.ElapsedTicks;
WriteLn('Delphi - Calculating Checksum');
sw.Reset; sw.Start;
DelphiHash256(Stream, Bytes);
sw.Stop;
Writeln(Bytes.BinToHex);
WriteLn('Elapsed: ' + sw.Elapsed.ToString);
Writeln(Format('MS Crypto is %d%% faster', [(sw.ElapsedTicks-CryptoTicks) * 100 div CryptoTicks]));
finally
Stream.Free;
end;
Writeln('Hit <Enter> to exit');
Readln;
except
on E: Exception do Writeln(E.ClassName, ': ', E.Message);
end;
end.

Delphi ZLib Compress / Decompress

I've got a minor issue with decompressing using the ZLib unit in Delphi
unit uZCompression;
interface
uses
uCompression;
type
TZZipCompression = class(TInterfacedObject, ICompression)
public
function DoCompression(aContent: TArray<Byte>): TArray<Byte>;
function DoDecompression(aContent: TArray<Byte>): TArray<Byte>;
function GetWindowsBits: Integer; virtual;
end;
TZGZipCompression = class(TZZipCompression)
function GetWindowsBits: Integer; override;
end;
implementation
uses
System.ZLib, System.Classes, uMxKxUtils;
{ TZCompression }
function TZZipCompression.DoCompression(aContent: TArray<Byte>): TArray<Byte>;
var
LContentStream, LOutputStream: TMemoryStream;
LCompressedStream: TZCompressionStream;
begin
LContentStream := ByteArrayToStream(aContent);
LOutputStream := TMemoryStream.Create;
LCompressedStream := TZCompressionStream.Create(LOutputStream, zcDefault, GetWindowsBits);
LCompressedStream.CopyFrom(LContentStream, LContentStream.Size);
LCompressedStream.Free;
Result := StreamToByteArray(LOutputStream);
LOutputStream.Free;
LContentStream.Free;
end;
function TZZipCompression.DoDecompression(aContent: TArray<Byte>): TArray<Byte>;
var
LContentStream, LOutputStream: TMemoryStream;
LDecompressedStream: TZDecompressionStream;
begin
LContentStream := ByteArrayToStream(aContent);
LOutputStream := TMemoryStream.Create;
LDecompressedStream := TZDecompressionStream.Create(LContentStream);
LOutputStream.CopyFrom(LDecompressedStream, LDecompressedStream.Size);
LDecompressedStream.Free;
Result := StreamToByteArray(LOutputStream);
LOutputStream.Free;
LContentStream.Free;
end;
function TZZipCompression.GetWindowsBits: Integer;
begin
Result := 15;
end;
{ TZGZipCompression }
function TZGZipCompression.GetWindowsBits: Integer;
begin
Result := inherited;
Result := Result + 16;
end;
end.
This is my unit which is driven by an interface (which you don't need to know about), and data is passed in and out through a TArray variables.
I've coded it to be able to do 2 types of compression, standard zip and gzip which is determined by the windowsbits passed in to the functions.
Here are a couple of other functions being used to convert the TArray to TMemoryStream
function ByteArrayToStream(aContent: TArray<Byte>): TMemoryStream;
begin
Result := TMemoryStream.Create;
Result.Write(aContent, length(aContent)*SizeOf(aContent[0]));
Result.Position := 0;
end;
function StreamToByteArray(aStream: TMemoryStream): TArray<Byte>;
var
LStreamPos: Int64;
begin
if Assigned(aStream) then
begin
LStreamPos := aStream.Position;
aStream.Position := 0;
SetLength(Result, aStream.Size);
aStream.Read(Result, aStream.Size);
aStream.Position := LStreamPos;
end
else
SetLength(Result, 0);
end;
Now I can compress and decompress to .zip using the TZZipCompression class perfectly fine (it doesn't open up as a zip file, but it does decompress back to the original file which I can open and edit).
I can also compress to .gz using the TZGZipCompression class fine as well (interestingly I can open this gzip file perfectly well).
My issue however is that it won't decompress back from the .gz file and throws and error as soon as it hits
LOutputStream.CopyFrom(LDecompressedStream, LDecompressedStream.Size)
Funnily enough the Help file example has it as below
LOutputStream.CopyFrom(LDecompressedStream, 0)
But this doesn't work either.
Can anyone spot the issue?
Your conversion functions between TArray<Byte> and TMemoryStream are wrong, as you are not accessing the array content correctly. TArray is a dynamic array. When calling TMemoryStream.Write() and TMemoryStream.Read(), you are passing the memory address of the TArray itself, not the memory address of the data that the TArray points at. You need to reference the TArray to get the correct memory address, eg:
function ByteArrayToStream(const aContent: TArray<Byte>): TMemoryStream;
begin
Result := TMemoryStream.Create;
try
if Length(aContent) > 0 then
Result.WriteBuffer(aContent[0], Length(aContent));
Result.Position := 0;
except
Result.Free;
raise;
end;
end;
function StreamToByteArray(aStream: TMemoryStream): TArray<Byte>;
begin
if Assigned(aStream) then
begin
SetLength(Result, aStream.Size);
if Length(Result) > 0 then
Move(aStream.Memory^, Result[0], aStream.Size);
end
else
SetLength(Result, 0);
end;
Alternatively:
function ByteArrayToStream(const aContent: TArray<Byte>): TMemoryStream;
begin
Result := TMemoryStream.Create;
try
Result.WriteBuffer(PByte(aContent)^, Length(aContent));
Result.Position := 0;
except
Result.Free;
raise;
end;
end;
function StreamToByteArray(aStream: TMemoryStream): TArray<Byte>;
begin
if Assigned(aStream) then
begin
SetLength(Result, aStream.Size);
Move(aStream.Memory^, PByte(Result)^, aStream.Size);
end
else
SetLength(Result, 0);
end;
That being said, you don't need to waste memory making copies of the array data using TMemoryStream. You can use TBytesStream instead (since dynamic arrays are reference counted), eg:
function TZZipCompression.DoCompression(aContent: TArray<Byte>): TArray<Byte>;
var
LContentStream, LOutputStream: TBytesStream;
LCompressedStream: TZCompressionStream;
begin
LContentStream := TBytesStream.Create(aContent);
try
LOutputStream := TBytesStream.Create(nil);
try
LCompressedStream := TZCompressionStream.Create(LOutputStream, zcDefault, GetWindowsBits);
try
LCompressedStream.CopyFrom(LContentStream, 0);
finally
LCompressedStream.Free;
end;
Result := Copy(LOutputStream.Bytes, 0, LOutputStream.Size);
finally
LOutputStream.Free;
end;
finally
LContentStream.Free;
end;
end;
function TZZipCompression.DoDecompression(aContent: TArray<Byte>): TArray<Byte>;
var
LContentStream, LOutputStream: TBytesStream;
LDecompressedStream: TZDecompressionStream;
begin
LContentStream := TBytesStream.Create(aContent);
try
LOutputStream := TBytesStream.Create(nil);
try
LDecompressedStream := TZDecompressionStream.Create(LContentStream, GetWindowsBits);
try
LOutputStream.CopyFrom(LDecompressedStream, 0);
finally
LDecompressedStream.Free;
end;
Result := Copy(LOutputStream.Bytes, 0, LOutputStream.Size);
finally
LOutputStream.Free;
end;
finally
LContentStream.Free;
end;
end;

How write to a txt file using SysUtils.FileWrite api?

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;

How to save strings in a stringlist which is created in another procedure?

i need some help with my procedure. I want to save some strings in a stringlist which is created in another procedure. How can i do this?
I wrote a comment at the right place to understand it better.
procedure GetIniNamesWithoutExt(IniPfade: TStringList);
var
i, suchPunkt: integer;
ini: TIniFile;
Modul, fullFileName, IniName: String;
begin
try
for i := 0 to IniPfade.Count-1 do
begin
fullFileName := IniPfade.Strings[i];
Modul := ExtractFileName(fullFileName); // Dateiname aktueller Ini + .Ini Endung
suchPunkt := Pos('.', Modul);
IniName := Copy(Modul, 1, suchPunkt-1); // Aktueller Modulname ohne ini Endung
// Here should be the Code for saving the String "IniName" to a StringList which is created in procedure a. Procedure a calls the procedure GetIniNamesWithoutExt.
end;
finally
end;
end;
How about
procedure GetIniNamesWithoutExt(IniPfade, Module: TStrings);
var
i, suchPunkt: integer;
ini: TIniFile;
Modul, fullFileName, IniName: String;
begin
Module.BeginUpdate;
try
for i := 0 to IniPfade.Count-1 do
begin
fullFileName := IniPfade.Strings[i];
Modul := ExtractFileName(fullFileName); // Dateiname aktueller Ini + .Ini Endung
suchPunkt := Pos('.', Modul);
IniName := Copy(Modul, 1, suchPunkt-1); // Aktueller Modulname ohne ini Endung
Module.Add(IniName);
end;
finally
Module.EndUpdate;
end;
end;
and from procedure A:
procedure A;
var
Module: TStringList;
begin
Module := TStringList.Create;
try
GetIniNamesWithoutExt(IniPfade , Module);
// Do Whatever you want with "Module"
finally
Module.Free;
end;
end;

Resources