压缩算法.bas

新魔剑压缩机。采用新的压缩算法对文件压缩。

      If DicCol(k) < 255 Then DicCol(k) = DicCol(k) + 1 '纪录字典
      If DicCol(k) = RePlaceLim Then RePlaceAble = RePlaceAble + 1 '可替换+1
      If AscCol(SouData(j)) = False Then '纪录Asc集合
        AscCol(SouData(j)) = True
        AscCount = AscCount - 1
      End If
      If RePlaceAble >= AscCount Then '确定是否开始替换
        RePlaceAble = AscCount
        Exit For
      End If
    Next
    If j = i + RealLen Then j = i + RealLen - 1
    '组装字典并创建映射
    CycleCount = 0
    If PossibleCycle >= 1 Then '查找是否可循环
      For k = 1 To PossibleCycle '遍历上次字典
        m = RePlaceDic(k).DicCode(1) Or RePlaceDic(k).DicCode(2) * 256&
        If DicCol(m) >= RePlaceLim Then
          If AscCol(RePlaceDic(k).AscCode) = False Then
            CycleCount = CycleCount + 1 '记录循环字典
            CycleDic(CycleCount) = RePlaceDic(k)
            CycleMap(CycleCount) = k
            DicMap(m) = RePlaceDic(k).AscCode
            DicCol(m) = 0 '消除标记
            AscCol(RePlaceDic(k).AscCode) = True
          End If
        End If
      Next
    End If
    If RePlaceAble - CycleCount >= 1 Then
      n = -1
      k = 1
      For m = 0 To 65535
        If DicCol(m) >= RePlaceLim Then '发现可替换
          For n = n + 1 To 255
            If AscCol(n) = False Then '发现可映射
              DicMap(m) = n '映射生成
              RePlaceDic(k).DicCode(1) = m And &HFF '字典生成
              RePlaceDic(k).DicCode(2) = m \ 256
              RePlaceDic(k).AscCode = n
              k = k + 1
              Exit For
            End If
          Next
        End If
        If k > RePlaceAble - CycleCount Then Exit For
      Next
    End If
    
    ReDim Preserve DesData(LBound(DesData) To UBound(DesData) + 4 + CycleCount + 3 * (RePlaceAble - CycleCount) + RealLen)
    DesPos = DesPos + 1
    DesData(DesPos) = CycleCount
    DesPos = DesPos + 1
    Call CopyMemory(DesData(DesPos), CycleMap(1), CycleCount)
    DesPos = DesPos + CycleCount
    DesData(DesPos) = RePlaceAble - CycleCount
'    If RePlaceAble - CycleCount > 0 Then
     ' DesPos = DesPos + 1
      Call CopyMemory(DesData(DesPos + 1), RePlaceDic(1), 3 * (RePlaceAble - CycleCount))
      DesPos = DesPos + 3 * (RePlaceAble - CycleCount)
'    End If
    For k = 1 To CycleCount '合并字典
      m = CycleDic(k).DicCode(1) Or CycleDic(k).DicCode(2) * 256&
      RePlaceDic(RePlaceAble - CycleCount + k) = CycleDic(k)
      DicCol(m) = RePlaceLim
    Next
    '写入目标数据
    m = DesPos
    DesPos = DesPos + 2
    For n = i To j - 1
      k = SouData(n) Or SouData(n + 1) * 256&
      DesPos = DesPos + 1
      If DicCol(k) >= RePlaceLim Then
        DesData(DesPos) = DicMap(k) '替换
        n = n + 1
      Else
        DesData(DesPos) = SouData(n) '无替换
      End If
    Next
    If n = j Then '末尾处理
      DesPos = DesPos + 1
      DesData(DesPos) = SouData(j)
    End If
    ReDim Preserve DesData(LBound(DesData) To DesPos) '确定目标真实大小
    '写入目标文件
    DesData(m + 1) = (DesPos - m - 2) \ 256
    DesData(m + 2) = (DesPos - m - 2) And &HFF
    i = j + 1
  Loop Until UBound(SouData) - i < 4096
  If i <= UBound(SouData) Then
    ReDim TempData(i To UBound(SouData))
    Call CopyMemory(TempData(i), SouData(i), UBound(SouData) - i + 1)
    Call SwapArray(TempData, SouData)
  Else
    Call ClearArray(SouData, i)
  End If
