Imports System.Runtime.InteropServices

Public Class cCabFile
  Private Const MAX_PATH = 260

  Private mstrFileToExtract As String
  Private mstrOutputPath As String
  Private mstrOutputFile As String
  Private mlngCount As Integer

  ' Cab file to work with.
  Public CabName As String

  ' ==================================
  ' Events raised by this class.
  ' ==================================

  Public Event FileFound( _
          ByVal FileName As String, _
          ByVal DateTime As Date, _
          ByVal Size As Integer, _
          ByVal Path As String)

  Public Event BeforeExtract( _
          ByVal FileName As String, _
          ByRef Cancel As Boolean)

  Public Event AfterExtract( _
          ByVal FileName As String)

  ' ==========================================
  ' Name of the class, for error messages, and
  ' a base for user-defined error values (of
  ' which there aren't many, in this class).
  ' ==========================================

  Private Const conClass As String = "CabFile"
  Private Const conErrBase = vbObjectError + 1956

  Public Enum Errors
    errNoCabFile = conErrBase + 0
  End Enum

  Private Const conErrNoCabFile = _
   "You must set the CabName property before " & _
   "taking any action on the CabFile object."

  Private Const conErrUnknown = "Unknown error."

  ' ==================================
  ' <XMLTags>
  ' ==================================

  Private Const conXMLFile = "FILE"
  Private Const conXMLName = "NAME"
  Private Const conXMLDate = "DATE"
  Private Const conXMLSize = "SIZE"
  Private Const conXMLFullName = "FULLNAME"
  Private Const conXMLPath = "PATH"
  Private Const conXMLTop = "CABFILE"
  Private Const conXMLCabFile = "CABFILENAME"
  Private Const conXMLFileCount = "FILECOUNT"

  ' ==================================
  ' </XMLTags>
  ' ==================================

  ' Output XML string. See the GetXML method.
  Private mstrXML As String

  ' Notification messages, handled in the callback
  ' procedure. This class doesn't handle them all.

  Private Const SPFILENOTIFY_FILEINCABINET = &H11
  Private Const SPFILENOTIFY_NEEDNEWCABINET = &H12
  Private Const SPFILENOTIFY_FILEEXTRACTED = &H13

  ' Instructions sent out of the callback procedure.
  ' Tells Windows what to do next.

  Private Enum FILEOP
    FILEOP_ABORT = 0 ' Abort cabinet processing.
    FILEOP_DOIT = 1 ' Extract the current file.
    FILEOP_SKIP = 2 ' Skip the current file.
  End Enum

  ' Local enum, indicating what action to
  ' take on each pass through the callback
  ' procedure.

  Private Enum SetupIterateCabinetActions
    sicCount
    sicReport
    sicExtract
    sicGetXML
  End Enum

  ' ==================================
  ' API Declarations
  ' ==================================

  Private Const NO_ERROR = 0

  <StructLayout(LayoutKind.Sequential, CharSet:=CharSet.Unicode)>
  Private Structure FILE_IN_CABINET_INFO
    Dim NameInCabinet As String
    Dim FileSize As Integer
    Dim Win32Error As Integer
    Dim DosDate As Short
    Dim DosTime As Short
    Dim DosAttribs As Short
    <MarshalAs(UnmanagedType.ByValTStr, SizeConst:=MAX_PATH)> Dim FullTargetName As String
  End Structure

  <StructLayout(LayoutKind.Sequential, CharSet:=CharSet.Unicode)>
  Private Structure FILEPATHS
    Dim Target As String
    Dim Source As String
    Dim Win32Error As Integer
    Dim Flags As Integer
  End Structure

  Private Declare Unicode Function SetupIterateCabinet Lib "setupapi.dll" _
   Alias "SetupIterateCabinetW" (ByVal CabinetFile As String, _
   ByVal Reserved As Integer, ByVal MsgHandler As PSP_FILE_CALLBACK, _
   ByVal Context As Integer) As Boolean

  Private Delegate Function PSP_FILE_CALLBACK(ByVal Context As Integer, _
   ByVal Notification As Integer, ByVal Param1 As IntPtr, _
   ByVal Param2 As IntPtr) As Integer

  Public Function GetInfo(Optional ByVal FileToInvestigate As String = vbNullString) As Boolean
    Dim lngReturn As Integer

    ' Iterate through all the files in the cab file,
    ' raising the FileFound event for each found file.
    ' If you specify a value for FileToInvestigate,
    ' the event will only occur zero or one times.

    On Error GoTo HandleErrors

    If Strings.Len(CabName) = 0 Then
      Err.Raise(Errors.errNoCabFile, _
       conClass, fGetError(Errors.errNoCabFile))
    Else
      'Call SetCabFile(Me)
      mstrFileToExtract = FileToInvestigate

      lngReturn = SetupIterateCabinet(CabName, 0, _
       New PSP_FILE_CALLBACK(AddressOf CabinetCallback), SetupIterateCabinetActions.sicReport)
      If lngReturn = 0 Then
        '
        ' If the return value is 0, the
        ' call to SetupIterateCabinet failed.
        ' Raise the error back to the caller,
        ' and convert the error to appropriate
        ' text, if possible. fErrToText doesn't
        ' catch all possible errors, but gets
        ' many of them.
        '
        Err.Raise(Err.LastDllError, _
         conClass, fErrToText(Err.LastDllError))
      End If
    End If

    GetInfo = (lngReturn <> 0)

