ioboardtestunit.pas

在Windows 2000或者XP系统下的ISA接口卡测试程序的完整代码

unit IOBoardTestUnit;

interface

uses
  Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms,
  Dialogs, ExtCtrls, StdCtrls, Buttons, Spin, WinSvc;

const
  PORTTALK_TYPE = 40000; { 32768-65535是保留给用户使用的}
  METHOD_BUFFERED = 0;
  FILE_ANY_ACCESS = 0;
  IOCTL_IOPM_RESTRICT_ALL_ACCESS  = PORTTALK_TYPE shl 16 +
    $900 shl 2 +
    METHOD_BUFFERED +
    FILE_ANY_ACCESS shl 14;

  IOCTL_IOPM_ALLOW_EXCUSIVE_ACCESS = PORTTALK_TYPE shl 16 +
    $901 shl 2 +
    METHOD_BUFFERED +
    FILE_ANY_ACCESS shl 14;

  IOCTL_SET_IOPM = PORTTALK_TYPE shl 16 +
    $902 shl 2 +
    METHOD_BUFFERED +
    FILE_ANY_ACCESS shl 14;

  IOCTL_ENABLE_IOPM_ON_PROCESSID = PORTTALK_TYPE shl 16 +
    $903 shl 2 +
    METHOD_BUFFERED +
    FILE_ANY_ACCESS shl 14;

  IOCTL_READ_PORT_UCHAR = PORTTALK_TYPE shl 16 +
    $904 shl 2 +
    METHOD_BUFFERED +
    FILE_ANY_ACCESS shl 14;

  IOCTL_WRITE_PORT_UCHAR = PORTTALK_TYPE shl 16 +
    $905 shl 2 +
    METHOD_BUFFERED +
    FILE_ANY_ACCESS shl 14;

type
TConvertType = (ctByte,ctWord,ctLongword);
TRandomType = (rtByte,rtWord,rtLongword);
TAutoTestMode = (atmOff,atmCounter,atmRandom,atmScanMove,atmCycleMove,atmPointMove,
                 atmBit1,atmBit2,atmBit3,atmBit4);
TCodeEditPos = (cepNull,cepBin,cepHex,cepDec);

