frmmainform.frm

modbus源代码

       Case 2
            m_ModbusServer.ReadOutputStatus iDevice, iDataStart, iQnt, vValues
       Case 3
            m_ModbusServer.ReadInputStatus iDevice, iDataStart, iQnt, vValues
       
      End Select
      
  End If
  
  If iQnt < Me.lstValues.ListCount Then
       
    For i = 1 To (lstValues.ListCount - iQnt)
      lstValues.RemoveItem 0
    Next i
  End If
  
  For i = 0 To iQnt - 1
    If i > lstValues.ListCount - 1 Then
      lstValues.AddItem ""
    End If
    lstValues.List(i) = "[" & CStr(i + iDataStart) & "]=" & CStr(vValues(i))
  Next i
  
  
  Exit Sub
  
ReadFunctionError:
 m_lErrors = m_lErrors + 1
'lstValues.Clear
'lstValues.AddItem "Error:0x" & Hex$(Err.Number) & " " & Err.Description
lstErros.AddItem CStr(m_lErrors) & "-Error:0x" & Hex$(Err.Number) & " " & Err.Description
Err.Clear

Exit Sub

End Sub

Private Sub cmdConnectWithTcpServer_Click()
   
  Screen.MousePointer = vbHourglass
  m_bServerStarted = ConnectUsingTCP_IP()
  Screen.MousePointer = vbDefault
    
End Sub


Private Sub cmdCustomfunc_Click()
   
  On Error GoTo CommError
  
  'Implementing a  diagnostic function
  LoopbackTest 1  'Test if device with address 1 is working
  
  
  Exit Sub
  
CommError:
 MsgBox "&H" & Hex$(Err.Number) & "  " & Err.Description
Exit Sub
End Sub

Private Sub cmdHangUp_Click()
  
  Dim sRecived As String 'Text Returned by modem
  Dim lTimeout As Long 'Time to wait a message in ms
  Dim sTelNumber As String
  
  'escape sequence
  lTimeout = 1000
  sRecived = SendCommand("+++", lTimeout)
  Debug.Print sRecived
  sRecived = SendCommand("ATH0", lTimeout)
  Debug.Print sRecived
  
  
End Sub

Private Sub cmdInitializeModem_Click()
     
  Dim sRecived As String 'Text Returned by modem
  Dim lTimeout As Long 'Time to wait a message in ms
  Dim sTelNumber As String
  
  'put your modem intialization string
  lTimeout = 1000
  sRecived = SendCommand("AT&F1", lTimeout)
  Debug.Print sRecived
  
  
  'dial to your plc
  lTimeout = 10000 'wait 10 seconds
                   'the program with be stoped for 10 seconds
                   'waiting for response
  sTelNumber = "30688777"
  sRecived = SendCommand("ATDT" & sTelNumber, lTimeout) '
  Debug.Print sRecived
  
     
End Sub

Private Sub cmdNew_Click()
   Dim f As frmMainForm
   
   Set f = New frmMainForm
   
   f.Show
   
   Set f = Nothing
   
End Sub

Private Sub cmdStartServer_Click()
  
  Screen.MousePointer = vbHourglass
  m_bServerStarted = ConnectWithSerialDevice()
  Screen.MousePointer = vbDefault
  
End Sub

Private Sub cmdStartStopPoll_Click()
    
    If trmPollDevice.Enabled Then
      trmPollDevice.Enabled = False
      cmdStartStopPoll.Caption = "&Start"
    Else
      m_lErrors = 0
      m_lNumPolls = 0
      trmPollDevice.Enabled = True
      cmdStartStopPoll.Caption = "&Stop"
    End If
      
      
End Sub





Private Sub Form_Load()

   LoadContols
   m_bServerStarted = False

End Sub

Function SendCommand(ByVal sCommand As String, ByVal lTimeout As Long) As String

