main.pas

关于利用DELPHI来进行企业级方案解决的著作的附书源码

 end;
 MyIniFile.Free;
 B_CloseDriverClick(Sender);
 Close;
end;

function HexToInt(s:String):dWord;
const hexch:array[0..15] of Char='0123456789ABCDEF';
var i,j : Byte;
    r,n,k:dWord;
    ch : Char;
begin
  k:=1; r:=0;
  for i:=Length(s) downto 1 do
  begin
    ch:=s[i]; n:=0;
    for j:=0 to 15 do if UpperCase(ch)=hexch[j] then n:=j;
    r:=r+n*k; if i>1 then k:=k*16;
  end;
  Result:=r;
end;

procedure TMainForm.GReadSelectCell(Sender: TObject; Col, Row: Longint;
  var CanSelect: Boolean);
begin
  with GRead do
  begin
    PortRSel:=HexToInt(Cells[1,Row]); NomRSel:=Row;
  end;
end;

procedure TMainForm.B_WriteClick(Sender: TObject);
begin
 with GWrite do
 begin
   PortWSel:=HexToInt(Cells[1,Row]);    Cells[1,Row]:=IntToHex(PortWSel,4);
   ValWSel:=HexToInt(Cells[2,Row]);     Cells[2,Row]:=IntToHex(ValWSel,2);
   NomWSel:=Row;
   if (PortWSel=0) then begin MessageBeep(0); Exit; end;
   SetPortByte(HwCtrl,PortWSel,ValWSel);
 end;
end;

procedure TMainForm.B_WriteAllClick(Sender: TObject);
var i,v       : Byte;
    P,N       : Word;
begin
 with GWrite do
 begin
   N:=0;
   for i:=1 to MaxPorts do
   begin
     P:=HexToInt(Cells[1,i]); Cells[1,i]:=IntToHex(P,4);
     if p>0 then
     begin
       V:=HexToInt(Cells[2,i]); Cells[2,i]:=IntToHex(v,2);
       Inc(N);
       PortRec[N].PortData:=V;
       PortRec[N].PortAddr:=P;
       PortRec[N].fWrite:=TRUE;
       SetPortByte(HwCtrl,P,V);
     end;
   end;
//   if N>0 then PortControl(@PortRec,N);
 end;
end;

procedure TMainForm.B_ReadClick(Sender: TObject);
var b : Byte;
begin
 with GRead do
 begin
   PortRSel:=HexToInt(Cells[1,Row]); Cells[1,Row]:=IntToHex(PortRSel,4);
   NomRSel:=Row;
   if (PortRSel=0) then begin MessageBeep(0); Exit; end;
   b:=GetPortByte(HwCtrl,PortRSel);
   Cells[2,Row]:=IntToHex(b,2);
 end;
end;

procedure TMainForm.B_ReadAllClick(Sender: TObject);
var i       : Byte;
    P,N     : Word;
    cl      : array[1..MaxPorts] of Byte;
begin
 with GRead do
 begin
   N:=0;
   for i:=1 to MaxPorts do
   begin
     P:=HexToInt(Cells[1,i]); Cells[1,i]:=IntToHex(P,4);
     if p>0 then
     begin
       Inc(N); cl[N]:=i;
       PortRec[N].PortAddr:=P;
       PortRec[N].fWrite:=FALSE;
       PortRec[N].PortData:=GetPortByte(HwCtrl,P);
     end;
   end;
//   if N>0 then PortControl(@PortRec,N);
   for i:=1 to N do
     Cells[2,cl[i]]:=IntToHex(PortRec[i].PortData,2);
 end;
end;

procedure TMainForm.B_SetMemoryClick(Sender: TObject);
begin
  PhysAddr:=HexToInt(E_Addr.text); E_Addr.Text:=IntToHex(PhysAddr,8);
  PointPhys:=TPointPhys(MapPhysToLinear(HwCtrl,PhysAddr,256));
  B_SetMemory.Enabled:=FALSE;
  ShowButtons;
end;

