Excel Com port communication 16

[malforg]

Can anyone help with communicating to a COM port through Excel (on a machine that does not also have Visual Basic installed)?

I've tried downloading MSCOMM -- Excel recognizes the reference to MSComm32.ocx, but I get an error when trying to use it ("Run-time error '429': ActiveX component can't create object" ).

These are the lines of code that create the error (omitting the remainder of the subroutine). The line "Set CPort..." is what causes the error to pop up:

Sub ComPortTesting()
   Dim CPort As MSComm

   Set CPort = New MSComm 
...

This is really a two part question:

(1) Can this be done using MSComm? (Or is there some basic problem like a licensing/registry issue)

AND

(2) Is there another way to communicate with the Com port using Excel that doesn't require MSComm?

Thanks!
--Jason

 

[mattj63]

Strange. Maybe its the version of Windows or Office that has some effect.

I found an Excel Worksheet on the internet that had the MSComm ctrl already present. I deleted everything (code, ctrls, tabs) but the MSComm control and was able to use it successfully writing fresh code. However can't add another MSComm to the worksheet or copy/paste. I guess as long as I only need to use 1 port I'm OK with using this as a template. Got to figure out how to trick it into adding another MSComm ctrl.

Matt

 

[LabQ]

I believe registering MSComm32.ocx will only allow you to run it. To create an instance in design mode requires a license, which you would get if you had install vb onto the computer you are coding on. Also I've seen some comments on problems with bugs in the license from vb5, follow links

http://www.colby.edu/info.tech/jfu/vba_fix.html

http://support.microsoft.com/support/kb/articles/Q181/8/54.asp

my 2 1/2 cents

Alan

 

[joethall]

Been trying to communicate with a little microprocessor using CheapComm and I'm not having much luck. I finally found the nugget that pointed out that GetString() is really GetStringData(0) so now my form runs without compile errors. But that's about all it does!

I can post the VBA code if someone cares, but can anyone offer examples of using CheapComm that I might find useful?

jth

 

[tbl]

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

 

[tbl]

This is another example of communication with a very sophisticated multi-channel measuring instrument. An 8 byte string is sent to the instrument which then sends back the status of each channel in Hex containing the floating point decimal representation. As I could not find any way of converting the 4 bytes per channel into decimal, I made a rather crude but effective model in Excel to convert the incoming bytes 4 by 4 into floating point decimal.This has been working fine for 4 years without restarting the Windows NT PC ! The Excel file is programmed to monitor the incoming parameters and send an E-mail automatically if any of them go out of bounds.

****************************************************
Sub EnvironmentLoop()
Dim PortSettings As String, BinaryResponse As String, ResponseString As String
Dim Interval As Integer, i As Integer, DataCol As Integer
Dim JumoChannel As Integer
Dim WriteColumndata, WriteTime As Integer
Dim ArrayOut(0 To 8) As Byte 'Set the length of transmission array
Dim ArBytes(0 To 229) As Byte
Dim strJumo As String
Dim JumoDataRow As Integer
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 EnvironmentDataRow As Integer
Dim NumberofGraphPoints As Integer, MaxNrofPoints As Integer
Dim WriteResult As Variant, PreviousWriteResult As Variant, OvenDrukResult As Variant
Call StopEnvironmentLoop 'stop timer while macro executes

With ThisWorkbook.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 = True
' Open selected serial port with baudrate 4800, Parity Even, 7 databits and 1 stop bit
'("COM2", "9600,n,8,1")
PortSettings = CStr(BaudRate & "," & Parity & "," & DataBits & "," & StopBits)

