Option Explicit

Sub Zip_File_Or_Files()
    Dim strDate         As String
    Dim DefPath         As String
    Dim sFName          As String
    Dim oApp            As Object
    Dim iCtr            As Long
    Dim I               As Integer
    Dim Fname           As Variant
    Dim vArr            As Variant
    Dim FileNameZip     As Variant
    Dim str             As String
    Dim FSO             As New FileSystemObject
    Dim destino         As String
    Dim cont            As Integer
    Dim pasta           As String
    Dim sub_pasta       As Folder
    Dim FolderName, oFolder
    Dim desktop         As String
    Dim contador        As Integer
    
    Dim fd As Object
    Dim sfd As Object
    
    desktop = CreateObject("WScript.Shell").specialfolders("Desktop")
    
    If Right(desktop, 1) <> "" Then
        desktop = desktop & ""
    End If
    
    strDate = Format(Now, " dd-mmm-yy h-mm-ss")
    
    'Define caminho padrão
    FSO.CreateFolder (desktop & "SISCOSERV" & "-" & strDate)
    
    DefPath = desktop & "SISCOSERV" & "-" & strDate
    
    If Right(DefPath, 1) <> "" Then
        DefPath = DefPath & ""
    End If
    
    FileNameZip = DefPath & "SISCOSERV" & "-" & contador & ".zip"
    'Variáveis para nomear pastas

    'Usuário selecionar os arquivos do tipo xml
    Fname = Application.GetOpenFilename(filefilter:="Arquivos XML (*.xml*), *.xml*", _
                    MultiSelect:=True, Title:="Selecione os arquivos XML que você quer zipar")
    
    pasta = "C:UsersViniciusDesktopSISCOCERV_BACKCUPZIP21"
    
    'Cria uma pasta em que os xmls serão copiados
    If FSO.FolderExists(pasta) = False Then
        destino = FSO.CreateFolder(pasta).path
        destino = FSO.CreateFolder(pasta & iCtr).path
    Else
        FSO.DeleteFolder (pasta)
        
        If Right(pasta, 1) <> "" Then
            pasta = pasta & ""
        Else
            Exit Sub
        End If
        
        destino = FSO.CreateFolder(pasta).path
        destino = FSO.CreateFolder(pasta & iCtr).path
    End If
        
    'executa looping em todos os arquivos selecionados, copiando-os em pastas em grupos de 200
    For iCtr = LBound(Fname) To UBound(Fname)
         
          If cont = 200 Then
             'renomeia a pasta
             destino = FSO.CreateFolder(pasta & iCtr).path
             cont = 0
          End If
         
         'copia arquivo na pasta
         Call FSO.CopyFile(Fname(iCtr), destino & "_" & Dir(Fname(iCtr)), True)
         
         'incrementa contador
         cont = cont + 1
              
    Next iCtr
    
    Set fd = FSO.GetFolder(pasta)
    
    For Each sfd In fd.SubFolders
     
    Set oApp = CreateObject("Shell.Application")

    'Browse to the folder
    Set oFolder = sfd
    If Not oFolder Is Nothing Then
        'Create empty Zip File
        NewZip (FileNameZip)
        
        FolderName = oFolder
        If Right(FolderName, 1) <> "" Then
            FolderName = FolderName & ""
        End If

        'Copy the files to the compressed folder
        oApp.Namespace(FileNameZip).CopyHere oApp.Namespace(FolderName).items

        'Keep script waiting until Compressing is done
        On Error Resume Next
        Do Until oApp.Namespace(FileNameZip).items.count = _
        oApp.Namespace(FolderName).items.count
            Application.Wait (Now + TimeValue("0:00:01"))
        Loop
        On Error GoTo 0
        contador = contador + 1
        FileNameZip = DefPath & "SISCOSERV" & "-" & contador & ".zip"
    
    End If
    
    Next
    
End Sub



Sub NewZip(sPath)
'Create empty Zip File
'Changed by keepITcool Dec-12-2005
    If Len(Dir(sPath)) > 0 Then Kill sPath
    Open sPath For Output As #1
    Print #1, Chr$(80) & Chr$(75) & Chr$(5) & Chr$(6) & String(18, 0)
    Close #1
    'Excel.Application.DisplayAlerts = True
End Sub


Function bIsBookOpen(ByRef szBookName As String) As Boolean
Excel.Application.DisplayAlerts = False
' Rob Bovey
    On Error Resume Next
    bIsBookOpen = Not (Application.Workbooks(szBookName) Is Nothing)
    'Excel.Application.DisplayAlerts = True
End Function


Function Split97(sStr As Variant, sdelim As String) As Variant
Excel.Application.DisplayAlerts = False
'Tom Ogilvy
    Split97 = Evaluate("{""" & _
                       Application.Substitute(sStr, sdelim, """,""") & """}")
    Excel.Application.DisplayAlerts = True
End Function