如何用Excel VBA编程 串口 发送及接收命令

B.L

各位大侠，请教一个问题，任务要求是 把A列中（比如A1到A20）的字符串，通过串口命令发出去，延迟2秒后，检查收到的串口反馈，与B列（比如B1到B20）中同一行的字符串做对比，如果相同，就在C列的同一行 写入 OK，否则写入NG。
这个程序要怎么编写啊？更高级一点，使用一个按键来触发这个功能的话，要怎么弄？


比如：
设置一个按键，点击按键后触发以下功能：

将A1中的字符串通过串口发出去；
等待2秒；
检查收到的串口的反馈数据是否等于B1——如果等于，则C1中填写OK；如果不等于，C1中填写NG；

等待3秒；

将A2中的字符串通过串口发出去；。。。以此类推，直到遍历到A20。

谢谢各位！！

liucqa

你百度一下vb api 串口

B.L

百度过，但是看不懂。。。完全门外汉一个

B.L

顶一下。。

B.L

顶一下，求牛人指点。。。。

crazy0qwer

B.L 发表于 2015-8-28 17:53
顶一下，求牛人指点。。。。

别顶了，到其他地方问吧。
这里恐怕没有这方面的人，而且也没有条件来测试。

B.L

在论坛里磨了几天，找到一个这个的模板，但是在  “'*****************这里总是不成功*********************” 这个地方总是不成功，请教大侠看看。

楼上的兄弟，请问我还可以去哪里论坛问哈？谢谢~


'* ******************************************************* *
'*    程序名称：basComm.bas
'*    程序功能：在VB中利用API进行串口通信
'*    作者：lyserver
'*    联系方式：http://blog.csdn.net/lyserver
'* ******************************************************* *
      '撰写:老朽
      '网址:http://Club.ExcelHome.net
      '日期:2009-7-9 下午 04:15:40
Option Explicit
Option Base 0
Private Declare Function CreateFile Lib "kernel32" Alias "CreateFileA" (ByVal lpFileName As String, ByVal dwDesiredAccess As Long, ByVal dwShareMode As Long, ByVal lpSecurityAttributes As Long, ByVal dwCreationDisposition As Long, ByVal dwFlagsAndAttributes As Long, ByVal hTemplateFile As Long) As Long
Private Declare Function ReadFile Lib "kernel32" (ByVal hFile As Long, lpBuffer As Any, ByVal nNumberOfBytesToRead As Long, lpNumberOfBytesRead As Long, ByVal lpOverlapped As Long) As Long
Private Declare Function WriteFile Lib "kernel32" (ByVal hFile As Long, lpBuffer As Any, ByVal nNumberOfBytesToWrite As Long, lpNumberOfBytesWritten As Long, ByVal lpOverlapped As Long) As Long
Private Declare Function CloseHandle Lib "kernel32" (ByVal hObject As Long) As Long
Private Const GENERIC_READ = &H80000000
Private Const GENERIC_WRITE = &H40000000
Private Const OPEN_EXISTING = 3
Private Const INVALID_HANDLE_VALUE = -1
Private Declare Function GetCommState Lib "kernel32" (ByVal nCid As Long, lpDCB As DCB) As Long
Private Declare Function SetCommState Lib "kernel32" (ByVal hCommDev As Long, lpDCB As DCB) As Long
Private Declare Function SetCommTimeouts Lib "kernel32" (ByVal hFile As Long, lpCommTimeouts As COMMTIMEOUTS) As Long
Private Declare Function SetupComm Lib "kernel32" (ByVal hFile As Long, ByVal dwInQueue As Long, ByVal dwOutQueue As Long) As Long
Private Declare Function PurgeComm Lib "kernel32" (ByVal hFile As Long, ByVal dwFlags As Long) As Long
Private Const PURGE_TXABORT = &H1     '  Kill the pending/current writes to the comm port.
Private Const PURGE_RXABORT = &H2     '  Kill the pending/current reads to the comm port.
Private Const PURGE_TXCLEAR = &H4     '  Kill the transmit queue if there.
Private Const PURGE_RXCLEAR = &H8     '  Kill the typeahead buffer if there.

Private Type DCB
        DCBlength As Long
        BaudRate As Long
        fBitFields As Long 'See Comments in Win32API.Txt
        wReserved As Integer
        XonLim As Integer
        XoffLim As Integer
        ByteSize As Byte
        Parity As Byte
        StopBits As Byte
        XonChar As Byte
        XoffChar As Byte
        ErrorChar As Byte
        EOFChar As Byte
        EvtChar As Byte
        wReserved1 As Integer 'Reserved; Do Not Use
End Type
Private Type COMMTIMEOUTS
        ReadIntervalTimeout As Long
        ReadTotalTimeoutMultiplier As Long
        ReadTotalTimeoutConstant As Long
        WriteTotalTimeoutMultiplier As Long
        WriteTotalTimeoutConstant As Long
End Type
Private Declare Function SafeArrayGetDim Lib "oleaut32.dll" (ByRef saArray() As Any) As Long


