进制转换问题

Question

Private Declare Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" (Destination As Any, Source As Any, ByVal Length As Long)Private Type Int64
    Lo As Long
    Hi As Long
End TypePrivate Function MyHex(ByVal Value As Double) As String
    Dim c As Currency
    Dim i64 As Int64
    
    c = Value / 10000
    
    CopyMemory i64, c, 8
    
    If i64.Hi Then
        MyHex = Hex(i64.Hi) & Right("0000000" & Hex(i64.Lo), 8)
    Else
        MyHex = Hex(i64.Lo)
    End If
    
End FunctionPrivate Sub Command1_Click()
    MsgBox MyHex(187647123874968#)
    
End Sub

Answer 1

TO 楼主:
如果有时间，研究一下这个帖子http://expert.csdn.net/Expert/topic/901/901179.xml?temp=.3970453

Answer 2

我原来写的一个16进制的加法，你可以改造一下：你可以把大数化成N个2147483648（7FFFFFFF）相加即可，速度问题自己考虑，应该不是很慢。
Public Function HexAdd(sHexA As String, sHexB As String) As String
    Dim i As Integer
    Dim tmpA As String
    Dim tmpB As String
    Dim bAdd As Boolean
    
    Dim strA() As String
    Dim strB() As String
    Dim strResult() As String
    
    Dim strLen      As Integer
    
    On Error GoTo Err_Exit
    
    tmpA$ = sHexA$
    tmpB$ = sHexB$
    bAdd = False
    
    i = InStr(UCase$(sHexA$), "&H")
    If i <> 0 Then
        tmpA$ = Right$(Trim$(sHexA$), Len(sHexA$) - 2)
    End If
    i = InStr(UCase$(sHexB$), "&H")
    If i <> 0 Then
        tmpB$ = Right$(Trim$(sHexB$), Len(sHexB$) - 2)
    End If
    
    If Len(tmpA$) > Len(tmpB$) Then
        strLen = Len(tmpA$)
        tmpB$ = String(Len(tmpA$) - Len(tmpB$), "0") + tmpB$
    Else
        strLen = Len(tmpB$)
        tmpA$ = String(Len(tmpB$) - Len(tmpA$), "0") + tmpA$
    End If
    
    ReDim strA$(1 To strLen)
    ReDim strB$(1 To strLen)
    
    For i = 1 To strLen
        strA$(i) = Mid(tmpA$, i, 1)
        strB$(i) = Mid(tmpB$, i, 1)
    Next
    
    Dim tmp$
    
    ReDim strResult$(0 To strLen)
    For i = strLen To 1 Step -1
        If bAdd Then
            tmp$ = Hex(CDec("&H" + strA$(i)) + CDec("&H" + strB$(i)) + 1)
        Else
            tmp$ = Hex(CDec("&H" + strA$(i)) + CDec("&H" + strB$(i)))
        End If
        If Len(tmp$) > 1 Then
            bAdd = True
        Else
            bAdd = False
        End If
        strResult$(i) = Right$(tmp$, 1)
    Next
    
    If Len(tmp$) > 1 Then
        strResult(i) = "1"
    End If
    
    tmp$ = ""
    For i = 0 To strLen
        tmp$ = tmp$ + strResult(i)
    Next
    
    'HexAdd = "&H" + tmp$
    HexAdd = tmp$
    Exit Function
Err_Exit:
    HexAdd = ""
End Function

Answer 3

TO  Cooly(Lazy) :
谢谢你的代码，没怎么看懂，：P，你的代码最多也只能支持20多位的吧，要是再长的数，我应该修改什么地方？TO wu_yongcai(浪人) ：
谢谢，不过对于一个比较的的数，就算改成加法，速度上还是很慢的啊

Answer 4

TO wu_yongcai(浪人) ：
谢谢，不过对于一个比较大的数（不好意思，刚才的写错了），就算改成加法，速度上还是很慢的啊

Answer 5

TO   Tenner(Tenner) 
 Cooly(Lazy) 给的算法已经很快了啊，就是不支持更大的数了。

Answer 6

其实这是一个没有必要做的事情，当然Cooly(Lazy)给出的代码是不错的，直接用内存存储的数据进行转换的思路真挺好，但是是否可以用迭代的方法？除16求余的方法？

Answer 7

'刚写的代码，理论上可以转换非常大的数字，大家试试：
Private Sub Form_Click()
Dim start As Long
Const hugenum = "1234567890123456789012345678901234567890123456789012345678901234567890123456789012345678901234567890"
start = Timer
MsgBox dectohex(hugenum), , "it take me about " & Format((Timer - start), "0.0000") & " seconds to trans the hugenum to hex"
End SubFunction half(ByVal x As String) As String 'get half of x
x = 0 & x
Dim i As Long
ReDim result(2 To Len(x)) As String
For i = 2 To Len(x)
result(i) = CStr(Val(Mid(x, i, 1)) \ 2 + IIf(Val(Mid(x, i - 1, 1)) Mod 2 = 1, 5, 0))
Next
half = Join(result, "")
If Left(half, 1) = "0" Then half = Right(half, Len(half) - 1) ' no zero ahead
End Function
Function dectohex(ByVal hugenum As String) As String ' trans hugenum to hex
Do While Len(hugenum) > 2
dectohex = Hex(Val(Right(hugenum, 4)) Mod 16) & dectohex
For i = 1 To 4 'devide hugenum  by 16
hugenum = half(hugenum)
Next
Loop
dectohex = Hex(Val(hugenum)) & dectohex
End Function
'八进制，二进制同理
Function dectooct(ByVal hugenum As String) As String ' trans hugenum to oct
Do While Len(hugenum) > 1
dectooct = Oct(Val(Right(hugenum, 3)) Mod 8) & dectooct
For i = 1 To 3 'devide hugenum  by 8
hugenum = half(hugenum)
Next
Loop
dectooct = Oct(Val(hugenum)) & dectooct
End FunctionFunction dectobin(ByVal hugenum As String) As String ' trans hugenum to bin
Do While Not hugenum = "1"
dectobin = Val(Right(hugenum, 1)) Mod 2 & dectobinhugenum = half(hugenum) 'devide hugenum  by 16dectobin = "1" & dectobin
End Function

Answer 8

'少了个loop
Function dectobin(ByVal hugenum As String) As String ' trans hugenum to bin
Do While Not hugenum = "1"
dectobin = Val(Right(hugenum, 1)) Mod 2 & dectobinhugenum = half(hugenum) 'devide hugenum  by 16loopdectobin = "1" & dectobin
End Function

Answer 9

不对啊，你的算法依然超不出Double型的长度。15位左右

Answer 10

TO all现在看来，从内存里读，是最好的算法了，现在我只是想抛砖引玉，把这个问题作为一个纯技术的研究来讨论一下。还有，我的看法，只要用到除法，都是没法支持比较大的数的，即使理论上是正确的，实际做起来还是慢的很。

Answer 11

不会吧，dectobin(string(1000,"9")) 运行18"可以算出啊。

Answer 12

对字符串进行运算应该有很宽的范围。x = "1234567890"
For i = 1 To 100
num = num & x
Nextdectohex(num)=7845F900EECA8BAAE1426FC89F8541D52924B6E2A775A35A25B3E60A635A7B53EFA03EDE4F7D2B478568D5562E306B8120EE6C90AF3A740CC5360FB23B4DF84C14CFC5FA2B3927ACBD5FED6436D5E01BA11A139C78FF4781CAEB2928FCCA4480858D1EBC547F56C935CD7A3E072CB0CF7F8B7475ED0CA82D5B5B45B5C0362303B7133FDB63F19BE1C34871F91BCB8AB5845AEC95DEDBF7B709AB1F830F25EC864A73085C245D6C45EDBC6E0E13CA7838696A5AF93C7E71716D6925E667D8FE112E0034498BC0ACD8ABFA818EB0C9C6422B5D0BF0D55F5B73615FD5B39CDC4425A3EE42379B6927D2E2D9D62763D91F38A6B48C5EBD459149BDFB04AE111C014582216E7CBFC354D9D4D3D7A14DCBBC97B1BAD5BEA6BFCB80AC6FB40D87C1E20466E21A45A4F767654ED486E577C3DED8ACA9DE65B9A6C88A8D5AC3C1D9344F7D5B11EF14AA33A2E91886016C1B52B4A1CC3D596211CA69989822599C69EC74058396B78F33F3F307F17731C348EA26FC29D18352DDC3F190BD986F50D5E5E7EB001B51E3B725A501C2A01788A9935E243D1161EF7BF14BACCFF196CE3F0AD2100个1234567890首尾相连，转换为16进制为830位，PII266，64M内存用时16秒

Answer 13

给出一个本人自己写的，数制转换模块
以前写的，可以实现二、八、十六进制的无限位转换，但十进制限最大为Currency型，在此仅供参考，转换包括小数部分的转换Option ExplicitPrivate Const c_strPoint As String = "."
Private Const c_intBaseNMax As Integer = 16                 '最大进制Public Function Dec2BaseN(DecNum As Currency, BaseN As Integer, NAfter As Integer) As String'十进制数转任意进制    Dim m_curInteger As Currency        '整数部分
    Dim m_dblFloat As Double            '小数部分
    Dim m_strInteger As String          '结果整数部分
    Dim m_strFloat As String            '结果小数部分
    Dim m_intCounter As Integer         '计数器
    
    If BaseN > c_intBaseNMax Or BaseN < 2 Then Exit Function            '进制不正确
    
    m_curInteger = Fix(DecNum)
    m_dblFloat = CSng(DecNum - m_curInteger)
    
    Do While (m_curInteger > 0)
        m_strInteger = GetNumChar((m_curInteger / BaseN - Fix(m_curInteger / BaseN)) * BaseN) & m_strInteger
        m_curInteger = Fix(m_curInteger / BaseN)
    Loop
    
    Do While (m_intCounter < NAfter)
        m_strFloat = m_strFloat & GetNumChar(Fix(m_dblFloat * BaseN))
        m_dblFloat = m_dblFloat * BaseN - Fix(m_dblFloat * BaseN)
        m_intCounter = m_intCounter + 1
    Loop
    
    Dec2BaseN = m_strInteger & IIf(m_strFloat = vbNullString, vbNullString, c_strPoint) & m_strFloatEnd Function
Public Function Bin2Dec(BinNum As String) As Double'二进制数转十进制数    Dim m_lngCounter As Long            '计数器
    Dim m_strInteger As String          '整数部分
    Dim m_strFloat As String            '小数部分
    Dim m_curInteger As Currency        '整数数字
    Dim m_sngFloat As Single            '小数数字
    
    If IsLegal(BinNum, 2) = False Then Exit Function        '不合法数据
    
    Call SeparatePoint(BinNum, m_strInteger, m_strFloat)
    
    For m_lngCounter = 1 To Len(m_strInteger)
        m_curInteger = m_curInteger + CLng(Mid(m_strInteger, m_lngCounter, 1)) * (2 ^ (Len(m_strInteger) - m_lngCounter))
    Next m_lngCounter
    
    For m_lngCounter = 1 To Len(m_strFloat)
        m_sngFloat = m_sngFloat + CLng(Mid(m_strFloat, m_lngCounter, 1)) * (2 ^ (-m_lngCounter))
    Next m_lngCounter
    
    Bin2Dec = CDbl(m_curInteger) + CDbl(m_sngFloat)End FunctionPublic Function Bin2Hex(BinNum As String) As String'二进制数转十六进制数    Dim m_lngCounter As Long            '计数器
    Dim m_strInteger As String          '整数部分
    Dim m_strFloat As String            '小数部分
    Dim m_strIntegerA As String         '转换后的整数部分
    Dim m_strFloatA As String           '转换后的小数部分
    
    If IsLegal(BinNum, 2) = False Then Exit Function         '不合法数据
    
    Call SeparatePoint(BinNum, m_strInteger, m_strFloat)
    
    m_strInteger = FillZero(m_strInteger, 4, False)
    m_strFloat = FillZero(m_strFloat, 4, True)
    
    For m_lngCounter = 1 To Len(m_strInteger) Step 4
        m_strIntegerA = m_strIntegerA & BinByte2HexByte(Mid(m_strInteger, m_lngCounter, 4))
    Next m_lngCounter
    
    For m_lngCounter = 1 To Len(m_strFloat) Step 4
        m_strFloatA = m_strFloatA & BinByte2HexByte(Mid(m_strFloat, m_lngCounter, 4))
    Next m_lngCounter
    
    Bin2Hex = m_strIntegerA & c_strPoint & m_strFloatAEnd Function

Answer 14

Public Function Bin2Oct(BinNum As String) As String'二进制数转八进制数    Dim m_lngCounter As Long            '计数器
    Dim m_strInteger As String          '整数部分
    Dim m_strFloat As String            '小数部分
    Dim m_strIntegerA As String         '转换后的整数部分
    Dim m_strFloatA As String           '转换后的小数部分
    
    If IsLegal(BinNum, 2) = False Then Exit Function         '不合法数据
    
    Call SeparatePoint(BinNum, m_strInteger, m_strFloat)
    
    m_strInteger = FillZero(m_strInteger, 3, False)
    m_strFloat = FillZero(m_strFloat, 3, True)
    
    For m_lngCounter = 1 To Len(m_strInteger) Step 3
        m_strIntegerA = m_strIntegerA & BinByte2OctByte(Mid(m_strInteger, m_lngCounter, 3))
    Next m_lngCounter
    
    For m_lngCounter = 1 To Len(m_strFloat) Step 3
        m_strFloatA = m_strFloatA & BinByte2OctByte(Mid(m_strFloat, m_lngCounter, 3))
    Next m_lngCounter
    
    Bin2Oct = m_strIntegerA & c_strPoint & m_strFloatAEnd FunctionPublic Function Hex2Bin(HexNum As String) As String'十六进制数转二进制数    Dim m_lngCounter As Long            '计数器
    Dim m_strInteger As String          '整数部分
    Dim m_strFloat As String            '小数部分
    Dim m_strIntegerA As String         '转换后的整数部分
    Dim m_strConv As String             '中间转换字串
    Dim m_strFloatA As String           '转换后的小数部分
    
    If IsLegal(HexNum, 16) = False Then Exit Function         '不合法数据
    
    Call SeparatePoint(HexNum, m_strInteger, m_strFloat)
    
    For m_lngCounter = 1 To Len(m_strInteger)
        m_strConv = Byte2BinByte(Mid(m_strInteger, m_lngCounter, 1))
        If m_lngCounter <> 1 Then m_strConv = String(4 - Len(m_strConv), "0") & m_strConv
        m_strIntegerA = m_strIntegerA & m_strConv
    Next m_lngCounter
    
    For m_lngCounter = 1 To Len(m_strFloat)
        m_strConv = Byte2BinByte(Mid(m_strFloat, m_lngCounter, 1))
        m_strConv = String(4 - Len(m_strConv), "0") & m_strConv
        m_strFloatA = m_strFloatA & m_strConv
    Next m_lngCounter
    
    Hex2Bin = m_strIntegerA & IIf(m_strFloat = vbNullString, vbNullString, c_strPoint) & RTrimZero(m_strFloatA)End FunctionPublic Function Oct2Bin(OctNum As String) As String'八进制数转二进制数    Dim m_lngCounter As Long            '计数器
    Dim m_strInteger As String          '整数部分
    Dim m_strFloat As String            '小数部分
    Dim m_strIntegerA As String         '转换后的整数部分
    Dim m_strConv As String             '中间转换字串
    Dim m_strFloatA As String           '转换后的小数部分
    
    If IsLegal(OctNum, 8) = False Then Exit Function         '不合法数据
    
    Call SeparatePoint(OctNum, m_strInteger, m_strFloat)
    
    For m_lngCounter = 1 To Len(m_strInteger)
        m_strConv = Byte2BinByte(Mid(m_strInteger, m_lngCounter, 1))
        If m_lngCounter <> 1 Then m_strConv = String(3 - Len(m_strConv), "0") & m_strConv
        m_strIntegerA = m_strIntegerA & m_strConv
    Next m_lngCounter
    
    For m_lngCounter = 1 To Len(m_strFloat)
        m_strConv = Byte2BinByte(Mid(m_strFloat, m_lngCounter, 1))
        m_strConv = String(3 - Len(m_strConv), "0") & m_strConv
        m_strFloatA = m_strFloatA & m_strConv
    Next m_lngCounter
    
    Oct2Bin = m_strIntegerA & IIf(m_strFloat = vbNullString, vbNullString, c_strPoint) & RTrimZero(m_strFloatA)End FunctionPublic Function Hex2Dec(HexNum As String) As Double'十六进制数转十进制数    If IsLegal(HexNum, 16) = False Then Exit Function       '不合法数据
    
    Hex2Dec = Bin2Dec(Hex2Bin(HexNum))End FunctionPublic Function Oct2Dec(OctNum As String) As Double'八进制数转十进制数    If IsLegal(OctNum, 8) = False Then Exit Function       '不合法数据
    
    Oct2Dec = Bin2Dec(Oct2Bin(OctNum))End FunctionPrivate Function IsLegal(Number As String, Base As Integer) As Boolean'判断数据是否合法    Dim m_lngCounter As Long            '计数器
    Dim m_lngCounterA As Long           '计数器
    Dim m_strChar As String             '字符
    
    '判断长度
    If Number = vbNullString Then
        IsLegal = False
        Exit Function
    End If
    
    '判断小数点是否合法
    m_lngCounter = InStr(1, Number, c_strPoint)
    If m_lngCounter <> 0 Then
        If InStr(m_lngCounter + 1, Number, c_strPoint) <> 0 Or _
           Left(Number, 1) = c_strPoint Or _
           Right(Number, 1) = c_strPoint Then
            IsLegal = False
            Exit Function
        End If
    End If
    
    '判断数字是否合法
    For m_lngCounter = 1 To Len(Number)
        For m_lngCounterA = 1 To Base
            m_strChar = UCase(Mid(Number, m_lngCounter, 1))
            If GetCharNum(m_strChar) > Base - 1 Then
                IsLegal = False
                Exit Function
            End If
        Next m_lngCounterA
    Next m_lngCounter
    
    IsLegal = True
    
End FunctionPrivate Function GetNumChar(Number As Integer) As String'数字对应位    If Number < 10 Then
        GetNumChar = CStr(Number)
    Else
        GetNumChar = Chr(vbKeyA + Number - 10)
    End IfEnd FunctionPrivate Function GetCharNum(Char As String) As Integer'位对应数字    If Asc(Char) >= vbKey0 And Asc(Char) <= vbKey9 Then
        GetCharNum = CInt(Char)
    Else
        GetCharNum = Asc(Char) - vbKeyA + 10
    End IfEnd FunctionPrivate Sub SeparatePoint(Number As String, IntegerPart As String, FloatPart As String)'分离整数与小数部分    Dim m_lngCounter As Long        '计数器
    
    m_lngCounter = InStr(1, Number, c_strPoint)
    
    If m_lngCounter <> 0 Then
        IntegerPart = Mid(Number, 1, m_lngCounter - 1)
        FloatPart = Mid(Number, m_lngCounter + 1)
    Else
        IntegerPart = Number
        FloatPart = vbNullString
    End IfEnd SubPrivate Function BinByte2HexByte(BinByte As String) As String'二进制字节转十六进制字节    Dim m_intCounter As Integer         '计数器
    Dim m_intNum As Integer             '数值
    
    For m_intCounter = 1 To 4
        m_intNum = m_intNum + CInt(Mid(BinByte, m_intCounter, 1)) * 2 ^ (4 - m_intCounter)
    Next m_intCounter
    
    BinByte2HexByte = Hex(m_intNum)End FunctionPrivate Function BinByte2OctByte(BinByte As String) As String'二进制字节转八进制字节    Dim m_intCounter As Integer         '计数器
    Dim m_intNum As Integer             '数值
    
    For m_intCounter = 1 To 3
        m_intNum = m_intNum + CInt(Mid(BinByte, m_intCounter, 1)) * 2 ^ (3 - m_intCounter)
    Next m_intCounter
    
    BinByte2OctByte = CStr(m_intNum)End FunctionPrivate Function Byte2BinByte(ByteChar As String) As String'其它进制字节转二进制字节    Byte2BinByte = Dec2BaseN(CCur(GetCharNum(ByteChar)), 2, 0)
    
End FunctionPrivate Function FillZero(Number As String, FillNum As Integer, FillAfter As Boolean) As String'填充“0”    If FillAfter = False Then
        FillZero = String(((Len(Number) + FillNum - 1) \ FillNum) * FillNum - Len(Number), "0") & Number
    Else
        FillZero = Number & String(((Len(Number) + FillNum - 1) \ FillNum) * FillNum - Len(Number), "0")
    End IfEnd FunctionPrivate Function RTrimZero(Target As String) As String'去掉最右边的“0”    Dim m_lngCounter As Long            '计数器
    
    If Target = vbNullString Then Exit Function
    For m_lngCounter = Len(Target) To 1 Step -1
        If Mid(Target, m_lngCounter, 1) <> "0" Then
            RTrimZero = Mid(Target, 1, m_lngCounter)
            Exit Function
        End If
    Next m_lngCounterEnd Function