ioboardtestunit.pas

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

 end;
 GetWindowThreadProcessId(CurWnd,@ProcessId);
 if not DeviceIoControl(PortTalk_Handle,
                        Cardinal(IOCTL_ENABLE_IOPM_ON_PROCESSID),
                        @ProcessId,
                        4,
                        nil,
                        0,
                        BytesReturned,
                        nil) then begin
  ClosePortTalk;
  exit;
 end;
 ClosePortTalk;
 sleep(300);
 result := true;
end;

function OpenCurrentProcessIOAllAccess(PID: THandle): boolean;
var
BytesReturned : 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;
 end;
 if not DeviceIoControl(PortTalk_Handle,
                        Cardinal(IOCTL_ENABLE_IOPM_ON_PROCESSID),
                        @PID,
                        4,
                        nil,
                        0,
                        BytesReturned,
                        nil) then begin
  ClosePortTalk;
  exit;
 end;
 ClosePortTalk;
 sleep(300);
 result := true;
end;

function OutPortB(PortAddress:word;byte1:byte): boolean;
var
RCode: boolean;
BytesReturned: DWORD;
Buffer: array[0..2] of byte;
pBuffer: pword;
begin
 pBuffer := pword(@Buffer[0]);
 pBuffer^ := PortAddress;
 Buffer[2] := byte1;
 RCode := DeviceIoControl(PortTalk_Handle,
                          Cardinal(IOCTL_WRITE_PORT_UCHAR),
                          @Buffer,
                          3,
                          nil,
                          0,
                          BytesReturned,
                          nil);
 result := not RCode;
end;

function InPortB(PortAddress: word; var Error: boolean): byte;
var
RCode: boolean;
BytesReturned: DWORD;
Buffer: array[0..2]of byte;
pBuffer: pword;
begin
 pBuffer := pword(@Buffer[0]);
 pBuffer^ := PortAddress;
 RCode := DeviceIoControl(PortTalk_Handle,
                         cardinal(IOCTL_READ_PORT_UCHAR),
                         @Buffer,
                         2,
                         @Buffer,
                         1,
                         BytesReturned,
                         nil);
 Error := not RCode;
 Result := Buffer[0];
end;

function OpenIOPM: boolean;
var
CurProcessID  : THandle;
begin
 result := false;
 CurProcessID := GetCurrentProcessID;
 if CurProcessID <> 0 then begin
  IOPM_isOpen := OpenCurrentProcessIOAllAccess(CurProcessID);
  if IOPM_isOpen then begin
   result := true;
   Sleep(3);
  end;
 end;
end;

function BinToByte(s : string) : byte;
var
w,i,j : byte;
begin
 w := 0;
 j := 1;
 for i := Length(s) downto 1 do begin
  w := w + (ord(s[i]) - 48) * j;
  j := j * 2;
 end;
 result := w
end;

function ByteToHex(num: byte): string;
var
numhi,numlo : byte;
begin
 numlo := num   and  $0f;
 numhi := (num shr 4) and $0f;
 if numhi <= 9 then char(numhi) := chr(ord('1') + numhi - 1)
               else char(numhi) := chr(ord('A') + numhi - 10);
 if numlo <= 9 then char(numlo) := chr(ord('1') + numlo - 1)
               else char(numlo) := chr(ord('A') + numlo - 10);
 result := char(numhi) + char(numlo);
end;

function ByteBinToHex(ByteBin: string): string;
begin
 result := ByteToHex(BinToByte(ByteBin));
end;


procedure WriteByteToPort(IOAddr: word; Value: byte);
begin
 asm
  mov dx,IOAddr
  mov al,Value
  out dx,al
 end;
end;

procedure WriteWordToPort(IOAddr: word; Value: word);
begin
 asm
  mov dx,IOAddr
  mov ax,Value
  out dx,ax
 end;
end;

function ReadByteFromPort(IOAddr: word): byte;
begin
 asm
  mov dx,IOAddr
  in  al,dx
  mov result,al
 end;
end;

function ReadWordFromPort(IOAddr: word): word;
begin
 asm
  mov dx,IOAddr
  in  ax,dx
  mov result,ax
 end;
end;

// ---------------------- Event function --------------------------------

procedure TForm1.FormCreate(Sender: TObject);
begin
 if not OpenIOPM then begin
  ShowMessage('无法为当前程序打开 I/O 访问权！');
  Halt;
 end;
 IOBaseAddr := $390;
 TestCount := 0;
 MoveMap := '110';
 MoveMapLen := 3;
 MToLeft := true;
 EditMoveMap.Text := MoveMap;
 CodeEditPos := cepBin;
 ResetTestCode;
 AutoTestMode := atmOff;