type
  TForm1 = class(TForm)
    Panel1: TPanel;
    Panel2: TPanel;
    Panel3: TPanel;
    Panel4: TPanel;
    BitBtnExit: TBitBtn;
    GroupBox1: TGroupBox;
    EditOut1a: TEdit;
    LabelOut1a: TLabel;
    EditIn1a: TEdit;
    LabelIn1a: TLabel;
    BitBtnOut1: TBitBtn;
    CheckBoxGroup1: TCheckBox;
    BitBtnIn1: TBitBtn;
    EditIOBase: TEdit;
    LabelIOBase: TLabel;
    GroupBox2: TGroupBox;
    LabelOut2a: TLabel;
    LabelIn2a: TLabel;
    EditOut2a: TEdit;
    EditIn2a: TEdit;
    BitBtnOut2: TBitBtn;
    CheckBoxGroup2: TCheckBox;
    BitBtnIn2: TBitBtn;
    GroupBox3: TGroupBox;
    LabelOut3a: TLabel;
    LabelIn3a: TLabel;
    EditOut3a: TEdit;
    EditIn3a: TEdit;
    BitBtnOut3: TBitBtn;
    CheckBoxGroup3: TCheckBox;
    BitBtnIn3: TBitBtn;
    GroupBox4: TGroupBox;
    LabelOut4a: TLabel;
    LabelIn4a: TLabel;
    EditOut4a: TEdit;
    EditIn4a: TEdit;
    BitBtnOut4: TBitBtn;
    CheckBoxGroup4: TCheckBox;
    BitBtnIn4: TBitBtn;
    GroupBox5: TGroupBox;
    LabelOut5a: TLabel;
    LabelIn5a: TLabel;
    EditOut5a: TEdit;
    EditIn5a: TEdit;
    BitBtnOut5: TBitBtn;
    CheckBoxGroup5: TCheckBox;
    BitBtnIn5: TBitBtn;
    GroupBox6: TGroupBox;
    LabelOut6a: TLabel;
    LabelIn6a: TLabel;
    EditOut6a: TEdit;
    EditIn6a: TEdit;
    BitBtnOut6: TBitBtn;
    CheckBoxGroup6: TCheckBox;
    BitBtnIn6: TBitBtn;
    GroupBox7: TGroupBox;
    LabelOut7a: TLabel;
    LabelIn7a: TLabel;
    EditOut7a: TEdit;
    EditIn7a: TEdit;
    BitBtnOut7: TBitBtn;
    CheckBoxGroup7: TCheckBox;
    BitBtnIn7: TBitBtn;
    GroupBox8: TGroupBox;
    EditCount: TEdit;
    LabelCount: TLabel;
    SpeedButton1: TSpeedButton;
    SpeedButton2: TSpeedButton;
    SpeedButton3: TSpeedButton;
    SpeedButton4: TSpeedButton;
    SpeedButton5: TSpeedButton;
    SpeedButton6: TSpeedButton;
    SpeedButton7: TSpeedButton;
    SpeedButton8: TSpeedButton;
    Timer1: TTimer;
    LabelOut1b: TLabel;
    LabelIn1b: TLabel;
    LabelIn2b: TLabel;
    LabelOut2b: TLabel;
    LabelIn3b: TLabel;
    LabelOut3b: TLabel;
    LabelIn4b: TLabel;
    LabelOut4b: TLabel;
    LabelIn6b: TLabel;
    LabelOut6b: TLabel;
    LabelIn7b: TLabel;
    LabelOut7b: TLabel;
    LabelIn5b: TLabel;
    EditOut1b: TEdit;
    LabelOut5c: TLabel;
    EditOut5b: TEdit;
    EditOut2b: TEdit;
    EditOut3b: TEdit;
    EditOut4b: TEdit;
    EditOut6b: TEdit;
    LabelOut6c: TLabel;
    EditOut7b: TEdit;
    LabelOut7c: TLabel;
    BitBtnReset: TBitBtn;
    SpinEdit1: TSpinEdit;
    LabelInterval: TLabel;
    SpeedButton9: TSpeedButton;
    SpeedButton10: TSpeedButton;
    EditMoveMap: TEdit;
    LabelPointMap: TLabel;
    SpeedButton11: TSpeedButton;
    SpeedButton12: TSpeedButton;
    EditOut5c: TEdit;
    LabelIn5c: TLabel;
    LabelOut5b: TLabel;
    EditOut1c: TEdit;
    EditIn1b: TEdit;
    LabelIn1c: TLabel;
    EditIn1c: TEdit;
    EditIn2b: TEdit;
    EditIn2c: TEdit;
    LabelIn2c: TLabel;
    EditIn3b: TEdit;
    EditIn3c: TEdit;
    LabelIn3c: TLabel;
    EditIn4b: TEdit;
    EditIn4c: TEdit;
    LabelIn4c: TLabel;
    EditIn6b: TEdit;
    EditIn6c: TEdit;
    LabelIn6c: TLabel;
    EditIn7b: TEdit;
    EditIn7c: TEdit;
    LabelIn7c: TLabel;
    EditOut2c: TEdit;
    EditOut3c: TEdit;
    EditOut4c: TEdit;
    EditOut6c: TEdit;
    EditOut7c: TEdit;
    EditIn5b: TEdit;
    EditIn5c: TEdit;
    procedure FormCreate(Sender: TObject);
    procedure FormDestroy(Sender: TObject);
    procedure FormShow(Sender: TObject);
    procedure BitBtnExitClick(Sender: TObject);
    procedure Timer1Timer(Sender: TObject);
    procedure EditOut1aKeyPress(Sender: TObject; var Key: Char);
    procedure EditOut1bKeyPress(Sender: TObject; var Key: Char);
    procedure EditOut1aChange(Sender: TObject);
    procedure EditOut1bChange(Sender: TObject);
    procedure BitBtnResetClick(Sender: TObject);
    procedure SpinEdit1Change(Sender: TObject);
    procedure SpeedButton1Click(Sender: TObject);
    procedure SpeedButton2Click(Sender: TObject);
    procedure SpeedButton3Click(Sender: TObject);
    procedure SpeedButton4Click(Sender: TObject);
    procedure SpeedButton5Click(Sender: TObject);
    procedure SpeedButton6Click(Sender: TObject);
    procedure SpeedButton7Click(Sender: TObject);
    procedure SpeedButton8Click(Sender: TObject);
    procedure EditIOBaseChange(Sender: TObject);
    procedure SpeedButton9Click(Sender: TObject);
    procedure SpeedButton10Click(Sender: TObject);
    procedure EditMoveMapChange(Sender: TObject);
    procedure SpeedButton11Click(Sender: TObject);
    procedure SpeedButton12Click(Sender: TObject);
    procedure BitBtnOut1Click(Sender: TObject);
    procedure BitBtnIn1Click(Sender: TObject);
    procedure EditOut1cChange(Sender: TObject);
    procedure EditOut1cKeyPress(Sender: TObject; var Key: Char);
    procedure EditOut5cKeyPress(Sender: TObject; var Key: Char);
    procedure EditOut1cMouseDown(Sender: TObject; Button: TMouseButton;
      Shift: TShiftState; X, Y: Integer);
    procedure EditOut1bMouseDown(Sender: TObject; Button: TMouseButton;
      Shift: TShiftState; X, Y: Integer);
    procedure EditOut1aMouseDown(Sender: TObject; Button: TMouseButton;
      Shift: TShiftState; X, Y: Integer);
  private
    IOBaseAddr : word;
    TestCount : Longint;
    CodeEditPos : TCodeEditPos;
    PointAddCount : integer;
    ByteCounter : byte;
    WordCounter : word;
    MoveByte : byte;
    MoveWord : word;
    MoveMap  : ShortString;
    MoveMapLen : integer;
    ByteMoveToLeft : boolean;
    WordMoveToLeft : boolean;
    ATBool : boolean;
    MToLeft : boolean;
    AutoTestMode : TAutoTestMode;
    procedure BinConvertHexDec(BinEdit,HexEdit,DecEdit: TEdit; ConvertType: TConvertType);
    procedure HexConvertBinDec(HexEdit,BinEdit,DecEdit: TEdit; ConvertType: TConvertType);
    procedure DecConvertBinHex(DecEdit,BinEdit,HexEdit: TEdit; ConvertType: TConvertType);
    function GetRandomWord(RandomType: TRandomType): word;
    procedure WriteTestCodeToPorts(ByteValue: byte; WordValue: word);
    procedure ResetTestCode;
    procedure AutoTest;
  public
    { Public declarations }
  end;

