Composant tlptport avec fonction out & inp + gestion de la mémoire physique

Télécharger le projet
Commenter

Description

mise à jour importante désormais c'est un composant permettant le dialogue avec le port parallèle LPT, cette mise à jour inclus notamment la prise en charge des OS Windows 9x/NT/2000 and XP et ce grâce au driver WinIO de chez http://www.internals.com

on m'a demander récemment comment faire pour avoir l'adresse du Port LPT, effectivement ce n'est pas aussi simple car d'habitude il faut aller voir le BIOS...
maintenant c'est une histoire ancienne le composant va chercher les Ports en lisant la mémoire physique, en effet les valeurs des Ports sont stockés à l'adresse [$0040:$0008] seulement voilà là il sagit d'une adresse logique, j'ai donc dû rajouter une fonction qui calcule l'adresse Physique à partir de l'adresse Logique "MakeMemLoc", bon le nom n'est peut être pas assez explicite :)

maintenant on peut aussi énuméré les Ports LPT

Source / Exemple : 


unit LPTPort;

interface
Uses
Windows , Classes, SysUtils, Dialogs;

(***********************************************************************************************)
(*  Author  : Shining-Freeman                                                                  *)
(*  Date    : 25/04/2003                                                                       *)
(*  Release : 10/03/2006                                                                       *)
(*  Purpose : contrôler le port parallèle                                                      *)
(***********************************************************************************************)

