Browse Source

uwinImports: Windows-specific imports and utils

master
Martok 7 years ago
parent
commit
f67480ede3
3 changed files with 263 additions and 2 deletions
  1. +5
    -1
      bitSpaceUtils.lpk
  2. +1
    -1
      bitSpaceUtils.pas
  3. +257
    -0
      uwinImports.pas

+ 5
- 1
bitSpaceUtils.lpk View File

@@ -11,7 +11,7 @@
<UnitOutputDirectory Value="lib\$(TargetCPU)-$(TargetOS)"/>
</SearchPaths>
</CompilerOptions>
<Files Count="31">
<Files Count="32">
<Item1>
<Filename Value="uutlAlgorithm.pas"/>
<UnitName Value="uutlAlgorithm"/>
@@ -136,6 +136,10 @@
<Filename Value="uutlCommandLine.pas"/>
<UnitName Value="uutlCommandLine"/>
</Item31>
<Item32>
<Filename Value="uwinImports.pas"/>
<UnitName Value="uwinImports"/>
</Item32>
</Files>
<RequiredPkgs Count="2">
<Item1>


+ 1
- 1
bitSpaceUtils.pas View File

@@ -12,7 +12,7 @@ uses
uutlEvent, uutlEventManager, uutlFilter, uutlGenerics, uutlInterfaces, uutlKeyCodes, uutlLinq, uutlListBase,
uutlLogger, uutlMCF, uutlObservable, uutlSScanf, uutlStreamHelper, uutlSyncObjs, uutlThreads, uutlTypes,
uutlXmlHelper, uutlVariantObject, uutlVariantProperty, uutlVariantEnum, uutlVariantSet, uutlCommandLine,
LazarusPackageIntf;
uwinImports, LazarusPackageIntf;

implementation



+ 257
- 0
uwinImports.pas View File

@@ -0,0 +1,257 @@
unit uwinImports;

{$mode objfpc}{$H+}

