cabfile.cls

guan yu pai ke xi tong de ruan jian

    strFull = fStringFromPointer(fici.NameInCabinet)
    Call fSplitFile(strFull, strPath, strFile)
    '
    ' If you haven't specified a file to investigate,
    ' investigate them all.
    '
    If 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_ABORT
            blnDoIt = True
        End If
    End If
    
    If blnDoIt Then
        '
        ' Retrieve the file date information.
        '
        With fici
            Call DosDateTimeToFileTime(.DosDate, .DosTime, ft)
            dtm = fFileTimeToVBATime(ft, False)
        End With
        
        
        RaiseEvent FileFound(strFile, dtm, fici.FileSize, strPath)
    End If
    fHandleReport = CLng(foAction)
End Function

Private Function fHandleXML(fici As FileInCabinetInfo) As Long
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_SKIP
    '
    ' Assume you don't want to process the
    ' current file.
    '
    blnDoIt = False
    '
    ' Get the file name passed to this callback function.
    '
    strFull = fStringFromPointer(fici.NameInCabinet)
    Call fSplitFile(strFull, strPath, strFile)
    '
    ' If you haven't specified a file to investigate,
    ' investigate them all.
    '
    If 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_ABORT
            blnDoIt = True
        End If
    End If
    If blnDoIt Then
        '
        ' Retrieve the file date information.
        '
        With fici
            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(fici.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(fici As FileInCabinetInfo) As Long
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_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.
    '
    strFile = fStringFromPointer(fici.NameInCabinet)
    '
    ' If you haven't specified a file to extract,
    ' extract them all.
    '
    If 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
                Call pCopyStringToArray(fici.FullTargetName, strFull)
                foAction = 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 fSysTimeToVBATime(stSysTime As SYSTEMTIME) As Date
    '
    ' Converts Windows SYSTEMTIME to VBA date/time.
    '
    ' Consrtuct a VBA date/time value using the
    ' DateSerial and TimeSerial functions.
    '
    With stSysTime
        fSysTimeToVBATime = DateSerial(.intYear, .intMonth, .intDay) + _
                        TimeSerial(.intHour, .intMinute, .intSecond)
    End With
End Function

Private Function fFileTimeToVBATime(ftFileTime As FILETIME, _
 Optional fLocal As Boolean = True) As Date

Dim stSystem        As SYSTEMTIME
Dim ftLocalFileTime As FILETIME
    '
    ' Converts Windows FILETIME date/time value to VBA.
    '
    ' If the user wants local time, convert the file
    ' time to local file time.
    '
    If fLocal Then
        Call FileTimeToLocalFileTime(ftFileTime, ftLocalFileTime)
        ftFileTime = ftLocalFileTime
    End If
    '
    ' Convert the file time to system time then
    ' call our own function to convert to VBA time
    '
    If CBool(FileTimeToSystemTime(ftFileTime, stSystem)) Then
        fFileTimeToVBATime = fSysTimeToVBATime(stSystem)
    End If
End Function

Private Function fStringFromPointer(ByVal ptr As Long) As String
Dim lngLen   As Long
Dim strBuffer As String
    '
    ' Given a string pointer, copy the value
    ' of the string into a new, safe location.
    '
    lngLen = lstrlen(ptr)
    strBuffer = Space(lngLen)
    Call CopyMemory(ByVal strBuffer, ByVal ptr, lngLen)
    fStringFromPointer = strBuffer
End Function

Private Sub pCopyStringToArray(bytArray() As Byte, strValue As String)
Dim i         As Long
Dim bytTemp() As Byte
    '
    ' bytArray is a fixed-sized array of bytes.
    ' You can't copy text directly into a fixed-
    ' sized array, but you can do it directly
    ' into a dynamic array. Therefore, copy
    ' the string into a dynamic array, and then
    ' copy it byte-for-byte into the fixed array.
    '
    ' Convert to ANSI, in a byte array.
    '
    bytTemp = StrConv(strValue, vbFromUnicode)
    '
    ' Copy the byte array to the output location.
    '
    For i = LBound(bytTemp) To UBound(bytTemp)
        bytArray(i + 1) = bytTemp(i)
    Next i
    '
    ' Tack on the extra null character.
    '
    bytArray(i + 1) = 0
End Sub

Private Function fCalcOutputFile(strFileFound As String) As String
Dim strPath As String
Dim strFile As String
Dim strOut  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 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 Len(mstrOutputFile) > 0 Then
        strFile = mstrOutputFile
    Else
        strFile = strFileFound
    End If
    
    fCalcOutputFile = fFixPath(strPath) & strFile
End Function

Private Function fGetPath(strFile As String) As String
Dim lngPos As Long
    '
    ' Given a file name with a path, pull off the path part.
    '
    
    lngPos = InStrRev(strFile, "\")
    If lngPos > 0 Then
        fGetPath = Left$(strFile, lngPos)
    Else
        fGetPath = ""
    End If
End Function

Private Function fErrToText(lngErr As Long) 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(lngErr As Long) 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 errNoCabFile
            strOut = conErrNoCabFile
        Case Else
            strOut = conErrUnknown
    End Select
    fGetError = strOut
End Function

Private Function fBuildXMLElement(strValue As String, _
        strTag As String, Optional strAttributeName As String, _
        Optional strAttributeValue As String) 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 Len(strAttributeName) > 0 Then
        strOut = strOut & " " & strAttributeName & " = '" & strAttributeValue & "'"
    End If
    strOut = strOut & ">" & strValue & "</" & strTag & ">"
    
    fBuildXMLElement = strOut
End Function