{
 Historiques :

 10/03/2006 : Ajout de
            SelectPort(Addr   : WORD); équivaut à LPTport := Addr
            SelectPortByIndex(PortIndex : Integer); choisit le port en fonction du combobox
            GetPhysDWORD(Addr : DWORD ; var Return : DWORD):Boolean; Lecture de la Mémoire Physique en DWORD=LongWord
            SetPhysDWORD(Addr : DWORD ; Value : DWORD):Boolean; écriture de la Mémoire Physique
            EnumPorts(Strings : TStrings);overload; énumération des Ports disponibles dans un Combobox;
            EnumPorts;overload; // énumération des Ports dans la List(TCollection)
            MakeMemLoc(Offset : DWORD ; Segment : DWORD): DWORD; transforme une adresse logique en adresse physique [xx:xx]
}

  Const
  Version = 'Bêta 1.3';

  Type

  TPinKind =
  (
  pkD0,
  pkD1,
  pkD2,
  pkD3,
  pkD4,
  pkD5,
  pkD6,
  pkD7
  );
  TPinKinds = Set of TPinKind;

  TPinInfo = record
  Name   : String;
  Kind   : TPinKind;
  Offset : Byte;
  end;

  Const
  { Table d'adressage des PIN's D0..D7
   Nota : sur le port parallele D0 est situé sur le pin 1
  }
  TPinLookUp : array[0..7] of TPinInfo=(
  (Name : 'D0' ; Kind : pkD0 ; Offset : $1),
  (Name : 'D1' ; Kind : pkD1 ; Offset : $2),
  (Name : 'D2' ; Kind : pkD2 ; Offset : $4),
  (Name : 'D3' ; Kind : pkD3 ; Offset : $8),
  (Name : 'D4' ; Kind : pkD4 ; Offset : $10),
  (Name : 'D5' ; Kind : pkD5 ; Offset : $20),
  (Name : 'D6' ; Kind : pkD6 ; Offset : $40),
  (Name : 'D7' ; Kind : pkD7 ; Offset : $80)
  );

  Type

  TOnPinChange = procedure (Sender : TObject ; Info : TPinInfo ; State : Boolean) of Object;

  TLPTList      = class;
  TLPTListItems = class;

  TLPTList = class(TCollection)
  private
    { Déclarations privées }
    FItemIndex : Integer;
    function GetItem (Index : Integer): TLPTListItems;
    procedure SetItem (Index : Integer ; Value : TLPTListItems);
  public
    { Déclarations publiques }
    ItemFind : TLPTListItems;
    Constructor Create;
    Destructor Destroy;override;
    function Add: TLPTListItems;
    function ItemExist (ItemName : String): Boolean;
    function ItemOf (ItemName : String): TLPTListItems;
    property Items[Index : Integer] : TLPTListItems read GetItem write SetItem; default;
    property ItemIndex : integer read FItemIndex write FItemIndex;
  published
  end;

  
  TLPTListItems = class(TCollectionItem)
  private
    { Déclarations privées }
    FName : String;
    FPort : WORD;
  protected
    { Déclarations protégées }
    Parent : TLPTList;
  public
    { Déclarations publiques }
    Constructor Create (Collection : TCollection);override;
    Destructor  Destroy;override;
    procedure   Assign (Source : TPersistent);override;
  published
    property    Name : String  read FName write FName;
    property    Port : WORD    read FPort write FPort;
  end;

  TLPTPort = class(TComponent)
  private
    FInitialized : Boolean;
    FDLLHandle   : THandle;
    FPort        : Word;
    { calcule des sommes pour les pins D0..D7}
    FPinHash     : Integer;
    FLS          : array[0..7] of Boolean;//Led State
    FOnPinChange : TOnPinChange;
    FInpOffset   : Integer;
    FUpdate      : Boolean;
    FPorts       : TLPTList;
    procedure   NotifyPinChange(Name : String ; State : Boolean);
    procedure   LoadSysDrivers;
    procedure   FreeSysDrivers;
    function    GetBytePort  (Addr : Word): Byte;
    function    GetDWordPort (Addr : Word): DWord;
    function    GetWordPort  (Addr : Word): Word;
    procedure   SetBytePort  (Addr : Word; const Value: Byte);
    procedure   SetDWordPort (Addr : Word; const Value: DWord);
    procedure   SetWordPort  (Addr : Word; const Value: Word);
    procedure   SetD0(const Value: Boolean);
    procedure   SetD1(const Value: Boolean);
    procedure   SetD2(const Value: Boolean);
    procedure   SetD3(const Value: Boolean);
    procedure   SetD4(const Value: Boolean);
    procedure   SetD5(const Value: Boolean);
    procedure   SetD6(const Value: Boolean);
    procedure   SetD7(const Value: Boolean);
    function    GetD0: Boolean;
    function    GetD1: Boolean;
    function    GetD2: Boolean;
    function    GetD3: Boolean;
    function    GetD4: Boolean;
    function    GetD5: Boolean;
    function    GetD6: Boolean;
    function    GetD7: Boolean;
    procedure   SetPorts(const Value : TLPTList);
  protected
    procedure   InitializeDrivers;
    procedure   FinalizeDrivers;
  public
    Constructor Create(AOwner : TComponent);override;
    Destructor  Destroy;override;
    procedure   BeginUpdate;
    procedure   EndUpdate;

    function    Open:Boolean;
    function    Close:Boolean;
    procedure   ClearPins;

    procedure   SetPin  (Name  : String; State : Boolean = true);
    procedure   SetPins (Names : array of String);

    procedure   SelectPort(Addr   : WORD);
    procedure   SelectPortByIndex(PortIndex : Integer);
    function    GetPhysDWORD(Addr : DWORD ; var Return : DWORD):Boolean;
    function    SetPhysDWORD(Addr : DWORD ; Value : DWORD):Boolean;

    procedure   EnumPorts(Strings : TStrings);overload;
    procedure   EnumPorts;overload;

    { fonction de sortie
      Out utiliser LPTPort pour l'accès
      OutP permet de spécifié un port
    }
    function    Out (Value : Byte):Boolean;overload;
    function    Out (Value : Word):Boolean;overload;
    function    Out (Value : DWord):Boolean;overload;

    function    Inp   : Byte;
    function    InpW  : Word;
    function    InpDW : DWord;

    function    OutP (Addr : Word; Value : Byte):Boolean;overload;
    function    OutP (Addr : Word; Value : Word):Boolean;overload;
    function    OutP (Addr : Word; Value : DWord):Boolean;overload;

    function    InpP  (Addr : Word) : Byte;
    function    InpWP (Addr : Word) : Word;
    function    InpDWP(Addr : Word) : DWord;

    property    Port   [Addr : Word] : Byte  read GetBytePort  write SetBytePort;
    property    PortW  [Addr : Word] : Word  read GetWordPort  write SetWordPort;
    property    PortDW [Addr : Word] : DWord read GetDWordPort write SetDWordPort;

    property    D0 : Boolean read GetD0 write SetD0;
    property    D1 : Boolean read GetD1 write SetD1;
    property    D2 : Boolean read GetD2 write SetD2;
    property    D3 : Boolean read GetD3 write SetD3;
    property    D4 : Boolean read GetD4 write SetD4;
    property    D5 : Boolean read GetD5 write SetD5;
    property    D6 : Boolean read GetD6 write SetD6;
    property    D7 : Boolean read GetD7 write SetD7;

    property    Initialized : Boolean   read FInitialized;
    property    Ports       : TLPTList  read FPorts write SetPorts;
  published
    property    LPTPort     : Word         read FPort        write FPort;

    {
     Inp normalement Inp = Base + 1 pour lire l'état
     donc inp vaut 1 par défaut, lors de l'appel à la fonction Inp, celle-ci renvoie inp(Port + LptInp);
    }
    property    InpOffset   : Integer      read FInpOffset   write FInpOffset default 1;

    property    OnPinChange : TOnPinChange read FOnPinChange write FOnPinChange;
  end;