bIsPortOk = Form1.CheapComm1.OpenCommPort(ActivPort, 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 Jumo SEND string
ArrayOut(0) = 1
ArrayOut(1) = 4
ArrayOut(2) = 0
ArrayOut(3) = 53
ArrayOut(4) = 0
ArrayOut(5) = 112
ArrayOut(6) = 225
ArrayOut(7) = 224

Form1.CheapComm1.SendBinaryData (ArrayOut) 'send Jumo string

'get the current time (seconds since midnight)
fStartTime = Timer

Do
'Check that 229 bytes have in fact been received !
nNumBytesWaiting = Form1.CheapComm1.GetNumBytes
fCurrentTime = Timer 'get current time
'if no reply within 5 sec, exit
If fCurrentTime - fStartTime > 10 Then
MsgBox "No Valid Reply from JUMO!", vbCritical, "Reply Error"
End
End If
Loop Until nNumBytesWaiting = 229
'Select the number of bytes to be removed from buffer for processing
nNumBytesReceived = Form1.CheapComm1.GetBinaryData(ArBytes, 229)

Form1.CheapComm1.CloseCommPort 'close Comport


WriteTime = 1 'Column position for Time stamp
WriteColumndata = 2 'Set column start position for writing data



EnvironmentDataRow = Application.WorksheetFunction.CountA(Sheets("EnvironmentData").Range("Environment.Data").Columns(1))
If EnvironmentDataRow < 1 Then EnvironmentDataRow = 0
EnvironmentDataRow = EnvironmentDataRow + 1 'advance data row by 1 to avoid overwriting previous result


For i = 3 To MaxBytesRead 'Read enough Bytes for 12 channels = 51
'starting at byte 3 (ignore header info)
' Get main data
ThisWorkbook.Sheets("ENVIRONMENTDATA").Unprotect
ThisWorkbook.Sheets("ENVIRONMENTDATA").Range("Environment.Data")(EnvironmentDataRow, WriteTime) = Now

'Write 4 bytes from the JUMO string to the Converter program
ThisWorkbook.Sheets("DataConverter").Range("Jumo.Data.Entry")(1, 1) = Hex(ArBytes(i))
ThisWorkbook.Sheets("DataConverter").Range("Jumo.Data.Entry")(2, 1) = Hex(ArBytes(i + 1))
ThisWorkbook.Sheets("DataConverter").Range("Jumo.Data.Entry")(3, 1) = Hex(ArBytes(i + 2))
ThisWorkbook.Sheets("DataConverter").Range("Jumo.Data.Entry")(4, 1) = Hex(ArBytes(i + 3))

'Write data to appropriate cell on ENVIRONMENTDATA

WriteResult = ThisWorkbook.Sheets("DataConverter").Range("Jumo.Result").Value
PreviousWriteResult = ThisWorkbook.Sheets("ENVIRONMENTDATA").Range("Environment.Data")(EnvironmentDataRow - 1, WriteColumndata).Value
OvenDrukResult = ThisWorkbook.Sheets("ENVIRONMENTDATA").Range("Environment.Data")(EnvironmentDataRow, WriteColumndata - 1).Value

ThisWorkbook.Sheets("ENVIRONMENTDATA").Range("Environment.Data")(EnvironmentDataRow, WriteColumndata) = ThisWorkbook.Sheets("DataConverter").Range("Jumo.Result").Value
If ThisWorkbook.Sheets("DataConverter").Range("Jumo.Result").Value > 1000 Then
ThisWorkbook.Sheets("ENVIRONMENTDATA").Range("Environment.Data")(EnvironmentDataRow, WriteColumndata) = ""
End If
'Automatically convert mVolt input from Pfeiffer instrument to mBar x 100
If WriteColumndata = 3 And OvenDrukResult < 1 Then ThisWorkbook.Sheets("ENVIRONMENTDATA").Range("Environment.Data")(EnvironmentDataRow, WriteColumndata + 14) = (WriteResult - 1) * 125

'Automatically write change in water
If WriteColumndata = 13 And EnvironmentDataRow > 1 Then ThisWorkbook.Sheets("ENVIRONMENTDATA").Range("Environment.Data")(EnvironmentDataRow, WriteColumndata + 3) = (WriteResult - PreviousWriteResult) * 3600 / 900


For j = 1 To 229 'Log all HEX bytes received to JumoHEXData (for debugging)
ThisWorkbook.Sheets("JumoHEXData").Range("Jumo.HEX.Data")(j, 1) = Hex(ArBytes(j - 1))
Next j

WriteColumndata = WriteColumndata + 1 'Reset start position for writing data
i = i + 3
Next i

MaxNrofPoints = ThisWorkbook.Sheets("ENVIRONMENTDATA").Range("Environment.Data").Rows.Count
NumberofGraphPoints = ThisWorkbook.Sheets("CONTROL").Range("GraphPoints").Value
' Backup environment data if table full max 500 points,or if number of graph points has been reached
If EnvironmentDataRow = ThisWorkbook.Sheets("ENVIRONMENTDATA").Range("Environment.Data").Rows.Count Then
ElseIf EnvironmentDataRow = ThisWorkbook.Sheets("CONTROL").Range("GraphPoints").Value Then
Call BackupEnvironmentData
End If
'Select cell to allow user to see result
ThisWorkbook.Sheets("ENVIRONMENTDATA").Select
ThisWorkbook.Sheets("ENVIRONMENTDATA").Range("A" & EnvironmentDataRow + 5).Select

ThisWorkbook.Sheets("ENVIRONMENTDATA").Protect DrawingObjects:=True, Contents:=True, Scenarios:=True
ThisWorkbook.Save

' Rerun sub if looping enabled
'Call EnableEnvironmentLoop

If EnvironmentLoopActivated Then
' Remember new data position

Interval = CInt(ThisWorkbook.Sheets("CONTROL").Range("PollingInterval").Value)
NextResponse = Now + ConvertTime(Interval)
Application.OnTime NextResponse, "EnvironmentLoop"
End If
Call CreateCopyContentsFile
ThisWorkbook.Sheets("ENVIRONMENTDATA").Select
ThisWorkbook.Sheets("ENVIRONMENTDATA").Range("A" & EnvironmentDataRow + 5).Select
End Sub

 

[farmcafe]

Can anyone help with using Excel to speak to a PIC chips using COM1 serial comms port?

This is perhaps repeating the first question posted on this thread, but I have spent hours trying to understand the pursuing discussions and efforts and looking up recommended links.

I don't want to do anything fancy, only write and read strings or binary data at low speed to and from a PIC chip.

I did download a free version of Liberty Basic. Using its open and print commands it was possible to communicate with the serial port.

Is there in summary a simple way to make Excel use serial comms without having to buy very expensive add-ins and if so, how would this be done? If there is not, what is the least expensive way of resolving this issue? I am at the moment confused.

Ever so thankful for some help!

 

[tbl]

It doesn't matter what you are trying to communicate with.The steps are always like this.........

1. Use Port Monitor (freeware) to study the (successful) communication between a PC and the device.
2. Identify a few commands and log them so that you can later simulate them in Excel.You need at lest 1 command with its resulting response from the device.
3. Decide if your comms are ASCII or HEX based, and what your port settings need to be. This you can see from Port Monitor.
4. Make a primitive VBA script which sends the command and receives the response. To do this you merely install CheapComm or MSCOMM32.ocx + register, and test using Port Monitor to see what your program is doing.
5. Write your program in VBA

Richard

 

[tbl]

Just one thing that I maybe should have mentioned in all this correspondence....

Both CheapComm and MSCOMM only work if they are embedded in a Form. The have to be inserted in a form under the forms palette. This puzzled me greatly when I first started on Excel comms.
Hope this of some help.

Richard

 

[farmcafe]

Thanks so much for an amazingly fast response!

The forms bit puzzled me too. Is there an answer to why this is the case (do you have to attach the commands to an object)?

How do you actually do this? I don't know how to make the forms palette show the Cheapcomms functions/subroutines, although they show in the reference library in the Excel Visual Basic editing window.

Without being too much of a burden, if you wanted to send at 9600 baud (stopbits 8 parity none stopbits 1 and flowcontrol none) a simple string "Hello world" from cell A1 in Sheet1 and then receive "Hello world" and write it into cell A2 in Sheet1, what would this programme look like in VBA Excel using Cheapcomms?

Looking forward to hear from you soon.

 

[tbl]

OK farmcafe, I make no apologies for the very low technical level of this explanation !

1. Open Excel with blank sheet and press Alt + F11 to open VBA.
2. Right click on This workbook and insert both a form and a module.
3. Install CheapComm
4. In VBA under TOOLS/REFERENCES/BROWSE find CheapComm.ocx in System32 and register it in References - must be present in the list and ticked.
5.Click on the UserForm that you have created and select Additional Controls by using right click on Toolbox
6. Drag the funny CheapComm icon onto your form and select Properties (right mouse)
7. You will see that the properties window has opened and CheapComm1 has arrived !
8. You now have a valid Form containing CheapCom ActiveX which can be addressed by the code in a module.
9. Insert your code into the blank module

**************************************************
Sub SendHelloWorldASCII ()

bIsPortOk = UserForm1.CheapComm1.OpenCommPort("COM1", "9600,n,8,1")

Use the code from the help file of CheapComm

end sub
****************************************************

I don't have time to program your code today but I will publish it when I have time. Hope this gets you started.

Richard

 

[farmcafe]

I am chuffed. Thanks ever so much.

(A bit embarassing, I have programmed Basic since 1988 and C++ since 1990, Excel and Access Visual Basic since 1992 - but have not done much since 1997.)

 

[tbl]

As promised, your program. Just stuff this code into an empty module of an Excel book ,prepared as I described in my previous post.

************************************************************
Sub HelloWorld() 'fully tested !
bIsPortOpenSuccessful = UserForm1.CheapComm1.OpenCommPort("COM1", "9600,n,8,1")
'you can of course link your string to an Excel cell
nNumBytesSent = UserForm1.CheapComm1.SendStringData("HELLO WORLD")

fStartTime = Timer 'get the current time (seconds since midnight)

Do
'Give the program time to read the input buffer
nNumBytesWaiting = UserForm1.CheapComm1.GetNumBytes
fCurrentTime = Timer 'get current time
'if no reply within 10 sec, exit
If fCurrentTime - fStartTime > 10 Then
MsgBox "Doesn't look like WORLD is going to reply !", vbCritical, "Reply Error"
UserForm1.CheapComm1.CloseCommPort 'close Comport
End 'get out of loop
End If
Loop Until nNumBytesWaiting = 11 'Change this value to suit number of words
'Select the number of bytes to be removed from buffer for processing
nNumBytesReceived = UserForm1.CheapComm1.GetStringData(strData, 11)
ReceivedString = strData 'this is what has come back to the port
UserForm1.CheapComm1.CloseCommPort
End Sub
************************************************************
It is always a very good idea to have Port Monitor running while you step through the code with F8. You then get the following in Port Monitor

0.00008241 EXCEL.EXE IRP_MJ_CREATE Serial0 SUCCESS Options: Open
0.00000643 EXCEL.EXE IOCTL_SERIAL_GET_TIMEOUTS Serial0 SUCCESS
0.00000419 EXCEL.EXE IOCTL_SERIAL_GET_BAUD_RATE Serial0 SUCCESS
0.00000307 EXCEL.EXE IOCTL_SERIAL_GET_LINE_CONTROL Serial0 SUCCESS
0.00000223 EXCEL.EXE IOCTL_SERIAL_GET_CHARS Serial0 SUCCESS
0.00000251 EXCEL.EXE IOCTL_SERIAL_GET_HANDFLOW Serial0 SUCCESS
0.00001285 EXCEL.EXE IOCTL_SERIAL_SET_BAUD_RATE Serial0 SUCCESS Rate: 9600
0.00000754 EXCEL.EXE IOCTL_SERIAL_SET_RTS Serial0 SUCCESS
0.00000782 EXCEL.EXE IOCTL_SERIAL_SET_DTR Serial0 SUCCESS
0.00000782 EXCEL.EXE IOCTL_SERIAL_SET_LINE_CONTROL Serial0 SUCCESS StopBits: 1 Parity: NONE WordLength: 8
0.00000587 EXCEL.EXE IOCTL_SERIAL_SET_CHAR Serial0 SUCCESS EOF:0 ERR:0 BRK:0 EVT:0 XON:0 XOFF:0
0.00000754 EXCEL.EXE IOCTL_SERIAL_SET_HANDFLOW Serial0 SUCCESS Shake:1 Replace:40 XonLimit:0 XoffLimit:0
0.00000196 EXCEL.EXE IOCTL_SERIAL_SET_TIMEOUTS Serial0 SUCCESS RI:-1 RM:0 RC:0 WM:10 WC:1000
0.00000782 EXCEL.EXE IOCTL_SERIAL_SET_DTR Serial0 SUCCESS
0.00000503 EXCEL.EXE IOCTL_SERIAL_PURGE Serial0 SUCCESS Purge: TXCLEAR
0.00000615 EXCEL.EXE IOCTL_SERIAL_PURGE Serial0 SUCCESS Purge: RXCLEAR
0.00005140 EXCEL.EXE IRP_MJ_WRITE Serial0 SUCCESS Length 11: HELLO WORLD
0.00000838 EXCEL.EXE IOCTL_SERIAL_GET_COMMSTATUS Serial0 SUCCESS

 

[farmcafe]

Supberb!

Thank you again!

 

[tbl]

There have been a lot of discussions about using MSCOMM32 and the problems with registering it. I am beginning to think that people are trying to use it on its own without a form. This is possible and I have done it, both with MSCOMM and CheapComm, but it's a lot easier to stick the component in a form and just use it.

Richard

 

[farmcafe]

What would you need to do if you were not to use a form?

Intrigued!

 

[tbl]

Not really worth the effort ! You have to work at a much lower level and specify and register eveything. I include a bit of code which I use to get a list of available ports on a Windows PC. The result gives you a complete list of all available ports on the PC.

Option Explicit

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

Richard

 

[farmcafe]

That is really useful!

Slick looking programming, too.

I was impressed that this thread has been maintained by you for 2 years and with instantaneous response.

 

[tbl]

Thanks for the compliment. Actually, responding to other users' comments on this forum is so easy as you automatically get a mail each time something happens. If only some of the other forums were as organised.
The art of RS232 communication with Excel is particularly satisfying, as the data that one gets from an instrument almost always ends up in Excel in the end. It is therefore much more elegant to import your data directly into Excel.I have got loads of programs which not only monitor industrial instruments, but notify users by e-mail (including Lotus Notes ....) automatically if the data exceeds a particular limit. Some of these have been running for more than 3 years without re-booting !

Richard

 

[MisterCfromIT]

there seem to be a lot of people out there struggling with licensing errors for the MSComm on machines that do not have VB6 installed.

this worked for me : (for end-users under Windows NT 4.0)

- copy the mscomm32.ocx to the location
d:\winnt\system32\

- run from the dosprompt :
regsvr32 d:\winnt\system32\mscomm32.ocx

- save both the texts between the dotted lines in notepad files which you save as .reg
The blank lines also are important so leave them where they are !

------------------------------
REGEDIT4

[HKEY_LOCAL_MACHINE\SOFTWARE\Classes\Licenses\4250E830-6AC2-11cf-8ADB-00AA00C00905]
@="kjljvjjjoquqmjjjvpqqkqmqykypoqjquoun"

----------------------------------
AND
---------------------------------
REGEDIT4

[HKEY_CLASSES_ROOT\Licenses\4250E830-6AC2-11cf-8ADB-00AA00C00905]
@="kjljvjjjoquqmjjjvpqqkqmqykypoqjquoun"

--------------------------------------

run both files on the end-user machine just by doubleclicking them
==> this solved the errors and made MSComm available.

==> with thanks and respect to the guys on

http://www.vbfrance.com/

<===

 

[PHV]

And no licensing issue with Microsoft doing that ?