End If
End Sub

Private Sub UnRePlaceCode(SouData() As Byte, DesData() As Byte)
Static RePlaceDic(1 To 255) As RePlaceCode '替换表
Dim RealLen As Long
Dim CycleDic(1 To 255) As RePlaceCode, CycleMap(1 To 255) As Byte
Dim CycleCount As Byte
Dim AscMap(0 To 255) As Byte   'Asc映射
Dim i As Long, j As Long, k As Byte
Dim SouPos As Long
Dim TempData() As Byte
SouPos = LBound(SouData)
'开始计时
If UBound(SouData) - LBound(SouData) + 1 = 0 Then
  Erase RePlaceDic
Else
  If LBound(SouData) = 1 Then Call ClearArray(DesData, 1)
  CycleCount = SouData(SouPos)
  SouPos = SouPos + 1
  Call CopyMemory(CycleMap(1), SouData(SouPos), CycleCount)
  For i = 1 To CycleCount
    CycleDic(i) = RePlaceDic(CycleMap(i))
  Next
  SouPos = SouPos + CycleCount
  k = SouData(SouPos)
  SouPos = SouPos + 1
  Call CopyMemory(RePlaceDic(1), SouData(SouPos), 3 * k)
  SouPos = SouPos + 3 * k
  Call CopyMemory(RePlaceDic(k + 1), CycleDic(1), 3 * CycleCount)
  k = k + CycleCount
  '读取处理单元大小
  RealLen = SouData(SouPos) * 256& Or SouData(SouPos + 1)
  SouPos = SouPos + 2
  '生成Asc映射
  'Erase AscMap
  For i = 1 To k
    AscMap(RePlaceDic(i).AscCode) = i
  Next
  j = UBound(DesData)
  ReDim Preserve DesData(LBound(DesData) To UBound(DesData) + ReadLen) '初始化目标单元大小
  For i = SouPos To SouPos + RealLen - 1
    j = j + 1
    If AscMap(SouData(i)) = 0 Then
      DesData(j) = SouData(i) '无替换
    Else
      DesData(j) = RePlaceDic(AscMap(SouData(i))).DicCode(1) '替换
      j = j + 1
      DesData(j) = RePlaceDic(AscMap(SouData(i))).DicCode(2)
    End If
  Next
  ReDim Preserve DesData(LBound(DesData) To j) '确定目标单元真实大小
  If i <= UBound(SouData) Then
    Call SwapArray(TempData, SouData)
    ReDim SouData(i To UBound(TempData))
    Call CopyMemory(SouData(i), TempData(i), UBound(TempData) - i + 1)
  Else
    Call ClearArray(SouData, i)
  End If
End If
End Sub

Public Function Extract(SouFile As String, DesFileNum As Integer, DesFilePos As Long) As Long
On Error GoTo Err

Dim RealLen As Long
Dim buffer1() As Byte, buffer2() As Byte, buffer3() As Byte
Dim SouFileNum As Integer '文件号
Dim SouFileLen As Long   '原文件长

