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