1.txt

tvAPIThing.pas 的编译资料

      // free allocated memory
      FreeMem( pcFileName );
   end; // try
end;

function TtvAPIThing.GetFreeDiskSpace( const Drive : Char ) : LongInt;
var
   lpRootPathName          : PChar; // address of root path
   lpSectorsPerCluster     : DWORD; // address of sectors per cluster
   lpBytesPerSector        : DWORD; // address of bytes per sector
   lpNumberOfFreeClusters  : DWORD; // address of number of free clusters
   lpTotalNumberOfClusters : DWORD; // address of total number of clusters
begin
      lpRootPathName := PChar( Drive + ':\' );
      if Windows.GetDiskFreeSpace( lpRootPathName,
                                   lpSectorsPerCluster,
                                   lpBytesPerSector,
                                   lpNumberOfFreeClusters,
                                   lpTotalNumberOfClusters ) then
         Result := lpNumberOfFreeClusters * lpBytesPerSector * lpSectorsPerCluster
      else
         Result := -1;
end;

function TtvAPIThing.myGetCurrentDirectory: String;
var
   nBufferLength : DWORD; // size, in characters, of directory buffer
   lpBuffer   : PChar; // address of buffer for current directory
begin
   GetMem( lpBuffer, MAX_PATH + 1 );
   nBufferLength := 0;
   try
      if Windows.GetCurrentDirectory( nBufferLength, lpBuffer ) > 0 then
         Result := lpBuffer;
   finally
      FreeMem( lpBuffer );
   end; // try
end;

function TtvAPIThing.FileSize( const FileName : String ) : LongInt;
var
   hFile          : THandle; // handle of file to get size of
   lpFileSizeHigh : DWORD;   // address of high-order word for file size
begin
   Result := -1;
   hFile := FileOpen( FileName, fmShareDenyNone );
   try
      if hFile <> 0 then
         Result := Windows.GetFileSize( hFile, @lpFileSizeHigh );
   finally
      FileClose( hFile );
   end; // try
end;

function TtvAPIThing.GetShortPathName( const Path : String ): String;
var
   lpszShortPath : PChar; // points to a buffer to receive the null-terminated short form of the path
begin
   GetMem( lpszShortPath, MAX_PATH + 1 );
   try
      Windows.GetShortPathName( PChar( Path ), lpszShortPath, MAX_PATH + 1 );
      Result := lpszShortPath;
   finally
      FreeMem( lpszShortPath );
   end;
end;

function TtvAPIThing.myGetTempPath: String;
var
    nBufferLength : DWORD; // size, in characters, of the buffer
    lpBuffer      : PChar; // address of buffer for temp. path
begin
   nBufferLength := 0; // initialize 
   GetMem( lpBuffer, MAX_PATH + 1 );
   try
      if GetTempPath( nBufferLength, lpBuffer ) <> 0 then
         Result := lpBuffer
      else
         Result := ';
   finally
      FreeMem( lpBuffer );
   end;
end;

function TtvAPIThing.GetVolumeInformation( const Drive : Char ) : TVolumeInfo;
var
   lpRootPathName           : PChar; // address of root directory of the file system
   lpVolumeNameBuffer       : PChar; // address of name of the volume
   nVolumeNameSize          : DWORD; // length of lpVolumeNameBuffer
   lpVolumeSerialNumber     : DWORD; // address of volume serial number
   lpMaximumComponentLength : DWORD; // address of system's maximum filename length
   lpFileSystemFlags        : DWORD; // address of file system flags
   lpFileSystemNameBuffer   : PChar; // address of name of file system
   nFileSystemNameSize      : DWORD; // length of lpFileSystemNameBuffer
begin
   GetMem( lpVolumeNameBuffer, MAX_PATH + 1 );
   GetMem( lpFileSystemNameBuffer, MAX_PATH + 1 );
   try
      nVolumeNameSize := MAX_PATH + 1;
      nFileSystemNameSize := MAX_PATH + 1;

      lpRootPathName := PChar( Drive + ':\' );
      if Windows.GetVolumeInformation( lpRootPathName,
                                       lpVolumeNameBuffer,
                                       nVolumeNameSize,
                                       @lpVolumeSerialNumber,
                                       lpMaximumComponentLength,
                                       lpFileSystemFlags,
                                       lpFileSystemNameBuffer,
                                       nFileSystemNameSize ) then
      begin
      (*
         // to check disk flags do the following
         if (lpFileSystemFlags and FS_CASE_IS_PRESERVED) <> 0 then
            if Length( flags ) <> 0 then
               flags := flags + #13#10'FS_CASE_IS_PRESERVED'
            else
               flags := 'FS_CASE_IS_PRESERVED';

         if (lpFileSystemFlags and FS_CASE_SENSITIVE) <> 0 then
            if Length( flags ) <> 0 then
               flags := flags + #13#10'FS_CASE_SENSITIVE'
            else
               flags := 'FS_CASE_SENSITIVE';

         if (lpFileSystemFlags and FS_UNICODE_STORED_ON_DISK) <> 0 then
            if Length( flags ) <> 0 then
               flags := flags + #13#10'FS_UNICODE_STORED_ON_DISK'
            else
               flags := 'FS_UNICODE_STORED_ON_DISK';

         if (lpFileSystemFlags and FS_PERSISTENT_ACLS) <> 0 then
            if Length( flags ) <> 0 then
               flags := flags + #13#10'FS_PERSISTENT_ACLS'
            else
               flags := 'FS_PERSISTENT_ACLS';

         if (lpFileSystemFlags and FS_FILE_COMPRESSION) <> 0 then
            if Length( flags ) <> 0 then
               flags := flags + #13#10'FS_FILE_COMPRESSION'
            else
               flags := 'FS_FILE_COMPRESSION';

         if (lpFileSystemFlags and FS_VOL_IS_COMPRESSED) <> 0 then
            if Length( flags ) <> 0 then
               flags := flags + #13#10'FS_VOL_IS_COMPRESSED'
            else
               flags := 'FS_VOL_IS_COMPRESSED';
         *)

         with Result do
         begin
            Name               := lpVolumeNameBuffer;
            SerialNumber       := lpVolumeSerialNumber;
            MaxComponentLength := lpMaximumComponentLength;
            FileSystemFlags    := lpFileSystemFlags;
            FileSystemName     := lpFileSystemNameBuffer;
         end; // with Result
      end // if
      else
      begin
         with Result do
         begin
            Name               := ';
            SerialNumber       := -1;
            MaxComponentLength := -1;
            FileSystemFlags    := -1;
            FileSystemName     := ';
         end; // with Result
      end; // else
   finally
      FreeMem( lpVolumeNameBuffer );
      FreeMem( lpFileSystemNameBuffer );
   end; // try
end;

function TtvAPIThing.GetFullPathName( const Path : String ): String;
var
   nBufferLength : DWORD; // size, in characters, of path buffer
   lpBuffer      : PChar; // address of path buffer
   lpFilePart    : PChar; // address of filename in path
begin
   nBufferLength := MAX_PATH + 1;
   GetMem( lpBuffer, MAX_PATH + 1 );
   try
      if Windows.GetFullPathName( PChar( Path ), nBufferLength, lpBuffer, lpFilePart ) <> 0 then
         Result := lpBuffer
      else
         Result := ';
   finally
      FreeMem( lpBuffer );
   end;
end;

function TtvAPIThing.myGetLogicalDrives : String;
var
   drives  : set of 0..25;
   drive   : integer;
begin
   Result := ';
   DWORD( drives ) := Windows.GetLogicalDrives;
   for drive := 0 to 25 do
      if drive in drives then
         Result := Result + Chr( drive + Ord( 'A' ));
end;

function TtvAPIThing.FindExecutable( const FileName : String ): String;
var
   lpResult : PChar;  // address of buffer for string for executable file on return
begin
   GetMem( lpResult, MAX_PATH + 1 );
   try
      if ShellAPI.FindExecutable( PChar( FileName ),
                                  PChar( CurrentDirectory ),
                                  lpResult ) > 32 then
         Result := lpResult
      else
         Result := 'ERROR_FILE_NOT_FOUND';
   finally
      FreeMem( lpResult );
   end; // try
end;

procedure TtvAPIThing.myGetSystemInfo;
var
   SysInfo : TSystemInfo;
begin
   Windows.GetSystemInfo(SysInfo);

   with SysInfo do
   begin
      FPageSize      := dwPageSize;

      case dwProcessorType of
         PROCESSOR_INTEL_386      : FProcessorType := '386';
         PROCESSOR_INTEL_486      : FProcessorType := '486';
         PROCESSOR_INTEL_PENTIUM  : FProcessorType := 'Pentium';
         PROCESSOR_MIPS_R4000     : FProcessorType := 'MIPS';
         PROCESSOR_ALPHA_21064    : FProcessorType := 'ALPHA';
      end; // case dwProcessorType

      FNumberOfProcessors := dwNumberOfProcessors; 
   end;
end;

function TtvAPIThing.myGetVersion: String;
var
   VersionInfo : TOSVersionInfo;
   OSName      : String;
begin
   // set the size of the record
   VersionInfo.dwOSVersionInfoSize := SizeOf( TOSVersionInfo );

   if Windows.GetVersionEx( VersionInfo ) then
      begin
         with VersionInfo do
         begin
            case dwPlatformId of
               VER_PLATFORM_WIN32s   : OSName := 'Win32s';
               VER_PLATFORM_WIN32_WINDOWS : OSName := 'Windows 95';
               VER_PLATFORM_WIN32_NT      : OSName := 'Windows NT';
            end; // case dwPlatformId
            Result := OSName + ' Version ' + IntToStr( dwMajorVersion ) + '.' + IntToStr( dwMinorVersion ) +
                      #13#10' (Build ' + IntToStr( dwBuildNumber ) + ': ' + szCSDVersion + ')';
         end; // with VersionInfo
      end // if GetVersionEx
   else
      Result := ';
end;

procedure TtvAPIThing.Loaded;
begin
   inherited Loaded;
   myGetSystemInfo;
   // Uncomment out the line below to make the nagging message go away
   ShowMessage( 'This application is using a'#13#10'TtvAPIThing component created by'#13#10'Tim Victor'#13#10'[e-mail]' );
end;

procedure TtvAPIThing.FormatDrive( const Drive : Char );
var
  wDrive       : Word;
  dtDrive      : TDriveType;
  strDriveType : String;
begin
   // determine what type of drive is being
   dtDrive := DriveType( Drive );
   // if it's not a HDD or a FDD then raise an exception
   if  ( dtDrive <> dtFloppy ) and ( dtDrive <> dtFixed ) then
      begin
         strDriveType := 'Cannot format a ';
         case dtDrive of
            dtUnknown : strDriveType := 'Cannot determine drive type';
            dtNoDrive : strDriveType := 'Specified drive does not exist';
            dtNetwork : strDriveType := strDriveType + 'Network Drive';
            dtCDROM   : strDriveType := strDriveType + 'CD-ROM Drive';
            dtRAM     : strDriveType := strDriveType + 'RAM Drive';
         end; // case dtDrive

         raise Exception.Create( strDriveType + '.' );
      end // if DriveType
   else // proceed with the format
      begin
         wDrive := Ord( Drive ) - Ord( 'A' );
         // SHFormatDrive is an undocumented API function
         SHFormatDrive( Application.Handle, wDrive, $ffff, 0);
      end; // else
end;

function TtvAPIThing.myGlobalMemoryStatus( Index : Integer ): DWORD;
var
   MemoryStatus : TMemoryStatus;
begin
   with MemoryStatus do
   begin
      dwLength := SizeOf( TMemoryStatus );
      Windows.GlobalMemoryStatus( MemoryStatus );
      case Index of
         1 : Result := dwMemoryLoad;
         2 : Result := dwTotalPhys;
         3 : Result := dwAvailPhys;
         4 : Result := dwTotalPageFile;
         5 : Result := dwAvailPageFile;
         6 : Result := dwTotalVirtual;
         7 : Result := dwAvailVirtual;
         else Result := 0;
      end; // case
   end; // with MemoryStatus
end;

function TtvAPIThing.DriveType( const Drive : Char ) : TDriveType;
begin
   Result := TDriveType(GetDriveType(PChar(Drive + ':\')));
end;

procedure TtvAPIThing.ShutDown;
const
  SE_SHUTDOWN_NAME = 'SeShutdownPrivilege';   // Borland forgot this declaration
var
  hToken       : THandle;
  tkp          : TTokenPrivileges;
  tkpo         : TTokenPrivileges;
  zero         : DWORD;
begin
  if OSVersion = 'Windows NT' then // we've got to do a whole buch of things
     begin
        zero := 0;
        if not OpenProcessToken( GetCurrentProcess(), TOKEN_ADJUST_PRIVILEGES or TOKEN_QUERY, hToken) then
           begin
             MessageBox( 0, 'Exit Error', 'OpenProcessToken() Failed', MB_OK );
             Exit;
           end; // if not OpenProcessToken( GetCurrentProcess(), TOKEN_ADJUST_PRIVILEGES or TOKEN_QUERY, hToken)

        // SE_SHUTDOWN_NAME
        if not LookupPrivilegeValue( nil, 'SeShutdownPrivilege' , tkp.Privileges[0].Luid ) then
           begin
              MessageBox( 0, 'Exit Error', 'LookupPrivilegeValue() Failed', MB_OK );
              Exit;
           end; // if not LookupPrivilegeValue( nil, 'SeShutdownPrivilege' , tkp.Privileges[0].Luid )
        tkp.PrivilegeCount := 1;
        tkp.Privileges[0].Attributes := SE_PRIVILEGE_ENABLED;

        AdjustTokenPrivileges( hToken, False, tkp, SizeOf( TTokenPrivileges ), tkpo, zero );
        if Boolean( GetLastError() ) then
           begin
              MessageBox( 0, 'Exit Error', 'AdjustTokenPrivileges() Failed', MB_OK );
              Exit;
           end // if Boolean( GetLastError() )
        else
           ExitWindowsEx( EWX_FORCE or EWX_SHUTDOWN, 0 );
      end // if OSVersion = 'Windows NT'
   else
      begin // just shut the machine down
        Windows.ExitWindows( 0, 0 );
      end; // else
end;

procedure Register;
begin
   RegisterComponents( 'Samples', [TtvAPIThing] );
end;

end.