CalcCRC32 for 64-bit programs? - delphi
I found this code in an older program from Angus Johnson:
const
table: ARRAY[0..255] OF DWORD =
($00000000, $77073096, $EE0E612C, $990951BA,
$076DC419, $706AF48F, $E963A535, $9E6495A3,
$0EDB8832, $79DCB8A4, $E0D5E91E, $97D2D988,
$09B64C2B, $7EB17CBD, $E7B82D07, $90BF1D91,
$1DB71064, $6AB020F2, $F3B97148, $84BE41DE,
$1ADAD47D, $6DDDE4EB, $F4D4B551, $83D385C7,
$136C9856, $646BA8C0, $FD62F97A, $8A65C9EC,
$14015C4F, $63066CD9, $FA0F3D63, $8D080DF5,
$3B6E20C8, $4C69105E, $D56041E4, $A2677172,
$3C03E4D1, $4B04D447, $D20D85FD, $A50AB56B,
$35B5A8FA, $42B2986C, $DBBBC9D6, $ACBCF940,
$32D86CE3, $45DF5C75, $DCD60DCF, $ABD13D59,
$26D930AC, $51DE003A, $C8D75180, $BFD06116,
$21B4F4B5, $56B3C423, $CFBA9599, $B8BDA50F,
$2802B89E, $5F058808, $C60CD9B2, $B10BE924,
$2F6F7C87, $58684C11, $C1611DAB, $B6662D3D,
$76DC4190, $01DB7106, $98D220BC, $EFD5102A,
$71B18589, $06B6B51F, $9FBFE4A5, $E8B8D433,
$7807C9A2, $0F00F934, $9609A88E, $E10E9818,
$7F6A0DBB, $086D3D2D, $91646C97, $E6635C01,
$6B6B51F4, $1C6C6162, $856530D8, $F262004E,
$6C0695ED, $1B01A57B, $8208F4C1, $F50FC457,
$65B0D9C6, $12B7E950, $8BBEB8EA, $FCB9887C,
$62DD1DDF, $15DA2D49, $8CD37CF3, $FBD44C65,
$4DB26158, $3AB551CE, $A3BC0074, $D4BB30E2,
$4ADFA541, $3DD895D7, $A4D1C46D, $D3D6F4FB,
$4369E96A, $346ED9FC, $AD678846, $DA60B8D0,
$44042D73, $33031DE5, $AA0A4C5F, $DD0D7CC9,
$5005713C, $270241AA, $BE0B1010, $C90C2086,
$5768B525, $206F85B3, $B966D409, $CE61E49F,
$5EDEF90E, $29D9C998, $B0D09822, $C7D7A8B4,
$59B33D17, $2EB40D81, $B7BD5C3B, $C0BA6CAD,
$EDB88320, $9ABFB3B6, $03B6E20C, $74B1D29A,
$EAD54739, $9DD277AF, $04DB2615, $73DC1683,
$E3630B12, $94643B84, $0D6D6A3E, $7A6A5AA8,
$E40ECF0B, $9309FF9D, $0A00AE27, $7D079EB1,
$F00F9344, $8708A3D2, $1E01F268, $6906C2FE,
$F762575D, $806567CB, $196C3671, $6E6B06E7,
$FED41B76, $89D32BE0, $10DA7A5A, $67DD4ACC,
$F9B9DF6F, $8EBEEFF9, $17B7BE43, $60B08ED5,
$D6D6A3E8, $A1D1937E, $38D8C2C4, $4FDFF252,
$D1BB67F1, $A6BC5767, $3FB506DD, $48B2364B,
$D80D2BDA, $AF0A1B4C, $36034AF6, $41047A60,
$DF60EFC3, $A867DF55, $316E8EEF, $4669BE79,
$CB61B38C, $BC66831A, $256FD2A0, $5268E236,
$CC0C7795, $BB0B4703, $220216B9, $5505262F,
$C5BA3BBE, $B2BD0B28, $2BB45A92, $5CB36A04,
$C2D7FFA7, $B5D0CF31, $2CD99E8B, $5BDEAE1D,
$9B64C2B0, $EC63F226, $756AA39C, $026D930A,
$9C0906A9, $EB0E363F, $72076785, $05005713,
$95BF4A82, $E2B87A14, $7BB12BAE, $0CB61B38,
$92D28E9B, $E5D5BE0D, $7CDCEFB7, $0BDBDF21,
$86D3D2D4, $F1D4E242, $68DDB3F8, $1FDA836E,
$81BE16CD, $F6B9265B, $6FB077E1, $18B74777,
$88085AE6, $FF0F6A70, $66063BCA, $11010B5C,
$8F659EFF, $F862AE69, $616BFFD3, $166CCF45,
$A00AE278, $D70DD2EE, $4E048354, $3903B3C2,
$A7672661, $D06016F7, $4969474D, $3E6E77DB,
$AED16A4A, $D9D65ADC, $40DF0B66, $37D83BF0,
$A9BCAE53, $DEBB9EC5, $47B2CF7F, $30B5FFE9,
$BDBDF21C, $CABAC28A, $53B39330, $24B4A3A6,
$BAD03605, $CDD70693, $54DE5729, $23D967BF,
$B3667A2E, $C4614AB8, $5D681B02, $2A6F2B94,
$B40BBE37, $C30C8EA1, $5A05DF1B, $2D02EF8D);
//CRC algorithm courtesy of Earl F. Glynn ...
//(http://www.efg2.com/Lab/Mathematics/CRC.htm)
function CalcCRC32(p: pchar; length: integer): dword;
var
i: integer;
begin
result := $FFFFFFFF;
for i := 0 to length-1 do
begin
result := (result shr 8) xor table[ pbyte(p)^ xor (result and $000000ff) ];
inc(p);
end;
result := not result;
end;
The CalcCRC32 function gives back erroneous results if the code is compiled in 64-bit program.
How could this function be changed to make it work in a 64-bit program in Delphi 10.1 Berlin?
The code has been taken from: TextDiff\BasicDemo2\HashUnit.pas on http://www.angusj.com/delphi/textdiff.html
I have used these two texts to test TextDiff:
Text 1:
CompanyName=Igor Pavlov
FileDescription=7-Zip Standalone Console
FileVersion=17.01 beta
InternalName=7za
LegalCopyright=Copyright (c) 1999-2017 Igor Pavlov
OriginalFilename=7za.exe
ProductName=7-Zip
ProductVersion=17.01 beta
Text2:
CompanyName=Igor Pavlov
FileDescription=7-Zip Standalone Console
FileVersion=4.61 beta
InternalName=7za
LegalCopyright=Copyright (c) 1999-2008 Igor Pavlov
OriginalFilename=7za.exe
ProductName=7-Zip
ProductVersion=4.61 beta
Here is how I changed the code according to the solution:
function CalcCRC32(p: PByte; length: NativeUInt): dword;
var
i: integer;
begin
result := $FFFFFFFF;
for i := 0 to length-1 do
begin
result := (result shr 8) xor table[ pbyte(p)^ xor (result and $000000ff) ];
inc(p);
end;
result := not result;
end;
function HashLine(const line: string; IgnoreCase, IgnoreBlanks: boolean): pointer;
var
i, j, len: integer;
s: String;
begin
s := line;
if IgnoreBlanks then
begin
i := 1;
j := 1;
len := length(line);
while i <= len do
begin
if not (line[i] in [#9,#32]) then
begin
s[j] := line[i];
inc(j);
end;
inc(i);
end;
setlength(s,j-1);
end;
if IgnoreCase then s := AnsiLowerCase(s);
//return result as a pointer to save typecasting later...
result := pointer(CalcCRC32(PByte(s), length(s)));
end;
In general, this code should work in 64bit, provided length does not exceed 2GB. That is not your issue.
The p parameter needs to be changed from PChar to PByte (or even just Pointer) since PChar is PWideChar in D2009+ but the code is expecting PChar to be PAnsiChar instead.
Also, you should probably change length from Integer to Native(U)Int so you can take better advantage of 64bit memory sizes greater than 2GB.
Now, with that said, if you want to get the CRC of a string, be aware that string is a UTF-16 encoded UnicodeString in D2009+, but CRC operates on bytes rather than characters. So, when computing the CRC of a string, you have to decide which byte encoding it should be converted to first. And when comparing the CRCs of multiple strings, make sure they are converted to the same byte encoding first.
You may read the following to better understand how string works in Delphi.
Here you have the interface section of an unicode aware HashLine function; there is no reason to use Pointer as the result type.
uses System.Types;
function HashLine(const line: string; IgnoreCase, IgnoreBlanks: boolean): dword;
Here the implementation part.
uses
System.SysUtils, System.StrUtils, System.Character, System.Classes;
const
table: ARRAY[0..255] OF DWORD =
($00000000, $77073096, $EE0E612C, $990951BA,
...
$B40BBE37, $C30C8EA1, $5A05DF1B, $2D02EF8D);
function CalcCRC32(p: PByte; length: NativeUInt): DWORD;
var
i: NativeUInt;
begin
result := $FFFFFFFF;
for i := 0 to length-1 do
begin
result := (result shr 8) xor table[ p^ xor (result and $000000ff) ];
inc(p);
end;
result := not result;
end;
function HashLine(const line: string; IgnoreCase, IgnoreBlanks: boolean): DWORD;
var
i, j: integer;
s: string;
b: TBytes;
begin
if IgnoreBlanks then
begin
j := low(string);
setlength(s, length(line));
for i := low(line) to high(line) do
begin
// if not (line[i] in [#9,#32]) then
if not line[i].IsWhiteSpace() then
begin
s[j] := line[i];
inc(j);
end;
end;
setlength(s,j-1);
end else begin
s := line;
end;
if IgnoreCase then
s := s.ToLower();
b := TEncoding.UTF8.GetBytes(s);
result := CalcCRC32(#b[0], length(b));
end;
The call HashLine('HEllo, World!', false, false) results F47B1828 which is equal to the result here
Just change result := not result; to result := result xor $FFFFFFFF;.
Related
Delphi (2006): how to Split by new line and break at the same time
I have this simple operation in Java, where the string is split by new line and break. String i= "Holidays Great. Bye"; String []linesArray = i.split("\\r?\\n"); I would like to obtain the same result in Delphi 2006. Is it valid to use the following steps? charArray[0] := '\\r'; charArray[1] := '\\n'; strArray := strA.Split(charArray);
I interpret your request like this: "Split a string at both CR and LF." which implies that CR+LF gives an empty string element. For instance, 'alpha'#13'beta'#10'gamma'#13#10'delta' yields the five elements 'alpha', 'beta', 'gamma', '', and 'delta'. If so, and if you are using a non-ancient version of Delphi, this is really simple: var S := 'alpha'#13'beta'#10'gamma'#13#10'delta'; var Parts := S.Split([#13, #10]); for var Part in Parts do ShowMessage(Part); For old Delphi versions The code above requires TStringHelper (crucially) and also makes use of inline variable declarations, for in loops, and generics. For old Delphi versions, you can do it manually: type TStringArray = array of string; function Split(const S: string): TStringArray; var Count: Integer; const Delta = 512; procedure Add(const Part: string); begin if Length(Result) = Count then SetLength(Result, Length(Result) + Delta); Result[Count] := Part; Inc(Count); end; var p, i: Integer; begin Result := nil; Count := 0; p := 0; // previous delim for i := 1 to Length(S) do if S[i] in [#13, #10] then begin Add(Copy(S, Succ(p), i - p - 1)); p := i; end; Add(Copy(S, Succ(p))); SetLength(Result, Count); end; procedure TForm1.FormCreate(Sender: TObject); var S: string; Parts: TStringArray; i: Integer; begin S := 'alpha'#13'beta'#10'gamma'#13#10'delta'; Parts := Split(S); for i := 0 to High(Parts) do ShowMessage(Parts[i]); end;
How to get the string representation of a ShortCut Key including the SHIFTSTATE?
In a Delphi 10.4.2 Win32 VCL Application, and based on the question + solution here which provides a way to get the string representation of a Shortcut Key (but presumably with no possibility to also pass a SHIFTSTATE for the Shortcut Key) I wrote this code: function MyGetSpecialShortcutName(ShortCut: TShortCut): string; // gets shortcut name for e.g. VK_NUMPAD0 where TMenuItem.Shortcut gets the wrong shortcut name var ScanCode: Integer; KeyName: array[0..255] of Char; begin Result := ''; FillChar(KeyName, SizeOf(KeyName), 0); ScanCode := Winapi.Windows.MapVirtualKey(LoByte(Word(ShortCut)), 0) shl 16; if ScanCode <> 0 then begin if Winapi.Windows.GetKeyNameText(ScanCode, KeyName, Length(KeyName)) <> 0 then Result := KeyName; end; end; function GetSpecialShortcutNameWithShiftState(const AScanCode: Word; const AShiftState: System.Classes.TShiftState = []): string; begin Result := MyGetSpecialShortcutName(Vcl.Menus.ShortCut(AScanCode, AShiftState)); end; Usage: Result := GetSpecialShortcutNameWithShiftState(VK_A, [ssCTRL]); However, the Result is "A" where the expected Result should be "CTRL+A". How to get the string representation of a ShortCut Key including the SHIFTSTATE?
The OP wants the key names fully localised, but for completeness I first show that the VCL already has a function to obtain a partly unlocalised string, namely, ShortCutToText in the Menus unit: ShortCutToText(ShortCut(Ord('A'), [ssShift, ssAlt])) This returns Shift+Alt+A on all systems. Now, using the Win32 function GetKeyNameText already mentioned in the Q, it is easy to obtain a fully localised shortcut string: function GetKeyName(AKey: Integer): string; var name: array[0..128] of Char; begin FillChar(name, SizeOf(name), 0); GetKeyNameText(MapVirtualKey(AKey, 0) shl 16, #name[0], Length(name)); Result := name; end; function ModifierVirtualKey(AModifier: Integer): Integer; begin case AModifier of Ord(ssShift): Result := VK_SHIFT; Ord(ssCtrl): Result := VK_CONTROL; Ord(ssAlt): Result := VK_MENU; else Result := 0; end; end; function ShortcutToString(AKey: Integer; AShiftState: TShiftState = []): string; begin Result := ''; for var Modifier in AShiftState do begin var ModifierKey := ModifierVirtualKey(Ord(Modifier)); if ModifierKey <> 0 then Result := Result + IfThen(not Result.IsEmpty, '+') + GetKeyName(ModifierKey); end; Result := Result + IfThen(not Result.IsEmpty, '+') + GetKeyName(AKey); end; (Here I use a IfThen overload from StrUtils.) Now, ShortcutToString(Ord('A'), [ssShift, ssAlt]) returns SKIFT+ALT+A on my Swedish system. SKIFT is, as you might already have guessed, the Swedish name for the SHIFT key.
Detect the status of a printer paper
i need to get paper status information from a printer. I have a list of esc/pos commands. I'm trying to send these comands with escape function http://msdn.microsoft.com/en-us/library/windows/desktop/dd162701%28v=vs.85%29.aspx This is my code type TPrnBuffRec = record bufflength: Word; Buff_1: array[0..255] of Char; end; procedure TFTestStampa.SpeedButton2Click(Sender: TObject); var Buff: TPrnBuffRec; BuffOut: TPrnBuffRec; TestInt: Integer; cmd : string; begin printer.BeginDoc; try TestInt := PassThrough; if Escape(Printer.Handle, QUERYESCSUPPORT, SizeOf(TESTINT), #testint, nil) > 0 then begin cmd := chr(10) + chr(04) + '4'; StrPCopy(Buff.Buff_1, cmd); Buff.bufflength := StrLen(Buff.Buff_1); Escape(Printer.Canvas.Handle, Passthrough, 0, #buff, #buffOut); ShowMessage( conver(strPas(buffOut.Buff_1)) ); end finally printer.EndDoc; end; function TFTestStampa.Conver(s: string): String; var i: Byte; t : String; begin t := ''; for i := 1 to Length(s) do t := t + IntToHex(Ord(s[i]), 2) + ' '; Result := t; end; Problem is with different cmds I obtain always the same string .... Can you give me an example of escape function with last parameter not nill ? Alternatives to obtain paper status ?
I suppose you are using Delphi 2009 above and you used this source for your example, so your problem might be caused by Unicode parameters. In Delphi since version 2009, string type is defined as UnicodeString whilst in Delphi 2009 below as AnsiString, the same stands also for Char which is WideChar in Delphi 2009 up and AnsiChar below. If so, then I think you have a problem at least with your buffer data length, because Char = WideChar takes 2 bytes and you were using StrLen function which returns the number of chars what cannot correspond to the data size of number of chars * 2 bytes. I hope this will fix your problem, but I can't verify it, because I don't have your printer :) type TPrinterData = record DataLength: Word; Data: array [0..255] of AnsiChar; // let's use 1 byte long AnsiChar end; function Convert(const S: AnsiString): string; var I: Integer; // 32-bit integer is more efficient than 8-bit byte type T: string; // here we keep the native string data type begin T := ''; for I := 1 to Length(S) do T := T + IntToHex(Ord(S[I]), 2) + ' '; Result := T; end; procedure TFTestStampa.SpeedButton2Click(Sender: TObject); var TestInt: Integer; Command: AnsiString; BufferIn: TPrinterData; BufferOut: TPrinterData; begin Printer.BeginDoc; try TestInt := PASSTHROUGH; if Escape(Printer.Handle, QUERYESCSUPPORT, SizeOf(TestInt), #TestInt, nil) > 0 then begin Command := Chr(10) + Chr(04) + '4'; StrPCopy(BufferIn.Data, Command); BufferIn.DataLength := StrLen(Command); FillChar(BufferOut.Data, Length(BufferOut.Data), #0); BufferOut.DataLength := 0; Escape(Printer.Canvas.Handle, PASSTHROUGH, 0, #BufferIn, #BufferOut); ShowMessage(Convert(StrPas(BufferOut.Data))); end finally Printer.EndDoc; end; end;
in Delphi7, How can I retrieve hard disk unique serial number?
Hi I want to retrieve HDD unique (hardware) serial number. I use some functions but in Windows Seven or Vista they don't work correctly because of admin right. Is it possible retrieve it without run as Administrator?
Following the links in the question comments Sertac posted, I came across this interesting C++ question, where Fredou answered with a nice link to a codeproject example showing how to do this in .NET, which in turn was based on a link to Borland C++ code and article. The cool thing is that this C++ code works as a non-administrator user too! Now you need someone to help you translate this C++ code to Delphi. Edit: Found a Delphi unit that does this for you. I wrote some sample use for it: program DiskDriveSerialConsoleProject; {$APPTYPE CONSOLE} uses Windows, SysUtils, hddinfo in 'hddinfo.pas'; const // Max number of drives assuming primary/secondary, master/slave topology MAX_IDE_DRIVES = 16; procedure ReadPhysicalDriveInNTWithZeroRights (); var DriveNumber: Byte; HDDInfo: THDDInfo; begin HDDInfo := THDDInfo.Create(); try for DriveNumber := 0 to MAX_IDE_DRIVES - 1 do try HDDInfo.DriveNumber := DriveNumber; if HDDInfo.IsInfoAvailable then begin Writeln('VendorId: ', HDDInfo.VendorId); Writeln('ProductId: ', HDDInfo.ProductId); Writeln('ProductRevision: ', HDDInfo.ProductRevision); Writeln('SerialNumber: ', HDDInfo.SerialNumber); Writeln('SerialNumberInt: ', HDDInfo.SerialNumberInt); Writeln('SerialNumberText: ', HDDInfo.SerialNumberText); end; except on E: Exception do Writeln(Format('DriveNumber %d, %s: %s', [DriveNumber, E.ClassName, E.Message])); end; finally HDDInfo.Free; end; end; begin ReadPhysicalDriveInNTWithZeroRights; Write('Press <Enter>'); Readln; end. Unit from http://www.delphipraxis.net/564756-post28.html // http://www.delphipraxis.net/564756-post28.html unit hddinfo; interface uses Windows, SysUtils, Classes; const IOCTL_STORAGE_QUERY_PROPERTY = $2D1400; type THDDInfo = class (TObject) private FDriveNumber: Byte; FFileHandle: Cardinal; FInfoAvailable: Boolean; FProductRevision: string; FProductId: string; FSerialNumber: string; FVendorId: string; procedure ReadInfo; procedure SetDriveNumber(const Value: Byte); public constructor Create; property DriveNumber: Byte read FDriveNumber write SetDriveNumber; property VendorId: string read FVendorId; property ProductId: string read FProductId; property ProductRevision: string read FProductRevision; property SerialNumber: string read FSerialNumber; function SerialNumberInt: Cardinal; function SerialNumberText: string; function IsInfoAvailable: Boolean; end; implementation type STORAGE_PROPERTY_QUERY = packed record PropertyId: DWORD; QueryType: DWORD; AdditionalParameters: array[0..3] of Byte; end; STORAGE_DEVICE_DESCRIPTOR = packed record Version: ULONG; Size: ULONG; DeviceType: Byte; DeviceTypeModifier: Byte; RemovableMedia: Boolean; CommandQueueing: Boolean; VendorIdOffset: ULONG; ProductIdOffset: ULONG; ProductRevisionOffset: ULONG; SerialNumberOffset: ULONG; STORAGE_BUS_TYPE: DWORD; RawPropertiesLength: ULONG; RawDeviceProperties: array[0..511] of Byte; end; function ByteToChar(const B: Byte): Char; begin Result := Chr(B + $30) end; function SerialNumberToCardinal (SerNum: String): Cardinal; begin HexToBin(PChar(SerNum), PChar(#Result), SizeOf(Cardinal)); end; function SerialNumberToString(SerNum: String): String; var I, StrLen: Integer; Pair: string; B: Byte; Ch: Char absolute B; begin Result := ''; StrLen := Length(SerNum); if Odd(StrLen) then Exit; I := 1; while I < StrLen do begin Pair := Copy (SerNum, I, 2); HexToBin(PChar(Pair), PChar(#B), 1); Result := Result + Chr(B); Inc(I, 2); end; I := 1; while I < Length(Result) do begin Ch := Result[I]; Result[I] := Result[I + 1]; Result[I + 1] := Ch; Inc(I, 2); end; end; constructor THddInfo.Create; begin inherited; SetDriveNumber(0); end; function THDDInfo.IsInfoAvailable: Boolean; begin Result := FInfoAvailable end; procedure THDDInfo.ReadInfo; type PCharArray = ^TCharArray; TCharArray = array[0..32767] of Char; var Returned: Cardinal; Status: LongBool; PropQuery: STORAGE_PROPERTY_QUERY; DeviceDescriptor: STORAGE_DEVICE_DESCRIPTOR; PCh: PChar; begin FInfoAvailable := False; FProductRevision := ''; FProductId := ''; FSerialNumber := ''; FVendorId := ''; try FFileHandle := CreateFile( PChar('\\.\PhysicalDrive' + ByteToChar(FDriveNumber)), 0, FILE_SHARE_READ or FILE_SHARE_WRITE, nil, OPEN_EXISTING, 0, 0 ); if FFileHandle = INVALID_HANDLE_VALUE then RaiseLastOSError; ZeroMemory(#PropQuery, SizeOf(PropQuery)); ZeroMemory(#DeviceDescriptor, SizeOf(DeviceDescriptor)); DeviceDescriptor.Size := SizeOf(DeviceDescriptor); Status := DeviceIoControl( FFileHandle, IOCTL_STORAGE_QUERY_PROPERTY, #PropQuery, SizeOf(PropQuery), #DeviceDescriptor, DeviceDescriptor.Size, Returned, nil ); if not Status then RaiseLastOSError; if DeviceDescriptor.VendorIdOffset <> 0 then begin PCh := #PCharArray(#DeviceDescriptor)^[DeviceDescriptor.VendorIdOffset]; FVendorId := PCh; end; if DeviceDescriptor.ProductIdOffset <> 0 then begin PCh := #PCharArray(#DeviceDescriptor)^[DeviceDescriptor.ProductIdOffset]; FProductId := PCh; end; if DeviceDescriptor.ProductRevisionOffset <> 0 then begin PCh := #PCharArray(#DeviceDescriptor)^[DeviceDescriptor.ProductRevisionOffset]; FProductRevision := PCh; end; if DeviceDescriptor.SerialNumberOffset <> 0 then begin PCh := #PCharArray(#DeviceDescriptor)^[DeviceDescriptor.SerialNumberOffset]; FSerialNumber := PCh; end; FInfoAvailable := True; finally if FFileHandle <> INVALID_HANDLE_VALUE then CloseHandle(FFileHandle); end; end; function THDDInfo.SerialNumberInt: Cardinal; begin Result := 0; if ((IsInfoAvailable = True) and (FSerialNumber <> '')) then Result := SerialNumberToCardinal(FSerialNumber) end; function THDDInfo.SerialNumberText: string; begin Result := ''; if ((IsInfoAvailable = True) and (FSerialNumber <> '')) then Result := SerialNumberToString(FSerialNumber) end; procedure THDDInfo.SetDriveNumber(const Value: Byte); begin FDriveNumber := Value; ReadInfo; end; end. Edit: RAID configurations require special provisions. For instance, I got a RAID system with multiple RAID 5 array; only the first one displays, and it does not show the drive serial numbers, but the serial number of the RAID array: VendorId: AMCC ProductId: 9550SXU-16ML ProductRevision: 3.08 SerialNumber: 006508296D6A2A00DE82 SerialNumberInt: 688416000 --jeroen
You can use the WMI (Windows Management Instrumentation) to get information related to windows hardware. Exist two wmi classes wich exposes a property called SerialNumber which store the Number allocated by the manufacturer to identify the physical media. these classes are Win32_DiskDrive and Win32_PhysicalMedia.to access the SerialNumber property of these classes you must know the DeviceId of the Disk which is something like this \\.\PHYSICALDRIVE0. Another way is use a association class which link the Physical drive with the logical drive (C,D,E) so you must find this link previous to obtain the serial number. the sequence to find this association is like this. Win32_DiskPartition -> Win32_LogicalDiskToPartition -> Win32_DiskDrive Note 1 : The SerialNumber property for the Win32_DiskDrive class does not exist in Windows Server 2003, Windows XP, Windows 2000, and Windows NT 4.0, so how you are talking about use Windows Vista or Windows 7, will work ok for you. Note 2 : The code does not require a administrator account to run. check this code {$APPTYPE CONSOLE} uses SysUtils, ActiveX, ComObj, Variants; function GetDiskSerial(const Drive:AnsiChar):string; var FSWbemLocator : OLEVariant; objWMIService : OLEVariant; colDiskDrives : OLEVariant; colLogicalDisks: OLEVariant; colPartitions : OLEVariant; objDiskDrive : OLEVariant; objPartition : OLEVariant; objLogicalDisk : OLEVariant; oEnumDiskDrive : IEnumvariant; oEnumPartition : IEnumvariant; oEnumLogical : IEnumvariant; iValue : LongWord; DeviceID : string; begin; Result:=''; FSWbemLocator := CreateOleObject('WbemScripting.SWbemLocator'); objWMIService := FSWbemLocator.ConnectServer('localhost', 'root\CIMV2', '', ''); //Connect to the WMI colDiskDrives := objWMIService.ExecQuery('SELECT * FROM Win32_DiskDrive','WQL',0); oEnumDiskDrive:= IUnknown(colDiskDrives._NewEnum) as IEnumVariant; while oEnumDiskDrive.Next(1, objDiskDrive, iValue) = 0 do begin DeviceID := StringReplace(objDiskDrive.DeviceID,'\','\\',[rfReplaceAll]); //Escape the `\` chars in the DeviceID value because the '\' is a reserved character in WMI. colPartitions := objWMIService.ExecQuery(Format('ASSOCIATORS OF {Win32_DiskDrive.DeviceID="%s"} WHERE AssocClass = Win32_DiskDriveToDiskPartition',[DeviceID]));//link the Win32_DiskDrive class with the Win32_DiskDriveToDiskPartition class oEnumPartition := IUnknown(colPartitions._NewEnum) as IEnumVariant; while oEnumPartition.Next(1, objPartition, iValue) = 0 do begin colLogicalDisks := objWMIService.ExecQuery('ASSOCIATORS OF {Win32_DiskPartition.DeviceID="'+objPartition.DeviceID+'"} WHERE AssocClass = Win32_LogicalDiskToPartition'); //link the Win32_DiskPartition class with theWin32_LogicalDiskToPartition class. oEnumLogical := IUnknown(colLogicalDisks._NewEnum) as IEnumVariant; while oEnumLogical.Next(1, objLogicalDisk, iValue) = 0 do begin if objLogicalDisk.DeviceID=(Drive+':') then //compare the device id begin Result:=objDiskDrive.SerialNumber; Exit; end; objLogicalDisk:=Unassigned; end; objPartition:=Unassigned; end; end; end; begin try CoInitialize(nil); try Writeln(GetDiskSerial('C')); Readln; finally CoUninitialize; end; except on E:Exception do begin Writeln(E.Classname, ':', E.Message); Readln; end; end; end.
Here is another DiskId32 translation from C++ to Delphi by Victor Derevyanko project: http://code.google.com/p/dvsrc/ Because the first method (WithZeroRights) doesn't work for me, I wrote another for ReadIdeDriveAsScsiDriveInNT method: unit HDScsiInfo; interface uses Windows, SysUtils; const IDENTIFY_BUFFER_SIZE = 512; FILE_DEVICE_SCSI = $0000001b; IOCTL_SCSI_MINIPORT_IDENTIFY = ((FILE_DEVICE_SCSI shl 16) + $0501); IDE_ATA_IDENTIFY = $EC; // Returns ID sector for ATA. IOCTL_SCSI_MINIPORT = $0004D008; // see NTDDSCSI.H for definition type TDiskData = array [0..256-1] of DWORD; TDriveInfo = record ControllerType: Integer; //0 - primary, 1 - secondary, 2 - Tertiary, 3 - Quaternary DriveMS: Integer; //0 - master, 1 - slave DriveModelNumber: String; DriveSerialNumber: String; DriveControllerRevisionNumber: String; ControllerBufferSizeOnDrive: Int64; DriveType: String; //fixed or removable or unknown DriveSizeBytes: Int64; end; THDScsiInfo = class (TObject) private FDriveNumber: Byte; FFileHandle: Cardinal; FInfoAvailable: Boolean; FProductRevision: string; FSerialNumber: string; FControllerType: Integer; FDriveMS: Integer; FDriveModelNumber: string; FControllerBufferSizeOnDrive: Int64; FDriveType: string; FDriveSizeBytes: Int64; procedure ReadInfo; procedure SetDriveNumber(const Value: Byte); procedure PrintIdeInfo(DiskData: TDiskData); public constructor Create; property DriveNumber: Byte read FDriveNumber write SetDriveNumber; property ProductRevision: string read FProductRevision; property SerialNumber: string read FSerialNumber; property ControllerType: Integer read FControllerType; property DriveMS: Integer read FDriveMS; property DriveModelNumber: string read FDriveModelNumber; property ControllerBufferSizeOnDrive: Int64 read FControllerBufferSizeOnDrive; property DriveType: string read FDriveType; property DriveSizeBytes: Int64 read FDriveSizeBytes; function IsInfoAvailable: Boolean; end; implementation type SRB_IO_CONTROL = record HeaderLength: Cardinal; Signature: array [0..8-1] of Byte; Timeout: Cardinal; ControlCode: Cardinal; ReturnCode: Cardinal; Length: Cardinal; end; PSRB_IO_CONTROL = ^SRB_IO_CONTROL; DRIVERSTATUS = record bDriverError: Byte;// Error code from driver, or 0 if no error. bIDEStatus: Byte;// Contents of IDE Error register. // Only valid when bDriverError is SMART_IDE_ERROR. bReserved: array [0..1] of Byte;// Reserved for future expansion. dwReserved: array [0..1] of Longword;// Reserved for future expansion. end; SENDCMDOUTPARAMS = record cBufferSize: Longword;// Size of bBuffer in bytes DriverStatus: DRIVERSTATUS;// Driver status structure. bBuffer: array [0..0] of Byte;// Buffer of arbitrary length in which to store the data read from the // drive. end; IDEREGS = record bFeaturesReg: Byte;// Used for specifying SMART "commands". bSectorCountReg: Byte;// IDE sector count register bSectorNumberReg: Byte;// IDE sector number register bCylLowReg: Byte;// IDE low order cylinder value bCylHighReg: Byte;// IDE high order cylinder value bDriveHeadReg: Byte;// IDE drive/head register bCommandReg: Byte;// Actual IDE command. bReserved: Byte;// reserved for future use. Must be zero. end; SENDCMDINPARAMS = record cBufferSize: Longword;// Buffer size in bytes irDriveRegs: IDEREGS; // Structure with drive register values. bDriveNumber: Byte;// Physical drive number to send // command to (0,1,2,3). bReserved: array[0..2] of Byte;// Reserved for future expansion. dwReserved: array [0..3] of Longword;// For future use. bBuffer: array [0..0] of Byte;// Input buffer. //!TODO: this is array of single element end; PSENDCMDINPARAMS = ^SENDCMDINPARAMS; PSENDCMDOUTPARAMS = ^SENDCMDOUTPARAMS; IDSECTOR = record wGenConfig: Word; wNumCyls: Word; wReserved: Word; wNumHeads: Word; wBytesPerTrack: Word; wBytesPerSector: Word; wSectorsPerTrack: Word; wVendorUnique: array [0..3-1] of Word; sSerialNumber: array [0..20-1] of AnsiChar; wBufferType: Word; wBufferSize: Word; wECCSize: Word; sFirmwareRev: array [0..8-1] of AnsiChar; sModelNumber: array [0..40-1] of AnsiChar; wMoreVendorUnique: Word; wDoubleWordIO: Word; wCapabilities: Word; wReserved1: Word; wPIOTiming: Word; wDMATiming: Word; wBS: Word; wNumCurrentCyls: Word; wNumCurrentHeads: Word; wNumCurrentSectorsPerTrack: Word; ulCurrentSectorCapacity: Cardinal; wMultSectorStuff: Word; ulTotalAddressableSectors: Cardinal; wSingleWordDMA: Word; wMultiWordDMA: Word; bReserved: array [0..128-1] of Byte; end; PIDSECTOR = ^IDSECTOR; TArrayDriveInfo = array of TDriveInfo; type DeviceQuery = record HeaderLength: Cardinal; Signature: array [0..8-1] of Byte; Timeout: Cardinal; ControlCode: Cardinal; ReturnCode: Cardinal; Length: Cardinal; cBufferSize: Longword;// Buffer size in bytes irDriveRegs: IDEREGS; // Structure with drive register values. bDriveNumber: Byte;// Physical drive number to send bReserved: array[0..2] of Byte;// Reserved for future expansion. dwReserved: array [0..3] of Longword;// For future use. bBuffer: array [0..0] of Byte;// Input buffer. //!TODO: this is array of single element end; function ConvertToString (diskdata: TDiskData; firstIndex: Integer; lastIndex: Integer; buf: PAnsiChar): PAnsiChar; var index: Integer; position: Integer; begin position := 0; // each integer has two characters stored in it backwards for index := firstIndex to lastIndex do begin // get high byte for 1st character buf[position] := AnsiChar(Chr(diskdata [index] div 256)); inc(position); // get low byte for 2nd character buf [position] := AnsiChar(Chr(diskdata [index] mod 256)); inc(position); end; // end the string buf[position] := Chr(0); // cut off the trailing blanks index := position - 1; while (index >0) do begin // if not IsSpace(AnsiChar(buf[index])) if (AnsiChar(buf[index]) <> ' ') then break; buf [index] := Chr(0); dec(index); end; Result := buf; end; constructor THDScsiInfo.Create; begin inherited; SetDriveNumber(0); end; function THDScsiInfo.IsInfoAvailable: Boolean; begin Result := FInfoAvailable end; procedure THDScsiInfo.PrintIdeInfo (DiskData: TDiskData); var nSectors: Int64; serialNumber: array [0..1024-1] of AnsiChar; modelNumber: array [0..1024-1] of AnsiChar; revisionNumber: array [0..1024-1] of AnsiChar; begin // copy the hard drive serial number to the buffer ConvertToString (DiskData, 10, 19, #serialNumber); ConvertToString (DiskData, 27, 46, #modelNumber); ConvertToString (DiskData, 23, 26, #revisionNumber); FControllerType := FDriveNumber div 2; FDriveMS := FDriveNumber mod 2; FDriveModelNumber := modelNumber; FSerialNumber := serialNumber; FProductRevision := revisionNumber; FControllerBufferSizeOnDrive := DiskData [21] * 512; if ((DiskData [0] and $0080) <> 0) then FDriveType := 'Removable' else if ((DiskData [0] and $0040) <> 0) then FDriveType := 'Fixed' else FDriveType := 'Unknown'; // calculate size based on 28 bit or 48 bit addressing // 48 bit addressing is reflected by bit 10 of word 83 if ((DiskData[83] and $400) <> 0) then begin nSectors := DiskData[103] * Int64(65536) * Int64(65536) * Int64(65536) + DiskData[102] * Int64(65536) * Int64(65536) + DiskData[101] * Int64(65536) + DiskData[100]; end else begin nSectors := DiskData [61] * 65536 + DiskData [60]; end; // there are 512 bytes in a sector FDriveSizeBytes := nSectors * 512; end; procedure THDScsiInfo.ReadInfo; type DataArry = array [0..256-1] of WORD; PDataArray = ^DataArry; const SENDIDLENGTH = sizeof (SENDCMDOUTPARAMS) + IDENTIFY_BUFFER_SIZE; var I: Integer; buffer: array [0..sizeof (SRB_IO_CONTROL) + SENDIDLENGTH - 1] of AnsiChar; dQuery: DeviceQuery; dummy: DWORD; pOut: PSENDCMDOUTPARAMS; pId: PIDSECTOR; DiskData: TDiskData; pIdSectorPtr: PWord; begin FInfoAvailable := False; FFileHandle := CreateFile (PChar(Format('\\.\Scsi%d:', [FDriveNumber])), GENERIC_READ or GENERIC_WRITE, FILE_SHARE_READ or FILE_SHARE_WRITE, nil, OPEN_EXISTING, 0, 0); if (FFileHandle <> INVALID_HANDLE_VALUE) then begin ZeroMemory(#dQuery, SizeOf(dQuery)); dQuery.HeaderLength := sizeof (SRB_IO_CONTROL); dQuery.Timeout := 10000; dQuery.Length := SENDIDLENGTH; dQuery.ControlCode := IOCTL_SCSI_MINIPORT_IDENTIFY; StrLCopy(#dQuery.Signature, 'SCSIDISK', 8); dQuery.irDriveRegs.bCommandReg := IDE_ATA_IDENTIFY; dQuery.bDriveNumber := FDriveNumber; if (DeviceIoControl (FFileHandle, IOCTL_SCSI_MINIPORT, #dQuery, SizeOf(dQuery), #buffer, sizeof (SRB_IO_CONTROL) + SENDIDLENGTH, dummy, nil)) then begin pOut := PSENDCMDOUTPARAMS(buffer + sizeof (SRB_IO_CONTROL)); //!TOCHECK pId := PIDSECTOR(#pOut^.bBuffer[0]); if (pId^.sModelNumber[0] <> Chr(0) ) then begin pIdSectorPtr := PWord(pId); for I := 0 to 256-1 do DiskData[I] := PDataArray(pIdSectorPtr)[I]; PrintIdeInfo (DiskData); FInfoAvailable := True; end; end; CloseHandle(FFileHandle); end; end; procedure THDScsiInfo.SetDriveNumber(const Value: Byte); begin FDriveNumber := Value; ReadInfo; end; end. Sample usage: procedure ReadIdeDriveAsScsiDriveInNT; var DriveNumber: Byte; HDDInfo: THDScsiInfo; begin HDDInfo := THDScsiInfo.Create(); try for DriveNumber := 0 to MAX_IDE_DRIVES - 1 do try HDDInfo.DriveNumber := DriveNumber; if HDDInfo.IsInfoAvailable then begin Writeln('Available Drive: ', HDDInfo.DriveNumber); Writeln('ControllerType: ', HDDInfo.ControllerType); Writeln('DriveMS: ', HDDInfo.DriveMS); Writeln('DriveModelNumber: ', HDDInfo.DriveModelNumber); Writeln('ControllerBufferSizeOnDrive: ', HDDInfo.ControllerBufferSizeOnDrive); Writeln('DriveType: ', HDDInfo.DriveType); Writeln('DriveSizeBytes: ', HDDInfo.DriveSizeBytes); Writeln('ProductRevision: ', HDDInfo.ProductRevision); Writeln('SerialNumber: ', HDDInfo.SerialNumber); end; except on E: Exception do Writeln(Format('DriveNumber %d, %s: %s', [DriveNumber, E.ClassName, E.Message])); end; finally HDDInfo.Free; end; end; begin ReadIdeDriveAsScsiDriveInNT; Write('Press <Enter>'); end. This works great with my WD disk.
I found this code, it is fixed one and working fine with me on windows 7 64 https://code.google.com/p/dvsrc/downloads/detail?name=20120116DiskId32Port_fixed.7z&can=2&q= and this his all work https://code.google.com/p/dvsrc/downloads/list
Posting this purely for completeness sake, and to possibly satisfy those interested or die hard hardware fanatics. I do not have a Pascal compiler at my disposal to test these routines on current Windows systems, but I do know this code worked back in the DOS era. Maybe it still works from a command prompt window. Pascal code: uses Dos, Crt; type SerNoType = record case Integer of 0: (SerNo1, SerNo2: Word); 1: (SerNo: Longint); end; DiskSerNoInfoType = record Infolevel: Word; VolSerNo: SerNoType; VolLabel: array[1..11] of Char; FileSys: array[1..8] of Char; end; function HexDigit(N: Byte): Char; begin if N < 10 then HexDigit := Chr(Ord('0') + N) else HexDigit := Chr(Ord('A') + (N - 10)); end; function GetVolSerialNo(DriveNo: Byte): String; var ReturnArray: DiskSerNoInfoType; Regs: Registers; begin with Regs do begin AX := $440d; BL := DriveNo; CH := $08; CL := $66; DS := Seg(ReturnArray); DX := Ofs(ReturnArray); Intr($21, Regs); if (Flags and FCarry) <> 0 then GetVolSerialNo := '' else with ReturnArray.VolSerNo do GetVolSerialNo := HexDigit(Hi(SerNo2) div 16) + HexDigit(Hi(SerNo2) mod 16) + HexDigit(Lo(SerNo2) div 16) + HexDigit(Lo(SerNo2) mod 16) + HexDigit(Hi(SerNo1) div 16) + HexDigit(Hi(SerNo1) mod 16) + HexDigit(Lo(SerNo1) div 16) + HexDigit(Lo(SerNo1) mod 16); end; end; procedure PutVolSerialNo(DriveNo: Byte; SerialNo: Longint); var ReturnArray: DiskSerNoInfoType; Regs: Registers; begin with Regs do begin AX := $440d; BL := DriveNo; CH := $08; CL := $66; DS := Seg(ReturnArray); DX := Ofs(ReturnArray); Intr($21, Regs); if (Flags and FCarry) = 0 then begin ReturnArray.VolSerNo.SerNo := SerialNo; AH := $69; BL := DriveNo; AL := $01; DS := Seg(ReturnArray); DX := Ofs(ReturnArray); Intr($21, Regs); end; end; end; Please feel free to update this answer in order to get it working (if possible at all) in Delphi.
(Wide)String - storing in TFileStream, Delphi 7. What is the fastest way?
I'm using Delphi7 (non-unicode VCL), I need to store lots of WideStrings inside a TFileStream. I can't use TStringStream as the (wide)strings are mixed with binary data, the format is projected to speed up loading and writing the data ... However I believe that current way I'm loading/writing the strings might be a bottleneck of my code ... currently I'm writing length of a string, then writing it char by char ... while loading, first I'm loading the length, then loading char by char ... So, what is the fastest way to save and load WideString to TFileStream? Thanks in advance
Rather than read and write one character at a time, read and write them all at once: procedure WriteWideString(const ws: WideString; stream: TStream); var nChars: LongInt; begin nChars := Length(ws); stream.WriteBuffer(nChars, SizeOf(nChars); if nChars > 0 then stream.WriteBuffer(ws[1], nChars * SizeOf(ws[1])); end; function ReadWideString(stream: TStream): WideString; var nChars: LongInt; begin stream.ReadBuffer(nChars, SizeOf(nChars)); SetLength(Result, nChars); if nChars > 0 then stream.ReadBuffer(Result[1], nChars * SizeOf(Result[1])); end; Now, technically, since WideString is a Windows BSTR, it can contain an odd number of bytes. The Length function reads the number of bytes and divides by two, so it's possible (although not likely) that the code above will cut off the last byte. You could use this code instead: procedure WriteWideString(const ws: WideString; stream: TStream); var nBytes: LongInt; begin nBytes := SysStringByteLen(Pointer(ws)); stream.WriteBuffer(nBytes, SizeOf(nBytes)); if nBytes > 0 then stream.WriteBuffer(Pointer(ws)^, nBytes); end; function ReadWideString(stream: TStream): WideString; var nBytes: LongInt; buffer: PAnsiChar; begin stream.ReadBuffer(nBytes, SizeOf(nBytes)); if nBytes > 0 then begin GetMem(buffer, nBytes); try stream.ReadBuffer(buffer^, nBytes); Result := SysAllocStringByteLen(buffer, nBytes) finally FreeMem(buffer); end; end else Result := ''; end; Inspired by Mghie's answer, have replaced my Read and Write calls with ReadBuffer and WriteBuffer. The latter will raise exceptions if they are unable to read or write the requested number of bytes.
There is nothing special about wide strings, to read and write them as fast as possible you need to read and write as much as possible in one go: procedure TForm1.Button1Click(Sender: TObject); var Str: TStream; W, W2: WideString; L: integer; begin W := 'foo bar baz'; Str := TFileStream.Create('test.bin', fmCreate); try // write WideString L := Length(W); Str.WriteBuffer(L, SizeOf(integer)); if L > 0 then Str.WriteBuffer(W[1], L * SizeOf(WideChar)); Str.Seek(0, soFromBeginning); // read back WideString Str.ReadBuffer(L, SizeOf(integer)); if L > 0 then begin SetLength(W2, L); Str.ReadBuffer(W2[1], L * SizeOf(WideChar)); end else W2 := ''; Assert(W = W2); finally Str.Free; end; end;
WideStrings contain a 'string' of WideChar's, which use 2 bytes each. If you want to store the UTF-16 (which WideStrings use internally) strings in a file, and be able to use this file in other programs like notepad, you need to write a byte order mark first: #$FEFF. If you know this, writing can look like this: Stream1.Write(WideString1[1],Length(WideString)*2); //2=SizeOf(WideChar) reading can look like this: Stream1.Read(WideChar1,2);//assert returned 2 and WideChar1=#$FEFF SetLength(WideString1,(Stream1.Size div 2)-1); Stream1.Read(WideString1[1],(Stream1.Size div 2)-1);
You can also use TFastFileStream for reading the data or strings, I pasted the unit at http://pastebin.com/m6ecdc8c2 and a sample below: program Project36; {$APPTYPE CONSOLE} uses SysUtils, Classes, FastStream in 'FastStream.pas'; const WideNull: WideChar = #0; procedure WriteWideStringToStream(Stream: TFileStream; var Data: WideString); var len: Word; begin len := Length(Data); // Write WideString length Stream.Write(len, SizeOf(len)); if (len > 0) then begin // Write WideString Stream.Write(Data[1], len * SizeOf(WideChar)); end; // Write null termination Stream.Write(WideNull, SizeOf(WideNull)); end; procedure CreateTestFile; var Stream: TFileStream; MyString: WideString; begin Stream := TFileStream.Create('test.bin', fmCreate); try MyString := 'Hello World!'; WriteWideStringToStream(Stream, MyString); MyString := 'Speed is Delphi!'; WriteWideStringToStream(Stream, MyString); finally Stream.Free; end; end; function ReadWideStringFromStream(Stream: TFastFileStream): WideString; var len: Word; begin // Read length of WideString Stream.Read(len, SizeOf(len)); // Read WideString Result := PWideChar(Cardinal(Stream.Memory) + Stream.Position); // Update position and skip null termination Stream.Position := Stream.Position + (len * SizeOf(WideChar)) + SizeOf(WideNull); end; procedure ReadTestFile; var Stream: TFastFileStream; my_wide_string: WideString; begin Stream := TFastFileStream.Create('test.bin'); try Stream.Position := 0; // Read WideString my_wide_string := ReadWideStringFromStream(Stream); WriteLn(my_wide_string); // Read another WideString my_wide_string := ReadWideStringFromStream(Stream); WriteLn(my_wide_string); finally Stream.Free; end; end; begin CreateTestFile; ReadTestFile; ReadLn; end.