dcutils.pas

DiskControls.v3.8.Full.Source 控制磁盘的控件 包括源代码

{*******************************************************************************

  Disk Controls pack v3.5
  FILE: dcUtils.pas - bonus routines for many purposes

  Copyright (c) 1999-2002 UtilMind Solutions
  All rights reserved.
  E-Mail: [e-mail], [e-mail]
  WWW: http://www.appcontrols.com, http://www.utilmind.com

  The entire contents of this file is protected by International Copyright
Laws. Unauthorized reproduction, reverse-engineering, and distribution of all
or any portion of the code contained in this file is strictly prohibited and
may result in severe civil and criminal penalties and will be prosecuted to
the maximum extent possible under the law.

*******************************************************************************}
{$I umDefines.inc}

unit dcUtils;

interface

uses Windows, Classes, Graphics;

const
  C_ROOT_DIR  = 'C:\';
  AST_DOT_AST = '*.*';

{ string routines }
{ STRING / FILENAME ROUTINES (check out Disk(App)Controls.hlp for reference) }
type
  TdcSplitStrSide = (LEFT, RIGHT);
  TdcSplitStrSides = set of TdcSplitStrSide;
procedure SplitStr(const SubStr, Str: String;
            var FirstPart, SecondPart: String;
            MainSide: TdcSplitStrSide;
            LeaveSeparatorOn: TdcSplitStrSides);
{$IFNDEF D5}
function  IncludeTrailingBackslash(const St: String): String;
function  ExcludeTrailingBackslash(const St: String): String;
{$ENDIF}
procedure SplitFileNameAndParams(var FileName, Params: String); { splits filename and params }
function  GetPureFileName(const FileName: String): String; { removes all params }
function  GetCorrectFileName(const FileName: String): String; { if file not found - trying to find it in \WINDOWS and \WINDOWS|SYSTEM directories }
function  GetCorrectDirName(const DirName: String): String;
procedure SplitSemicolons(St: String; StrList: TStringList);
procedure GetShell32Icons(IconIndex: Integer; var LargeIcon, SmallIcon: TIcon);
procedure GetDefaultIcons(var LargeIcon, SmallIcon: TIcon);

{ shell utilities routines }
function  GetSystemImageList(Size: Integer): THandle; // Size can be only 16 (16x16) or 32 (32x32)
procedure RunControlPanel(CmdShow: UINT);
procedure RunCPL(const FileName: String; CmdShow: UINT);
function  OpenWithDlg(const FileName: String): Boolean; // returns True if succeed
procedure RepaintScreen;

{ file routines }
function DirectoryExists(const Name: String): Boolean;
function ObjectExists(const Name: String): Boolean;
function IsEqualFileTime(T1, T2: TFileTime): Boolean;
{$IFNDEF D6}
procedure ForceDirectories(Dir: String);
{$ENDIF}
function IsUNCPath(const Path: String): Boolean;

{ Numerical Convertison routines}
{ converts the 32bit Integer to unisgned Extended (float) type }
function IntToExt(Int: DWord): Extended;
{ converts the two 32bit Integer to unisgned Extended (float) type }
function Int2x32ToExt(IntHi, IntLo: DWord): Extended;
{$IFDEF D4}
function Int2x32ToInt64(IntHi, IntLo: DWord): Int64;
{$ENDIF}
function UTCFileTimeToDateTime(Time: TFileTime): TDateTime;
function DateTimeToUTCFileTime(Time: TDateTime): TFileTime;
{ converts datetime value without exception }
function StrToDateTimeDef(const S: String; DefDateTime: TDateTime): TDateTime;


{ miscellaneous }
type
  TdcOSVersion = (osUnknown, os95, os95OSR2, os98, os98SE, osNT3, osNT4, os2K, osME);
  
function GetOS: TdcOSVersion;
function GetOSStr: String;
{ True when the Windows NT/2000 and False when 95/98/ME}
function IsNT: Boolean;
{ True when Windows XP or higher }
function IsXP: Boolean;
{ returns path to System directory }
function GetSystemDir: String;
{ returns path to Windows directory }
function GetWindowsDir: String;
{ returns path to Temporary directory }
function GetTempDir: String;
{ Returns file version for EXE/DLLs }
function GetFileVersion(FileName: String): DWord;

{ graphics }
function IsPictureNotEmpty(const Picture: TPicture): Boolean;
function GetTextHeight(const Canvas: TCanvas): Integer;

implementation

uses Consts, SysUtils, ShellAPI, CommCtrl;

