global.bas

21加密算法,用vB语言编写实现,可了解各种加密算法的结构

    Version = Chr(ByteArray(InPos))
    InPos = InPos - 1
    Select Case Version
        Case "0"
            CodecsUsed = ByteArray(InPos)
            InPos = InPos - 1
            ReDim UsedCodecs(CodecsUsed)
            For X = 1 To CodecsUsed
                UsedCodecs(X) = ByteArray(InPos)
                InPos = InPos - 1
            Next
            ReDim Preserve ByteArray(InPos)
    End Select
    ReDim WorkArray(0)
    For X = 0 To 255
        Master.Bars(1 * 256 + X).Visible = False
    Next
    Master.AscTab(1).Clear
    Master.FreqTab(1).Clear
    Master.FileSize(1).Caption = " "
    Master.MaxValue(1).Caption = "Maximum"
    Master.MidValue(1).Caption = "Medium"
    Master.LowValue(1).Caption = "Lowest"
    JustLoaded = False
End Sub

'this sub is used to save a file
'if the file was coded/compressed the types of coders/compressors used
'will be saved with the file so that we can recall it later
Public Sub Save_File_As(ByteArray() As Byte, source As Boolean)
    Dim FileNr As Integer
    Dim HeadArray() As Byte
    Dim OutHead As Integer
    Dim HeadText As String
    Dim Answer As Integer
    Dim CodecsUsed As Integer
    Dim SaveName As String
    Dim ExtPos As Integer
    Dim Temp As Integer
    Dim X As Integer
    If UBound(ByteArray) = 0 Then
        MsgBox "There is nothing to be saved"
        Exit Sub
    End If
    If source = False And LastCoder <> 0 Then Call AddCoder2List(LastCoder)
    If UBound(UsedCodecs) = 0 And UBound(ByteArray) = UBound(OriginalArray) Then
        Answer = MsgBox("此操作将覆盖原文件" & Chr(13) & "要继续保存文件吗?", vbYesNo + vbExclamation)
        If Answer = vbNo Then
            Exit Sub
        End If
    End If
Ask_SaveName:
    SaveName = ""
    Master.Cdlg.DialogTitle = "Type in the name you want to save with"
    Master.Cdlg.FileName = ""
    Master.Cdlg.ShowSave
    SaveName = Master.Cdlg.FileName
    If SaveName = "" Then
        If source = False And LastCoder <> 0 Then
            ReDim Preserve UsedCodecs(UBound(UsedCodecs) - 1)
            LastCoder = UsedCodecs(UBound(UsedCodecs))
        End If
        Exit Sub
    End If
    Temp = 0
    Do
        ExtPos = Temp
        Temp = InStr(ExtPos + 1, SaveName, ".")
    Loop While Temp <> 0
    If ExtPos = 0 Or ExtPos < Len(SaveName) - 5 Then
        SaveName = SaveName & ".hmf"
    End If
'store the header in reversed order at the end of the file
    HeadText = "UCF0"
    If LastCoder = 0 And source = False Then
        CodecsUsed = 0
    Else
        CodecsUsed = UBound(UsedCodecs)
    End If
    ReDim HeadArray(4 + CodecsUsed)
    OutHead = 0
    For X = CodecsUsed To 1 Step -1
        HeadArray(OutHead) = UsedCodecs(X)
        OutHead = OutHead + 1
    Next
    HeadArray(OutHead) = CodecsUsed
    OutHead = OutHead + 1
    For X = Len(HeadText) To 1 Step -1
        HeadArray(OutHead) = ASC(Mid(HeadText, X, 1))
        OutHead = OutHead + 1
    Next
    FileNr = FreeFile
    If Dir(SaveName, vbNormal) <> "" Then
        Answer = MsgBox("文件已经存在," & Chr(13) & Chr(13) & "要替换吗?", vbCritical + vbYesNo)
        If Answer = vbNo Then
            GoTo Ask_SaveName
        End If
        Kill SaveName   'first remove it otherwise size is not adjusted
    End If
    Open SaveName For Binary As #FileNr
    Put #FileNr, , ByteArray()
    If CodecsUsed > 0 Then
        Put #FileNr, , HeadArray()
    End If
    Close #FileNr
End Sub

