save email attachments and winrar it

[mmenofy]

Hi

I am using the following VBA to save email attachments to specific folder and then record it in an excel file
----> what i need is to convert the attachments to a compressed file (winrar or winzip)

Public Sub SATD(MItem As Outlook.MailItem)

Dim oAttachment As Outlook.Attachment
Dim sSaveFolder As String
sSaveFolder = "D:\DOWNLOADTEST\"

For Each oAttachment In MItem.Attachments

oAttachment.SaveAsFile sSaveFolder & oAttachment.filename

'------------------------------------------------------------------
Dim filename As String
Dim RetVal
Dim fs
filename = "D:\DOWNLOADTEST\TEST.xlsm"
Set fs = CreateObject("Scripting.FileSystemObject")
If (fs.FileExists(filename)) Then
Shell "cmd.exe /c Start ""Tiff"" """ & filename & """"
Else
MsgBox ("File not found")
End If

Next
End Sub

 

[Logit]

The following will zip everything located in a folder of your choosing :

Option Explicit

Sub Zip_File_Or_Files()
    Dim strDate As String, DefPath As String, sFName As String
    Dim oApp As Object, iCtr As Long, I As Integer
    Dim FName, vArr, FileNameZip
      
    DefPath = Application.DefaultFilePath
    If Right(DefPath, 1) <> "\" Then
        DefPath = DefPath & "\"
    End If

    strDate = Format(Now, " dd-mmm-yy h-mm-ss")
    FileNameZip = DefPath & "MyFilesZip " & strDate & ".zip"

    'Browse to the file(s), use the Ctrl key to select more files
    FName = Application.GetOpenFilename(filefilter:="Excel Files (*.xl*), *.xl*", _
                    MultiSelect:=True, Title:="Select the files you want to zip")
    If IsArray(FName) = False Then
        'do nothing
    Else
        'Create empty Zip File
        NewZip (FileNameZip)
        Set oApp = CreateObject("Shell.Application")
        I = 0
        For iCtr = LBound(FName) To UBound(FName)
            vArr = Split97(FName(iCtr), "\")
            sFName = vArr(UBound(vArr))
            If bIsBookOpen(sFName) Then
                MsgBox "You can't zip a file that is open!" & vbLf & _
                       "Please close it and try again: " & FName(iCtr)
            Else
                'Copy the file to the compressed folder
                I = I + 1
                oApp.Namespace(FileNameZip).CopyHere FName(iCtr)

                'Keep script waiting until Compressing is done
                On Error Resume Next
                Do Until oApp.Namespace(FileNameZip).items.Count = I
                    Application.Wait (Now + TimeValue("0:00:01"))
                Loop
                On Error GoTo 0
            End If
        Next iCtr

        MsgBox "You find the zipfile here: " & FileNameZip
    End If
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
End Sub


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


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

The following uses 7Zip.exe :

Option Explicit

'This macro takes all files (*.xlsx) in folder located at :  "C:\Users\My\Desktop\New folder\"
'Places them into a zip file (using 7Zip) and stores the zip file in a sub-folder named  zip

'Edit As Required

Sub zipAll()
Dim strDestFileName, strSourceFileName, str7ZipPath, strCommand, folder As String

folder = "C:\Users\My\Desktop\New folder\"

strDestFileName = folder + "zip\" + Filename + ".zip"
 strSourceFileName = folder + Filename + "*.xlsx"
 str7ZipPath = "C:\Program Files\7-Zip\7z.exe"

 strCommand = str7ZipPath & " a -tzip """ & strDestFileName & """ """ & strSourceFileName & """"
 Shell strCommand
End Sub

 

[mmenofy]

Thank you so much, but i can't use this in my code (Sorry, still new in VBA)
My code is saving the e-mail attachments in a folder (automatically), all what i need is to collect this mail attachment and compress it then save it in the folder

The following will zip everything located in a folder of your choosing :

Option Explicit

Sub Zip_File_Or_Files()
    Dim strDate As String, DefPath As String, sFName As String
    Dim oApp As Object, iCtr As Long, I As Integer
    Dim FName, vArr, FileNameZip
     
    DefPath = Application.DefaultFilePath
    If Right(DefPath, 1) <> "\" Then
        DefPath = DefPath & "\"
    End If

    strDate = Format(Now, " dd-mmm-yy h-mm-ss")
    FileNameZip = DefPath & "MyFilesZip " & strDate & ".zip"

    'Browse to the file(s), use the Ctrl key to select more files
    FName = Application.GetOpenFilename(filefilter:="Excel Files (*.xl*), *.xl*", _
                    MultiSelect:=True, Title:="Select the files you want to zip")
    If IsArray(FName) = False Then
        'do nothing
    Else
        'Create empty Zip File
        NewZip (FileNameZip)
        Set oApp = CreateObject("Shell.Application")
        I = 0
        For iCtr = LBound(FName) To UBound(FName)
            vArr = Split97(FName(iCtr), "\")
            sFName = vArr(UBound(vArr))
            If bIsBookOpen(sFName) Then
                MsgBox "You can't zip a file that is open!" & vbLf & _
                       "Please close it and try again: " & FName(iCtr)
            Else
                'Copy the file to the compressed folder
                I = I + 1
                oApp.Namespace(FileNameZip).CopyHere FName(iCtr)

                'Keep script waiting until Compressing is done
                On Error Resume Next
                Do Until oApp.Namespace(FileNameZip).items.Count = I
                    Application.Wait (Now + TimeValue("0:00:01"))
                Loop
                On Error GoTo 0
            End If
        Next iCtr

        MsgBox "You find the zipfile here: " & FileNameZip
    End If
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
End Sub


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


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

The following uses 7Zip.exe :

Option Explicit

'This macro takes all files (*.xlsx) in folder located at :  "C:\Users\My\Desktop\New folder\"
'Places them into a zip file (using 7Zip) and stores the zip file in a sub-folder named  zip

'Edit As Required

Sub zipAll()
Dim strDestFileName, strSourceFileName, str7ZipPath, strCommand, folder As String

folder = "C:\Users\My\Desktop\New folder\"

strDestFileName = folder + "zip\" + Filename + ".zip"
 strSourceFileName = folder + Filename + "*.xlsx"
 str7ZipPath = "C:\Program Files\7-Zip\7z.exe"

 strCommand = str7ZipPath & " a -tzip """ & strDestFileName & """ """ & strSourceFileName & """"
 Shell strCommand
End Sub