Hope this is of some use. All code between ********** has been used together in programs
************************************************************
Option Explicit
'routine to get available ports and display them
Public Ports(0 To 100) As PortInfo
'API calls
Declare Function EnumPorts Lib "winspool.drv" Alias "EnumPortsA" (ByVal pName As String, ByVal Level As Long, ByVal lpbPorts As Long, ByVal cbBuf As Long, pcbNeeded As Long, pcReturned As Long) As Long
Declare Function lstrlenW Lib "kernel32.dll" (ByVal lpString As Long) As Long
Declare Sub CopyMem Lib "kernel32.dll" Alias "RtlMoveMemory" (pTo As Any, uFrom As Any, ByVal lSize As Long)
Declare Function HeapAlloc Lib "kernel32.dll" (ByVal hHeap As Long, ByVal dwFlags As Long, ByVal dwBytes As Long) As Long
Declare Function GetProcessHeap Lib "kernel32.dll" () As Long
Declare Function HeapFree Lib "kernel32.dll" (ByVal hHeap As Long, ByVal dwFlags As Long, lpMem As Any) As Long
'API Structures
Type PortInfo
pPortName As String
pMonitorName As String
pDescription As String
fPortType As Long
Reserved As Long
End Type
Type ApiPortInfo
pPortName As Long
pMonitorName As Long
pDescription As Long
fPortType As Long
Reserved As Long
End Type
Public Function TrimStr(strName As String) As String
'Finds a null then trims the string
Dim x As Integer
x = InStr(strName, vbNullChar)
If x > 0 Then TrimStr = Left(strName, x - 1) Else TrimStr = strName
End Function
Public Function LPSTRtoSTRING(ByVal lngPointer As Long) As String
Dim lngLength As Long
'Get number of characters in string
lngLength = lstrlenW(lngPointer) * 2
'Initialize string so we have something to copy the string into
LPSTRtoSTRING = String(lngLength, 0)
'Copy the string
CopyMem ByVal StrPtr(LPSTRtoSTRING), ByVal lngPointer, lngLength
'Convert to Unicode
LPSTRtoSTRING = TrimStr(StrConv(LPSTRtoSTRING, vbUnicode))
End Function
'Use ServerName to specify the name of a Remote Workstation i.e. "//WIN95WKST"
'or leave it blank "" to get the ports of the local Machine
Public Function GetAvailablePorts(ServerName As String) As Long
Dim ret As Long
Dim PortsStruct(0 To 100) As ApiPortInfo
Dim pcbNeeded As Long
Dim pcReturned As Long
Dim TempBuff As Long
Dim i As Integer
'Get the amount of bytes needed to contain the data returned by the API call
ret = EnumPorts(ServerName, 2, TempBuff, 0, pcbNeeded, pcReturned)
'Allocate the Buffer
TempBuff = HeapAlloc(GetProcessHeap(), 0, pcbNeeded)
ret = EnumPorts(ServerName, 2, TempBuff, pcbNeeded, pcbNeeded, pcReturned)
If ret Then
'Convert the returned String Pointer Values to VB String Type
CopyMem PortsStruct(0), ByVal TempBuff, pcbNeeded
For i = 0 To pcReturned - 1
Ports(i).pDescription = LPSTRtoSTRING(PortsStruct(i).pDescription)
Ports(i).pPortName = LPSTRtoSTRING(PortsStruct(i).pPortName)
Ports(i).pMonitorName = LPSTRtoSTRING(PortsStruct(i).pMonitorName)
Ports(i).fPortType = PortsStruct(i).fPortType
Next
End If
GetAvailablePorts = pcReturned
'Free the Heap Space allocated for the Buffer
If TempBuff Then HeapFree GetProcessHeap(), 0, TempBuff
End Function
Sub ListPorts()
Dim NumPorts As Long
Dim i As Integer
'Get the Numbers of Ports in the System
'and Fill the Ports Structure
NumPorts = GetAvailablePorts("")
'Fill the List with the available Ports
Sheets("CONTROL").Range("PortList").ClearContents
For i = 0 To NumPorts - 1
Sheets("CONTROL").Range("PortList")(i + 1).Value = Ports(i).pPortName
Next
End Sub
'ASCII routine to send the trigger message "SEND" to a humidity measuring sensor and parse the repy
Declare Function OpenCom Lib "Port" Alias "OPENCOM" (ByVal A$) As Integer
Declare Sub CLOSECOM Lib "Port" ()
Declare Sub SENDBYTE Lib "Port" (ByVal b%)
Declare Function READBYTE Lib "Port" () As Integer
Declare Sub DTR Lib "Port" (ByVal b%)
Declare Sub RTS Lib "Port" (ByVal b%)
Declare Sub TXD Lib "Port" (ByVal b%)
Declare Function CTS Lib "Port" () As Integer
Declare Function DSR Lib "Port" () As Integer
Declare Function RI Lib "Port" () As Integer
Declare Function DCD Lib "Port" () As Integer
Declare Sub DELAY Lib "Port" (ByVal b%)
Declare Sub TIMEINIT Lib "Port" ()
Declare Sub TIMEINITUS Lib "Port" ()
Declare Function TIMEREAD Lib "Port" () As Long
Declare Function TIMEREADUS Lib "Port" () As Long
Declare Sub DELAYUS Lib "Port" (ByVal l As Long)
Declare Sub REALTIME Lib "Port" (ByVal i As Boolean)
Function DecimalCode(StringToConvert As String) As Integer
Select Case StringToConvert
' Normal characters
Case Is = "A": DecimalCode = 65
Case Is = "B": DecimalCode = 66
Case Is = "C": DecimalCode = 67
Case Is = "D": DecimalCode = 68
Case Is = "E": DecimalCode = 69
Case Is = "F": DecimalCode = 70
Case Is = "G": DecimalCode = 71
Case Is = "H": DecimalCode = 72
Case Is = "I": DecimalCode = 73
Case Is = "J": DecimalCode = 74
Case Is = "K": DecimalCode = 75
Case Is = "L": DecimalCode = 76
Case Is = "M": DecimalCode = 77
Case Is = "N": DecimalCode = 78
Case Is = "O": DecimalCode = 79
Case Is = "P": DecimalCode = 80
Case Is = "Q": DecimalCode = 81
Case Is = "R": DecimalCode = 82
Case Is = "S": DecimalCode = 83
Case Is = "T": DecimalCode = 84
Case Is = "U": DecimalCode = 85
Case Is = "V": DecimalCode = 86
Case Is = "W": DecimalCode = 87
Case Is = "X": DecimalCode = 88
Case Is = "Y": DecimalCode = 89
Case Is = "Z": DecimalCode = 90
' Special characters
Case Is = "CR": DecimalCode = 13 'Carriage return
Case Is = "TAB": DecimalCode = 9 'Tab
End Select
End Function
Function GetResponse() As Variant
Dim i As Integer, NewChar As Variant
On Error Resume Next
' Send characters (decimal codes)
SENDBYTE DecimalCode("S")
SENDBYTE DecimalCode("E")
SENDBYTE DecimalCode("N")
SENDBYTE DecimalCode("D")
SENDBYTE DecimalCode("CR")
' Remove junk from start of return string
GetResponse = ""
For i = 1 To 20
GetResponse = GetResponse + Chr$(READBYTE)
Next i
' Process data
If GetResponse < 0 Then
GetResponse = ""
Else
' Store separate parts of response in array ResponseList
End If
End Function
Sub EnvironmentLoop()
Dim PortSettings As String, BinaryResponse As String, ResponseString As String
Dim Interval As Integer, i As Integer, DataCol As Integer
Dim EnvironmentDataRow As Integer
' Modify XL behaviour
On Error Resume Next
' Check if COM port selected
With Sheets("CONTROL")
' Get selected port
If .OBComm1.Value = True Then
ActivPort = "COM1"
ElseIf .OBComm2.Value = True Then
ActivPort = "COM2"
ElseIf .OBComm3.Value = True Then
ActivPort = "COM3"
ElseIf .OBComm4.Value = True Then
ActivPort = "COM4"
Else
MsgBox ("U must select a serial port.")
Exit Sub
End If
End With
' Modify Excel behaviour
Application.ScreenUpdating = False
' Open selected serial port with baudrate 4800, Parity Even, 7 databits and 1 stop bit
PortSettings = CStr(ActivPort & ":" & BaudRate & "," & Parity & "," & DataBits & "," & StopBits)
If OpenCom(PortSettings) < 0 Then
MsgBox ("Serial port " & ActivPort & " can NOT be opened.")
Exit Sub
End If
' Count new datarow and check if >= 1.
EnvironmentDataRow = Application.WorksheetFunction.CountA(Sheets("ENVIRONMENTDATA").Range("Environment.Data").Columns(1)) + 1
If EnvironmentDataRow < 1 Then EnvironmentDataRow = 1
' Get response and paste data in table
ResponseString = CStr(GetResponse())
If Len(ResponseString) > 3 Then
Sheets("ENVIRONMENTDATA").Range("Environment.Data")(EnvironmentDataRow, 1) = Now
Sheets("ENVIRONMENTDATA").Range("Environment.Data")(EnvironmentDataRow, 2) = Mid(ResponseString, 2, 4)
Sheets("ENVIRONMENTDATA").Range("Environment.Data")(EnvironmentDataRow, 3) = Mid(ResponseString, 7, 4)
Sheets("ENVIRONMENTDATA").Range("Environment.Data")(EnvironmentDataRow, 4) = Mid(ResponseString, 12, 3)
Sheets("ENVIRONMENTDATA").Range("LastRelHumidity") = Mid(ResponseString, 2, 4)
Sheets("ENVIRONMENTDATA").Range("LastAbsHumidity") = Mid(ResponseString, 7, 4)
Sheets("ENVIRONMENTDATA").Range("LastTemp") = Mid(ResponseString, 12, 3)
End If
' Close serial port
CLOSECOM
Application.ScreenUpdating = True
' Backup environment data if table full
If EnvironmentDataRow = Sheets("ENVIRONMENTDATA").Range("Environment.Data").Rows.Count Then
Call BackupEnvironmentData(False)
End If
' Rerun sub if looping enabled
If EnvironmentLoopActivated Then
' Remember new data position
EnvironmentDataRow = EnvironmentDataRow + 1
Interval = CInt(Sheets("CONTROL").Range("PollingInterval").Value)
NextResponse = Now + ConvertTime(Interval)
Application.OnTime NextResponse, "EnvironmentLoop"
End If
End Sub
Function ConvertTime(ByVal InputSeconds As Integer) As Date
Dim Hours As Integer, Minutes As Integer, Seconds As Integer
Hours = InputSeconds \ 3600
Minutes = (InputSeconds - Hours * 3600) \ 60
Seconds = InputSeconds - Hours * 3600 - Minutes * 60
ConvertTime = TimeSerial(Hours, Minutes, Seconds)
End Function
*********************************************************
'this is a routine used to communicate with a microprocessor using HEX.
Sub Read_FPO_Registers()
'This routine is used to send a single fixed command, which returns
'the binary state of all registers.
'This is the routine that is used for reading the state of the I/Os
Dim PortSettings As String, BinaryResponse As String, ResponseString As String
Dim Interval As Integer, i As Integer, DataCol As Integer
Dim ArrayOut(0 To 19) As Byte 'Set the length of transmission array for this case
Dim ArBytes(0 To 229) As Byte
Dim strFPO As String
Dim j As Integer
Dim fStartTime As Single
Dim fCurrentTime As Single
Dim bIsPortOk As Boolean
Dim nNumBytesWaiting As Integer
Dim nNumBytesReceived As Integer
Dim SampleTime As Date
Dim CommsOK As Boolean
Dim TimeToSave As Variant
'kill timer to stop multiple timers running
On Error Resume Next 'sometimes the timer is NOT running
Application.OnTime SampleTime, "Read_FPO_Registers", , False
On Error GoTo 0
Sheets("TimeAnalysis").Range("SaveTimerTotal") = Sheets("TimeAnalysis").Range("SaveTimerTotal") + 1
Application.ScreenUpdating = True
CommsOK = True
' Open selected serial port with baudrate 19200, Parity Odd, 8 databits and 1 stop bit
'("COM1", "19200,o,8,1") These settings are in Public Declarations
PortSettings = CStr(BaudRate & "," & Parity & "," & DataBits & "," & StopBits)
'Open COM port with these settings
bIsPortOk = Form1.CheapComm1.OpenCommPort(ActivePort, PortSettings)
'if port can't be opened successfully, end program
If bIsPortOk = False Then
MsgBox "Can't open serial port. Ending Program"
End
End If
Form1.CheapComm1.ClearCommPort 'clear buffers
'Define array for the FPO string
ArrayOut(0) = DecimalCode("%")
ArrayOut(1) = DecimalCode("0")
ArrayOut(2) = DecimalCode("1")
ArrayOut(3) = DecimalCode("#")
ArrayOut(4) = DecimalCode("R")
ArrayOut(5) = DecimalCode("C")
ArrayOut(6) = DecimalCode("C")
ArrayOut(7) = DecimalCode("X")
ArrayOut(8) = DecimalCode("0")
ArrayOut(9) = DecimalCode("0")
ArrayOut(10) = DecimalCode("0")
ArrayOut(11) = DecimalCode("0")
ArrayOut(12) = DecimalCode("0")
ArrayOut(13) = DecimalCode("0")
ArrayOut(14) = DecimalCode("0")
ArrayOut(15) = DecimalCode("0")
ArrayOut(16) = DecimalCode("*")
ArrayOut(17) = DecimalCode("*")
ArrayOut(18) = DecimalCode("CR")
nNumBytesSent = Form1.CheapComm1.SendSubArray(ArrayOut, BytesToSend) 'send FPO array
'Form1.CheapComm1.SendBinaryData (ArrayOut) 'send FPO string
'get the current time (seconds since midnight)
fStartTime = Timer
Do
'Give the program time to read the input buffer
nNumBytesWaiting = Form1.CheapComm1.GetNumBytes
fCurrentTime = Timer 'get current time
'if no reply within 2 sec, exit
If fCurrentTime - fStartTime > 2 Then
'MsgBox "No Reply from Matsushita FPO PLC !", vbCritical, "Reply Error"
Form1.CheapComm1.CloseCommPort 'close Comport
CommsOK = False
GoTo BYPASS 'leave the loop if no reply, and write entry in log
End If
Loop Until nNumBytesWaiting = 13 'Change this value to suit number of words
'Select the number of bytes to be removed from buffer for processing
nNumBytesReceived = Form1.CheapComm1.GetBinaryData(ArBytes, 13)
Form1.CheapComm1.CloseCommPort 'close Comport
DataByte1 = ASCIIChr((ArBytes(6))) 'These are the 4 Bytes of the register contents
DataByte2 = ASCIIChr((ArBytes(7))) 'converted to numerical form from HEX
DataByte3 = ASCIIChr((ArBytes(8)))
DataByte4 = ASCIIChr((ArBytes(9)))
BinData1 = BinaryCode((DataByte1))
BinData2 = BinaryCode((DataByte2))
BinData3 = BinaryCode((DataByte3))
BinData4 = BinaryCode((DataByte4))
'Create 16 digit string which is the status of the register - max 16 bits
'The value of the bits can be 0 or 1 - Input 1 is the last digit
'Input 2 is the second last digit ...........
BinaryRegisterStatus = BinData3 & BinData4 & BinData1 & BinData2 'Reverse low byte/high byte
'BinaryRegisterStatus = "ABCDEFGHIJKLMNOP"
BinLength = Len(BinaryRegisterStatus)
For j = 2 To 51 'Log first 50 HEX bytes received to FPO HEXData (for debugging)
ThisWorkbook.Sheets("FPOHEXData").Range("FPO.HEX.Data")(j, 1) = ASCIIChr((ArBytes(j - 2)))
Next j
'write I/O status to worksheet for the 16 I/Os
For i = 1 To BinLength
Range("FPOstatus")(1, i).Value = Mid(BinaryRegisterStatus, i, 1)
Next i
BYPASS:
Call UpdateDataLog(CommsOK) 'Run update of times since last reset to zero
Call ResetMachineStatus 'sets the status of the status lamps
'reset save timer and save
If Sheets("TimeAnalysis").Range("SaveTimerTotal") >= SavePeriod Then
'Sheets("TimeAnalysis").CBAutologging.Value = False
ActiveWorkbook.Save
Sheets("TimeAnalysis").Range("SaveTimerStartValue") = Now()
Sheets("TimeAnalysis").Range("SaveTimerTotal") = 0
'Sheets("TimeAnalysis").CBAutologging.Value = True
End If
If LoggingActivated = True Then
SampleTime = Now + TimeValue("00:00:20")
'restart timer if required
Application.OnTime SampleTime, "Read_FPO_Registers"
End If
End Sub
Sub SendFPOTestQueryString()
'Sends the entire string directly from the Excel sheet, stopping at the first blank line.
'Use this routine for testing new commands.
Dim PortSettings As String, BinaryResponse As String, ResponseString As String
Dim Interval As Integer, i As Integer, DataCol As Integer
Dim ArrayOut(0 To 50) As Byte 'Set the length of transmission array
Dim ArBytes(0 To 229) As Byte
Dim strFPO As String
Dim j As Integer
Dim fStartTime As Single
Dim fCurrentTime As Single
Dim bIsPortOk As Boolean
Dim nNumBytesWaiting As Integer
Dim nNumBytesReceived As Integer
Dim BytesToSend As Integer
'Routine scans the Range where the test message is stored until it comes to the first blank line
Range("TestString")(1, 1).Select
i = 1
While ActiveCell <> ""
ActiveCell.Offset(1, 0).Select
Pi = Range("TestString")(i, 1)
If i = 1 Then P1 = Pi
If i = 2 Then P2 = Pi
If i = 3 Then P3 = Pi
If i = 4 Then P4 = Pi
If i = 5 Then P5 = Pi
If i = 6 Then P6 = Pi
If i = 7 Then P7 = Pi
If i = 8 Then P8 = Pi
If i = 9 Then P9 = Pi
If i = 10 Then P10 = Pi
If i = 11 Then P11 = Pi
If i = 12 Then P12 = Pi
If i = 13 Then P13 = Pi
If i = 14 Then P14 = Pi
If i = 15 Then P15 = Pi
If i = 16 Then P16 = Pi
If i = 17 Then P17 = Pi
If i = 18 Then P18 = Pi
If i = 19 Then P19 = Pi
If i = 20 Then P20 = Pi
If i = 21 Then P21 = Pi
If i = 22 Then P22 = Pi
If i = 23 Then P23 = Pi
If i = 24 Then P24 = Pi
If i = 25 Then P25 = Pi
If i = 26 Then P26 = Pi
If i = 27 Then P27 = Pi
If i = 28 Then P28 = Pi
If i = 29 Then P29 = Pi
If i = 30 Then P30 = Pi
i = i + 1
Wend
BytesToSend = ActiveCell.Row - 2 'This is the number of characters in the test message
' Open selected serial port according to settings in PublicDeclarations
PortSettings = CStr(BaudRate & "," & Parity & "," & DataBits & "," & StopBits)
bIsPortOk = Form1.CheapComm1.OpenCommPort(ActivePort, PortSettings)
'if port can't be opened successfully, end program
If bIsPortOk = False Then
MsgBox "Can't open serial port. Ending Program"
End
End If
Form1.CheapComm1.ClearCommPort 'clear buffers
'Define array for the FPO string
ArrayOut(0) = DecimalCode(CStr(P1)) ' Use ASCII translator to convert to numbers
ArrayOut(1) = DecimalCode(CStr(P2))
ArrayOut(2) = DecimalCode(CStr(P3))
ArrayOut(3) = DecimalCode(CStr(P4))
ArrayOut(4) = DecimalCode(CStr(P5))
ArrayOut(5) = DecimalCode(CStr(P6))
ArrayOut(6) = DecimalCode(CStr(P7))
ArrayOut(7) = DecimalCode(CStr(P8))
ArrayOut(8) = DecimalCode(CStr(P9))
ArrayOut(9) = DecimalCode(CStr(P10))
ArrayOut(10) = DecimalCode(CStr(P11))
ArrayOut(11) = DecimalCode(CStr(P12))
ArrayOut(12) = DecimalCode(CStr(P13))
ArrayOut(13) = DecimalCode(CStr(P14))
ArrayOut(14) = DecimalCode(CStr(P15))
ArrayOut(15) = DecimalCode(CStr(P16))
ArrayOut(16) = DecimalCode(CStr(P17))
ArrayOut(17) = DecimalCode(CStr(P18))
ArrayOut(18) = DecimalCode(CStr(P19))
ArrayOut(19) = DecimalCode(CStr(P20))
ArrayOut(20) = DecimalCode(CStr(P21))
ArrayOut(21) = DecimalCode(CStr(P22))
ArrayOut(22) = DecimalCode(CStr(P23))
ArrayOut(23) = DecimalCode(CStr(P24))
ArrayOut(24) = DecimalCode(CStr(P25))
ArrayOut(25) = DecimalCode(CStr(P26))
ArrayOut(26) = DecimalCode(CStr(P27))
ArrayOut(27) = DecimalCode(CStr(P28))
ArrayOut(28) = DecimalCode(CStr(P29))
ArrayOut(29) = DecimalCode(CStr(P30))
nNumBytesSent = Form1.CheapComm1.SendSubArray(ArrayOut, BytesToSend) 'send FPO array
'Form1.CheapComm1.SendBinaryData (ArrayOut) 'send FPO string
'get the current time (seconds since midnight)
fStartTime = Timer
Do
'Give the program time to read the input buffer
nNumBytesWaiting = Form1.CheapComm1.GetNumBytes
fCurrentTime = Timer 'get current time
'if no reply within 2 sec, exit
If fCurrentTime - fStartTime > 2 Then
MsgBox "No Reply from Matsushita FPO PLC !", vbCritical, "Reply Error"
Form1.CheapComm1.CloseCommPort 'close Comport
End
End If
Loop Until nNumBytesWaiting > 0 'Change this value to suit number of words
'Select the number of bytes to be removed from buffer for processing
nNumBytesReceived = Form1.CheapComm1.GetBinaryData(ArBytes, 9)
Form1.CheapComm1.CloseCommPort 'close Comport
DataByte1 = ASCIIChr((ArBytes(7)))
DataByte2 = ASCIIChr((ArBytes(8)))
DataByte3 = ASCIIChr((ArBytes(9)))
DataByte4 = ASCIIChr((ArBytes(10)))
For j = 2 To 51 'Log first 50 HEX bytes received to FPO HEXData (for debugging)
ThisWorkbook.Sheets("FPOHEXData").Range("FPO.HEX.Data")(j, 1) = ASCIIChr((ArBytes(j - 2)))
Next j
'ASCIIChr
End Sub
Function BinaryCode(StringToConvert As String) As String
' Converts HEX into Binary
Select Case StringToConvert
Case Is = "0": BinaryCode = "0000"
Case Is = "1": BinaryCode = "0001"
Case Is = "2": BinaryCode = "0010"
Case Is = "3": BinaryCode = "0011"
Case Is = "4": BinaryCode = "0100"
Case Is = "5": BinaryCode = "0101"
Case Is = "6": BinaryCode = "0110"
Case Is = "7": BinaryCode = "0111"
Case Is = "8": BinaryCode = "1000"
Case Is = "9": BinaryCode = "1001"
Case Is = "A": BinaryCode = "1010"
Case Is = "B": BinaryCode = "1011"
Case Is = "C": BinaryCode = "1100"
Case Is = "D": BinaryCode = "1101"
Case Is = "E": BinaryCode = "1110"
Case Is = "F": BinaryCode = "1111"
Case Is = "a": BinaryCode = "1010"
Case Is = "b": BinaryCode = "1011"
Case Is = "c": BinaryCode = "1100"
Case Is = "d": BinaryCode = "1101"
Case Is = "e": BinaryCode = "1110"
Case Is = "f": BinaryCode = "1111"
End Select
End Function