frmbaseconv.frm

来自「vb精彩编程希望大家有用」· FRM 代码 · 共 564 行 · 第 1/2 页

    NewVal = InputData
DoAgain:
    '采用除2取余法转换
    NewVal = (NewVal / 2)
    If InStr(1, CStr(NewVal), ".") Then
        BinOut = BinOut + "1"
        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 DoAgain
DoneIt:
    BinTemp = ""
    For I = Len(BinOut) To 1 Step -1
        BinTemp1 = Mid(BinOut, I, 1)
        BinTemp = BinTemp + BinTemp1
    Next I
    BinOut = BinTemp
    Dec2Bin = BinOut
eds:
End Function
Function Bin2Hex(InputData As String) As String
    '二进制转十六进制
    Dim I As Integer
    Dim LenBin As Integer
    Dim JOne As String
    Dim NumBlocks As Integer
    Dim FullBin As String
    Dim HexOut As String
    Dim TempBinBlock As String
    Dim TempHex As String
    LenBin = Len(InputData)
    For I = 1 To LenBin
        JOne = Mid(InputData, I, 1)
        If JOne <> "0" And JOne <> "1" Then
            MsgBox "输入的不是一个二进制数！", vbCritical
            Exit Function
        End If
    Next I
    FullBin = InputData
    If LenBin < 4 Then
        '不足四位，填满四位
        If LenBin = 3 Then
            FullBin = "0" + FullBin
        ElseIf LenBin = 2 Then
            FullBin = "00" + FullBin
        ElseIf LenBin = 1 Then
            FullBin = "000" + FullBin
        ElseIf LenBin = 0 Then
            MsgBox "无有效数..", vbCritical
            Exit Function
        End If
        NumBlocks = 1
        GoTo DoBlocks
    End If
    If LenBin = 4 Then
        NumBlocks = 1
        GoTo DoBlocks
    End If
    If LenBin > 4 Then
        Dim TempHold As Currency
        Dim TempDiv As Currency
        Dim AfterDot As Integer
        Dim Pos As Integer
        TempHold = Len(InputData)
        TempDiv = (TempHold / 4)  '按四位分组
        Pos = InStr(1, CStr(TempDiv), ".")
        If Pos = 0 Then  '刚好够分组
            NumBlocks = TempDiv
            GoTo DoBlocks
        End If
        '不够分组的，判断应在前面加多少个0
        AfterDot = Mid(CStr(TempDiv), (Pos + 1))
        If AfterDot = 25 Then
            FullBin = "000" + FullBin
            NumBlocks = (Len(FullBin) / 4)
        ElseIf AfterDot = 5 Then
            FullBin = "00" + FullBin
            NumBlocks = (Len(FullBin) / 4)
        ElseIf AfterDot = 75 Then
            FullBin = "0" + FullBin
            NumBlocks = (Len(FullBin) / 4)
        Else
            Exit Function
        End If
            GoTo DoBlocks
    End If
DoBlocks:
    HexOut = ""
    For I = 1 To Len(FullBin) Step 4
        TempBinBlock = Mid(FullBin, I, 4)
        If TempBinBlock = "0000" Then
            HexOut = HexOut + "0"
        ElseIf TempBinBlock = "0001" Then
            HexOut = HexOut + "1"
        ElseIf TempBinBlock = "0010" Then
            HexOut = HexOut + "2"
        ElseIf TempBinBlock = "0011" Then
            HexOut = HexOut + "3"
        ElseIf TempBinBlock = "0100" Then
            HexOut = HexOut + "4"
        ElseIf TempBinBlock = "0101" Then
            HexOut = HexOut + "5"
        ElseIf TempBinBlock = "0110" Then
            HexOut = HexOut + "6"
        ElseIf TempBinBlock = "0111" Then
            HexOut = HexOut + "7"
        ElseIf TempBinBlock = "1000" Then
            HexOut = HexOut + "8"
        ElseIf TempBinBlock = "1001" Then
            HexOut = HexOut + "9"
        ElseIf TempBinBlock = "1010" Then
            HexOut = HexOut + "A"
        ElseIf TempBinBlock = "1011" Then
            HexOut = HexOut + "B"
        ElseIf TempBinBlock = "1100" Then
            HexOut = HexOut + "C"
        ElseIf TempBinBlock = "1101" Then
            HexOut = HexOut + "D"
        ElseIf TempBinBlock = "1110" Then
            HexOut = HexOut + "E"
        ElseIf TempBinBlock = "1111" Then
            HexOut = HexOut + "F"
        End If
    Next I
    Bin2Hex = HexOut
eds:
End Function
Function Hex2Bin(InputData As String) As String
'十六进制转二进制
    Dim I As Integer
    Dim BinOut As String
    Dim Lenhex As Integer
    InputData = UCase(InputData)
    Lenhex = Len(InputData)
    For I = 1 To Lenhex
        If IsNumeric(Mid(InputData, I, 1)) Then
            GoTo NumOk
        ElseIf Mid(InputData, I, 1) = "A" Then
            GoTo NumOk
        ElseIf Mid(InputData, I, 1) = "B" Then
            GoTo NumOk
        ElseIf Mid(InputData, I, 1) = "C" Then
            GoTo NumOk
        ElseIf Mid(InputData, I, 1) = "D" Then
            GoTo NumOk
        ElseIf Mid(InputData, I, 1) = "E" Then
            GoTo NumOk
        ElseIf Mid(InputData, I, 1) = "F" Then
            GoTo NumOk
        Else
            MsgBox "输入的不是16进制数！", vbCritical
            Exit Function
        End If