'串口操作演示
      '撰写:老朽
      '网址:http://Club.ExcelHome.net
      '日期:2009-7-9 下午 04:15:41
Sub Main()
    Dim hComm As Long
    Dim szTest As String
    Dim rg As Range
    Dim GET1 As String
    Dim SEND1 As String
   
    '打开串口1
    hComm = OpenComm(4)
    If hComm <> 0 Then
        '设置串口通讯参数
        SetCommParam hComm
        '设置串口超时
        SetCommTimeOut hComm, 2, 3
        
        
        For Each rg In Range("C3:C6")
        
            GET1 = BytesToString(ReadComm(hComm))
            GET1 = "--"
            SEND1 = rg.Offset(0, -1).Value
            WriteComm hComm, StringToBytes(SEND1)
            
            WaitSec 2
            
             '读串口
            GET1 = BytesToString(ReadComm(hComm))
            Debug.Print GET1
            
            'If rg.Value = GET1 Then
            'If InStr(GET1, rg.Value) = 0 Then
            If rg.Value2 Like GET1 Then '*****************这里总是不成功*********************
                    
            rg.Offset(0, 2).Value = "OK"
            
            Else
            
            rg.Offset(0, 2).Value = "NG"
        
            End If
        Next
               
    CloseComm hComm
    End If
    CloseComm hComm
End Sub

Private Sub WaitSec(ByVal dS As Double)
Dim sTimer As Date
sTimer = Timer
Do
DoEvents
Loop While Format((Timer - sTimer), "0.00") < dS
End Sub


'打开串口
      '撰写:老朽
      '网址:http://Club.ExcelHome.net
      '日期:2009-7-9 下午 04:15:41
Function OpenComm(ByVal lComPort As Long) As Long
    Dim hComm As Long
    hComm = CreateFile("COM" & lComPort, GENERIC_READ Or GENERIC_WRITE, 0, 0, OPEN_EXISTING, 0, 0)
    If hComm = INVALID_HANDLE_VALUE Then
        OpenComm = 0
    Else
        OpenComm = hComm
    End If
End Function
'关闭串口
      '撰写:老朽
      '网址:http://Club.ExcelHome.net
      '日期:2009-7-9 下午 04:15:41
Sub CloseComm(hComm As Long)
    CloseHandle hComm
    hComm = 0
End Sub
'读串口
      '撰写:老朽
      '网址:http://Club.ExcelHome.net
      '日期:2009-7-9 下午 04:15:41
Function ReadComm(ByVal hComm As Long) As Byte()
    Dim dwBytesRead As Long
    Dim BytesBuffer() As Byte
    ReDim BytesBuffer(32)
    ReadFile hComm, BytesBuffer(0), UBound(BytesBuffer) + 1, dwBytesRead, 0
    If dwBytesRead > 0 Then
        ReDim Preserve BytesBuffer(dwBytesRead)
        ReadComm = BytesBuffer
    End If
End Function
'写串口
      '撰写:老朽
      '网址:http://Club.ExcelHome.net
      '日期:2009-7-9 下午 04:15:41
Function WriteComm(ByVal hComm As Long, BytesBuffer() As Byte) As Long
    Dim dwBytesWrite
    If SafeArrayGetDim(BytesBuffer) = 0 Then Exit Function
    WriteFile hComm, BytesBuffer(0), UBound(BytesBuffer) + 1, dwBytesWrite, 0
    WriteComm = dwBytesWrite
End Function

'设置串口通讯参数
      '撰写:老朽
      '网址:http://Club.ExcelHome.net
      '日期:2009-7-9 下午 04:15:41
Function SetCommParam(ByVal hComm As Long, Optional ByVal lBaudRate As Long = 57600, _
        Optional ByVal cByteSize As Byte = 8, Optional ByVal cStopBits As Byte = 0, _
        Optional ByVal cParity As Byte = 0, Optional ByVal cEOFChar As Long = 26) As Boolean
    Dim dc As DCB
    If hComm = 0 Then Exit Function
    If GetCommState(hComm, dc) Then
        dc.BaudRate = lBaudRate
        dc.ByteSize = cByteSize
        dc.StopBits = cStopBits
        dc.Parity = cParity
        dc.EOFChar = cEOFChar
        SetCommParam = CBool(SetCommState(hComm, dc))
    End If
End Function
'设置串口超时
      '撰写:老朽
      '网址:http://Club.ExcelHome.net
      '日期:2009-7-9 下午 04:15:41
Function SetCommTimeOut(ByVal hComm As Long, Optional ByVal dwReadTimeOut As Long = 2, _
        Optional ByVal dwWriteTimeOut As Long = 3) As Boolean
    Dim ct As COMMTIMEOUTS
    If hComm = 0 Then Exit Function
    ct.ReadIntervalTimeout = dwReadTimeOut '读操作时，字符间超时
    ct.ReadTotalTimeoutMultiplier = dwReadTimeOut '读操作时，每字节超时
    ct.ReadTotalTimeoutConstant = dwReadTimeOut '读操作时，固定超时（总超时=每字节超时*字节数+固定超时）
    ct.WriteTotalTimeoutMultiplier = dwWriteTimeOut '写操作时，每字节超时
    ct.WriteTotalTimeoutConstant = dwWriteTimeOut '写操作时，固定超时（总超时=每字节超时*字节数+固定超时）
    SetCommTimeOut = CBool(SetCommTimeouts(hComm, ct))
