0/5 (13 avis)
Vue 21 913 fois - Téléchargée 1 852 fois
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.
19 mai 2010 à 20:45
source des logiciels d'application via le port LPT chat "avec Delphi
6 nov. 2006 à 09:17
j'utilise 3 pc d'ont 1 que j'utilise le w98 + delphi3 pour faire mes *.dll pour utiliser le port sur d'autre windows.
A+
8 mars 2006 à 01:17
@+
7 mars 2006 à 14:49
mise à jour importante effectivement puisque les drivers Winio prennent en charge XP ce qui n'était pas le cas précédemment.
bonne mise à jour qui manquait
@+
jlen
12 juil. 2004 à 04:22
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.