树表操作.bas

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

Attribute VB_Name = "树表操作"
Option Explicit

Public List() As FileInform

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

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

Public 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

Public Sub ListToTree(Tree As Nodes, Picture As PictureBox, ImageList As ImageList)
On Error GoTo Err
Dim i As Long
Dim p As FileInform, q As Node
Dim Pic As String, Relative As Byte
Dim s As String
For i = 1 To UBound(List)
  If List(i).FileParam.FileLen >= 0 Then
    p = List(i)
    s = StrConv(p.FileNme, vbUnicode)
    If p.FileParam.FileAttr And vbDirectory Then Pic = "Directory" Else Pic = AddIcon(s, Picture, ImageList)
    Set q = Tree.Add(Tree.Item(1), tvwChild, "DS" & i, s, Pic)
    q.Tag = i
    Exit For
  End If
Next
For i = i + 1 To UBound(List)
  If List(i).FileParam.FileLen >= 0 Then
    If List(i).FileParam.FileDeep > p.FileParam.FileDeep Then
      Relative = tvwChild
    Else
      Relative = tvwNext
      Do Until List(i).FileParam.FileDeep = List(q.Tag).FileParam.FileDeep
        Set q = q.Parent
      Loop
    End If
    p = List(i)
    s = StrConv(p.FileNme, vbUnicode)
    If p.FileParam.FileAttr And vbDirectory Then Pic = "Directory" Else Pic = AddIcon(s, Picture, ImageList)
    Set q = Tree.Add(q, Relative, "DS" & i, s, Pic)
    q.Tag = i
  End If
Next
Err:
End Sub

Public Sub AddFolder(Path As String, Tree As Nodes, TreePos As Node, FileNum As Integer)
Dim FSO As New Scripting.FileSystemObject, RootFolder As Folder
Dim i As Long, j As Long, k As Long, l As Long, TName() As Byte
Dim NewList() As FileInform
Set RootFolder = FSO.GetFolder(Path)

ReDim Preserve List(0 To Tree.Count)

i = TreePos.Tag
If i = 0 Then
  j = 0
Else
  j = List(i).FileParam.FileDeep - 1
  If List(i).FileParam.FileAttr And vbDirectory Then If MsgBox("选中项为文件夹,选""是""将文件添加至子目录,选""否""将文件添加至当前目录", vbYesNo) = vbYes Then j = List(i).FileParam.FileDeep
End If
i = i + 1
Do Until List(i - 1).FileParam.FileDeep <= j
  i = i - 1
Loop

Seek #FileNum, LOF(FileNum) - 3
Get #FileNum, , k
Seek #FileNum, k
ReDim NewList(0)
Call AddFolderPro(RootFolder, NewList, 0, j + 2, FileNum)

Unload FrmProgress

ReDim Preserve List(0 To Tree.Count + UBound(NewList))
For k = Tree.Count - 1 To i Step -1
  List(k + UBound(NewList) + 1) = List(k)
Next

TName = StrConv(RootFolder.Name, vbFromUnicode)
If UBound(TName) > 255 Then ReDim Preserve TName(0 To 255)
List(i).FileNme = TName
List(i).FileParam.FileAttr = RootFolder.Attributes
List(i).FileParam.FileDeep = j + 1

For k = 1 To UBound(NewList)
  List(i + k) = NewList(k)
Next

l = Seek(FileNum)
Put #FileNum, , CLng(UBound(List))
For k = 1 To UBound(List)
  Put #FileNum, , CByte(UBound(List(k).FileNme))
Next
For k = 1 To UBound(List)
  Put #FileNum, , List(k).FileNme
  Put #FileNum, , List(k).FileParam
Next
Put #FileNum, , l

End Sub

Public Sub AddFolderPro(ParFolder As Folder, List() As FileInform, ListPos As Long, Deep As Byte, FileNum As Integer)
Dim EachFolder As Folder, EachFile As File
Dim i As Long, k As Long, TName() As Byte
ReDim Preserve List(0 To UBound(List) + ParFolder.SubFolders.Count + ParFolder.Files.Count)
For Each EachFolder In ParFolder.SubFolders
  If Cancel Then Exit Sub
  TName = StrConv(EachFolder.Name, vbFromUnicode)
  If UBound(TName) > 255 Then ReDim Preserve TName(0 To 255)
  ListPos = ListPos + 1
  List(ListPos).FileNme = TName
  List(ListPos).FileParam.FileAttr = EachFolder.Attributes
  List(ListPos).FileParam.FileDeep = Deep

  Call AddFolderPro(EachFolder, List, ListPos, Deep + 1, FileNum)
Next

For Each EachFile In ParFolder.Files
  If Cancel Then
    ReDim Preserve List(0 To ListPos - 1)
    Exit Sub
  End If

  TName = StrConv(EachFile.Name, vbFromUnicode)
  If UBound(TName) > 255 Then ReDim Preserve TName(0 To 255)
  ListPos = ListPos + 1
  List(ListPos).FileNme = TName
  List(ListPos).FileParam.FileAttr = EachFile.Attributes
  List(ListPos).FileParam.FileDeep = Deep

  List(ListPos).FileParam.FilePos = Seek(FileNum)
  k = Extract(EachFile.Path, FileNum, Seek(FileNum))
  List(ListPos).FileParam.FileLen = k - List(ListPos).FileParam.FilePos
Next
End Sub

