UnACE

Option Explicit

Private Type ACEOPENARCHIVEDATA
Arcname As Long
OpenMode As Long
OpenResult As Long
flags As Long
Host As Long
AV As String * 51
CmtBuf As Long ' sollte ein Long sein / ist in C in char *
CmtBufSize As Long
CmtSize As Long
CmtState As Long
ChangeVolProc As Long
ProcessDataProc As Long
End Type

Public Type ACEHEADERDATA
Arcname As String * 260
Filename As String * 260
flags As Long
PackSize As Long
UnpSize As Long
FileCRC As Long
FILETIME As Long
Method As Long
QUAL As Long
FileAttr As Long
CmtBuf As Long ' sollte ein Long sein / ist in C in char *
CmtBufSize As Long
CmtSize As Long
CmtState As Long
End Type

Private Type typCHANGEVOLPROC
Arcname As String
Mode As Long
End Type

Private Type typPROCESSDATAPROC
Addr As String
Size As Long
End Type

Private Const ACEERR_MEM = 1
Private Const ACEERR_FILES = 2
Private Const ACEERR_FOUND = 3
Private Const ACEERR_FULL = 4
Private Const ACEERR_OPEN = 5
Private Const ACEERR_READ = 6
Private Const ACEERR_WRITE = 7
Private Const ACEERR_CLINE = 8
Private Const ACEERR_CRC = 9
Private Const ACEERR_OTHER = 10
Private Const ACEERR_EXISTS = 11
Private Const ACEERR_END = 128
Private Const ACEERR_HANDLE = 129
Private Const ACEERR_CONSTANT = 130
Private Const ACEERR_NOPASSW = 131
Private Const ACEERR_METHOD = 132
Private Const ACEERR_USER = 255

'Const SUCCESS = 0&


Public Const ACEOPEN_LIST = 0
Private Const ACEOPEN_EXTRACT = 1

Public Const ACECMD_SKIP = 0
Private Const ACECMD_TEST = 1
Private Const ACECMD_EXTRACT = 2

Private Const ACEVOL_REQUEST = 0
Private Const ACEVOL_OPENED = 1

Private Declare Function ACEOpenArchive Lib "unACE.dll" _
(ByRef Archivedata As ACEOPENARCHIVEDATA) As Long
Public Declare Function ACEProcessFile Lib "unACE.dll" _
(ByVal hArcData As Long, _
ByVal Operation As Long, _
ByVal DestPath As String) As Long
Public Declare Function ACECloseArchive Lib "unACE.dll" _
(ByVal hArcData As Long) As Long
Public Declare Function ACEReadHeader Lib "unACE.dll" _
(ByVal hArcData As Long, _
ByRef Headerdata As ACEHEADERDATA) As Long

' dritten Parameter geändert

Public Function OpenACEArchive(sFilename As String, _
OpenMode As Long, _
ByRef bMultVolume As Boolean) As Long
Dim hArchive As Long
Dim tArchiveData As ACEOPENARCHIVEDATA
Dim ByteArray() As Byte

ReDim ByteArray(0 To Len(sFilename)) As Byte
tArchiveData.Arcname = modIni.StringToPointer(sFilename, ByteArray)
tArchiveData.OpenMode = OpenMode ' parameter statt Konstante
tArchiveData.CmtBufSize = 0
hArchive = ACEOpenArchive(tArchiveData)
If tArchiveData.OpenResult <> 0 Then
If hArchive <> 0 Then ACECloseArchive hArchive
OpenACEArchive = 0
Else
bMultVolume = CBool(tArchiveData.flags & &H800)
OpenACEArchive = hArchive
End If
End Function

Public Function UnpackACE(sFilename As String) As Boolean
Dim hArchive As Long
Dim tHeaderdata As ACEHEADERDATA
Dim sFile As String
Dim sArchive As String

Dim lMilliSeconds As Long
Dim lNumFiles As Long
Dim dblUnpackedBytes As Double ' könnte sehr viel werden, deshalb kein Long
Dim dblExtractedBytes As Double
Dim bMultVolume As Boolean

' Anzahl der Dateien bestimmen und

' Größe aller Dateien ermitteln:

frmPGress2.lblExtractPath.Caption = "Teste Archiv(e)"
frmPGress2.lblExtractPath.Refresh


If Not modACEInfo.InspectACEArchiveDLL(sFilename, lMilliSeconds, _
lNumFiles, dblUnpackedBytes, _
frmPGress2.lblArchive) Then Exit Function

frmPGress2.ccrpPGBar.Max = lNumFiles

hArchive = OpenACEArchive(sFilename, ACEOPEN_EXTRACT, bMultVolume)
If hArchive = 0 Then Exit Function

While ACEReadHeader(hArchive, tHeaderdata) = 0
sFile = modIni.LiesName(tHeaderdata.Filename)
sArchive = modIni.LiesArchiv(tHeaderdata.Arcname)

frmPGress2.lblExtractPath.Caption = "Extrahiere: " & sFile
frmPGress2.lblExtractPath.Refresh

frmPGress2.lblArchive.Caption = "Extrahiere das Archiv:" & sArchive
frmPGress2.lblArchive.Refresh

glRet = ACEProcessFile(hArchive, ACECMD_EXTRACT, gsExtractPfad & "\")
If glRet <> 0 Then
If glRet = ACEERR_WRITE Then
MsgBox "Konnte Datei nicht auf Festplatte schreiben!", vbCritical
ACECloseArchive hArchive
Exit Function
End If

If glRet = ACEERR_CRC Then
MsgBox "Datei " & sFile & " Crc-Error.", _
vbInformation + vbOKOnly
End If
End If

If tHeaderdata.FileAttr <> vbDirectory Then
If frmPGress2.ccrpPGBar.Value < frmPGress2.ccrpPGBar.Max Then
frmPGress2.ccrpPGBar.Value = frmPGress2.ccrpPGBar.Value + 1
End If

dblExtractedBytes = dblExtractedBytes + tHeaderdata.UnpSize
If frmPGress2.ccrpPGBar2.Value < frmPGress2.ccrpPGBar2.Max Then
frmPGress2.ccrpPGBar2.Value = CInt((dblExtractedBytes * 100#) / dblUnpackedBytes) 'advance the progress bar as the file is copied
End If
End If

DoEvents ' DoEvents wird zumindest 1 mal benötigt sonst läuft die Animierte Glasuhr nicht mehr
Wend
ACECloseArchive hArchive
End Function

###################################################################
Copyright Emil Weiss
für Testzwecke freigestellt
emil.weiss@koeln.netsurf.de
http://koeln.netsurf.de/~emil.weiss (Only IE4 or later)
###################################################################