utils/uwinImports.pas

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.