mycomponent.pas

delphi中各种API函数的实现

unit MyComponent;

interface

uses
  Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs,
  StdCtrls, ExtCtrls, ShellAPI, tvAPIThing;

type
  Tfrm_Main = class(TForm)
    Button1: TButton;
    Button2: TButton;
    Button3: TButton;
    Button4: TButton;
    Button5: TButton;
    Button6: TButton;
    Button7: TButton;
    Button8: TButton;
    Button9: TButton;
    Button10: TButton;
    Timer1: TTimer;
    Button11: TButton;
    Button12: TButton;
    Panel1: TPanel;
    Image1: TImage;
    Button13: TButton;
    Label1: TLabel;
    Button14: TButton;
    Button15: TButton;
    Button16: TButton;
    Button21: TButton;
    Button17: TButton;
    Button22: TButton;
    Button23: TButton;
    Button24: TButton;
    Button25: TButton;
    Button26: TButton;
    Button18: TButton;

    procedure Button1Click(Sender: TObject);
    procedure FormCreate(Sender: TObject);
    procedure Button2Click(Sender: TObject);
    procedure Button3Click(Sender: TObject);
    procedure Button4Click(Sender: TObject);
    procedure Button5Click(Sender: TObject);
    procedure Button6Click(Sender: TObject);
    procedure Button7Click(Sender: TObject);
    procedure Button8Click(Sender: TObject);
    procedure Button9Click(Sender: TObject);
    procedure Button10Click(Sender: TObject);
    procedure Timer1Timer(Sender: TObject);
    procedure Button11Click(Sender: TObject);
    procedure Button12Click(Sender: TObject);
    procedure Button13Click(Sender: TObject);
    procedure Button14Click(Sender: TObject);
    procedure Button15Click(Sender: TObject);
    procedure Button16Click(Sender: TObject);
    procedure Button18Click(Sender: TObject);
    procedure Button21Click(Sender: TObject);
    procedure Button17Click(Sender: TObject);
    procedure Button22Click(Sender: TObject);
    procedure Button23Click(Sender: TObject);
    procedure Button24Click(Sender: TObject);
    procedure Button25Click(Sender: TObject);
    procedure Button26Click(Sender: TObject);
    procedure FormDestroy(Sender: TObject);
  private
    { Private declarations }
  public
    { Public declarations }
    APIThing : TtvAPIThing;
  end;

  TtvStringList = class(TStringList)
  private
  public
  protected
     procedure AppendToFile(const FileName : String);
  end;

var
  frm_Main: Tfrm_Main;

implementation

{$R *.DFM}

procedure TtvStringList.AppendToFile(const FileName : String);
var
   FFile : TextFile;
   iString   : Integer;
begin
   // if the file doesn't exist then call some code that's already written
   if not FileExists(FileName) then
      SaveToFile(FileName)
   else
   // else we've got to open the file go to the end of it and loop through our list
   begin
      // associate the name of an external file with a file variable.
      AssignFile( FFile, FileName );
      // Prepare the file for having text added the end
      System.Append( FFile );

      // loop through the list and write out the strings
      for iString := 0 to Count - 1 do
         Writeln( FFile, Strings[ iString ] );

      // Close the file
      CloseFile( FFile );
   end;
end;

procedure Tfrm_Main.Button1Click(Sender: TObject);
begin
   ShowMessage( 'File Comments: ' + APIThing.GetFileInformation( Application.ExeName, 'Comments' ) );
end;

procedure Tfrm_Main.FormCreate(Sender: TObject);
begin
   APIThing := TtvAPIThing.Create( Self );

   with APIThing do
      Image1.Picture.Icon.Handle := ExtractIcon( WindowsDirectory + '\Notepad.exe' );
   //Image1.Picture.Icon.Handle := APIThing.ExtractAssociatedIcon( Application.ExeName );
end;

procedure Tfrm_Main.Button2Click(Sender: TObject);
var
   f1, f2 : string;
   x : TFixedFileInfo;