NumOk:
    Next I
    BinOut = ""
    For I = 1 To Lenhex
        If Mid(InputData, I, 1) = "0" Then
            BinOut = BinOut + "0000"
        ElseIf Mid(InputData, I, 1) = "1" Then
            BinOut = BinOut + "0001"
        ElseIf Mid(InputData, I, 1) = "2" Then
            BinOut = BinOut + "0010"
        ElseIf Mid(InputData, I, 1) = "3" Then
            BinOut = BinOut + "0011"
        ElseIf Mid(InputData, I, 1) = "4" Then
            BinOut = BinOut + "0100"
        ElseIf Mid(InputData, I, 1) = "5" Then
            BinOut = BinOut + "0101"
        ElseIf Mid(InputData, I, 1) = "6" Then
            BinOut = BinOut + "0110"
        ElseIf Mid(InputData, I, 1) = "7" Then
            BinOut = BinOut + "0111"
        ElseIf Mid(InputData, I, 1) = "8" Then
            BinOut = BinOut + "1000"
        ElseIf Mid(InputData, I, 1) = "9" Then
            BinOut = BinOut + "1001"
        ElseIf Mid(InputData, I, 1) = "A" Then
            BinOut = BinOut + "1010"
        ElseIf Mid(InputData, I, 1) = "B" Then
            BinOut = BinOut + "1011"
        ElseIf Mid(InputData, I, 1) = "C" Then
            BinOut = BinOut + "1100"
        ElseIf Mid(InputData, I, 1) = "D" Then
            BinOut = BinOut + "1101"
        ElseIf Mid(InputData, I, 1) = "E" Then
            BinOut = BinOut + "1110"
        ElseIf Mid(InputData, I, 1) = "F" Then
            BinOut = BinOut + "1111"
        Else
            MsgBox "这是个循环数, Wahhhhhhhhhhh", vbCritical
        End If
    Next I
    Hex2Bin = BinOut
eds:
End Function
Function Hex2Dec(InputData As String) As Double
    '十六进制转十进制
    Dim I As Integer
    Dim DecOut As Double
    Dim Lenhex As Integer
    Dim HexStep As Double
    DecOut = 0
    InputData = UCase(InputData)
    Lenhex = Len(InputData)
    For I = 1 To Lenhex
        If IsNumeric(Mid(InputData, I, 1)) Then
            GoTo NumOk
        ElseIf Mid(InputData, I, 1) = "A" Then
            GoTo NumOk
        ElseIf Mid(InputData, I, 1) = "B" Then
            GoTo NumOk
        ElseIf Mid(InputData, I, 1) = "C" Then
            GoTo NumOk
        ElseIf Mid(InputData, I, 1) = "D" Then
            GoTo NumOk
        ElseIf Mid(InputData, I, 1) = "E" Then
            GoTo NumOk
        ElseIf Mid(InputData, I, 1) = "F" Then
            GoTo NumOk
        Else
            MsgBox "不是16进制数！", vbCritical
            Exit Function
        End If
NumOk:
    Next I
    HexStep = 0
    For I = Lenhex To 1 Step -1
        HexStep = HexStep * 16
        If HexStep = 0 Then
            HexStep = 1
        End If
        If Mid(InputData, I, 1) = "0" Then
           DecOut = DecOut + (0 * HexStep)
        ElseIf Mid(InputData, I, 1) = "1" Then
           DecOut = DecOut + (1 * HexStep)
        ElseIf Mid(InputData, I, 1) = "2" Then
           DecOut = DecOut + (2 * HexStep)
        ElseIf Mid(InputData, I, 1) = "3" Then
           DecOut = DecOut + (3 * HexStep)
        ElseIf Mid(InputData, I, 1) = "4" Then
           DecOut = DecOut + (4 * HexStep)
        ElseIf Mid(InputData, I, 1) = "5" Then
           DecOut = DecOut + (5 * HexStep)
        ElseIf Mid(InputData, I, 1) = "6" Then
           DecOut = DecOut + (6 * HexStep)
        ElseIf Mid(InputData, I, 1) = "7" Then
           DecOut = DecOut + (7 * HexStep)
        ElseIf Mid(InputData, I, 1) = "8" Then
           DecOut = DecOut + (8 * HexStep)
        ElseIf Mid(InputData, I, 1) = "9" Then
           DecOut = DecOut + (9 * HexStep)
        ElseIf Mid(InputData, I, 1) = "A" Then
           DecOut = DecOut + (10 * HexStep)
        ElseIf Mid(InputData, I, 1) = "B" Then
           DecOut = DecOut + (11 * HexStep)
        ElseIf Mid(InputData, I, 1) = "C" Then
           DecOut = DecOut + (12 * HexStep)
        ElseIf Mid(InputData, I, 1) = "D" Then
           DecOut = DecOut + (13 * HexStep)
        ElseIf Mid(InputData, I, 1) = "E" Then
           DecOut = DecOut + (14 * HexStep)
        ElseIf Mid(InputData, I, 1) = "F" Then
           DecOut = DecOut + (15 * HexStep)
        Else
           MsgBox "这是个循环数, Wahhhhhhhhhhh", vbCritical
        End If
    Next I
    Hex2Dec = DecOut
eds:
End Function