Delphi: crypting resource file - delphi

I have this function that should crypt bytes from resource file but it's just crashing my app:
function crypt(src: Pointer; len: DWORD): DWORD;
var
B: TByteArray absolute src;
index: DWORD;
begin
for index := 0 to len - 1 do
begin
B[index] := B[index] xor 5; //just to test if its working
end;
result := 1;
end;
i am using it like this:
hFind := FindResource(...);
size := SizeOfResource(HInstance, hFind);
hRes :=LoadResource(HInstance, hFind);
bytes :=LockResource(hRes);
crypt(bytes, size);
if i dont call the crypt function program works. What am i doing wrong?

You've got two problems with that code. First is with the byte array, its elements do not contain your resource data but random data starting with the address of your pointer 'src'. Use a pointer to a TByteArray like this:
var
B: PByteArray absolute src;
index: DWORD;
begin
for index := 0 to len - 1 do
begin
B^[index] := B^[index] xor 5; //just to test if its working
end;
..
Second is, you'll still get an AV for trying to modify a read-only memory segment. Depending on what you are trying to do, you can use VirtualProtect on 'bytes' before calling 'crypt', or copy the memory to a byte array and modify it there, or use BeginUpdateResource-UpdateResource-EndUpdateResource if you're trying to modify the resource.

Code like this is easiest to write with pointers like this:
function crypt(src: Pointer; len: DWORD): DWORD;
var
B: ^Byte;
index: DWORD;
begin
B := src;
for index := 0 to len - 1 do
begin
B^ := B^ xor 5; //just to test if its working
inc(B);
end;
result := 1;
end;
Naturally you do need to respect the issue of read-only memory that Sertac highlighted. I'm just adding this code to illustrate what I believe to be the canonical way to walk a buffer that arrives as a void pointer.

Related

How to read last line in a text file using Delphi

