Private Sub RARExecute(Mode As RarOperations, RarFile As String, Optional ByVal _
  Password As String)
    Dim lHandle As Long
    Dim iStatus As Integer
    Dim uRAR As RAROpenArchiveData
    Dim uHeader As RARHeaderData
    Dim sStat As String, Ret As Long
 
    uRAR.ArcName = RarFile
    uRAR.CmtBuf = Space(16384)
    uRAR.CmtBufSize = 16384
 
    If Mode = OP_LIST Then
        uRAR.OpenMode = RAR_OM_LIST
    Else
        uRAR.OpenMode = RAR_OM_EXTRACT
    End If
 
    lHandle = RAROpenArchive(uRAR)
    If uRAR.OpenResult <> 0 Then OpenError uRAR.OpenResult, RarFile
 
    If Password <> "" Then RARSetPassword lHandle, Password
 
    If (uRAR.CmtState = 1) Then MsgBox uRAR.CmtBuf, vbApplicationModal + _
      vbInformation, "Comment"
 
    iStatus = RARReadHeader(lHandle, uHeader)
    Show
    Do Until iStatus <> 0
        sStat = Left(uHeader.FileName, InStr(1, uHeader.FileName, vbNullChar) - _
          1)
        Select Case Mode
        Case RarOperations.OP_EXTRACT
 
            Ret = RARProcessFile(lHandle, RAR_EXTRACT, "" & "\", _
              uHeader.FileName)
        Case RarOperations.OP_TEST
 
            Ret = RARProcessFile(lHandle, RAR_TEST, "", uHeader.FileName)
        Case RarOperations.OP_LIST
 
            Ret = RARProcessFile(lHandle, RAR_SKIP, "", "")
        End Select
 
        If Ret = 0 Then
 
        Else
            ProcessError Ret
        End If
 
        iStatus = RARReadHeader(lHandle, uHeader)
        Refresh
    Loop
 
    If iStatus = ERAR_BAD_DATA Then Erro ("File header broken")
 
    RARCloseArchive lHandle
End Sub
Private Sub OpenError(ErroNum As Long, ArcName As String)
    Select Case ErroNum
    Case ERAR_NO_MEMORY
        Erro "Not enough memory"
    Case ERAR_EOPEN:
        Erro "Cannot open " & ArcName
    Case ERAR_BAD_ARCHIVE:
        Erro ArcName & " is not RAR archive"
    Case ERAR_BAD_DATA:
        Erro ArcName & ": archive header broken"
    End Select
End Sub
 
Private Sub ProcessError(ErroNum As Long)
    Select Case ErroNum
    Case ERAR_UNKNOWN_FORMAT
        Erro "Unknown archive format"
    Case ERAR_BAD_ARCHIVE:
        Erro "Bad volume"
    Case ERAR_ECREATE:
        Erro "File create error"
    Case ERAR_EOPEN:
        Erro "Volume open error"
    Case ERAR_ECLOSE:
        Erro "File close error"
    Case ERAR_EREAD:
        Erro "Read error"
    Case ERAR_EWRITE:
        Erro "Write error"
    Case ERAR_BAD_DATA:
        Erro "CRC error"
    End Select
End Sub
 
Private Sub Erro(Msg As String)
    MsgBox Msg, vbApplicationModal + vbExclamation, "Error"
    End
End Sub

Private Sub Form_Load()
 
Label1.Caption = "Warte auf Archive..."
' **************** Hier bitte den Pfad festlegen wo die Arschive ankommen******
A_Pfad = "C:\Test"
' **************** Hier bitte den Pfad festlegen wo die enpakten archive 
' gespeichert werden******
EA_Pfad = "C:\test\entpakte"
 
'***************** Hier wenns ein passwort gibt, eingeben, wenn nicht leer 
' lassen********
PW = ""
 
 
File1.Path = A_Pfad
File1.FileName = "*.rar"
ChDir A_Pfad
End Sub
 
Private Sub Timer1_Timer()
    If run = True Then Exit Sub
    run = True
    Dim Datei As String
    For i = 0 To File1.ListCount - 1
    Datei = File1.List(i)
 
    If Datei = "" Then Label1.Caption = "Warte auf Archive...": Exit Sub
        On Error Resume Next
        Ordner = Left(Datei, Len(Datei) - 4)
        MkDir A_Pfad & "\" & Ordner
        ChDir A_Pfad & "\" & Ordner
        On Error GoTo 0
 
        Label1.Caption = "Archive " & Datei & " wird entpackt..."
        DoEvents
        RARExecute OP_EXTRACT, A_Pfad & "\" & Datei, PW
        ChDir A_Pfad
        FileCopy A_Pfad & "\" & Datei, EA_Pfad & "\" & Datei
        Kill A_Pfad & "\" & Datei
    Next i
    File1.Refresh
    DoEvents
    Label1.Caption = "Warte auf Archive..."
    run = False
End Sub

me.hide