form1.frm

打包文件

VERSION 5.00
Object = "{831FDD16-0C5C-11D2-A9FC-0000F8754DA1}#2.0#0"; "MSCOMCTL.OCX"
Begin VB.Form Form1 
   BorderStyle     =   1  'Fixed Single
   Caption         =   "Self Extractor"
   ClientHeight    =   1365
   ClientLeft      =   45
   ClientTop       =   330
   ClientWidth     =   4965
   Icon            =   "Form1.frx":0000
   LinkTopic       =   "Form1"
   MaxButton       =   0   'False
   MinButton       =   0   'False
   ScaleHeight     =   1365
   ScaleWidth      =   4965
   StartUpPosition =   3  'Windows Default
   Begin MSComctlLib.ProgressBar PG 
      Align           =   2  'Align Bottom
      Height          =   375
      Left            =   0
      TabIndex        =   7
      Top             =   990
      Visible         =   0   'False
      Width           =   4965
      _ExtentX        =   8758
      _ExtentY        =   661
      _Version        =   393216
      Appearance      =   1
      Scrolling       =   1
   End
   Begin VB.ListBox Coll 
      Height          =   450
      Left            =   1920
      TabIndex        =   6
      Top             =   1200
      Visible         =   0   'False
      Width           =   1215
   End
   Begin VB.CommandButton Command2 
      Caption         =   "Cancel"
      Height          =   375
      Left            =   3720
      TabIndex        =   3
      Top             =   600
      Width           =   1215
   End
   Begin VB.TextBox Text1 
      Height          =   405
      Left            =   840
      TabIndex        =   1
      Top             =   600
      Width           =   2775
   End
   Begin VB.CommandButton Command1 
      Caption         =   "Extract"
      Height          =   375
      Left            =   3720
      TabIndex        =   0
      Top             =   120
      Width           =   1215
   End
   Begin VB.ListBox List1 
      Height          =   1620
      Left            =   0
      TabIndex        =   5
      Top             =   1080
      Visible         =   0   'False
      Width           =   4935
   End
   Begin VB.Label Status 
      Caption         =   "Idle"
      Height          =   255
      Left            =   120
      TabIndex        =   4
      Top             =   1080
      Width           =   4935
   End
   Begin VB.Image Image1 
      Height          =   480
      Left            =   120
      Picture         =   "Form1.frx":1272
      Top             =   240
      Width           =   480
   End
   Begin VB.Label Label1 
      Caption         =   "Please select the directory you wish to extract the file to, and click ""Extract"""
      Height          =   615
      Left            =   840
      TabIndex        =   2
      Top             =   120
      Width           =   2775
   End
End
Attribute VB_Name = "Form1"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = True
Attribute VB_Exposed = False
Dim FFilename As String

Private Sub Command1_Click()
Dim MyString, Direc, Position ' Position is basically my own Loc() function
On Error GoTo ErrHandler

' See if the directory they want to extract to exists
Direc = Dir(Text1.Text, vbDirectory)
If Direc = "" Then
    ' Create the Directory
    MkDir Text1.Text
End If

' Open THIS file
Open App.Path & "\" & App.EXEName & ".exe" For Binary As #1

' Disable the buttons
Command1.Enabled = False
Command2.Enabled = False
Status.Caption = "Finding key..."

' Find where the files begin
Do While Not MyString = "-=#SELFEXTRACT#=-"
    Line Input #1, MyString
Loop

For i = 0 To List1.ListCount - 1
    
    ' Just a bug fix here
    If Right(Text1.Text, 1) = "\" Then
        FFilename = Text1.Text & List1.List(i)
    Else
        FFilename = Text1.Text & "\" & List1.List(i)
    End If
    
    ' Open the destination file
    Open FFilename For Binary As #2
        Position = 0
        Status.Caption = "Extracting " & List1.List(i) & "..."
        PG.Visible = True
        PG.Max = Coll.List(i)
        
        ' Begin Extraction
        Do
            a = Coll.List(i)
            c = a - Position
            PG.Value = Position
            
            ' Check to see if the bit to be read is <= 5KB
            If c <= 5000 Then
                ' Read the data
                dat$ = dat$ & Input(c, #1)
                
                ' Decompress the data
                PG.Visible = False
                Status.Caption = "Decompressing " & List1.List(i) & "..."
                DoEvents
                dat$ = HuffmanDecode(dat$)
                PG.Visible = True
                
                ' Write the data
                Put #2, , dat$
                ' Get ready for next file (if any)
                GoTo NextOne
            Else
                ' Read the data
                dat$ = dat$ & Input(5000, #1)
                Position = Position + 5000
            End If
        Loop
    
NextOne:
    Close #2
    Status.Caption = "Extracted " & List1.List(i)
    dat$ = ""
Next i

' Extraction Complete!

PG.Visible = False
dat = ""
Close #1
MsgBox "Extraction Complete!", vbInformation, "Done"
End
Exit Sub

ErrHandler:
If Err.Number = 62 Then
    MsgBox "No data was found in this file", vbCritical, "ERROR"
Else
    MsgBox "An error has occured!" & vbNewLine & Err.Number & ": " & Err.Description, vbCritical, "ERROR"
End If
Status.Caption = "Extraction failed!"
Close #1
Close #2
Kill FFilename
End
End Sub

Private Sub Command2_Click()
End
End Sub

Private Sub Form_Load()
Dim MyString, MyString2

' If an error occurs then its not a valid file
On Error GoTo ErrHandler

' Open THIS file
Open App.Path & "\" & App.EXEName & ".exe" For Binary As #1

' Search for the string
Do While Not MyString = "-=#NOOFFILES#=-"
    Line Input #1, MyString
Loop

' Read the number of files
Line Input #1, MyString
Do While Not MyString2 = "-=#FILNAME#=-"
    Line Input #1, MyString2
Loop

' Read the filenames
For i = 1 To MyString
    Line Input #1, MyString2
    List1.AddItem MyString2
Next i
Do While Not MyString2 = "-=#LOFS#=-"
    Line Input #1, MyString2
Loop

' Read teh length of each file
For i = 1 To MyString
    Line Input #1, MyString2
    Coll.AddItem MyString2
Next i

' See if there is more than 1 file
If List1.ListCount > 1 Then
    ' Enable the listbox, so the user can see what files are in there
    Height = 3390
    List1.Visible = True
    Status.Top = 2760
    Caption = "DD's Self-Extractor - " & List1.ListCount & " files found"
Else
    Caption = "DD's Self-Extractor - " & List1.List(0)
End If

Close #1
Text1.Text = App.Path & "\" & App.EXEName & "\"
Exit Sub

ErrHandler:
MsgBox "This is not a valid Self Extractor file!", vbCritical, "ERROR"
Close #1
End
End Sub

Private Sub Form_Unload(Cancel As Integer)
' You can only quit using the Cancel BUTTON
Cancel = -1
End Sub