porttestu1.pas

在Windows NT使用I/O端口,包括装载,开始,卸载驱动程序的函数.

unit PortTestU1;
{--------------------------------------------
Test program for exercising gwiopm permissions map driver,
used to allow direct I/O port programming under Win NT.

Revisions
---------
98-06-01 GW Changed to graphical "control panel" for IOPM window
98-05-20 GW Original

Copyright Graham Wideman
------------------------
This module is distributed as freeware, and may be freely used for any purpose.
I would appreciate a credit notice if this is useful in your work. Thanks.

Note that this work was greatly aided by demo code from:
Dale Roberts      (giveio.sys)
Paula Tomlinson   (LOADDRV)

------------------------------------------}

interface

uses
  Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs,
  StdCtrls, Menus;

type
  Tfm_Main = class(TForm)
    bt_ClearMemo: TButton;
    GroupBox1: TGroupBox;
    bt_Install: TButton;
    bt_Start: TButton;
    bt_Stop: TButton;
    bt_Remove: TButton;
    GroupBox2: TGroupBox;
    bt_OpenSCM: TButton;
    bt_CloseSCM: TButton;
    GroupBox3: TGroupBox;
    bt_Test: TButton;
    lb_OutBuf: TLabel;
    bt_DeviceOpen: TButton;
    bt_DeviceClose: TButton;
    bt_Version: TButton;
    mm_Results: TMemo;
    bt_IOPM: TButton;
    GroupBox5: TGroupBox;
    bt_ShowPorts: TButton;
    MainMenu1: TMainMenu;
    m_File: TMenuItem;
    m_Quit: TMenuItem;
    m_Help: TMenuItem;
    m_About: TMenuItem;
    GroupBox6: TGroupBox;
    bt_Spkr: TButton;
    bt_Video: TButton;
    procedure bt_InstallClick(Sender: TObject);
    procedure bt_OpenSCMClick(Sender: TObject);
    procedure bt_StartClick(Sender: TObject);
    procedure bt_StopClick(Sender: TObject);
    procedure bt_RemoveClick(Sender: TObject);
    procedure bt_DeviceTestClick(Sender: TObject);
    procedure bt_CloseSCMClick(Sender: TObject);
    procedure bt_DeviceOpenClick(Sender: TObject);
    procedure bt_VersionClick(Sender: TObject);
    procedure bt_DeviceCloseClick(Sender: TObject);
    procedure bt_ClearMemoClick(Sender: TObject);
    procedure bt_IOPMClick(Sender: TObject);
    procedure bt_ShowPortsClick(Sender: TObject);
    procedure m_QuitClick(Sender: TObject);
    procedure m_AboutClick(Sender: TObject);
    procedure FormCreate(Sender: TObject);
    procedure bt_SpkrClick(Sender: TObject);
    procedure bt_VideoClick(Sender: TObject);
  private
    { Private declarations }
  public
    { Public declarations }
    procedure DriverStatusMessage(Sender: TObject; Status: DWORD);
  end;

var
  fm_Main: Tfm_Main;

//----------------------------------------------------------------
implementation
uses gwportio, gwiopm, fm_IOPM1, fm_IOPort1, fm_About, fm_PCSpkr1,
  fm_VSync1;
{$R *.DFM}

//---------------------------------
procedure Tfm_Main.FormCreate(Sender: TObject);
//---------------------------------
begin
  Top := 100;
  Left := 100;
end;

//---------------------------------
procedure Tfm_Main.DriverStatusMessage(Sender: TObject; Status: DWORD);
//---------------------------------
Var
  S: string;
  Parent: TObject;
  PParen: integer;
Begin
  S := '';
  If Sender <> nil then
  Begin
    if Sender is TButton then
    Begin
      Parent := TButton(Sender).Parent;
      If Parent is TGroupBox then
      Begin
        S := TGroupBox(Parent).Caption;
        PParen := Pos('(',S);
        If PParen > 0 then S := Copy(S,1,PParen-1);
        S := S +'-- ';
      end;
      S := S + TButton(Sender).Caption+': ';
    end;
  end;
  S := S + GWIOPM_Driver.ErrorLookup(Status);
  // Lbl.Caption := S;

  mm_Results.Lines.Add(S);
end;

//=======================================================
// Service Control Manager
//=======================================================

//---------------------------------
procedure Tfm_Main.bt_OpenSCMClick(Sender: TObject);
//---------------------------------
Var
  Status: DWORD;