procedure TMainForm.B_ReadMemoryClick(Sender: TObject);
var CurrAddr,i,j : dWord;
    s            : String;
    b            : Byte;
    ch           : Char;
begin
  if PointPhys<>NIL then
  begin
    CurrAddr:=PhysAddr;
    for i:=1 to 16 do
    begin
      s:=IntToHex(CurrAddr,8); MemoHex.Cells[0,i]:=s; s:='';
      for j:=1 to 16 do s:=s+IntToHex(PointPhys^[i][j],2);
      MemoHex.Cells[1,i]:=s; s:='';
      for j:=1 to 16 do
      begin
        b:=PointPhys^[i][j];
        if b>=$20 then ch:=Char(b) else ch:='.';  s:=s+ch;
      end;
      MemoHex.Cells[2,i]:=s;
      CurrAddr:=CurrAddr+16;
    end;

  end;

end;

procedure TMainForm.E_AddrChange(Sender: TObject);
begin
  B_SetMemory.Enabled:=ActiveHW;;
end;

procedure TMainForm.Timer1Timer(Sender: TObject);
var nPin : Byte;
    i : Word;
    s : String;
begin
  with TextMemo do
  begin

//    L_Debug.caption:='DebugCode='+IntToStr(DebugCode);
    L_ScanCode.caption:=': '+IntToHex(Scan_Code,2)+'h';
    L_LPT_Data.caption:=': '+IntToHex(Data_Reg,2)+'h';
    L_LPT_STATUS.caption:=': '+IntToHex(Status_Reg,2)+'h';
    L_Timers.Caption:=IntToStr(Flag_tim div 1000);
    L_Flag.Caption:=IntToStr(Flag_Intr);
    if ActiveHW and (not IsIRQMasked(HwCtrl)) then
    begin
      CurrTicker:=GetTickCount;
      Flag_Tim:=Sum_Ticks+CurrTicker-OldTicker;
    end else  OldTicker:=GetTickCount;
    if ActiveHW then
    begin
      L_Gen.Caption:=IntToStr(IRQCounter);
      for nPin:=1 to 17 do
        CPinRead[nPin].Checked:=GetPin(HwCtrl,nPin);
      C_ACKWL.Checked := GetLPTAckwl(HwCtrl);
      C_Busy.Checked  := GetLPTBusy(HwCtrl);
      C_ERROR.Checked := GetLPTError(HwCtrl);
      C_PE.Checked    := GetLPTPaperEnd(HwCtrl);
      C_SLCT.Checked  := GetLPTSlct(HwCtrl);
    end
    else FlagPrint:=FALSE;


    if FlagPrint then
    begin
      Timer1.Enabled:=FALSE;
      for i:=1 to 100 do
      begin
        Application.ProcessMessages;
        s:=Lines[NumLine]+#$0D#$0A;
        if NumSymbol>Length(s) then
        begin
          if NumLine=Lines.Count then begin
                                        Timer1.Enabled:=TRUE;
                                        FlagPrint:=FALSE; Exit;
                                      end;
          Inc(NumLine);
          s:=Lines[NumLine]+#$0D#$0A;
          NumSymbol:=1;
        end;
        if LPTPrintChar(HwCtrl,Word(s[NumSymbol])) then Inc(NumSymbol);
      end;
      Timer1.Enabled:=TRUE;
    end;

    B_Stop.Enabled:=FlagPrint;
    B_Print.Enabled:=not FlagPrint;

  end;
end;

procedure TMainForm.B_MaskClick(Sender: TObject);
begin
  begin
    if not B_Mask.Checked then
    begin
      Sum_Ticks:=Flag_Tim;
      MaskIRQ(HwCtrl);
      SetPortByte(HwCtrl,GetLPTBasePort(HwCtrl)+2,0);
      C_LPT_IRQ.Checked:=FALSE;
    end
    else
    begin
      IRQ := SpinIRQ.Value;
      SetIRQ(HwCtrl,IRQ,OnHwInterrupt);
      Flag_Intr := 0;
      Sum_Ticks := 0;
      Flag_Tim  := 0;
      Scan_Code := 0;
      UnmaskIRQ(HwCtrl);
    end;
    ShowButtons;
  end;