const
CByteBit1 : byte = $aa;
CWordBit1 : word = $aaaa;
CByteBit2 : byte = $cc;
CWordBit2 : word = $cccc;
CByteBit3 : byte = $f0;
CWordBit3 : word = $f0f0;
CByteBit4 : byte = $ff;
CWordBit4 : word = $ffff;

var
  Form1: TForm1;

implementation

{$R *.dfm}

var
  PortTalk_Handle: THandle = 0;  {PortTalk句柄}
  IOPM_isOpen : boolean = false;

// ------------------------ I/O Function ---------------------------

function CopyPathName(FullName: string): string;
var
i : integer;
begin
 for i := Length(FullName) downto 1 do
  if FullName[i] = '\' then begin
   result := Copy(FullName,1,i);
   exit;
  end;
 result := '';
end;

function GetAppDir: string;
var
SPathStr : ShortString;
begin
 SPathStr := CopyPathName(ParamStr(0));
 SetLength(SPathStr,Length(SPathStr) - 1);
 result := SPathStr;
end;

function InstallPortTalkDriver : boolean;
var
SchSCManager:SC_HANDLE;
SchService:SC_HANDLE;
TDrvFileName : ShortString;
SDrvFileName : ShortString;
begin
 result := true;
 if GetSystemDirectory(@TDrvFileName[1],200) = 0 then exit;
 SetLength(TDrvFileName,StrLen(@TDrvFileName[1]));
 if TDrvFileName[Length(TDrvFileName)] <> '\' then
  TDrvFileName := TDrvFileName + '\Drivers\PortTalk.sys' else
  TDrvFileName := TDrvFileName + 'Drivers\PortTalk.sys';
 SDrvFileName := GetAppDir;
 if SDrvFileName[Length(SDrvFileName)] <> '\' then
  SDrvFileName := SDrvFileName + '\PortTalk.sys' + #0#0 else
  SDrvFileName := SDrvFileName + 'PortTalk.sys' + #0#0;
 if not FileExists(TDrvFileName) then begin
  TDrvFileName := TDrvFileName + #0#0;
  if not CopyFile(@SDrvFileName[1],@TDrvFileName[1],false) then begin
   result := false;
   exit;
  end;
 end else TDrvFileName := TDrvFileName + #0#0;
 SchSCManager := OpenSCManager(nil,nil,SC_MANAGER_ALL_ACCESS);
 if SchSCManager = 0 then begin
  result := false;
  exit;
 end;
 SchService := CreateService(SchSCManager,                     { SCManager数据库 }
                             'PortTalk',                        { 服务个数 }
                             'PortTalk',                        { 显示名 }
                             SERVICE_ALL_ACCESS,                { 权限 }
                             SERVICE_KERNEL_DRIVER,             { 服务类别 }
                             SERVICE_DEMAND_START,              { 启动类别 }
                             SERVICE_ERROR_NORMAL,              { 出错控件类别 }
                             @TDrvFileName[1],
                             nil,nil,nil,nil,nil);
 CloseServiceHandle(SchSCManager);
 if SchService = 0 then begin
  result := false;
  exit;
 end;
