module1

PUD码转换

Attribute VB_Name = "Module1"
Public Function s_hex(hex_value As Variant) As Variant
Dim L_VAL, H_VAL As String
If Len(hex_value) = 1 Then
   hex_value = "0" & hex_value
End If
Select Case Left(hex_value, 1)
       Case "A"
            L_VAL = "10"
       Case "B"
            L_VAL = "11"
       Case "C"
            L_VAL = "12"
       Case "D"
            L_VAL = "13"
       Case "E"
            L_VAL = "14"
       Case "F"
            L_VAL = "15"
       Case Else
            L_VAL = Left(hex_value, 1)
End Select
Select Case Right(hex_value, 1)
       Case "A"
            H_VAL = "10"
       Case "B"
            H_VAL = "11"
       Case "C"
            H_VAL = "12"
       Case "D"
            H_VAL = "13"
       Case "E"
            H_VAL = "14"
       Case "F"
            H_VAL = "15"
       Case Else
            H_VAL = Right(hex_value, 1)
End Select
s_hex = Val(L_VAL) * 16 + Val(H_VAL)
End Function

Public Function Dec2Bin(zs As String) As Variant
Dim zt, yu, yu1, yu2, yu3, yu4, yu5, yu6, yu7, yu8 As Integer
yu1 = zs Mod 2    '余数1
zt = zs \ 2       '整数
yu2 = zt Mod 2    '余数2
zt = zt \ 2       '整数
yu3 = zt Mod 2    '余数3
zt = zt \ 2       '整数
yu4 = zt Mod 2    '余数4
zt = zt \ 2       '整数
yu5 = zt Mod 2    '余数5
zt = zt \ 2       '整数
yu6 = zt Mod 2    '余数6
zt = zt \ 2       '整数
yu7 = zt Mod 2    '余数7
zt = zt \ 2       '整数
yu8 = zt Mod 2    '余数8
yu = yu8 & yu7 & yu6 & yu5 & yu4 & yu3 & yu2 & yu1

Dec2Bin = yu

End Function

Function Bin2Hex(InputData As String) As String
''
''  Converts Binary to hex
''
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)

''
''  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

''  Set the Variable to the Binary
''
FullBin = InputData

''
''  If the value is less than 4 in length, build it up.
''
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 "Nothing Given..", 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)
''
''  Works by seeing whats after the deciomal place
''
Pos = InStr(1, CStr(TempDiv), ".")

If Pos = 0 Then
 '' Divided by 4 perfectly
 NumBlocks = TempDiv
 GoTo DoBlocks
End If

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
  MsgBox "Big Time Screw up happened, WAHHHHHHHHHHH", vbInformation
  Exit Function
End If

  GoTo DoBlocks
End If

''
''  The rest will process the now built up number
''
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