1

Тема: Работаем с архивами

Разархивирование RAR

Option Explicit
 
Private Type RARHeaderData
    ArcName As String * 260
    FileName As String * 260
    Flags As Long
    PackSize As Long
    UnpSize As Long
    HostOS As Long
    FileCRC As Long
    FileTime As Long
    UnpVer As Long
    Method As Long
    FileAttr As Long
    CmtBuf As String
    CmtBufSize As Long
    CmtSize As Long
    CmtState As Long
End Type
 
Private Type RAROpenArchiveData
    ArcName As String
    OpenMode As Long
    OpenResult As Long
    CmtBuf As String
    CmtBufSize As Long
    CmtSize As Long
    CmtState As Long
End Type
 
Private Declare Function RAROpenArchive Lib "unrar.dll" (ArcData As RAROpenArchiveData) As Long
Private Declare Function RARReadHeader Lib "unrar.dll" (ByVal hArcData As Long, HeaderData As RARHeaderData) As Long
Private Declare Function RARProcessFile Lib "unrar.dll" (ByVal hArcData As Long, ByVal Operation As Long, _
ByVal DestPath As String, ByVal DestName As String) As Long
 
Private Declare Function RARCloseArchive Lib "unrar.dll" (ByVal hArcData As Long) As Long
Private Declare Sub RARSetChangeVolProc Lib "unrar.dll" (ByVal hArcData As Long, ByVal lpfChangeVolProc As Long)
Private Declare Sub RARSetProcessDataProc Lib "unrar.dll" (ByVal hArcData As Long, ByVal lpfProcessDataProc As Long)
Private Declare Sub RARSetPassword Lib "unrar.dll" (ByVal hArcData As Long, ByVal Password As String)
 
Const RAR_HDR_READ_OK = 0
Const ERAR_BAD_DATA = 12
Const RAR_EXTRACT = 2
Const RAR_OM_EXTRACT = 1
 
'// ADDED
'// Converts strings from Unicode to OEM encoding to make sure
'// certain characters in paths are handled properly by RARProcessFile
Private Declare Sub CharToOem Lib "user32" Alias "CharToOemA" _
(ByVal StrFrom As String, ByVal StrTo As String)
 
 
 
Public Function ExtractArchive(sArchive As String, Optional ByVal sDestPath As String, Optional sPassword As String) As Boolean
    ' Description:-
    ' Extract file(s) from RAR archive.
    ' Parameters:-
    ' Mode = Operation to perform on RAR Archive
    ' RARFile = RAR Archive filename
    ' sPassword = Password (Optional)
    Dim lHandle As Long
    Dim iStatus As Integer
    Dim uRAR As RAROpenArchiveData
    Dim uHeader As RARHeaderData
    Dim sFile As String, lRet As Long
 
    'Преобразование кодировки
    CharToOem sDestPath, sDestPath
 
    uRAR.ArcName = sArchive
    uRAR.CmtBuf = Space(16384)
    uRAR.CmtBufSize = 16384
    uRAR.OpenMode = RAR_OM_EXTRACT
 
 
    lHandle = RAROpenArchive(uRAR)
    If uRAR.OpenResult = 0 Then
        If sPassword <> vbNullString Then RARSetPassword lHandle, sPassword
        If (uRAR.CmtState = 1) Then MsgBox uRAR.CmtBuf, vbApplicationModal + vbInformation, "Comment"
        iStatus = RARReadHeader(lHandle, uHeader)
 
        Do Until iStatus <> 0
            sFile = Left(uHeader.FileName, InStr(1, uHeader.FileName, vbNullChar) - 1)
 
            lRet = RARProcessFile(lHandle, RAR_EXTRACT, vbNullString, sDestPath & sFile)
 
            iStatus = RARReadHeader(lHandle, uHeader)
 
        Loop
 
        If iStatus = ERAR_BAD_DATA Then MsgBox ("File header broken")
 
        RARCloseArchive lHandle
    End If
End Function