funcoesmodbus.bas

Segundo modulo para funcoes em modbus

Attribute VB_Name = "FuncoesModBus"
'=======================================================
'Modulo de funcoes para comunicacao do protocolo ModBus
'Feito por Rodrigo Mendes Defende
'13/04/2009
'=======================================================
'Tipos de Constantes
'    LerRegistro = 3
'    EscritaRegistro = 6
'    OnOffBobina = 5
'    LerBobina = 1

Dim tipoPLC As String

Public Enum Acao
    Ativar
    Desativar
End Enum

Public Enum TipoRetorno
    Dados
    StatusBobina
    SemRetorno
End Enum

Public Enum TipoCLP
    LG
    WEG
End Enum

'Constantes para a ModBus no LG
Public Const P As String = "0000"
Public Const M As String = "4096"
Public Const L As String = "8192"
Public Const K As String = "12288"
Public Const f As String = "16384"
Public Const T As String = "20480"
Public Const C As String = "24576"
Public Const D As String = "32768"

Public Enum MemoriaLG
    area_P
    area_M
    area_L
    area_K
    area_F
    area_T
    area_C
    area_D
End Enum

Public CRCTable(0 To 511) As Byte
Dim CRC_Low, CRC_High As Byte
Public Declare Sub Sleep Lib "kernel32" (ByVal dwMilliseconds As Long)

Private Function RegraLG(nMemoria As String, nTipo As MemoriaLG) As String
Dim A As Long

On Error Resume Next

Select Case nTipo
    Case area_P
        A = CLng(CLng(nMemoria) + CLng(P))
        RegraLG = CStr(A)
    Case area_M
        A = CLng(CLng(ConverteDecimal(nMemoria)) + CLng(M))
        RegraLG = CStr(A)
    Case area_L
        A = CLng(CLng(nMemoria) + CLng(L))
        RegraLG = CStr(A)
    Case area_K
        A = CLng(CLng(nMemoria) + CLng(K))
        RegraLG = CStr(A)
    Case area_F
        A = CLng(CLng(nMemoria) + CLng(f))
        RegraLG = CStr(A)
    Case area_T
        A = CLng(CLng(nMemoria) + CLng(T))
        RegraLG = CStr(A)
    Case area_C
        A = CLng(CLng(nMemoria) + CLng(C))
        RegraLG = CStr(A)
    Case area_D
        A = CLng(CLng(nMemoria) + CLng(D))
        RegraLG = CStr(A)
End Select

If Err.Number <> 0 Then
    MsgBox "Erro na convers鉶 de endere鏾 para LG.", vbCritical, "Convers鉶 de Dados."
    Exit Function
End If

End Function
Private Function AddZeroModBus(StrIn As String, intDigits As Integer)
On Error Resume Next

StrIn = Trim(StrIn)
If Len(StrIn) >= intDigits Then
    AddZeroModBus = StrIn
    Exit Function
End If
AddZeroModBus = String(intDigits - Len(StrIn), "0") & StrIn

If Err.Number <> 0 Then
    MsgBox "Erro ao arrendodar zeros a memoria. Erro: " & Err.Description, vbCritical, "Erro de sistema."
    Exit Function
End If
End Function
Private Sub CRC_16(ByVal Data As String, Length As Integer)

Dim i As Integer
Dim Index As Byte

CRC_Low = &HFF
CRC_High = &HFF

For i = 1 To Length
Index = CRC_High Xor Asc(Mid(Data, i, 1))
CRC_High = CRC_Low Xor CRCTable(Index)
CRC_Low = CRCTable(Index + 256)
Next i

End Sub
Public Function AbreSerial(ByVal Acao As Acao, nPorta As String, nSeting As String) As Integer

On Error Resume Next
'Indicar nesta funcao qual o formulario que contem o objeto MSComm

If Acao = Ativar Then
    frmCom.msCom.CommPort = nPorta
    frmCom.msCom.Settings = nSeting
    frmCom.msCom.InBufferSize = 2048
    frmCom.msCom.OutBufferSize = 2048
    frmCom.msCom.InputLen = 0
    frmCom.msCom.PortOpen = True
    AbreSerial = 0

ElseIf Acao = Desativar Then
    frmCom.msCom.PortOpen = False
End If

If Err.Number <> 0 Then
    AbreSerial = 1
    Exit Function
End If

End Function
Public Sub OnOff(LocalMemoria As String, Optional vTipoMemoria As MemoriaLG = area_C, Optional vTipoCLP As TipoCLP = LG)
Dim Data As String
Dim T1 As Long
Dim Adrr As String
Dim LoAdrr As String
Dim HiAdrr As String
Dim Interno As Integer
'Dim inBuffer As String
Dim PauseTime, Start, Finish, TotalTime

