stsystem.pas

条码控件： 一维条码控件 二维条码控件 PDF417Barcode MaxiCodeBarcode

var
  Abort : Boolean;
    procedure SearchBranch;
    var
      SR    : TSearchRec;
      Error : SmallInt;
      Dir   : AnsiString;
    begin
      Error := FindFirst(StDosAnyFile, faDirectory, SR);
      if Error = 0 then begin
        GetDir(0, Dir);
        if Dir[Length(Dir)] <> StDosPathDelim then
          Dir := Dir + StDosPathDelim;
        Abort := False;
        while (Error = 0) and not Abort do begin
          try
            if (@IncludeItem = nil) or (IncludeItem(SR, true, Abort)) then begin
              if (SR.Attr and faDirectory = faDirectory) and
                 (SR.Name <> StThisDir) and (SR.Name <> StParentDir) then
                FL.Add(Dir + SR.Name);
            end;
          except
            on EOutOfMemory do
              raise EOutOfMemory.Create(stscSysStringListFull);
          end;
          Error := FindNext(SR);
        end;
        FindClose(SR);
      end;

      if not Abort and SubDirs then begin
        Error := FindFirst(StDosAnyFile, faDirectory, SR);
        if Error = 0 then begin
          Abort := False;
          while (Error = 0) and not Abort do begin
            if ((SR.Attr and faDirectory = faDirectory) and
                (SR.Name <> StThisDir) and (SR.Name <> StParentDir)) then begin
              if (@IncludeItem = nil) or (IncludeItem(SR, false, Abort)) then begin
                StChDir(SR.Name);
                SearchBranch;
                StChDir(StParentDir);
              end;
            end;
            Error := FindNext(SR);
          end;
          FindClose(SR);

        end;
      end;
    end;

var
  OrgDir : AnsiString;

begin
  if IsDirectory(StartDir) then
  begin
    GetDir(0, OrgDir);
    try
      StChDir(StartDir);
      SearchBranch;
    finally
      StChDir(OrgDir);
    end;
  end else
    raise Exception.Create(stscSysBadStartDir);
end;

{EnumerateFiles}
procedure EnumerateFiles(const StartDir : AnsiString;                  {!!.02}
                         FL : TStrings;
                         SubDirs : Boolean;
                         IncludeItem : TIncludeItemFunc);
{-Retrieves the complete path name of files in a requested file system path.}
var
  Abort : Boolean;

    procedure SearchBranch;
    var
      SR    : TSearchRec;
      Error : SmallInt;
      Dir   : AnsiString;
    begin
      Error := FindFirst(StDosAnyFile, faAnyFile, SR);
      if Error = 0 then begin
        GetDir(0, Dir);
        if Dir[Length(Dir)] <> StDosPathDelim then
          Dir := Dir + StDosPathDelim;

        Abort := False;
        while (Error = 0) and not Abort do begin
          try
            if (@IncludeItem = nil) or (IncludeItem(SR, true, Abort)) then
              FL.Add(Dir + SR.Name);
          except
            on EOutOfMemory do
            begin
              raise EOutOfMemory.Create(stscSysStringListFull);
            end;
          end;
          Error := FindNext(SR);
        end;
        FindClose(SR);
      end;


      if not Abort and SubDirs then begin
        Error := FindFirst(StDosAnyFile, faAnyFile, SR);
        if Error = 0 then begin
          Abort := False;
          while (Error = 0) and not Abort do begin
            if ((SR.Attr and faDirectory = faDirectory) and
                (SR.Name <> StThisDir) and (SR.Name <> StParentDir)) then begin
              if (@IncludeItem = nil) or (IncludeItem(SR, false, Abort)) then begin
                StChDir(SR.Name);
                SearchBranch;
                StChDir(StParentDir);
              end;
            end;
            Error := FindNext(SR);
          end;
          FindClose(SR);
        end;
      end;
    end;

var
  OrgDir : AnsiString;

begin
  if IsDirectory(StartDir) then
  begin
    GetDir(0, OrgDir);
    try
      StChDir(StartDir);
      SearchBranch;
    finally
      StChDir(OrgDir);
    end;
  end else
    raise Exception.Create(stscSysBadStartDir);
end;


{FileHandlesLeft}
{.$HINTS OFF}
function FileHandlesLeft(MaxHandles : Cardinal) : Cardinal;
  {-Returns the number of available file handles. In 32-bit, this can be a
    large number.  Use MaxHandles to limit the number of handles counted.
    The maximum is limited by HandleLimit - you can increase HandleLimit if
    you wish.  A temp file is required because Win95 seems to have some
    limit on the number of times you can open NUL.}
const
  HandleLimit = 1024;
type
  PHandleArray = ^THandleArray;
  THandleArray = array[0..Pred(HandleLimit)] of Integer;
var
  Handles : PHandleArray;
  MaxH, I : Integer;
  TempPath, TempFile : PAnsiChar;