{$R LPTPort.dcr}

function PinNameToPinInfo(Name  : String; var Info : TPinInfo):Boolean;
function PinValToPinKinds(Value : Byte):TPinKinds;
function GetDir:String;// revient au même que ExtractFilePath mais sans utiliser Application.ExeName(dans Forms)
function DecToBin(Value : Integer ; nBits : Integer = 8): String;
function HexToBin(Value : String  ; nBits : Integer = 8):String;
function IsNumeric(Value : String):Boolean;

{
 Make Memory Location
 permet d'avoir l'équivalent de la fonction TurboPascal MemW[xx:xx]
 Seulement cette fonction ne fait que calculer l'adresse physique à partir de l'adresse logique, et ne fournis aucun accès à celle-ci
 Exemple
 l'adresse logique [0040:0008] contient l'adresse du port de LPT1
 et donc son adresse physique est $408;

 autre exemple
 [$2135:$4A] correspond à l'adresse Physique $2139A
}

function MakeMemLoc(Offset : DWORD ; Segment : DWORD): DWORD;

procedure Register;

implementation

procedure Register;
begin
    RegisterComponents('SFC I/O' , [TLPTPort]);
end;

   Type
   TDriverInfo = record
   Name    : String;
   ResName : String;
   end;

   Const
   TDrivers : array [0..2] of TDriverInfo = (
   (Name : 'WinIO.dll' ; ResName : 'WIDL'), // noyau  Sys <> OS
   (Name : 'WinIO.sys' ; ResName : 'WISY'), //  pour Win2000,XP,NT
   (Name : 'WinIO.vxd' ; ResName : 'WIVX')  //  pour Win95,98
   );

  {
   Déclaration de la DLL WinIO.dll
  }
   var
   InitializeWinIo     : function : Boolean;stdcall;
   ShutdownWinIo       : function : Boolean;stdcall;
   MapPhysToLin        : function (var pbPhysAddr: Byte; dwPhysSize : Integer; var pPhysicalMemoryHandle : THandle):PByte;
   UnmapPhysicalMemory : function (PhysicalMemoryHandle : THandle; var pbLinAddr: Byte): Boolean;
   GetPhysLong         : function (pbPhysAddr : DWORD;  var pdwPhysVal  : DWORD): Boolean;stdcall;
   SetPhysLong         : function (pbPhysAddr : DWORD; dwPhysVal  : DWORD): Boolean;stdcall;
   GetPortVal          : function (wPortAddr : Word; var pdwPortVal : Integer; bSize: Byte): Boolean;stdcall;
   SetPortVal          : function (wPortAddr : Word; dwPortVal: Integer; bSize: Byte): Boolean;stdcall;
   InstallWinIoDriver  : function (pszWinIoDriverPath: PChar; IsDemandLoaded : Boolean = False): Boolean;stdcall;
   RemoveWinIoDriver   : function  : Boolean;stdcall;
   StartWinIoDriver    : function  : Boolean;stdcall;
   StopWinIoDriver     : function  : Boolean;stdcall;

function  PinNameToPinInfo(Name : String; var Info : TPinInfo):Boolean;
var
I : Integer;
begin
    result := False;
    for i := Low(TPinLookUp) To High(TPinLookUp) do
    begin
        if SameText(Name , TPinLookUp[i].Name) then
        begin
            Info := TPinLookUp[i];
            result := True;
            Break;
        end;
    end;
end;