I need to read the last line in some very large textfiles (to get the timestamp from the data). TStringlist would be a simple approach but it returns an out of memory error. I'm trying to use seek and blockread, but the characters in the buffer are all nonsense. Is this something to do with unicode?
Function TForm1.ReadLastLine2(FileName: String): String;
var
FileHandle: File;
s,line: string;
ok: 0..1;
Buf: array[1..8] of Char;
k: longword;
i,ReadCount: integer;
begin
AssignFile (FileHandle,FileName);
Reset (FileHandle); // or for binary files: Reset (FileHandle,1);
ok := 0;
k := FileSize (FileHandle);
Seek (FileHandle, k-1);
s := '';
while ok<>1 do begin
BlockRead (FileHandle, buf, SizeOf(Buf)-1, ReadCount); //BlockRead ( var FileHandle : File; var Buffer; RecordCount : Integer {; var RecordsRead : Integer} ) ;
if ord (buf[1]) <>13 then //Arg to integer
s := s + buf[1]
else
ok := ok + 1;
k := k-1;
seek (FileHandle,k);
end;
CloseFile (FileHandle);
// Reverse the order in the line read
setlength (line,length(s));
for i:=1 to length(s) do
line[length(s) - i+1 ] := s[i];
Result := Line;
end;
Based on www.delphipages.com/forum/showthread.php?t=102965
The testfile is a simple CSV I created in excel ( this is not the 100MB I ultimately need to read).
a,b,c,d,e,f,g,h,i,j,blank
A,B,C,D,E,F,G,H,I,J,blank
1,2,3,4,5,6,7,8,9,0,blank
Mary,had,a,little,lamb,His,fleece,was,white,as,snow
And,everywhere,that,Mary,went,The,lamb,was,sure,to,go
You really have to read the file in LARGE chunks from the tail to the head.
Since it is so large it does not fit the memory - then reading it line by line from start to end would be very slow. With ReadLn - twice slow.
You also has to be ready that the last line might end with EOL or may not.
Personally I would also account for three possible EOL sequences:
CR/LF aka #13#10=^M^J - DOS/Windows style
CR without LF - just #13=^M - Classic MacOS file
LF without CR - just #10=^J - UNIX style, including MacOS version 10
If you are sure your CSV files would only ever be generated by native Windows programs it would be safe to assume full CR/LF be used. But if there can be other Java programs, non-Windows platforms, mobile programs - I would be less sure. Of course pure CR without LF would be the least probable case of them all.
uses System.IOUtils, System.Math, System.Classes;
type FileChar = AnsiChar; FileString = AnsiString; // for non-Unicode files
// type FileChar = WideChar; FileString = UnicodeString;// for UTF16 and UCS-2 files
const FileCharSize = SizeOf(FileChar);
// somewhere later in the code add: Assert(FileCharSize = SizeOf(FileString[1]);
function ReadLastLine(const FileName: String): FileString; overload; forward;
const PageSize = 4*1024;
// the minimal read atom of most modern HDD and the memory allocation atom of Win32
// since the chances your file would have lines longer than 4Kb are very small - I would not increase it to several atoms.
function ReadLastLine(const Lines: TStringDynArray): FileString; overload;
var i: integer;
begin
Result := '';
i := High(Lines);
if i < Low(Lines) then exit; // empty array - empty file
Result := Lines[i];
if Result > '' then exit; // we got the line
Dec(i); // skip the empty ghost line, in case last line was CRLF-terminated
if i < Low(Lines) then exit; // that ghost was the only line in the empty file
Result := Lines[i];
end;
// scan for EOLs in not-yet-scanned part
function FindLastLine(buffer: TArray<FileChar>; const OldRead : Integer;
const LastChunk: Boolean; out Line: FileString): boolean;
var i, tailCRLF: integer; c: FileChar;
begin
Result := False;
if Length(Buffer) = 0 then exit;
i := High(Buffer);
tailCRLF := 0; // test for trailing CR/LF
if Buffer[i] = ^J then begin // LF - single, or after CR
Dec(i);
Inc(tailCRLF);
end;
if (i >= Low(Buffer)) and (Buffer[i] = ^M) then begin // CR, alone or before LF
Inc(tailCRLF);
end;
i := High(Buffer) - Max(OldRead, tailCRLF);
if i - Low(Buffer) < 0 then exit; // no new data to read - results would be like before
if OldRead > 0 then Inc(i); // the CR/LF pair could be sliced between new and previous buffer - so need to start a bit earlier
for i := i downto Low(Buffer) do begin
c := Buffer[i];
if (c=^J) or (c=^M) then begin // found EOL
SetString( Line, #Buffer[i+1], High(Buffer) - tailCRLF - i);
exit(True);
end;
end;
// we did not find non-terminating EOL in the buffer (except maybe trailing),
// now we should ask for more file content, if there is still left any
// or take the entire file (without trailing EOL if any)
if LastChunk then begin
SetString( Line, #Buffer[ Low(Buffer) ], Length(Buffer) - tailCRLF);
Result := true;
end;
end;
function ReadLastLine(const FileName: String): FileString; overload;
var Buffer, tmp: TArray<FileChar>;
// dynamic arrays - eases memory management and protect from stack corruption
FS: TFileStream; FSize, NewPos: Int64;
OldRead, NewLen : Integer; EndOfFile: boolean;
begin
Result := '';
FS := TFile.OpenRead(FileName);
try
FSize := FS.Size;
if FSize <= PageSize then begin // small file, we can be lazy!
FreeAndNil(FS); // free the handle and avoid double-free in finally
Result := ReadLastLine( TFile.ReadAllLines( FileName, TEncoding.ANSI ));
// or TEncoding.UTF16
// warning - TFIle is not share-aware, if the file is being written to by another app
exit;
end;
SetLength( Buffer, PageSize div FileCharSize);
OldRead := 0;
repeat
NewPos := FSize - Length(Buffer)*FileCharSize;
EndOfFile := NewPos <= 0;
if NewPos < 0 then NewPos := 0;
FS.Position := NewPos;
FS.ReadBuffer( Buffer[Low(Buffer)], (Length(Buffer) - OldRead)*FileCharSize);
if FindLastLine(Buffer, OldRead, EndOfFile, Result) then
exit; // done !
tmp := Buffer; Buffer := nil; // flip-flop: preparing to broaden our mouth
OldRead := Length(tmp); // need not to re-scan the tail again and again when expanding our scanning range
NewLen := Min( 2*Length(tmp), FSize div FileCharSize );
SetLength(Buffer, NewLen); // this may trigger EOutOfMemory...
Move( tmp[Low(tmp)], Buffer[High(Buffer)-OldRead+1], OldRead*FileCharSize);
tmp := nil; // free old buffer
until EndOfFile;
finally
FS.Free;
end;
end;
PS. Note one extra special case - if you would use Unicode chars (two-bytes ones) and would give odd-length file (3 bytes, 5 bytes, etc) - you would never be ble to scan the starting single byte (half-widechar). Maybe you should add the extra guard there, like Assert( 0 = FS.Size mod FileCharSize)
PPS. As a rule of thumb you better keep those functions out of the form class, - because WHY mixing them? In general you should separate concerns into small blocks. Reading file has nothing with user interaction - so should better be offloaded to an extra UNIT. Then you would be able to use functions from that unit in one form or 10 forms, in main thread or in multi-threaded application. Like LEGO parts - they give you flexibility by being small and separate.
PPPS. Another approach here would be using memory-mapped files. Google for MMF implementations for Delphi and articles about benefits and problems with MMF approach. Personally I think rewriting the code above to use MMF would greatly simplify it, removing several "special cases" and the troublesome and memory copying flip-flop. OTOH it would demand you to be very strict with pointers arithmetic.
https://en.wikipedia.org/wiki/Memory-mapped_file
https://msdn.microsoft.com/en-us/library/ms810613.aspx
http://torry.net/quicksearchd.php?String=memory+map&Title=No
Your char type is two byte, so that buffer is 16 byte. Then with blockread you read sizeof(buffer)-1 byte into it, and check the first 2 byte char if it is equal to #13.
The sizeof(buffer)-1 is dodgy (where does that -1 come from?), and the rest is valid, but only if your input file is utf16.
Also your read 8 (or 16) characters each time, but compare only one and then do a seek again. That is not very logical either.
If your encoding is not utf16, I suggest you change the type of a buffer element to ansichar and remove the -1
In response to kopiks suggestion, I figured out how to do it with TFilestream, it works ok with the simple test file, though there may be some further tweeks when I use it on a variety of csv files. Also, I don't make any claims that this is the most efficient method.
procedure TForm1.Button6Click(Sender: TObject);
Var
StreamSize, ApproxNumRows : Integer;
TempStr : String;
begin
if OpenDialog1.Execute then begin
TempStr := ReadLastLineOfTextFile(OpenDialog1.FileName,StreamSize, ApproxNumRows);
// TempStr := ReadFileStream('c:\temp\CSVTestFile.csv');
ShowMessage ('approximately '+ IntToStr(ApproxNumRows)+' Rows');
ListBox1.Items.Add(TempStr);
end;
end;
Function TForm1.ReadLastLineOfTextFile(const FileName: String; var StreamSize, ApproxNumRows : Integer): String;
const
MAXLINELENGTH = 256;
var
Stream: TFileStream;
BlockSize,CharCount : integer;
Hash13Found : Boolean;
Buffer : array [0..MAXLINELENGTH] of AnsiChar;
begin
Hash13Found := False;
Result :='';
Stream := TFileStream.Create(FileName, fmOpenRead or fmShareDenyWrite);
StreamSize := Stream.size;
if StreamSize < MAXLINELENGTH then
BlockSize := StreamSize
Else
BlockSize := MAXLINELENGTH;
// for CharCount := 0 to Length(Buffer)-1 do begin
// Buffer[CharCount] := #0; // zeroing the buffer can aid diagnostics
// end;
CharCount := 0;
Repeat
Stream.Seek(-(CharCount+3), 2); //+3 misses out the #0,#10,#13 at the end of the file
Stream.Read( Buffer[CharCount], 1);
Result := String(Buffer[CharCount]) + result;
if Buffer[CharCount] =#13 then
Hash13Found := True;
Inc(CharCount);
Until Hash13Found OR (CharCount = BlockSize);
ShowMessage(Result);
ApproxNumRows := Round(StreamSize / CharCount);
end;
Just thought of a new solution.
Again, there could be better ones, but this one is the best i thought of.
function GetLastLine(textFilePath: string): string;
var
list: tstringlist;
begin
list := tstringlist.Create;
try
list.LoadFromFile(textFilePath);
result := list[list.Count-1];
finally
list.free;
end;
end;

How to concat multiple strings with Move?

How can I concat an array of strings with Move. I tried this but I just cannot figure how to get Move operation working correctly.
program Project2;
{$POINTERMATH ON}
procedure Concat(var S: String; const A: Array of String);
var
I, J: Integer;
Len: Integer;
begin
Len := 0;
for I := 0 to High(A) do
Len := Len + Length(A[I]);
SetLength(S, Length(S) + Len);
for I := 0 to High(A) do
Move(PWideChar(A[I])[0], S[High(S)], Length(A[I]) * SizeOf(WideChar));
end;
var
S: String;
begin
S := 'test';
Concat(S, ['test', 'test2', 'test3']);
end.
I'd write this function like so:
procedure Concat(var Dest: string; const Source: array of string);
var
i: Integer;
OriginalDestLen: Integer;
SourceLen: Integer;
TotalSourceLen: Integer;
DestPtr: PChar;
begin
TotalSourceLen := 0;
OriginalDestLen := Length(Dest);
for i := low(Source) to high(Source) do begin
inc(TotalSourceLen, Length(Source[i]));
end;
SetLength(Dest, OriginalDestLen + TotalSourceLen);
DestPtr := PChar(Pointer(Dest)) + OriginalDestLen;
for i := low(Source) to high(Source) do begin
SourceLen := Length(Source[i]);
Move(Pointer(Source[i])^, DestPtr^, SourceLen*SizeOf(Char));
inc(DestPtr, SourceLen);
end;
end;
It's fairly self-explanatory. The complications are caused by empty strings. Any attempt to index characters of an empty string will lead to exceptions when range checking is enabled.
To handle that complication, you can add if tests for the case where one of the strings involved in the Move call is empty. I prefer a different approach. I'd rather cast the string variable to be a pointer. That bypasses range checking but also allows the if statement to be omitted.
Move(Pointer(Source[i])^, DestPtr^, SourceLen*SizeOf(Char));
One might wonder what happens if Source[i] is empty. In that case Pointer(Source[i]) is nil and you might expect an access violation. In fact, there is no error because the length of the move as specified by the third argument is zero, and the nil pointer is never actually de-referenced.
The other line of note is here:
DestPtr := PChar(Pointer(Dest)) + OriginalDestLen;
We use PChar(Pointer(Dest)) rather than PChar(Dest). The latter invokes code to check whether or not Dest is empty, and if so yields a pointer to a single null-terminator. We want to avoid executing that code, and obtain the address held in Dest directly, even if it is nil.
In the second loop you forget that S already has the right size to get filled with all the elements so you have to use another variable to know the destination parameter of Move
procedure Concat(var S: String; const A: Array of String);
var
I, Len, Sum: Integer;
begin
Len := 0;
for I := 0 to High(A) do
Inc(Len, Length(A[I]));
Sum := Length(S);
SetLength(S, Sum + Len);
for I := 0 to High(A) do
begin
if Length(A[I]) > 0 then
Move(A[I][1], S[Sum+1], Length(A[I]) * SizeOf(Char));
Inc(Sum, Length(A[I]));
end;
end;
Casting the source parameter to PWideChar is totally superfluous since the Move function use a kind of old generic syntax that allows to pass everything you want (const Parameter without type).

How to make call to DLL function from Delphi?

// Get a list of accounts in a domain separated by \x00 and ended by \x00\x00
Function GetUserList(AName: PAnsiChar; Var List; Size: Longint): Longint; StdCall;
I need to call the above from XE6.
Would someone be kind enough to post an example of how I can
get this buffer, and put it to a stream or a string.
The variable "List" is supposed to fill up some buffer, which I can read
off the list of users.
After trying for a couple of options, I have tried all options such as:
thanks!
var
Buffer: array of Byte;
iCount : Integer;
sName : AnsiString;
begin
...
SetLength(Buffer, 4096);
iCount := GetUserListTest(PAnsiChar(sName)#Buffer[0], Length(Buffer)); // cannot
// iCount := GetUserList(PAnsiChar(sName), Buffer, Length(Buffer));
That is not a Win32 API function, so it must be a third-party function. Ask the vendor for an example.
A var parameter expects you to pass a variable to it. The var receives the address of the variable. #Buffer[0] does not satisfy that requirement, as # returns a Pointer, and then the var ends up with the address of the pointer itself, not the address of the variable being pointed at. The function is expecting a pointer to a buffer. By using a var to receive that pointer, you need to drop the # and pass the first array element, so that the address of that element (effectively the address of the buffer) will be passed to the function, eg:
iCount := GetUserList(PAnsiChar(sName), Buffer[0], iCount);
Alternatively, you can use this syntax instead, which will pass the same address of the first element:
iCount := GetUserList(PAnsiChar(sName), PByte(Buffer)^, iCount);
Now, with that said, chances are that the function may allow you to query it for the necessary array size so you can allocate only what is actually needed (but check the documentation to be sure, I'm making an assumption here since you have not said otherwise)), eg:
procedure GetDomainUsers(const Domain: AnsiString; Users: TStrings);
var
Buffer: array of AnsiChar;
iCount : Integer;
User: PAnsiChar;
begin
// this call ASSUMES the function returns the needed
// bytecount when given a NULL/empty array - check
// the documentation!!!
iCount := GetUserList(PAnsiChar(Domain), PAnsiChar(nil)^, 0);
if iCount > 0 then
begin
SetLength(Buffer, iCount);
iCount := GetUserList(PAnsiChar(Domain), Buffer[0]{or: PAnsiChar(Buffer)^}, iCount);
end;
if iCount > 0 then
begin
Users.BeginUpdate;
try
User := PAnsiChar(Buffer);
while User^ <> #0 do
begin
Users.Add(User);
Inc(User, StrLen(User)+1);
end;
finally
Users.EndUpdate;
end;
end;
end;
If that does not work, then you will have to pre-allocate a large array:
procedure GetDomainUsers(const Domain: AnsiString; Users: TStrings);
var
Buffer: array of AnsiChar;
User: PAnsiChar;
begin
SetLength(Buffer, 1024);
if GetUserList(PAnsiChar(Domain), Buffer[0]{or: PAnsiChar(Buffer)^}, Length(Buffer)) > 0 then
begin
Users.BeginUpdate;
try
User := PAnsiChar(Buffer);
while User^ <> #0 do
begin
Users.Add(User);
Inc(User, StrLen(User)+1);
end;
finally
Users.EndUpdate;
end;
end;
end;

Delphi function comparing content of two TStream?

I need to compare if two TStream descendant have the same content.
The only interesting result for me is the boolean Yes / No.
I'm going to code a simple loop checking byte after byte the streams content's.
But I'm curious to know if there is an already existing function. I haven't found any inside DelphiXE or JCL/JVCL libs.
Of course, the two streams have the same size !
Exactly, as Nickolay O. said you should read your stream in blocks and use CompareMem. Here is an example (including size test) ...
function IsIdenticalStreams(Source, Destination: TStream): boolean;
const Block_Size = 4096;
var Buffer_1: array[0..Block_Size-1] of byte;
Buffer_2: array[0..Block_Size-1] of byte;
Buffer_Length: integer;
begin
Result := False;
if Source.Size <> Destination.Size then
Exit;
while Source.Position < Source.Size do
begin
Buffer_Length := Source.Read(Buffer_1, Block_Size);
Destination.Read(Buffer_2, Block_Size);
if not CompareMem(#Buffer_1, #Buffer_2, Buffer_Length) then
Exit;
end;
Result := True;
end;
The IsIdenticalStreams function posted by daemon_x is excellent - but needs one adjustment to work properly. (Uwe Raabe caught the issue already.) It is critical that you reset the stream positions before starting the loop - or this procedure will probably return an incorrect TRUE if the two streams were already accessed outside this function.
This is the final solution that works every time. I just renamed the function to suit my naming conventions. Thank you daemon_x for the elegant solution.
function StreamsAreIdentical(Stream1, Stream2: TStream): boolean;
const
Block_Size = 4096;
var
Buffer_1: array[0..Block_Size-1] of byte;
Buffer_2: array[0..Block_Size-1] of byte;
Buffer_Length: integer;
begin
Result := False;
if Stream1.Size <> Stream2.Size then exit;
// These two added lines are critical for proper operation
Stream1.Position := 0;
Stream2.Position := 0;
while Stream1.Position < Stream1.Size do
begin
Buffer_Length := Stream1.Read(Buffer_1, Block_Size);
Stream2.Read(Buffer_2, Block_Size);
if not CompareMem(#Buffer_1, #Buffer_2, Buffer_Length) then exit;
end;
Result := True;
end;
There is no such built-in function. Only one thing I can recommend - read not byte-to-byte, but using blocks of 16-64kbytes, that would be much faster.
Answers from user532231 and Mike are working in 99% cases, but there are additional checks to be made!
Descendants of TStream can be almost anything, so it's not guaranteed that Stream.Read will return same amount of data, even if streams are of the same length (stream descendant can also download data, so may return readed=0 bytes, while waiting for next chunk). Streams can be also on completelly different media and stream read error could occur on just one.
For 100% working code all these checks should be made. I modified the function from Mike.
If this function is used for example to rewrite stream 2 if not identical to Stream1, all errors should be checked. When function result is True, everthing is ok, but if it is False, it would be very smart to check if Streams are actually different or just some error occured.
Edited: Added some additional checks, FilesAreIdentical function based on StreamsAreIdentical and usage example.
// Usage example
var lError: Integer;
...
if FilesAreIdentical(lError, 'file1.ext', 'file2.ext')
then Memo1.Lines.Append('Files are identical.')
else case lError of
0: Memo1.Lines.Append('Files are NOT identical!');
1: Memo1.Lines.Append('Files opened, stream read exception raised!');
2: Memo1.Lines.Append('File does not exist!');
3: Memo1.Lines.Append('File open exception raised!');
end; // case
...
// StreamAreIdentical
function StreamsAreIdentical(var aError: Integer;
const aStream1, aStream2: TStream;
const aBlockSize: Integer = 4096): Boolean;
var
lBuffer1: array of byte;
lBuffer2: array of byte;
lBuffer1Readed,
lBuffer2Readed,
lBlockSize: integer;
begin
Result:=False;
aError:=0;
try
if aStream1.Size <> aStream2.Size
then Exit;
aStream1.Position:=0;
aStream2.Position:=0;
if aBlockSize>0
then lBlockSize:=aBlockSize
else lBlockSize:=4096;
SetLength(lBuffer1, lBlockSize);
SetLength(lBuffer2, lBlockSize);
lBuffer1Readed:=1; // just for entering while
while (lBuffer1Readed > 0) and (aStream1.Position < aStream1.Size) do
begin
lBuffer1Readed := aStream1.Read(lBuffer1[0], lBlockSize);
lBuffer2Readed := aStream2.Read(lBuffer2[0], lBlockSize);
if (lBuffer1Readed <> lBuffer2Readed) or ((lBuffer1Readed <> lBlockSize) and (aStream1.Position < aStream1.Size))
then Exit;
if not CompareMem(#lBuffer1[0], #lBuffer2[0], lBuffer1Readed)
then Exit;
end; // while
Result:=True;
except
aError:=1; // stream read exception
end;
end;
// FilesAreIdentical using function StreamsAreIdentical
function FilesAreIdentical(var aError: Integer;
const aFileName1, aFileName2: String;
const aBlockSize: Integer = 4096): Boolean;
var lFileStream1,
lFilestream2: TFileStream;
begin
Result:=False;
try
if not (FileExists(aFileName1) and FileExists(aFileName2))
then begin
aError:=2; // file not found
Exit;
end;
lFileStream1:=nil;
lFileStream2:=nil;
try
lFileStream1:=TfileStream.Create(aFileName1, fmOpenRead or fmShareDenyNone);
lFileStream2:=TFileStream.Create(aFileName2, fmOpenRead or fmShareDenyNone);
result:=StreamsAreIdentical(aError, lFileStream1, lFileStream2, aBlockSize);
finally
if lFileStream2<>nil
then lFileStream2.Free;
if lFileStream1<>nil
then lFileStream1.Free;
end; // finally
except
aError:=3; // file open exception
end; // except
end;

What's the best method for getting the local computer name in Delphi

The code needs to be compatible with D2007 and D2009.
My Answer: Thanks to everyone who answered, I've gone with:
function ComputerName : String;
var
buffer: array[0..255] of char;
size: dword;
begin
size := 256;
if GetComputerName(buffer, size) then
Result := buffer
else
Result := ''
end;
The Windows API GetComputerName should work. It is defined in windows.pas.
Another approach, which works well is to get the computer name via the environment variable. The advantage of this approach (or disadvantage depending on your software) is that you can trick the program into running as a different machine easily.
Result := GetEnvironmentVariable('COMPUTERNAME');
The computer name environment variable is set by the system. To "override" the behavior, you can create a batch file that calls your program, setting the environment variable prior to the call (each command interpreter gets its own "copy" of the environment, and changes are local to that session or any children launched from that session).
GetComputerName from the Windows API is the way to go. Here's a wrapper for it.
function GetLocalComputerName : string;
var c1 : dword;
arrCh : array [0..MAX_PATH] of char;
begin
c1 := MAX_PATH;
GetComputerName(arrCh, c1);
if c1 > 0 then
result := arrCh
else
result := '';
end;
What about this :
function GetComputerName: string;
var
buffer: array[0..MAX_COMPUTERNAME_LENGTH + 1] of Char;
Size: Cardinal;
begin
Size := MAX_COMPUTERNAME_LENGTH + 1;
Windows.GetComputerName(#buffer, Size);
Result := StrPas(buffer);<br/>
end;
From http://exampledelphi.com/delphi.php/tips-and-tricks/delphi-how-to-get-computer-name/
If you want more than just the host name, you need GetComputerNameEx. Since there are many wrong implementations around (MAX_COMPUTERNAME_LENGTH is not enough, and 1024 is bad), here is mine:
uses Winapi.Windows;
function GetLocalComputerName(
NameType: TComputerNameFormat = ComputerNameDnsHostname): string;
var
len: DWORD;
begin
len:= 0;
GetComputerNameEx(NameType, nil, len); //get length
SetLength(Result, len - 1);
if not GetComputerNameEx(NameType, PChar(Result), len) then RaiseLastOSError;
end;
Valid values for the NameType parameter are:
ComputerNameDnsHostname, ComputerNameDnsDomain, ComputerNameDnsFullyQualified
ComputerNamePhysicalDnsHostname, ComputerNamePhysicalDnsDomain, ComputerNamePhysicalDnsFullyQualified
ComputerNameNetBIOS, ComputerNamePhysicalNetBIOS
I use this,
function GetLocalPCName: String;
var
Buffer: array [0..63] of AnsiChar;
i: Integer;
GInitData: TWSADATA;
begin
Result := '';
WSAStartup($101, GInitData);
GetHostName(Buffer, SizeOf(Buffer));
Result:=Buffer;
WSACleanup;
end;
Bye
This code works great, except when computer is on simple Workgroup and try to using GetLocalComputerName(ComputerNameDnsFullyQualified) returns computer name with a #0 (null) char at end, resulting in a bad processing of other charanters sent to a Memo component as a log.
Just fix this issue checking for null at end.
function GetLocalComputerName(
NameType: TComputerNameFormat = ComputerNameDnsHostname): WideString;
var
len: DWORD;
begin
len:= 0;
GetComputerNameEx(NameType, nil, len); //get length
SetLength(Result, len - 1);
if not GetComputerNameEx(NameType, PWideChar(Result), len)
then RaiseLastOSError;
// fix null at end
len := Length(Result);
if (len > 2) and (Result[len] = #0) then
Result := Copy(Result, 1, len-1);
end;

Resources