Dim vResp As Variant
Dim vNumOfBytesRead As Variant
   Dim abyData() As Byte
   Dim i As Integer
   
   sCommand = sCommand & vbCrLf
   ReDim abyData(0 To Len(sCommand) - 1)
   
   For i = 0 To Len(sCommand) - 1
     abyData(i) = Asc(Mid$(sCommand, i + 1, 1))
   Next i
   
   m_ModbusServer.TxRxRawData CVar(abyData), Len(sCommand), vResp, 0, lTimeout, vNumOfBytesRead


  For i = 0 To vNumOfBytesRead - 1
     SendCommand = SendCommand & Chr$(vResp(i))
   Next i

End Function
'
'Example how to create new modbus function
'
Function LoopbackTest(nAddr As Integer) As Long

    Const QUERY_LENGHT = 6
    Const nReplyLength = 6
    Dim abyQuery() As Byte
    Dim vReply As Variant
    Dim nError As Long
    Dim iReg As Integer
    Dim iRetry As Integer

    ReDim abyQuery(0 To QUERY_LENGHT)
 
    'new modbus message see modbus protcol on www.modicon.com
    abyQuery(0) = nAddr 'ADDR
    abyQuery(1) = 8 'Function
    abyQuery(2) = 0 'diag. code=0
    abyQuery(3) = 0
    abyQuery(4) = &HA5
    abyQuery(5) = &H37

    Do
        nError = m_ModbusServer.TxRxMessage(CVar(abyQuery), QUERY_LENGHT, vReply, nReplyLength) 'send message to device
        If (nError = mbErrOk) Then 'interpret response ,
            For iReg = 0 To QUERY_LENGHT - 1
                If (abyQuery(iReg) <> vReply(iReg)) Then
                    nError = mbErrInvResp
                    Exit For
                End If
            Next iReg


        End If

        iRetry = iRetry + iRetry

    Loop While ((iRetry < m_ModbusServer.Retries) And (mbErrOk <> nError))

    LoopbackTest = nError


       
End Function 'end LoopBackTest

Function ConnectWithSerialDevice() As Boolean

  On Error GoTo ErrorConnectWithSerialDevice
  
  'Set m_DcomUtil = New DCOMLib 'Initialize object to use DCOM
  
  'You can use normal Vb object creation
  'if you not try to instanciate on another machine
  Set m_ModbusServer = New ModbusSrv
  
   'Set m_ModbusServer = m_DcomUtil.CreateRemoteObject("{B3DE3CC2-C629-11D1-8FE9-E4CD05C10000}", "", False)

   'Set m_ModbusServer = m_DcomUtil.CreateRemoteObject("ModbusSrv.ModbusSrv.1", "", False)

   'Set parameters as your hardware requirements
   m_ModbusServer.OpenConnection "com1", mbLOCAL 'change com port
   m_ModbusServer.ComPort = 1 'change com port
   m_ModbusServer.BaudRate = 9600
   m_ModbusServer.Parity = mbNOPARITY
   
   m_ModbusServer.FlowControl = mbFC_NONE
   
   m_ModbusServer.SilentInterval = 20
   m_ModbusServer.TimeOut = 500
   
   m_ModbusServer.TransmissionMode = mbMODE_RTU
   m_ModbusServer.ByteSize = 8
   m_ModbusServer.StopBits = mbONESTOPBIT
   
   m_ModbusServer.RaiseError = True
     
   If Not m_ModbusServer.Connect Then
      ConnectWithSerialDevice = False
      MsgBox "Error connecting with serial port Try Change Parameters of serial port , see the Function ConnectWithSerialDevice"
   Else
   
      If chkEnableTCPInterface.Value Then
        Set m_TcpServer = m_ModbusServer.CreateTCPServer

        'change this address
        m_TcpServer.ServerAddress = "127.0.0.1"
        m_TcpServer.ServerPort = 502

        If Not m_TcpServer.StartServer Then
          MsgBox "Error Starting TCP Serial Port Interface Try. to change server address at Sub ConnectWithSerialDevice"
        End If
      Else
       Set m_TcpServer = Nothing
      End If
      
      ConnectWithSerialDevice = True
   End If
   
   
   
Exit Function

ErrorConnectWithSerialDevice:
 MsgBox "Error:" & CStr(Err) & " " & Err.Description
 ConnectWithSerialDevice = False
Exit Function

End Function


Private Sub trmPollDevice_Timer()
    
    ReadFunction
    
End Sub