51

51单片机大量源码

Dim bytTemp As Byte
Dim strTemp As String
Dim lLocation As Long
abytS = StrConv(strs, vbFromUnicode)
For lLocation = 0 To UBound(abytS)
bytTemp = abytS(lLocation)
strTemp = Hex(bytTemp)
strTemp = Right("00" & strTemp, 2)
StrtoHex = StrtoHex & strTemp
Next lLocation
End Function
Public Function HextoStr(ByVal strs As String) As String '16 to str
Dim i    As Integer, tmp       As String
If Len(strs) Mod 2 Then Exit Function
For i = 1 To Len(strs) Step 2
          n = Val("&H" & Mid(strs, i, 2))
          If n < 0 Or n > 127 Then
                  n = Val("&H" & Mid(strs, i, 4))
                    i = i + 2
          End If
          tmp = tmp & Chr(n)
Next i
HextoStr = tmp
End Function





Private Sub Command2_Click()
If ComPort.PortOpen = False Then
 MsgBox "请先连接串口，然后在操作", vbInformation, "锐志电子温馨提示"
 Exit Sub
 End If


zd = 0
Timer1.Enabled = True
End Sub




Public Function D_To_B(ByVal Dec As Long) As String
    Do
        D_To_B = Dec Mod 2 & D_To_B
        Dec = Dec \ 2
    Loop While Dec
End Function

Public Function B_To_D(ByVal Bin As String) As Integer
    Dim i As Long
    For i = 1 To Len(Bin)
        B_To_D = B_To_D * 2 + Val(Mid(Bin, i, 1))
    Next i
End Function

Public Function H_To_B(ByVal Hex As String) As String
    Dim i As Long
    Dim B As String
    
    Hex = UCase(Hex)
    For i = 1 To Len(Hex)
        Select Case Mid(Hex, i, 1)
            Case "0": B = B & "0000"
            Case "1": B = B & "0001"
            Case "2": B = B & "0010"
            Case "3": B = B & "0011"
            Case "4": B = B & "0100"
            Case "5": B = B & "0101"
            Case "6": B = B & "0110"
            Case "7": B = B & "0111"
            Case "8": B = B & "1000"
            Case "9": B = B & "1001"
            Case "A": B = B & "1010"
            Case "B": B = B & "1011"
            Case "C": B = B & "1100"
            Case "D": B = B & "1101"
            Case "E": B = B & "1110"
            Case "F": B = B & "1111"
        End Select
    Next i
    While Left(B, 1) = "0"
        B = Right(B, Len(B) - 1)
    Wend
    H_To_B = Format(B, "00000000")
End Function

Public Function B_To_H(ByVal Bin As String) As String
    Dim i As Long
    Dim H As String
    If Len(Bin) Mod 4 <> 0 Then
        Bin = String(4 - Len(Bin) Mod 4, "0" & Bin)
    End If
    
    For i = 1 To Len(Bin) Step 4
        Select Case Mid(Bin, i, 4)
            Case "0000": H = H & "0"
            Case "0001": H = H & "1"
            Case "0010": H = H & "2"
            Case "0011": H = H & "3"
            Case "0100": H = H & "4"
            Case "0101": H = H & "5"
            Case "0110": H = H & "6"
            Case "0111": H = H & "7"
            Case "1000": H = H & "8"
            Case "1001": H = H & "9"
            Case "1010": H = H & "A"
            Case "1011": H = H & "B"
            Case "1100": H = H & "C"
            Case "1101": H = H & "D"
            Case "1110": H = H & "E"
            Case "1111": H = H & "F"
        End Select
    Next i
    B_To_H = H
End Function
Function Long2Bin(Data As Long) As String
    Dim tmp As String
    tmp = ""
    tmp = tmp & IIf(Data And 32768, "1", "0")
    tmp = tmp & IIf(Data And 16384, "1", "0")
    tmp = tmp & IIf(Data And 8192, "1", "0")
    tmp = tmp & IIf(Data And 4096, "1", "0")
    tmp = tmp & IIf(Data And 2048, "1", "0")
    tmp = tmp & IIf(Data And 1024, "1", "0")
    tmp = tmp & IIf(Data And 512, "1", "0")
    tmp = tmp & IIf(Data And 256, "1", "0")
    tmp = tmp & IIf(Data And 128, "1", "0")
    tmp = tmp & IIf(Data And 64, "1", "0")
    tmp = tmp & IIf(Data And 32, "1", "0")
    tmp = tmp & IIf(Data And 16, "1", "0")
    tmp = tmp & IIf(Data And 8, "1", "0")
    tmp = tmp & IIf(Data And 4, "1", "0")
    tmp = tmp & IIf(Data And 2, "1", "0")
    tmp = tmp & IIf(Data And 1, "1", "0")
    Long2Bin = tmp
End Function






Private Sub Command5_Click()
Timer1.Enabled = False
End Sub

Private Sub Form_Load()


    '端口循环计数器
    Dim iComPort As Integer

    '错误陷阱
    On Error GoTo CommErrorHandle
    
    '尝试列表存在端口
    For iComPort = 1 To 16
        ComPort.CommPort = iComPort '指定端口号
        If ComPort.PortOpen = True Then ComPort.PortOpen = False '如打开先关闭
        ComPort.PortOpen = True  '尝试打开
        ComPort.PortOpen = False '确认成功关闭
    Next
    
    '端口配置
    ComPort.InputLen = 1    '1 个字符产生接收事件
    ComPort.RThreshold = 1  '1 个字符产生接收事件
    
    '跳出错误
    Exit Sub