On Error Resume Next

T1 = (CLng(197) * 256)

'Transforma o endereco da memoria em Hexadecimal com 4 digitos
'Seleciona o tipo de CLP
If vTipoCLP = WEG Then
    Adrr = AddZeroModBus(Hex$(LocalMemoria), 4)
ElseIf vTipoCLP = LG Then
    Adrr = AddZeroModBus(Hex$(RegraLG(LocalMemoria, vTipoMemoria)), 4)
End If
    
'Separa o maior e menor BIT siginificativo
LoAdrr = Right$(Adrr, 2)
HiAdrr = Left$(Adrr, 2)

'Preapra os dados para formar o pacote e enviar para a Modbus LIGA BOBINA
'liga bobina - CERTO
Data = Chr$(1) + Chr$(Val("&H" & "5")) + Chr$(Val("&H" & HiAdrr)) + Chr$(Val("&H" & LoAdrr)) + Chr$("&HFF") + Chr$("&H00")

CRC_16 Data, Len(Data)
Data = Data & Chr$(CRC_High) & Chr$(CRC_Low)

inBuffer = ""
frmCom.msCom.InputLen = 0
frmCom.msCom.Output = Data

Do While frmCom.msCom.OutBufferCount > 0
Loop

PauseTime = 2
Start = Timer

Do While (Timer < Start + PauseTime) And (frmCom.msCom.InBufferCount < Val(QtdBites) * 2 + 5)
    DoEvents
Loop

'Prepara para receber os dados da Modbus
inBuffer = frmCom.msCom.Input
Finish = Timer
j = 0
'EmptyBuffer

'Preapra os dados para formar o pacote e enviar para a Modbus DESLIGA BOBINA

'desliga bobina
Data = Chr$(1) + Chr$(Val("&H" & "5")) + Chr$(Val("&H" & HiAdrr)) + Chr$(Val("&H" & LoAdrr)) + Chr$("&H00") + Chr$("&H00")

CRC_16 Data, Len(Data)
Data = Data & Chr$(CRC_High) & Chr$(CRC_Low)

inBuffer = ""
frmCom.msCom.InputLen = 0
frmCom.msCom.Output = Data

Do While frmCom.msCom.OutBufferCount > 0
Loop

PauseTime = 2
Start = Timer

Do While (Timer < Start + PauseTime) And (frmCom.msCom.InBufferCount < Val(QtdBites) * 2 + 5)
    DoEvents
Loop

'Prepara para receber os dados da Modbus
inBuffer = frmCom.msCom.Input
Finish = Timer
j = 0
EmptyBuffer

If Err.Number <> 0 Then
    MsgBox "Erro na fun玢o OnOff. Erro: " & Err.Description, vbCritical, "Erro de sistema."
    Exit Sub
End If

End Sub

Public Function MDBVX(FuncaoModbus As Integer, QtdBites As String, LocalMemoria As String, Optional ComRetorno As TipoRetorno = 0, Optional AcionaBobina As Boolean = False, Optional vTipoCLP As TipoCLP = LG, Optional vTipoMemoria As MemoriaLG = area_C)

Dim Data As String
Dim T1 As Long
Dim Adrr As String
Dim LoAdrr As String
Dim HiAdrr As String
Dim Interno As Integer
'Dim inBuffer As String
Dim vBobina As Integer

On Error Resume Next

T1 = (CLng(197) * 256)

'Transforma o endereco da memoria em Hexadecimal com 4 digitos
'Seleciona o tipo de CLP
If vClp = WEG Then
    Adrr = AddZeroModBus(Hex$(LocalMemoria), 4)
ElseIf vClp = LG Then
    Adrr = AddZeroModBus(Hex$(RegraLG(LocalMemoria, vTipoMemoria)), 4)
End If

'Separa o maior e menor BIT siginificativo
LoAdrr = Right$(Adrr, 2)
HiAdrr = Left$(Adrr, 2)

'Verifica as funcoes que serao usadas e faz as validacoes
If FuncaoModbus = 6 Then
    Qty$ = AddZeroModBus(Hex$(Val(QtdBites)), 4)
    If Len(Qty$) > 4 Then Qty$ = Right$(Qty$, 4)
        LoQt$ = Right$(Qty$, 2)
        HiQt$ = Left$(Qty$, 2)

    Data = Chr$(1) + Chr$(Val("&H" & "6")) + Chr$(Val("&H" & HiAdrr)) + Chr$(Val("&H" & LoAdrr)) & Chr$(Val("&H" & HiQt$)) & Chr$(Val("&H" & LoQt$))
