NEED Zip file Array Help Please

[yirrlaar]

Can someone please help me figure out why I'm stuck in an infinite loop when adding a file to the zip file? The first file it is attempting to zip is only 16kb and I've let it run for 30minutes and nothing appears to be going into the zip file.

Any ideas?

Sub Archive_files()
    Application.DisplayAlerts = False
    Dim NetworkLoc As String
    Dim CurDate As Date
    Dim SOMonth As Date
    Dim LookupFile As String, x
    Dim CopyFile
    Dim srcFile As String
    Dim oApp As Object
    Dim I As Integer
    Dim FileNameZip As String
    Dim ArchiveFolder As String
    Dim ZipFiles As String
    
    NetworkLoc = <<insert Network location here>>
    CurDate = Workbooks("Testing.xlsb").Sheets("Sheet1").Range("B2").Value
    SOMonth = DateSerial(Year(CurDate), Month(CurDate), 1) - 1
    ArchiveFolder = NetworkLoc & "Archive\"
    
    FileNameZip = ArchiveFolder & Format(SOMonth, "mm-yyyy") & ".zip"
    CopyFile = Array(NetworkLoc & "*" & Format(SOMonth, "Mmmm") & "*")
    For Each x In CopyFile
        LookupFile = Dir(NetworkLoc & x)
        Do While LookupFile <> ""
            srcFile = NetworkLoc & LookupFile
            FileCopy srcFile, ArchiveFolder & LookupFile
'            Kill srcFile
            LookupFile = Dir
        Loop
    Next
    
    If Len(Dir(FileNameZip)) > 0 Then Kill FileNameZip
    Open FileNameZip For Output As #1
    Print #1, Chr$(80) & Chr$(75) & Chr$(5) & Chr$(6) & String(18, 0)
    Close #1
    
    ZipFiles = Dir(ArchiveFolder & "*" & Format(SOMonth, "Mmmm") & "*")
    
    Set oApp = CreateObject("Shell.Application")
    I = 0
    Do While ZipFiles <> ""
        oApp.Namespace(FileNameZip).CopyHere oApp.Namespace(ArchiveFolder & ZipFiles).Items
        I = I + 1
            Do Until oApp.Namespace(FileNameZip).Items.Count = I
                Application.Wait (Now + TimeValue("0:00:01"))
            Loop
        ZipFiles = Dir
    Loop
End Sub

 

[Sektor]

FileCopy *does not* zip files.

 

[yirrlaar]

I am aware of that as that is part 1 of the sub ... COPY the files to the folder and then step 2 ZIP the files I just copied without including other files

 

[yirrlaar]

I figured it out

oApp.Namespace(FileNameZip).CopyHere oApp.Namespace(ArchiveFolder & ZipFiles).Items

should be

oApp.Namespace(FileNameZip).CopyHere oApp.Namespace(ArchiveFolder & ZipFiles)

 

[yirrlaar]

Here is the complete working code to move certain files to an archive folder, send an array of files to be zipped and then delete the files that were just zipped:

Sub Achive_Files()
    Dim FileNameZip
    Dim oApp As Object
    Dim CurDate As Date, SOMonth As Date

    NetworkLoc = "insert file location here"
    CurDate = Workbooks("Testing.xlsb").Sheets("Sheet1").Range("B2").Value
    SOMonth = DateSerial(Year(CurDate), Month(CurDate), 1) - 1
    ArchiveFolder = NetworkLoc & "Archive\"

    FileNameZip = ArchiveFolder & Format(SOMonth, "mm-yyyy") & ".zip"
    LookupFile = Dir(NetworkLoc & "*" & Format(SOMonth, "Mmmm") & "*")
    Do While LookupFile <> ""
        srcFile = NetworkLoc & LookupFile
        FileCopy srcFile, ArchiveFolder & LookupFile
        Kill srcFile
        LookupFile = Dir
    Loop

    If Len(Dir(FileNameZip)) > 0 Then Kill FileNameZip
    Open FileNameZip For Output As #1
    Print #1, Chr$(80) & Chr$(75) & Chr$(5) & Chr$(6) & String(18, 0)
    Close #1

    Set oApp = CreateObject("Shell.Application")
    ZipFiles = Dir(ArchiveFolder & "*" & Format(SOMonth, "Mmmm") & "*")
    I = 0
    Do While ZipFiles <> ""
        oApp.Namespace(FileNameZip).CopyHere oApp.Namespace(ArchiveFolder & ZipFiles)
        I = I + 1
        On Error Resume Next
        Do Until oApp.Namespace(FileNameZip).Items.Count = I
            Application.Wait (Now + TimeValue("0:00:01"))
        Loop
        On Error GoTo 0
        ZipFiles = Dir
    Loop
    
    LookupFile = Dir(ArchiveFolder & "*" & Format(SOMonth, "Mmmm") & "*")
    Do While LookupFile <> ""
        Kill ArchiveFolder & LookupFile
        LookupFile = Dir
    Loop
End Sub