end;

procedure TForm1.FormDestroy(Sender: TObject);
begin
{}
end;

procedure TForm1.FormShow(Sender: TObject);
begin
{}
end;

procedure TForm1.BitBtnExitClick(Sender: TObject);
begin
 Timer1.Enabled := false;
 Close;
end;

procedure TForm1.Timer1Timer(Sender: TObject);
begin
 AutoTest;
end;

procedure TForm1.EditOut1aKeyPress(Sender: TObject; var Key: Char);
begin
 if (Key <> '0') and (Key <> '1') and (Key <> Char($08)) then Key := Char($00);
end;

procedure TForm1.EditOut1bKeyPress(Sender: TObject; var Key: Char);
begin
 if (not (Key in ['0'..'9'])) and
    (not (UpCase(Key) in ['A'..'F'])) and
    (Key <> Char($08)) then Key := Char($00);
end;

procedure TForm1.EditOut1cKeyPress(Sender: TObject; var Key: Char);
begin
 if (not (Key in ['0'..'9'])) and
    (Key <> Char($08)) then Key := Char($00) else begin
  if (Key <> Char($08)) and (StrToInt(TEdit(Sender).Text + key) > 255) then Key := Char($00);
 end;
end;

procedure TForm1.EditOut5cKeyPress(Sender: TObject; var Key: Char);
begin
 if (not (Key in ['0'..'9'])) and
    (Key <> Char($08)) then Key := Char($00) else begin
  if (Key <> Char($08)) and (StrToInt(TEdit(Sender).Text + key) > 65535) then Key := Char($00);
 end;
end;

procedure TForm1.EditOut1aMouseDown(Sender: TObject; Button: TMouseButton;
  Shift: TShiftState; X, Y: Integer);
begin
 CodeEditPos := cepBin;
end;

procedure TForm1.EditOut1bMouseDown(Sender: TObject; Button: TMouseButton;
  Shift: TShiftState; X, Y: Integer);
begin
 CodeEditPos := cepHex;
end;

procedure TForm1.EditOut1cMouseDown(Sender: TObject; Button: TMouseButton;
  Shift: TShiftState; X, Y: Integer);
begin
 CodeEditPos := cepDec;
end;

function FillNumber0(Str: string; NLength: byte): string;
var
i : byte;
begin
 result := '';
 if Length(Str) < NLength then
  for i := 1 to NLength - Length(Str) do result := result + '0';
 result := result + Str;
end;

function WordToHex(num: word): string;
var
nummsbhi,nummsblo,numlsbhi,numlsblo : byte;
begin
 numlsblo := num  and  $000f;
 numlsbhi := (num shr 4) and $000f;
 nummsblo := (num shr 8) and $000f;
 nummsbhi := (num shr 12) and $000f;
 if numlsblo <= 9 then
  char(numlsblo) := chr(ord('1') + numlsblo - 1)
  else
  char(numlsblo) := chr(ord('A') + numlsblo - 10);
 if numlsbhi <= 9 then
  char(numlsbhi) := chr(ord('1') + numlsbhi - 1)
  else
  char(numlsbhi) := chr(ord('A') + numlsbhi - 10);
 if nummsblo <= 9 then
  char(nummsblo) := chr(ord('1') + nummsblo - 1)
  else
  char(nummsblo) := chr(ord('A') + nummsblo - 10);
 if nummsbhi <= 9 then
  char(nummsbhi) := chr(ord('1') + nummsbhi - 1)
  else
  char(nummsbhi) := chr(ord('A') + nummsbhi - 10);
 result := char(nummsbhi) + char(nummsblo) +
           char(numlsbhi) + char(numlsblo);
end;

function BinToWord(s: string): word;
var
w,i,j : word;
begin
 w := 0;
 j := 1;
 for i := Length(s) downto 1 do begin
  w := w + (ord(s[i]) - 48) * j;
  j := j * 2;
 end;
 result := w
end;

function WordBinToHex(WordBin: string): string;
begin
 result := WordToHex(BinToWord(WordBin));
end;