ExitHere:
    Exit Function

HandleErrors:
    Err.Raise(Err.Number, _
     conClass & ".GetInfo", Err.Description)
    Resume ExitHere
  End Function

  Friend Function CabinetCallback(ByVal Context As Integer, _
   ByVal Notification As Integer, ByVal Param1 As IntPtr, _
   ByVal Param2 As IntPtr) As Integer

    CabinetCallback = NO_ERROR 'затычка (чтоб всегда возвращала значение), не уверен что это правильно

    ' Callback procedure for SetupIterateCabinet. This procedure
    ' is called by a corresponding procedure in a standard module.

    On Error GoTo HandleErrors

    '
    ' Handle the callback for the CAB file.
    '
    Select Case Notification
      Case SPFILENOTIFY_NEEDNEWCABINET
        ' Not handled here.
        CabinetCallback = NO_ERROR

      Case SPFILENOTIFY_FILEEXTRACTED

        ' Copy the bytes passed into a FILEPATHS structure.
        ' Although this procedure gets a parameter of
        ' type FileCabinetInfo, you want to cast it as a
        ' FILEPATHS structure. The LSET statement does that
        ' for you. You can also use the CopyMemory API function,
        ' but this is simpler.

        Dim fp As FILEPATHS = DirectCast(Marshal.PtrToStructure(Param1, GetType(FILEPATHS)), FILEPATHS)

        If fp.Win32Error = NO_ERROR Then
          RaiseEvent AfterExtract(fp.Target)
        End If
        CabinetCallback = fp.Win32Error

      Case SPFILENOTIFY_FILEINCABINET
        Select Case Context
          Case SetupIterateCabinetActions.sicCount
            '
            ' Counting? Increment the private counter
            ' variable each time, and tell Windows
            ' to skip further processing for the file.
            '
            mlngCount = mlngCount + 1
            CabinetCallback = FILEOP.FILEOP_SKIP

          Case SetupIterateCabinetActions.sicReport
            CabinetCallback = fHandleReport(Param1)

          Case SetupIterateCabinetActions.sicGetXML
            CabinetCallback = fHandleXML(Param1)

          Case SetupIterateCabinetActions.sicExtract
            CabinetCallback = fHandleExtract(Param1)
        End Select
    End Select

NormalExit:
    Exit Function