SouFileNum = FreeFile
Open SouFile For Binary As #SouFileNum
Pro = 0
FileName = Mid$(SouFile, InStrRev(SouFile, "\") + 1)
'正式处理
Seek #SouFileNum, 1
Seek #DesFileNum, DesFilePos
SouFileLen = LOF(SouFileNum)

If SouFileLen > 0 Then
  Call ClearArray(buffer1, 1)
  Call ClearArray(buffer2, 1)
  Call PointCode(buffer1, buffer2)
  Call RePlaceCode(buffer1, buffer2)

  Do
    Do Until UBound(buffer2) - LBound(buffer2) + 1 >= 65535 Or UBound(buffer1) - LBound(buffer1) = -1 And SouFileLen + 1 = Seek(SouFileNum)
      DoEvents '防卡死
      Pro = Round(Seek(SouFileNum) / SouFileLen, 4) '进度计算

     If Cancel Then
        Close #SouFileNum
        Extract = Seek(DesFileNum)
        Exit Function
      End If
  
      Seek #SouFileNum, LBound(buffer1)
      If SouFileLen - Seek(SouFileNum) + 1 >= 65535 Then RealLen = 65535 Else RealLen = SouFileLen - Seek(SouFileNum) + 1
      ReDim buffer1(LBound(buffer1) To LBound(buffer1) + RealLen - 1)
      Get #SouFileNum, , buffer1
      Call PointCode(buffer1, buffer2)
    Loop
    Call RePlaceCode(buffer2, buffer3)
    Put #DesFileNum, , buffer3
    Call ClearArray(buffer3, 1)
  Loop Until UBound(buffer2) - LBound(buffer2) = -1 And SouFileLen + 1 = Seek(SouFileNum)

End If
Close #SouFileNum '关闭文件
Pro = 1
Extract = Seek(DesFileNum)

Exit Function
Err: '错误处理
  Close #SouFileNum
  Extract = Seek(DesFileNum)
  MsgBox "Error!"
End Function

Public Function UnExtract(SouFileNum As Integer, StartPos As Long, EndPos As Long, DesFile As String) As Long
On Error GoTo Err
'变量定义
Dim RealLen As Long
Dim buffer1() As Byte, buffer2() As Byte, buffer3() As Byte
Dim SouFileLen As Long   '原文件长
Dim DesFileNum As Integer  '文件号
  
Pro = 0
FileName = Mid$(DesFile, InStrRev(DesFile, "\") + 1)
SouFileLen = EndPos - StartPos
Seek #SouFileNum, StartPos
DesFileNum = FreeFile
Open DesFile For Binary As #DesFileNum

If Seek(SouFileNum) < EndPos Then
  Call ClearArray(buffer1, StartPos)
  Call ClearArray(buffer2, 1)
  Call UnRePlaceCode(buffer1, buffer2)
  Call UnPointCode(buffer1, buffer2)
  Do
    Do Until Seek(SouFileNum) = EndPos And UBound(buffer1) - LBound(buffer1) = -1 Or UBound(buffer2) - LBound(buffer2) + 1 >= 65535 * 2
      DoEvents '防卡死
      Pro = Round((Seek(SouFileNum) - StartPos) / SouFileLen, 4) '进度计算
      If Cancel Then
        Close #DesFileNum
        UnExtract = -1
        Exit Function
      End If
      Seek #SouFileNum, LBound(buffer1)
      If EndPos - Seek(SouFileNum) >= 65535 * 2 Then RealLen = 65535 * 2 Else RealLen = EndPos - Seek(SouFileNum)
      ReDim buffer1(LBound(buffer1) To LBound(buffer1) + RealLen - 1)
      Seek #SouFileNum, LBound(buffer1)
      Get #SouFileNum, , buffer1
      Call UnRePlaceCode(buffer1, buffer2)
    Loop
    Call UnPointCode(buffer2, buffer3)
    Put #DesFileNum, , buffer3
    Call ClearArray(buffer3, UBound(buffer3) + 1)
  Loop Until UBound(buffer2) - LBound(buffer2) = -1 And Seek(SouFileNum) = EndPos And UBound(buffer1) - LBound(buffer1) = -1

End If

UnExtract = LOF(DesFileNum)
Close #DesFileNum '关闭文件
Pro = 1
Exit Function
Err: '错误处理
  Close #DesFileNum
  UnExtract = -1
  MsgBox "Error!"
End Function