├── README ├── README.md ├── clsVB6serialAPI.cls └── frmVB6serialAPtest.frm /README: -------------------------------------------------------------------------------- 1 | Introduction: In Microsoft Visual Basic 6 (VB6) the MSComm.ocx way of using serial ports is not valid for ports above 16. 2 | Quote (MSComm Help file): CommPort Property 3 | "You can set value to any number between 1 and 16" 4 | 5 | The class in this repository can be used with ports below and above the 16 port boundary. 6 | It contains standardized public functions, for example, to set up a port, open, read, write and close the port. 7 | The class can be instantiated for one com port or say a series in an array. 8 | 9 | To make test harness/demonstrator for VB6 Serial API class... 10 | 11 | Need: 12 | * VB6 form: frmVB6serialAPItest.frm 13 | * VB6 class: clsVB6serialAPI.cls 14 | * Microsoft VB6 development system able to run under say WinXP or Win7 15 | The form is just an example of the public functions in the class being called. 16 | The public functions in the class all return a text string with error message and most return a blank string if the operation suceeded. 17 | 18 | Sequence: 19 | * Create new folder. Suggested name: vb6SerialAPI 20 | * Copy Form and Class (two files) into this folder 21 | * Launch VB6 development system, New Project, New Standard Exe, Open 22 | * Remove Form1 (Right click on it to get drop down menu, select Remove) 23 | * Add form existing frmVB6serialAPItest.frm 24 | * Add class existing clsVB6serialAPI.cls 25 | * Project (tab)/Project Properties... 26 | * Startup Object - select form just copied into folder from dropdown box. 27 | * Project Name - vb6SerialAPI 28 | * Run 29 | * Check form with buttons appears and vb6SerialAPI.vbp was created in new folder. 30 | 31 | Acknowledgements: 32 | Acknowledgements and thanks to the author of http://www.thescarms.com/vbasic/CommIO.aspx 33 | who created module modCOMM or CommIO.bas on which the class is based with as few changes as possible. 34 | 35 | Latest class version: 20140515_2040 36 | 37 | -------------------------------------------------------------------------------- /README.md: -------------------------------------------------------------------------------- 1 | vb6SerialAPI 2 | ============ 3 | 4 | Visual Basic 6 class allowing serial port handling using the API method instead of MSComm 5 | -------------------------------------------------------------------------------- /clsVB6serialAPI.cls: -------------------------------------------------------------------------------- 1 | VERSION 1.0 CLASS 2 | BEGIN 3 | MultiUse = -1 'True 4 | Persistable = 0 'NotPersistable 5 | DataBindingBehavior = 0 'vbNone 6 | DataSourceBehavior = 0 'vbNone 7 | MTSTransactionMode = 0 'NotAnMTSObject 8 | END 9 | Attribute VB_Name = "clsVB6serialAPI" 10 | Attribute VB_GlobalNameSpace = False 11 | Attribute VB_Creatable = True 12 | Attribute VB_PredeclaredId = False 13 | Attribute VB_Exposed = False 14 | Option Explicit 'Force explicit variable declaration. 15 | 16 | '******************************************************************************** 17 | 'This class represents a serial port with API comms 18 | 'Language is Microsoft Visual Basic Six (VB6). 19 | 'See... 20 | ' http://stackoverflow.com/questions/4929414/serial-port-programming-vb6-via-win32-api 21 | 'Serial Port Communication: perform serial port I/O without using the Microsoft Comm Control component 22 | 'Above link leads to... 23 | ' http://www.thescarms.com/vbasic/CommIO.aspx 24 | ' 25 | ' This class is based on content from original CommIO.bas modCOMM module 26 | ' from the above reference. 27 | ' This is a collection of routines to perform serial port I/O without 28 | ' using the Microsoft Comm Control component. This module uses the Windows API 29 | ' to perform the overlapped I/O operations necessary for serial communications. 30 | ' See API serial port public functions below for possible options. 31 | '******************************************************************************** 32 | Const scVersion = "20140515_2040" 'Version of this class 33 | 34 | Private z_SerialPortNumber As Integer 'Unique key 35 | Private z_iBaud As Integer 'Also 0 means port is not set up 36 | Private z_bIsOpen As Boolean 'True if serial port was opened 37 | 38 | '------------------------------------------------------------------------------- 39 | ' Constants 40 | '------------------------------------------------------------------------------- 41 | 42 | ' Output Control Lines (CommSetLine) 43 | Private Const LINE_BREAK = 1 44 | Private Const LINE_DTR = 2 45 | Private Const LINE_RTS = 3 46 | 47 | ' Input Control Lines (CommGetLine) 48 | Private Const LINE_CTS = &H10& 49 | Private Const LINE_DSR = &H20& 50 | Private Const LINE_RING = &H40& 51 | Private Const LINE_RLSD = &H80& 52 | Private Const LINE_CD = &H80& 53 | 54 | '------------------------------------------------------------------------------- 55 | ' System Constants 56 | '------------------------------------------------------------------------------- 57 | Private Const ERROR_IO_INCOMPLETE = 996& 58 | Private Const ERROR_IO_PENDING = 997 59 | Private Const GENERIC_READ = &H80000000 60 | Private Const GENERIC_WRITE = &H40000000 61 | Private Const FILE_ATTRIBUTE_NORMAL = &H80 62 | Private Const FILE_FLAG_OVERLAPPED = &H40000000 63 | Private Const FORMAT_MESSAGE_FROM_SYSTEM = &H1000 64 | Private Const OPEN_EXISTING = 3 65 | 66 | ' COMM Functions 67 | Private Const MS_CTS_ON = &H10& 68 | Private Const MS_DSR_ON = &H20& 69 | Private Const MS_RING_ON = &H40& 70 | Private Const MS_RLSD_ON = &H80& 71 | Private Const PURGE_RXABORT = &H2 72 | Private Const PURGE_RXCLEAR = &H8 73 | Private Const PURGE_TXABORT = &H1 74 | Private Const PURGE_TXCLEAR = &H4 75 | 76 | ' COMM Escape Functions 77 | Private Const CLRBREAK = 9 78 | Private Const CLRDTR = 6 79 | Private Const CLRRTS = 4 80 | Private Const SETBREAK = 8 81 | Private Const SETDTR = 5 82 | Private Const SETRTS = 3 83 | 84 | '------------------------------------------------------------------------------- 85 | ' System Structures 86 | '------------------------------------------------------------------------------- 87 | Private Type COMSTAT 88 | fBitFields As Long ' See Comment in Win32API.Txt 89 | cbInQue As Long 90 | cbOutQue As Long 91 | End Type 92 | 93 | Private Type COMMTIMEOUTS 94 | ReadIntervalTimeout As Long 95 | ReadTotalTimeoutMultiplier As Long 96 | ReadTotalTimeoutConstant As Long 97 | WriteTotalTimeoutMultiplier As Long 98 | WriteTotalTimeoutConstant As Long 99 | End Type 100 | 101 | ' 102 | ' The DCB structure defines the control setting for a serial 103 | ' communications device. 104 | ' 105 | Private Type DCB 106 | DCBlength As Long 107 | BaudRate As Long 108 | fBitFields As Long ' See Comments in Win32API.Txt 109 | wReserved As Integer 110 | XonLim As Integer 111 | XoffLim As Integer 112 | ByteSize As Byte 113 | Parity As Byte 114 | StopBits As Byte 115 | XonChar As Byte 116 | XoffChar As Byte 117 | ErrorChar As Byte 118 | EofChar As Byte 119 | EvtChar As Byte 120 | wReserved1 As Integer 'Reserved; Do Not Use 121 | End Type 122 | 123 | Private Type OVERLAPPED 124 | Internal As Long 125 | InternalHigh As Long 126 | offset As Long 127 | OffsetHigh As Long 128 | hEvent As Long 129 | End Type 130 | 131 | Private Type SECURITY_ATTRIBUTES 132 | nLength As Long 133 | lpSecurityDescriptor As Long 134 | bInheritHandle As Long 135 | End Type 136 | 137 | 138 | '------------------------------------------------------------------------------- 139 | ' Program Structures 140 | '------------------------------------------------------------------------------- 141 | 142 | Private Type COMM_ERROR 143 | lngErrorCode As Long 144 | strFunction As String 145 | strErrorMessage As String 146 | End Type 147 | 148 | Private Type COMM_PORT 149 | lngHandle As Long 150 | blnPortOpen As Boolean 151 | udtDCB As DCB 152 | End Type 153 | 154 | '------------------------------------------------------------------------------- 155 | ' Program Storage 156 | '------------------------------------------------------------------------------- 157 | 158 | Private udtCommOverlap As OVERLAPPED 159 | Private udtCommError As COMM_ERROR 160 | 'was Private udtPorts(1 To MAX_API_PORTS) As COMM_PORT 161 | Private udtPort1 As COMM_PORT 162 | 163 | '------------------------------------------------------------------------------- 164 | ' System Functions begin 165 | '------------------------------------------------------------------------------- 166 | ' 167 | ' Fills a specified DCB structure with values specified in 168 | ' a device-control string. 169 | 'http://msdn.microsoft.com/en-us/library/windows/desktop/aa363143%28v=vs.85%29.aspx 170 | ' 171 | Private Declare Function BuildCommDCB Lib "kernel32" Alias "BuildCommDCBA" _ 172 | (ByVal lpDef As String, lpDCB As DCB) As Long 173 | ' 174 | ' Retrieves information about a communications error and reports 175 | ' the current status of a communications device. The function is 176 | ' called when a communications error occurs, and it clears the 177 | ' device's error flag to enable additional input and output 178 | ' (I/O) operations. 179 | Private Declare Function ClearCommError Lib "kernel32" _ 180 | (ByVal hFile As Long, lpErrors As Long, lpStat As COMSTAT) As Long 181 | ' 182 | ' Closes an open communications device or file handle. 183 | Private Declare Function CloseHandle Lib "kernel32" (ByVal hObject As Long) As Long 184 | ' 185 | ' Creates or opens a communications resource and returns a handle 186 | ' that can be used to access the resource. 187 | Private Declare Function CreateFile Lib "kernel32" Alias "CreateFileA" _ 188 | (ByVal lpFileName As String, ByVal dwDesiredAccess As Long, _ 189 | ByVal dwShareMode As Long, lpSecurityAttributes As Any, _ 190 | ByVal dwCreationDisposition As Long, ByVal dwFlagsAndAttributes As Long, _ 191 | ByVal hTemplateFile As Long) As Long 192 | ' 193 | ' Directs a specified communications device to perform a function. 194 | Private Declare Function EscapeCommFunction Lib "kernel32" _ 195 | (ByVal nCid As Long, ByVal nFunc As Long) As Long 196 | ' 197 | ' Formats a message string such as an error string returned 198 | ' by anoher function. 199 | Private Declare Function FormatMessage Lib "kernel32" Alias "FormatMessageA" _ 200 | (ByVal dwFlags As Long, lpSource As Any, ByVal dwMessageId As Long, _ 201 | ByVal dwLanguageId As Long, ByVal lpBuffer As String, ByVal nSize As Long, _ 202 | Arguments As Long) As Long 203 | ' 204 | ' Retrieves modem control-register values. 205 | Private Declare Function GetCommModemStatus Lib "kernel32" _ 206 | (ByVal hFile As Long, lpModemStat As Long) As Long 207 | ' 208 | ' Retrieves the current control settings for a specified 209 | ' communications device. 210 | Private Declare Function GetCommState Lib "kernel32" _ 211 | (ByVal nCid As Long, lpDCB As DCB) As Long 212 | ' 213 | ' Retrieves the calling thread's last-error code value. 214 | Private Declare Function GetLastError Lib "kernel32" () As Long 215 | ' 216 | ' Retrieves the results of an overlapped operation on the 217 | ' specified file, named pipe, or communications device. 218 | Private Declare Function GetOverlappedResult Lib "kernel32" _ 219 | (ByVal hFile As Long, lpOverlapped As OVERLAPPED, _ 220 | lpNumberOfBytesTransferred As Long, ByVal bWait As Long) As Long 221 | ' 222 | ' Discards all characters from the output or input buffer of a 223 | ' specified communications resource. It can also terminate 224 | ' pending read or write operations on the resource. 225 | Private Declare Function PurgeComm Lib "kernel32" _ 226 | (ByVal hFile As Long, ByVal dwFlags As Long) As Long 227 | ' 228 | ' Reads data from a file, starting at the position indicated by the 229 | ' file pointer. After the read operation has been completed, the 230 | ' file pointer is adjusted by the number of bytes actually read, 231 | ' unless the file handle is created with the overlapped attribute. 232 | ' If the file handle is created for overlapped input and output 233 | ' (I/O), the application must adjust the position of the file pointer 234 | ' after the read operation. 235 | Private Declare Function ReadFile Lib "kernel32" _ 236 | (ByVal hFile As Long, ByVal lpBuffer As String, _ 237 | ByVal nNumberOfBytesToRead As Long, ByRef lpNumberOfBytesRead As Long, _ 238 | lpOverlapped As OVERLAPPED) As Long 239 | ' 240 | ' Configures a communications device according to the specifications 241 | ' in a device-control block (a DCB structure). The function 242 | ' reinitializes all hardware and control settings, but it does not 243 | ' empty output or input queues. 244 | Private Declare Function SetCommState Lib "kernel32" _ 245 | (ByVal hCommDev As Long, lpDCB As DCB) As Long 246 | ' 247 | ' Sets the time-out parameters for all read and write operations on a 248 | ' specified communications device. 249 | Private Declare Function SetCommTimeouts Lib "kernel32" _ 250 | (ByVal hFile As Long, lpCommTimeouts As COMMTIMEOUTS) As Long 251 | ' 252 | ' Initializes the communications parameters for a specified 253 | ' communications device. 254 | Private Declare Function SetupComm Lib "kernel32" _ 255 | (ByVal hFile As Long, ByVal dwInQueue As Long, ByVal dwOutQueue As Long) As Long 256 | ' 257 | ' Writes data to a file and is designed for both synchronous and a 258 | ' synchronous operation. The function starts writing data to the file 259 | ' at the position indicated by the file pointer. After the write 260 | ' operation has been completed, the file pointer is adjusted by the 261 | ' number of bytes actually written, except when the file is opened with 262 | ' FILE_FLAG_OVERLAPPED. If the file handle was created for overlapped 263 | ' input and output (I/O), the application must adjust the position of 264 | ' the file pointer after the write operation is finished. 265 | Private Declare Function WriteFile Lib "kernel32" _ 266 | (ByVal hFile As Long, ByVal lpBuffer As String, _ 267 | ByVal nNumberOfBytesToWrite As Long, lpNumberOfBytesWritten As Long, _ 268 | lpOverlapped As OVERLAPPED) As Long 269 | 270 | ' System Functions end 271 | '------------------------------------------------------------------ 272 | 273 | '------------------------------------------------------------------------------- 274 | ' GetSystemMessage - Gets system error text for the specified error code. 275 | '------------------------------------------------------------------------------- 276 | Private Function GetSystemMessage(lngErrorCode As Long) As String 277 | 278 | Dim intPos As Integer 279 | Dim strMessage As String, strMsgBuff As String * 256 280 | 281 | Call FormatMessage(FORMAT_MESSAGE_FROM_SYSTEM, 0, lngErrorCode, 0, strMsgBuff, 255, 0) 282 | 283 | intPos = InStr(1, strMsgBuff, vbNullChar) 284 | If intPos > 0 Then 285 | strMessage = Trim$(Left$(strMsgBuff, intPos - 1)) 286 | Else 287 | strMessage = Trim$(strMsgBuff) 288 | End If 289 | 290 | GetSystemMessage = strMessage 291 | 292 | End Function 293 | 294 | '------------------------------------------------------------------------------- 295 | ' CommOpen - Opens/Initializes serial port. 296 | ' 297 | ' 298 | ' Parameters: 299 | ' strPort - COM port name. (COM1, COM2, COM3, COM4) 300 | ' strSettings - Communication settings. 301 | ' Example: "baud=9600 parity=N data=8 stop=1" 302 | ' 303 | ' Returns: 304 | ' Error Code - 0 = No Error. 305 | ' 306 | '------------------------------------------------------------------------------- 307 | Private Function CommOpen(strPort As String, _ 308 | strSettings As String) As Long 309 | ' 310 | 311 | Dim lngStatus As Long 312 | Dim udtCommTimeOuts As COMMTIMEOUTS 313 | 314 | On Error GoTo Routine_Error 315 | 316 | ' See if port already in use. 317 | If udtPort1.blnPortOpen Then 318 | lngStatus = -1 319 | With udtCommError 320 | .lngErrorCode = lngStatus 321 | .strFunction = "CommOpen" 322 | .strErrorMessage = "Port in use." 323 | End With 324 | 325 | GoTo Routine_Exit 326 | End If 327 | 328 | ' Open serial port. 329 | udtPort1.lngHandle = CreateFile(strPort, GENERIC_READ Or _ 330 | GENERIC_WRITE, 0, ByVal 0&, OPEN_EXISTING, FILE_ATTRIBUTE_NORMAL, 0) 331 | 332 | If udtPort1.lngHandle = -1 Then 333 | lngStatus = SetCommError("CommOpen (CreateFile)") 334 | GoTo Routine_Exit 335 | End If 336 | 337 | udtPort1.blnPortOpen = True 338 | 339 | ' Setup device buffers (1K each). 340 | lngStatus = SetupComm(udtPort1.lngHandle, 1024, 1024) 341 | 342 | If lngStatus = 0 Then 343 | lngStatus = SetCommError("CommOpen (SetupComm)") 344 | GoTo Routine_Exit 345 | End If 346 | 347 | ' Purge buffers. 348 | lngStatus = PurgeComm(udtPort1.lngHandle, PURGE_TXABORT Or _ 349 | PURGE_RXABORT Or PURGE_TXCLEAR Or PURGE_RXCLEAR) 350 | 351 | If lngStatus = 0 Then 352 | lngStatus = SetCommError("CommOpen (PurgeComm)") 353 | GoTo Routine_Exit 354 | End If 355 | 356 | ' Set serial port timeouts. 357 | With udtCommTimeOuts 358 | .ReadIntervalTimeout = -1 359 | .ReadTotalTimeoutMultiplier = 0 360 | .ReadTotalTimeoutConstant = 1000 361 | .WriteTotalTimeoutMultiplier = 0 362 | .WriteTotalTimeoutMultiplier = 1000 363 | End With 364 | 365 | lngStatus = SetCommTimeouts(udtPort1.lngHandle, udtCommTimeOuts) 366 | 367 | If lngStatus = 0 Then 368 | lngStatus = SetCommError("CommOpen (SetCommTimeouts)") 369 | GoTo Routine_Exit 370 | End If 371 | 372 | ' Get the current state (DCB). 373 | lngStatus = GetCommState(udtPort1.lngHandle, _ 374 | udtPort1.udtDCB) 375 | 376 | If lngStatus = 0 Then 377 | lngStatus = SetCommError("CommOpen (GetCommState)") 378 | GoTo Routine_Exit 379 | End If 380 | 381 | ' Modify the DCB to reflect the desired settings. 382 | lngStatus = BuildCommDCB(strSettings, udtPort1.udtDCB) 383 | 384 | If lngStatus = 0 Then 385 | lngStatus = SetCommError("CommOpen (BuildCommDCB)") 386 | GoTo Routine_Exit 387 | End If 388 | 389 | ' Set the new state. 390 | lngStatus = SetCommState(udtPort1.lngHandle, _ 391 | udtPort1.udtDCB) 392 | 393 | If lngStatus = 0 Then 394 | lngStatus = SetCommError("CommOpen (SetCommState)") 395 | GoTo Routine_Exit 396 | End If 397 | 398 | lngStatus = 0 399 | 400 | Routine_Exit: 401 | CommOpen = lngStatus 402 | Exit Function 403 | 404 | Routine_Error: 405 | lngStatus = Err.Number 406 | With udtCommError 407 | .lngErrorCode = lngStatus 408 | .strFunction = "CommOpen" 409 | .strErrorMessage = Err.Description 410 | End With 411 | Resume Routine_Exit 412 | End Function 413 | 414 | Private Function SetCommError(strFunction As String) As Long 415 | 416 | With udtCommError 417 | .lngErrorCode = Err.LastDllError 418 | .strFunction = strFunction 419 | .strErrorMessage = GetSystemMessage(.lngErrorCode) 420 | SetCommError = .lngErrorCode 421 | End With 422 | 423 | End Function 424 | 425 | Private Function SetCommErrorEx(strFunction As String, lngHnd As Long) As Long 426 | Dim lngErrorFlags As Long 427 | Dim udtCommStat As COMSTAT 428 | 429 | With udtCommError 430 | .lngErrorCode = GetLastError 431 | .strFunction = strFunction 432 | .strErrorMessage = GetSystemMessage(.lngErrorCode) 433 | 434 | Call ClearCommError(lngHnd, lngErrorFlags, udtCommStat) 435 | 436 | .strErrorMessage = .strErrorMessage & " COMM Error Flags = " & _ 437 | Hex$(lngErrorFlags) 438 | 439 | SetCommErrorEx = .lngErrorCode 440 | End With 441 | 442 | End Function 443 | 444 | '------------------------------------------------------------------------------- 445 | ' CommSet - Modifies the serial port settings. 446 | ' 447 | ' Parameters: 448 | ' strSettings - Communication settings. 449 | ' Example: "baud=9600 parity=N data=8 stop=1" 450 | ' 451 | ' Returns: 452 | ' Error Code - 0 = No Error. 453 | '------------------------------------------------------------------------------- 454 | Private Function CommSet(strSettings As String) As Long 455 | ' 456 | Dim lngStatus As Long 457 | 458 | On Error GoTo Routine_Error 459 | 460 | lngStatus = GetCommState(udtPort1.lngHandle, _ 461 | udtPort1.udtDCB) 462 | 463 | If lngStatus = 0 Then 464 | lngStatus = SetCommError("CommSet (GetCommState)") 465 | GoTo Routine_Exit 466 | End If 467 | 468 | lngStatus = BuildCommDCB(strSettings, udtPort1.udtDCB) 469 | 470 | If lngStatus = 0 Then 471 | lngStatus = SetCommError("CommSet (BuildCommDCB)") 472 | GoTo Routine_Exit 473 | End If 474 | 475 | lngStatus = SetCommState(udtPort1.lngHandle, _ 476 | udtPort1.udtDCB) 477 | 478 | If lngStatus = 0 Then 479 | lngStatus = SetCommError("CommSet (SetCommState)") 480 | GoTo Routine_Exit 481 | End If 482 | 483 | lngStatus = 0 484 | 485 | Routine_Exit: 486 | CommSet = lngStatus 487 | Exit Function 488 | 489 | Routine_Error: 490 | lngStatus = Err.Number 491 | With udtCommError 492 | .lngErrorCode = lngStatus 493 | .strFunction = "CommSet" 494 | .strErrorMessage = Err.Description 495 | End With 496 | Resume Routine_Exit 497 | End Function 498 | 499 | '------------------------------------------------------------------------------- 500 | ' CommClose - Close the serial port. 501 | ' 502 | ' Parameters: 503 | ' 504 | ' Returns: 505 | ' Error Code - 0 = No Error. 506 | '------------------------------------------------------------------------------- 507 | Private Function CommClose() As Long 508 | 'Ensure this is executed on close down to release the handle 509 | Dim lngStatus As Long 510 | 511 | On Error GoTo Routine_Error 512 | 513 | If udtPort1.blnPortOpen Then 514 | lngStatus = CloseHandle(udtPort1.lngHandle) 515 | 516 | If lngStatus = 0 Then 517 | lngStatus = SetCommError("CommClose (CloseHandle)") 518 | GoTo Routine_Exit 519 | End If 520 | 521 | udtPort1.blnPortOpen = False 522 | End If 523 | 524 | lngStatus = 0 525 | 526 | Routine_Exit: 527 | CommClose = lngStatus 528 | Exit Function 529 | 530 | Routine_Error: 531 | lngStatus = Err.Number 532 | With udtCommError 533 | .lngErrorCode = lngStatus 534 | .strFunction = "CommClose" 535 | .strErrorMessage = Err.Description 536 | End With 537 | Resume Routine_Exit 538 | End Function 539 | 540 | '------------------------------------------------------------------------------- 541 | ' CommRead - Read serial port input buffer. 542 | ' 543 | ' Parameters: 544 | ' strInData - Data buffer. 545 | ' lngSize - Maximum number of bytes to be read. 546 | ' 547 | ' Returns: 548 | ' Error Code - 0 = No Error. 549 | '------------------------------------------------------------------------------- 550 | Private Function CommRead(strInData As String, _ 551 | lngSize As Long) As Long 552 | 'Please note that this routine CommRead does not wait for data to be received. 553 | 'A common scheme is to set a timer and periodically read the port. 554 | 555 | Dim lngStatus As Long 556 | Dim lngRdSize As Long, lngBytesRead As Long 557 | Dim lngRdStatus As Long, strRdBuffer As String * 1024 558 | Dim lngErrorFlags As Long, udtCommStat As COMSTAT 559 | 560 | On Error GoTo Routine_Error 561 | 562 | strInData = "" 563 | lngBytesRead = 0 564 | DoEvents 565 | 566 | ' Clear any previous errors and get current status. 567 | lngStatus = ClearCommError(udtPort1.lngHandle, lngErrorFlags, _ 568 | udtCommStat) 569 | 570 | If lngStatus = 0 Then 571 | lngBytesRead = -1 572 | lngStatus = SetCommError("CommRead (ClearCommError)") 573 | GoTo Routine_Exit 574 | End If 575 | 576 | If udtCommStat.cbInQue > 0 Then 577 | If udtCommStat.cbInQue > lngSize Then 578 | lngRdSize = udtCommStat.cbInQue 579 | Else 580 | lngRdSize = lngSize 581 | End If 582 | Else 583 | lngRdSize = 0 584 | End If 585 | 586 | If lngRdSize Then 587 | lngRdStatus = ReadFile(udtPort1.lngHandle, strRdBuffer, _ 588 | lngRdSize, lngBytesRead, udtCommOverlap) 589 | 590 | If lngRdStatus = 0 Then 591 | lngStatus = GetLastError 592 | If lngStatus = ERROR_IO_PENDING Then 593 | ' Wait for read to complete. 594 | ' This function will timeout according to the 595 | ' COMMTIMEOUTS.ReadTotalTimeoutConstant variable. 596 | ' Every time it times out, check for port errors. 597 | 598 | ' Loop until operation is complete. 599 | While GetOverlappedResult(udtPort1.lngHandle, _ 600 | udtCommOverlap, lngBytesRead, True) = 0 601 | 602 | lngStatus = GetLastError 603 | 604 | If lngStatus <> ERROR_IO_INCOMPLETE Then 605 | lngBytesRead = -1 606 | lngStatus = SetCommErrorEx( _ 607 | "CommRead (GetOverlappedResult)", _ 608 | udtPort1.lngHandle) 609 | GoTo Routine_Exit 610 | End If 611 | Wend 612 | Else 613 | ' Some other error occurred. 614 | lngBytesRead = -1 615 | lngStatus = SetCommErrorEx("CommRead (ReadFile)", _ 616 | udtPort1.lngHandle) 617 | GoTo Routine_Exit 618 | 619 | End If 620 | End If 621 | 622 | strInData = Left$(strRdBuffer, lngBytesRead) 623 | End If 624 | 625 | Routine_Exit: 626 | CommRead = lngBytesRead 627 | Exit Function 628 | 629 | Routine_Error: 630 | lngBytesRead = -1 631 | lngStatus = Err.Number 632 | With udtCommError 633 | .lngErrorCode = lngStatus 634 | .strFunction = "CommRead" 635 | .strErrorMessage = Err.Description 636 | End With 637 | Resume Routine_Exit 638 | End Function 639 | 640 | '------------------------------------------------------------------------------- 641 | ' CommWrite - Output data to the serial port. 642 | ' 643 | ' Parameters: 644 | ' strData - Data to be transmitted. 645 | ' 646 | ' Returns: 647 | ' Error Code - 0 = No Error. 648 | '------------------------------------------------------------------------------- 649 | Private Function CommWrite(strData As String) As Long 650 | 651 | Dim i As Integer 652 | Dim lngStatus As Long, lngSize As Long 653 | Dim lngWrSize As Long, lngWrStatus As Long 654 | 655 | On Error GoTo Routine_Error 656 | 657 | ' Get the length of the data. 658 | lngSize = Len(strData) 659 | 660 | ' Output the data. 661 | lngWrStatus = WriteFile(udtPort1.lngHandle, strData, lngSize, _ 662 | lngWrSize, udtCommOverlap) 663 | 664 | ' Note that normally the following code will not execute because the driver 665 | ' caches write operations. Small I/O requests (up to several thousand bytes) 666 | ' will normally be accepted immediately and WriteFile will return true even 667 | ' though an overlapped operation was specified. 668 | 669 | DoEvents 670 | 671 | If lngWrStatus = 0 Then 672 | lngStatus = GetLastError 673 | If lngStatus = 0 Then 674 | GoTo Routine_Exit 675 | ElseIf lngStatus = ERROR_IO_PENDING Then 676 | ' We should wait for the completion of the write operation so we know 677 | ' if it worked or not. 678 | ' 679 | ' This is only one way to do this. It might be beneficial to place the 680 | ' writing operation in a separate thread so that blocking on completion 681 | ' will not negatively affect the responsiveness of the UI. 682 | ' 683 | ' If the write takes long enough to complete, this function will timeout 684 | ' according to the CommTimeOuts.WriteTotalTimeoutConstant variable. 685 | ' At that time we can check for errors and then wait some more. 686 | 687 | ' Loop until operation is complete. 688 | While GetOverlappedResult(udtPort1.lngHandle, _ 689 | udtCommOverlap, lngWrSize, True) = 0 690 | 691 | lngStatus = GetLastError 692 | 693 | If lngStatus <> ERROR_IO_INCOMPLETE Then 694 | lngStatus = SetCommErrorEx( _ 695 | "CommWrite (GetOverlappedResult)", _ 696 | udtPort1.lngHandle) 697 | GoTo Routine_Exit 698 | End If 699 | Wend 700 | Else 701 | ' Some other error occurred. 702 | lngWrSize = -1 703 | 704 | lngStatus = SetCommErrorEx("CommWrite (WriteFile)", _ 705 | udtPort1.lngHandle) 706 | GoTo Routine_Exit 707 | 708 | End If 709 | End If 710 | 711 | For i = 1 To 10 712 | DoEvents 713 | Next 714 | 715 | Routine_Exit: 716 | CommWrite = lngWrSize 717 | Exit Function 718 | 719 | Routine_Error: 720 | lngStatus = Err.Number 721 | With udtCommError 722 | .lngErrorCode = lngStatus 723 | .strFunction = "CommWrite" 724 | .strErrorMessage = Err.Description 725 | End With 726 | Resume Routine_Exit 727 | End Function 728 | 729 | Private Function getState(ByVal iLineType As Integer, ByVal sTipe As String, ByRef sErrRetrn As String) As String 730 | 'User supplies sErrRetrn so any error message can be returned, 731 | 'blank signifies no problems. 732 | Const FNREF = "getState " 733 | On Error GoTo ErorHandlr 734 | Dim lErRetn As Long 735 | Dim bState As Boolean 736 | lErRetn = CommGetLine(iLineType, bState) 737 | If lErRetn = 0 Then 738 | 'OK return 739 | sErrRetrn = "" 'say No problems 740 | If bState = True Then 741 | getState = sTipe & "=1 " 742 | Else 743 | getState = sTipe & "=0 " 744 | End If 745 | Else 746 | 'Error seen amcc debug 747 | sErrRetrn = FNREF & sTipe & " Error: " & Str(lErRetn) & " " & GetSystemMessage(lErRetn) 748 | getState = sTipe & "=? " 749 | End If 750 | Exit Function ' Exit to avoid handler. 751 | ErorHandlr: ' Error-handling routine. 752 | sErrRetrn = FNREF & "Error " & Err.Number & ", " & Err.Description 753 | End Function 754 | 755 | '------------------------------------------------------------------------------- 756 | ' CommGetLine - Get the state of selected serial port control lines. 757 | ' 758 | ' Parameters: 759 | ' intLine - Serial port line. CTS, DSR, RING, RLSD (CD) 760 | ' blnState - Returns state of line (Cleared or Set). 761 | ' 762 | ' Returns: 763 | ' Error Code - 0 = No Error. 764 | '------------------------------------------------------------------------------- 765 | Private Function CommGetLine(ByVal intLine As Integer, _ 766 | ByRef blnState As Boolean) As Long 767 | 768 | Dim lngStatus As Long 769 | Dim lngComStatus As Long, lngModemStatus As Long 770 | 771 | On Error GoTo Routine_Error 772 | 773 | lngStatus = GetCommModemStatus(udtPort1.lngHandle, lngModemStatus) 774 | 775 | If lngStatus = 0 Then 776 | lngStatus = SetCommError("CommReadCD (GetCommModemStatus)") 777 | GoTo Routine_Exit 778 | End If 779 | 780 | If (lngModemStatus And intLine) Then 781 | blnState = True 782 | Else 783 | blnState = False 784 | End If 785 | 786 | lngStatus = 0 787 | 788 | Routine_Exit: 789 | CommGetLine = lngStatus 790 | Exit Function 791 | 792 | Routine_Error: 793 | lngStatus = Err.Number 794 | With udtCommError 795 | .lngErrorCode = lngStatus 796 | .strFunction = "CommReadCD" 797 | .strErrorMessage = Err.Description 798 | End With 799 | Resume Routine_Exit 800 | End Function 801 | 802 | 803 | '------------------------------------------------------------------------------- 804 | ' CommGetError - Get the last serial port error message. 805 | ' 806 | ' Parameters: 807 | ' strMessage - Error message from last serial port error. 808 | ' 809 | ' Returns: 810 | ' Error Code - Last serial port error code. 811 | '------------------------------------------------------------------------------- 812 | Private Function CommGetError(strMessage As String) As Long 813 | 814 | With udtCommError 815 | CommGetError = .lngErrorCode 816 | strMessage = "Error (" & CStr(.lngErrorCode) & "): " & .strFunction & _ 817 | " - " & .strErrorMessage 818 | End With 819 | 820 | End Function 821 | 822 | '------------------------------------------------------------------------------- 823 | ' CommFlush - Flush the send and receive serial port buffers. 824 | ' 825 | ' Parameters: 826 | ' 827 | ' Returns: 828 | ' Error Code - 0 = No Error. 829 | '------------------------------------------------------------------------------- 830 | Private Function CommFlush() As Long 831 | 832 | Dim lngStatus As Long 833 | 834 | On Error GoTo Routine_Error 835 | 836 | lngStatus = PurgeComm(udtPort1.lngHandle, PURGE_TXABORT Or _ 837 | PURGE_RXABORT Or PURGE_TXCLEAR Or PURGE_RXCLEAR) 838 | 839 | If lngStatus = 0 Then 840 | lngStatus = SetCommError("CommFlush (PurgeComm)") 841 | GoTo Routine_Exit 842 | End If 843 | 844 | lngStatus = 0 845 | 846 | Routine_Exit: 847 | CommFlush = lngStatus 848 | Exit Function 849 | 850 | Routine_Error: 851 | lngStatus = Err.Number 852 | With udtCommError 853 | .lngErrorCode = lngStatus 854 | .strFunction = "CommFlush" 855 | .strErrorMessage = Err.Description 856 | End With 857 | Resume Routine_Exit 858 | End Function 859 | 860 | Private Function fixLine(ByVal iLineType As Integer, ByVal bInStaet As Boolean) As String 861 | 'Returns empty string if ok else error message 862 | Const FNREF = "fixLine " 863 | On Error GoTo ErorHandlr 864 | Dim lRetn As Long 865 | fixLine = "" 'Assume no problems 866 | lRetn = CommSetLine(iLineType, bInStaet) 867 | If lRetn <> 0 Then 868 | fixLine = "Problem setting line, Error: " & Str(lRetn) & " " & GetSystemMessage(lRetn) 869 | End If 870 | Exit Function ' Exit to avoid handler. 871 | ErorHandlr: ' Error-handling routine. 872 | fixLine = FNREF & "Error " & Err.Number & ", " & Err.Description 873 | End Function 874 | 875 | '------------------------------------------------------------------------------- 876 | ' CommSetLine - Set the state of selected serial port control lines. 877 | ' 878 | ' Parameters: 879 | ' intLine - Serial port line. BREAK, DTR, RTS 880 | ' Note: BREAK actually sets or clears a "break" condition on 881 | ' the transmit data line. 882 | ' blnState - Sets the state of line (Cleared or Set). 883 | ' 884 | ' Returns: 885 | ' Error Code - 0 = No Error. 886 | '------------------------------------------------------------------------------- 887 | Private Function CommSetLine(intLine As Integer, _ 888 | blnState As Boolean) As Long 889 | 890 | Dim lngStatus As Long 891 | Dim lngNewState As Long 892 | 893 | On Error GoTo Routine_Error 894 | 895 | If intLine = LINE_BREAK Then 896 | If blnState Then 897 | lngNewState = SETBREAK 898 | Else 899 | lngNewState = CLRBREAK 900 | End If 901 | 902 | ElseIf intLine = LINE_DTR Then 903 | If blnState Then 904 | lngNewState = SETDTR 905 | Else 906 | lngNewState = CLRDTR 907 | End If 908 | 909 | ElseIf intLine = LINE_RTS Then 910 | If blnState Then 911 | lngNewState = SETRTS 912 | Else 913 | lngNewState = CLRRTS 914 | End If 915 | End If 916 | 917 | lngStatus = EscapeCommFunction(udtPort1.lngHandle, lngNewState) 918 | 919 | If lngStatus = 0 Then 920 | lngStatus = SetCommError("CommSetLine (EscapeCommFunction)") 921 | GoTo Routine_Exit 922 | End If 923 | 924 | lngStatus = 0 925 | 926 | Routine_Exit: 927 | CommSetLine = lngStatus 928 | Exit Function 929 | 930 | Routine_Error: 931 | lngStatus = Err.Number 932 | With udtCommError 933 | .lngErrorCode = lngStatus 934 | .strFunction = "CommSetLine" 935 | .strErrorMessage = Err.Description 936 | End With 937 | Resume Routine_Exit 938 | End Function 939 | 940 | Private Sub class_initialize() 941 | z_SerialPortNumber = 0 'See Note 1 942 | End Sub 943 | 944 | '----------------------------------------------------------------------------------- 945 | '-------------API serial port public functions Begin 946 | '----------------------------------------------------------------------------------- 947 | 'The following functions communicate with the API serial port... 948 | ' clSerialAPIinitialise* (Sets port number and initialises this class E1) 949 | ' clSerialAPIsetBaud* (Sets baud rate for closed port E1) 950 | ' clSerialAPIopen* (Opens the port E1) 951 | ' clSerialAPIread* (Reads the API port E2) 952 | ' clSerialAPIwrite* (Writes to the API port E1) 953 | ' clSerialAPIclose* (Closes or ensures port is closed E1) 954 | ' clSerialAPIflush (Flush the send and receive serial port buffers E1) 955 | ' clSerialAPIsetBREAK (Set BREAK line E1) 956 | ' clSerialAPIsetDTR (Set DTR line E1) 957 | ' clSerialAPIsetRTS (Set RTS line E1) 958 | 959 | 'The following functions provide information about API serial port... 960 | ' clSerialAPIgetBaud (returns a integer Baud rate) 961 | ' clSerialAPIgetIsOpen (returns boolean true if port is open) 962 | ' clSerialAPIgetLines (returns string of 1 or 0 else error message) 963 | ' clSerialAPIgetVersion (returns the build version of serial API class) 964 | 965 | 'NOTES: 966 | ' * Starred functions comprise the minimum set useful. 967 | ' E1 Returns error message else blank string if ok 968 | ' E2 User must supply a string as a parameter otherwise return is as E1 969 | '---------------------------------------------------------------------- 970 | 971 | Public Function clSerialAPIinitialise(ByVal iSerPortNumbre As Integer) As String 972 | 'Initialise serial port class 973 | 'Returns error message else blank string if ok 974 | Const FNREF = "clSerialAPIinitialise " 975 | On Error GoTo ErorHandlr 976 | 977 | 'Note 1 Ensure port numbers are greater than 0 as this is used to show port is not initialised. 978 | If iSerPortNumbre < 1 Then 979 | clSerialAPIinitialise = "API serial port number must exceed 0" 980 | Exit Function 981 | End If 982 | 983 | 'Test for port already being used 984 | If z_SerialPortNumber = iSerPortNumbre Then 985 | clSerialAPIinitialise = "API serial port " & iSerPortNumbre & " is already in use" 986 | Exit Function 987 | End If 988 | 989 | clSerialAPIinitialise = "" 'All is well 990 | z_SerialPortNumber = iSerPortNumbre 991 | z_iBaud = 0 'To indicate port is not set up 992 | z_bIsOpen = False 993 | Exit Function ' Exit to avoid handler. 994 | ErorHandlr: ' Error-handling routine. 995 | clSerialAPIinitialise = FNREF & "Error " & Err.Number & ", " & Err.Description 996 | End Function 997 | 998 | Public Function clSerialAPIsetBaud(ByVal iBaudIn As Integer) As String 999 | 'This sets up an unopened port. It does not open the port. 1000 | 'Returns empty string if ok else error message. 1001 | Const FNREF = "clSerialAPIsetBaud " 1002 | On Error GoTo ErorHandlr 1003 | 1004 | 'Only allow a closed port to have baud changed 1005 | If z_bIsOpen = True Then 1006 | clSerialAPIsetBaud = "Close port first then set baud" 1007 | Exit Function 1008 | End If 1009 | z_iBaud = iBaudIn 1010 | clSerialAPIsetBaud = "" 1011 | Exit Function ' Exit to avoid handler. 1012 | ErorHandlr: ' Error-handling routine. 1013 | clSerialAPIsetBaud = FNREF & "Error " & Err.Number & ", " & Err.Description 1014 | End Function 1015 | 1016 | Public Function clSerialAPIopen() As String 1017 | 'Returns blank string if okay else message containing the problem 1018 | 'The caller is advised to check the return string. 1019 | 'Parity, data bits and stop bits are hardcoded below. 1020 | 'Baud rate must be set before this function is called. 1021 | 'Note O1: The COM port name format can vary. Any of the following formats 1022 | 'may be valid depending on the system and serial port driver. 1023 | 'Try the others if the port won't open. 1024 | ' COM1 1025 | ' COM1: 1026 | ' \\.\COM1 1027 | 1028 | Const FNREF = "clSerialAPIopen " 1029 | On Error GoTo ErorHandlr 1030 | 1031 | Dim lngStaatus As Long 1032 | Dim strError As String 1033 | clSerialAPIopen = "" 'Default to no problems seen 1034 | 1035 | If z_iBaud = 0 Then 1036 | clSerialAPIopen = "Port not set up so cannot open it" 1037 | Exit Function 1038 | End If 1039 | 1040 | If z_bIsOpen = True Then 1041 | clSerialAPIopen = "Port is already open" 1042 | Exit Function 1043 | End If 1044 | 1045 | ' Initialize Communications (See above Note O1) 1046 | lngStaatus = CommOpen("COM" & CStr(z_SerialPortNumber), _ 1047 | "baud=" & z_iBaud & " parity=N data=8 stop=1") 1048 | 1049 | If lngStaatus <> 0 Then 1050 | lngStaatus = CommGetError(strError) 'function fills in strError 1051 | clSerialAPIopen = "COM Error: " & strError 1052 | z_bIsOpen = False 'Define port being closed 1053 | Else 1054 | z_bIsOpen = True 1055 | ' Set modem control lines. 1056 | lngStaatus = CommSetLine(LINE_RTS, True) 1057 | lngStaatus = CommSetLine(LINE_DTR, True) 1058 | End If 1059 | Exit Function ' Exit to avoid handler. 1060 | ErorHandlr: ' Error-handling routine. 1061 | clSerialAPIopen = FNREF & "Error " & Err.Number & ", " & Err.Description 1062 | End Function 1063 | 1064 | Public Function clSerialAPIread(ByVal iMaxBytesIn As Long, ByRef sReturnError As String) As String 1065 | 'Returns blank string if okay else message 1066 | 'INPUT iMaxBytesIn is maximum number of bytes to be read in 1067 | 'OUTPUT The user must supply a string variable (parameter sReturnError) 1068 | 'for any error messages this will be set blank if no problems found. 1069 | Const FNREF = "clSerialAPIread " 1070 | On Error GoTo ErorHandlr 1071 | Dim lngStaatus As Long 1072 | Dim strData As String 1073 | clSerialAPIread = "" 1074 | sReturnError = "" 'Assume no problems 1075 | 1076 | If z_iBaud = 0 Then 1077 | sReturnError = "Attempt to read an unitialised port " 1078 | Exit Function 1079 | End If 1080 | 1081 | If z_bIsOpen = False Then 1082 | sReturnError = "Attempt to read a closed port " 1083 | Exit Function 1084 | End If 1085 | 1086 | ' Read maximum of iMaxBytesIn bytes from serial port. 1087 | lngStaatus = CommRead(strData, iMaxBytesIn) 1088 | If lngStaatus > 0 Then 1089 | clSerialAPIread = strData ' Get data. All okay. 1090 | ElseIf lngStaatus < 0 Then 1091 | sReturnError = "API read handle error" ' Handle error. 1092 | End If 1093 | Exit Function ' Exit to avoid handler. 1094 | ErorHandlr: ' Error-handling routine. 1095 | sReturnError = FNREF & "Error " & Err.Number & ", " & Err.Description 1096 | End Function 1097 | 1098 | Public Function clSerialAPIwrite(ByVal strData As String) As String 1099 | 'Returns blank string if okay else message 1100 | Const FNREF = "clSerialAPIwrite " 1101 | On Error GoTo ErorHandlr 1102 | Dim lngSize, lngStaatus As Long 1103 | 1104 | clSerialAPIwrite = "" 'Assume no problems 1105 | If z_iBaud = 0 Then 1106 | clSerialAPIwrite = "Attempt to write to an unitialised port " 1107 | Exit Function 1108 | End If 1109 | 1110 | lngSize = Len(strData) 1111 | lngStaatus = CommWrite(strData) 1112 | If lngStaatus <> lngSize Then 1113 | clSerialAPIwrite = "API write handle error" 1114 | End If 1115 | Exit Function ' Exit to avoid handler. 1116 | ErorHandlr: ' Error-handling routine. 1117 | clSerialAPIwrite = FNREF & "Error " & Err.Number & ", " & Err.Description 1118 | End Function 1119 | 1120 | Public Function clSerialAPIclose() As String 1121 | 'Returns blank string if okay else message 1122 | Const FNREF = "clSerialAPIclose " 1123 | On Error GoTo ErorHandlr 1124 | Dim lRetn As Long 1125 | 'Close communications. 1126 | 'More than one close is not harmful so no need for complications 1127 | clSerialAPIclose = "" 'Assume no problems 1128 | lRetn = CommClose 'returns 0 if ok 1129 | If lRetn = 0 Then 1130 | z_bIsOpen = False 'To say closed 1131 | Else 1132 | clSerialAPIclose = "Problem closing " & Str(lRetn) 1133 | End If 1134 | Exit Function ' Exit to avoid handler. 1135 | ErorHandlr: ' Error-handling routine. 1136 | clSerialAPIclose = FNREF & "Error " & Err.Number & ", " & Err.Description 1137 | End Function 1138 | 1139 | Public Function clSerialAPIflush() As String 1140 | 'Returns blank string if okay else message 1141 | Const FNREF = "clSerialAPIclose " 1142 | On Error GoTo ErorHandlr 1143 | Dim lRetn As Long 1144 | clSerialAPIflush = "" 'Assume operation is ok 1145 | 1146 | If z_bIsOpen = False Then 1147 | clSerialAPIflush = "Attempt to flush a closed port" 1148 | Exit Function 1149 | End If 1150 | 1151 | lRetn = CommFlush 1152 | If lRetn <> 0 Then 1153 | clSerialAPIflush = "Problem flushing, Error: " & Str(lRetn) & " " & GetSystemMessage(lRetn) 1154 | End If 1155 | 1156 | Exit Function ' Exit to avoid handler. 1157 | ErorHandlr: ' Error-handling routine. 1158 | clSerialAPIflush = FNREF & "Error " & Err.Number & ", " & Err.Description 1159 | End Function 1160 | 1161 | Public Function clSerialAPIsetBREAK(ByVal bInStaet As Boolean) As String 1162 | clSerialAPIsetBREAK = fixLine(LINE_BREAK, bInStaet) 1163 | End Function 1164 | 1165 | Public Function clSerialAPIsetDTR(ByVal bInStaet As Boolean) As String 1166 | clSerialAPIsetDTR = fixLine(LINE_DTR, bInStaet) 1167 | End Function 1168 | 1169 | Public Function clSerialAPIsetRTS(ByVal bInStaet As Boolean) As String 1170 | clSerialAPIsetRTS = fixLine(LINE_RTS, bInStaet) 1171 | End Function 1172 | 1173 | 'The following get information about the port 1174 | Public Property Get clSerialAPIgetBaud() As Integer 1175 | clSerialAPIgetBaud = z_iBaud 1176 | End Property 1177 | 1178 | Public Property Get clSerialAPIgetIsOpen() As Boolean 1179 | clSerialAPIgetIsOpen = z_bIsOpen 1180 | End Property 1181 | 1182 | Public Function clSerialAPIgetLines() As String 1183 | 'Returns a series of 1 or 0 to represent line states of CD CTS DSR RING RLSD 1184 | 'or an error message 1185 | Const FNREF = "clSerialAPIgetLines " 1186 | On Error GoTo ErorHandlr 1187 | Dim sSts, sErrRetn As String 1188 | 1189 | If z_bIsOpen = False Then 1190 | clSerialAPIgetLines = "Open port before changing line states" 1191 | End If 1192 | 1193 | sSts = "" 1194 | sErrRetn = "" 'No error assumed, this will be passed to getState to populate if error seen 1195 | 1196 | Do While True 1197 | 'A once through only loop 1198 | sSts = sSts + getState(LINE_CD, "CD", sErrRetn) 1199 | If sErrRetn <> "" Then 1200 | Exit Do 1201 | End If 1202 | sSts = sSts + getState(LINE_CTS, "CTS", sErrRetn) 1203 | If sErrRetn <> "" Then 1204 | Exit Do 'with error in sErrRetn 1205 | End If 1206 | sSts = sSts + getState(LINE_DSR, "DSR", sErrRetn) 1207 | If sErrRetn <> "" Then 1208 | Exit Do 1209 | End If 1210 | sSts = sSts + getState(LINE_RING, "RING", sErrRetn) 1211 | If sErrRetn <> "" Then 1212 | Exit Do 1213 | End If 1214 | sSts = sSts + getState(LINE_RLSD, "RLSD", sErrRetn) 1215 | ' If sErrRetn <> "" Then 1216 | ' Exit Do 1217 | ' End If 1218 | Exit Do 'Important as once only 1219 | Loop 1220 | If sErrRetn = "" Then 1221 | clSerialAPIgetLines = sSts 'No problems 1222 | Else 1223 | clSerialAPIgetLines = sErrRetn 'Problem(s) seen 1224 | End If 1225 | Exit Function ' Exit to avoid handler. 1226 | ErorHandlr: ' Error-handling routine. 1227 | clSerialAPIgetLines = FNREF & "Error " & Err.Number & ", " & Err.Description 1228 | End Function 1229 | 1230 | Public Property Get clSerialAPIgetVersion() As String 1231 | 'Use as for example... MsgBox(YourClass.clSerialAPIgetVersion) 1232 | clSerialAPIgetVersion = scVersion 1233 | End Property 1234 | 1235 | '-------------API serial port public functions End 1236 | 1237 | 1238 | 1239 | -------------------------------------------------------------------------------- /frmVB6serialAPtest.frm: -------------------------------------------------------------------------------- 1 | VERSION 5.00 2 | Begin VB.Form frmVB6serialAPItest 3 | Caption = "Test for class for one serial API port" 4 | ClientHeight = 6465 5 | ClientLeft = 120 6 | ClientTop = 450 7 | ClientWidth = 8535 8 | LinkTopic = "Form1" 9 | ScaleHeight = 6465 10 | ScaleWidth = 8535 11 | StartUpPosition = 3 'Windows Default 12 | Begin VB.Frame frameLines 13 | Caption = "Control Lines" 14 | Height = 1095 15 | Left = 1800 16 | TabIndex = 26 17 | Top = 3750 18 | Visible = 0 'False 19 | Width = 2295 20 | Begin VB.CommandButton cmdRTS0 21 | Caption = "RTS0" 22 | Height = 345 23 | Left = 1560 24 | TabIndex = 32 25 | Top = 270 26 | Width = 615 27 | End 28 | Begin VB.CommandButton cmdDTR0 29 | Caption = "DTR0" 30 | Height = 345 31 | Left = 840 32 | TabIndex = 31 33 | Top = 270 34 | Width = 615 35 | End 36 | Begin VB.CommandButton cmdBRK0 37 | Caption = "BRK0" 38 | Height = 345 39 | Left = 120 40 | TabIndex = 30 41 | Top = 270 42 | Width = 615 43 | End 44 | Begin VB.CommandButton cmdRTS1 45 | Caption = "RTS1" 46 | Height = 345 47 | Left = 1560 48 | TabIndex = 29 49 | Top = 660 50 | Width = 615 51 | End 52 | Begin VB.CommandButton cmdDTR1 53 | Caption = "DTR1" 54 | Height = 345 55 | Left = 840 56 | TabIndex = 28 57 | Top = 660 58 | Width = 615 59 | End 60 | Begin VB.CommandButton cmdBRK1 61 | Caption = "BRK1" 62 | Height = 345 63 | Left = 120 64 | TabIndex = 27 65 | Top = 660 66 | Width = 615 67 | End 68 | End 69 | Begin VB.Frame FrameErrors 70 | Caption = "ERRORS" 71 | Height = 975 72 | Left = 120 73 | TabIndex = 23 74 | Top = 4950 75 | Width = 8415 76 | Begin VB.TextBox txbErrors 77 | Height = 525 78 | Left = 120 79 | TabIndex = 25 80 | Top = 330 81 | Width = 8175 82 | End 83 | Begin VB.CommandButton butClearErrorReport 84 | Caption = "Clear Error box" 85 | Height = 255 86 | Left = 2040 87 | TabIndex = 24 88 | Top = 120 89 | Width = 1335 90 | End 91 | End 92 | Begin VB.TextBox tbxWrite 93 | Height = 405 94 | Left = 1800 95 | TabIndex = 21 96 | Text = "Hello serial API sender" 97 | Top = 1920 98 | Width = 6615 99 | End 100 | Begin VB.TextBox txbVersion 101 | Height = 405 102 | Left = 5400 103 | TabIndex = 14 104 | Top = 6000 105 | Width = 3015 106 | End 107 | Begin VB.TextBox txbStatus 108 | Height = 405 109 | Left = 1800 110 | TabIndex = 13 111 | Text = "NOT SET UP (1)" 112 | Top = 3210 113 | Width = 6615 114 | End 115 | Begin VB.TextBox txbRead 116 | Height = 525 117 | Left = 1800 118 | TabIndex = 12 119 | Top = 2550 120 | Width = 6615 121 | End 122 | Begin VB.TextBox txbBaud 123 | Height = 345 124 | Left = 1800 125 | TabIndex = 10 126 | Text = "Text1" 127 | Top = 810 128 | Width = 975 129 | End 130 | Begin VB.TextBox txbPortNumber 131 | Height = 345 132 | Left = 1800 133 | TabIndex = 8 134 | Text = "Text1" 135 | Top = 210 136 | Width = 975 137 | End 138 | Begin VB.CommandButton butSetUpBaud 139 | Caption = "Setup Baud" 140 | Height = 490 141 | Left = 120 142 | TabIndex = 7 143 | Top = 690 144 | Width = 1220 145 | End 146 | Begin VB.CommandButton butInit 147 | Caption = "Init" 148 | Height = 490 149 | Left = 120 150 | TabIndex = 6 151 | Top = 120 152 | Width = 1220 153 | End 154 | Begin VB.CommandButton cmdFlush 155 | Caption = "Flush" 156 | Height = 490 157 | Left = 120 158 | TabIndex = 5 159 | Top = 3780 160 | Width = 1220 161 | End 162 | Begin VB.CommandButton cmdStatus 163 | Caption = "Show Status" 164 | Height = 490 165 | Left = 120 166 | TabIndex = 4 167 | Top = 3150 168 | Width = 1220 169 | End 170 | Begin VB.CommandButton cmdClose 171 | Caption = "Close" 172 | Height = 490 173 | Left = 120 174 | TabIndex = 3 175 | Top = 4410 176 | Width = 1220 177 | End 178 | Begin VB.CommandButton cmdRead 179 | Caption = "Read" 180 | Height = 490 181 | Left = 120 182 | TabIndex = 2 183 | Top = 2520 184 | Width = 1220 185 | End 186 | Begin VB.CommandButton cmdWrite 187 | Caption = "Write" 188 | Height = 490 189 | Left = 120 190 | TabIndex = 1 191 | Top = 1860 192 | Width = 1220 193 | End 194 | Begin VB.CommandButton cmdOpen 195 | Caption = "Open" 196 | Height = 490 197 | Left = 120 198 | TabIndex = 0 199 | Top = 1260 200 | Width = 1220 201 | End 202 | Begin VB.Label labToClose 203 | Caption = "To Close: Press close button first then X above." 204 | Height = 495 205 | Left = 6240 206 | TabIndex = 34 207 | Top = 60 208 | Width = 2175 209 | End 210 | Begin VB.Label labCrLf 211 | Caption = "Put \r for and \n for " 212 | Height = 315 213 | Left = 6000 214 | TabIndex = 33 215 | Top = 1620 216 | Width = 2415 217 | End 218 | Begin VB.Label Label8 219 | Caption = "<<" 220 | Height = 225 221 | Left = 1440 222 | TabIndex = 22 223 | Top = 2010 224 | Width = 255 225 | End 226 | Begin VB.Label Label7 227 | Caption = ">>" 228 | Height = 225 229 | Left = 1440 230 | TabIndex = 20 231 | Top = 3270 232 | Width = 255 233 | End 234 | Begin VB.Label Label6 235 | Caption = ">>" 236 | Height = 225 237 | Left = 1440 238 | TabIndex = 19 239 | Top = 2670 240 | Width = 255 241 | End 242 | Begin VB.Label Label5 243 | Caption = "<<" 244 | Height = 225 245 | Left = 1440 246 | TabIndex = 18 247 | Top = 840 248 | Width = 255 249 | End 250 | Begin VB.Label Label4 251 | Caption = "<<" 252 | Height = 225 253 | Left = 1440 254 | TabIndex = 17 255 | Top = 240 256 | Width = 255 257 | End 258 | Begin VB.Label Label3 259 | Alignment = 1 'Right Justify 260 | Caption = "clsVB6serialAPI version" 261 | Height = 315 262 | Left = 2880 263 | TabIndex = 16 264 | Top = 6060 265 | Width = 2415 266 | End 267 | Begin VB.Label Label2 268 | Caption = "frmVB6serialAPItest" 269 | Height = 285 270 | Left = 120 271 | TabIndex = 15 272 | Top = 6030 273 | Width = 1935 274 | End 275 | Begin VB.Label labBaud 276 | Caption = "Baud eg 2400 or 9600 etc" 277 | Height = 285 278 | Left = 2880 279 | TabIndex = 11 280 | Top = 810 281 | Width = 1935 282 | End 283 | Begin VB.Label labPortNumber 284 | Caption = "Port Number eg 1 or 18" 285 | Height = 285 286 | Left = 2880 287 | TabIndex = 9 288 | Top = 210 289 | Width = 1935 290 | End 291 | End 292 | Attribute VB_Name = "frmVB6serialAPItest" 293 | Attribute VB_GlobalNameSpace = False 294 | Attribute VB_Creatable = False 295 | Attribute VB_PredeclaredId = True 296 | Attribute VB_Exposed = False 297 | Option Explicit 298 | 299 | 'Program language used: Microsoft Visual Basic Six (VB6). 300 | 'This form provides a test for serial API port handling class clsVB6serialAPI 301 | 'and also demonstrates use of the public functions of the class. 302 | 'Class version control is at the top of the class code. 303 | 304 | 'Port 4 is default on startup as laptops without serial ports can use a USB to 305 | 'serial adapter that often is allocated to this port. 306 | 307 | 'CAUTION: When using the VB6 development system always close an open port then 308 | ' close the form (click top RHS X on form). 309 | ' Selecting Run/End when a port is open leads to failure to open the port next time. 310 | ' If this is experienced exit the development system (File/Exit) and restart. 311 | 312 | 'NB In this test code only one serial port is set up see Note 1 313 | 'however if several are needed it may be convenient to address them as an array 314 | 'as the following example shows... 315 | 'Public clSerAPI(PORT_FIRST To PORT_LAST) As clsVB6serialAPI 316 | 'Dim iPortNum As Integer 317 | 'For iPortNum = PORT_FIRST To PORT_LAST 318 | ' 'Go through every serial port that could be used 319 | ' Set clSerAPI(iPortNum) = New clsVB6serialAPI 'Make a new instance 320 | ' clSerAPI(iPortNum).clSerialAPIinitialise iPortNum 'Initialise the port 321 | 'Next iPortNum 322 | 323 | 'Modification record (latest float on top) 324 | 'CX003 Add line handling 14May2014 325 | 'CX002 clSerialAPIflush added to return string 13May2014 326 | 'CX001 add test if class object exists 07May2014 327 | 328 | Private clSerAPI As clsVB6serialAPI 329 | 330 | Private Sub Form_Load() 331 | txbStatus.Text = "Port not set up" 332 | 'Put in suggested starting port number and baud 333 | txbPortNumber.Text = "4" 334 | txbBaud.Text = "9600" 335 | End Sub 336 | 337 | Private Sub butInit_Click() 338 | 'Init port allocating port number but baud etc not yet set up 339 | Dim sErrorReturn, sPortNumber As String 340 | Dim iSerialPortToTest As Integer 341 | 342 | sPortNumber = txbPortNumber.Text 343 | If IsNumeric(sPortNumber) = False Then 344 | txbErrors.Text = "Type in port number to use as a number" 345 | Exit Sub 346 | End If 347 | iSerialPortToTest = Int(sPortNumber) 348 | 349 | If Not clSerAPI Is Nothing Then 350 | 'ie if class is something then... ie class was previously instantiated 351 | txbErrors.Text = "Serial API port number " & sPortNumber & " is already in use" 352 | Exit Sub 353 | End If 354 | 355 | Set clSerAPI = New clsVB6serialAPI 'make a new instance Note 1 356 | 357 | 'Check class was instantiated 358 | If clSerAPI Is Nothing Then 359 | 'Class was not instantiated 360 | txbErrors.Text = "Error: Class was not set up" 361 | Exit Sub 362 | End If 363 | 364 | sErrorReturn = clSerAPI.clSerialAPIinitialise(iSerialPortToTest) 'Add serial port class initialisation 365 | If sErrorReturn <> "" Then 366 | txbErrors.Text = sErrorReturn 367 | Else 368 | 'All set up ok 369 | frameLines.Visible = True 'allow line states to be changed 370 | End If 371 | cmdStatus_Click 'show status 372 | txbVersion.Text = clSerAPI.clSerialAPIgetVersion 373 | End Sub 374 | 375 | Private Sub butSetUpBaud_Click() 376 | 'Set baud and port description 377 | Dim sRetn, sBaud As String 378 | sRetn = "" 379 | 380 | 'CX001 add test if class object exists 381 | If clSerAPI Is Nothing Then 382 | 'API class needs setting up 383 | txbErrors.Text = "Initialise before setting Baud" 384 | Exit Sub 385 | End If 386 | 387 | sBaud = txbBaud.Text 388 | If IsNumeric(sBaud) = False Then 389 | txbErrors.Text = "Type in baud to use" 390 | Exit Sub 391 | End If 392 | 393 | 'Here class is something then... ie class was instantiated 394 | sRetn = clSerAPI.clSerialAPIsetBaud(sBaud) 395 | If sRetn <> "" Then 396 | txbErrors.Text = sRetn 397 | End If 398 | cmdStatus_Click 'show status 399 | End Sub 400 | 401 | Private Sub cmdStatus_Click() 402 | 'Test open close function and show status of port 403 | Dim iBaud As Integer 404 | Dim bIsOpen As Boolean 405 | Dim sOpenClosd, sPortNumber, sLineStates As String 406 | 407 | If clSerAPI Is Nothing Then 408 | 'ie if class was not instantiated 409 | txbErrors.Text = "Initialise before reading status" 410 | Exit Sub 411 | End If 412 | 413 | 'Get port number in use 414 | sPortNumber = txbPortNumber.Text 415 | If IsNumeric(sPortNumber) = False Then 416 | txbErrors.Text = "Type in port number to use" 417 | Exit Sub 418 | End If 419 | 420 | iBaud = clSerAPI.clSerialAPIgetBaud 421 | bIsOpen = clSerAPI.clSerialAPIgetIsOpen 422 | If bIsOpen = True Then 423 | sLineStates = clSerAPI.clSerialAPIgetLines 424 | sOpenClosd = "OPEN (" & sLineStates & ")" 425 | Else 426 | sOpenClosd = "CLOSED" 427 | End If 428 | txbStatus.Text = Format(sPortNumber, "00") & " " & iBaud & " baud " & " " & sOpenClosd 429 | End Sub 430 | 431 | Private Sub cmdOpen_Click() 432 | Dim sErrorReturn As String 433 | 434 | sErrorReturn = "" 435 | 'CX001 add test if class object exists 436 | If clSerAPI Is Nothing Then 437 | 'API class needs setting up 438 | txbErrors.Text = "Initialise before opening the port" 439 | Exit Sub 440 | End If 441 | 'Here class is something then... ie class was instantiated 442 | sErrorReturn = clSerAPI.clSerialAPIopen() 443 | If sErrorReturn <> "" Then 444 | txbErrors.Text = sErrorReturn 445 | End If 446 | cmdStatus_Click 'show status 447 | End Sub 448 | 449 | Private Sub cmdRead_Click() 450 | Dim sStringReadIn As String 451 | Dim sErrorReturn As String 452 | 453 | sErrorReturn = "" 454 | 'CX001 add test if class object exists 455 | If Not clSerAPI Is Nothing Then 456 | 'ie if class is something then... ie class was instantiated 457 | sStringReadIn = clSerAPI.clSerialAPIread(64, sErrorReturn) 458 | Else 459 | 'API class needs setting up 460 | sErrorReturn = "Initialise before Read" 461 | End If 462 | If sErrorReturn <> "" Then 463 | 'Problem seen 464 | txbErrors.Text = sErrorReturn 465 | txbRead.Text = "" 466 | Else 467 | 'No problems returned 468 | txbRead.Text = sStringReadIn 469 | End If 470 | End Sub 471 | 472 | Private Sub cmdWrite_Click() 473 | ' Write data to serial port. 474 | Dim sErrorReturn, sTextToWrite As String 475 | sErrorReturn = "" 476 | sTextToWrite = tbxWrite.Text 477 | sTextToWrite = Replace(sTextToWrite, "\r", vbCr) 478 | sTextToWrite = Replace(sTextToWrite, "\n", vbLf) 479 | 'CX001 add test if class object exists 480 | If Not clSerAPI Is Nothing Then 481 | 'ie if class is something then... ie class was instantiated 482 | sErrorReturn = clSerAPI.clSerialAPIwrite(sTextToWrite) 'Returns blank string if okay else message 483 | Else 484 | 'API class needs setting up 485 | sErrorReturn = "Initialise before Write" 486 | End If 487 | If sErrorReturn <> "" Then 488 | 'Problem seen 489 | txbErrors.Text = sErrorReturn 490 | End If 491 | End Sub 492 | 493 | Private Sub cmdClose_Click() 494 | 'This just closes the port, no shutdown 495 | clSerAPI.clSerialAPIclose 496 | cmdStatus_Click 'show status 497 | End Sub 498 | 499 | 'Test Flush 500 | Private Sub cmdFlush_Click() 501 | 'CX001 add test if class object exists 502 | Dim sRetn As String 503 | If clSerAPI Is Nothing Then 504 | 'API class needs setting up 505 | txbErrors.Text = "Initialise before flushing" 506 | Exit Sub 507 | End If 508 | sRetn = clSerAPI.clSerialAPIflush 509 | If sRetn <> "" Then 510 | 'Problem ocurred 511 | txbErrors.Text = sRetn 512 | End If 513 | End Sub 514 | 515 | Public Sub Form_Unload(Cancel As Integer) 516 | 'Closes comports and forms and shuts down. 517 | Dim sStr As String 518 | If Not clSerAPI Is Nothing Then 519 | 'ie if class is something then... ie class was instantiated 520 | sStr = clSerAPI.clSerialAPIclose 521 | showInfo "*** CLOSING... *** " & sStr 522 | End If 523 | Close ' Close all open files. 524 | 525 | 'If code below is not executed the application won't close properly 526 | Dim frmCurrent As Form 527 | For Each frmCurrent In Forms 528 | If Not "frmSAPIMain" = frmCurrent.Name Then 529 | Unload frmCurrent 530 | Set frmCurrent = Nothing 531 | End If 532 | Next 533 | End Sub 534 | 535 | Private Sub butClearErrorReport_Click() 536 | 'Clear Error box 537 | txbErrors.Text = "" 538 | End Sub 539 | 540 | Sub showInfo(ByVal sTeext As String) 541 | 'Show information in pop up box 542 | MsgBox sTeext, vbInformation 543 | End Sub 544 | 545 | 'Set BREAK DTR and RTS lines True(1) or False(0) - six routines 546 | Private Sub cmdBRK0_Click() 547 | 'Test below is not essential as frame with line buttons in is not visible on start up. 548 | If clSerAPI Is Nothing Then 549 | 'Class was not instantiated 550 | txbErrors.Text = "Error: Class not yet set up" 551 | Exit Sub 552 | End If 553 | txbErrors.Text = clSerAPI.clSerialAPIsetBREAK(False) 554 | cmdStatus_Click 'show status 555 | End Sub 556 | 557 | Private Sub cmdBRK1_Click() 558 | txbErrors.Text = clSerAPI.clSerialAPIsetBREAK(True) 559 | cmdStatus_Click 'show status 560 | End Sub 561 | 562 | Private Sub cmdDTR0_Click() 563 | txbErrors.Text = clSerAPI.clSerialAPIsetDTR(False) 564 | cmdStatus_Click 'show status 565 | End Sub 566 | 567 | Private Sub cmdDTR1_Click() 568 | txbErrors.Text = clSerAPI.clSerialAPIsetDTR(True) 569 | cmdStatus_Click 'show status 570 | End Sub 571 | 572 | Private Sub cmdRTS0_Click() 573 | txbErrors.Text = clSerAPI.clSerialAPIsetRTS(False) 574 | cmdStatus_Click 'show status 575 | End Sub 576 | 577 | Private Sub cmdRTS1_Click() 578 | txbErrors.Text = clSerAPI.clSerialAPIsetRTS(True) 579 | cmdStatus_Click 'show status 580 | End Sub 581 | '--------From end 582 | 583 | --------------------------------------------------------------------------------