procedure TForm1.BinConvertHexDec(BinEdit,HexEdit,DecEdit: TEdit; ConvertType: TConvertType);
begin
 case ConvertType of
  ctByte: if Length(BinEdit.Text) >= 8 then begin
           HexEdit.Text := ByteBinToHex(BinEdit.Text);
           DecEdit.Text := FillNumber0(IntToStr(BinToByte(BinEdit.Text)),3);
          end;
  ctWord: if Length(BinEdit.Text) >= 16 then begin
           HexEdit.Text := WordBinToHex(BinEdit.Text);
           DecEdit.Text := FillNumber0(IntToStr(BinToWord(BinEdit.Text)),5);
          end;
 end;
end;

procedure TForm1.EditOut1aChange(Sender: TObject);
begin
 if CodeEditPos = cepBin then begin
  if Sender = EditOut1a then BinConvertHexDec(EditOut1a,EditOut1b,EditOut1c,ctByte) else
  if Sender = EditOut2a then BinConvertHexDec(EditOut2a,EditOut2b,EditOut2c,ctByte) else
  if Sender = EditOut3a then BinConvertHexDec(EditOut3a,EditOut3b,EditOut3c,ctByte) else
  if Sender = EditOut4a then BinConvertHexDec(EditOut4a,EditOut4b,EditOut4c,ctByte) else
  if Sender = EditOut5a then BinConvertHexDec(EditOut5a,EditOut5b,EditOut5c,ctWord) else
  if Sender = EditOut6a then BinConvertHexDec(EditOut6a,EditOut6b,EditOut6c,ctByte) else
  if Sender = EditOut7a then BinConvertHexDec(EditOut7a,EditOut7b,EditOut7c,ctByte);
 end;
end;

function ByteToBin(wordnum : byte) : string;
const
CLength = 8;
var
i   : byte;
num : word;
wordstr : string[9];
begin
 num := 1;
 for i := CLength downto 1 do begin
  if (wordnum and num) <> 0 then wordstr[i] := '1' else wordstr[i]:= '0';
  num := num * 2;
 end;
 SetLength(wordstr,CLength);
 result := wordstr;
end;

function HexToByte(str: ShortString): byte;
var
strhi,strlo : char;
begin
 if Length(str) < 2 then begin
  strlo := str[1];
  strhi := '0';
 end else begin
  strhi := str[1];
  strlo := str[2];
 end;
 if strhi in ['0'..'9'] then
  byte(strhi) := ord(strhi) - ord('0') else
 if Upcase(strhi) in ['A'..'F'] then
  byte(strhi) := ord(strhi) - ord('A') + 10 else begin
  result := 0;
  exit;
 end;
 if strlo in ['0'..'9'] then
  byte(strlo) := ord(strlo) - ord('0') else
 if Upcase(strlo) in ['A'..'F'] then
  byte(strlo) := ord(strlo) - ord('A') + 10 else begin
  result := 0;
  exit;
 end;
 result := ((byte(strhi) shl 4) and $f0) or (byte(strlo) and $0f);
end;

function ByteHexToBin(ByteHex: string): string;
begin
 result := ByteToBin(HexToByte(ByteHex));
end;

function WordToBin(wordnum : word): string;
const
CLength = 16;
var
i : byte;
num : word;
wordstr : string[17];
begin
 num := 1;
 for i := CLength downto 1 do begin
  if (wordnum and num) <> 0 then wordstr[i] := '1' else wordstr[i]:= '0';
  num := num * 2;
 end;
 SetLength(wordstr,CLength);
 result := wordstr;
end;

function CharOrd(inchar :char): byte;
begin
 if inchar in ['0'..'9'] then
    result := ord(inchar) - ord('0') else
 if Upcase(inchar) in ['A'..'F'] then
    result := ord(inchar) - ord('A') + 10 else
    result := 0;
end;

function HexToWord(str: ShortString): Word;
var
wordhi,wordlo     : word;
strmsbhi,strmsblo : char;
strlsbhi,strlsblo : char;
begin
 case Length(str) of
   0:  begin
        strlsblo := '0'; strlsbhi := '0';
        strmsblo := '0'; strmsbhi := '0';
       end;
   1 : begin
        strlsblo := str[1]; strlsbhi := '0';
        strmsblo := '0';       strmsbhi := '0';
       end;
   2 : begin
        strlsblo := str[2]; strlsbhi := str[1];
        strmsblo := '0';       strmsbhi := '0';
        end;
   3 : begin
        strlsblo := str[3]; strlsbhi := str[2];
        strmsblo := str[1]; strmsbhi := '0';
       end;
   4 : begin
        strlsblo := str[4]; strlsbhi := str[3];
        strmsblo := str[2]; strmsbhi := str[1];
       end;