begin

   f1 := 'C:\autoexec.bat';
   f2 := 'C:\boot.ini';
    case APIThing.CompareFileTime( f1, f2, ftLastWriteTime ) of
       ftError             : ShowMessage( 'Error' );
       ftFileOneIsOlder    : ShowMessage( f1 + '''s Last Write Time is older' );
       ftFileTimesAreEqual : ShowMessage( f1 + ' and ' + f2 + ' have equal Last Write Time''s' );
       ftFileTwoIsOlder    : ShowMessage( f2 + '''s Last Write Time is older' );
    end; // case

    f1 := Application.ExeName;
    x := APIThing.FileInfo( f1 );
    ShowMessage( f1 +
                 #13#10'Version: ' + IntToStr( x.wFileVersionLS ) + '.' + IntToStr( x.wFileVersionMS ) +
                 #13#10'Release: ' + IntToStr( x.wProductVersionLS) +
                 #13#10'Build: '  + IntToStr( x.wProductVersionMS ) );
end;

procedure Tfrm_Main.Button3Click(Sender: TObject);
var
   i : integer;
   s : String;
begin
   s := '';

   for i := 1 to Length( APIThing.LogicalDrives ) do
      s := s + APIThing.LogicalDrives[i] + ':\ - ' +
           IntToStr( APIThing.GetFreeDiskSpace( APIThing.LogicalDrives[i] ) ) + #13#10;

   ShowMessage( 'Free Disk Space:'#13#10 + s );
end;

procedure Tfrm_Main.Button4Click(Sender: TObject);
begin
   ShowMessage( 'Current Directory: ' + APIThing.CurrentDirectory );
end;

procedure Tfrm_Main.Button5Click(Sender: TObject);
begin
   ShowMessage( 'FileSize of ' + Application.ExeName + ': ' + IntToStr( APIThing.FileSize( Application.ExeName ) ) );
end;

procedure Tfrm_Main.Button6Click(Sender: TObject);
begin
   ShowMessage( 'Short Path Name: ' + APIThing.GetShortPathName( Application.ExeName ) );
end;

procedure Tfrm_Main.Button7Click(Sender: TObject);
begin
   ShowMessage( 'Temp Path: ' + APIThing.TempPath );
end;

procedure Tfrm_Main.Button8Click(Sender: TObject);
var
   VolumeInfo : TVolumeInfo;
   flags      : String;
begin
   VolumeInfo := APIThing.GetVolumeInformation( 'C' );
   with VolumeInfo do
   begin
      if (FileSystemFlags and FS_CASE_IS_PRESERVED) <> 0 then
            if Length( flags ) <> 0 then
               flags := flags + #13#10#9'FS_CASE_IS_PRESERVED'
            else
               flags := 'FS_CASE_IS_PRESERVED';

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

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

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

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

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

      ShowMessage( 'Volume Information For Drive C'#13#10#13#10 +
                   'Name:'#9 + Name + #13#10 +
                   'Serial Number:'#9 + Copy( IntToHex( SerialNumber, 0 ), 1, 4 ) + '-' + Copy( IntToHex( SerialNumber, 0 ), 5, 4 )+ #13#10 +
                   'Max Component Length:'#9 + IntToStr( MaxComponentLength ) + #13#10 +
                   'File System Flags:'#13#10#9 + Flags + #13#10 +
                   'File System:'#9 + FileSystemName );
   end; // with VolumeInfo
end;

procedure Tfrm_Main.Button9Click(Sender: TObject);
begin
   ShowMessage( 'Full Path Name: ' + APIThing.GetFullPathName( Application.ExeName ) );
end;

procedure Tfrm_Main.Button10Click(Sender: TObject);
begin
   ShowMessage( 'Logical Drives: ' + APIThing.LogicalDrives );
end;

procedure Tfrm_Main.Timer1Timer(Sender: TObject);
begin
   Label1.Caption := 'System Time: ' + APIThing.SystemTime + #13#10'Local Time: ' + APIThing.LocalTime;
end;

procedure Tfrm_Main.Button11Click(Sender: TObject);
begin
   ShowMessage( 'Windows Directory: ' + APIThing.WindowsDirectory );
end;

procedure Tfrm_Main.Button12Click(Sender: TObject);
begin
    ShowMessage( 'System Directory: ' + APIThing.SystemDirectory );
end;

procedure Tfrm_Main.Button13Click(Sender: TObject);
var
   s : String;
begin
   s := Application.ExeName;
   with APIThing do
      ShowMessage( 'GetFileTime Values For'#13#10 + s + #13#10#13#10 +
                   'Creation Time: ' + DateTimeToStr( GetFileTime( s, ftCreationTime ) ) + #13#10 +
                   'Last Access Time: ' + DateTimeToStr( GetFileTime( s, ftLastAccessTime ) ) + #13#10 +
                   'Last Write Time: ' + DateTimeToStr( GetFileTime( s, ftLastWriteTime ) ) );
end;

procedure Tfrm_Main.Button14Click(Sender: TObject);
begin
   ShowMessage( 'User Name: ' + APIThing.UserName );
end;

procedure Tfrm_Main.Button15Click(Sender: TObject);
begin
   ShowMessage( 'Computer Name: ' + APIThing.ComputerName );
end;

procedure Tfrm_Main.Button16Click(Sender: TObject);
begin
   ShowMessage('Executable for C:\boot.ini is:'#13#10 + APIThing.FindExecutable('C:\boot.ini'));
end;

procedure Tfrm_Main.Button18Click(Sender: TObject);
begin
   ShowMessage( APIThing.GetUniversalName( 'S' ) );
end;

procedure Tfrm_Main.Button21Click(Sender: TObject);
begin
   ShowMessage( APIThing.OSVersion );
end;

procedure Tfrm_Main.Button17Click(Sender: TObject);
var
   s1, s2 : String;
   x      : TFixedFileInfo;
begin
   x := APIThing.FileInfo( Application.ExeName );
   s1 := APIThing.GetFileInformation( Application.ExeName, 'InternalName' );
   s2 := 'Version: ' + IntToStr( x.wFileVersionLS ) + '.' + IntToStr( x.wFileVersionMS ) +
         ' (Build: '  + IntToStr( x.wProductVersionMS ) + ')'#13#10'Release: ' +
         IntToStr( x.wProductVersionLS);

   APIThing.ShellAbout( s1, s2 );
end;

procedure Tfrm_Main.Button22Click(Sender: TObject);
begin
   APIThing.FormatDrive( 'a' );
end;

procedure Tfrm_Main.Button23Click(Sender: TObject);
begin
   with APIThing do
   begin
      ShowMessage( 'Memory Availability'#13#10 +
                   'Memory Utilization: ' + IntToStr( dwMemoryLoad )+ '%'#13#10 +
                   'Total bytes of physical memory: ' + IntToStr( dwTotalPhys ) + #13#10 +
                   'Physical memory available: ' + IntToStr( dwAvailPhys ) + #13#10 +
                   'Total number of bytes that can be stored in the paging file: ' + IntToStr( dwTotalPageFile ) + #13#10 +
                   'Bytes available in the paging file: ' + IntToStr( dwAvailPageFile ) + #13#10 +
                   'Total number of bytes that can be described in the user mode portion of the virtual address space of the calling process: ' + IntToStr( dwTotalVirtual ) + #13#10 +
                   'Bytes of unreserved and uncommitted memory in the user mode portion of the virtual address space of the calling process: ' + IntToStr( dwAvailVirtual )
                 );
   end; // with APIThing
end;

procedure Tfrm_Main.Button24Click(Sender: TObject);
var
   dtDriveType  : TDriveType;
   strDriveType : String;
   drive        : Char;
begin
   drive := 'a';
   dtDriveType := APIThing.DriveType( drive );
   case dtDriveType of
      dtUnknown : strDriveType := 'Unknown';
      dtNoDrive : strDriveType := 'Not A Drive';
      dtFloppy  : strDriveType := 'FDD';
      dtFixed   : strDriveType := 'HDD';
      dtNetwork : strDriveType := 'Network Drive';
      dtCDROM   : strDriveType := 'CD-ROM';
      dtRAM     : strDriveType := 'RAM Drive';
   end; // case APIThing.DriveType;
   ShowMessage( 'Drive ' + drive +' is a ''' + strDriveType + ''' drive' );
end;

procedure Tfrm_Main.Button25Click(Sender: TObject);
begin
   APIThing.ShutDown;
end;

procedure Tfrm_Main.Button26Click(Sender: TObject);
begin
   with APIThing do
      ShowMessage(
                    'Page Size: ' + IntToStr( PageSize ) + #13#10 +
                    'Active Processor Mask: ' + IntToStr( ActiveProcessorMask ) + #13#10 +
                    'Number of Processors: ' + IntToStr( NumberOfProcessors ) + #13#10 +
                    'Processor Type: ' + IntToStr( ProcessorType ) + #13#10 +
                    'Allocation Granularity: ' + IntToStr( AllocationGranularity ) + #13#10 +
                    'Processor Level: ' + IntToStr( ProcessorLevel )+ #13#10 +
                    'Processor Revision: ' + IntToStr( ProcessorRevision )
                 );
end;

procedure Tfrm_Main.FormDestroy(Sender: TObject);
begin
   APIThing.Free;
end;

end.