begin
  Result := 0;
  MaxH := MinLong(HandleLimit, MaxHandles);
  TempFile := nil;
  TempPath := nil;
  Handles := nil;
  try
    TempFile := StrAlloc(MAX_PATH+1);                                    {!!.01}
    TempPath := StrAlloc(MAX_PATH+1);                                    {!!.01}
    GetMem(Handles, MaxH * SizeOf(Integer));
    GetTempPath(MAX_PATH, TempPath);                                     {!!.01}
    GetTempFileName(TempPath, 'ST', 0, TempFile);
    for I := 0 to Pred(MaxH) do begin
      Handles^[I] := CreateFile(TempFile, 0, FILE_SHARE_READ, nil,
        OPEN_EXISTING, FILE_FLAG_DELETE_ON_CLOSE, 0);
      if Handles^[I] <> LongInt(INVALID_HANDLE_VALUE) then
        Inc(Result) else Break;
    end;
    for I := 0 to Pred(Result) do
      FileClose(Handles^[I]);
  finally
    if Assigned(Handles) then
      FreeMem(Handles, MaxH * SizeOf(Integer));
    StrDispose(TempFile);
    StrDispose(TempPath);
  end;
end;
{.$HINTS ON}

{ -------------------------------------------------------------------------- }
function StPatternMatch(const Source : string; iSrc : Integer;          {!!.02}
                const Pattern : string; iPat : Integer ) : Boolean;     {!!.02}
{ recursive routine to see if the source string matches
  the pattern.  Both ? and * wildcard characters are allowed.
  Compares Source from iSrc to Length(Source) to
  Pattern from iPat to Length(Pattern)}
var
  Matched : Boolean;
  k : Integer;
begin
{$R-}
  if Length( Source ) = 0 then begin
    Result := Length( Pattern ) = 0;
    Exit;
  end;

  if iPat = 1 then begin
    if ( CompareStr( Pattern, StDosAnyFile) = 0 ) or
       ( CompareStr( Pattern, StUnixAnyFile ) = 0 ) then begin
      Result := True;
      Exit;
    end;
  end;

  if Length( Pattern ) = 0 then begin
    Result := (Length( Source ) - iSrc + 1 = 0);
    Exit;
  end;

  while True do begin
    if ( Length( Source ) < iSrc ) and
       ( Length( Pattern ) < iPat ) then begin
      Result := True;
      Exit;
    end;

    if Length( Pattern ) < iPat then begin
      Result := False;
      Exit;
    end;

    if (iPat <= Length(Pattern)) and (Pattern[iPat] = '*') then begin
      k := iPat;
      if ( Length( Pattern ) < iPat + 1 ) then begin
        Result := True;
        Exit;
      end;

      while True do begin
        Matched := StPatternMatch( Source, k, Pattern, iPat + 1 );
        if Matched or ( Length( Source ) < k ) then begin
          Result := Matched;
          Exit;
        end;
        inc( k );
      end;
    end
    else begin
      if ((Pattern[iPat] = '?') and
           ( Length( Source ) <> iSrc - 1 ) ) or
           ( Pattern[iPat] = Source[iSrc] ) then begin
        inc( iPat );
        inc( iSrc );
      end
      else begin
        Result := False;
        Exit;
      end;
    end;
  end;
{$R+}
end;

{FileMatchesMask}
function FileMatchesMask(const FileName, FileMask : AnsiString ) : Boolean;
{-see if FileName matches FileMask}
var
  DirMatch : Boolean;
  MaskDir : AnsiString;
  LFN, LFM : AnsiString;
begin
  LFN := UpperCase( FileName );
  LFM := UpperCase( FileMask );
  MaskDir := ExtractFilePath( LFN );
  if MaskDir = '' then
    DirMatch := True
  else
    DirMatch := StPatternMatch( ExtractFilePath( LFN ), 1, MaskDir, 1 );

  Result := DirMatch and StPatternMatch( ExtractFileName( LFN ), 1,
                                       ExtractFileName( LFM ), 1 );
end;

{FileTimeToStDateTime}
function FileTimeToStDateTime(FileTime : LongInt) : TStDateTimeRec;
{-Converts a DOS date-time value to TStDate and TStTime values.}

var
  DDT : TDateTime;
begin
  DDT := FileDateToDateTime(FileTime);
  Result.D := DateTimeToStDate(DDT);
  Result.T := DateTimeToStTime(DDT);
end;

{FindNthSlash}
function FindNthSlash(const Path : AnsiString; n : Integer) : Integer;
{ return the position of the character just before the nth slash }
var
  i : Integer;
  Len : Integer;
  iSlash : Integer;
begin
  Len := Length( Path );
  Result := Len;
  iSlash := 0;
  i := 1;
  while i <= Len do begin
    if Path[i] = StPathDelim then begin
      inc( iSlash );
      if iSlash = n then begin
        Result := pred( i );
        break;
      end;
    end;
    inc( i );
  end;
end;

