VB解压缩与压缩

Call RARExtract("Extract", frmSource.txtOpenRar.Text, frmSource.txtOutputPath.Text, frmSource.txtPassword.Text) 'runs extraction function

Function RARExtract(ByVal ReqdFunction As String, ByVal sRARArchive As String, Optional ByVal sDestPath As String, Optional ByVal sPassword As String, Optional ByVal ReqdFolder) As Integer

' Description:-
' Exrtact file(s) from RAR archive.

' Parameters:-
' sRARArchive   = RAR Archive filename
' sDestPath     = Destination path for extracted file(s)
' sPassword     = Password [OPTIONAL]

' Returns:-
' Integer       = 0  Failed (no files, incorrect PW etc)
'                 -1 Failed to open RAR archive
'                 >0 Number of files extracted
   
Dim lHandle As Long
Dim lStatus As Long
Dim uRAR As RAROpenArchiveData
Dim uHeader As RARHeaderData
Dim Ret As Long 'if not used, it only shows two items in the list
Dim sStat As String ' the filename
'Dim FunctionToPerform As String ' extra, allows the archive to be tested for number of files

Dim TheIcon As Integer

Dim PropFilename As String
Dim PropRAWFileDate As String
Dim PropFlags As String
Dim PropPassword As Integer
Dim PropFolder As String
Dim PropComment As String
Dim TotalUnpacked As Double
Dim PropCarriesOn As Boolean

Dim path As String

'PropComment = uHeader.flags And &H8
'MsgBox PropComment

If Mid(sRARArchive, Len(sRARArchive) - 3, 4) <> ".rar" Then 'if the ext on fullpathtorar is .rar
    MsgBox "You have bypassed the 'select only Rar Archive' function, you cheeky monkey!" & vbCrLf & vbCrLf & "But I am smart and knew you would try!", vbExclamation + vbOKOnly, "Not a Rar Archive"
    Exit Function
End If

'displaying comments by frozenpea of vbcity.com
uRAR.CmtBuf = Space(16384)
uRAR.CmtBufSize = 16384

'Dim PropFileComp As Double
    RARExtract = -1
   
    ' Open the RAR

    uRAR.ArcName = sRARArchive
    uRAR.OpenMode = RAR_OM_EXTRACT
    lHandle = RAROpenArchive(uRAR) 'RAROpen(uRAR)

CorruptFile = False
    ' Failed to open RAR ?
   

        If uRAR.OpenResult <> 0 Then
            GoTo ErrDefs
            'MsgBox "Corrupt File", vbCritical + vbOKOnly
            'CorruptFile = True
            'Exit Function
        End If
   
    ' Password ?
   
    If sPassword <> "" Then
        RARSetPassword lHandle, sPassword
    End If
   
    ' Extract file(s)...
   
    iFileCount = 0
    iFolderCount = 0
    ' Is there at lease one archived file to extract ?
    lStatus = RARReadHeader(lHandle, uHeader) 'RARReadHdr(lHandle, uHeader)

 

'/
'TotalUnpacked = 0
    Do Until lStatus <> 0
    DoEvents ' keep it responsive
        If StopProcessing = True Then
            frmProgress.lblProcessingFile.Caption = "Stopping. Please be patient"
            Exit Do 'exit loop early
        End If

        If ReqdFunction = "Extract" Then
            'Process (extract) the current file within the archive

          
            If RARProcessFile(lHandle, RAR_EXTRACT, "", sDestPath + uHeader.FileName) = 0 Then
                Debug.Print uHeader.flags And &H1
               
                'Checks to see if the archive spans volumes, if it does, the size is reported wrongly (size*no of volumes wrongly)
                'if it does span volumes, don't count the size
                PropCarriesOn = uHeader.flags And &H1
                If PropCarriesOn = True Then
                    'do nothing
                Else
                    TotalUnpacked = TotalUnpacked + uHeader.UnpSize 'how much data has been currently extracted
                    ExtractedObjects = ExtractedObjects + 1
                End If
                '/// progress bar code
                With frmProgress
                        .lblProcessingFile = (Left(uHeader.FileName, InStr(1, uHeader.FileName, vbNullChar) - 1))
                    If TotalArchiveSize <> 0 Then 'if its 0, will cause an error + if its 0, the archive unpacked is 0 which is daft
                        .lblProgress.Caption = CInt((TotalUnpacked / TotalArchiveSize) * 100) & " %" 'change %age text
                        .lblFileNumber.Caption = ExtractedObjects & " / " & ArchiveObjects
                        'frmOutput.Refresh 'needed to show the value thoughout process
                        .ProgressBar1.Max = TotalArchiveSize 'set progressbar to 100 max
                        .ProgressBar1.Value = TotalUnpacked ' advance the progressbar to how much has been unpacked
                        .ProgressBar2.Max = ArchiveObjects
                        .ProgressBar2.Value = ExtractedObjects
                    Else
                        .ProgressBar1 = 100
                        .lblProgress = "100 %"
                       
                    End If
                End With
               
                ' Is there another archived file in this RAR ?
                lStatus = RARReadHeader(lHandle, uHeader) 'generates a code, the Defs are at the top.Allows exiting of loop 'RARReadHdr(lHandle, uHeader)
           
            'below code checks if there is an error and exits the function
            'IMPORTANT needs to be last otherwise it exits prematurely
            ElseIf RARProcessFile(lHandle, RAR_EXTRACT, "", sDestPath + uHeader.FileName) <> 0 Then 'extracts the rar archive  'RARProcFile(lHandle, RAR_EXTRACT, "", sDestPath + uHeader.FileName) = 0 Then
                Debug.Print RARProcessFile(lHandle, RAR_EXTRACT, "", sDestPath + uHeader.FileName)
                MsgBox "Unexpected end of archive", vbExclamation, "Error"
                RARCloseArchive lHandle 'close archive
                Exit Function
            End If
