两个十六进制相加怎么运算？ - VB6论坛

第 3 楼

得分:0

无聊随便写写～大部分是废话～

frmMain :

程序代码：

Option Explicit

Dim TitleTemp() As Byte, FilePath As String, FileName As String
Dim fl As Long, Status As Boolean

Private Sub cmdCommand1_Click()
Dim FileNum As Integer, fl As Long

On Error GoTo ErrorHandling

    FileNum = FreeFile: FilePath = "": txtText1.Text = "": txtText1.ToolTipText = ""
    
    ProgressBar1.Value = 0

    Dialog1.ShowOpen
    FilePath = Dialog1.FileName
    
    If FilePath <> "" Then
        
        fl = FileLen(FilePath)
        
        txtText1.Text = FilePath
        txtText1.ToolTipText = txtText1.Text
        
        Status = LoadFile(fl)
        
        If Status = True Then
            MsgBox "LoadFile OK !"
        End If
        
        cmdCommand1.Enabled = False
        cmdCommand2.Enabled = True
        
    Else
        
        FilePath = "": txtText1.Text = "": txtText1.ToolTipText = ""
    
    End If
    
Exit Sub

ErrorHandling:
    Status = False ': MsgBox "Error !"
    Call ErrorWriteBuff(FileName, 0, "cmdCommand1_Click", Err.Number, Err.Description, "系统讯息")
    Resume Next
End Sub

Private Sub cmdCommand2_Click()
Dim S1 As Currency, S2 As Currency, f As Currency, t1 As Currency   '计时用
Dim FileNum As Integer, i As Long, NewFileName As String, ErrFileName As String, Path As String

