tvapithing.pas

del *.obj del *.dcu del *.~* del *.hpp del *.dcp del *.dpl del *.cesettings del *.log upx sy

   try
      if Windows.GetFullPathName( PChar( Path ), nBufferLength, lpBuffer, lpFilePart ) <> 0 then
         Result := lpBuffer
      else
         Result := 'ERROR';
   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;

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.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( const 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     div 1024;
         3 : Result := dwAvailPhys     div 1024;
         4 : Result := dwTotalPageFile div 1024;
         5 : Result := dwAvailPageFile div 1024;
         6 : Result := dwTotalVirtual  div 1024;
         7 : Result := dwAvailVirtual  div 1024;
         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 Pos( 'Windows NT', OSVersion ) = 1  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)
        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
        ExitWindowsEx( EWX_FORCE or EWX_SHUTDOWN, 0 );
      end; // else
end;

function TtvAPIThing.SystemTimeToDateTime(const SystemTime: TSystemTime): TDateTime;
begin
  with SystemTime do
    Result := EncodeDate(wYear, wMonth, wDay) +
      EncodeTime(wHour, wMinute, wSecond, wMilliSeconds);
end;

function TtvAPIThing.myGetSystemInfoWORD( const Index : Integer )  : WORD;
var
   SysInfo : TSystemInfo;
begin
   //property wProcessorArchitecture     : WORD index 1 read myGetSystemInfoWORD;
   //property wProcessorLevel            : WORD index 2 read myGetSystemInfoWORD;
   //property wProcessorRevision         : WORD index 3 read myGetSystemInfoWORD;

   Windows.GetSystemInfo( SysInfo );
   with SysInfo do
      case Index of
         1 : Result := wProcessorArchitecture;
         2 : Result := wProcessorLevel;
         3 : Result := wProcessorRevision;
         else Result := null;
      end; // case Index of
end;

function TtvAPIThing.myGetSystemInfoDWORD( const Index : Integer ) : DWORD;
var
   SysInfo : TSystemInfo;
begin
   //property dwPageSize                 : DWORD index 1 read myGetSystemInfoDWORD;
   //property dwActiveProcessorMask      : DWORD index 2 read myGetSystemInfoDWORD;
   //property dwNumberOfProcessors       : DWORD index 3 read myGetSystemInfoDWORD;
   //property dwProcessorType            : DWORD index 4 read myGetSystemInfoDWORD;
   //property dwAllocationGranularity    : DWORD index 5 read myGetSystemInfoDWORD;

   Windows.GetSystemInfo( SysInfo );

   with SysInfo do
      case Index of
         1 : Result := dwPageSize;
         2 : Result := dwActiveProcessorMask;
         3 : Result := dwNumberOfProcessors;
         4 : Result := dwProcessorType;
         5 : Result := dwAllocationGranularity;
         else Result := null;
      end; // case Index of
end;

// Removed for D4
function TtvAPIThing.myGetSystemInfoPtr( const Index : Integer ): Pointer;
var
   SysInfo : TSystemInfo;
begin
   //property lpMinimumApplicationAddress : Pointer index 1 read myGetSystemInfoPtr;
   //property lpMaximumApplicationAddress : Pointer index 2 read myGetSystemInfoPtr;
   Windows.GetSystemInfo( SysInfo );

   with SysInfo do
      case Index of
         1 : Result := lpMinimumApplicationAddress;
         2 : Result := lpMaximumApplicationAddress;
         else Result := nil;
      end; // case Index of
end;

function TtvAPIThing.DisconnectNetworkDrive( const Drive : Char ): Boolean;
var
   sDrive    : String;
   pResource : PChar;
begin
   (*
    WNetCancelConnection2(
    LPTSTR  lpszName,	// address of resource name to disconnect
    DWORD  fdwConnection,	// connection type flags
    BOOL  fForce 	// flag for unconditional disconnect
    );
   *)

   sDrive    := Drive + ':';
   pResource := PChar( sDrive );
   Result    := ( Windows.WNetCancelConnection2( pResource, 0, True ) = NO_ERROR );
end;

function TtvAPIThing.AddNetworkDrive( const Resource : String; const Drive : Char ): Boolean;
var
   sDrive : String;
   pDrive : PChar;
begin
   (*
    DWORD WNetAddConnection(
    LPTSTR  lpszRemoteName,	// address of network device name
    LPTSTR  lpszPassword,	// address of password
    LPTSTR  lpszLocalName 	// address of local device name
   );
   *)
   sDrive := Drive + ':';
   pDrive := PChar( sDrive );
   Result := ( Windows.WNetAddConnection( PChar( Resource ), '', pDrive ) = NO_ERROR );
end;

function TtvAPIThing.GetUniversalName( const Drive : Char ): String;
var
   pResource : PChar;
   lpBuffer  : PUniversalNameInfo;
   dwWDSize  : DWORD;
begin
   (*
     DWORD WNetGetUniversalName(
     LPCTSTR  lpLocalPath,	// address of drive-based path for a network resource
     DWORD  dwInfoLevel,	// specifies form of universal name to be obtained
     LPVOID  lpBuffer,   	// address of buffer that receives universal name data structure
     LPDWORD  lpBufferSize 	// address of variable that specifies size of buffer
     );
   *)
   pResource := PChar( Drive + ':\' );
   dwWDSize  := 1024;
   GetMem( lpBuffer, dwWDSize );
   try
      if WNetGetUniversalName( pResource, UNIVERSAL_NAME_INFO_LEVEL, lpBuffer, dwWDSize ) = NO_ERROR then
         Result := lpBuffer.lpUniversalName
      else
         Result := 'ERROR';
   finally
      FreeMem( lpBuffer );
   end;
end;

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

end.