CommErrorHandle:

    '68   = 设备无效
    '8002 = 端口号无效
    '8012 = 端口无法打开
    If Err = 68 Or Err = 8002 Or Err = 8012 Then
        '端口无效时则禁止单击连接按钮
        optComPort(iComPort - 1).Enabled = False
    End If
    
    '继续错误
    Resume Next
    
End Sub

Private Sub ComPort_OnComm()
'如果已经接收数据，则继续
    On Error Resume Next
    If ComPort.CommEvent <> comEvReceive Then Exit Sub
    Dim intInputLen As Integer
    Select Case Me.ComPort.CommEvent
        Case comEvReceive
            '此处添加处理接收的代码
            ComPort.InputMode = comInputModeBinary '二进制接收
            intInputLen = ComPort.InBufferCount
            ReDim bytInput(intInputLen)
            bytInput = ComPort.Input
            
            jieshou
           
    End Select
End Sub

Public Function jieshou() '接收数据处理为16进制
    Dim i As Integer
    For i = 0 To UBound(bytInput)
        If Len(Hex(bytInput(i))) = 1 Then
            strData = strData & "0" & Hex(bytInput(i))
            'Debug.Print strData
        Else
            strData = strData & Hex(bytInput(i))
          
        End If
       
         Text3 = Hex(bytInput(i))
           Text2 = Right$("00" & Text3, 2)
            Text3 = H_To_B(Text3)
            If Text2 = "00" Then
            Text3 = "00000000"
            End If
            
For ii = 1 To 8
df = Mid$(Text3, ii, 1)
    If df = 0 Then
    Shape2.Item(7 - (ii - 1)).FillColor = &HFF
    'Check2.Item(7 - (ii - 1)).Value = 1
    Else
    Shape2.Item(7 - (ii - 1)).FillColor = &HFFFFFF
     'Check2.Item(7 - (ii - 1)).Value = 0
    End If
    Next ii
    Next
    'Text2 = strData
   
End Function

'**********************************
'字符表示的十六进制数转化为相应的整数
'错误则返回  -1
'**********************************

Function ConvertHexChr(str As String) As Integer
    
    Dim test As Integer
    
    test = Asc(str)
    If test >= Asc("0") And test <= Asc("9") Then
        test = test - Asc("0")
    ElseIf test >= Asc("a") And test <= Asc("f") Then
        test = test - Asc("a") + 10
    ElseIf test >= Asc("A") And test <= Asc("F") Then
        test = test - Asc("A") + 10
    Else
        test = -1                                       '出错信息
    End If
    ConvertHexChr = test
    
End Function




Function strHexToByteArray(strText As String, bytByte() As Byte) As Integer
    
    Dim HexData As Integer          '十六进制(二进制)数据字节对应值
    Dim hstr As String * 1          '高位字符
    Dim lstr As String * 1          '低位字符
    Dim HighHexData As Integer      '高位数值
    Dim LowHexData As Integer       '低位数值
    Dim HexDataLen As Integer       '字节数
    Dim StringLen As Integer        '字符串长度
    Dim Account As Integer          '计数
        
    strTestn = ""                   '设初值
    HexDataLen = 0
    strHexToByteArray = 0
    
    StringLen = Len(strText)
    Account = StringLen \ 2
    ReDim bytByte(Account)
    
    For n = 1 To StringLen
    
        Do                                              '清除空格
            hstr = Mid(strText, n, 1)
            n = n + 1
            If (n - 1) > StringLen Then
                HexDataLen = HexDataLen - 1
                
                Exit For
            End If
        Loop While hstr = " "
        
        Do
            lstr = Mid(strText, n, 1)
            n = n + 1
            If (n - 1) > StringLen Then
                HexDataLen = HexDataLen - 1
                
                Exit For
            End If
        Loop While lstr = " "
        n = n - 1
        If n > StringLen Then
            HexDataLen = HexDataLen - 1
            Exit For
        End If
        
        HighHexData = ConvertHexChr(hstr)
        LowHexData = ConvertHexChr(lstr)
        
        If HighHexData = -1 Or LowHexData = -1 Then     '遇到非法字符中断转化
            HexDataLen = HexDataLen - 1
            
            Exit For
        Else
            
            HexData = HighHexData * 16 + LowHexData
            bytByte(HexDataLen) = HexData
            HexDataLen = HexDataLen + 1
            
            
        End If
                        
    Next n
    
    If HexDataLen > 0 Then                              '修正最后一次循环改变的数值
        HexDataLen = HexDataLen - 1
        ReDim Preserve bytByte(HexDataLen)
    Else
        ReDim Preserve bytByte(0)
    End If
    
    
    If StringLen = 0 Then                               '如果是空串,则不会进入循环体
        strHexToByteArray = 0
    Else
        strHexToByteArray = HexDataLen + 1
    End If
    
    
End Function



Private Sub Form_QueryUnload(Cancel As Integer, UnloadMode As Integer)

    '断开连接并退出
    If ComPort.PortOpen = True Then ComPort.PortOpen = False

End Sub



Private Sub Text4_Change()
Text6.Text = B_To_H(Text4.Text)
End Sub
Private Sub Pause(interval)
Current = Timer
Do While Timer - Current < Val(interval)
DoEvents
Loop
End Sub

Private Sub Timer1_Timer()
Text1.Text = DecimaltoHex(zd)
longth = strHexToByteArray(Text1, bytSendByte())
        
        If longth > 0 Then
            ComPort.Output = bytSendByte
        End If
        zd = zd + 1
If zd > 255 Then
zd = 0
End If
   
End Sub