{$IFNDEF D4}
var
  TwoDigitYearCenturyWindow: Word = 50;
{$IFNDEF D3}
  LeadBytes: set of Char = [];

type
  PDayTable = ^TDayTable;
  TDayTable = Array[1..12] of Word;

const
  MonthDays: Array[Boolean] of TDayTable =
    ((31, 28, 31, 30, 31, 30, 31, 31, 30, 31, 30, 31),
     (31, 29, 31, 30, 31, 30, 31, 31, 30, 31, 30, 31));
     
  SCannotCreateDir = 'Unable to create directory';     
{$ENDIF}
{$ENDIF}

{$IFNDEF D3}
function AnsiLastChar(const S: string): PChar;
var
  LastByte: Integer;
begin
  LastByte := Length(S);
  if LastByte <> 0 then
    Result := @S[LastByte]
  else
    Result := nil;
end;

function IsLeapYear(const AYear: Integer): Boolean;
begin
  Result := (AYear mod 4 = 0) and ((AYear mod 100 <> 0) or (AYear mod 400 = 0));
end;
{$ENDIF}

{$IFNDEF D5}
function IncludeTrailingBackslash(const St: String): String;
begin
 if (St = '') or (St[Length(St)] <> '\') then
   Result := St + '\'
 else
   Result := St;
end;

function ExcludeTrailingBackslash(const St: String): String;
begin
  Result := St;
  while (Result <> '') and (Result[Length(Result)] = '\') do
   SetLength(Result, Length(Result) - 1);
end;
{$ENDIF}

procedure SplitStr(const SubStr, Str: String;
            var FirstPart, SecondPart: String;
            MainSide: TdcSplitStrSide;
            LeaveSeparatorOn: TdcSplitStrSides);
var
  I: Integer;
begin
  I := Pos(SubStr, Str);
  if I <> 0 then
   begin
    FirstPart := Str;
    SetLength(FirstPart, I - 1);
    inc(I, Length(SubStr));
    SecondPart := Copy(Str, I, Length(Str) - I + Length(SubStr) + 1);

    if LEFT in LeaveSeparatorOn then
      FirstPart := FirstPart + SubStr;

    if RIGHT in LeaveSeparatorOn then
      SecondPart := SubStr + SecondPart;
   end
  else { if SubStr not found }
   if MainSide = LEFT then
    begin
     FirstPart := Str;
     SecondPart := '';
    end
   else
    begin
     FirstPart := '';
     SecondPart := Str;
    end;
end;

{ splits filename and params }
procedure SplitFilenameAndParams(var FileName, Params: String);
var
  OriginalFileName,
  tmpFileName, tmpParams, StName: String;
  PosStart, PosEnd: Integer;

  procedure CheckExtension;
  begin
    if (ExtractFileExt(FileName) <> '') and 
       (ExtractFileExt(tmpFileName) = '') then
     begin
      tmpFileName := FileName;
      tmpParams := Params;
     end
    else
     begin
      FileName := tmpFileName;
      Params := tmpParams;
     end;
  end;

begin
  FileName := Trim(FileName);
  if FileName = '' then Exit;

  PosStart := Pos('"', FileName);
  if PosStart <> 0 then
    Delete(FileName, PosStart, 1);
  PosEnd := Pos('"', FileName);
  if (PosStart <> 0) and (PosEnd <> 0) then
   begin
    Delete(FileName, PosEnd, 1);

    if PosStart = 1 then
     begin
      Params := Copy(FileName, PosEnd + 1, Length(FileName) - PosEnd);
      Delete(FileName, PosEnd, Length(FileName) - PosEnd + 1);

      { delete all the left quotes }
      Params := Trim(Params);
      PosStart := Pos('"', Params);
      if PosStart <> 0 then
       begin
        Delete(Params, PosStart, 1);
        PosEnd := Pos('"', Params);
        if PosEnd <> 0 then
          Delete(Params, PosEnd, 1);
        end;
     end
    else
     begin
      Params := Copy(FileName, PosStart, Length(FileName) - PosStart + 1);
      Delete(FileName, PosStart - 1, Length(FileName) - PosStart + 2);
     end;
   end
  else { if no quotes ('"') in the string then
         splitting the string by space character }
   begin
    Params := '';
    tmpParams := '';
    OriginalFileName := FileName;

    SplitStr(' -', FileName, tmpFileName, tmpParams, LEFT, [RIGHT]);
    CheckExtension;
    if Params = '' then
      SplitStr(' /', FileName, tmpFileName, tmpParams, LEFT, [RIGHT]);
    CheckExtension;
    if tmpParams = '' then
      SplitStr(' \', FileName, tmpFileName, tmpParams, LEFT, [RIGHT]);
    CheckExtension;
    if tmpParams = '' then
      SplitStr(',', FileName, tmpFileName, tmpParams, LEFT, []);
    CheckExtension;
    if tmpParams = '' then
      SplitStr(' %', FileName, tmpFileName, tmpParams, LEFT, [RIGHT]);
    CheckExtension;

   if (UpperCase(ExtractFileExt(FileName)) = '.DLL') and
      (Pos('RUNDLL', UpperCase(FileName)) <> 0) then
    begin
     SplitStr(' ', ExtractFileName(OriginalFileName), StName, Params, LEFT, []);
     FileName := ExtractFilePath(OriginalFileName) + StName;
    end
   end;

  FileName := Trim(FileName);
  Params := Trim(Params);
end;

{ removes all params }
function GetPureFileName(const FileName: String): String;
var
  Params: String;
begin
  Result := FileName;
  SplitFileNameAndParams(Result, Params);
end;

{ if file not found - trying to find it in \WINDOWS and \WINDOWS|SYSTEM directories }
function GetCorrectFileName(const FileName: String): String;
label SecondTry;
begin
  Result := GetPureFileName(FileName);
  if (ExtractFilePath(Result) = '') and
     not FileExists(Result) then
   begin
    SecondTry:
    { trying to find program in WINDOWS\SYSTEM directory }
    if FileExists(GetSystemDir + Result) then
      Result := GetSystemDir + Result
    else
      { trying to find program in \WINDOWS directory }
      if FileExists(GetWindowsDir + Result) then
         Result := GetWindowsDir + Result
       else
        { trying to add .exe extension }
        if ExtractFileExt(Result) = '' then
         begin
          Result := Result + '.exe';
          goto SecondTry;
         end
        else
         Result := GetPureFileName(FileName);
   end;
end;

function GetCorrectDirName(const DirName: String): String;
var
  Ch: Char;
  St: String;
begin
  Result := DirName;
  { from current directory}
  if Length(Result) = 0 then
    Result := GetCurrentDir
  else
   if not IsUNCPath(Result) then
    // path without disk
    if Result[1] = '\' then
     begin
      GetDir(0, St);
      Result := St[1] + ':' + Result;
     end
    else
     // disk without path
     if (Length(Result) = 2) and (Result[2] = ':') then
      begin
       Ch := UpCase(Result[1]);
       if (Ch >= 'A') and (Ch <= 'Z') then
         GetDir(Byte(Ch) - 64{'A'}, Result);
      end;

  Result := IncludeTrailingBackslash(Result);
end;

procedure SplitSemicolons(St: String; StrList: TStringList);
label DontAdd;
var
  tmpStr: String;
  I, J: Integer;
begin
  if not Assigned(StrList) then Exit;
  StrList.Clear;

  repeat
    I := Pos(';', St);
    if I = 0 then J := Length(St)
    else J := I - 1;

    tmpStr := Copy(St, 1, J);
    Delete(St, 1, J + 1);

    { we shouln't add line if this already exists }
    J := StrList.Count;
    if J <> 0 then
     for J := 0 to J - 1 do
      if tmpStr = StrList[J] then goto DontAdd;
      
    StrList.Add(tmpStr);
    DontAdd:
  until I = 0;
end;

procedure GetShell32Icons(IconIndex: Integer; var LargeIcon, SmallIcon: TIcon);
var
  LIcon, SIcon: hIcon;
begin
  ExtractIconEx(PChar(GetSystemDir + 'SHELL32.DLL'), IconIndex, LIcon, SIcon, 1);
  LargeIcon.Handle := LIcon;
  SmallIcon.Handle := SIcon;
end;

procedure GetDefaultIcons(var LargeIcon, SmallIcon: TIcon);
begin
  GetShell32Icons(0, LargeIcon, SmallIcon);
end;


{ file routines }
function DirectoryExists(const Name: String): Boolean;
var
  Code: Integer;
begin
  Code := GetFileAttributes(PChar(Name));
  Result := (Code <> -1) and (FILE_ATTRIBUTE_DIRECTORY and Code <> 0);
end;

function ObjectExists(const Name: String): Boolean;
var
  Handle: THandle;
  Data: TWin32FindData;  
begin
  Handle := FindFirstFile(PChar(Name), Data);
  if Handle <> INVALID_HANDLE_VALUE then
   begin
    Windows.FindClose(Handle);
    Result := True;
   end
  else Result := False;
end;

function IsEqualFileTime(T1, T2: TFileTime): Boolean;
begin
  if (T1.dwLowDateTime = T2.dwLowDateTime) and (T1.dwHighDateTime = T2.dwHighDateTime) then
    Result := True
  else
    Result := False;
end;

{$IFNDEF D6}
procedure ForceDirectories(Dir: String);
begin
  if Length(Dir) = 0 then
    raise Exception.Create(SCannotCreateDir);
  if (AnsiLastChar(Dir) <> nil) and (AnsiLastChar(Dir)^ = '\') then
    Delete(Dir, Length(Dir), 1);
  if (Length(Dir) < 3) or DirectoryExists(Dir)
    or (ExtractFilePath(Dir) = Dir) then Exit; // avoid 'xyz:\' problem.
  ForceDirectories(ExtractFilePath(Dir));
  CreateDir(Dir);
end;
{$ENDIF}

function IsUNCPath(const Path: String): Boolean;
begin
  Result := Pos('\\?\', Path) = 1;
end;


{ shell utilities routines }
var
  OverlaysAdded: Boolean = False;

function  GetSystemImageList(Size: Integer): THandle;
const
  COMCTL32_V472 = (4 shl 16) or 72;
var
  Flag: DWord;
  ShInfo: TSHFileInfo;

  procedure AddOverlays;
  const
    SIC_SHARING_HAND = 29;
    SIC_SHORTCUT = 30;

    LR_SHARED = $8000;
  var
    h16, h32: THandle;
    hIcon: THandle;
    hShell32: THandle;
  begin
    hShell32 := Windows.LoadLibrary('shell32.dll');
    if hShell32 = 0 then Exit;
    try
      h16 := SHGetFileInfo(C_ROOT_DIR, 0, ShInfo, SizeOf(TSHFileInfo), SHGFI_SYSICONINDEX or SHGFI_SMALLICON);
      h32 := SHGetFileInfo(C_ROOT_DIR, 0, ShInfo, SizeOf(TSHFileInfo), SHGFI_SYSICONINDEX or SHGFI_LARGEICON);
      // Have to apply the icons to both image lists simultaneously

      hicon := Windows.LoadImage(hShell32, PChar(SIC_SHARING_HAND), IMAGE_ICON, 16, 16, LR_SHARED);
      ImageList_SetOverlayImage(h16, ImageList_AddIcon(h16, hIcon), 1);
      DestroyIcon(hicon);

      hicon := Windows.LoadImage(hShell32, PChar(SIC_SHARING_HAND), IMAGE_ICON, 32, 32, LR_SHARED);
      ImageList_SetOverlayImage(h32, ImageList_AddIcon(h32, hIcon), 1);
      DestroyIcon(hicon);

      hicon := Windows.LoadImage(hShell32, PChar(SIC_SHORTCUT), IMAGE_ICON, 16, 16, LR_SHARED);
      ImageList_SetOverlayImage(h16, ImageList_AddIcon(h16, hIcon), 2);
      DestroyIcon(hicon);

      hicon := Windows.LoadImage(hShell32, PChar(SIC_SHORTCUT), IMAGE_ICON, 32, 32, LR_SHARED);      ImageList_SetOverlayImage(h32, ImageList_AddIcon(h32, hicon), 2);
      DestroyIcon(hicon);

      OverlaysAdded := True;
    finally
      if hShell32 <> 0 then FreeLibrary(hShell32);
    end;
  end;

begin
  if IsNT and (GetFileVersion('comctl32.dll') >= COMCTL32_V472) and not OverlaysAdded then
    AddOverlays;

  if Size = 32 then Flag := SHGFI_LARGEICON
  else Flag := SHGFI_SMALLICON;
  Result := SHGetFileInfo(C_ROOT_DIR, 0, ShInfo, SizeOf(TShFileInfo), SHGFI_SYSICONINDEX or Flag);
end;

procedure RunControlPanel(CmdShow: UINT);
begin
  try
    WinExec('rundll32 shell32,Control_RunDLL', CmdShow);
  except
  end;
end;

procedure RunCPL(const FileName: String; CmdShow: UINT);
begin
  try
    WinExec(PChar('rundll32 shell32,Control_RunDLL ' + FileName), CmdShow);
  except
  end;
end;