End Function


'设置串口读写缓冲区大小
      '撰写:老朽
      '网址:http://Club.ExcelHome.net
      '日期:2009-7-9 下午 04:15:41
Function SetCommBuffer(ByVal hComm As Long, Optional ByVal dwBytesRead As Long = 1024, _
        Optional ByVal dwBytesWrite As Long = 512) As Boolean
    If hComm = 0 Then Exit Function
    SetCommBuffer = CBool(SetupComm(hComm, dwBytesRead, dwBytesWrite))
End Function
'清空串口缓冲区
      '撰写:老朽
      '网址:http://Club.ExcelHome.net
      '日期:2009-7-9 下午 04:15:41
Sub ClearComm(ByVal hComm As Long, Optional ByVal InBuffer As Boolean = True, Optional ByVal OutBuffer As Boolean = True)
    If hComm = 0 Then Exit Sub
    If InBuffer And OutBuffer Then '清空输入输出缓冲区
        PurgeComm hComm, PURGE_TXABORT Or PURGE_RXABORT Or PURGE_TXCLEAR Or PURGE_RXCLEAR
    ElseIf InBuffer Then '清空输入缓冲区
        PurgeComm hComm, PURGE_RXABORT Or PURGE_RXCLEAR
    ElseIf OutBuffer Then '清空输出缓冲区
        PurgeComm hComm, PURGE_TXABORT Or PURGE_TXCLEAR
    End If
End Sub
'辅助函数：BSTR字符串转换为CHAR字符串
      '撰写:老朽
      '网址:http://Club.ExcelHome.net
      '日期:2009-7-9 下午 04:15:41
Function StringToBytes(ByVal szText As String) As Byte()
    If Len(szText) > 0 Then
        StringToBytes = StrConv(szText, vbFromUnicode)
    End If
End Function
'辅助函数：CHAR字符串转换为BSTR字符串
      '撰写:老朽
      '网址:http://Club.ExcelHome.net
      '日期:2009-7-9 下午 04:15:41
Function BytesToString(bytesText() As Byte) As String
    If SafeArrayGetDim(bytesText) <> 0 Then
        BytesToString = StrConv(bytesText, vbUnicode)
    End If
End Function
'辅助函数：获得CHAR字符串长度
      '撰写:老朽
      '网址:http://Club.ExcelHome.net
      '日期:2009-7-9 下午 04:15:41
Function Byteslen(bytesText() As Byte) As Long
    If SafeArrayGetDim(bytesText) <> 0 Then
        Byteslen = UBound(bytesText) + 1
    End If
End Function

子曰然也

同在研究这个问题，刚入门，学习！

gzhswy

如果你的仪器支持VISA指令，就通过调用visa32.dll控制仪器吧，方便很多。可以在网上下载到visa32.bas模块。具体EXCEL VBA编程实例可以去安捷伦官方下载。
关于定时功能，可以通过调用Windows API实现：
Declare PtrSafe Function SetTimer Lib "user32.dll" (ByVal hwnd As Long, ByVal nIDEvent As Long, ByVal uElapse As Long, ByVal lpTimerFunc As Long) As Long
Declare PtrSafe Function KillTimer Lib "user32.dll" (ByVal hwnd As Long, ByVal nIDEvent As Long) As Long
遍历系统串口也可以用API实现：
Declare PtrSafe Function RegCloseKey Lib "advapi32.dll" (ByVal hKey As Long) As Long
Declare PtrSafe Function RegOpenKey Lib "advapi32.dll" Alias "RegOpenKeyA" (ByVal hKey As Long, ByVal lpSubKey As String, phkResult As Long) As Long
Declare PtrSafe Function RegEnumKeyEx Lib "advapi32.dll" Alias "RegEnumKeyExA" (ByVal hKey As Long, ByVal dwIndex As Long, ByVal lpName As String, lpcbName As Long, ByVal lpReserved As Long, ByVal lpClass As String, lpcbClass As Long, lpftLastWriteTime As Any) As Long
Declare PtrSafe Function RegEnumValue Lib "advapi32.dll" Alias "RegEnumValueA" (ByVal hKey As Long, ByVal dwIndex As Long, ByVal lpValueName As String, lpcbValueName As Long, ByVal lpReserved As Long, lpType As Long, lpData As Byte, lpcbData As Long) As Long
热键可以通过OnKey设置：
Private Sub Workbook_Activate()
Application.OnKey "{F6}", "ShowMainForm"
End Sub
具体实例可以在网上查
希望能帮得到你。

李公子2017

具体实例可以在网上查