www.pudn.com > LPT_I2C.rar > LptI2C.cls
VERSION 1.0 CLASS
BEGIN
MultiUse = -1 'True
Persistable = 0 'NotPersistable
DataBindingBehavior = 0 'vbNone
DataSourceBehavior = 0 'vbNone
MTSTransactionMode = 0 'NotAnMTSObject
END
Attribute VB_Name = "LptI2C"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = True
Attribute VB_PredeclaredId = False
Attribute VB_Exposed = True
Option Explicit
Dim LptOp As LPT
Dim f_I2C_Error As Boolean
Dim delay As Byte
Dim LptOpenFlag As Boolean
Dim LptOpSetFlag As Boolean
'-----------------------------------------
Public SDA_In_LPTaddress As Long
Public SDA_In_NoBit As Byte
Public SDA_In_CPLflag As Byte
'----------------------------
Public SDA_Out_LPTaddress As Long
Public SDA_Out_NoBit As Byte
Public SDA_Out_CPLflag As Byte
'----------------------------
Public SCL_In_LPTaddress As Long
Public SCL_In_NoBit As Byte
Public SCL_In_CPLflag As Byte
'----------------------------
Public SCL_Out_LPTaddress As Long
Public SCL_Out_NoBit As Byte
Public SCL_Out_CPLflag As Byte
Private Sub SetLptOp()
Set LptOp = New LPT
LptOpSetFlag = True
End Sub
Private Sub OpenParallel()
If LptOp.OpenLPT = False Then
MsgBox "Open LPT fail !"
LptOpenFlag = False
Exit Sub
Else
LptOpenFlag = True
End If
End Sub
'Public Sub ClsLptOp()
'Cls LptOp
'LptOpSetFlag = False
'End Sub
'Public Sub SDA_In_Config(ByVal LPTaddress As Long, ByVal NoBit As Byte, ByVal CPLflag As Byte)
'SDA_In_LPTaddress = LPTaddress
'SDA_In_NoBit = NoBit
'SDA_In_CPLflag = CPLflag
'End Sub
'Public Sub SDA_Out_Config(ByVal LPTaddress As Long, ByVal NoBit As Byte, ByVal CPLflag As Byte)
'SDA_Out_LPTaddress = LPTaddress
'SDA_Out_NoBit = NoBit
'SDA_Out_CPLflag = CPLflag
'End Sub
'Public Sub SCL_In_Config(ByVal LPTaddress As Long, ByVal NoBit As Byte, ByVal CPLflag As Byte)
'SCL_In_LPTaddress = LPTaddress
'SCL_In_NoBit = NoBit
'SCL_In_CPLflag = CPLflag
'End Sub
'Public Sub SCL_Out_Config(ByVal LPTaddress As Long, ByVal NoBit As Byte, ByVal CPLflag As Byte)
'SCL_Out_LPTaddress = LPTaddress
'SCL_Out_NoBit = NoBit
'SCL_Out_CPLflag = CPLflag
'End Sub
Public Function SetSDAPort(ByVal portaddress As Long, ByVal bitnum As Byte, ByVal bitcpl As Byte)
'********************************************************
If LptOpSetFlag = False Then
'--------------------
SetLptOp '申明并口对象
OpenParallel '打开并口
'--------------------
Else
If LptOpenFlag = False Then
OpenParallel '打开并口
End If
End If
'********************************************************
If bitcpl Then
LptOp.ClrLptBit portaddress, bitnum
Else
LptOp.SetLptBit portaddress, bitnum
End If
End Function
Public Function ClrSDAPort(ByVal portaddress As Long, ByVal bitnum As Byte, ByVal bitcpl As Byte)
'********************************************************
If LptOpSetFlag = False Then
'--------------------
SetLptOp '申明并口对象
OpenParallel '打开并口
'--------------------
Else
If LptOpenFlag = False Then
OpenParallel '打开并口
End If
End If
'********************************************************
If bitcpl Then
LptOp.SetLptBit portaddress, bitnum
Else
LptOp.ClrLptBit portaddress, bitnum
End If
End Function
Public Function GetSDAPort(ByVal portaddress As Long, ByVal bitnum As Byte, ByVal bitcpl As Byte) As Boolean
'********************************************************
If LptOpSetFlag = False Then
'--------------------
SetLptOp '申明并口对象
OpenParallel '打开并口
'--------------------
Else
If LptOpenFlag = False Then
OpenParallel '打开并口
End If
End If
'********************************************************
If bitcpl Then
GetSDAPort = Not LptOp.GetLptBit(portaddress, bitnum)
Else
GetSDAPort = LptOp.GetLptBit(portaddress, bitnum)
End If
End Function
Public Function SetSCLPort(ByVal portaddress As Long, ByVal bitnum As Byte, ByVal bitcpl As Byte)
'********************************************************
If LptOpSetFlag = False Then
'--------------------
SetLptOp '申明并口对象
OpenParallel '打开并口
'--------------------
Else
If LptOpenFlag = False Then
OpenParallel '打开并口
End If
End If
'********************************************************
If bitcpl Then
LptOp.ClrLptBit portaddress, bitnum
Else
LptOp.SetLptBit portaddress, bitnum
End If
End Function
Public Function ClrSCLPort(ByVal portaddress As Long, ByVal bitnum As Byte, ByVal bitcpl As Byte)
'********************************************************
If LptOpSetFlag = False Then
'--------------------
SetLptOp '申明并口对象
OpenParallel '打开并口
'--------------------
Else
If LptOpenFlag = False Then
OpenParallel '打开并口
End If
End If
'********************************************************
If bitcpl Then
LptOp.SetLptBit portaddress, bitnum
Else
LptOp.ClrLptBit portaddress, bitnum
End If
End Function
Public Function GetSCLPort(ByVal portaddress As Long, ByVal bitnum As Byte, ByVal bitcpl As Byte) As Boolean
'********************************************************
If LptOpSetFlag = False Then
'--------------------
SetLptOp '申明并口对象
OpenParallel '打开并口
'--------------------
Else
If LptOpenFlag = False Then
OpenParallel '打开并口
End If
End If
'********************************************************
If bitcpl Then
GetSCLPort = Not LptOp.GetLptBit(portaddress, bitnum)
Else
GetSCLPort = LptOp.GetLptBit(portaddress, bitnum)
End If
End Function
'==============================================================================================================
Public Property Let IicBusDelayTime(ByVal DelayUs As Byte)
If DelayUs > 0 And DelayUs < 256 Then
delay = DelayUs
Else
MsgBox "Please enter a valid value !"
End If
End Property
Public Property Get IicError() As Boolean
IicError = f_I2C_Error
End Property
Public Property Let IicError(ByVal flag As Boolean)
f_I2C_Error = flag
End Property
Public Function IicReadByte(ByVal SlaveAddr As Byte, ByVal RegAddr As Byte) As Byte
Dim r As Byte
Dim BusTryCnt As Byte
BusTryCnt = 5
f_I2C_Error = False
Do
IicStart SlaveAddr
IicSendByte RegAddr
IicStart (SlaveAddr + 1)
r = IicReceiveByte
If f_I2C_Error = False Then
Exit Do
End If
BusTryCnt = BusTryCnt - 1
Loop While (BusTryCnt)
IicReadByte = r
End Function
'================================================================
Sub IicStart(ByVal SlaveAddress As Byte)
'------------------------------------------------------
'If LptOpSetFlag = False Then
' SetLptOp
' LptOpSetFlag = True
'End If
'If LptOpenFlag = False Then
'If LptOp.OpenLPT = False Then
' MsgBox "Open LPT fail !"
' Exit Sub
'Else
' LptOpenFlag = True
'End If
'End If
'------------------------------------------------------
SetSDA
SetSCL
If GetSDAPort(SDA_In_LPTaddress, SDA_In_NoBit, SDA_In_CPLflag) = False Then
f_I2C_Error = True
Exit Sub
End If
If GetSCLPort(SCL_In_LPTaddress, SCL_In_NoBit, SCL_In_CPLflag) = False Then
f_I2C_Error = True
Exit Sub
End If
ClrSDA
ClrSCL
IicSendByte SlaveAddress
End Sub
Sub SetSDA()
Dim chr1 As Byte
SetSDAPort SDA_Out_LPTaddress, SDA_Out_NoBit, SDA_Out_CPLflag
IicBusDelay
If GetSDAPort(SDA_In_LPTaddress, SDA_In_NoBit, SDA_In_CPLflag) Then
Exit Sub
End If
For chr1 = 0 To 19 Step 1
If GetSDAPort(SDA_In_LPTaddress, SDA_In_NoBit, SDA_In_CPLflag) Then
Exit For
End If
Next
End Sub
Sub SetSCL()
Dim chr1 As Long
SetSCLPort SCL_Out_LPTaddress, SCL_Out_NoBit, SCL_Out_CPLflag
IicBusDelay
If GetSCLPort(SCL_In_LPTaddress, SCL_In_NoBit, SCL_In_CPLflag) Then
Exit Sub
End If
For chr1 = 0 To 20000 Step 1
If GetSCLPort(SCL_In_LPTaddress, SCL_In_NoBit, SCL_In_CPLflag) Then
Exit For
End If
Next
End Sub
Sub ClrSDA()
ClrSDAPort SDA_Out_LPTaddress, SDA_Out_NoBit, SDA_Out_CPLflag
IicBusDelay
End Sub
Sub ClrSCL()
ClrSCLPort SCL_Out_LPTaddress, SCL_Out_NoBit, SCL_Out_CPLflag
IicBusDelay
End Sub
Sub IicSendByte(ByVal chr1 As Byte)
Dim chr2 As Integer
For chr2 = 7 To 0 Step -1
If (chr1 And 2 ^ chr2) = 2 ^ chr2 Then
SetSDA
Else
ClrSDA
End If
SetSCL
ClrSCL
Next
IicCheckAck
End Sub
Public Function IicReceiveByte() As Byte
Dim chr1 As Byte
Dim chr2 As Integer
chr1 = 0
SetSDA
For chr2 = 7 To 0 Step -1
SetSCL
If GetSDAPort(SDA_In_LPTaddress, SDA_In_NoBit, SDA_In_CPLflag) Then
chr1 = chr1 + 2 ^ chr2
End If
ClrSCL
Next
SetSCL
ClrSCL 'Send No-ACK
IicStop
IicReceiveByte = chr1
End Function
Sub IicStop()
ClrSCL
ClrSDA
SetSCL
SetSDA
'------------------------------------
If LptOpenFlag Then
LptOp.CloseLPT
LptOpenFlag = False
End If
'If LptOpSetFlag Then
' ClsLptOp
' LptOpSetFlag = False
' End If
'-----------------------------------
End Sub
Sub IicCheckAck()
SetSDA
SetSCL
IicBusDelay
If GetSDAPort(SDA_In_LPTaddress, SDA_In_NoBit, SDA_In_CPLflag) Then
f_I2C_Error = True
End If
ClrSCL
End Sub
Public Sub IicBusDelay()
Dim i As Byte
If delay <= 0 Or delay > 255 Then
delay = 1
End If
For i = 1 To delay
Next
End Sub
'================================================================
Sub IicWriteByte(ByVal SlaveAddr As Byte, ByVal RegAddr As Byte, ByVal RegData As Byte)
Dim BusTryCnt As Byte
BusTryCnt = 5
f_I2C_Error = False
Do
IicStart SlaveAddr
IicSendByte RegAddr
IicSendByte RegData
IicStop
If f_I2C_Error = False Then
Exit Sub
End If
BusTryCnt = BusTryCnt - 1
Loop While (BusTryCnt)
End Sub
'===================================================================
Private Function IicToolTest() As Boolean
Dim i As Byte
Dim j As Byte
Dim SCLFindOut As Boolean
Dim SDAFindOut As Boolean
'********************************************************
If LptOpSetFlag = False Then
'--------------------
SetLptOp '申明并口对象
OpenParallel '打开并口
'--------------------
Else
If LptOpenFlag = False Then
OpenParallel '打开并口
End If
End If
'********************************************************
If LptOpenFlag = False Then
IicToolTest = False
Exit Function
End If
'=================================================================================
For i = 0 To 7 Step 1
'-------------------------------------------------------
For j = 0 To 7 Step 1
LptOp.SetLptBit 888, i
If LptOp.GetLptBit(889, j) = True Then
'--------------------------------------
LptOp.ClrLptBit 888, i
If LptOp.GetLptBit(889, j) = False Then
If SDAFindOut = False Then
SDA_Out_NoBit = i
SDA_In_NoBit = j
SDAFindOut = True
Else
SCL_Out_NoBit = i
SCL_In_NoBit = j
SCLFindOut = True
End If
Exit For
End If
'--------------------------------------
Else
'-------------------------------
LptOp.ClrLptBit 888, i
If LptOp.GetLptBit(889, j) Then
If SDAFindOut = False Then
SDA_Out_NoBit = i
SDA_In_NoBit = j
SDAFindOut = True
Else
SCL_Out_NoBit = i
SCL_In_NoBit = j
SCLFindOut = True
End If
Exit For
End If
'-------------------------------
End If
Next
'--------------------------------------------------------
If SDAFindOut = True And SCLFindOut = True Then
Exit For
End If
Next
'==============================================================================
If SDAFindOut = True And SCLFindOut = True Then
IicToolTest = True
Else
IicToolTest = False
End If
SDA_In_LPTaddress = 889
SDA_Out_LPTaddress = 888
SCL_In_LPTaddress = 889
SCL_Out_LPTaddress = 888
End Function
Private Function IicBusTest(ByVal Address As Byte, ByVal temp_SDA_In_CPLflag As Byte, ByVal temp_SDA_Out_CPLflag As Byte, ByVal temp_SCL_In_CPLflag As Byte, ByVal temp_SCL_Out_CPLflag As Byte) As Boolean
Dim tempIn As Byte
Dim tempOut As Byte
DoEvents
SDA_In_CPLflag = temp_SDA_In_CPLflag
SDA_Out_CPLflag = temp_SDA_Out_CPLflag
SCL_In_CPLflag = temp_SCL_In_CPLflag
SCL_Out_CPLflag = temp_SCL_Out_CPLflag
f_I2C_Error = False
IicStart Address
If f_I2C_Error = False Then
IicBusTest = True
Exit Function
End If
'----------------------------
tempIn = SDA_In_NoBit 'SCL,SDA互换
tempOut = SDA_Out_NoBit
SDA_In_NoBit = SCL_In_NoBit
SDA_Out_NoBit = SCL_Out_NoBit
SCL_In_NoBit = tempIn
SCL_Out_NoBit = tempOut
'---------------------------
f_I2C_Error = False
IicStart Address
If f_I2C_Error = False Then
IicBusTest = True
Exit Function
End If
IicBusTest = False
End Function
Public Function IicBusSearch(ByVal deviceAddress As Byte) As Boolean
If IicToolTest = False Then
MsgBox "IicTool not finded !!!"
IicBusSearch = False
Exit Function
End If
If IicBusTest(deviceAddress, 0, 0, 0, 0) = True Then
IicBusSearch = True
Exit Function
ElseIf IicBusTest(deviceAddress, 0, 0, 0, 1) = True Then '1
IicBusSearch = True
Exit Function
ElseIf IicBusTest(deviceAddress, 0, 0, 1, 0) = True Then '2
IicBusSearch = True
Exit Function
ElseIf IicBusTest(deviceAddress, 0, 0, 1, 1) = True Then '3
IicBusSearch = True
Exit Function
ElseIf IicBusTest(deviceAddress, 0, 1, 0, 0) = True Then '4
IicBusSearch = True
Exit Function
ElseIf IicBusTest(deviceAddress, 0, 1, 0, 1) = True Then '5
IicBusSearch = True
Exit Function
ElseIf IicBusTest(deviceAddress, 0, 1, 1, 0) = True Then '6
IicBusSearch = True
Exit Function
ElseIf IicBusTest(deviceAddress, 0, 1, 1, 1) = True Then '7
IicBusSearch = True
Exit Function
ElseIf IicBusTest(deviceAddress, 1, 0, 0, 0) = True Then '8
IicBusSearch = True
Exit Function
ElseIf IicBusTest(deviceAddress, 1, 0, 0, 1) = True Then '9
IicBusSearch = True
Exit Function
ElseIf IicBusTest(deviceAddress, 1, 0, 1, 0) = True Then '10
IicBusSearch = True
Exit Function
ElseIf IicBusTest(deviceAddress, 1, 0, 1, 1) = True Then '11
IicBusSearch = True
Exit Function
ElseIf IicBusTest(deviceAddress, 1, 1, 0, 0) = True Then '12
IicBusSearch = True
Exit Function
ElseIf IicBusTest(deviceAddress, 1, 1, 0, 1) = True Then '13
IicBusSearch = True
Exit Function
ElseIf IicBusTest(deviceAddress, 1, 1, 1, 0) = True Then '14
IicBusSearch = True
Exit Function
ElseIf IicBusTest(deviceAddress, 1, 1, 1, 1) = True Then '15
IicBusSearch = True
Exit Function
End If
IicBusSearch = False
End Function