begin
  Status := GWIOPM_Driver.OpenSCM;
  DriverStatusMessage(Sender, Status);
end;

//---------------------------------
procedure Tfm_Main.bt_CloseSCMClick(Sender: TObject);
Var
  Status: DWORD;
//---------------------------------
begin
  Status := GWIOPM_Driver.CloseSCM;
  DriverStatusMessage(Sender, Status);
end;

//=======================================================
// Driver
//=======================================================

//---------------------------------
procedure Tfm_Main.bt_InstallClick(Sender: TObject);
//---------------------------------
Var
  Status: DWORD;
begin
  Status := GWIOPM_Driver.Install('');
  DriverStatusMessage(Sender, Status);
end;

//---------------------------------
procedure Tfm_Main.bt_StartClick(Sender: TObject);
//---------------------------------
Var
  Status: DWORD;
begin
  Status := GWIOPM_Driver.Start;
  DriverStatusMessage(Sender, Status);
end;

//---------------------------------
procedure Tfm_Main.bt_StopClick(Sender: TObject);
//---------------------------------
Var
  Status: DWORD;
begin
  Status := GWIOPM_Driver.Stop;
  DriverStatusMessage(Sender, Status);
end;

//---------------------------------
procedure Tfm_Main.bt_RemoveClick(Sender: TObject);
//---------------------------------
Var
  Status: DWORD;
begin
  Status := GWIOPM_Driver.Remove;
  DriverStatusMessage(Sender, Status);
end;

//=======================================================
// Device
//=======================================================

//---------------------------------
procedure Tfm_Main.bt_DeviceOpenClick(Sender: TObject);
//---------------------------------
Var
  Status: DWORD;
begin
  Status := GWIOPM_Driver.DeviceOpen;
  DriverStatusMessage(Sender, Status);
end;

//---------------------------------
procedure Tfm_Main.bt_DeviceCloseClick(Sender: TObject);
//---------------------------------
Var
  Status: DWORD;
begin
  Status := GWIOPM_Driver.DeviceClose;
  DriverStatusMessage(Sender, Status);
end;

//---------------------------------
procedure Tfm_Main.bt_DeviceTestClick(Sender: TObject);
//---------------------------------
Var
  Status, RetVal: DWORD;
begin
  lb_OutBuf.Caption := '---';
  Status := GWIOPM_Driver.IOCTL_IOPMD_READ_TEST(RetVal);
  DriverStatusMessage(Sender, Status);
  lb_OutBuf.Caption := IntToHex(RetVal,8);
end;

//---------------------------------
procedure Tfm_Main.bt_VersionClick(Sender: TObject);
//---------------------------------
Var
  Status, RetVal: DWORD;
begin
  lb_OutBuf.Caption := '---';
  Status := GWIOPM_Driver.IOCTL_IOPMD_READ_VERSION(RetVal);
  DriverStatusMessage(Sender, Status);
  lb_OutBuf.Caption := IntToStr(RetVal);
end;

//---------------------------------
procedure Tfm_Main.bt_ClearMemoClick(Sender: TObject);
//---------------------------------
begin
  mm_Results.Lines.Clear;
end;

//---------------------------------
procedure Tfm_Main.bt_IOPMClick(Sender: TObject);
//---------------------------------
begin
  fm_IOPM.Show;
  fm_IOPM.Left := Left+50;
  fm_IOPM.Top := Top+50;
end;

//---------------------------------
procedure Tfm_Main.bt_ShowPortsClick(Sender: TObject);
//---------------------------------
begin
  fm_IOPort.Show;
  fm_IOPort.Left := Left+100;
  fm_IOPort.Top := Top+100;
end;

//---------------------------------
procedure Tfm_Main.m_QuitClick(Sender: TObject);
//---------------------------------
begin
  Application.Terminate;
end;

//---------------------------------
procedure Tfm_Main.m_AboutClick(Sender: TObject);
//---------------------------------
begin
  AboutBox.ShowModal;
end;

//---------------------------------
procedure Tfm_Main.bt_SpkrClick(Sender: TObject);
//---------------------------------
begin
  fm_PCSpkr.Left := Left+100;
  fm_PCSpkr.Top := Top+100;
  fm_PCSpkr.Show;
end;

//---------------------------------
procedure Tfm_Main.bt_VideoClick(Sender: TObject);
//---------------------------------
begin
  fm_VSync.Left := Left+100;
  fm_VSync.Top := Top+100;
  fm_VSync.Show;
end;

end.