modmisccomm.bas

Atmel Atmeag128 AVR弹片机 随书原码

Attribute VB_Name = "modMiscComm"
Option Explicit

Public BitRate As Long
Public Buffer As Variant
Public OneByteDelay As Single
Public PortExists As Boolean
Public PortInUse As Boolean
Public PortNumber As Integer
Public PortOpen As Boolean
Public SaveDataInFile As Boolean
Public TimedOut As Boolean
Public ValidPort As Boolean

'API declares:
Public Declare Function EscapeCommFunction _
    Lib "Kernel32" _
    (ByVal nCid As Long, _
    ByVal nFunc As Long) _
    As Long
Public Declare Function timeGetTime _
    Lib "winmm.dll" () _
    As Long
Public Declare Function TransmitCommChar _
    Lib "Kernel32" _
    (ByVal nCid As Long, _
    ByVal cChar As Byte) _
    As Long

Public Sub FlushBuffer()
    Dim S As String
    Dim j As Integer
    For j = 1 To frmComm.MSComm1.InBufferCount
        S = frmComm.MSComm1.Input
    Next
End Sub

Public Function fncDisplayDateAndTime() As String
'Date and time formatting.
fncDisplayDateAndTime = _
    CStr(Format(Date, "General Date")) & ", " & _
    (Format(Time, "Long Time"))
End Function

Public Function fncOneByteDelay(BitRate As Long) As Single
'Calculate the time in milliseconds to transmit
'8 bits + 1 Start & 1 Stop bit.
Dim DelayTime As Integer
DelayTime = 10000 / BitRate
If DelayTime < 1 Then DelayTime = 1
fncOneByteDelay = DelayTime
End Function

Public Sub Delay(DelayInMilliseconds As Single)
'Delay timer with approximately 1-msec. resolution.
'Uses the API function timeGetTime.
'Rolls over 24 days after the last Windows startup.
Dim Timeout As Single
Timeout = DelayInMilliseconds + timeGetTime()
Do Until timeGetTime() >= Timeout
    DoEvents
Loop
End Sub

Public Sub uSleep(SleepTime As Integer)
'Delay for number of iterations specified
'Use for sub millisecond delay
'Not calibrated
Dim j As Integer
For j = 1 To SleepTime
Next
End Sub


Public Sub FindPorts()
'Find Comm ports by trying to open each.
'Each port must support the current settings (bit rate, etc.).
Dim Count As Integer
Dim SavedPortNumber As Integer
Dim SaveCurrentPort As Boolean
ReDim CommPorts(1 To 16)
On Error Resume Next
SaveCurrentPort = False
NumberOfPorts = 0
'If a port is already open, reopen it on exiting.
If frmComm.MSComm1.PortOpen = True Then
        'xDebug.Print "FindPort", PortNumber
        frmComm.MSComm1.PortOpen = False
        SavedPortNumber = PortNumber
        SaveCurrentPort = True
End If
For Count = 1 To 16
    frmComm.MSComm1.CommPort = Count
    frmComm.MSComm1.PortOpen = True
    If Err.Number = 8005 Then
        'The port is already open
        'The port exists, so add it to the list.
        NumberOfPorts = NumberOfPorts + 1
        CommPorts(NumberOfPorts) = "COM" & CStr(Count)
    ElseIf frmComm.MSComm1.PortOpen = True Then
        'If the port opens, it exists.
        'Close it and add to the list.
        frmComm.MSComm1.PortOpen = False
        NumberOfPorts = NumberOfPorts + 1
        CommPorts(NumberOfPorts) = "COM" & CStr(Count)
    Err.Clear
    End If
Next Count
'Disable the error handler
On Error GoTo 0
ReDim Preserve CommPorts(1 To NumberOfPorts)
If SaveCurrentPort = True Then
    PortNumber = SavedPortNumber
    frmComm.MSComm1.CommPort = PortNumber
    frmComm.MSComm1.PortOpen = True
End If
End Sub


'  Parses data from the received data array, ByteArrayRcv,
'  and places variables in the variant array VarArrayRcv

Public Sub ParseRecdData(ParseStr As String)

End Sub


Public Function fncByteToAsciiHex _
    (ByteToConvert As Byte) _
    As String
'Converts a byte to a 2-character ASCII Hex string
Dim AsciiHex As String
AsciiHex = Hex$(ByteToConvert)
If Len(AsciiHex) = 1 Then
    AsciiHex = "0" & AsciiHex
End If
fncByteToAsciiHex = AsciiHex
End Function

Public Function fncHexAsciiToByte _
      (InputStrToConvert As String) As Byte
'Converts a 2-char Ascii string to a Byte
      fncHexAsciiToByte = _
                Val("&H" & InputStrToConvert)
End Function

Public Function IntToByte(IntVal As Integer, ErrorFlag As Integer) As Byte
    If (IntVal < 0) Or IntVal > 255 Then
        IntToByte = CByte(IntVal And &HFF)
        ErrorFlag = 1
    Else
        IntToByte = CByte(IntVal)
        ErrorFlag = 0
    End If
End Function

Public Function LongToByte(LongVal As Long, ErrorFlag As Integer) As Byte
    If (LongVal < 0) Or LongVal > 255 Then
        LongToByte = 255
        ErrorFlag = 1
    Else
        LongToByte = CByte(LongVal)
        ErrorFlag = 0
    End If
End Function

Public Function LongToInt(LongVal As Long, ErrorFlag As Integer) As Integer
    '-32,768 to 32,767
    If (LongVal < -32768) Or LongVal > 32767 Then
        LongToInt = 32767
        ErrorFlag = 1
    Else
        LongToInt = CInt(LongVal)
        ErrorFlag = 0
    End If
End Function

Public Function IsByteOK()
    
End Function


' Converts string of numeric chars to value, places decimal left of x digits from right
Public Function StrToInt(S As String, DecimalLoc As Integer, DisplayLen As Integer) As String
    Dim S1 As String
    'S1 = Left(S, Len(S) - DecimalLoc) & "." & Right(S, DecimalLoc)
    StrToInt = Format(Str(Val(S) / 100), " ##.00")
End Function

Public Function RealToStr(R As Double) As String
    Dim i As Integer
    i = CInt(R)
    RealToStr = CStr(i)
    'Debug.Print RealToStr
End Function

Public Sub PutStrCR(S As String)
    frmComm.MSComm1.Output = S & Chr(13)
End Sub

Public Sub PutStr(S As String)
    frmComm.MSComm1.Output = S
End Sub