548 lines
20 KiB
ObjectPascal
548 lines
20 KiB
ObjectPascal
unit PCANdrvD;
|
|
//***************************************************************************************
|
|
// Project Name: TPCanDriver component for Borland Delphi
|
|
// Description: Encapsulates PCAN's Light driver into a VCL component for PCANUSB 1CH.
|
|
// File Name: PCANdrvD.pas
|
|
//
|
|
//---------------------------------------------------------------------------------------
|
|
// C O P Y R I G H T
|
|
//---------------------------------------------------------------------------------------
|
|
// Copyright (c) 2011 by Feaser http://www.feaser.com All rights reserved
|
|
//
|
|
// This software has been carefully tested, but is not guaranteed for any particular
|
|
// purpose. The author does not offer any warranties and does not guarantee the accuracy,
|
|
// adequacy, or completeness of the software and is not responsible for any errors or
|
|
// omissions or the results obtained from use of the software.
|
|
//
|
|
//---------------------------------------------------------------------------------------
|
|
// L I C E N S E
|
|
//---------------------------------------------------------------------------------------
|
|
// This file is part of OpenBLT. OpenBLT is free software: you can redistribute it and/or
|
|
// modify it under the terms of the GNU General Public License as published by the Free
|
|
// Software Foundation, either version 3 of the License, or (at your option) any later
|
|
// version.
|
|
//
|
|
// OpenBLT is distributed in the hope that it will be useful, but WITHOUT ANY WARRANTY;
|
|
// without even the implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR
|
|
// PURPOSE. See the GNU General Public License for more details.
|
|
//
|
|
// You should have received a copy of the GNU General Public License along with OpenBLT.
|
|
// If not, see <http://www.gnu.org/licenses/>.
|
|
//
|
|
// A special exception to the GPL is included to allow you to distribute a combined work
|
|
// that includes OpenBLT without being obliged to provide the source code for any
|
|
// proprietary components. The exception text is included at the bottom of the license
|
|
// file <license.html>.
|
|
//
|
|
//***************************************************************************************
|
|
interface
|
|
|
|
|
|
//***************************************************************************************
|
|
// Includes
|
|
//***************************************************************************************
|
|
uses
|
|
Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs, Pcan_usb;
|
|
|
|
|
|
//***************************************************************************************
|
|
// Type Definitions
|
|
//***************************************************************************************
|
|
type
|
|
TPCanChannel = ( pcanchannel0 );
|
|
TPCanHardware = ( PCAN_USB1CH );
|
|
TPCanDirection = ( PcanTx, PCanRx );
|
|
TPCanMessage = packed record
|
|
id : LongInt;
|
|
dlc : Byte;
|
|
data : array [0..7] of Byte;
|
|
time : LongInt;
|
|
ext : Boolean;
|
|
end;
|
|
|
|
type
|
|
TPCanMessageEvent = procedure( Sender: TObject; Direction: TPCanDirection; Message: TPCanMessage ) of object;
|
|
|
|
type
|
|
TPCanEventThread = class(TThread)
|
|
private
|
|
{ Private declarations }
|
|
FMethod: TThreadMethod;
|
|
protected
|
|
procedure Execute; override;
|
|
public
|
|
property Method : TThreadMethod read FMethod write FMethod;
|
|
end;
|
|
|
|
type
|
|
TPCanDriver = class(TComponent)
|
|
private
|
|
{ Private declarations }
|
|
FCanEventThread: TPCanEventThread;
|
|
FThreadRunning : boolean;
|
|
FCanConnected : boolean;
|
|
FStartTickCnt : DWORD;
|
|
function IsThreadRunning: boolean;
|
|
procedure ProcessReception;
|
|
protected
|
|
{ Protected declarations }
|
|
FBaudRate : LongInt;
|
|
FChannel : TPCanChannel;
|
|
FHardware : TPCanHardware;
|
|
FPriority : TThreadPriority;
|
|
FExtendedId : Boolean;
|
|
FOnMessage : TPCanMessageEvent;
|
|
procedure SetBaudRate( Value: LongInt );
|
|
procedure SetChannel( Value: TPCanChannel );
|
|
procedure SetHardware( Value: TPCanHardware );
|
|
procedure SetPriority( Value: TThreadPriority );
|
|
procedure SetExtendedId( Value: Boolean );
|
|
public
|
|
{ Public declarations }
|
|
constructor Create( AOwner: TComponent ); override;
|
|
destructor Destroy; override;
|
|
function Connect: boolean; virtual;
|
|
procedure Disconnect; virtual;
|
|
function Transmit( Message: TPCanMessage): boolean; virtual;
|
|
function IsConnected: boolean; virtual;
|
|
published
|
|
{ Published declarations }
|
|
property BaudRate : LongInt read FBaudRate write SetBaudRate default 500000;
|
|
property Channel : TPCanChannel read FChannel write SetChannel default pcanchannel0;
|
|
property Hardware : TPCanHardware read FHardware write SetHardware default PCAN_USB1CH;
|
|
property Priority : TThreadPriority read FPriority write SetPriority default tpNormal;
|
|
property ExtendedId : Boolean read FExtendedId write SetExtendedId default False;
|
|
property OnMessage : TPCanMessageEvent read FOnMessage write FOnMessage;
|
|
end;
|
|
|
|
|
|
//***************************************************************************************
|
|
// Prototypes
|
|
//***************************************************************************************
|
|
procedure Register;
|
|
|
|
implementation
|
|
//***************************************************************************************
|
|
// NAME: Execute
|
|
// PRECONDITIONS: none
|
|
// PARAMETER: none
|
|
// RETURN VALUE: none
|
|
// DESCRIPTION: Overriden Execute function for the CanEventThread. Calls and synchro-
|
|
// nizes with the TCanDriver.ProcessEvents function.
|
|
//
|
|
//***************************************************************************************
|
|
procedure TPCanEventThread.Execute;
|
|
begin
|
|
while not Terminated do
|
|
begin
|
|
if Assigned(Method) then // make sure TPCanDriver.ProcessEvents is set
|
|
Synchronize(Method); // call and synchronize
|
|
end;
|
|
end; //*** end of Execute ***
|
|
|
|
|
|
//***************************************************************************************
|
|
// NAME: Create
|
|
// PRECONDITIONS: none
|
|
// PARAMETER: AOwner : owner of the component
|
|
// RETURN VALUE: none
|
|
// DESCRIPTION: Component constructor. Calls TComponent's constructor and initializes
|
|
// the private property variables to their default values.
|
|
//
|
|
//***************************************************************************************
|
|
constructor TPCanDriver.Create( AOwner: TComponent );
|
|
begin
|
|
// call inherited constructor
|
|
inherited Create( AOwner );
|
|
|
|
// set defaults for internal variables
|
|
FThreadRunning := False;
|
|
FCanConnected := False;
|
|
|
|
// set defaults for properties
|
|
FBaudRate := 500000;
|
|
FChannel := pcanchannel0;
|
|
FHardware := PCAN_USB1CH;
|
|
FPriority := tpNormal;
|
|
FExtendedId := False;
|
|
end; //*** end of Create ***
|
|
|
|
|
|
//***************************************************************************************
|
|
// NAME: Destroy
|
|
// PRECONDITIONS: none
|
|
// PARAMETER: none
|
|
// RETURN VALUE: none
|
|
// DESCRIPTION: Component destructor. Calls TComponent's destructor
|
|
//
|
|
//***************************************************************************************
|
|
destructor TPCanDriver.Destroy;
|
|
begin
|
|
Disconnect; // close the port and driver
|
|
inherited Destroy; // call inherited destructor
|
|
end; //*** end of Destroy ***
|
|
|
|
|
|
//***************************************************************************************
|
|
// NAME: IsConnected
|
|
// PRECONDITIONS: none
|
|
// PARAMETER: none
|
|
// RETURN VALUE: True or False
|
|
// DESCRIPTION: Determines whether or not the CAN driver is connected and active
|
|
//
|
|
//***************************************************************************************
|
|
function TPCanDriver.IsConnected: boolean;
|
|
begin
|
|
Result := FCanConnected;
|
|
end; //*** end of IsConnected ***
|
|
|
|
|
|
//***************************************************************************************
|
|
// NAME: IsThreadRunning
|
|
// PRECONDITIONS: none
|
|
// PARAMETER: none
|
|
// RETURN VALUE: True or False
|
|
// DESCRIPTION: Determines whether or not the CAN event thread is running
|
|
//
|
|
//***************************************************************************************
|
|
function TPCanDriver.IsThreadRunning: boolean;
|
|
begin
|
|
if FThreadRunning = True then
|
|
Result := True
|
|
else
|
|
Result := False;
|
|
end; //*** end of IsThreadRunning ***
|
|
|
|
|
|
//***************************************************************************************
|
|
// NAME: SetBaudRate
|
|
// PRECONDITIONS: none
|
|
// PARAMETER: Value : new baudrate value [0 - 1000000 bps]
|
|
// RETURN VALUE: none
|
|
// DESCRIPTION: Configures the baudrate
|
|
//
|
|
// |------------------------------------------------------------------------------------
|
|
// | Update baudrate configuration
|
|
// |------------------------------------------------------------------------------------
|
|
//***************************************************************************************
|
|
procedure TPCanDriver.SetBaudRate( Value: LongInt );
|
|
begin
|
|
FBaudRate := Value; // update property
|
|
end; //*** end of SetBaudRate ***
|
|
|
|
|
|
//***************************************************************************************
|
|
// NAME: SetChannel
|
|
// PRECONDITIONS: none
|
|
// PARAMETER: Value : channel0 or channel1
|
|
// RETURN VALUE: none
|
|
// DESCRIPTION: Configures the used CAN channel
|
|
//
|
|
// |------------------------------------------------------------------------------------
|
|
// | Update channel configuration
|
|
// |------------------------------------------------------------------------------------
|
|
//***************************************************************************************
|
|
procedure TPCanDriver.SetChannel( Value: TPCanChannel );
|
|
begin
|
|
FChannel := Value;
|
|
end; //*** end of SetChannel ***
|
|
|
|
|
|
//***************************************************************************************
|
|
// NAME: SetHardware
|
|
// PRECONDITIONS: none
|
|
// PARAMETER: Value : type of CAN hardware (Virtual, CANcardXL, etc.)
|
|
// RETURN VALUE: none
|
|
// DESCRIPTION: Configures the used CAN hardware
|
|
//
|
|
// |------------------------------------------------------------------------------------
|
|
// | Update hardware configuration
|
|
// |------------------------------------------------------------------------------------
|
|
//***************************************************************************************
|
|
procedure TPCanDriver.SetHardware( Value: TPCanHardware );
|
|
begin
|
|
FHardware := Value;
|
|
end; //*** end of SetHardware ***
|
|
|
|
|
|
//***************************************************************************************
|
|
// NAME: SetPriority
|
|
// PRECONDITIONS: none
|
|
// PARAMETER: Value : thread priority
|
|
// RETURN VALUE: none
|
|
// DESCRIPTION: Configures the priority for the CAN event thread
|
|
//
|
|
// |------------------------------------------------------------------------------------
|
|
// | y\ Is Thread running? /n
|
|
// |------------------------------------------------------------------------------------
|
|
// | Stop Thread |
|
|
// | Update Thread priority | Update Thread priority
|
|
// | Restart Thread |
|
|
// |------------------------------------------------------------------------------------
|
|
//***************************************************************************************
|
|
procedure TPCanDriver.SetPriority( Value: TThreadPriority );
|
|
begin
|
|
if IsThreadRunning then
|
|
begin
|
|
FCanEventThread.Suspend; // suspend the thread
|
|
FPriority := Value; // update the priority
|
|
FCanEventThread.Resume; // resume the thread
|
|
end
|
|
else
|
|
begin
|
|
FPriority := Value; // update the priority
|
|
end;
|
|
end; //*** end of SetPriority ***
|
|
|
|
|
|
//***************************************************************************************
|
|
// NAME: SetExtendedId
|
|
// PRECONDITIONS: none
|
|
// PARAMETER: Value : true = support only 29-bit id's, false = support only 11-bit
|
|
// RETURN VALUE: none
|
|
// DESCRIPTION: Configures the support of extended 29-bit identifiers
|
|
//
|
|
// |------------------------------------------------------------------------------------
|
|
// | Update extended id support selection
|
|
// |------------------------------------------------------------------------------------
|
|
//***************************************************************************************
|
|
procedure TPCanDriver.SetExtendedId( Value: Boolean );
|
|
begin
|
|
FExtendedId := Value;
|
|
end; //*** end of SetExtendedId ***/
|
|
|
|
|
|
//***************************************************************************************
|
|
// NAME: Connect
|
|
// PRECONDITIONS: Disconnected from CAN bus
|
|
// PARAMETER: none
|
|
// RETURN VALUE: True or False for succees or error, respectively
|
|
// DESCRIPTION: Initializes the CAN driver and synchronizes the hardware with the CAN
|
|
// bus.
|
|
//
|
|
//***************************************************************************************
|
|
function TPCanDriver.Connect: boolean;
|
|
var
|
|
Baudcode : Word;
|
|
MsgType : Integer;
|
|
|
|
begin
|
|
Result := False;
|
|
FThreadRunning := False;
|
|
FCanConnected := False;
|
|
|
|
// convert baudrate in bps to supported baudrate code
|
|
Baudcode := CAN_BAUD_500K; // init local
|
|
case FBaudRate of
|
|
5000 : Baudcode := CAN_BAUD_5K;
|
|
10000 : Baudcode := CAN_BAUD_10K;
|
|
20000 : Baudcode := CAN_BAUD_20K;
|
|
33333 : Baudcode := $1D14;
|
|
50000 : Baudcode := CAN_BAUD_50K;
|
|
83333 : Baudcode := $4B14;
|
|
100000 : Baudcode := CAN_BAUD_100K;
|
|
125000 : Baudcode := CAN_BAUD_125K;
|
|
250000 : Baudcode := CAN_BAUD_250K;
|
|
500000 : Baudcode := CAN_BAUD_500K;
|
|
1000000 : Baudcode := CAN_BAUD_1M;
|
|
end;
|
|
|
|
// convert extented id info
|
|
if FExtendedId then
|
|
MsgType := 1
|
|
else
|
|
MsgType := 0;
|
|
|
|
//-------------------------- open the driver ------------------------------------------
|
|
if CAN_Init(Baudcode, MsgType) <> CAN_ERR_OK then Exit;
|
|
|
|
|
|
//-------------------------- open the acceptance filter --------------------------------
|
|
if CAN_ResetFilter <> CAN_ERR_OK then
|
|
begin
|
|
CAN_Close;
|
|
Exit;
|
|
end;
|
|
|
|
if FExtendedId then
|
|
begin
|
|
if CAN_MsgFilter($000, $1FFFFFFF, MSGTYPE_EXTENDED) <> CAN_ERR_OK then
|
|
begin
|
|
CAN_Close;
|
|
Exit;
|
|
end;
|
|
end
|
|
else
|
|
begin
|
|
if CAN_MsgFilter($000, $7FF, MSGTYPE_STANDARD) <> CAN_ERR_OK then
|
|
begin
|
|
CAN_Close;
|
|
Exit;
|
|
end;
|
|
end;
|
|
|
|
//-------------------------- reset message queues -------------------------------------
|
|
if CAN_ResetClient <> CAN_ERR_OK then
|
|
begin
|
|
CAN_Close;
|
|
Exit;
|
|
end;
|
|
|
|
//-------------------------- start CAN event thread -----------------------------------
|
|
FCanEventThread := TPCanEventThread.Create(True); // create and suspend
|
|
FCanEventThread.FreeOnTerminate := True; // auto free on termination
|
|
FCanEventThread.Method := ProcessReception; // set method
|
|
FCanEventThread.Resume; // start
|
|
FThreadRunning := True;
|
|
|
|
|
|
//-------------------------- store start time for time stamps -------------------------
|
|
FStartTickCnt := GetTickCount;
|
|
|
|
//-------------------------- success --------------------------------------------------
|
|
FCanConnected := True;
|
|
Result := True; // successfully initialized the driver
|
|
end; //*** end of Connect ***
|
|
|
|
|
|
//***************************************************************************************
|
|
// NAME: Disconnect
|
|
// PRECONDITIONS: none
|
|
// PARAMETER: none
|
|
// RETURN VALUE: none
|
|
// DESCRIPTION: Disconnects the CAN driver
|
|
//
|
|
//***************************************************************************************
|
|
procedure TPCanDriver.Disconnect;
|
|
begin
|
|
if IsConnected = True then // are we connected?
|
|
begin
|
|
FCanConnected := False;
|
|
// close the channel
|
|
CAN_Close;
|
|
end;
|
|
|
|
if IsThreadRunning then
|
|
begin
|
|
FCanEventThread.Terminate; // stop
|
|
FThreadRunning := False;
|
|
end;
|
|
end; //*** end of Disconnect ***
|
|
|
|
|
|
//***************************************************************************************
|
|
// NAME: Transmit
|
|
// PRECONDITIONS: Driver initialized using 'Connect'
|
|
// PARAMETER: Message: CAN message that is to be transmitted
|
|
// RETURN VALUE: True or False for succees or error, respectively
|
|
// DESCRIPTION: Transmits a CAN message.
|
|
//
|
|
//***************************************************************************************
|
|
function TPCanDriver.Transmit( Message: TPCanMessage): boolean;
|
|
var
|
|
cnt : Byte;
|
|
msg : TPCANMsg;
|
|
msgcpy : TPCanMessage;
|
|
begin
|
|
// make sure the CAN driver is connected
|
|
if not IsConnected then
|
|
begin
|
|
Result := False; // can't transmit it not connected
|
|
exit; // no need to continue
|
|
end;
|
|
|
|
// set the message identifier
|
|
msg.ID := Message.id;
|
|
if Message.ext then
|
|
msg.MSGTYPE := MSGTYPE_EXTENDED
|
|
else
|
|
msg.MSGTYPE := MSGTYPE_STANDARD;
|
|
|
|
// set the data length
|
|
msg.LEN := Message.dlc;
|
|
|
|
// store the data bytes
|
|
for cnt :=0 to Message.dlc do
|
|
begin
|
|
msg.DATA[cnt] := Message.data[cnt];
|
|
end;
|
|
|
|
// submit the transmit request
|
|
if CAN_Write(msg) <> CAN_ERR_OK then
|
|
begin
|
|
Result := False;
|
|
exit;
|
|
end;
|
|
|
|
//---------------- process transmission confirmation --------------------------
|
|
if Assigned( FOnMessage ) then
|
|
begin
|
|
msgcpy := Message;
|
|
msgcpy.time := GetTickCount - FStartTickCnt;
|
|
FOnMessage( Self, PCanTx, msgcpy ); // call application's event handler
|
|
end;
|
|
|
|
Result := True;
|
|
end; //*** end of Transmit ***
|
|
|
|
|
|
//***************************************************************************************
|
|
// NAME: ProcessReception
|
|
// PRECONDITIONS: thread running
|
|
// PARAMETER: none
|
|
// RETURN VALUE: none
|
|
// DESCRIPTION: Called by the CAN event tread. This function traps and processes CAN
|
|
// events for OnMessage.
|
|
//
|
|
//***************************************************************************************
|
|
procedure TPCanDriver.ProcessReception;
|
|
var
|
|
cnt : Byte;
|
|
msg : TPCanMessage;
|
|
msgraw : TPCANMsg;
|
|
begin
|
|
//---------------- process reception indication -------------------------------
|
|
// continue only if a new message is present in the queue
|
|
if CAN_Read(msgraw) <> CAN_ERR_OK then
|
|
Exit;
|
|
|
|
// only process CAN messages and not the status messages
|
|
if (msgraw.MSGTYPE = MSGTYPE_EXTENDED) or (msgraw.MSGTYPE = MSGTYPE_STANDARD) then
|
|
begin
|
|
// copy the message info
|
|
msg.time := GetTickCount - FStartTickCnt;
|
|
msg.id := msgraw.ID;
|
|
msg.dlc := msgraw.LEN;
|
|
// store the data bytes
|
|
for cnt :=0 to msg.dlc do
|
|
begin
|
|
msg.data[cnt] := msgraw.DATA[cnt];
|
|
end;
|
|
|
|
if Assigned( FOnMessage ) then
|
|
begin
|
|
FOnMessage( Self, PCanRx, msg ); // call application's event handler
|
|
end;
|
|
end;
|
|
end; //*** end of ProcessReception ***
|
|
|
|
|
|
//***************************************************************************************
|
|
// NAME: Register
|
|
// PRECONDITIONS: none
|
|
// PARAMETER: none
|
|
// RETURN VALUE: none
|
|
// DESCRIPTION: Registers the TPCanDriver component into Borland Delphi's IDE.
|
|
//
|
|
//***************************************************************************************
|
|
procedure Register;
|
|
begin
|
|
RegisterComponents('Feaser', [TPCanDriver]);
|
|
end; //*** end of Register ***
|
|
|
|
|
|
end.
|
|
//********************************** end of PCANdrvD.pas ********************************
|
|
|
|
|