自解压过程.bas

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

Attribute VB_Name = "自解压过程"
Public Declare Function SHBrowseForFolder Lib "shell32.dll" Alias "SHBrowseForFolderA" (lpBrowseInfo As BROWSEINFO) As Long
Public Declare Function SHGetPathFromIDList Lib "shell32.dll" (ByVal pidl As Long, pszPath As String) As Long
Private Declare Function VarPtrArray Lib "msvbvm60.dll" Alias "VarPtr" (ByRef Ptr() As Any) As Long
Private Declare Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" (Destination As Any, Source As Any, ByVal Length As Long)

Public Type BROWSEINFO
        hOwner   As Long
        pidlRoot   As Long
        pszDisplayName   As String
        lpszTitle   As String
        ulFlage   As Long
        lpfn   As Long
        lparam   As Long
        iImage   As Long
End Type

Type FileParameter
  FileAttr  As Byte
  FileDeep  As Byte
  FilePos   As Long
  FileLen   As Long
End Type

Type FileInform
  FileNme() As Byte
  FileParam As FileParameter
End Type

Type RePlaceCode
  DicCode(1 To 2) As Byte
  AscCode As Byte
End Type

Public List() As FileInform
Public RePlaceLim As Byte, Pro As Single, Cancel As Boolean, FileName As String
Private Const ReadLen As Long = 65535

Sub Main()
Dim FSO As New FileSystemObject, s As String
s = App.Path & "\" & App.EXEName & ".EXE"
If FSO.FileExists(s) Then
  Open s For Binary As #1
  Call GetList(1)
  Dim Path As String
  Path = ShowDir(FrmProgress.hWnd, "目标路径")
  If Path <> "" Then
    Cancel = False
    FrmProgress.Show
    Call ReleaseFile(Path, 0, 1)
  End If
End If
End Sub

Function ShowDir(MehWnd As Long, Optional Title As String) As String
Dim BI As BROWSEINFO
Dim TempID As Long
Dim TempStr As String
        
TempStr = String$(255, Chr$(0))
With BI
  .hOwner = MehWnd
  .pidlRoot = 0
  .lpszTitle = Title + Chr$(0)
  .ulFlage = &H1
End With
        
TempID = SHBrowseForFolder(BI)
        
If SHGetPathFromIDList(ByVal TempID, ByVal TempStr) Then ShowDir = Left$(TempStr, InStr(TempStr, Chr$(0)) - 1)
End Function

Sub GetList(FileNum As Integer)
On Error GoTo Err
Dim AllCount As Long, EachNameLen() As Byte
Dim ListPos As Long
Dim i As Long
Seek #FileNum, LOF(FileNum) - 3
Get #FileNum, , ListPos
Seek #FileNum, ListPos
Get #FileNum, , AllCount
ReDim List(0 To AllCount)
If AllCount > 0 Then
  ReDim EachNameLen(1 To AllCount)
  Get #FileNum, , EachNameLen
  For i = 1 To AllCount
    ReDim List(i).FileNme(0 To EachNameLen(i))
    Get #FileNum, , List(i).FileNme
    Get #FileNum, , List(i).FileParam
  Next
End If
Exit Sub
Err:
  ReDim List(0)
  Seek #FileNum, LOF(FileNum) + 1
  Put #FileNum, , LOF(FileNum)
End Sub

Sub ReleaseFile(Path As String, ListPos As Long, FileNum As Integer)
On Error GoTo Err
Dim t As FileInform, r As Folder, FSO As New FileSystemObject, Name As String
Dim k As Long
If ListPos > 0 Then
  t = List(ListPos)
  If t.FileParam.FileLen >= 0 Then
    Name = Path & "\" & StrConv(t.FileNme, vbUnicode)
    If t.FileParam.FileAttr And vbDirectory Then
      If FSO.FolderExists(Name) Then
        Set r = FSO.GetFolder(Name)
      Else
        Set r = FSO.CreateFolder(Name)
      End If
      r.Attributes = t.FileParam.FileAttr
      Call ReleaseFolder(r, ListPos, FileNum)
    Else
      If FSO.FileExists(Name) Then If MsgBox("文件已存在,是否覆盖?", vbOKCancel + vbExclamation) = vbOK Then Kill Name Else Exit Sub
      k = UnExtract(FileNum, t.FileParam.FilePos, t.FileParam.FilePos + t.FileParam.FileLen, Name)
      SetAttr Name, t.FileParam.FileAttr
    End If
  End If
Else
  Call ReleaseFolder(FSO.GetFolder(Path), ListPos, FileNum)
End If
Unload FrmProgress
Exit Sub
Err:
  Unload FrmProgress
  MsgBox "Error!"
End Sub

