xzipdemo.bas

开发工具是vc

Attribute VB_Name = "XZIPDEMO1"
Option Explicit

' Variable to communicate to the ExtractDialog form

Public ExtractDialogCanceled As Boolean

' Constants to determine characteristics of Zip Open Dialog

Public Const OpenZip = 0
Public Const NewZip = 1
Public Const TestZip = 2
Public Const FixZip = 3
Public Const DeleteZip = 4
Public Const SelectBin = 5

' Constants to determine command executed by ExecuteSelFilesCmd

Public Const SF_Delete = 0
Public Const SF_Extract = 1

' This function counts the number of files in the list of files
' of the type returned by the SelectFilesToProcess function.

Public Function CountFilesInList(ByVal FileList As String) As Integer

   Dim Count As Integer
   Dim Pos As Integer
   
   Count = 0
   For Pos = 1 To Len(FileList)
      If Mid$(FileList, Pos, 1) = Chr(0) Then Count = Count + 1
   Next Pos
   
   If Count = 0 Then Count = 1
   
   CountFilesInList = Count

End Function


' This function takes a list of files of the type that is returned by
' the SelectFilesToProcess function, and returns a single file (with
' pathname).

Public Function GetFileFromList(ByVal FileList As String, FileNumber As Integer) As String

   Dim Pos As Integer
   Dim Count As Integer
   Dim FNStart As Integer
   Dim FNLen As Integer
   Dim Path As String

   If InStr(FileList, Chr(0)) = 0 Then
      GetFileFromList = FileList
   Else
      Count = 0
      Path = Left$(FileList, InStr(FileList, Chr(0)) - 1)
      If Right$(Path, 1) <> "\" Then Path = Path + "\"
      FileList = FileList + Chr(0) 'Addition de Chr(0) a la place de ""
      For Pos = 1 To Len(FileList)
         If Mid$(FileList, Pos, 1) = Chr(0) Then
            Count = Count + 1
            If Count = FileNumber Then FNStart = Pos + 1
            If Count = (FileNumber + 1) Then
               FNLen = Pos - FNStart
               Exit For
            End If
         End If
      Next Pos
      GetFileFromList = Path + Mid$(FileList, FNStart, FNLen)
   End If

End Function

' This is a generic error handling procedure for the Xceed Zip OCX.
' It opens a message box containing a brief description of an
' error that has occured when manipulating Zip files.
'
' Pass the return code from any method (like CmdAdd, CmdExtract...)
' in the ErrorCode parameter, and one word describing the current
' operation in the DoingWhat parameter.
'
Public Sub HandleError(ErrorCode As Integer, DoingWhat As String)

   Dim EDesc    As String     ' Error description text
   Dim InfoOnly As Integer    ' False=Error, True=Warning

   EDesc = "" ' If this stays empty, we will not show a MsgBox
   InfoOnly = False

   If ErrorCode > XcdSuccess Then
    
      Select Case ErrorCode
         Case XcdWarningGeneral, XcdWarningNoZipFile, XcdErrorNothingToDo
            Rem Do not show a MsgBox for these codes
         Case XcdWarningEmptyZipFile
            EDesc = "The Zip file is empty."
            InfoOnly = True
         Case XcdWarningFilesSkipped
            EDesc = "Some files were skipped while " + DoingWhat + "."
            InfoOnly = True
         Case XcdErrorUserAbort
            EDesc = "The " + DoingWhat + " operation was aborted."
            InfoOnly = True
         Case XcdErrorNoZipFile
            EDesc = "Could not find the archive file."
         Case XcdErrorEOF, XcdErrorZipStruct
            EDesc = "The archive file is corrupted. Try using the Fix option on it."
         Case XcdErrorMemory
            EDesc = "Ran out of memory while " + DoingWhat + "."
         Case XcdErrorDiskFull
            If frmMain.ZipMain.MultidiskMode Then
               EDesc = "A full disk was inserted instead of an empty one."
            Else
               EDesc = "Disk full while " + DoingWhat + "."
            End If
         Case XcdErrorTestFailed
            EDesc = "Test failed - errors in the archive."
         Case XcdErrorZeroTested
            EDesc = "No files ended up being tested in the archive."
         Case XcdErrorTempFile
            EDesc = "Problem with the temporary file."
         Case XcdErrorLatest
            EDesc = "Could not update the Zip archive date. Archive only contains directories or is empty."
         Case XcdErrorLibInUse
            EDesc = "Another application is currently performing a similar task. Wait until the other application has completed its operation."
         Case XcdErrorParentDir
            EDesc = "Attempt to remove parent directory."
         Case XcdErrorDOSError
            EDesc = "Read/Write error with the Zip file or one of the files to process."
         Case XcdErrorNameRepeat
            EDesc = "Names repeated in archive after discarding pathnames."
         Case XcdErrorMultidisk
            EDesc = "Cannot work on multiple-disk archives when not in Multidisk mode."
         Case XcdErrorWrongDisk
            EDesc = "Wrong disk was inserted too many times."
         Case XcdErrorMultiDiskBadCall
            EDesc = "Operation not supported for Multidisk Zip archives."
         Case XcdErrorCantOpenBinary
            EDesc = "Could not open the self-extractor binary."
         Case XcdErrorCantOpenSFXConfig
            EDesc = "Could not open the self-extractor configuration file"
         Case XcdErrorInvalidEventParam
            EDesc = "Invalid command parameter passed to an Xceed Zip event."
         Case XcdErrorCantWriteSfx
            EDesc = "Not enough space on first disk to write self-extractor."
         Case XcdErrorRead
            EDesc = "Problem reading from file while " + DoingWhat + "."
         Case XcdErrorWrite
            EDesc = "Problem writing to file while " + DoingWhat + "."
         Case XcdErrorCantCreateFile
            EDesc = "Problem creating file while " + DoingWhat + "."
         Case XcdErrorBinaryVersion
            EDesc = "Invalid self-extractor binary version."
         Case XcdErrorNotLicensed
            EDesc = "This application was created with an unlicensed copy of the " + _
                    "Xceed Zip component. It will only run in design mode."
         Case XcdErrorCantCreateDir
            EDesc = "Problem creating destination directory while " + DoingWhat + "."
         Case XcdErrorBadCall
            EDesc = "Invalid property settings. Check your code."
         Case Else
            EDesc = "An error occured while " + DoingWhat + " the specified files."
      End Select

   End If

   If Len(EDesc) > 0 Then
      If InfoOnly Then
         MsgBox EDesc, vbExclamation      ' A warning
      Else
         MsgBox EDesc, vbCritical         ' An error
      End If
   End If