HandleErrors:
    Err.Raise(Err.Number, conClass & ".CabCallBack", Err.Description)
    Resume NormalExit
  End Function

  Private Function fHandleReport(ByVal fici As IntPtr) As Integer
    Dim foAction As FILEOP
    Dim blnDoIt As Boolean
    Dim strFile As String = ""
    Dim ft As FILETIME
    Dim dtm As Date
    Dim strPath As String = ""
    Dim strFull As String

    ' Assume you want to keep processing.

    foAction = FILEOP.FILEOP_SKIP

    ' Assume you don't want to process the
    ' current file.

    blnDoIt = False

    ' Get the file name passed to this callback function.

    Dim fileInCabinetInfo As FILE_IN_CABINET_INFO = _
     DirectCast(Marshal.PtrToStructure(fici, GetType(FILE_IN_CABINET_INFO)), FILE_IN_CABINET_INFO)
    strFull = fileInCabinetInfo.NameInCabinet
    Call fSplitFile(strFull, strPath, strFile)

    ' If you haven't specified a file to investigate,
    ' investigate them all.

    If Strings.Len(mstrFileToExtract) = 0 Then
      blnDoIt = True
    Else

      ' Otherwise, check to see if this is the file you
      ' want extracted.

      If StrComp(strFull, mstrFileToExtract, vbTextCompare) = 0 Then

        ' If you found a match for the one file
        ' you're interested in, abort processing afterwards.

        foAction = FILEOP.FILEOP_ABORT
        blnDoIt = True
      End If
    End If

    If blnDoIt Then

      ' Retrieve the file date information.

      With fileInCabinetInfo
        Call DosDateTimeToFileTime(.DosDate, .DosTime, ft)
        dtm = fFileTimeToVBATime(ft, False)
      End With


      RaiseEvent FileFound(strFile, dtm, fileInCabinetInfo.FileSize, strPath)
    End If
    fHandleReport = CInt(foAction)
  End Function

  Private Function fHandleXML(ByVal fici As IntPtr) As Integer
    Dim foAction As FILEOP
    Dim blnCancel As Boolean
    Dim blnDoIt As Boolean
    Dim strFile As String = ""
    Dim ft As FILETIME
    Dim dtm As Date
    Dim strPath As String = ""
    Dim strFull As String

    On Error GoTo HandleErrors

    ' Assume you want to keep processing.

    foAction = FILEOP.FILEOP_SKIP

    ' Assume you don't want to process the
    ' current file.

    blnDoIt = False

    ' Get the file name passed to this callback function.

    Dim fileInCabinetInfo As FILE_IN_CABINET_INFO = _
     DirectCast(Marshal.PtrToStructure(fici, GetType(FILE_IN_CABINET_INFO)), FILE_IN_CABINET_INFO)
    strFull = fileInCabinetInfo.NameInCabinet
    Call fSplitFile(strFull, strPath, strFile)

    ' If you haven't specified a file to investigate,
    ' investigate them all.

    If Strings.Len(mstrFileToExtract) = 0 Then
      blnDoIt = True
    Else

      ' Otherwise, check to see if this is the file you
      ' want extracted.

      If StrComp(strFile, mstrFileToExtract, vbTextCompare) = 0 Then

        ' If you found a match for the one file
        ' you're interested in, abort processing
        ' afterwards.

        foAction = FILEOP.FILEOP_ABORT
        blnDoIt = True
      End If
    End If
    If blnDoIt Then

      ' Retrieve the file date information.

      With fileInCabinetInfo
        Call DosDateTimeToFileTime(.DosDate, .DosTime, ft)
        dtm = fFileTimeToVBATime(ft, False)
      End With
      mstrXML = mstrXML & _
       fBuildXMLElement( _
       fBuildXMLElement(strFull, conXMLFullName) & _
       fBuildXMLElement(strFile, conXMLName) & _
       fBuildXMLElement(CStr(dtm), conXMLDate) & _
       fBuildXMLElement(CStr(fileInCabinetInfo.FileSize), conXMLSize) & _
       fBuildXMLElement(strPath, conXMLPath), conXMLFile) & vbCrLf
    End If
    fHandleXML = CLng(foAction)

NormalExit:
    Exit Function

HandleErrors:
    Err.Raise(Err.Number, Err.Source, Err.Description)
    Resume NormalExit
  End Function

  Private Function fHandleExtract(ByVal fici As IntPtr) As Integer
    Dim foAction As FILEOP
    Dim blnCancel As Boolean
    Dim blnDoIt As Boolean
    Dim strFile As String
    Dim strPath As String = ""
    Dim strFull As String

    On Error GoTo HandleErrors

    ' Assume you want to keep processing without
    ' extracting the file.

    foAction = FILEOP.FILEOP_SKIP

    ' Assume you don't want to process the
    ' current file at all.

    blnDoIt = False

    ' Get the file that's been found in the CAB file.

    Dim fileInCabinetInfo As FILE_IN_CABINET_INFO = _
     DirectCast(Marshal.PtrToStructure(fici, GetType(FILE_IN_CABINET_INFO)), FILE_IN_CABINET_INFO)
    strFile = fileInCabinetInfo.NameInCabinet

    ' If you haven't specified a file to extract,
    ' extract them all.

    If Strings.Len(mstrFileToExtract) = 0 Then
      blnDoIt = True
    Else

      ' Otherwise, check to see if this is the file you
      ' want extracted.

      If StrComp(strFile, mstrFileToExtract, _
       vbTextCompare) = 0 Then

        ' If you found a match for the one file
        ' you're interested in, abort processing
        ' afterwards.

        blnDoIt = True
      End If
    End If

    If blnDoIt Then
      RaiseEvent BeforeExtract(strFile, blnCancel)
      If Not blnCancel Then
        strFull = fCalcOutputFile(strFile)
        Call fSplitFile(strFull, strPath, strFile)

        ' Better make sure the path exists
        ' before attempting to create the file.

        If fMakePath(strPath) Then
          strFull = fileInCabinetInfo.FullTargetName
          foAction = FILEOP.FILEOP_DOIT
        End If
      End If
    End If
    fHandleExtract = CLng(foAction)