end;

procedure TMainForm.SpinIRQChange(Sender: TObject);
begin
  IRQ:=SpinIRQ.Value;
  SetIRQ(HwCtrl,IRQ,OnHwInterrupt);
  ShowButtons;
end;

procedure TMainForm.B_FillMemoryClick(Sender: TObject);
var i,j : byte;
begin
  if PointPhys<>NIL then
  begin
    for i:=1 to 16 do
    begin
      for j:=1 to 16 do PointPhys^[i][j]:=16*(i-1)+j-1;
    end;
  end;
end;

procedure TMainForm.C_HardClick(Sender: TObject);
begin
  SetHardAccess(HwCtrl,C_Hard.Checked);
end;

procedure TMainForm.C_LPT_IRQClick(Sender: TObject);
begin
  begin
    if C_LPT_IRQ.Checked then SetPortByte(HwCtrl,GetLPTBasePort(HwCtrl)+2,$10)
                         else SetPortByte(HwCtrl,GetLPTBasePort(HwCtrl)+2,$00);
  end;
end;

procedure TMainForm.WPin1Click(Sender: TObject);
var nPin : Byte;
begin
  for nPin:=1 to 17 do
     SetPin(HwCtrl,nPin,BOOL(CPinWrite[nPin].Checked));
end;

procedure TMainForm.C_InitClick(Sender: TObject);
begin
  LPTInit(HwCtrl);
end;

procedure TMainForm.B_ClearClick(Sender: TObject);
begin
  TextMemo.Clear;
end;

procedure TMainForm.B_PrintClick(Sender: TObject);
begin
  with TextMemo do
  begin
    if FlagPrint then Exit;
    NumLine:=0;
    NumSymbol:=1;
    FlagPrint:=TRUE;
  end;
end;

procedure TMainForm.B_StopClick(Sender: TObject);
begin
  FlagPrint:=FALSE;
end;

procedure TMainForm.SpinLPTChange(Sender: TObject);
begin
  begin
    SetLPTNumber(HwCtrl,SpinLPT.Value);
  end;
  ShowButtons;
end;

procedure TMainForm.B_OpenClick(Sender: TObject);
begin
 HwCtrl:=0;
 HwCtrl:=OpenTVicHW32(HwCtrl);
//  L_Debug.caption:='DebugCode='+IntToStr(HwCtrl.DebugCode);
 if not GetActiveHW(HwCtrl) then
 begin
    MessageBeep(0);
    Application.MessageBox('The driver "VICHWxx" not found',
                           ' Warning! ',mb_OK or mb_ICONHAND);
 end
 else begin
         ActiveHW:=TRUE;
         SpinIRQ.Value:=IRQ;
         SetIRQ(HwCtrl,IRQ,OnHwInterrupt);
         Timer1.Enabled:=TRUE;
      end;
 B_SetMemory.Enabled:=TRUE;
 ShowButtons();
end;

procedure TMainForm.B_CloseDriverClick(Sender: TObject);
begin
  Timer1.Enabled:=FALSE;
  if ActiveHW then SetPortByte(HwCtrl,GetLPTBasePort(HwCtrl)+2,$00);
  C_LPT_IRQ.Checked:=FALSE;
  B_Mask.Checked:=FALSE;
  PointPhys:=NIL;
  B_SetMemory.Enabled:=FALSE;
  Flag_Intr:=0;
  ActiveHW:=FALSE;
  HwCtrl:=CloseTVicHW32(HwCtrl);
  ShowButtons;
end;

initialization
  NomWSel:=0; NomRSel:=0; PointPhys:=NIL; Flag_Intr:=0; Flag_tim:=0;
  Sum_Ticks:=0;CurrTicker:=0; OldTicker:=0;   Scan_Code := 0;
  FlagPrint:=FALSE; IRQCounter := 0;
  ActiveHW :=FALSE;  HwCtrl:=0;
end.