{FlushOsBuffers}
{-Flush the OS buffers for the specified file handle.}
function FlushOsBuffers(Handle : Integer) : Boolean;
  {-Flush the OS's buffers for the specified file}
begin
  Result := FlushFileBuffers(Handle);
  if not Result then
{$IFDEF Version6}
    RaiseLastOSError;
{$ELSE}
    RaiseLastWin32Error;
{$ENDIF}
end;

{GetCurrentUser}
function GetCurrentUser : AnsiString;
{-Obtains current logged in username}
var
  Size : DWORD;
  UserNameZ : array [0..511] of AnsiChar;
begin
  Size := sizeof(UserNameZ);
  if not GetUserName(UserNameZ, Size) then
{$IFDEF Version6}
    RaiseLastOSError;
{$ELSE}
    RaiseLastWin32Error;
{$ENDIF}
//  SetString(Result, UserNameZ, Size);                      {!!.02}
  SetString(Result, UserNameZ, StrLen(UserNameZ));           {!!.02}
end;

{GetDiskClass}
function GetDiskClass(Drive : AnsiChar) : DiskClass;
{-Return the disk class for the specified drive.}
type
  TMediaType =
    ( Unknown,                { Format is unknown }
      F5_1Pt2_512,            { 5.25", 1.2MB,  512 bytes/sector }
      F3_1Pt44_512,           { 3.5",  1.44MB, 512 bytes/sector }
      F3_2Pt88_512,           { 3.5",  2.88MB, 512 bytes/sector }
      F3_20Pt8_512,           { 3.5",  20.8MB, 512 bytes/sector }
      F3_720_512,             { 3.5",  720KB,  512 bytes/sector }
      F5_360_512,             { 5.25", 360KB,  512 bytes/sector }
      F5_320_512,             { 5.25", 320KB,  512 bytes/sector }
      F5_320_1024,            { 5.25", 320KB,  1024 bytes/sector }
      F5_180_512,             { 5.25", 180KB,  512 bytes/sector }
      F5_160_512,             { 5.25", 160KB,  512 bytes/sector }
      RemovableMedia,         { Removable media other than floppy }
      FixedMedia );           { Fixed hard disk media }

  PDiskGeometry = ^TDiskGeometry;
  TDiskGeometry = record
    Cylinders1 : DWORD;
    Cylinders2 : Integer;
    MediaType : TMediaType;
    TracksPerCylinder : DWORD;
    SectorsPerTrack : DWORD;
    BytesPerSector : DWORD;
  end;

var
  Root : array[0..3] of AnsiChar;
  Root2 : array[0..6] of AnsiChar;
  ReturnedByteCount,
  SectorsPerCluster,
  BytesPerSector,
  NumberOfFreeClusters,
  TotalNumberOfClusters : DWORD;
  SupportedGeometry : array[1..20] of TDiskGeometry;
  HDevice : THandle;
  I : Integer;
  VerInfo : TOSVersionInfo;
  Found : Boolean;
begin
  FillChar(VerInfo, SizeOf(TOSVersionInfo), #0);
  VerInfo.dwOSVersionInfoSize := SizeOf(TOSVersionInfo);

  Result := InvalidDrive;
  Found := False;
  StrCopy(Root, '%:\');
  Root[0] := Drive;
  case GetDriveType(Root) of
    0 : Result := UnknownDisk;
    1 : Result := InvalidDrive;
    DRIVE_REMOVABLE :
      begin
        GetVersionEx(VerInfo);
        if VerInfo.dwPlatformID = VER_PLATFORM_WIN32_NT then begin
          StrCopy(Root2, '\\.\%:');
          Root2[4] := Drive;
          HDevice := CreateFile(Root2, 0, FILE_SHARE_READ,
            nil, OPEN_ALWAYS, 0, 0);
          if HDevice = INVALID_HANDLE_VALUE then Exit;
          if not DeviceIoControl(HDevice, IOCTL_DISK_GET_MEDIA_TYPES, nil, 0,
            @SupportedGeometry, SizeOf(SupportedGeometry), ReturnedByteCount, nil)
          then Exit;
          for I := 1 to (ReturnedByteCount div SizeOf(TDiskGeometry)) do begin
            case SupportedGeometry[I].MediaType of
              F5_1Pt2_512 : begin
                Result := Floppy12;
                Exit;
              end;
              F3_1Pt44_512 : begin
                Result := Floppy144;
                Exit;
              end;
              F3_720_512 : begin
                Result := Floppy720;
                Found := True;
              end;
              F5_360_512 : begin
                Result := Floppy360;
                Found := True;
              end;
            end;
          end;
          if Found then Exit;
          Result := OtherFloppy;
        end else begin
          GetDiskFreeSpace(Root, SectorsPerCluster, BytesPerSector,
            NumberOfFreeClusters, TotalNumberOfClusters);
          case TotalNumberOfClusters of
             354 : Result := Floppy360;
             713,
            1422 : Result := Floppy720;
            2371 : Result := Floppy12;
            2847 : Result := Floppy144;
          else Result := OtherFloppy;
          end;
        end;
      end;
    DRIVE_FIXED : Result := HardDisk;
    DRIVE_REMOTE : Result := RemoteDrive;
    DRIVE_CDROM : Result := CDRomDisk;
    DRIVE_RAMDISK : Result := RamDisk;
  end;
end;

{GetDiskInfo}
function GetDiskInfo(Drive : AnsiChar; var ClustersAvailable, TotalClusters,