How can I set a file's compression attribute in Delphi? - delphi

How can I compact files (set the 'c' attribute) from Delphi? I am speaking about the "compress contents to save disk space" function available under NTFS.
It seems that FileSetAttr does not allow me to set the 'c' attribute for a file.

you can also use the CIM_DataFile and CIM_Directory WMI classes, both had two methods called Compress and UnCompress which can be used to set the NTFS compression in a file or folder.
Check these samples (if the )
Compress (NTFS) or UnCompress a File
function CompressFile(const FileName:string;Compress:Boolean):integer;
var
FSWbemLocator : OLEVariant;
FWMIService : OLEVariant;
FWbemObject : OLEVariant;
begin;
FSWbemLocator := CreateOleObject('WbemScripting.SWbemLocator');
FWMIService := FSWbemLocator.ConnectServer('localhost', 'root\CIMV2', '', '');
FWbemObject := FWMIService.Get(Format('CIM_DataFile.Name="%s"',[StringReplace(FileName,'\','\\',[rfReplaceAll])]));
if Compress then
Result:=FWbemObject.Compress()
else
Result:=FWbemObject.UnCompress();
end;
Compress (NTFS) or UnCompress a Folder
function CompressFolder(const FolderName:string;Recursive, Compress:Boolean):integer;
var
FSWbemLocator : OLEVariant;
FWMIService : OLEVariant;
FWbemObject : OLEVariant;
StopFileName : OLEVariant;
begin;
FSWbemLocator := CreateOleObject('WbemScripting.SWbemLocator');
FWMIService := FSWbemLocator.ConnectServer('localhost', 'root\CIMV2', '', '');
FWbemObject := FWMIService.Get(Format('CIM_Directory.Name="%s"',[StringReplace(FolderName,'\','\\',[rfReplaceAll])]));
if Compress then
if Recursive then
Result:=FWbemObject.CompressEx(StopFileName, Null, Recursive)
else
Result:=FWbemObject.Compress()
else
if Recursive then
Result:=FWbemObject.UnCompressEx(StopFileName, Null, Recursive)
else
Result:=FWbemObject.UnCompress();
end;

The documentation for SetFileAttributes() explains that the FILE_ATTRIBUTE_COMPRESSED flag is not accepted by that function (although it is for GetFileAttributes). Instead it states:
To set a file's compression state, use the DeviceIoControl function with the FSCTL_SET_COMPRESSION operation.
The FSCTL_SET_COMPRESSION link in particular explains precisely how to do it. It goes something like this:
const
COMPRESSION_FORMAT_NONE = 0;
COMPRESSION_FORMAT_DEFAULT = 1;
COMPRESSION_FORMAT_LZNT1 = 2;
procedure SetCompressionAttribute(const FileName: string; const CompressionFormat: USHORT);
const
FSCTL_SET_COMPRESSION = $9C040;
var
Handle: THandle;
Flags: DWORD;
BytesReturned: DWORD;
begin
if DirectoryExists(FileName) then
Flags := FILE_FLAG_BACKUP_SEMANTICS
else if FileExists(FileName) then
Flags := 0
else
raise Exception.CreateFmt('%s does not exist', [FileName]);
Handle := CreateFile(PChar(FileName), GENERIC_READ or GENERIC_WRITE, 0, nil, OPEN_EXISTING, Flags, 0);
Win32Check(Handle <> INVALID_HANDLE_VALUE);
try
if not DeviceIoControl(Handle, FSCTL_SET_COMPRESSION, #CompressionFormat, SizeOf(Comp), nil, 0, BytesReturned, nil) then
RaiseLastOSError;
finally
CloseHandle(Handle);
end;
end;

Here you go. Call this against a file or a folder and it should do the job for you. State=true makes it compressed, State=false undoes the compression. Remember, though, that if you run it against a folder it only changes the attribute and makes it so future files created in that folder are compressed. To compress the ones already in there, you have to iterate and call this on each file (FindFirst/FindNext/FindClose). HTH.
function CompressFile(filepath: string; state: boolean): boolean;
const
COMPRESSION_FORMAT_DEFAULT = 1;
COMPRESSION_FORMAT_NONE = 0;
FSCTL_SET_COMPRESSION: DWord = $9C040;
var
compsetting: Word;
bytesreturned: DWord;
FHandle: THandle;
begin
//if not os_is_nt then
// raise Exception.Create('A Windows NT based OS is required for this function.');
FHandle := CreateFile(PChar(filepath), GENERIC_READ or GENERIC_WRITE,
0, nil, OPEN_EXISTING, FILE_FLAG_BACKUP_SEMANTICS, 0);
if FHandle = INVALID_HANDLE_VALUE then
raise Exception.Create('CompressFile Message: ' + SysErrorMessage(GetLastError));
if state = true then
compsetting := COMPRESSION_FORMAT_DEFAULT
else
compsetting := COMPRESSION_FORMAT_NONE;
try
Result := DeviceIOControl(FHandle, FSCTL_SET_COMPRESSION, #compsetting,
sizeof(compsetting), nil, 0, bytesreturned, nil);
finally
CloseHandle(FHandle);
end;
end;

Related

Read text files in Delphi

Hi I am having a problem running a function to read a text file the problem seems to be that my antivirus blocks my delphi console program because when I do for a visual form there is no problem .
Tengos two codes one is this :
function LeerArchivox(const filename: TFileName): String;
var
List: TStringList;
begin
if (FileExists(filename)) then
begin
List := TStringList.Create;
List.Loadfromfile(filename);
Result := List.text;
List.Free;
end;
end;
This goes to perfection but do not want to use the component Classes for the program does not weigh much .
Also I have this :
function leerarchivo(filealeer: string): string;
var
abriendo: TextFile;
lineasleyendo: string;
finaldearchivo: string;
begin
finaldearchivo := '';
AssignFile(abriendo, filealeer);
Reset(abriendo);
while not Eof(abriendo) do
begin
ReadLn(abriendo, lineasleyendo);
finaldearchivo := finaldearchivo + lineasleyendo;
end;
CloseFile(abriendo);
Result := finaldearchivo;
end;
Other code.
function leerarchivo3(archivoaleer: string): string;
const
BUFF_SIZE = $8000;
var
dwread: LongWord;
hFile: THandle;
datafile: array [0 .. BUFF_SIZE - 1] of ansichar;
codigofinal: string;
begin
codigofinal := '';
hFile := CreateFile(PChar(archivoaleer), GENERIC_READ,
FILE_SHARE_READ or FILE_SHARE_WRITE, nil, OPEN_EXISTING,
FILE_ATTRIBUTE_READONLY, 0);
SetFilePointer(hFile, 0, nil, FILE_BEGIN);
Readfile(hFile, datafile, BUFF_SIZE, dwread, nil);
while (dwread > 0) do
begin
Readfile(hFile, datafile, BUFF_SIZE, dwread, nil);
codigofinal := codigofinal + datafile;
end;
Result := codigofinal;
end;
This is the problem because when I use my antivirus deletes it at the time , my question to other alternatives I have to read a text file without using Classes.
Someone can help me?
This code works fine for me as a console application, Delphi 2007, running on Win7 64:
Contents of 'E:\TempFiles\Test.txt':
One
Two
Three
Four
Source:
program Project2;
{$APPTYPE CONSOLE}
uses
SysUtils;
var
Txt: TextFile;
s: string;
AllText: string;
begin
AllText := '';
AssignFile(Txt, 'E:\TempFiles\test.txt');
Reset(Txt);
while not Eof(Txt) do
begin
Readln(Txt, s);
AllText := AllText + s;
// Write out each line; comment out to stop.
Writeln(s);
end;
CloseFile(Txt);
// Write out all content as a single string.
WriteLn(AllText);
ReadLn;
end.
Produces output:
One
Two
Three
Four
OneTwoThreeFour
You can use win32 api.
In one of my apps I do things like that, extend/modify to match your needs. This only use Win32 API and does not lock the file. It's like notepad. When you open a file with notepad it is not locked and can still be written or read by other software.
const
BUFF_SIZE = $8000;
var
dwread:LongWord;
hFile: THandle;
datafile : array [0..BUFF_SIZE-1] of ansichar;
//create file handler
hFile := createfile(PChar(TFilePanel(FilePanelList.Items[i-1]).LongFileName), GENERIC_READ,
FILE_SHARE_READ or FILE_SHARE_WRITE, nil, OPEN_EXISTING, FILE_ATTRIBUTE_READONLY, 0);
//set file pointer to beginning of file
SetFilePointer(hFile, 0, nil, FILE_BEGIN);
//read the file
try
Readfile(hFile, datafile, BUFF_SIZE, dwread, nil);
while (dwread > 0) do
begin
//read/use datafile
Here_do_something_with_datafile;
Readfile(hFile, datafile, BUFF_SIZE, dwread, nil);
end;
finally
closehandle(hFile);
end;
var txt : TextFile;
begin
AssignFile(txt,'filetxt.txt');
ReWrite(filetxt);
Writeln(filetxt,memo1.Lines.Text);
CloseFile(filetxt);
Reset(filetxt);
while not Eof(filetxt) do
begin
Readln(filetxt);
end;
CloseFile(filetxt);
If you don't want to use the Classes unit, only need to operate on this file, and are making a Windows executable, you could use the Windows unit instead and call the Win32 API functions: CreateFile, ReadFile, CloseHandle and related functions.

CreateFileMapping fails with hFile other than INVALID_HANDLE_VALUE

update - solved and answered, offending lines have been commented out
Brief description
I am having a problem linking CreateFile with CreateFileMapping even though I use (GENERIC_WRITE or GENERIC_WRITE) for CreateFile, with PAGE_READWRITE for CreateFileMapping
Detailed description
I am using CreateFileMapping to share memory between proceses.
the actual mechanics of that is working fine, assuming I don't map to a physical file and instead use INVALID_HANDLE_VALUE for the first parameter to CreateFileMapping. This is fine, however what I'd like to achieve is for the main process that creates this map to use a disk based file, and flush it to the drive, periodically, and when it shuts down, so the data is automatically saved.
Code follows...
(when i run this, i get "Error 5 : Access is Denied" as the ShowMessage)
const MaximumMapSize = 256 * 1024;
var virtualMemoryPath : string = '';
function getFileHandle(mapname : string; maxSize : dword) :THandle;
var diskfilename : string;
lpFileName: PChar;
dwDesiredAccess: DWORD;
dwShareMode: DWORD;
lpSecurityAttributes: PSecurityAttributes;
dwCreationDisposition : dword;
dwFlagsAndAttributes: DWORD;
hTemplateFile : THandle ;
temp : pointer;
begin
Result := INVALID_HANDLE_VALUE;
if (maxSize <= MaximumMapSize) and (Length(virtualMemoryPath) > 0) then
begin
diskfilename := virtualMemoryPath+mapname+'.bin';
if FileExists(diskfilename) then
Sysutils.DeleteFile(diskfilename);
lpFileName := PChar(diskfilename);
//dwDesiredAccess := GENERIC_WRITE or GENERIC_WRITE;//<<<wrong
dwDesiredAccess := GENERIC_READ or GENERIC_WRITE;
dwShareMode := 0;//FILE_SHARE_READ or FILE_SHARE_WRITE;//<<wrong
lpSecurityAttributes := nil;
dwCreationDisposition := CREATE_ALWAYS;
dwFlagsAndAttributes := 0;
hTemplateFile := 0 ;
Result := CreateFile(
lpFileName,
dwDesiredAccess,
dwShareMode,
lpSecurityAttributes,
dwCreationDisposition,
dwFlagsAndAttributes,
hTemplateFile);
if (Result <> INVALID_HANDLE_VALUE) then
begin
GetMem(temp,maxsize);
ZeroMemory(temp,maxsize);
FileWrite(result,temp^,maxSize);
FreeMem (temp,maxsize);
FlushFileBuffers(result);
SetFilePointer(result,0,0,FILE_BEGIN);
end;
end;
end;
function createMap (mapname : string ; maxSize: dword; var hFile: THandle) : THandle;
var
lpFileMappingAttributes: PSecurityAttributes;
flProtect : DWORD;
dwMaximumSizeHigh : DWORD;
dwMaximumSizeLow : DWORD;
lpName : PChar;
LastError : dword;
begin
Result := INVALID_HANDLE_VALUE;
if (maxSize > MaximumMapSize) then
exit;
// create a disk the file or return INVALID_HANDLE_VALUE if settings have not defined a path to folder
hFile := getFileHandle(mapname,maxSize);
lpFileMappingAttributes := nil;
flProtect := PAGE_READWRITE;
dwMaximumSizeHigh := 0;
dwMaximumSizeLow := maxSize;
lpName := PChar(mapname);
Result := CreateFileMapping(
hfile,
lpFileMappingAttributes,
flProtect,
dwMaximumSizeHigh,
dwMaximumSizeLow,
lpName);
if (Result = 0) then
begin
if (not (hFile = INVALID_HANDLE_VALUE) ) then
CloseHandle(hFile);
hFile := 0;
LastError := GetLastError();
ShowMessage( Format('Error %d : %s',[LastError,SysErrorMessage(LastError)]) );
end
else
begin
ShowMessage(Format('Returing handle %d',[result]));
if (hFile = INVALID_HANDLE_VALUE) then
hFile := 0;
end;
end;
dwDesiredAccess := GENERIC_WRITE or GENERIC_WRITE;
dwShareMode := FILE_SHARE_READ or FILE_SHARE_WRITE;
This cannot work. You'll need read and write access. Also, creating a view requires the operating system to be sure that it is the only one that can write to the file. There's no mechanism to detect another process writing to the file, other than through a view, and ensure that such a write is visible in memory in a timely and synchronous manner. Particularly the synchronous update is impossible to implement with multiple threads accessing the view.
Read sharing is similarly unwise, the operating system provides no guarantee at which time it updates the file from the view. The only guarantee is that it will be updated when all views are closed. Which also means that an orderly shutdown of Windows is required, you cannot make this reliable against mishaps like a power loss. Again, reads need to be done through the view, not the file. The only appropriate choice is no sharing.
The mistake is here:
GENERIC_WRITE or GENERIC_WRITE
You meant:
GENERIC_READ or GENERIC_WRITE
Fix that and your file mapping can be created.
I agree with Hans that you should not be sharing the file handle.

Check if everyone may read/write to a directory

We are facing the problem, that different user groups shall be able to read and write files from a common data directory (e.g. c:\ProgramData\xyz).
The data is written from different sources e.g. a service writes files into it and a user shall be able to change it's content later on.
The problem now is that this only works if "everybody" is allowed to read/write/change
files in that directory (und subdirs).
What I want to check in the installer is if all users are allowed to do so aka. check if the "every users" group (or "Jeder" group in german) is in the access list.
I have only basic knowledge about ACL and can change that in the explorer but I would need a few lines of code which push me into the right direction (in Delphi).
many thanks
Mike
I think it's not a Delphi but WinAPI question. Delphi doesn't have any special facilities to make this easier AFAIK.
Getting information from an ACL says you need to do GetSecurityInfo on an open handle, then GetEffectiveRightsFromACL on an ACL you get.
You specify a trustee, which can be by name, but better use SID. Name for "Everyone" can change, but there's a special SID for it which is valid on any PC, google it. Okay, here it is: "(S-1–1–0)". Or you can use CreateWellKnownSid and give it WinWorldSid to get the same SID (more proper but longer way).
All of that from five minutes of googling so watch out for mistakes.
Alright, here's some code.
function ConvertStringSidToSid(StringSid: PWideChar; var Sid: PSID): boolean; stdcall; external advapi32 name 'ConvertStringSidToSidW';
function AclGetEffectiveRights(const path, sid: string): cardinal;
var h: THandle; //handle to our directory
err: integer;
dacl: PACL; //access control list for the object
secdesc: pointer;
tr: TRUSTEE;
bsid: PSid;
begin
Result := 0;
//Open directory
h := CreateFile(PChar(path), GENERIC_READ, FILE_SHARE_READ, nil,
OPEN_EXISTING, FILE_ATTRIBUTE_NORMAL or FILE_FLAG_BACKUP_SEMANTICS, 0);
//we need FILE_FLAG_BACKUP_SEMANTICS to open a directory
if h=INVALID_HANDLE_VALUE then RaiseLastOsError();
try
bsid := nil;
//Query access control list for a directory -- the list you see in the properties box
err := GetSecurityInfo(h, SE_FILE_OBJECT, DACL_SECURITY_INFORMATION,
nil, nil, #dacl, nil, secdesc);
//GetSecurityInfo can return many things but we only need DACL,
//and we are required to also get a security descriptor
if err<>ERROR_SUCCESS then
raise Exception.CreateFmt('Cannot retrieve DACL: error %d',[err]);
try
//Convert string sid to binary sid
if not ConvertStringSidToSid(PChar(sid), bsid) then
RaiseLastOsError();
//Query effective rights for a trustee
BuildTrusteeWithSid(#tr, bsid);
err := GetEffectiveRightsFromAcl(dacl^, tr, Result);
if err<>ERROR_SUCCESS then
raise Exception.CreateFmt('Cannot calculate effective rights: error %d',[err]);
finally
//Documentation says to free some resources this way when we're done with it.
LocalFree(NativeUint(bsid));
LocalFree(NativeUint(secdesc));
end;
finally
CloseHandle(h);
end;
end;
It's used like this:
var rights,test: cardinal;
rights := AclGetEffectiveRights('C:\My\Folder','S-1-1-0');
//List rights you want tested
test := FILE_LIST_DIRECTORY + FILE_ADD_FILE + FILE_ADD_SUBDIRECTORY
+ FILE_READ_EA + FILE_WRITE_EA + FILE_TRAVERSE + FILE_DELETE_CHILD;
Result := (rights and test) = test;
Might not work; gives ACCESS_DENIED on my PC but that's probably because of my complicated domain situation. Anyway that's something for a start.
So.. The above version worked... until Windows Update 1903 hit me and GetEffectiveRightsFromAcl always resulted in an error ERROR_NO_SUCH_DOMAIN (which is obscure since there is no Domain whatsoever involved here).
So I needed to switch to the following procedure:
// ###########################################
// ### translated and extended from https://learn.microsoft.com/de-de/windows/win32/api/aclapi/nf-aclapi-geteffectiverightsfromacla
procedure DisplayAccessMask(Mask : ACCESS_MASK );
begin
{
// This evaluation of the ACCESS_MASK is an example.
// Applications should evaluate the ACCESS_MASK as necessary.
}
if (((Mask and GENERIC_ALL) = GENERIC_ALL)
or ((Mask and FILE_ALL_ACCESS) = FILE_ALL_ACCESS))
then
begin
OutputDebugString( 'Full control');
exit;
end;
if (((Mask and GENERIC_READ) = GENERIC_READ)
or ((Mask and FILE_GENERIC_READ) = FILE_GENERIC_READ))
then
OutputDebugString( 'Read');
if (((Mask and GENERIC_WRITE) = GENERIC_WRITE)
or ((Mask and FILE_GENERIC_WRITE) = FILE_GENERIC_WRITE))
then
OutputDebugString('Write');
if (((Mask and GENERIC_EXECUTE) = GENERIC_EXECUTE)
or ((Mask and FILE_GENERIC_EXECUTE) = FILE_GENERIC_EXECUTE))
then
OutputDebugString('Execute');
end;
function CheckMask( MASK : ACCESS_MASK; refMask : ACCESS_MASK ) : boolean;
var msk : ACCESS_MASK;
begin
msk := 0;
if (((Mask and GENERIC_READ) = GENERIC_READ)
or ((Mask and FILE_GENERIC_READ) = FILE_GENERIC_READ))
then
msk := msk or FILE_GENERIC_READ;
if (((Mask and GENERIC_WRITE) = GENERIC_WRITE)
or ((Mask and FILE_GENERIC_WRITE) = FILE_GENERIC_WRITE))
then
msk := msk or FILE_GENERIC_WRITE;
if (((Mask and GENERIC_EXECUTE) = GENERIC_EXECUTE)
or ((Mask and FILE_GENERIC_EXECUTE) = FILE_GENERIC_EXECUTE))
then
msk := msk or FILE_GENERIC_EXECUTE;
Result := (msk and refMask) = refMask;
end;
function GetAccess(hAuthzClient :AUTHZ_CLIENT_CONTEXT_HANDLE; psd : PSECURITY_DESCRIPTOR) : BOOL;
var AccessRequest : AUTHZ_ACCESS_REQUEST;
AccessReply : AUTHZ_ACCESS_REPLY;
buffer : Array[0..1023] of Byte;
begin
FillChar(AccessRequest, sizeof(AccessRequest), 0);
FillChar(AccessReply, sizeof(AccessReply), 0);
FillChar(buffer, sizeof(buffer), 0);
AccessRequest.DesiredAccess := MAXIMUM_ALLOWED;
AccessRequest.PrincipalSelfSid := nil;
AccessRequest.ObjectTypeList := nil;
AccessRequest.ObjectTypeListLength := 0;
AccessRequest.OptionalArguments := nil;
AccessReply.ResultListLength := 1;
AccessReply.GrantedAccessMask := PACCESS_MASK( LongWord(#Buffer[0]));
AccessReply.Error := PDWORD( LongWord( AccessReply.GrantedAccessMask ) + sizeof(Access_Mask));
Result := AuthzAccessCheck( 0,
hAuthzClient,
#AccessRequest,
0,
psd,
nil,
0,
#AccessReply,
nil);
if Result then
begin
DisplayAccessMask( AccessReply.GrantedAccessMask^ );
Result := CheckMask( AccessReply.GrantedAccessMask^, FILE_GENERIC_WRITE or FILE_GENERIC_READ );
end
else
RaiseLastOSError;
end;
function ConvertStringSidToSid(StringSid: PWideChar; var Sid: PSID): boolean; stdcall; external advapi32 name 'ConvertStringSidToSidW';
function ConvertNameToBinarySid(pAccountName : PCHAR): PSID ;
var pDomainName : PChar;
dwDomainNameSize : DWord;
aSID : PSID;
dwSIDSIZE : DWORD;
sidType : SID_NAME_USE;
begin
pDomainName := nil;
dwDomainNameSize := 0;
aSID := nil;
LookupAccountName( nil, pAccountName, aSID, dwSIDSIZE, pDomainName, dwDomainNameSize, sidType);
aSid := Pointer( LocalAlloc( LPTR, dwSIDSIZE*sizeof(char)) );
pDomainName := Pointer( LocalAlloc(LPTR, dwDomainNameSize*sizeof(char)) );
if not LookupAccountName( nil, pAccountName, aSID, dwSIDSIZE, pDomainName, dwDomainNameSize, sidType) then
begin
LocalFree( Cardinal(aSID) );
Result := nil;
end
else
begin
Result := aSid;
end;
LocalFree( Cardinal(pDomainName) );
end;
function GetEffectiveRightsForSID(hManager :AUTHZ_RESOURCE_MANAGER_HANDLE;
psd : PSECURITY_DESCRIPTOR;
sid : PChar) : BOOL;
var asid : PSID;
bResult : BOOL;
unusedID : LUID;
hAuthzClientContext : AUTHZ_CLIENT_CONTEXT_HANDLE;
begin
Result := False;
asid := nil;
hAuthzClientContext := 0;
FillChar(unusedID, sizeof(unusedID), 0);
if not ConvertStringSidToSid(sid, asid) then
RaiseLastOsError();
// asid := ConvertNameToBinarySid('rabatscher');
if asid = nil then
RaiseLastOSError;
try
if asid <> nil then
begin
bResult := AuthzInitializeContextFromSid( 0, aSid, hManager, nil, unusedId, nil, #hAuthzClientContext );
try
if bResult then
Result := GetAccess(hAuthzClientContext, psd);
finally
if hAuthzClientContext <> 0 then
AuthzFreeContext(hAuthzClientContext);
end;
end;
finally
if asid <> nil then
LocalFree(LongWord(asid));
end;
end;
function UseAuthzSolution( psd : PSECURITY_DESCRIPTOR; const sid : string = 'S-1-1-0') : boolean;
var hManager : AUTHZ_RESOURCE_MANAGER_HANDLE;
bResult : BOOL;
pSid : PChar;
begin
bResult := AuthzInitializeResourceManager(AUTHZ_RM_FLAG_NO_AUDIT,
nil, nil, nil, nil, #hManager);
if bResult then
begin
pSid := PChar(sid);
bResult := GetEffectiveRightsForSID(hManager, psd, psid);
AuthzFreeResourceManager(hManager);
end;
Result := bResult;
end;
function GetSecurityInfo(handle: THandle; ObjectType: SE_OBJECT_TYPE;
SecurityInfo: SECURITY_INFORMATION; ppsidOwner, ppsidGroup: PPSID; ppDacl, ppSacl: PACL;
var pSecurityDescriptor: PSECURITY_DESCRIPTOR): DWORD; stdcall; external 'ADVAPI32.DLL' name 'GetSecurityInfo'; {use localfree to release ppSecurityDescriptor}
function CheckDirectoryAccess( path : string ) : boolean;
var dw : DWORD;
apacl : PACL;
psd : PSECURITY_DESCRIPTOR;
apSID : PSID;
h : THandle;
begin
try
apSID := nil;
//Open directory
h := CreateFile(PChar(path), GENERIC_READ, FILE_SHARE_READ, nil,
OPEN_EXISTING, FILE_ATTRIBUTE_NORMAL or FILE_FLAG_BACKUP_SEMANTICS, 0);
//we need FILE_FLAG_BACKUP_SEMANTICS to open a directory
if h = INVALID_HANDLE_VALUE then
RaiseLastOsError();
try
//Query access control list for a directory -- the list you see in the properties box
dw := GetSecurityInfo(h, SE_FILE_OBJECT, DACL_SECURITY_INFORMATION or OWNER_SECURITY_INFORMATION or GROUP_SECURITY_INFORMATION,
nil, nil, #apacl, nil, psd);
if dw <> ERROR_SUCCESS then
RaiseLastOSError;
try
Result := UseAuthzSolution(psd);
finally
if apSID <> nil then
LocalFree(NativeUint(apSID));
LocalFree(NativeUint(psd));
end;
finally
CloseHandle(h);
end;
except
on E : Exception do
begin
Result := False;
end;
end;
end;
Note that there are a few changes so the procedure works:
GetSecurityInfo (from the above procedure) needs the parameter DACL_SECURITY_INFORMATION or OWNER_SECURITY_INFORMATION or GROUP_SECURITY_INFORMATION (not only DACL_SECURITY_INFORMATION) otherwise you get an Error 87 in AuthzAccessCheck!
In addition you need to check out the JWA headers from the jedi library.
Hope that helps other people too.

How to correctly retrieve battery serial number?

In Delphi 7 I'm working on a library implementing an object encapsulating information about the batteries attached to a system. It's working well, except for retrieving the serial number for the battery.
The code I am using for this call is as follows:
function TBattery.GetSerialNumber(hbat: THandle): boolean;
var
bqi: TBatteryQueryInformation;
Serial: PWideChar;
SerialSize,
dwOut: DWORD;
begin
Result := False;
if hbat <> INVALID_HANDLE_VALUE then
begin
ZeroMemory(#bqi, SizeOf(bqi));
dwOut := 0;
bqi.BatteryTag := FBatteryTag;
bqi.InformationLevel := BatterySerialNumber;
SerialSize := 2048;
GetMem(Serial, SerialSize);
try
ZeroMemory(Serial, SerialSize);
Result := DeviceIoControl(hbat, IOCTL_BATTERY_QUERY_INFORMATION, #bqi,
SizeOf(bqi), Serial, SerialSize, #dwOut, nil);
if Result then
FSerialNumber := Serial;
finally
FreeMem(Serial, SerialSize);
end;
end;
end;
Unfortunately, DeviceIoControl() always returns False and if I check GetLastError() afterwards then it comes back with error 87, "the parameter is incorrect."
This doesn't make much sense, because the code works perfectly well if I simply change the InformationLevel from BatterySerialNumber to BatteryUniqueID, say. Also, I've used the handle to the battery (hbat) in other calls in the code before GetSerialNumber and they all work fine, and I can call others after this one fails as well, so that's not the issue.
Any ideas? I'm really at a loss.
The issue it seems related to the dwOut variable which is passed as #dwOut, this variable represents the var lpBytesReturned parameter of the DeviceIoControl which is defined as
function DeviceIoControl(hDevice: THandle; dwIoControlCode: DWORD; lpInBuffer: Pointer;
nInBufferSize: DWORD; lpOutBuffer: Pointer; nOutBufferSize: DWORD;
var lpBytesReturned: DWORD; lpOverlapped: POverlapped): BOOL; stdcall;
So replacing your code by
Result := DeviceIoControl(hbat, IOCTL_BATTERY_QUERY_INFORMATION, #bqi,
SizeOf(bqi), Serial, SerialSize, dwOut, nil);
Must fix the problem.
WinAPI
Also check this code translated to delphi from this msdn entry Enumerating Battery Devices which can help you to detect any additional issues with your code.
uses
SetupApi,
Windows,
SysUtils;
type
BATTERY_QUERY_INFORMATION_LEVEL = (
BatteryInformation,
BatteryGranularityInformation,
BatteryTemperature,
BatteryEstimatedTime,
BatteryDeviceName,
BatteryManufactureDate,
BatteryManufactureName,
BatteryUniqueID,
BatterySerialNumber);
TBatteryQueryInformationLevel = BATTERY_QUERY_INFORMATION_LEVEL;
_BATTERY_QUERY_INFORMATION = record
BatteryTag: ULONG;
InformationLevel: BATTERY_QUERY_INFORMATION_LEVEL;
AtRate: Longint;
end;
BATTERY_QUERY_INFORMATION = _BATTERY_QUERY_INFORMATION;
PBATTERY_QUERY_INFORMATION = ^BATTERY_QUERY_INFORMATION;
TBatteryQueryInformation = BATTERY_QUERY_INFORMATION;
const
GUID_DEVCLASS_BATTERY:TGUID='{72631E54-78A4-11D0-BCF7-00AA00B7B32A}';
//DEFINE_GUID( GUID_DEVCLASS_BATTERY, 0x72631E54, 0x78A4, 0x11D0, 0xBC, 0xF7, 0x00, 0xAA, 0x00, 0xB7, 0xB3, 0x2A );
METHOD_BUFFERED = 0;
FILE_DEVICE_BATTERY = $00000029;
FILE_READ_ACCESS = $0001; // for files and pipes
IOCTL_BATTERY_QUERY_TAG =
(FILE_DEVICE_BATTERY shl 16) or (FILE_READ_ACCESS shl 14) or ($10 shl 2) or (METHOD_BUFFERED);
IOCTL_BATTERY_QUERY_INFORMATION =
(FILE_DEVICE_BATTERY shl 16) or (FILE_READ_ACCESS shl 14) or ($11 shl 2) or (METHOD_BUFFERED);
function GetBatteryInfo(InformationLevel : BATTERY_QUERY_INFORMATION_LEVEL) : string;
var
cbRequired : DWORD;
hdev : HDEVINFO;
idev : Integer;
did : TSPDeviceInterfaceData;
pdidd : PSPDeviceInterfaceDetailData;
hBattery : THandle;
bqi : TBatteryQueryInformation;
dwWait, dwOut : DWORD;
lpOutBuffer: PWideChar;
begin
// enumerate the batteries
hdev := SetupDiGetClassDevs(#GUID_DEVCLASS_BATTERY, nil, 0, DIGCF_PRESENT OR DIGCF_DEVICEINTERFACE);
if ( INVALID_HANDLE_VALUE <> THandle(hdev) ) then
begin
idev:=0;//first battery
ZeroMemory(#did, SizeOf(did));
did.cbSize := SizeOf(did);
if (SetupDiEnumDeviceInterfaces(hdev, nil, GUID_DEVCLASS_BATTERY, idev, did)) then
begin
try
cbRequired := 0;
SetupDiGetDeviceInterfaceDetail(hdev, #did, nil, 0, cbRequired, nil);
if (ERROR_INSUFFICIENT_BUFFER= GetLastError()) then
begin
pdidd:=AllocMem(cbRequired);
try
pdidd.cbSize := SizeOf(TSPDeviceInterfaceDetailData);
if (SetupDiGetDeviceInterfaceDetail(hdev, #did, pdidd, cbRequired, cbRequired, nil)) then
begin
hBattery :=CreateFile(pdidd.DevicePath, GENERIC_READ OR GENERIC_WRITE, FILE_SHARE_READ OR FILE_SHARE_WRITE, nil, OPEN_EXISTING, FILE_ATTRIBUTE_NORMAL, 0);
if (INVALID_HANDLE_VALUE <> hBattery) then
begin
try
ZeroMemory(#bqi, SizeOf(bqi));
// With the tag, you can query the battery info.
dwWait := 0;
if (DeviceIoControl(hBattery, IOCTL_BATTERY_QUERY_TAG, #dwWait, sizeof(dwWait), #bqi.BatteryTag, sizeof(bqi.BatteryTag), dwOut, nil)) then
begin
lpOutBuffer:=AllocMem(MAX_PATH);
try
ZeroMemory(lpOutBuffer,MAX_PATH);
bqi.InformationLevel:=InformationLevel;
if DeviceIoControl(hBattery, IOCTL_BATTERY_QUERY_INFORMATION, #bqi, SizeOf(BATTERY_QUERY_INFORMATION), lpOutBuffer, 255, dwOut,nil) then
Result:= WideCharToString(lpOutBuffer);
finally
FreeMem(lpOutBuffer);
end;
end;
finally
CloseHandle(hBattery)
end;
end;
end;
finally
FreeMem(pdidd);
end;
end;
finally
SetupDiDestroyDeviceInfoList(hdev);
end;
end;
end;
end;
begin
try
if not LoadsetupAPI then exit;
Writeln(GetBatteryInfo(BatterySerialNumber));
except
on E: Exception do
Writeln(E.ClassName, ': ', E.Message);
end;
readln;
end.
WMI
Finally as aside note, you can use the WMI to retrieve the same info, in this case using the BatteryStaticData WMI class
{$APPTYPE CONSOLE}
uses
SysUtils,
ActiveX,
ComObj,
Variants;
// Battery Static Data
procedure GetBatteryStaticDataInfo;
const
WbemUser ='';
WbemPassword ='';
WbemComputer ='localhost';
wbemFlagForwardOnly = $00000020;
var
FSWbemLocator : OLEVariant;
FWMIService : OLEVariant;
FWbemObjectSet: OLEVariant;
FWbemObject : OLEVariant;
oEnum : IEnumvariant;
iValue : LongWord;
begin;
FSWbemLocator := CreateOleObject('WbemScripting.SWbemLocator');
FWMIService := FSWbemLocator.ConnectServer(WbemComputer, 'root\WMI', WbemUser, WbemPassword);
FWbemObjectSet:= FWMIService.ExecQuery('SELECT SerialNumber FROM BatteryStaticData','WQL',wbemFlagForwardOnly);
oEnum := IUnknown(FWbemObjectSet._NewEnum) as IEnumVariant;
while oEnum.Next(1, FWbemObject, iValue) = 0 do
begin
Writeln(Format('SerialNumber %s',[String(FWbemObject.SerialNumber)]));// String
Writeln('');
FWbemObject:=Unassigned;
end;
end;
begin
try
CoInitialize(nil);
try
GetBatteryStaticDataInfo;
finally
CoUninitialize;
end;
except
on E:EOleException do
Writeln(Format('EOleException %s %x', [E.Message,E.ErrorCode]));
on E:Exception do
Writeln(E.Classname, ':', E.Message);
end;
Writeln('Press Enter to exit');
Readln;
end.
In summary, the code #RRUZ and I posted work fine under Windows 7, as well as other third-party applications. They do not work for retrieving the serial number under Windows XP. I've also tested under WinXP and 7 with base installs of the OS on the exact same hardware, with identical results (success under Windows 7, not under windows XP).
It appears that under WinXP the value BatterySerialNumber for IOCTL_BATTERY_QUERY_INFORMATION's InformationLevel member is not supported, but this is not documented directly in the Windows SDK docs. It is documented that invalid entries should return error 1 (ERROR_INVALID_FUNCTION) for GetLastError(), but in this case is returning 87 (for an invalid parameter) instead. I posit that this is because that value in the enumeration is not valid, so it makes the parameter invalid, but I'm not exactly sure.
Thanks to all for their help, especially #RRUZ for going way above and beyond!
(As an aside, it appears that one can extract the serial number from the battery's Unique ID (Using BatteryUniqueID as the InformationLevel member) and removing the manufacturer name and device name from the unique ID. That's a terrible hack, but it's a semi-viable workaround for Windows XP.)

Delphi - How to get list of USB removable hard drives and memory sticks?

In my application (Delphi), I need to list all the USB storage devices. These can be either flash memory sticks or external storage drives.
There is a Jvcl component JvDriveCombo, and it has the DriveType property - the problem is if I select DriveType := Fixed then in addition to the external drive, it also lists the internal drives (C:\, D:\ etc). However, I only want to list the external drives.
I believe there is DeviceIoControl function (I saw it on MSDN) but I have no idea of how to use it.
I wonder if anyone can help me with the proper way / code to list USB storage devices?
Thanks.
EDIT:
I just found some sample code and am posting it here:
uses .... jwawinbase, JwaWinIoctl;
procedure TForm1.Button1Click(Sender: TObject);
var
DriveCmdStr: string;
DriveHandle: THandle;
ADriveLetter: string;
hp: STORAGE_HOTPLUG_INFO;
rlen: DWORD;
begin
ADriveLetter := 'H';
DriveCmdStr := Format('\\.\%s:', [ADriveLetter]);
DriveHandle := CreateFile(PChar(DriveCmdStr), GENERIC_READ, FILE_SHARE_WRITE,
nil, OPEN_EXISTING, 0, 0);
if DriveHandle = INVALID_HANDLE_VALUE then
Exit;
DeviceIoControl(DriveHandle, IOCTL_STORAGE_GET_HOTPLUG_INFO, nil, 0, #hp,
SizeOf(hp), #rlen, nil);
CloseHandle(DriveHandle);
if hp.MediaRemovable then
showmessage('media removable');
end;
Now I would like to just know how to enumerate all the drive letters. Which is the most efficient function?
{$MINENUMSIZE 4}
const
IOCTL_STORAGE_QUERY_PROPERTY = $002D1400;
type
STORAGE_QUERY_TYPE = (PropertyStandardQuery = 0, PropertyExistsQuery, PropertyMaskQuery, PropertyQueryMaxDefined);
TStorageQueryType = STORAGE_QUERY_TYPE;
STORAGE_PROPERTY_ID = (StorageDeviceProperty = 0, StorageAdapterProperty);
TStoragePropertyID = STORAGE_PROPERTY_ID;
STORAGE_PROPERTY_QUERY = packed record
PropertyId: STORAGE_PROPERTY_ID;
QueryType: STORAGE_QUERY_TYPE;
AdditionalParameters: array [0..9] of AnsiChar;
end;
TStoragePropertyQuery = STORAGE_PROPERTY_QUERY;
STORAGE_BUS_TYPE = (BusTypeUnknown = 0, BusTypeScsi, BusTypeAtapi, BusTypeAta, BusType1394, BusTypeSsa, BusTypeFibre,
BusTypeUsb, BusTypeRAID, BusTypeiScsi, BusTypeSas, BusTypeSata, BusTypeMaxReserved = $7F);
TStorageBusType = STORAGE_BUS_TYPE;
STORAGE_DEVICE_DESCRIPTOR = packed record
Version: DWORD;
Size: DWORD;
DeviceType: Byte;
DeviceTypeModifier: Byte;
RemovableMedia: Boolean;
CommandQueueing: Boolean;
VendorIdOffset: DWORD;
ProductIdOffset: DWORD;
ProductRevisionOffset: DWORD;
SerialNumberOffset: DWORD;
BusType: STORAGE_BUS_TYPE;
RawPropertiesLength: DWORD;
RawDeviceProperties: array [0..0] of AnsiChar;
end;
TStorageDeviceDescriptor = STORAGE_DEVICE_DESCRIPTOR;
function GetBusType(Drive: AnsiChar): TStorageBusType;
var
H: THandle;
Query: TStoragePropertyQuery;
dwBytesReturned: DWORD;
Buffer: array [0..1023] of Byte;
sdd: TStorageDeviceDescriptor absolute Buffer;
OldMode: UINT;
begin
Result := BusTypeUnknown;
OldMode := SetErrorMode(SEM_FAILCRITICALERRORS);
try
H := CreateFile(PChar(Format('\\.\%s:', [AnsiLowerCase(Drive)])), 0, FILE_SHARE_READ or FILE_SHARE_WRITE, nil,
OPEN_EXISTING, 0, 0);
if H <> INVALID_HANDLE_VALUE then
begin
try
dwBytesReturned := 0;
FillChar(Query, SizeOf(Query), 0);
FillChar(Buffer, SizeOf(Buffer), 0);
sdd.Size := SizeOf(Buffer);
Query.PropertyId := StorageDeviceProperty;
Query.QueryType := PropertyStandardQuery;
if DeviceIoControl(H, IOCTL_STORAGE_QUERY_PROPERTY, #Query, SizeOf(Query), #Buffer, SizeOf(Buffer), dwBytesReturned, nil) then
Result := sdd.BusType;
finally
CloseHandle(H);
end;
end;
finally
SetErrorMode(OldMode);
end;
end;
procedure GetUsbDrives(List: TStrings);
var
DriveBits: set of 0..25;
I: Integer;
Drive: AnsiChar;
begin
List.BeginUpdate;
try
Cardinal(DriveBits) := GetLogicalDrives;
for I := 0 to 25 do
if I in DriveBits then
begin
Drive := Chr(Ord('a') + I);
if GetBusType(Drive) = BusTypeUsb then
List.Add(Drive);
end;
finally
List.EndUpdate;
end;
end;
You can access this information using WMI. If you use this SQL you can access information about installed disks.
select * from Win32_diskdrive where size<>NULL
This code retrive information about drives.
procedure TForm1.DoInventario(aWSQL:string; var mmResult:TMemo);
var
Locator:ISWbemLocator;
Services:ISWbemServices;
SObject:ISWbemObject;
ObjSet:ISWbemObjectSet;
Enum:IEnumVariant;
TempObj:OleVariant;
Value:Cardinal;
TS:TStrings;
begin
try
Locator := CoSWbemLocator.Create();
// Conectar con el Servicio de WMI
Services := Locator.ConnectServer(
STR_LOCALHOST, {ordenador local}
STR_CIM2_ROOT, {root}
STR_EMPTY, STR_EMPTY, {usuario y password -en local no son necesarios-}
STR_EMPTY,STR_EMPTY, 0, nil);
// Acceder a los datos
ObjSet := Services.ExecQuery(aWSQL, 'WQL',
wbemFlagReturnImmediately and wbemFlagForwardOnly , nil);
Enum := (ObjSet._NewEnum) as IEnumVariant;
// Hemos encontrado algun objeto?
while (Enum.Next(1, TempObj, Value) = S_OK) do begin
SObject := IUnknown(TempObj) as ISWBemObject;
// encontrado?
if (SObject <> nil) then begin
// Acceder a la propiedad
SObject.Properties_;
// Cargamos las propiedades
TS := TStringList.Create();
try
TS.Add(SObject.GetObjectText_(0));
// lo pasamos al memo
mmResult.Lines.Text := mmResult.Lines.Text + TS.Text;
finally
FreeAndNil(TS);
end;
end;
end;
except
// Recuperar excepciones
end;
end;
You must add ActiveX and WbemScripting_TLB (this must be imported) in your uses.
With this you can access all information of the disks.
To retrive the letter of all disk you can combine (retrieve can do with the same code) the access to the classes Win32_LogicalDiskToPartition and Win32_DiskDrive.
select * from Win32_LogicalDiskToPartition
select * from Win32_DiskDrive
If you search WMI you can find more related codes.
Regards.
I'm not sure if you're just looking to enumerate drive letters? The for-loop below does that, going through all letters, regardless of whether there's a drive for that letter.
Or, if you're looking for a different way to find removable drives, there's a function for that below, too. (Yours may be better...) Surprisingly, on my test, Windows.GetDriveType does NOT consider CD drives as removable. USB drives are flagged as removable, as one would expect.
Function RemovableDrive(Drive: char): Boolean;
begin
Result := (Windows.GetDriveType(PChar(Drive + ':\')) = Windows.Drive_Removable);
end;
procedure TForm1.Button1Click(Sender: TObject);
var
Drive: Char;
begin
for Drive := 'A' to 'Z' do
Memo1.Lines.Add('Drive: ' + Drive + ' is ' + BoolToStr(RemovableDrive(Drive), TRUE));
end;

Resources