end;

function StartPortTalkDriver: boolean;
type
TNewStartService = function (hService: SC_HANDLE; dwNumServiceArgs: DWORD;
                            lpServiceArgVectors: PPChar): BOOL; stdcall;
var
i : integer;
SchSCManager: SC_HANDLE;
schService: SC_HANDLE;
ret: BOOL;
err: DWORD;
begin
 SchSCManager := OpenSCManager(nil,nil,SC_MANAGER_ALL_ACCESS);
 if (SchSCManager = 0) then
 if (GetLastError = ERROR_ACCESS_DENIED) then begin
  result := false;
  exit;
 end;
 i := 0;
 repeat
  schService := OpenService(SchSCManager,'PortTalk',SERVICE_ALL_ACCESS);
  if (schService = 0) then begin
   case (GetLastError) of
    ERROR_ACCESS_DENIED:
       begin
        ShowMessage('PortTalk: 没有权限访问 PortTalk 服务数据库');
        result := false;
        exit;
       end;
    ERROR_INVALID_NAME:
       begin
        ShowMessage('PortTalk: 指定的服务名无效');
        result := false;
        exit;
       end;
    ERROR_SERVICE_DOES_NOT_EXIST:
       begin
        ShowMessage('PortTalk: PortTalk 驱动程序不存在');
        InstallPortTalkDriver;
        if i > 3 then begin
         result := false;
         exit;
        end;
        inc(i);
       end;
   end;
  end;
 until (schService <> 0);
 ret := TNewStartService(@StartService)(schService,0,nil); { 参数 }
 if not ret then begin
  err := GetLastError;
  if not (err = ERROR_SERVICE_ALREADY_RUNNING) then begin
   ShowMessage('PortTalk: 启动 PortTalk 时发生未知错误。'+#$D#$A+
               'PortTalk.sys 没有放入 \System32\Drivers 目录吗?');
   result:=false;
   exit;
  end;
 end;
 CloseServiceHandle(schService);
 result := true;
end;

function OpenPortTalk: boolean;
begin
 PortTalk_Handle := CreateFile('\\.\PortTalk',
                               GENERIC_READ,
                               0,
                               nil,
                               OPEN_EXISTING,
                               FILE_ATTRIBUTE_NORMAL,
                               0);
 if(PortTalk_Handle = INVALID_HANDLE_VALUE) then begin
  StartPortTalkDriver;
  PortTalk_Handle := CreateFile('\\.\PortTalk',
                                GENERIC_READ,
                                0,
                                nil,
                                OPEN_EXISTING,
                                FILE_ATTRIBUTE_NORMAL,
                                0);
  if(PortTalk_Handle = INVALID_HANDLE_VALUE) then begin
   result := false;
   exit;
  end;
 end;
 result := true;
end;

procedure ClosePortTalk;
begin
 CloseHandle(PortTalk_Handle);
end;

function OpenCurProcessIOAllAccess(CurWnd: THandle): boolean;
var
BytesReturned : DWORD;
ProcessId : DWORD;
begin
 result := false;
 if not OpenPortTalk then exit;
 if not DeviceIoControl(PortTalk_Handle,
                        Cardinal(IOCTL_IOPM_RESTRICT_ALL_ACCESS),
                        nil,
                        0,
                        nil,
                        0,
                        BytesReturned,
                        nil) then begin
  ClosePortTalk;
  exit;
 end;
 if not DeviceIoControl(PortTalk_Handle,
                        Cardinal(IOCTL_IOPM_ALLOW_EXCUSIVE_ACCESS),
                        nil,
                        0,
                        nil,
                        0,
                        BytesReturned,
                        nil) then begin
  ClosePortTalk;
  exit;