NormalExit:
    Exit Function

HandleErrors:
    Err.Raise(Err.Number, Err.Source, Err.Description)
    Resume NormalExit
  End Function

  Private Function fErrToText(ByVal lngErr As Integer) As String
    Dim strOut As String

    ' Given a Windows error number, convert to text.
    ' Only handles the most common errors.
    Select Case lngErr
      Case 2
        strOut = "The system cannot find the file specified."
      Case 3
        strOut = "The system cannot find the path specified."
      Case 4
        strOut = "The system cannot open the file."
      Case 5
        strOut = "Access is denied."
      Case 8
        strOut = "Not enough storage is available to process this command."
      Case 13
        strOut = "Invalid data."
      Case 14
        strOut = "Not enough storage is available to complete this operation."
      Case 15
        strOut = "The system cannot find the drive specified."
      Case 19
        strOut = "The media is write protected."
      Case 20
        strOut = "The system cannot find the device specified."
      Case 21
        strOut = "The device is not ready."
      Case 23
        strOut = "Data error (cyclic redundancy check)."
      Case 25
        strOut = "The drive cannot locate a specific area or track on the disk."
      Case 26
        strOut = "The specified disk or diskette cannot be accessed."
      Case 27
        strOut = "The drive cannot find the sector requested."
      Case 29
        strOut = "The system cannot write to the specified device."
      Case 30
        strOut = "The system cannot read from the specified device."
      Case 31
        strOut = "A device attached to the system is not functioning."
      Case 32
        strOut = "The process cannot access the file because it is being used by another process."
      Case 33
        strOut = "The process cannot access the file because another process has locked a portion of the file."
      Case 39
        strOut = "The disk is full."
      Case 82
        strOut = "The directory or file cannot be created."
      Case 111
        strOut = "The file name is too long."
      Case 112
        strOut = "There is not enough space on the disk."
      Case 123
        strOut = "The filename, directory name, or volume label syntax is incorrect."
      Case Else
        strOut = "Unknown error."
    End Select
    fErrToText = strOut
  End Function

  Private Function fGetError(ByVal lngErr As Integer) As String
    Dim strOut As String
    '
    ' Return an error message for an internal error.
    ' Add more to this SELECT CASE, if you need more.
    '
    Select Case lngErr
      Case Errors.errNoCabFile
        strOut = conErrNoCabFile
      Case Else
        strOut = conErrUnknown
    End Select
    fGetError = strOut
  End Function

  Private Function fBuildXMLElement(ByVal strValue As String, _
   ByVal strTag As String, Optional ByVal strAttributeName As String = vbNullString, _
   Optional ByVal strAttributeValue As String = vbNullString) As String

    Dim strOut As String

    ' Given a piece of text ("HELLO", for example) and a tag
    ' ("VALUE", for example), return a valid XML element:
    ' <VALUE>Hello</VALUE>

    ' You can optionally specify a single attribute value.

    strOut = "<" & strTag

    If Strings.Len(strAttributeName) > 0 Then
      strOut = strOut & " " & strAttributeName & " = '" & strAttributeValue & "'"
    End If
    strOut = strOut & ">" & strValue & "</" & strTag & ">"

    fBuildXMLElement = strOut
  End Function

  Private Function fFixPath(ByVal strPath As String) As String

    ' Append a trailing "\" to a path, if necessary.

    If Strings.Right(strPath, 1) = "\" Then
      fFixPath = strPath
    Else
      fFixPath = strPath & "\"
    End If
  End Function

  Private Sub fSplitFile(ByVal strFull As String, ByRef strPath As String, _
   ByRef strFile As String)

    Dim lngPos As Integer

    ' Given a full path, parse it and return
    ' the path and file name.

    lngPos = InStrRev(strFull, "\")
    If lngPos > 0 Then
      strPath = Strings.Left(strFull, lngPos)
      strFile = Mid(strFull, lngPos + 1)
    Else
      strPath = vbNullString
      strFile = strFull
    End If
  End Sub

  Private Function fCalcOutputFile(ByVal strFileFound As String) As String
    Dim strPath As String
    Dim strFile As String

    ' strFile is the name of the file, found in the CAB file.
    ' Given the values of mstrFileToExtract, mstrOutputPath,
    ' mstrOutputFile, return the full path of the output file.
    ' If mstrFileToExtract is empty, then disregard mstrOutputFile,
    ' because you'll be extracting all the files.

    ' Calculate the output path. Either use mstrOutputPath if it
    ' exists, or the CAB file's path if it doesn't.

    If Strings.Len(mstrOutputPath) > 0 Then
      strPath = mstrOutputPath
    Else
      strPath = fGetPath(CabName)
    End If

    ' Calculate the output file name. If mstrOutputFile exists,
    ' use it. If not, use the original name of the file.

    If Strings.Len(mstrOutputFile) > 0 Then
      strFile = mstrOutputFile
    Else
      strFile = strFileFound
    End If

    fCalcOutputFile = fFixPath(strPath) & strFile
  End Function

  Private Function fGetPath(ByVal strFile As String) As String
    Dim lngPos As Integer

    ' Given a file name with a path, pull off the path part.

    lngPos = InStrRev(strFile, "\")
    If lngPos > 0 Then
      fGetPath = Strings.Left(strFile, lngPos)
    Else
      fGetPath = ""
    End If
  End Function

  Public Function fMakePath(ByVal strPath As String) As Boolean
    Dim strItems() As String
    Dim strTemp As String = ""
    Dim lngUB As Integer
    Dim lngLB As Integer
    Dim i As Integer
    Dim lngStop As Integer

    ' Create the folders in the path that was passed in.

    If Strings.Len(strPath) = 0 Then
      fMakePath = False
      GoTo NormalExit
    End If

    On Error Resume Next

    ' Attempt to create the path.
    ' If this returns no error or error 75,
    ' you're done. Otherwise, do the work.

    ' Get right of trailing "\", if it's there.

    If Strings.Right(strPath, 1) = "\" Then
      strPath = Strings.Left(strPath, Strings.Len(strPath) - 1)
    End If

    MkDir(strPath)

    Select Case Err.Number
      Case 76
        ' Path doesn't exist.
      Case 75
        ' Path exists already, get out.
        fMakePath = True
        GoTo NormalExit
      Case 0
        ' Folder created successfully.
        fMakePath = True
        GoTo NormalExit
      Case Else
        ' This shouldn't happen.
        fMakePath = False
        GoTo NormalExit
    End Select

    ' Create an array full of all the items
    ' in the path, delimited with "\".

    strItems = Split(strPath, "\")

    ' Store away the lower and upper bounds.

    lngLB = LBound(strItems)
    lngUB = UBound(strItems)

    ' You've already determined that you cannot
    ' create the path, given all the items. That is,
    ' if the path is C:\a\b\c\d\e, you know that
    ' you cannot create the path with the "e" on there.
    ' Therefore, this loop works its way backwards, looking for
    ' the longest path that either exists, or that you
    ' can create, without error.

    ' Once you've found or created a path, the rest of
    ' the code works the other direction--adds on the
    ' path items, creating folders, until you get them
    ' all created, or trigger a run-time error.

    ' You're going to loop from the next-to-last item
    ' back to the start, attempting to create
    ' or locate the path.

    lngStop = lngUB
    For lngStop = lngUB - 1 To lngLB Step -1
      Err.Clear()
      strTemp = vbNullString
      ' Build up the path to be tested.
      For i = lngLB To lngStop
        strTemp = strTemp & "\" & strItems(i)
      Next i
      ' Remove the leading "\".
      If Strings.Len(strTemp) > 1 Then
        strTemp = Mid(strTemp, 2)
      End If

      ' Attempt to create the folder.
      ' This could succeed (error 0),
      ' fail because the folder exists (error 75),
      ' or fail because some parent folder
      ' doesn't exist (error 76). If you get
      ' error 0 or 75, you're done.

      MkDir(strTemp)
      Select Case Err.Number
        Case 0, 75
          ' Path created or it exists.
          Exit For
        Case 76 ' Path wasn't found.
        Case Else
          fMakePath = False
          GoTo NormalExit
      End Select
    Next lngStop

    ' Starting where you left off when working
    ' backwards, attempt to create the folders
    ' working downwards. At any point, if you get
    ' an error, you're done.

    For i = lngStop + 1 To lngUB
      Err.Clear()
      strTemp = strTemp & "\" & strItems(i)
      MkDir(strTemp)
      If Err.Number <> 0 Then

        ' You can't create the path. Return False.

        fMakePath = False
        GoTo NormalExit
      End If
    Next i
    fMakePath = True

NormalExit:
    Exit Function
  End Function

End Class