'/
        ElseIf ReqdFunction = "ObtainList" Then
        'list file code
       

            sStat = Left(uHeader.FileName, InStr(1, uHeader.FileName, vbNullChar) - 1) 'allows listbox to have more than set of data. sStat is the data for listbox
            PropFlags = uHeader.flags
           
           
           
            PropPassword = uHeader.flags And &H400 ' the password flag
            If PropPassword = 0 Then
                PropPassword = 0
            ElseIf PropPassword > 0 Then 'check for password flag
                PropPassword = 3 ' if the flag is set to true tell the user
                PasswordStatus = True
           
            End If
           
            PropFolder = uHeader.flags And &HE0
           
            'places the items in the archive into the listview and gives them their proper icon
            If PropFolder = &HE0 Then 'folder flag
                TheIcon = PropPassword + 2
            Else
                TheIcon = PropPassword + 1
            End If
           
            'checks to see if it is a toplevel folder. Prevents errors with long ass path code
            If InStr(1, sStat, "/") = 0 Then
           
                Set Lisx = frmSource.ListView.ListItems.Add(, , sStat, TheIcon, TheIcon)
            Else
                Set Lisx = frmSource.ListView.ListItems.Add(, , Right(sStat, InStr(1, StrReverse(sStat), "/") - 1), TheIcon, TheIcon)
               
            End If
                'fill the listboxes properties up
                Lisx.SubItems(1) = FilesSize(uHeader.PackSize)
                Lisx.SubItems(2) = FilesSize(uHeader.UnpSize)
                Lisx.SubItems(3) = ProcessDate(uHeader.FileTime)
                Lisx.SubItems(4) = Hex(uHeader.FileCRC)
                'checks to see if the object is a toplevel folder or not
                path = Left(sStat, InStr(1, sStat, Right(sStat, InStr(1, StrReverse(sStat), "/"))))
                If Len(path) = 1 Then path = ""
                Lisx.SubItems(5) = path

           
            Debug.Print "Carries on from before:"; PropFlags And &H1
           
            PropCarriesOn = PropFlags And &H1
            If PropCarriesOn = True Then
                'do not add the file size to the total size
            Else
                TotalArchiveSize = TotalArchiveSize + uHeader.UnpSize 'calculate uncompressed size
                ArchiveObjects = ArchiveObjects + 1
            End If
           
            Ret = RARProcessFile(lHandle, RAR_SKIP, "", "")
            'FilesInArchive.List1.List(FilesInArchive.List1.ListCount - 1) = FilesInArchive.List1.List(FilesInArchive.List1.ListCount - 1)

            lStatus = RARReadHeader(lHandle, uHeader) 'SCROLLS THROUTH THE LIST & gereates a code, defs are at top. Allows exiting of loop
           
            frmSource.ListView.View = lvwReport
           
            'expands the main node
            'frmSource.ListView.ListItems.Item(1).Expanded = True
        End If
'/

 '///
    Loop

If ReqdFunction = "ObtainList" Then
'shows the comment if needed
    Debug.Print "Comment:"; uRAR.CmtState
    If uRAR.CmtState = 1 Then 'there is an archive comment so display it
        ArchiveComment = uRAR.CmtBuf
        'MsgBox ArchiveComment, vbOKOnly, "Archive Comment"
    Else 'there isn't a comment so clear the "buffer"
        ArchiveComment = ""
    End If
End If

'filenames are encrypted?
        If lStatus = 21 Then
            MsgBox "Filenames encrypted. To see the filenames, enter a password in the 'Password' box" _
            & vbCrLf & vbCrLf & "then click on the 'Reload Archive Data' button at the bottom of window ", vbInformation + vbOKOnly
            PasswordStatus = True
        End If
    ' Close the RAR
    RARCloseArchive lHandle 'RARClose lHandle

    ' Return

    RARExtract = iFileCount

If PasswordStatus = True Then
    'bottom lines enables the password field
    frmSource.txtPassword.Visible = True
    frmSource.lblpassword.Visible = True
    frmSource.btnPasswordHelp.Visible = True
    frmSource.btnReload.Enabled = True
    'frmSource.txtPassword.BackColor = vbWhite
End If

   
Exit Function

ErrDefs:
Select Case uRAR.OpenResult
    Case 10
        MsgBox "Unexpected End of Archive", vbExclamation + vbOKOnly, "Error code 10"
    Case 11
        MsgBox "Not enough memory to open the archive", vbOKOnly + vbExclamation, "Error code 11"
    Case 12
        MsgBox "The archive header corrupt or damaged", vbOKOnly + vbCritical, "Error code 12"
        CorruptFile = True
   
    Case 13
        MsgBox "The archive is corrupt or damaged", vbOKOnly + vbCritical, "Error code 13"
        CorruptFile = True
    Case 14
        MsgBox "The Comment is in an unknown format", vbExclamation + vbOKOnly, "Error code 14"
    Case 15
        MsgBox "There was an error that occured when the archive was opened", vbOKOnly + vbCritical, "Error code 15"
    Case 16
        MsgBox "There was an error when the file was created", vbCritical + vbOKOnly, "Error code 16"
    Case 17
        MsgBox "There was an error closing the archive meaning it is still in the memory. Please terminate the De-rar.exe process to claim this memory space back", vbCritical + vbOKOnly, "Error code 17"
End Select

RARCloseArchive lHandle 'close archive

End Function