lpti2c.cls

用VB通过并口控制I2C总线

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