function PinValToPinKinds(Value : Byte):TPinKinds;
var
i   : Integer;
Pin : TPinInfo;
begin
    result := [];
    for i := Low(TPinLookUp) to High(TPinLookUp) do
    begin
        Pin := TPinLookup[i];
        if (Value and Pin.Offset) = Pin.Offset then
        result := result + [Pin.Kind];
    end;
end;

function GetDir:String;
begin
    result := GetCurrentDir + '\';
end;

function DecToBin(Value : Integer ; nBits : Integer = 8): String;
var
  i : Integer;
  C : Char;
begin
    Result := '';
    for i := nBits-1 downto 0 do
    begin
        C := '0';
        if  (Value and (1 shl i)<>0)  then C := '1';
        result := result + C;
    end;
end;

function HexToBin(Value : String ; nBits : Integer = 8):String;
begin
    result := DecToBin(StrToInt('$' + Value), nBits);
end;

function IsNumeric(Value : String):Boolean;
var
P : PChar;
begin
    result := False;
    P := PChar(Value);
    while (P^<>#0) do
    begin
        if P^ in ['0'..'9', 'A'..'F', 'a'..'f'] then
        result := true else
        begin
            result := false;
            break;
        end;
        inc(P);
    end;
end;

function MakeMemLoc(Offset : DWORD ; Segment : DWORD): DWORD;
begin
    Offset  := (Offset shl 4) and $FFFFFFFF;
    Segment := Segment  and $FFFFFFFF;
    result  := Offset + Segment;
end;
{ TLPTPort }

function TLPTPort.Close: Boolean;
begin
    result := ShutDownWinIO;
end;

constructor TLPTPort.Create(AOwner: TComponent);
begin
    inherited Create(AOwner);
    FInitialized := False;
    FDLLHandle   := 0;
    FPort        := $378; // Base
    FInpOffset   := 1;    // Base + 1 = Status register
    FUpdate      := False;
    FPorts       := TLPTList.Create; 
    LoadSysDrivers;
    InitializeDrivers;
end;

destructor TLPTPort.Destroy;
begin
    FinalizeDrivers;
    FreeSysDrivers;
    FPorts.Free; 
    inherited Destroy;
end;

function TLPTPort.GetBytePort(Addr: Word): Byte;
begin
    result := InpP(Addr);
end;

function TLPTPort.GetDWordPort(Addr: Word): DWord;
begin
    result := InpDWP(Addr);
end;

function TLPTPort.GetWordPort(Addr: Word): Word;
begin
    result := InpWP(Addr);
end;

function TLPTPort.Inp : Byte;
var
Ret : Integer;
begin
    result := 0;
    if GetPortVal(FPort  + FInpOffset , Ret , 1) then
    result := (Ret and $FF);
end;

function TLPTPort.InpW : Word;
var
Ret : Integer;
begin
    result := 0;
    if GetPortVal(FPort + FInpOffset , Ret , 2) then
    result := (Ret and $FFFF);
end;

procedure TLPTPort.InitializeDrivers;
begin
    FDLLHandle           := LoadLibrary(PChar(TDrivers[0].Name));
    @InitializeWinIo     := GetProcAddress(FDLLHandle,'InitializeWinIo');
    @ShutdownWinIo       := GetProcAddress(FDLLHandle,'ShutdownWinIo');
    @MapPhysToLin        := GetProcAddress(FDLLHandle,'MapPhysToLin');
    @UnmapPhysicalMemory := GetProcAddress(FDLLHandle,'UnmapPhysicalMemory');
    @GetPhysLong         := GetProcAddress(FDLLHandle,'GetPhysLong');
    @SetPhysLong         := GetProcAddress(FDLLHandle,'SetPhysLong');
    @GetPortVal          := GetProcAddress(FDLLHandle,'GetPortVal');
    @SetPortVal          := GetProcAddress(FDLLHandle,'SetPortVal');
    @InstallWinIoDriver  := GetProcAddress(FDLLHandle,'InstallWinIoDriver');
    @RemoveWinIoDriver   := GetProcAddress(FDLLHandle,'RemoveWinIoDriver');
    @StartWinIoDriver    := GetProcAddress(FDLLHandle,'StartWinIoDriver');
    @StopWinIoDriver     := GetProcAddress(FDLLHandle,'StopWinIoDriver');
end;

function TLPTPort.InpDW: DWord;
var
Ret : Integer;
begin
    result := 0;
    if  GetPortVal(FPort + FInpOffset , Ret , 4) then
    result := (Ret and $FFFFFFFF);
end;

function TLPTPort.Open: Boolean;
begin
    FInitialized := InitializeWinIo;
    result       := FInitialized;
end;

function TLPTPort.Out(Value: Byte): Boolean;
begin
    result := SetPortVal(FPort , Value, 1);
end;

function TLPTPort.Out(Value: Word): Boolean;
begin
    result := SetPortVal(FPort , Value, 2);
end;

function TLPTPort.Out(Value: DWord): Boolean;
begin
    result := SetPortVal(FPort , Value, 4);
end;

procedure TLPTPort.SetBytePort(Addr: Word; const Value: Byte);
begin
    OutP(Addr, Value);
end;

procedure TLPTPort.SetDWordPort(Addr: Word; const Value: DWord);
begin
    OutP(Addr, Value);
end;

procedure TLPTPort.SetWordPort(Addr: Word; const Value: Word);
begin
    OutP(Addr, Value);
end;

procedure TLPTPort.FreeSysDrivers;
var
i : integer;
begin
    for i := Low(TDrivers) to High(TDrivers) do
    DeleteFile(GetDir + TDrivers[i].Name);
end;

procedure TLPTPort.LoadSysDrivers;
var
I   : Integer;
Res : TResourceStream;
FileName : String;
begin
    { Extraction du Driver depuis le ressource LPTPort.dcr }
    res := nil;
    for i := Low(TDrivers) to High(TDrivers) do
    begin
        FileName := GetDir + TDrivers[i].Name;
        if FileExists(FileName)=False then
        begin
            try
            Res := TResourceStream.Create(hInstance , TDrivers[i].ResName , 'WINIO');
            Res.SaveToFile (FileName);
            { fichier caché }
            SetFileAttributes(PChar(FileName), FILE_ATTRIBUTE_SYSTEM + FILE_ATTRIBUTE_HIDDEN);
            finally
            Res.Free;
            end;
        end;//File doesn't exists
    end;//i++
end;

procedure TLPTPort.FinalizeDrivers;
begin
    FreeLibrary(FDLLHandle);
end;

procedure TLPTPort.SetPin(Name: String; State: Boolean = true);
var
Info : TPinInfo;
begin
    if PinNameToPinInfo(Name, Info) then
    begin
        Case Info.Kind of
        pkD0 : D0 := State;
        pkD1 : D1 := State;
        pkD2 : D2 := State;
        pkD3 : D3 := State;
        pkD4 : D4 := State;
        pkD5 : D5 := State;
        pkD6 : D6 := State;
        pkD7 : D7 := State;
        end;
    end;
end;

procedure TLPTPort.SetD0(const Value: Boolean);
begin
    if FLS[0] <> Value then
    begin
        FLS[0] := Value;
        NotifyPinChange('D0' , Value);
    end;
end;

procedure TLPTPort.NotifyPinChange(Name: String; State: Boolean);
var
Info : TPinInfo;
begin
    if PinNameToPinInfo(Name , Info) then
    begin
        if Assigned(FOnPinChange) then FOnPinChange(Self , Info , State);

        case State of
        True  :
        begin
            Inc(FPinHash , Info.Offset);
        end;

        False :
        begin
            Dec(FPinHash , Info.Offset);
        end;

        end;
        if FUpdate = False then
        Out(FPinHash);
    end;//Pin Found
end;

procedure TLPTPort.SetD1(const Value: Boolean);
begin
    if FLS[1] <> Value then
    begin
        FLS[1] := Value;
        NotifyPinChange('D1' , Value);
    end;
end;

procedure TLPTPort.SetD2(const Value: Boolean);
begin
    if FLS[2] <> Value then
    begin
        FLS[2] := Value;
        NotifyPinChange('D2' , Value);
    end;
end;

procedure TLPTPort.SetD3(const Value: Boolean);
begin
    if FLs[3] <> Value then
    begin
        FLS[3] := Value;
        NotifyPinChange('D3' , Value);
    end;
end;

procedure TLPTPort.SetD4(const Value: Boolean);
begin
    if FLS[4] <> Value then
    begin
        FLS[4] := Value;
        NotifyPinChange('D4' , Value);
    end;
end;

procedure TLPTPort.SetD5(const Value: Boolean);
begin
    if FLS[5] <> Value then
    begin
        FLS[5] := Value;
        NotifyPinChange('D5' , Value);
    end;
end;

procedure TLPTPort.SetD6(const Value: Boolean);
begin
    if FLS[6] <> Value then
    begin
        FLS[6] := Value;
        NotifyPinChange('D6' , Value);
    end;
end;

procedure TLPTPort.SetD7(const Value: Boolean);
begin
    if FLS[7] <> Value then
    begin
        FLS[7] := Value;
        NotifyPinChange('D7' , Value);
    end;
end;

function TLPTPort.GetD0: Boolean;
begin
    result := (Inp and $1) = $1; 
end;

function TLPTPort.GetD1: Boolean;
begin
    result := (Inp and $2) = $2;
end;

function TLPTPort.GetD2: Boolean;
begin
    result := (Inp and $4) = $4;
end;

function TLPTPort.GetD3: Boolean;
begin
    result := (Inp and $8) = $8;
end;

function TLPTPort.GetD4: Boolean;
begin
    result := (Inp and $10) = $10;
end;

function TLPTPort.GetD5: Boolean;
begin
    result := (Inp and $20) = $20;
end;

function TLPTPort.GetD6: Boolean;
begin
    result := (Inp and $40) = $40;
end;

function TLPTPort.GetD7: Boolean;
begin
    result := (Inp and $80) = $80;
end;

function TLPTPort.OutP(Addr: Word; Value: Byte): Boolean;
begin
    result := SetPortVal(Addr , Value, 1);
end;

function TLPTPort.OutP(Addr, Value: Word): Boolean;
begin
    result := SetPortVal(Addr , Value, 2);
end;

function TLPTPort.OutP(Addr: Word; Value: DWord): Boolean;
begin
    result := SetPortVal(Addr , Value, 4);
end;

function TLPTPort.InpDWP(Addr: Word): DWord;
var
Ret : Integer;
begin
    result := 0;
    if  GetPortVal(Addr + FInpOffset , Ret , 4) then
    result := (Ret and $FFFFFFFF);
end;

function TLPTPort.InpP(Addr: Word): Byte;
var
Ret : Integer;
begin
    result := 0;
    if GetPortVal(Addr + FInpOffset , Ret , 1) then
    result := (Ret and $FF);
end;

function TLPTPort.InpWP(Addr : Word): Word;
var
Ret : Integer;
begin
    result := 0;
    if GetPortVal(Addr + FInpOffset , Ret , 2) then
    result := (Ret and $FFFF);
end;

procedure TLPTPort.BeginUpdate;
begin
    FUpdate := True;
    
end;

procedure TLPTPort.EndUpdate;
begin
    if FUpdate then
    begin
        FUpdate := False;
        Out(FPinHash);
    end;
end;

procedure TLPTPort.SetPins(Names: array of String);
var
i     : Integer;
Info  : TPinInfo;
State : Boolean;
begin
    BeginUpdate;
    ClearPins;
    for i := Low(Names) to High(Names) do
    begin
        PinNameToPinInfo(Names[i] , Info);
        State := True;
        Case Info.Kind of
        pkD0 : D0 := State;
        pkD1 : D1 := State;
        pkD2 : D2 := State;
        pkD3 : D3 := State;
        pkD4 : D4 := State;
        pkD5 : D5 := State;
        pkD6 : D6 := State;
        pkD7 : D7 := State;
        end;//Case
    end;//i++
    EndUpdate;
end;

procedure TLPTPort.ClearPins;
begin
    D0 := False;
    D1 := False;
    D2 := False;
    D3 := False;
    D4 := False;
    D5 := False;
    D6 := False;
    D7 := False;
end;

function TLPTPort.GetPhysDWORD(Addr : DWORD; var Return : DWORD): Boolean;
begin
    Addr := Addr and $FFFFFFFF;
    result := GetPhysLong( Addr , Return );
    if result then Return := (Return and $FFFFFFFF);
end;

function TLPTPort.SetPhysDWORD(Addr, Value: DWORD): Boolean;
begin
    Addr   := (Addr  and $FFFFFFFF);
    Value  := (Value and $FFFFFFFF);
    result := SetPhysLong(Addr , Value);
end;

procedure TLPTPort.EnumPorts;
var
I          : Integer;
SearchBase : DWORD;
PortFind   : DWORD;
begin
    SearchBase := $408; // [$40:$008]
    Ports.Clear;
    for i := 1 to 3 do // LPT1 ... LPT3
    begin
        if GetPhysDWORD(SearchBase , PortFind) then
        begin
            PortFind := (PortFind and $FFFF);
            if (PortFind > 0) then
            begin
                with Ports.Add do
                begin
                    Name := Format('LPT%u' , [i]);
                    Port := PortFind;
                end;//with Ports.Add
            end;
        end;//if GetPhysique
        inc(SearchBase , 2);
    end;// i ++
end;

{ implementation of TLPTList }

function TLPTList.GetItem (Index : Integer): TLPTListItems;
begin
    result := TLPTListItems(inherited GetItem(Index));
end;

procedure TLPTList.SetItem (Index : Integer ; Value : TLPTListItems);
begin
    inherited SetItem(Index, Value);
end;

Constructor TLPTList.Create;
begin
    inherited Create(TLPTListItems);
end;

Destructor TLPTList.Destroy;
begin
    inherited Destroy;
end;

function TLPTList.Add: TLPTListItems;
begin
    result := TLPTListItems(inherited Add);
end;

function TLPTList.ItemExist (ItemName : String): Boolean;
var
I : Integer;
begin
    result := False;
    ItemIndex := -1;
    for i :=0 to Count -1 do
    begin
        if SameText(ItemName, Items[i].Name)  Then
         begin
             ItemIndex  := I;
             ItemFind   := Items[i];
             result     := True;
             Break;
         end;//Trouver
    end;//Fin de la boucle I
end;

function TLPTList.ItemOf (ItemName : String): TLPTListItems;
begin
    result := nil;
    if ItemExist(ItemName) Then
    result := Items[ItemIndex];
end;
  
  
{ implementation of TLPTListItems }

Constructor TLPTListItems.Create (Collection : TCollection);
begin
    inherited Create(Collection);
    Parent          := TLPTList(Collection);
    FPort           := 0;
end;

Destructor TLPTListItems.Destroy;
begin
    inherited Destroy;
end;

procedure TLPTListItems.Assign (Source : TPersistent);
begin
    if Source is TLPTListItems Then
    begin
        FName    := TLPTListItems(Source).FName;
        FPort    := TLPTListItems(Source).FPort;
    end else
    inherited;
end;

procedure TLPTPort.SetPorts(const Value: TLPTList);
begin
    FPorts.Assign(Value); 
end;

procedure TLPTPort.EnumPorts(Strings: TStrings);
var
i : Integer;
begin
    Strings.Clear;
    EnumPorts;    
    for i := 0 to Ports.Count -1 do
    Strings.Add(Ports[i].Name);
end;

procedure TLPTPort.SelectPort(Addr: WORD);
begin
    LPTPort := Addr; 
end;

procedure TLPTPort.SelectPortByIndex(PortIndex: Integer);
begin
    LPTPort := Ports[PortIndex].Port;
end;

end.

Conclusion :


l'utilisation du composant est très simple, d'ailleur vous n'êtes pas obliger d'installer le composant, vous pouvez le créé dynamiquement.

ce composant à été tester sur Windows 98 & XP Pro avec succès.

important !!!
si dans une de vos application vous devez lire la broche "busy", n'oubliez pas de mettre InpOffset = 1 si toute fois vous avez changer sa valeur

ensuite c'est simple la valeur du poids de busy est 128 une simple routine logique permet d'en lire l'état
exemple
InpOffset := 1;
if (Lpt.Inp and 128)=128 then ....
je rappel que Busy est activer à l'état 0

pas de bug pour le moment...
Télécharger le projet

Codes Sources

A voir également

S'inscrire maintenant

Vous n'êtes pas encore membre ?

inscrivez-vous, c'est gratuit et ça prend moins d'une minute !

Les membres obtiennent plus de réponses que les utilisateurs anonymes.

Le fait d'être membre vous permet d'avoir un suivi détaillé de vos demandes et codes sources.

Le fait d'être membre vous permet d'avoir des options supplémentaires.

Du même auteur (cs_shining)