Public Sub AddFile(File As File, Tree As Nodes, TreePos As Node, FileNum As Integer)
Dim i As Long, j As Long, k As Long, l As Long, t As Node, TName() As Byte
'ReDim Preserve List(0 To Tree.Count)
i = TreePos.Tag
If i = 0 Then
  j = 0
Else
  j = List(i).FileParam.FileDeep - 1
  If List(i).FileParam.FileAttr And vbDirectory Then If MsgBox("选中项为文件夹,选""是""将文件添加至子目录,选""否""将文件添加至当前目录", vbYesNo) = vbYes Then j = List(i).FileParam.FileDeep
End If
Do
  i = i + 1
  If i > UBound(List) Then ReDim Preserve List(0 To i)
Loop Until List(i).FileParam.FileDeep <= j
For k = Tree.Count - 1 To i Step -1
  List(k + 1) = List(k)
Next
TName = StrConv(File.Name, vbFromUnicode)
If UBound(TName) > 255 Then ReDim Preserve TName(0 To 255)
List(i).FileNme = TName
List(i).FileParam.FileAttr = File.Attributes
List(i).FileParam.FileDeep = j + 1
Seek #FileNum, LOF(FileNum) - 3
Get #FileNum, , j
List(i).FileParam.FilePos = j
l = Extract(File.Path, FileNum, j)
Unload FrmProgress
If Cancel Then List(i).FileParam.FileLen = -1 Else List(i).FileParam.FileLen = l - j
Put #FileNum, , CLng(Tree.Count)
For k = 1 To Tree.Count
  Put #FileNum, , CByte(UBound(List(k).FileNme))
Next
For k = 1 To Tree.Count
  Put #FileNum, , List(k).FileNme
  Put #FileNum, , List(k).FileParam
Next
Put #FileNum, , l
End Sub

Public Sub RemoveFile(TreePos As Node, FileNum As Integer)
Dim i As Long, j As Long
i = TreePos.Tag
j = List(i).FileParam.FileDeep
If i > 0 Then List(i).FileParam.FileLen = -1
For i = i + 1 To UBound(List)
  If List(i).FileParam.FileDeep > j Then
    List(i).FileParam.FileLen = -1
  Else
    Exit For
  End If
Next
Seek #FileNum, LOF(FileNum) - 3
Get #FileNum, , j
Seek #FileNum, j
Put #FileNum, , CLng(UBound(List))
For i = 1 To UBound(List)
  Put #FileNum, , CByte(UBound(List(i).FileNme))
Next
For i = 1 To UBound(List)
  Put #FileNum, , List(i).FileNme
  Put #FileNum, , List(i).FileParam
Next
End Sub

Public Sub ReleaseFile(Path As String, TreePos As Node, 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 TreePos.Tag > 0 Then
  t = List(TreePos.Tag)
  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, TreePos, 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
Else
  Call ReleaseFolder(FSO.GetFolder(Path), TreePos, FileNum)
End If
Unload FrmProgress
Exit Sub
Err:
  Unload FrmProgress
  MsgBox "Error!"
End Sub

Public Sub ReleaseFolder(ParFolder As Folder, TreePos As Node, FileNum As Integer)
Dim EachNode As Node, Name As String
Dim t As FileInform, r As Folder, FSO As New FileSystemObject
Dim k As Long
If TreePos.Children > 0 Then
  Set EachNode = TreePos.Child
  Do
    t = List(EachNode.Tag)
    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, EachNode, 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
    Set EachNode = EachNode.Next
  Loop Until EachNode Is Nothing
End If
End Sub

Public Sub ReSave(Path As String, SouFileNum As Integer)
Const n = 65535
Dim DesFileNum As Integer, NewList() As FileInform
Dim Data() As Byte
Dim i As Long, j As Long, k As Long, l As Long
DesFileNum = FreeFile
Open Path For Binary As #DesFileNum
Seek #DesFileNum, LOF(DesFileNum) + 1
ReDim NewList(0 To UBound(List))
For i = 1 To UBound(List)
  If List(i).FileParam.FileLen >= 0 Then
    j = j + 1
    NewList(j) = List(i)
    If List(i).FileParam.FilePos > 0 Then
      FileName = StrConv(List(i).FileNme, vbUnicode)
      NewList(j).FileParam.FilePos = Seek(DesFileNum)
      Seek #SouFileNum, List(i).FileParam.FilePos
      ReDim Data(1 To n)
      For k = 1 To List(i).FileParam.FileLen \ n
        If Cancel Then
          Close #DesFileNum
          Unload FrmProgress
          Exit Sub
        End If
        Get #SouFileNum, , Data
        Put #DesFileNum, , Data
      Next
      If List(i).FileParam.FileLen Mod n > 0 Then
        ReDim Data(1 To List(i).FileParam.FileLen Mod n)
        Get #SouFileNum, , Data
        Put #DesFileNum, , Data
      End If
    End If
  End If
Next
ReDim Preserve NewList(j)
l = Seek(DesFileNum)
Put #DesFileNum, , CLng(UBound(NewList))
For k = 1 To UBound(NewList)
  Put #DesFileNum, , CByte(UBound(NewList(k).FileNme))
Next
For k = 1 To UBound(NewList)
  Put #DesFileNum, , NewList(k).FileNme
  Put #DesFileNum, , NewList(k).FileParam
Next
Put #DesFileNum, , l
Close #DesFileNum
Unload FrmProgress
End Sub