End If

If FuncaoModbus = 1 Then
    Dim LoQty As String
    Dim HiQty As String
    
    Adrr = AddZeroModBus(Hex$("1"), 4)
    LoQty = Right$(Adrr, 2)
    HiQty = Left$(Adrr, 2)
    
    Data = Chr$(1) + Chr$(Val("&H" & "1")) + Chr$(Val("&H" & HiAdrr)) + Chr$(Val("&H" & LoAdrr)) + Chr$(Val("&H" & HiQty)) + Chr$(Val("&H" & LoQty))
End If

If FuncaoModbus = 3 Then
    Data = Chr$(1) + Chr$(Val("&H" & "3")) + Chr$(Val("&H" & HiAdrr)) + Chr$(Val("&H" & LoAdrr)) + Chr$(0) + Chr$(Val(QtdBites))
End If

If FuncaoModbus = 5 Then
    If AcionaBobina = True Then
    'liga bobina - CERTO
    Data = Chr$(1) + Chr$(Val("&H" & "5")) + Chr$(Val("&H" & HiAdrr)) + Chr$(Val("&H" & LoAdrr)) + Chr$("&HFF") + Chr$("&H00")
    '
    ElseIf AcionaBobina = False Then
    ''desliga bobina
    Data = Chr$(1) + Chr$(Val("&H" & "5")) + Chr$(Val("&H" & HiAdrr)) + Chr$(Val("&H" & LoAdrr)) + Chr$("&H00") + Chr$("&H00")
    End If
End If

'Preapra os dados para formar o pacote e enviar para a Modbus

CRC_16 Data, Len(Data)
Data = Data & Chr$(CRC_High) & Chr$(CRC_Low)

Dim PauseTime, Start, Finish, TotalTime

inBuffer = ""
frmCom.msCom.InputLen = 0
frmCom.msCom.Output = Data

Do While frmCom.msCom.OutBufferCount > 0
Loop

PauseTime = 1
Start = Timer

Do While (Timer < Start + PauseTime) And (frmCom.msCom.InBufferCount < Val(QtdBites) * 2 + 5)
'    DoEvents
Loop

'Prepara para receber os dados da Modbus
inBuffer = frmCom.msCom.Input
Finish = Timer
j = 0

'Caso haja retorno de informacao
If FuncaoModbus <> 6 Then
CRC_16 inBuffer, (Val(QtdBites) * 2 + 3)

If ComRetorno = Dados Then
    If FuncaoModbus = 1 Then
        vBobina = Str(Asc(Mid(inBuffer, Val(1) * 2 + 2))) ' - o que foi gravado
        If vBobina = 255 Then
            MDBVX = 1
        ElseIf vBobina = 254 Then
            MDBVX = 0
        End If
    Else
        For i = 4 To Val(QtdBites) * 2 + 3 Step 2
            MDBVX = Str((Asc(Mid(inBuffer, i, 1)) * CLng(256) + Asc(Mid(inBuffer, i + 1, 1))))
            j = j + 1
        Next i
    End If
End If

'caso nao haja retorna 0 para operacao bem sucessida
ElseIf ComRetorno = SemRetorno Then
    MDBVX = 0
    
'caso seja status da bobina
ElseIf ComRetorno = StatusBobina Then
    MDBVX = Str(Asc(Mid(inBuffer, Val("1") * 2 + 2)))
End If


If Err.Number <> 0 Then
'    MsgBox "Erro na fun玢o MDBVX. Erro: " & Err.Description, vbCritical, "Erro de sistema."
    MDBVX = -1
    Exit Function
End If

End Function
Public Sub EmptyBuffer()
Dim Sinks As Integer
'this just totally empties the input buffer
EmptySink:
'check how many characters are waiting to be read
BufLen = frmCom.msCom.InBufferCount
'set the input buffer length to the number of characters waiting in the buffer
frmCom.msCom.InputLen = BufLen
'get all the characters left in the buffer
ERRCHAR$ = frmCom.msCom.Input
If BufLen > 0 Then
'    Debug.Print "Emptying " & BufLen & " Characters..."
End If
'check if there are more characters coming in
If frmCom.msCom.InBufferCount > 0 Then GoTo EmptySink
'For Sinks = 1 To Len(ERRCHAR$)
'    frmMain.Caption = frmMain.Caption + Hex$(Asc(Mid$(ERRCHAR$, Sinks, 1)))
'Next Sinks
SINKend:
ComErr = 1
If frmCom.msCom.InBufferCount > 0 Then GoTo EmptySink
'reset our input length to 1 character
frmCom.msCom.InputLen = 1
End Sub