'this sub is used to show the statistics of a file
'it can display both the original as the workarray
Public Sub Show_Statistics(OrgData As Boolean, Data() As Byte, Optional TimeUsed As Double = 0)
    Dim StatWindow As Integer
    Dim Frequentie(255) As Long
    Dim SortFreq(1, 255) As Long
    Dim Counts() As Long
    Dim X As Long
    Dim Minval As Long
    Dim Maxval As Long
    Dim next_offset As Long
    Dim this_count As Long
    Dim HeightValue As Double
    Dim Entry As String
    Dim NewSize As String
    Dim NuSize As Long
    Dim BPB As String
    If OrgData = False Then StatWindow = 1
    NuSize = UBound(Data) + 1
    BPB = Format(((NuSize * 8) / OriginalSize), "###0.000") & " bpb"
    NewSize = NuSize & " Bytes  [ " & Format(100 - (OriginalSize - NuSize) / OriginalSize * 100, "##0.00") & "% ]  "
    If TimeUsed > 0 Then
        NewSize = NewSize & BPB & "  " & Format(TimeUsed, "###0.00") & " Sec."
    End If
    For X = 0 To UBound(Data)
        Frequentie(Data(X)) = Frequentie(Data(X)) + 1
    Next
    Minval = UBound(Data)
    For X = 0 To 255
        If Minval > Frequentie(X) Then Minval = Frequentie(X)
        If Maxval < Frequentie(X) Then Maxval = Frequentie(X)
    Next
' Lets use the counting sort to sort them into another array
' Create the Counts array.
    ReDim Counts(Minval To Maxval)
' Count the items.
    For X = 0 To 255
        Counts(Frequentie(X)) = Counts(Frequentie(X)) + 1
    Next X
' Convert the counts into offsets.
    next_offset = 0
    For X = Maxval To Minval Step -1
        this_count = Counts(X)
        Counts(X) = next_offset
        next_offset = next_offset + this_count
    Next X
' Place the items in the sorted array.
    For X = 0 To 255
        SortFreq(0, Counts(Frequentie(X))) = Frequentie(X)
        SortFreq(1, Counts(Frequentie(X))) = X
        Counts(Frequentie(X)) = Counts(Frequentie(X)) + 1
    Next X
'Create the graphics view
    HeightValue = (SortFreq(0, 0) - SortFreq(0, 255)) / Master.Graphic(StatWindow).Height
    For X = 0 To 255
        If Frequentie(X) - SortFreq(0, 255) <> 0 Then
            Master.Bars(StatWindow * 256 + X).Visible = True
            Master.Bars(StatWindow * 256 + X).Y1 = Master.Bars(StatWindow * 256 + X).Y2 - (Frequentie(X) - SortFreq(0, 255)) / HeightValue
            Master.Bars(StatWindow * 256 + X).BorderColor = RGBColor(X Mod 7)
        Else
            Master.Bars(StatWindow * 256 + X).Visible = False
        End If
    Next
    Master.MaxValue(StatWindow).Caption = SortFreq(0, 0)
    Master.MidValue(StatWindow).Caption = Int((SortFreq(0, 0) - SortFreq(0, 255)) / 2) + SortFreq(0, 255)
    Master.LowValue(StatWindow) = SortFreq(0, 255)
    Master.FileSize(StatWindow).Caption = NewSize
'Create the statistics view
    Master.AscTab(StatWindow).Clear
    Master.FreqTab(StatWindow).Clear
    Entry = "Index    Freq."
    Master.AscTab(StatWindow).AddItem Entry
    For X = 0 To 255
        Entry = Format(X, "##0") & Chr(9) & Frequentie(X)
        Master.AscTab(StatWindow).AddItem Entry
    Next
    Entry = "Index" & Chr(9) & "Ascii" & Chr(9) & "Freq."
    Master.FreqTab(StatWindow).AddItem Entry
    For X = 0 To 255
        Entry = Format(X, "##0") & Chr(9) & SortFreq(1, X) & Chr(9) & SortFreq(0, X)
        Master.FreqTab(StatWindow).AddItem Entry
    Next
End Sub

