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