{
Accepts the following defines (pass to package in project's Additions and Overrides):

UTL_WINSUPP_NT50 => Code should work/compile/start on NT5.0 (Windows 2000)
}


interface

uses
Classes, SysUtils, windows, activex, shlobj;

const
shell32 = 'shell32.dll';


{%REGION Filesystem }

//function GetVolumePathNameA(lpszFileName: LPCSTR; lpszVolumePathName: LPSTR; cchBufferLength: DWORD): BOOL; stdcall; external kernel32 name 'GetVolumePathNameA';
//function GetVolumePathNameW(lpszFileName: LPCWSTR; lpszVolumePathName: LPWSTR; cchBufferLength: DWORD): BOOL; stdcall; external kernel32 name 'GetVolumePathNameW';
function GetVolumePathName(lpszFileName: LPCTSTR; lpszVolumePathName: LPTSTR; cchBufferLength: DWORD): BOOL; stdcall; external kernel32 name 'GetVolumePathNameA';

{%ENDREGION}

{%REGION IOCTL }
const
FILE_DEVICE_DISK = $00000007;
FILE_DEVICE_MASS_STORAGE = $0000002D;

METHOD_BUFFERED = 0;

FILE_ANY_ACCESS = 0;
FILE_SPECIAL_ACCESS = FILE_ANY_ACCESS;
FILE_READ_ACCESS = $0001;
FILE_WRITE_ACCESS = $0002;
FILE_RW_ACCESS = FILE_READ_ACCESS or FILE_WRITE_ACCESS;

IOCTL_DISK_BASE = FILE_DEVICE_DISK;
IOCTL_DISK_GET_DRIVE_GEOMETRY = ((IOCTL_DISK_BASE shl 16) or (FILE_ANY_ACCESS shl 14) or ($0000 shl 2) or METHOD_BUFFERED);
IOCTL_DISK_FORMAT_TRACKS = ((IOCTL_DISK_BASE shl 16) or (FILE_RW_ACCESS shl 14) or ($0006 shl 2) or METHOD_BUFFERED);
IOCTL_DISK_GET_LENGTH_INFO = ((IOCTL_DISK_BASE shl 16) or (FILE_READ_ACCESS shl 14) or ($0017 shl 2) or METHOD_BUFFERED);
IOCTL_DISK_GET_MEDIA_TYPES = ((IOCTL_DISK_BASE shl 16) or (FILE_ANY_ACCESS shl 14) or ($0300 shl 2) or METHOD_BUFFERED);


IOCTL_STORAGE_BASE = FILE_DEVICE_MASS_STORAGE;
IOCTL_STORAGE_CHECK_VERIFY = ((IOCTL_STORAGE_BASE shl 16) or (FILE_READ_ACCESS shl 14) or ($0200 shl 2) or METHOD_BUFFERED);
IOCTL_STORAGE_CHECK_VERIFY2 = ((IOCTL_STORAGE_BASE shl 16) or (FILE_ANY_ACCESS shl 14) or ($0200 shl 2) or METHOD_BUFFERED);
IOCTL_STORAGE_MEDIA_REMOVAL = ((IOCTL_STORAGE_BASE shl 16) or (FILE_READ_ACCESS shl 14) or ($0201 shl 2) or METHOD_BUFFERED);
IOCTL_STORAGE_EJECT_MEDIA = ((IOCTL_STORAGE_BASE shl 16) or (FILE_READ_ACCESS shl 14) or ($0202 shl 2) or METHOD_BUFFERED);
IOCTL_STORAGE_LOAD_MEDIA = ((IOCTL_STORAGE_BASE shl 16) or (FILE_READ_ACCESS shl 14) or ($0203 shl 2) or METHOD_BUFFERED);
IOCTL_STORAGE_LOAD_MEDIA2 = ((IOCTL_STORAGE_BASE shl 16) or (FILE_ANY_ACCESS shl 14) or ($0203 shl 2) or METHOD_BUFFERED);
IOCTL_STORAGE_RESERVE = ((IOCTL_STORAGE_BASE shl 16) or (FILE_READ_ACCESS shl 14) or ($0204 shl 2) or METHOD_BUFFERED);
IOCTL_STORAGE_RELEASE = ((IOCTL_STORAGE_BASE shl 16) or (FILE_READ_ACCESS shl 14) or ($0205 shl 2) or METHOD_BUFFERED);
IOCTL_STORAGE_FIND_NEW_DEVICES = ((IOCTL_STORAGE_BASE shl 16) or (FILE_READ_ACCESS shl 14) or ($0206 shl 2) or METHOD_BUFFERED);
IOCTL_STORAGE_EJECTION_CONTROL = ((IOCTL_STORAGE_BASE shl 16) or (FILE_ANY_ACCESS shl 14) or ($0250 shl 2) or METHOD_BUFFERED);
IOCTL_STORAGE_MCN_CONTROL = ((IOCTL_STORAGE_BASE shl 16) or (FILE_ANY_ACCESS shl 14) or ($0251 shl 2) or METHOD_BUFFERED);

IOCTL_STORAGE_GET_MEDIA_TYPES = ((IOCTL_STORAGE_BASE shl 16) or (FILE_ANY_ACCESS shl 14) or ($0300 shl 2) or METHOD_BUFFERED);
IOCTL_STORAGE_GET_MEDIA_TYPES_EX = ((IOCTL_STORAGE_BASE shl 16) or (FILE_ANY_ACCESS shl 14) or ($0301 shl 2) or METHOD_BUFFERED);
IOCTL_STORAGE_GET_MEDIA_SERIAL_NUMBER= ((IOCTL_STORAGE_BASE shl 16) or (FILE_ANY_ACCESS shl 14) or ($0304 shl 2) or METHOD_BUFFERED);
IOCTL_STORAGE_GET_HOTPLUG_INFO = ((IOCTL_STORAGE_BASE shl 16) or (FILE_ANY_ACCESS shl 14) or ($0305 shl 2) or METHOD_BUFFERED);
IOCTL_STORAGE_SET_HOTPLUG_INFO = ((IOCTL_STORAGE_BASE shl 16) or (FILE_RW_ACCESS shl 14) or ($0306 shl 2) or METHOD_BUFFERED);

IOCTL_STORAGE_RESET_BUS = ((IOCTL_STORAGE_BASE shl 16) or (FILE_READ_ACCESS shl 14) or ($0400 shl 2) or METHOD_BUFFERED);
IOCTL_STORAGE_RESET_DEVICE = ((IOCTL_STORAGE_BASE shl 16) or (FILE_READ_ACCESS shl 14) or ($0401 shl 2) or METHOD_BUFFERED);
IOCTL_STORAGE_BREAK_RESERVATION = ((IOCTL_STORAGE_BASE shl 16) or (FILE_READ_ACCESS shl 14) or ($0405 shl 2) or METHOD_BUFFERED);

IOCTL_STORAGE_GET_DEVICE_NUMBER = ((IOCTL_STORAGE_BASE shl 16) or (FILE_ANY_ACCESS shl 14) or ($0420 shl 2) or METHOD_BUFFERED);

IOCTL_STORAGE_PREDICT_FAILURE = ((IOCTL_STORAGE_BASE shl 16) or (FILE_ANY_ACCESS shl 14) or ($0440 shl 2) or METHOD_BUFFERED);

{%ENDREGION}


{%REGION ShellAPI }
{$if FPC_FULLVERSION < 030101}
// only needed in versions where 0029036 is not fixed (before r32452)
type LPPCITEMIDLIST = ^LPCITEMIDLIST;
function SHOpenFolderAndSelectItems(pidlFolder:LPCITEMIDLIST;cidl:UINT; apidl: LPPCITEMIDLIST; dwflags: DWORD):HResult;StdCall; external shell32 name 'SHOpenFolderAndSelectItems';

{$ifend}

// FIXME: temporary until 0028760 is fixed in FPC
function SHBindToParent2(pidl:LPCITEMIDLIST; constref riid:TREFIID; var ppv:Pointer; var ppidlLast:LPCITEMIDLIST):HRESULT;StdCall;external External_library name 'SHBindToParent';

{%ENDREGION}

{%REGION Helper - Filesystem }
function GetVolumePathName(const aFileName: string): string;
function GetVolumeSpace(const aDisk: string; out Total, Free: QWord): Boolean;
function GetVolumeSizeIoCtl(const aDisk: string; out Total: QWord): Boolean;
function GetDiskGeometry(hDisk: THandle; var Geometry: DISK_GEOMETRY): Boolean;
function GetDriveGeometry(DriveLetter: char; var Geometry: DISK_GEOMETRY): Boolean;
function GetVolumeInformation(const aDisk: string; out DriveLabel, Filesystem: string): boolean;
function GetFileCompressedSize(const aFileName: string; out FSize: QWord): Boolean;
function GetFileIndex(const aFilename: string; out FIndex: QWORD): boolean;
{%ENDREGION}

{%REGION Helpr - ShellAPI }
function GetConfigLocation(const aPortable, aRoaming: boolean; aProgramSubdir: String): string;

function OpenFolderAndSelectFile(const FileName: string): boolean;
{%ENDREGION}

implementation

uses
windirs;

function GetVolumePathName(const aFileName: string): string;
begin
SetLength(Result, MAX_PATH + 2);
if not uwinImports.GetVolumePathName(LPCTSTR(aFileName), LPCTSTR(Result),MAX_PATH) then
exit;
SetLength(Result, strlen(PChar(Result)));
end;

function GetVolumeSpace(const aDisk: string; out Total, Free: QWord): Boolean;
var
freequota: QWord;
begin
Result:= GetDiskFreeSpaceEx(PChar(aDisk), @freequota, @Total,@Free);
end;

function GetVolumeSizeIoCtl(const aDisk: string; out Total: QWord): Boolean;
var
dn: string;
fh: THANDLE;
gio: GET_LENGTH_INFORMATION;
ret: dword;
begin
Result:= false;
dn:= '\\.\'+ExcludeTrailingPathDelimiter(aDisk);
fh:= CreateFile(PChar(dn), GENERIC_READ, FILE_SHARE_READ or FILE_SHARE_WRITE, nil, OPEN_EXISTING, 0, 0);
if fh = INVALID_HANDLE_VALUE then
exit;
try
if DeviceIoControl(fh, IOCTL_DISK_GET_LENGTH_INFO, nil, 0, @gio, sizeof(gio), @ret, nil) then begin
Total:= gio.Length.QuadPart;
Result:= true;
end;
finally
CloseHandle(fh);
end;
end;

////////////////////////////////////////////////////////////////////////////////
// Comment : gets the geometry of the disk
// Arguments : hDisk: THandle; var Geometry: DISK_GEOMETRY
// Result : Boolean

function GetDiskGeometry(hDisk: THandle; var Geometry: DISK_GEOMETRY): Boolean;
var
ReturnedBytesCount: DWORD;
begin
result := DeviceIoControl(hDisk, IOCTL_DISK_GET_DRIVE_GEOMETRY, nil, 0, @Geometry, sizeof(Geometry), ReturnedBytesCount, nil);
end;

function GetDriveGeometry(DriveLetter: char; var Geometry: DISK_GEOMETRY): Boolean;
var
SrcDrive : string;
hDrive : THandle;
begin
Result:= false;
SrcDrive := '\\.\' + DriveLetter + ':';
// open floppy drive
hDrive := CreateFile(@SrcDrive[1], GENERIC_READ or GENERIC_WRITE, FILE_SHARE_READ or FILE_SHARE_WRITE , nil, OPEN_EXISTING, 0, 0);
if hDrive <> INVALID_HANDLE_VALUE then try
Result:= GetDiskGeometry(hDrive, Geometry);
finally
CloseHandle(hDrive);
end;
end;

function GetVolumeInformation(const aDisk: string; out DriveLabel, Filesystem: string): boolean;
var
dn, fs: array[0..MAX_PATH] of Char;
begin
ZeroMemory(@dn[0], Length(dn));
ZeroMemory(@fs[0], Length(fs));
Result:= Windows.GetVolumeInformation(PChar(aDisk), @dn[0], High(dn), nil, nil, nil, @fs[0], high(fs));
if Result then begin
DriveLabel:= StrPas(dn);
Filesystem:= StrPas(fs);
end;
end;

function GetFileCompressedSize(const aFileName: string; out FSize: QWord): Boolean;
var
li: LARGE_INTEGER;
begin
SetLastError(0);
li.LowPart:= GetCompressedFileSize(LPCSTR(aFileName), @li.HighPart);
Result:= GetLastError = NOERROR;
if Result then
FSize:= li.QuadPart;
end;

function GetFileIndex(const aFilename: string; out FIndex: QWORD): boolean;
var
fh: THANDLE;
bhfi: TBYHANDLEFILEINFORMATION;
fi: LARGE_INTEGER;
begin
Result:= false;
fh:= FileOpen(aFilename, fmOpenRead or fmShareDenyNone);
if fh <> feInvalidHandle then begin
if GetFileInformationByHandle(fh, bhfi) then begin
fi.LowPart:= bhfi.nFileIndexLow;
fi.HighPart:= bhfi.nFileIndexHigh;
FIndex:= fi.QuadPart;
Result:= true;
end;
FileClose(fh);
end;
end;

function GetConfigLocation(const aPortable, aRoaming: boolean; aProgramSubdir: String): string;
begin
if aPortable then
Result:= ExtractFilePath(ParamStr(0))
else begin
if aRoaming then
Result:= IncludeTrailingPathDelimiter(GetWindowsSpecialDir(CSIDL_APPDATA))
else
Result:= IncludeTrailingPathDelimiter(GetWindowsSpecialDir(CSIDL_LOCAL_APPDATA));
if aProgramSubdir > '' then
Result += aProgramSubdir + PathDelim;
end;
end;

function OpenFolderAndSelectFile(const FileName: string): boolean;
{$IFNDEF UTL_WINSUPP_NT50}
var
IIDL: PItemIDList;
begin
result := false;
IIDL := ILCreateFromPath(PChar(FileName));
if IIDL <> nil then
try
result := SHOpenFolderAndSelectItems(IIDL, 0, LPPCITEMIDLIST(nil), 0) = S_OK;
finally
ILFree(IIDL);
end;
{$ELSE}
begin
ShellExecute(0, 'explore', PChar(ExtractFilePath(FileName)), nil, nil, SW_SHOWNORMAL);
{$ENDIF}
end;


end.


Loading…
Cancel
Save