jvfileutil.pas

East make Tray Icon in delphi

var
  Age: Longint;
begin
  Age := FileAge(FileName);
  {$IFDEF MSWINDOWS}
  // [roko] -1 is valid FileAge value on Linux
  if Age = -1 then
    Result := NullDate
  else
  {$ENDIF}
    Result := FileDateToDateTime(Age);
end;

function HasAttr(const FileName: string; Attr: Integer): Boolean;
var
  FileAttr: Integer;
begin
  FileAttr := FileGetAttr(FileName);
  Result := (FileAttr >= 0) and (FileAttr and Attr = Attr);
end;

function DeleteFiles(const FileMask: string): Boolean;
var
  SearchRec: TSearchRec;
begin
  Result := FindFirst(ExpandFileName(FileMask), faAnyFile, SearchRec) = 0;
  try
    if Result then
      repeat
//        if (SearchRec.Name[1] <> '.') and
//      !!! BUG !!!
// (rom) added '..' to complete the fix
        if (SearchRec.Name <> '.') and (SearchRec.Name <> '..') and
          (SearchRec.Attr and faVolumeID <> faVolumeID) and
          (SearchRec.Attr and faDirectory <> faDirectory) then
        begin
          Result := DeleteFile(ExtractFilePath(FileMask) + SearchRec.Name);
          if not Result then
            Break;
        end;
      until FindNext(SearchRec) <> 0;
  finally
    FindClose(SearchRec);
  end;
end;

function DeleteFilesEx(const FileMasks: array of string): Boolean;
var
  I: Integer;
begin
  Result := True;
  for I := Low(FileMasks) to High(FileMasks) do
    Result := Result and DeleteFiles(FileMasks[I]);
end;

function ClearDir(const Path: string; Delete: Boolean): Boolean;
const
  {$IFDEF WIN32}
  FileNotFound = 18;
  {$ELSE}
  FileNotFound = -18;
  {$ENDIF}
var
  FileInfo: TSearchRec;
  DosCode: Integer;
begin
  Result := DirExists(Path);
  if not Result then
    Exit;
  DosCode := FindFirst(NormalDir(Path) + '*.*', faAnyFile, FileInfo);
  try
    while DosCode = 0 do
    begin
//      if (FileInfo.Name[1] <> '.') and (FileInfo.Attr <> faVolumeID) then
//      !!! BUG !!!
      if (FileInfo.Name <> '.') and (FileInfo.Name <> '..') and (FileInfo.Attr <> faVolumeID) then
      begin
        if (FileInfo.Attr and faDirectory) = faDirectory then
          Result := ClearDir(NormalDir(Path) + FileInfo.Name, Delete) and Result
        else
        if (FileInfo.Attr and faVolumeID) <> faVolumeID then
        begin
          if (FileInfo.Attr and faReadOnly) = faReadOnly then
            FileSetAttr(NormalDir(Path) + FileInfo.Name, faArchive);
          Result := DeleteFile(NormalDir(Path) + FileInfo.Name) and Result;
        end;
      end;
      DosCode := FindNext(FileInfo);
    end;
  finally
    FindClose(FileInfo);
  end;
  if Delete and Result and (DosCode = FileNotFound) and
    not ((Length(Path) = 2) and (Path[2] = ':')) then
  begin
    RmDir(Path);
    Result := (IOResult = 0) and Result;
  end;
end;

{$IFDEF WIN32}
function GetTempDir: string;
var
  Buffer: array [0..MAX_PATH] of Char;
begin
  SetString(Result, Buffer, GetTempPath(SizeOf(Buffer), Buffer));
end;
{$ELSE}
function GetTempDir: string;
var
  Buffer: array [0..255] of Char;