Sub ReleaseFolder(ParFolder As Folder, ListPos As Long, FileNum As Integer)
Dim Name As String, TListPos As Long
Dim t As FileInform, r As Folder, FSO As New FileSystemObject
Dim k As Long
TListPos = ListPos
If ListPos < UBound(List) Then
  If List(ListPos + 1).FileParam.FileDeep > List(ListPos).FileParam.FileDeep Then
    Do
      ListPos = ListPos + 1
      Do While List(ListPos).FileParam.FileLen < 0
        ListPos = ListPos + 1
        If ListPos = UBound(List) Then Exit Sub
      Loop
      t = List(ListPos)
      Name = ParFolder.Path & "\" & StrConv(t.FileNme, vbUnicode)
      If t.FileParam.FileAttr And vbDirectory Then
        If FSO.FolderExists(Name) Then
          Set r = FSO.GetFolder(Name)
        Else
          Set r = FSO.CreateFolder(Name)
        End If
        r.Attributes = t.FileParam.FileAttr
        Call ReleaseFolder(r, ListPos, FileNum)
        If Cancel Then Exit Sub
      Else
        If FSO.FileExists(Name) Then If MsgBox("文件已存在,是否覆盖?", vbOKCancel + vbExclamation) = vbOK Then Kill Name Else Exit Sub
        k = UnExtract(FileNum, t.FileParam.FilePos, t.FileParam.FilePos + t.FileParam.FileLen, Name)
        SetAttr Name, t.FileParam.FileAttr
      End If
      If ListPos = UBound(List) Then Exit Sub
    Loop Until List(ListPos + 1).FileParam.FileDeep <= List(TListPos).FileParam.FileDeep
  End If
End If
End Sub

Private Sub ClearArray(Arr() As Byte, Pos As Long)
Dim t As Long
ReDim Arr(Pos To Pos)
Call CopyMemory(t, ByVal VarPtrArray(Arr), 4)
Call CopyMemory(ByVal t + 16, 0&, 4)
End Sub

Private Sub SwapArray(a() As Byte, b() As Byte)
Dim t As Long
Call CopyMemory(t, ByVal VarPtrArray(a), 4)
Call CopyMemory(ByVal VarPtrArray(a), ByVal VarPtrArray(b), 4)
Call CopyMemory(ByVal VarPtrArray(b), t, 4)
End Sub


Private Sub UnPointCode(SouData() As Byte, DesData() As Byte)
'变量定义
Static TempData() As Byte
Dim PointCol(1 To 16383) As Integer 'int(65535/4)=16383
Dim RealLen As Long
Dim i As Long, j As Long, k As Long
Dim l As Byte, r As Long, t As Long
Dim PointPos As Long
Dim SouPos As Long, TempPos As Long
Dim TempData2() As Byte

SouPos = LBound(SouData)

If UBound(SouData) - LBound(SouData) + 1 = 0 Then
  Erase TempData
Else
  If LBound(SouData) = 1 Then
    Call ClearArray(DesData, 1)
    Call ClearArray(TempData, 1)
  End If


  l = SouData(SouPos)
  SouPos = SouPos + 1
  RealLen = SouData(SouPos) * 256& Or SouData(SouPos + 1)
  TempPos = SouPos + 2
  SouPos = TempPos + RealLen
  PointPos = SouData(SouPos) * 256& Or SouData(SouPos + 1)
  SouPos = SouPos + 2
  Call CopyMemory(PointCol(1), SouData(SouPos), PointPos * 2)
  SouPos = SouPos + 2 * PointPos

  j = UBound(TempData)
  ReDim Preserve TempData(LBound(TempData) To j + ReadLen) '初始化目标单元大小
  PointPos = 0
  For k = TempPos To TempPos + RealLen - 1
    j = j + 1
    If SouData(k) = l Then
      PointPos = PointPos + 1
      t = PointCol(PointPos) And &HFFF
      For r = 0 To (PointCol(PointPos) And &HFFFF&) \ 4096 + 3
        TempData(j + r) = TempData(j - t + r)
      Next
      j = j + r - 1
    Else
      TempData(j) = SouData(k)
    End If
  Next
    
  'ReDim Preserve TempData(LBound(TempData) To j)  '确定目标单元真实大小
'  ReDim Preserve DesData(LBound(DesData) To j)
'  Call CopyMemory(DesData(LBound(DesData)), TempData(LBound(DesData)), j - LBound(DesData) + 1)
  If j - 4095 > LBound(DesData) Then i = j - 4095 Else i = LBound(DesData)
  
  If SouPos > UBound(SouData) Then
    Call ClearArray(SouData, SouPos)
  Else
    ReDim TempData2(SouPos To UBound(SouData))
    Call CopyMemory(TempData2(SouPos), SouData(SouPos), UBound(SouData) - SouPos + 1)
    Call SwapArray(TempData2, SouData)
  End If

  k = LBound(DesData)
  If i < k Then
    Call SwapArray(TempData, DesData)
    ReDim TempData(i To j)
    Call CopyMemory(TempData(i), DesData(i), j - i + 1)
    ReDim DesData(k To j)
    Call CopyMemory(DesData(k), TempData(k), j - k + 1)
  Else
    If k > j Then
      Call ClearArray(DesData, k)
    Else
      ReDim DesData(k To j)
      Call CopyMemory(DesData(k), TempData(k), j - k + 1)
      ReDim TempData(i To j)
      Call CopyMemory(TempData(i), DesData(i), j - i + 1)
    End If
  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) '确定目标单元真实大小
    Debug.Print j - LBound(DesData) + 1
  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 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