关于压缩BCD

Question

Function Dec2Bin(InputData As Double) As String
''
''  Converts Decimal to Binary
''  This uses the Quotient Remainder method
''
Dim Quot As Double
Dim Remainder As Double
Dim BinOut As String
Dim I As Integer
Dim NewVal As Double
Dim TempString As String
Dim TempVal As Double
Dim BinTemp As String
Dim BinTemp1 As String
Dim PosDot As Integer
Dim Temp2 As String
''  Check to see if there is a decimal point or not
''
If InStr(1, CStr(InputData), ".") Then
  MsgBox "Only Whole Numbers can be converted", vbCritical
  GoTo eds
End IfBinOut = ""
NewVal = InputData
DoAgain:''  Start the Calculations off
NewVal = (NewVal / 2)
''  If we have a remainder
If InStr(1, CStr(NewVal), ".") Then
  BinOut = BinOut + "1"
  
  '' Get rid of the Remainder
  NewVal = Format(NewVal, "#0")
  NewVal = (NewVal - 1)
  
   If NewVal < 1 Then
     GoTo DoneIt
   End If
Else
  BinOut = BinOut + "0"
   If NewVal < 1 Then
     GoTo DoneIt
   End If
End If
GoTo DoAgainDoneIt:
BinTemp = ""''  Reverse the Result
For I = Len(BinOut) To 1 Step -1
 BinTemp1 = Mid(BinOut, I, 1)
 BinTemp = BinTemp + BinTemp1
Next IBinOut = BinTemp'' Output the Result
Dec2Bin = BinOut
eds:
End Function

Answer 1

Function Bin2Dec(InputData As String) As Double
''
''  This converts Binary to Decimal
''
Dim DecOut As Double
Dim I As Integer
Dim LenBin As Double
Dim JOne As StringLenBin = Len(InputData)''
''  Make sure that it is a Binary Number
''
For I = 1 To LenBin
 JOne = Mid(InputData, I, 1)
   If JOne <> "0" And JOne <> "1" Then
     MsgBox "NOT A BINARY NUMBER", vbCritical
     Exit Function
   End If
Next I
DecOut = 0
For I = Len(InputData) To 1 Step -1
  If Mid(InputData, I, 1) = "1" Then
    DecOut = DecOut + 2 ^ (Len(InputData) - I)
  End If
Next I
        
  Bin2Dec = DecOut
        
End Function

Answer 2

把前面的double改成bytePrivate Sub cmdOpen_Click()
    MSComm1.CommPort = 1
    MSComm1.InputMode = comInputModeBinary
    MSComm1.RThreshold = 1
    MSComm1.PortOpen = True
    MSComm1.RThreshold = 1
    cmdOpen.Enabled = False
End Sub
Private Sub cmdSend_Click()
    Dim OutByte(0) As Byte
    Dim tmpstr As String
    Dim I As Integer
    
    If txtSend.Text = "" Then
        MsgBox "请输入要发送的数据！", vbExclamation, "提示"
        txtSend.SetFocus
    End If
''''''
'我只修改了能够发送一个byte
''''''    
    OutByte(0) = Bin2Dec(txtSend.Text)
        
    MSComm1.Output = OutByte
End SubPrivate Sub Form_Unload(Cancel As Integer)
    If MSComm1.PortOpen Then MSComm1.PortOpen = False
End SubPrivate Sub MSComm1_OnComm()
    Select Case MSComm1.CommEvent
        Case comEventBreak '收到中断讯号
        Case comEventCDTO '
        Case comEventCTSTO
        Case comEventDSRTO
        Case comEventFrame
        Case comEventOverrun '数据遗失
        Case comEventRxOver '接收缓冲区漫溢
        Case comEventRxParity '极性错误
        Case comEventTxFull '传送缓冲区漫溢
        Case comEventDCB '未预期错误
        Case comEvCD
        Case comEvCTS
        Case comEvDSR
        Case comEvRing
        Case comEvReceive '收到字符
            Dim InByte() As Byte
            Dim I As Integer
            Dim buf As String
            
            InByte = MSComm1.Input
            
            buf = ""
            For I = LBound(InByte) To UBound(InByte)
                buf = buf & Dec2Bin(InByte(I)) & vbCrLf
            Next I
'获取回来以后，在ListBox中显示其二进制
            ListRevive.AddItem buf
        Case comEvSend
        Case comEvEOF
    End Select
End Sub