On Error GoTo ErrorHandling

    NewFileName = "": ErrFileName = "": cmdCommand1.Enabled = False
    
    StatusBar1.Panels(1).Text = "Transform Process ..."

    Call QueryPerformanceFrequency(f)      '计时
    Call QueryPerformanceCounter(S1)       '计时
    
    FileName = Trim(Mid$(FilePath, InStrRev(FilePath, "\") + 1, Len(FilePath) - InStrRev(FilePath, "\")))
    Path = Trim(Mid$(FilePath, 1, Len(FilePath) - Len(FileName)))
    NewFileName = "New_" & FileName
    ErrFileName = "Err_" & FileName
    
    Status = Transform(Path, NewFileName, ErrFileName)
    
    Call QueryPerformanceCounter(S2)       '计时
    t1 = (S2 - S1) / f                     '计时
    
    If Status = True Then
        MsgBox "Finish !" & vbCrLf & "Spend Time : " & fl \ t1 & " (Line/Second)"
    End If
    
    cmdCommand1.Enabled = True
    cmdCommand2.Enabled = False
    
Exit Sub

ErrorHandling:
    Status = False ': MsgBox "Error !"
    Call ErrorWriteBuff(FileName, 0, "cmdCommand2_Click", Err.Number, Err.Description, "系统讯息")
    Resume Next
End Sub

Private Sub Form_Initialize()
    ErrorCount = 0: ReDim ErrorData(ErrorCount): ReDim TitleTemp(0): fl = 0: Status = False: FilePath = ""
End Sub

Private Sub Form_Load()

    If App.PrevInstance Then '避免程式执行两次以上
       Call MsgBox("This program has been executed", vbCritical, "Warning")
       Unload Me
    End If
    
    frmMain.Caption = frmMain.Caption & " Ver " & App.Major & "." & App.Minor & "." & App.Revision & ".1"

    SetCurrentDirectory App.Path

    cmdCommand1.Enabled = True
    cmdCommand2.Enabled = False
    
    ProgressBar1.Max = 100
    ProgressBar1.Min = 0
    ProgressBar1.Value = 0
    
End Sub

Private Function LoadFile(fl As Long) As Boolean
Dim FileNum As Integer

On Error GoTo ErrorHandling

    FileNum = FreeFile: FileName = ""
    
    ReDim TitleTemp(fl - 1)
    
    Open FilePath For Binary As #FileNum    '1秒    抓档案全部资料
        Get #FileNum, 1, TitleTemp()
    Close #FileNum
    
    LoadFile = True

Exit Function

ErrorHandling:
    LoadFile = False ': MsgBox "Error !"
    Call ErrorWriteBuff(FileName, 0, "LoadFile", Err.Number, Err.Description, "系统讯息")
    Resume Next
End Function

Private Function Transform(Path As String, NewFileName As String, ErrFileName As String) As Boolean
Dim i As Long, DataString() As Byte

On Error GoTo ErrorHandling

    '重点开始----------------------------------------------------------------
    
    For i = 0 To UBound(TitleTemp)
        
        '????????????????????????????????????????????????????????????????????
        
        Call DataStringProcess(TitleTemp(), i)
        
        '????????????????????????????????????????????????????????????????????
        
        If i Mod 1000 = 0 Then
            If i <> 0 Then ProgressBar1.Value = (i / fl) * 100
        ElseIf fl - i < 100 Then
            ProgressBar1.Value = 100
        End If
    Next i
    '------------------------------------------------------------------------
    
    Status = WriteFile(Path, NewFileName, ErrFileName, DataString())
    
    If Status <> True Then MsgBox "WriteFile Error !": Exit Function
    
    Transform = True
    
Exit Function

ErrorHandling:
    Transform = False ': MsgBox "Error !"
    Call ErrorWriteBuff(FileName, i, "Transform", Err.Number, Err.Description, "系统讯息")
    Resume Next
End Function

Private Function WriteFile(Path As String, NewFileName As String, ErrFileName As String, DataString() As Byte) As Boolean
Dim FileNum As Integer, i As Long

On Error GoTo ErrorHandling

    FileNum = FreeFile  'Write New Binary File
    
    Open Path & NewFileName For Binary Access Write As #FileNum
        
        For i = 0 To UBound(DataString)
            DoEvents
            Put #FileNum, , CByte(Val(DataString(i)))   'Binary
        Next i
    
    Close #FileNum
    
    If UBound(ErrorData) > 0 Then
    
        FileNum = FreeFile  'Write Error Messages
        
        Open Path & ErrFileName For Output As #FileNum
        
            For i = 0 To UBound(ErrorData)
                DoEvents
                Print #FileNum, ErrorData(i)   'String
            Next i
            
        Close #FileNum
        
    End If
    
    WriteFile = True
    
Exit Function

ErrorHandling:
    WriteFile = False ': MsgBox "Error !"
    Call ErrorWriteBuff(FileName, 0, "WriteFile", Err.Number, Err.Description, "系统讯息")
    Resume Next
End Function

Private Function DataStringProcess(TitleTemp() As Byte, i As Long) As Boolean

On Error GoTo ErrorHandling
    
    'Binary 处理分两种
    '1. 单纯一个16进位码对应一个Ascii Code
    
    '2. 不单纯有特定格式之N Bytes 16进位码组成一个数字或字串~而其中又分~
        '1.LSB系列 - 低位元至高位元由左排至右
        '2.MSB系列 - 低位元至高位元由右排至左
    
    DataStringProcess = True

Exit Function

ErrorHandling:
    DataStringProcess = False ': MsgBox "Error !"
    Call ErrorWriteBuff(FileName, 0, "WriteFile", Err.Number, Err.Description, "系统讯息")
    Resume Next
End Function

Module :

程序代码：

Option Explicit

Public Declare Function QueryPerformanceCounter Lib "kernel32" (x As Currency) As Boolean
Public Declare Function QueryPerformanceFrequency Lib "kernel32" (x As Currency) As Boolean
Public Declare Function SetCurrentDirectory Lib "kernel32" Alias "SetCurrentDirectoryA" (ByVal lpPathName As String) As Long

Public ErrorCount As Long
Public ErrorData() As String

Public Function ErrorWriteBuff(FileName As String, lines As Long, FunctionName As String, code As Integer, Description As String, Remarks As String) As Boolean
    
    If Description = "" Then Description = "Null"
    
    ReDim Preserve ErrorData(ErrorCount)
    ErrorData(ErrorCount) = FileName & ":" & Format(lines, "00000000") & "  " & FunctionName & "  " & "code :" & code & " Description :" & Description & ":" & Remarks
    ErrorCount = ErrorCount + 1
    
End Function

Public Function IEEE754(i As Currency, TitleTemp() As Byte, b As String) As String  '十进位转((二进位(自己写的))浮点数转换)

Dim binary() As Integer, ii As Integer, jj As Integer, temp As Integer, power As Integer
Dim number As Double, Result_T As Currency
Dim tempstring As String, a As String

Erase binary
ReDim binary(31)

temp = 0
power = 0
number = 0
tempstring = ""
b = ""

Result_T = ((CCur(TitleTemp(i)) * 1) + (CCur(TitleTemp(i + 1)) * 256) + (CCur(TitleTemp(i + 2)) * 65536) + (CCur(TitleTemp(i + 3)) * 16777216))

'-------------------------------------------------------------------十进位转二进位(自己写的)

    For ii = 0 To 3
        temp = TitleTemp(i + ii)
        For jj = 0 To 7
            If temp < 2 And temp >= 0 Then
                If temp = 1 Then
                    binary(31 - jj - (ii * 8)) = 1
                    temp = temp - 1
                Else
                    binary(31 - jj - (ii * 8)) = 0
                End If
            ElseIf temp >= 2 Then
                binary(31 - jj - (ii * 8)) = temp Mod 2
                temp = Fix(temp / 2)
            Else
                binary(31 - jj - (ii * 8)) = 0
            End If
        Next jj
    Next ii
    
'-------------------------------------------------------------------(32bits)二进位转浮点数

    For ii = 0 To 31
        a = a & binary(ii)
    Next ii
    
    If binary(0) = 0 Then
        b = "+"
    Else
        b = "-"
    End If
    
    tempstring = ""
    For ii = 1 To 8
        tempstring = tempstring & binary(ii)
    Next ii
    
    number = Dec(tempstring)
    power = number - 127
    
    tempstring = ""
    For ii = 9 To 31
        tempstring = tempstring & binary(ii)
    Next ii
    
    tempstring = "1." & tempstring
    number = Dec(tempstring)
    number = number * (2 ^ power)
    b = b & CStr(number)

'-------------------------------------------------------------------

End Function

Public Function Bin(ByVal n As Double, ByVal m As Long) As String   '十进位转二进位(网路抓的)-暂无用处

Dim i As Long, dot As Long, iP As Long, fP As Double
Dim prefix As String, BinInt As String, BinFloat As String
     
     If Left(n, 1) = "-" Then prefix = "-": n = Mid(n, 2)
     dot = InStr(n, ".")
     If dot <> 0 Then iP = Left(n, dot - 1): fP = Mid(n, dot) Else iP = n
     Do
          BinInt = (iP Mod 2) & BinInt
          iP = iP \ 2
     Loop Until iP = 0
     BinInt = prefix & BinInt
     If dot = 0 Then Bin = BinInt: Exit Function
     For i = 1 To m
          fP = fP * 2
          fP = (fP - Int(fP)) + (Int(fP) Mod 2)
          BinFloat = BinFloat & Int(fP)
          If fP = 1 Then Exit For
     Next
     Bin = BinInt & "." & BinFloat
     
End Function

Public Function Dec(ByVal n As String) As Double    '二进位转十进位

Dim i As Long, j As Long, dot As Long, prefix As Long

     prefix = Sgn(n)
     If prefix = -1 Then n = Mid(n, 2)
     dot = InStr(n, ".")
     If dot = 0 Then
          dot = Len(n) - 1
     Else
          n = Left(n, dot - 1) & Mid(n, dot + 1)
          dot = dot - 2
     End If
     For i = dot To dot - Len(n) + 1 Step -1
          j = j + 1
          If Mid(n, j, 1) <> 0 Then Dec = Dec + 2 ^ i
     Next
     Dec = Dec * prefix
     
End Function

Public Function StringToHex(K_start As Integer, K_end As Integer, j_start As Long, Title() As String, All() As String, end_j As Integer)

Dim k As Integer, m As Integer
Dim j As Long

On Error Resume Next

j = j_start

    For k = K_start To K_end
        m = 1
        If Title(k) <> "" Then
            If Asc(Title(k)) <> 0 Then
                If Len(Title(k)) <> 0 Then
                    If Title(k) = "2.5.9_8 " Then
                        All(j) = Len(Title(k)) + 3
                        For j = j + 1 To (j + 1) + Len(CStr(Title(k))) - 1
                            All(j) = Asc(Mid(CStr(Title(k)), m, 1))
                            m = m + 1
                        Next j
                    Else
                        All(j) = Len(Trim(Title(k)))
                        For j = j + 1 To (j + 1) + Len(Trim(Title(k))) - 1
                            All(j) = Asc(Mid(CStr(Title(k)), m, 1))
                            m = m + 1
                        Next j
                    End If
                End If
            Else
                All(j) = 0
                j = j + 1
            End If
        Else
            All(j) = 0
            j = j + 1
        End If
    Next k

end_j = j

End Function

Public Function DecToHex(Array_start As Integer, Source As Currency, ByRef Result() As String, How_Byte As Integer)

Dim TempTotalCount1 As Integer, TempTotalCount2 As Integer
    
On Error Resume Next

If How_Byte = 4 Then

    If Fix(CCur(Source) / 256) >= 1 Then
        If Fix(CCur(Source) / 65536) >= 1 Then
            If Fix(CCur(Source) / 16777216) >= 1 Then
                Result(Array_start + 3) = CByte(Fix(CCur(Source) / 16777216))                                                                   '''最高位数字(最右)
                TempTotalCount1 = Result(Array_start + 3)
                Result(Array_start + 2) = CByte(Fix(CCur(Source) / 65536) - CCur(TempTotalCount1) * 256)                                        '''次高位数字(右)
                TempTotalCount2 = Result(Array_start + 2)
                Result(Array_start + 1) = CByte(Fix(CCur(Source) / 256) - CCur((TempTotalCount1) * 65536) - (CCur(TempTotalCount2) * 256))      '''次次高位数字(右)
                Result(Array_start) = CByte(CCur(Source) - CCur(256 * (Fix(CCur(Source) / 256))))
'               Result(Array_start) = CByte(CCur(Source) Mod 256)                                                                               '''最低位数字(最左)
            Else
                Result(Array_start + 3) = 0
                Result(Array_start + 2) = CByte(Fix(CCur(Source) / 65536))
                TempTotalCount2 = Result(Array_start + 2)
                Result(Array_start + 1) = CByte(Fix(CCur(Source) / 256) - (CCur(TempTotalCount2) * 256))
                Result(Array_start) = CByte(CCur(Source) - CCur(256 * (Fix(CCur(Source) / 256))))
            End If
        Else
            Result(Array_start + 3) = 0
            Result(Array_start + 2) = 0
            Result(Array_start + 1) = CByte(Fix(CCur(Source) / 256))
            Result(Array_start) = CByte(CCur(Source) - CCur(256 * (Fix(CCur(Source) / 256))))
        End If
    Else
        Result(Array_start + 3) = 0
        Result(Array_start + 2) = 0
        Result(Array_start + 1) = 0
        Result(Array_start) = CByte(CCur(Source))
    End If
    
ElseIf How_Byte = 2 Then

    If Fix(CCur(Source) / 256) >= 1 Then
        Result(Array_start + 1) = CByte(Fix(CCur(Source) / 256))
        Result(Array_start) = CByte(CCur(Source) - CCur(256 * (Fix(CCur(Source) / 256))))
    Else
        Result(Array_start + 1) = 0
        Result(Array_start) = CByte(CCur(Source))
    End If
        
ElseIf How_Byte = 1 Then

    Result(Array_start) = CByte(CCur(Source))
    
End If

End Function

[注] :
模块部分有些是从之前写的档案复制出来的～所以参数部份会有点合不上～
主要只是用来说明～用VB转位元是多么麻烦的事而已～
这之前是写处理STDF档(有分LSB和MSB那种)～用VB写代码总长度比用C写多一倍～
效率却只有C的1/360不到～而且你还会发现用VB的～部分运算元无法处理长整数或更大的数字～
还要绞尽脑汁想替代方案来解决～这算VB的极限吗？

不要選我當版主