begin
  GetTempFileName(GetTempDrive(#0), '$', 1, Buffer);
  Result := ExtractFilePath(StrPas(Buffer));
end;
{$ENDIF}

{$IFDEF WIN32}
function GetWindowsDir: string;
var
  Buffer: array [0..MAX_PATH] of Char;
begin
  SetString(Result, Buffer, GetWindowsDirectory(Buffer, SizeOf(Buffer)));
end;
{$ELSE}
function GetWindowsDir: string;
begin
  Result[0] := Char(GetWindowsDirectory(@Result[1], 254));
end;
{$ENDIF}

{$IFDEF WIN32}
function GetSystemDir: string;
var
  Buffer: array [0..MAX_PATH] of Char;
begin
  SetString(Result, Buffer, GetSystemDirectory(Buffer, SizeOf(Buffer)));
end;
{$ELSE}
function GetSystemDir: string;
begin
  Result[0] := Char(GetSystemDirectory(@Result[1], 254));
end;
{$ENDIF}

{$IFDEF WIN32}

function ValidFileName(const FileName: string): Boolean;

  function HasAny(const Str, Substr: string): Boolean;
  var
    I: Integer;
  begin
    Result := False;
    for I := 1 to Length(Substr) do
    begin
      if Pos(Substr[I], Str) > 0 then
      begin
        Result := True;
        Break;
      end;
    end;
  end;

begin
  Result := (FileName <> '') and (not HasAny(FileName, '/<>"?*|'));
  if Result then
    Result := Pos('\', ExtractFileName(FileName)) = 0;
end;

function FileLock(Handle: Integer; Offset, LockSize: Longint): Integer;
begin
  if LockFile(Handle, Offset, 0, LockSize, 0) then
    Result := 0
  else
    Result := GetLastError;
end;

function FileUnlock(Handle: Integer; Offset, LockSize: Longint): Integer;
begin
  if UnlockFile(Handle, Offset, 0, LockSize, 0) then
    Result := 0
  else
    Result := GetLastError;
end;

{$IFDEF COMPILER4_UP}

function FileLock(Handle: Integer; Offset, LockSize: Int64): Integer;
begin
  if LockFile(Handle, Int64Rec(Offset).Lo, Int64Rec(Offset).Hi,
    Int64Rec(LockSize).Lo, Int64Rec(LockSize).Hi) then
    Result := 0
  else
    Result := GetLastError;
end;

function FileUnlock(Handle: Integer; Offset, LockSize: Int64): Integer;
begin
  if UnlockFile(Handle, Int64Rec(Offset).Lo, Int64Rec(Offset).Hi,
    Int64Rec(LockSize).Lo, Int64Rec(LockSize).Hi) then
    Result := 0
  else
    Result := GetLastError;
end;

{$ENDIF COMPILER4_UP}

{$ELSE}

function ValidFileName(const FileName: string): Boolean;
const
  MaxNameLen = 12; { file name and extension }
  MaxExtLen = 4; { extension with point }
  MaxPathLen = 79; { full file path in DOS }
var
  Dir, Name, Ext: TFileName;

  function HasAny(Str, SubStr: string): Boolean; near; assembler;
  asm
        PUSH     DS
        CLD
        LDS      SI,Str
        LES      DI,SubStr
        INC      DI
        MOV      DX,DI
        XOR      AH,AH
        LODSB
        MOV      BX,AX
        OR       BX,BX
        JZ       @@2
        MOV      AL,ES:[DI-1]
        XCHG     AX,CX
  @@1:  PUSH     CX
        MOV      DI,DX
        LODSB
        REPNE    SCASB
        POP      CX
        JE       @@3
        DEC      BX
        JNZ      @@1
  @@2:  XOR      AL,AL
        JMP      @@4
  @@3:  MOV      AL,1
  @@4:  POP      DS
  end;

begin
  Result := True;
  Dir := Copy(ExtractFilePath(FileName), 1, MaxPathLen);
  Name := Copy(ExtractFileName(FileName), 1, MaxNameLen);
  Ext := Copy(ExtractFileExt(FileName), 1, MaxExtLen);
  if (Dir + Name <> FileName) or HasAny(Name, ';,=+<>|"[] \') or
    HasAny(Copy(Ext, 2, 255), ';,=+<>|"[] \.') then
    Result := False;
end;

function LockFile(Handle: Integer; StartPos, Length: Longint;
  Unlock: Boolean): Integer; assembler;
asm
      PUSH     DS
      MOV      AH,5CH
      MOV      AL,Unlock
      MOV      BX,Handle
      MOV      DX,StartPos.Word[0]
      MOV      CX,StartPos.Word[2]
      MOV      DI,Length.Word[0]
      MOV      SI,Length.Word[2]
      INT      21H
      JNC      @@1
      NEG      AX
      JMP      @@2
@@1:  MOV      AX,0
@@2:  POP      DS
end;

function FileLock(Handle: Integer; Offset, LockSize: Longint): Integer;
begin
  Result := LockFile(Handle, Offset, LockSize, False);
end;

function FileUnlock(Handle: Integer; Offset, LockSize: Longint): Integer;
begin
  Result := LockFile(Handle, Offset, LockSize, True);
end;

{$ENDIF WIN32}

{$IFDEF WIN32}

function ShortToLongFileName(const ShortName: string): string;
var
  Temp: TWin32FindData;
  SearchHandle: THandle;
begin
  SearchHandle := FindFirstFile(PChar(ShortName), Temp);
  if SearchHandle <> INVALID_HANDLE_VALUE then
  begin
    Result := Temp.cFileName;
    if Result = '' then
      Result := Temp.cAlternateFileName;
  end
  else
    Result := '';
  Windows.FindClose(SearchHandle);
end;

function LongToShortFileName(const LongName: string): string;
var
  Temp: TWin32FindData;
  SearchHandle: THandle;
begin
  SearchHandle := FindFirstFile(PChar(LongName), Temp);
  if SearchHandle <> INVALID_HANDLE_VALUE then
  begin
    Result := Temp.cAlternateFileName;
    if Result = '' then
      Result := Temp.cFileName;
  end
  else
    Result := '';
  Windows.FindClose(SearchHandle);
end;

function ShortToLongPath(const ShortName: string): string;
var
  LastSlash: PChar;
  TempPathPtr: PChar;
begin
  Result := '';
  TempPathPtr := PChar(ShortName);
  LastSlash := StrRScan(TempPathPtr, '\');
  while LastSlash <> nil do
  begin
    Result := '\' + ShortToLongFileName(TempPathPtr) + Result;
    if LastSlash <> nil then
    begin
      LastSlash^ := char(0);
      LastSlash := StrRScan(TempPathPtr, '\');
    end;
  end;
  Result := TempPathPtr + Result;
end;

function LongToShortPath(const LongName: string): string;
var
  LastSlash: PChar;
  TempPathPtr: PChar;
begin
  Result := '';
  TempPathPtr := PChar(LongName);
  LastSlash := StrRScan(TempPathPtr, '\');
  while LastSlash <> nil do
  begin
    Result := '\' + LongToShortFileName(TempPathPtr) + Result;
    if LastSlash <> nil then
    begin
      LastSlash^ := Char(0);
      LastSlash := StrRScan(TempPathPtr, '\');
    end;
  end;
  Result := TempPathPtr + Result;
end;

const
  IID_IPersistFile: TGUID =
    (D1: $0000010B; D2: $0000; D3: $0000; D4: ($C0, $00, $00, $00, $00, $00, $00, $46));

{$IFNDEF COMPILER3_UP}

const
  IID_IShellLinkA: TGUID =
    (D1: $000214EE; D2: $0000; D3: $0000; D4: ($C0, $00, $00, $00, $00, $00, $00, $46));
  CLSID_ShellLink: TGUID =
    (D1: $00021401; D2: $0000; D3: $0000; D4: ($C0, $00, $00, $00, $00, $00, $00, $46));

type
  IShellLink = class(IUnknown) { sl }
    function GetPath(pszFile: LPSTR; cchMaxPath: Integer;
      var pfd: TWin32FindData; fFlags: DWORD): HResult; virtual; stdcall; abstract;
    function GetIDList(var ppidl: PItemIDList): HResult; virtual; stdcall; abstract;
    function SetIDList(pidl: PItemIDList): HResult; virtual; stdcall; abstract;
    function GetDescription(pszName: LPSTR; cchMaxName: Integer): HResult; virtual; stdcall; abstract;
    function SetDescription(pszName: LPSTR): HResult; virtual; stdcall; abstract;
    function GetWorkingDirectory(pszDir: LPSTR; cchMaxPath: Integer): HResult; virtual; stdcall; abstract;
    function SetWorkingDirectory(pszDir: LPSTR): HResult; virtual; stdcall; abstract;
    function GetArguments(pszArgs: LPSTR; cchMaxPath: Integer): HResult; virtual; stdcall; abstract;
    function SetArguments(pszArgs: LPSTR): HResult; virtual; stdcall; abstract;
    function GetHotkey(var pwHotkey: Word): HResult; virtual; stdcall; abstract;
    function SetHotkey(wHotkey: Word): HResult; virtual; stdcall; abstract;
    function GetShowCmd(var piShowCmd: Integer): HResult; virtual; stdcall; abstract;
    function SetShowCmd(iShowCmd: Integer): HResult; virtual; stdcall; abstract;
    function GetIconLocation(pszIconPath: LPSTR; cchIconPath: Integer;
      var piIcon: Integer): HResult; virtual; stdcall; abstract;
    function SetIconLocation(pszIconPath: LPSTR; iIcon: Integer): HResult; virtual; stdcall; abstract;
    function SetRelativePath(pszPathRel: LPSTR; dwReserved: DWORD): HResult; virtual; stdcall; abstract;
    function Resolve(Wnd: HWND; fFlags: DWORD): HResult; virtual; stdcall; abstract;
    function SetPath(pszFile: LPSTR): HResult; virtual; stdcall; abstract;
  end;

{$ENDIF}

const
  LinkExt = '.lnk';

procedure CreateFileLink(const FileName, DisplayName: string; Folder: Integer);
var
  ShellLink: IShellLink;
  PersistFile: IPersistFile;
  ItemIDList: PItemIDList;
  FileDestPath: array [0..MAX_PATH] of Char;
  FileNameW: array [0..MAX_PATH] of WideChar;
begin
  CoInitialize(nil);
  try
    OleCheck(CoCreateInstance(CLSID_ShellLink, nil, CLSCTX_SERVER,
      IID_IShellLinkA, ShellLink));
    try
      OleCheck(ShellLink.QueryInterface(IID_IPersistFile, PersistFile));
      try
        OleCheck(SHGetSpecialFolderLocation(0, Folder, ItemIDList));
        SHGetPathFromIDList(ItemIDList, FileDestPath);
        StrCat(FileDestPath, PChar('\' + DisplayName + LinkExt));
        ShellLink.SetPath(PChar(FileName));
        ShellLink.SetIconLocation(PChar(FileName), 0);
        MultiByteToWideChar(CP_ACP, 0, FileDestPath, -1, FileNameW, MAX_PATH);
        OleCheck(PersistFile.Save(FileNameW, True));
      finally
        {$IFDEF COMPILER3_UP}
        PersistFile := nil;
        {$ELSE}
        PersistFile.Release;
        {$ENDIF}
      end;
    finally
      {$IFDEF COMPILER3_UP}
      ShellLink := nil;
      {$ELSE}
      ShellLink.Release;
      {$ENDIF}
    end;
  finally
    CoUninitialize;
  end;
end;

procedure DeleteFileLink(const DisplayName: string; Folder: Integer);
var
  ShellLink: IShellLink;
  ItemIDList: PItemIDList;
  FileDestPath: array [0..MAX_PATH] of Char;
begin
  CoInitialize(nil);
  try
    OleCheck(CoCreateInstance(CLSID_ShellLink, nil, CLSCTX_SERVER,
      IID_IShellLinkA, ShellLink));
    try
      OleCheck(SHGetSpecialFolderLocation(0, Folder, ItemIDList));
      SHGetPathFromIDList(ItemIDList, FileDestPath);
      StrCat(FileDestPath, PChar('\' + DisplayName + LinkExt));
      DeleteFile(FileDestPath);
    finally
      {$IFDEF COMPILER3_UP}
      ShellLink := nil;
      {$ELSE}
      ShellLink.Release;
      {$ENDIF}
    end;
  finally
    CoUninitialize;
  end;
end;

{$ENDIF WIN32}

{$IFNDEF COMPILER3_UP}
function IsPathDelimiter(const S: string; Index: Integer): Boolean;
begin
  Result := (Index > 0) and (Index <= Length(S)) and (S[Index] = '\');
end;
{$ENDIF}

end.