VB,hex,bin,str,dec等数值和字符转换函数，UNICODE等转换函数

Option Explicit Public Declare Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" (Destination As Any, Source As Any, ByVal Length As Long) 'Private Declare Function BitAnd Lib "MyVCdll.dll" _ ' (ByVal nFirstNum As Long, _ ' ByVal nSecondNum As Long) As Long ' 'Private Declare Function BitLeftShift Lib "MyVCdll.dll" _ ' (ByVal nFirstNum As Long, _ ' ByVal nSecondNum As Integer) As Long ' 'Private Declare Function BitRightShift Lib "MyVCdll.dll" _ ' (ByVal nFirstNum As Long, _ ' ByVal nSecondNum As Integer) As Long ' 'Public Function vbBitAnd(ByVal nFirstNum As Long, ByVal nSecondNum As Long) As Long ' vbBitAnd = BitAnd(nFirstNum, nSecondNum) 'End Function ' 'Public Function vbBitLeftShift(ByVal nFirstNum As Long, ByVal nSecondNum As Integer) As Long ' vbBitLeftShift = BitLeftShift(nFirstNum, nSecondNum) 'End Function ' 'Public Function vbBitRightShift(ByVal nFirstNum As Long, ByVal nSecondNum As Integer) As Long ' vbBitRightShift = BitRightShift(nFirstNum, nSecondNum) 'End Function ''7-bit解码 ''strInput: 源编码串 ''返回: 目标字符串 'Public Function Decode7BitASC(ByVal strInput As String) As String ' ' Dim iTmp As Integer ' Dim iSrc() As Integer ' Dim iDst() As Integer ' ' Dim idxSrc As Long '源字符串的计数值 ' Dim idxDst As Long '目标解码串的计数值 ' Dim idxByte As Long '当前正在处理的组内字节的序号，范围是0-6 ' Dim iLeft As Long '上一字节残余的数据 ' Dim nD As Long ' ' Dim blReturn As Boolean ' Dim strMyString() As String ' Dim strOutput As String ' ' On Error Resume Next ' ' blReturn = String2Array(strInput, " ", nD, strMyString(), True) ' ' ReDim iSrc(0 To nD) ' ReDim iDst(0 To nD * 2) ' ' For idxSrc = 0 To nD - 1 ' iSrc(idxSrc) = Hex2Dec(strMyString(idxSrc)) ' Next idxSrc ' ' '计数值初始化 ' idxSrc = 0 ' idxDst = 0 ' ' '组内字节序号和残余数据初始化 ' idxByte = 0 ' iLeft = 0 ' ' '将源数据每7个字节分为一组，解压缩成8个字节 ' '循环该处理过程，直至源数据被处理完 ' '如果分组不到7字节，也能正确处理 ' While idxSrc < nD ' ' '将源字节右边部分与残余数据相加，去掉最高位，得到一个目标解码字节 ' iTmp = BitLeftShift(iSrc(idxSrc), idxByte) ' iTmp = iTmp Or iLeft ' iDst(idxDst) = iTmp And &H7F ' ' '将该字节剩下的左边部分，作为残余数据保存起来 ' iLeft = BitRightShift(iSrc(idxSrc), (7 - idxByte)) ' ' '修改目标串的指针和计数值 ' idxDst = idxDst + 1 ' ' '修改字节计数值 ' idxByte = idxByte + 1 ' ' '到了一组的最后一个字节 ' If idxByte = 7 Then ' ' '额外得到一个目标解码字节 ' iDst(idxDst) = iLeft ' ' '修改目标串的指针和计数值 ' idxDst = idxDst + 1 ' ' '组内字节序号和残余数据初始化 ' idxByte = 0 ' iLeft = 0 ' End If ' ' '修改源串的指针和计数值 ' idxSrc = idxSrc + 1 ' ' Wend ' ' For idxSrc = 0 To idxDst - 1 ' strOutput = strOutput & Chr(iDst(idxSrc)) ' Next idxSrc ' ' Decode7BitASC = strOutput ' 'End Function ' ''7-bit编码 ''strInput: 源字符串 ''iArrayRtn: 目标编码数组 'Public Function Encode7BitASC(ByVal strInput As String) As String ' ' Dim idxSrc As Long '源字符串的计数值 ' Dim idxDst As Long '目标编码串的计数值 ' Dim idxChar As Long '当前正在处理的组内字符字节的序号，范围是0-7 ' Dim iLeft As Long '上一字节残余的数据 ' Dim nSrcLength As Long '源字符串长度 ' ' Dim iTmp As Integer ' Dim iSrc() As Integer ' Dim i As Integer ' Dim iArrayRtn() As Integer ' ' On Error Resume Next ' idxSrc = 0 ' idxDst = 0 ' nSrcLength = Len(strInput) ' ' ReDim iSrc(0 To nSrcLength) ' ReDim iArrayRtn(0 To nSrcLength) ' ' For i = 1 To nSrcLength ' iSrc(i - 1) = AscB(Mid(strInput, i, 1)) ' Next i ' ' '将源串每8个字节分为一组，压缩成7个字节 ' '循环该处理过程，直至源串被处理完 ' '如果分组不到8字节，也能正确处理 ' For idxSrc = 0 To nSrcLength ' ' '取源字符串的计数值的最低3位 ' idxChar = idxSrc And 7 ' ' '处理源串的每个字节 ' If idxChar = 0 Then ' ' '组内第一个字节，只是保存起来，待处理下一个字节时使用 ' iLeft = iSrc(idxSrc) ' Else ' ' '组内其它字节，将其右边部分与残余数据相加，得到一个目标编码字节 ' iTmp = BitLeftShift(iSrc(idxSrc), (8 - idxChar)) ' DoEvents ' iTmp = BitAnd(iTmp, &HFF) ' iTmp = iTmp Or iLeft ' ' If iTmp <> 0 Then ' iArrayRtn(idxDst) = iTmp ' ' '修改目标串的指针和计数值 idxDst++; ' idxDst = idxDst + 1 ' End If ' ' '将该字节剩下的左边部分，作为残余数据保存起来 ' iLeft = BitRightShift(iSrc(idxSrc), idxChar) ' End If ' ' Next idxSrc ' ' Dim nTmp As Long ' Dim strTmp As String ' ' Encode7BitASC = "" ' For nTmp = 0 To idxDst ' strTmp = Hex(iArrayRtn(nTmp)) ' If Len(strTmp) < 2 Then strTmp = "0" & strTmp '' strTmp = strTmp & strTmp ' Next nTmp ' ' Encode7BitASC = Trim(strTmp) ' 'End Function ''//将UNICODE转换中文 'Print Unicode2Ascii("6211") '我 Public Function Unicode2Ascii(ByVal s As String) As String On Error Resume Next Dim i As Integer Dim R As String For i = 1 To Len(s) Step 4 R = R + ChrB("&H" & Mid(s, i + 2, 2)) & ChrB("&H" & Mid(s, i, 2)) Next Unicode2Ascii = R End Function 'Print Ascii2Char("61324233") 'a2B3 Public Function Ascii2Char(ByVal strAsc As String) As String Dim i As Integer Dim j As Integer Dim strTmp As String Dim strTmpA As String Dim strTmpB As String On Error Resume Next j = Len(strAsc) strTmpB = "" For i = 1 To j strTmpA = Mid(strAsc, i, 1) If strTmpA <> " " Then strTmpB = strTmpB & strTmpA Next i j = Len(strTmpB) strTmp = "" For i = 1 To j Step 2 strTmpA = Mid(strTmpB, i, 2) ' Debug.Print strTmpA 'strTmp = strTmp & ChrB(Hex2Dec(strTmpA)) strTmp = strTmp & Chr(Hex2Dec(strTmpA)) Next i Ascii2Char = strTmp End Function 'Print Char2Ascii("a2B3") '61324233 Public Function Char2Ascii(ByVal strChar As String) As String Dim iAsc As Integer Dim n1 As Long Dim n2 As Long Dim strTmp As String Dim strTmp1 As String Dim strTmp2 As String On Error Resume Next n1 = LenB(strChar) strTmp = "" For n2 = 1 To n1 iAsc = AscB(MidB(strChar, n2, 1)) If iAsc <> 0 Then strTmp1 = Hex(iAsc) If Len(strTmp1) < 2 Then strTmp1 = "0" & strTmp1 strTmp = strTmp & strTmp1 ' & " " End If Next n2 Char2Ascii = Trim(strTmp) End Function 'Print Hex2Dec("AF23") '44835 Public Function Hex2Dec(ByVal strInput As String) As Long Dim i As Integer Dim j As Integer Dim iLen As Integer Dim iTmp As Integer Dim nRet As Long Dim strTmp As String On Error Resume Next If strInput <> "" Then iLen = Len(strInput) nRet = 0 For i = 1 To iLen iTmp = Asc(Mid(strInput, i, 1)) If iTmp >= 48 And iTmp <= 57 Then '"0" = 48, "9" = 57 nRet = nRet + (iTmp - 48) * 16 ^ (iLen - i) ElseIf iTmp >= 65 And iTmp <= 70 Then '"A" = 65, "F" = 70 nRet = nRet + (iTmp - 55) * 16 ^ (iLen - i) ElseIf iTmp >= 97 And iTmp <= 102 Then '"a" = 97, "f" = 102 nRet = nRet + (iTmp - 87) * 16 ^ (iLen - i) Else nRet = 0 Exit For End If Next i End If Hex2Dec = nRet End Function 'Print GB2Unicode("我") '6211 '62114EEC Public Function GB2Unicode(ByVal strGB As String) As String Dim byteA() As Byte Dim i As Integer Dim strTmpUnicode As String Dim strA As String Dim strB As String On Error GoTo ErrorUnicode i = LenB(strGB) ReDim byteA(1 To i) For i = 1 To LenB(strGB) strA = MidB(strGB, i, 1) byteA(i) = AscB(strA) Next i '此时已经将strGB转换为Unicode编码，保存在数组byteA()中。 '下面需要调整顺序并以字符串的形式返回 strTmpUnicode = "" For i = 1 To UBound(byteA) Step 2 strA = Hex(byteA(i)) If Len(strA) < 2 Then strA = "0" & strA strB = Hex(byteA(i + 1)) If Len(strB) < 2 Then strB = "0" & strB strTmpUnicode = strTmpUnicode & strB & strA Next i GB2Unicode = strTmpUnicode Exit Function ErrorUnicode: MsgBox "错误：" & Err & "." & vbCrLf & Err.Description GB2Unicode = "" End Function 'Print Unicode2GB("6211") '我 '我们 Public Function Unicode2GB(ByVal strUnicode As String) As String Dim byteA() As Byte Dim i As Integer Dim strTmp As String Dim strTmpGB As String On Error GoTo ErrUnicode2GB i = Len(strUnicode) / 2 ReDim byteA(1 To i) For i = 1 To Len(strUnicode) / 2 Step 2 strTmp = Mid(strUnicode, i * 2 - 1, 2) strTmp = Hex2Dec(strTmp) byteA(i + 1) = strTmp strTmp = Mid(strUnicode, i * 2 + 1, 2) strTmp = Hex2Dec(strTmp) byteA(i) = strTmp Next i strTmpGB = "" For i = 1 To UBound(byteA) strTmp = byteA(i) strTmpGB = strTmpGB & ChrB(strTmp) Next i Unicode2GB = strTmpGB Exit Function ErrUnicode2GB: MsgBox "Err=" & Err.Number & ",原因：" & Err.Description Unicode2GB = "" End Function '此函数是将一个字符串中以charRef为分隔符的元素保存到数组MyStr()中 '********************************************* '参数： '============================================ '|YourStr： | 待分隔的字符串 '+-----------+------------------------------- '|charRef： | 分隔符号 '+-----------+------------------------------- '|isNormal： | 如果为假，则表示分隔符可能由 '| | 多个空格组成，例如Tab符号。 '+-----------+------------------------------- '|nD： | 返回值，表示有多少个元素 '+-----------+------------------------------- '|MyStr()： | 返回值，保存分隔后的各个元素。 '============================================ ' '********************************************** Public Function String2Array(ByVal YourStr As String, _ ByVal charRef As String, _ ByRef nD As Long, _ ByRef MyStr() As String, _ ByVal isNormal As Boolean) As Boolean Dim i As Long Dim j As Long Dim nUBound As Long Dim iAsc As Integer Dim strChar As String Dim strTmp As String Dim aryTr() As String On Error GoTo ErrorDecode strChar = "" YourStr = Trim(YourStr) '首先去掉字符串两边的空格 nUBound = 1 j = 0 ReDim aryTr(1 To nUBound) If Not isNormal Then For i = 1 To Len(YourStr) strTmp = Mid(YourStr, i, 1) iAsc = Asc(strTmp) If iAsc > 122 Or iAsc < 33 Then strChar = Mid(YourStr, i - j, j) If strChar <> "" Then aryTr(nUBound) = strChar nUBound = nUBound + 1 ReDim Preserve aryTr(1 To nUBound) End If strChar = "" j = 0 Else j = j + 1 If i = Len(YourStr) Then strChar = Mid(YourStr, i - j + 1, j) aryTr(nUBound) = strChar End If End If Next i nD = nUBound ReDim MyStr(0 To nUBound - 1) For i = 1 To nUBound MyStr(i - 1) = aryTr(i) Next i String2Array = True Else For i = 1 To Len(YourStr) strTmp = Mid(YourStr, i, 1) If strTmp = charRef Then strChar = Mid(YourStr, i - j, j) If strChar <> "" Then aryTr(nUBound) = strChar nUBound = nUBound + 1 ReDim Preserve aryTr(1 To nUBound) End If strChar = "" j = 0 Else j = j + 1 If i = Len(YourStr) Then strChar = Mid(YourStr, i - j + 1, j) aryTr(nUBound) = strChar End If End If Next i nD = nUBound ReDim MyStr(0 To nUBound - 1) For i = 1 To nUBound MyStr(i - 1) = aryTr(i) Next i String2Array = True End If Exit Function ErrorDecode: MsgBox Err.Number & ":" & Err.Description String2Array = False End Function Public Sub QuickSort(InputArray() As Double, LowPos As Integer, HighPos As Integer) Dim iPivot As Integer If LowPos < HighPos Then iPivot = PartitionA(InputArray, LowPos, HighPos) Call QuickSort(InputArray, LowPos, iPivot - 1) Call QuickSort(InputArray, iPivot + 1, HighPos) End If End Sub Private Sub Swap(InputArray() As Double, FirstPos As Integer, SecondPos As Integer) Dim dblTmp As Double dblTmp = InputArray(FirstPos) InputArray(FirstPos) = InputArray(SecondPos) InputArray(FirstPos) = dblTmp End Sub Private Function PartitionA(R() As Double, ByVal iB As Integer, ByVal iE As Integer) As Integer '//并返回基准记录的位置 Dim dblPivot As Double '===== 用区间的第1个记录作为基准 ===== dblPivot = R(iB) '===== { 从区间两端交替向中间扫描，直至iB=iE为止 ===== Do While (iB < iE) '----- pivot相当于在位置iB上 ----- Do While (iB < iE And R(iE) >= dblPivot) '--- 从右向左扫描，查找第1个小于Pivot的记录R(iE) --- iE = iE - 1 Loop '----- 表示找到的R(iE) < dblPivot ----- If (iB < iE) Then '--- 相当于交换R(ib)和R(ie)，交换后iB指针加1 --- R(iB) = R(iE) iB = iB + 1 End If '----- Pivot相当于在位置iE上 ----- Do While (iB < iE And R(iB) <= dblPivot) '--- 从左向右扫描，查找第1个大于Pivot的记录R(iB) --- iB = iB + 1 Loop '----- 表示找到了R(iB)，使R(iB) > Pivot ----- If (iB < iE) Then '--- 相当于交换R(iB)和R(iE)，交换后iE指针减1 --- R(iE) = R(iB) iE = iE - 1 End If Loop '===== 基准记录已被最后定位 ===== R(iB) = dblPivot PartitionA = iB End Function Private Function Partition(InputArray() As Double, LowPos As Integer, HighPos As Integer) As Integer Dim dblPivot As Double Dim iPos As Integer, iTmp As Integer Dim i As Integer, j As Integer iPos = LowPos dblPivot = InputArray(iPos) For i = LowPos + 1 To HighPos If InputArray(i) < dblPivot Then Call Swap(InputArray, iPos, i) iPos = iPos + 1 End If Next i Call Swap(InputArray, LowPos, iPos) Partition = iPos End Function 'Print Str2HexStr("asf") '617366 'Print Str2HexStr("我") 'CED2 Public Function Str2HexStr(ByVal arg0 As String) As String Dim i As Integer Dim strURLHexAscii As String strURLHexAscii = "" If Len(arg0) = 0 Then Str2HexStr = "" Exit Function End If For i = 1 To Len(arg0) Step 1 strURLHexAscii = strURLHexAscii & Int2HexStr(Asc(Mid(arg0, i, 1))) Next i Str2HexStr = strURLHexAscii End Function 'Print HexStr2Str("CED2") 'asf '不支持汉字 Public Function HexStr2Str(ByVal arg0 As String) As String Dim Temp As String HexStr2Str = "" Dim b As Byte Dim i As Integer i = 1 Dim j As Integer j = 0 While i < Len(arg0) Temp = Mid(arg0, i, 2) j = Hex2Dec_2byte(Temp) ' j = HexStr2Int(Temp) HexStr2Str = HexStr2Str & Chr(j) i = i + 2 j = 0 Temp = "" Wend End Function 'Print HexStr2Str("CED2") 'asf '支持汉字 Public Function HexStr2StrW(ByVal arg0 As String) As String Dim Temp As String HexStr2StrW = "" Dim b As Byte Dim i As Integer i = 1 Dim j As Long j = 0 While i < Len(arg0) Temp = Mid(arg0, i, 4) j = Hex2Dec_2byte(Temp) ' j = HexStr2Int(Temp) HexStr2StrW = HexStr2StrW & Chr(j) i = i + 4 j = 0 Temp = "" Wend End Function '/ '任意长度的十六进制字符转二进制字符 '/ Public Function Hex2Bin_long(in_Hex As String) As String Dim i As Integer in_Hex = LTrim(RTrim(in_Hex)) i = 1 For i = 1 To Len(in_Hex) Hex2Bin_long = Hex2Bin_long + Hex2Bin(Mid(in_Hex, i, 1)) Next End Function '/// '输入一位十六进制数，输出4位二进制。错误返回空字符串。 '/// Public Function Hex2Bin(in_Hex As String) As String Dim tempArray(4) As Integer Dim tempX As Integer Dim i As Integer Select Case UCase(in_Hex) Case "A" tempX = 10 Case "B" tempX = 11 Case "C" tempX = 12 Case "D" tempX = 13 Case "E" tempX = 14 Case "F" tempX = 15 Case Else If IsNumeric(in_Hex) Then tempX = Val(in_Hex) Else HtoB = "" '此处填加错误提示 'MsgBox "HtoB函数错误！in_Hex=" & in_Hex Exit Function End If End Select i = 1 For i = 1 To 4 tempArray(i) = Int(tempX / (2 ^ (4 - i))) tempX = tempX Mod 2 ^ (4 - i) Next Hex2Bin = LTrim(str(tempArray(1))) + LTrim(str(tempArray(2))) + LTrim(str(tempArray(3))) + LTrim(str(tempArray(4))) End Function '16进制转二进制函数 Public Function Hex2BinA(ByVal hex_str As String, MinimumDigits As Integer) As String Dim i As Long Dim b As String Dim ExtraDigitsNeeded As Integer hex_str = UCase(hex_str) For i = 1 To Len(hex_str) Select Case Mid(hex_str, 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 ExtraDigitsNeeded = MinimumDigits - Len(b) If ExtraDigitsNeeded > 0 Then b = String(ExtraDigitsNeeded, "0") & b End If Hex2BinA = b End Function '/// '二进制字符串转化为十进制字符串 '/// Public Function Bin2Dec(str_input As String) As String Dim tempBtoD As Long Dim i As Integer i = 1 For i = 1 To Len(str_input) tempBtoD = Val(Mid(str_input, i, 1)) * 2 ^ (Len(str_input) - i) + tempBtoD Next BtoD = Format(tempBtoD, "0") End Function ' '两字符十六进制数转化为十进制数 ' Public Function Hex2Dec_2byte(ByVal in_Hex As String) As Double If Len(in_Hex) = 4 Then Hex2Dec_2byte = Val(Hex2Dec_1byte(Mid(in_Hex, 1, 2))) * 256 + Val(Hex2Dec_1byte(Mid(in_Hex, 3, 2))) If Len(in_Hex) = 2 Then Hex2Dec_2byte = Val(Hex2Dec_1byte(Mid(in_Hex, 1, 2))) End Function '/ '单字符型十六进制数转化为十进制数 '/ Public Function Hex2Dec_1byte(in_Hex As String) As String Dim dec_temp As Integer Dim n As Integer Dim Temp As Integer Dim Temp1 As String n = 1 Do While n <= 2 Temp1 = Mid(in_Hex, n, 1) Select Case Temp1 Case "A" Temp = 10 Case "B" Temp = 11 Case "C" Temp = 12 Case "D" Temp = 13 Case "E" Temp = 14 Case "F" Temp = 15 Case Else Temp = Val(Temp1) End Select If n = 1 Then dec_temp = Temp * 16 Else dec_temp = dec_temp + Temp End If n = n + 1 Loop Hex2Dec_1byte = LTrim(str(dec_temp)) End Function '/ '检验输入字符串是否是十六进制字符串，返回逻辑值。 '/ Public Function IsHexStr(ByVal vInputStr As String) As Boolean Dim i As Integer Dim str As String IsHexStr = True If vInputStr = "" Then IsHexStr = False Exit Function End If For i = 1 To Len(vInputStr) str = UCase(Mid(vInputStr, i, 1)) If Not (IsNumeric(str) Or str = "A" Or str = "B" Or str = "C" Or str = "D" Or str = "E" Or str = "F") Then IsHexStr = False Exit For End If Next End Function Public Function GB2UTF8(ByVal Str_GB As String, Optional ByVal Sytle As String = "string") As String Dim Source() As Byte Dim UTF_16 As Long Dim Str_Bin As String Dim My_utf_Bin As String Dim Str_chr As String Dim UTF_VAL As Long Dim Str_hex As String Dim Str_utf_hex As String Dim i, j As Integer Dim nLength As Integer For j = 1 To Len(Str_GB) CopyMemory UTF_VAL, ByVal StrPtr(Mid(Str_GB, j, 1)), 2 '得到unicode码 Str_hex = Hex(UTF_VAL) '转为16进制字符串 Str_Bin = Hex2BinA(Str_hex, 16) '转为2进制字符串 If UTF_VAL < &H80 Then ' 1 UTF-8 byte My_utf_Bin = Mid(Str_Bin, 9, 8) ElseIf UTF_VAL < &H800 Then ' 2 UTF-8 bytes My_utf_Bin = "110" + Mid(Str_Bin, 5, 5) + "10" + Mid(Str_Bin, 11, 6) Else ' 3 UTF-8 bytes My_utf_Bin = "1110" + Mid(Str_Bin, 1, 4) + "10" + Mid(Str_Bin, 5, 6) + "10" + Mid(Str_Bin, 11, 6) End If Str_utf_hex = Str_utf_hex + Bin2Hex(My_utf_Bin) '转为utf8的16进制字符串 Next j '''''''''''''''''''''以下是转换成为utf8编码 nLength = Len(Str_utf_hex) / 2 ReDim Source(Len(Str_utf_hex) / 2) For i = 1 To Len(Str_utf_hex) Step 2 CopyMemory Source((i + 1) / 2), ByVal StrPtr(ChrB("&h" + Mid(Str_utf_hex, i, 2))), 1 Str_chr = Str_chr & ChrB(Source((i + 1) / 2)) Next i If Sytle = "hex" Or Sytle = "Hex" Or Sytle = "HEX" Then '判断是不是要输出机器码 GB2UTF8 = Str_utf_hex Else GB2UTF8 = Str_chr End If End Function '二进制转16进制函数 Public Function Bin2Hex(ByVal Bininary_in As String) As String Dim i As Long Dim H As String If Len(Bininary_in) Mod 4 <> 0 Then Bininary_in = String(4 - Len(Bininary_in) Mod 4, "0") & Bininary_in End If For i = 1 To Len(Bininary_in) Step 4 Select Case Mid(Bininary_in, 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 Bin2Hex = H End Function Public Function HexStr2Int(ByVal arg0 As String) As Integer HexStr2Int = Hex2Dec_2byte(arg0) End Function '把整数转换成HEX STR Public Function Int2HexStr(ByVal arg0 As Integer) As String Dim strChar As String strChar = "" strChar = Hex(arg0) If Len(strChar) Mod 2 = 1 Then strChar = "0" & strChar Int2HexStr = strChar End Function