End Sub

'ODIODI
' This function opens a dialog and lets the user select multiple
' files to be operated on.
'
' This function will return the full path and filename of each
' and every selected file, all concatenated in one big string.
' If the Cancel button was used, then the function will return
' an empty string.
'
' Note: The dialog used is limited to 255 characters total for
' the entire file list string. If too many files are selected,
' the file list will be cut and "file not found" errors will occur.
'
Public Function SelectFilesToProcess(Title As String) As String

   With frmMain.dlgSelectFiles
      .CancelError = False
      .FileName = ""

      .Flags = cdlOFNFileMustExist + cdlOFNNoChangeDir + cdlOFNHideReadOnly + cdlOFNExplorer + cdlOFNAllowMultiselect + cdlOFNLongNames

      .DialogTitle = Title
      .ShowOpen

      If Len(.FileName) > 0 Then
         SelectFilesToProcess = .FileName
      End If
   End With
   
End Function
'ODIODI
' This function takes a string containing a path and tries to make it
' fit into a given control's display space (i.e: Panel and label captions.)
' Note: It considers a '\' to indicate the presence of a path in the string.
'
Function ShortenPathForDisplay(aString As String, aForm As Object, Width As Integer) As String

  Dim TempString As String
  Dim Pos As Long
  Dim Pos2 As Long
    
  TempString = aString
  
  While aForm.TextWidth(TempString) > Width
    
    Pos = InStr(1, TempString, "...")
    If Pos > 0 Then
      TempString = Left$(TempString, Pos - 1) + Right$(TempString, Len(TempString) - Pos - 3)
    End If
    
    Pos = InStr(3, TempString, "\")
    Pos2 = InStr(Pos + 1, TempString, "\")
    
    If Pos2 = 0 Then
      ShortenPathForDisplay = Left$(TempString, Pos) + "..." + Right$(TempString, Len(TempString) - Pos + 1)
      Exit Function
    End If
    
    TempString = Left$(TempString, Pos) + "..." + Right$(TempString, Len(TempString) - Pos2 + 1)
    
  Wend
  ShortenPathForDisplay = TempString
End Function

' This function opens up a 'Open File' Dialog to have the
' user select a Zip file. Depending on the DialogType parameter,
' the behavior of the dialog is different.
'
' This function will return the full path and filename of the
' selected Zip file. If the Cancel button was used, then the
' function will return an empty string.
'
Public Function SelectZipFile$(DialogType As Integer)

   With frmMain.dlgSelectZip
      
      .FileName = ""
      .Flags = cdlOFNFileMustExist + cdlOFNNoChangeDir + cdlOFNHideReadOnly
      .Filter = "Zip archives (*.zip)|*.zip|Self-extracting Zip archives (*.exe)|*.exe|All files (*.*)|*.*"
      
      Select Case DialogType
         Case OpenZip
            .DialogTitle = "Open Archive"
            .Action = 1
         Case NewZip
            .Flags = cdlOFNOverwritePrompt + cdlOFNNoChangeDir + cdlOFNHideReadOnly
            .DialogTitle = "New Archive"
            .Action = 2  ' Pretend we are saving file. A new archive is really created when Adding files.
         Case TestZip
            .DialogTitle = "Test Archive"
            .Action = 1
         Case FixZip
            .DialogTitle = "Fix Archive"
            .Action = 1
         Case DeleteZip
            .DialogTitle = "Delete Archive"
            .Action = 1
         Case SelectBin
            .FileName = ""
            .Filter = "Self-extractor binary (*.bin)|*.bin|All files (*.*)|*.*"
            .DialogTitle = "Select self-extractor binary"
            .Action = 1
      End Select

      SelectZipFile = .FileName
   End With
   
End Function