'this sub is used to show the contents of the file
'its used for both the original as the workarray
Public Sub Show_Contents(ByteArray() As Byte)
    Dim X As Long
    Dim Y As Integer
    Dim AddData As String
    Dim AddText As String
    Dim Data As Byte
    Dim Text As String
    On Error GoTo No_Data
    X = UBound(ByteArray)
    If X = 0 Then
        MsgBox "没有数据!"
        Exit Sub
    End If
    On Error GoTo 0
    frmViewContents.Show
    frmViewContents.lstContents.Clear
    For X = 0 To UBound(ByteArray) Step 16
        AddData = String(61, " ")
        Mid(AddData, 35, 1) = "|"
        AddText = String(16, " ")
        Mid(AddData, 1, 9) = Right("00000000" & Hex(X), 8) & ":"
        For Y = 0 To 15
            If X + Y <= UBound(ByteArray) Then
                Data = ByteArray(X + Y)
                Mid(AddData, 12 + (3 * Y), 2) = Right("0" & Hex(Data), 2)
                If Data < 28 Then Text = Chr(1) Else Text = Chr(Data)
                Mid(AddText, Y + 1, 1) = Text
            End If
        Next
        If frmViewContents.Visible = True Then
            frmViewContents.lstContents.AddItem AddData & AddText
        Else
            Exit Sub
        End If
        If X Mod 500 * 16 = 0 Then DoEvents
    Next
    DoEvents
No_Data:
End Sub

'this sub is used to store a coder/compressor type into an array
'so that we can keep up which coders/compressors are used to get to
'the last file whe have standing in the original array
Public Sub AddCoder2List(CodeNumber As Integer)
    JustLoaded = False
    If LastDeCoded = True Then
        If UBound(UsedCodecs) > 0 Then
            ReDim Preserve UsedCodecs(UBound(UsedCodecs) - 1)
            LastCoder = UsedCodecs(UBound(UsedCodecs))
        End If
        Exit Sub
    End If
    ReDim Preserve UsedCodecs(UBound(UsedCodecs) + 1)
    UsedCodecs(UBound(UsedCodecs)) = CodeNumber
End Sub

'this sub is used to decode/uncompress automaticly without the user
'having search which type of coder/compressor was used
Public Sub Auto_Decode_Depack()
    Dim X As Integer
    Dim CodeNumber As Integer
    If UBound(OriginalArray) = 0 Then
        MsgBox "没有数据来执行压缩/解压缩操作"
        Exit Sub
    End If
    If UBound(UsedCodecs) = 0 Or JustLoaded = True Then
        MsgBox "This file was'nt Coded/Compressed"
        Exit Sub
    End If
    CodeNumber = UsedCodecs(UBound(UsedCodecs))
    AutoDecodeIsOn = True
    If CodeNumber > 128 Then
        Call Start_Coder(CodeNumber And 127)
    Else
        Call Start_Compressor(CodeNumber)
    End If
    Call Copy_Work2Orig
    ReDim WorkArray(0)
    For X = 0 To 255
        Master.Bars(1 * 256 + X).Visible = False
    Next
    Master.AscTab(1).Clear
    Master.FreqTab(1).Clear
    Master.FileSize(1).Caption = " "
    Master.MaxValue(1).Caption = "Maximum"
    Master.MidValue(1).Caption = "Medium"
    Master.LowValue(1).Caption = "Lowest"
    AutoDecodeIsOn = False
    If UBound(UsedCodecs) > 0 Then
        ReDim Preserve UsedCodecs(UBound(UsedCodecs) - 1)
        LastCoder = UsedCodecs(UBound(UsedCodecs))
    End If
    Call Show_Statistics(True, OriginalArray)
End Sub

'this sub is used to compare the original array with the workarray
Public Sub Compare_Source_With_Target()
    Dim FileSize As Long
    Dim SameSize As Boolean
    Dim Text As String
    Dim Equal As Boolean
    Dim X As Long
    SameSize = True
    Equal = True
    If UBound(OriginalArray) = 0 Then
        MsgBox "没有数据"
        Exit Sub
    End If
    If UBound(WorkArray) = 0 Then
        MsgBox "There is nothing to compare with"
        Exit Sub
    End If
    FileSize = UBound(OriginalArray)
    If UBound(WorkArray) <> FileSize Then
        SameSize = False
        If UBound(WorkArray) < FileSize Then
            FileSize = UBound(WorkArray)
        End If
    End If
    For X = 0 To FileSize
        If OriginalArray(X) <> WorkArray(X) Then
            Equal = False
            Exit For
        End If
    Next
    If Equal = False Then
        Text = "The files are different at position " & X & " : " & Right("000000" & Hex(X), 6)
        If SameSize = False Then
            Text = Text & Chr(13) & "And They dont have the same size"
        End If
        MsgBox Text
        Exit Sub
    End If
    If SameSize = False Then
        Text = "The files are almost the same except that they don't have the same size"
    Else
        Text = "the two files are the same"
    End If
    MsgBox Text
End Sub