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 Command3_Click(Index As Integer)
If ComPort.PortOpen = False Then
 MsgBox "請先連接串口，然后在操作", vbInformation, "銳志電子溫馨提示"
 Exit Sub
 End If


Select Case Index
Case 0
 sendbin ("C0")
 Case 1
 sendbin ("F9")
 
 Case 2
 sendbin ("A4")
 Case 3
 sendbin ("B0")
 
 Case 4
 sendbin ("99")
 Case 5
 sendbin ("92")

 Case 6
 sendbin ("82")
 Case 7
 sendbin ("F8")
 
 Case 8
 sendbin ("80")
 Case 9
 sendbin ("90")
 
 Case 10
 sendbin ("88")
 
 Case 11
 
 sendbin ("83")
 
 Case 12
 
 sendbin ("C6")
 
 Case 13
 
 sendbin ("A1")
 
 Case 14
 
 sendbin ("86")
 
 Case 15
 
 sendbin ("8E")



End Select
End Sub

Private Sub Form_Load()

yy = 1
    '端口循環計數器
   
    
    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 = Mid(Text5.Text, yy, 2)
sendbin (Text1.Text)
yy = yy + 2
If yy = Len(Text5.Text) + 3 Then
yy = 1
End If


   
End Sub
Private Sub sendbin(sendchar As String)

 longth = strHexToByteArray(sendchar, bytSendByte())
        
        If longth > 0 Then
         If ComPort.PortOpen = True Then
            ComPort.Output = bytSendByte
            End If
        End If
        End Sub