Outlook 2010 Saving Zipped Attachment - Help Needed!

[dc88310]

Greetings!

I will start by saying i am not a VBA expert by any stretch of the imagination. I have some code that i currently use to take an email attachment and save it to my network. It works perfectly for the attachments i am moving over.

My current code, I have as a module (For reference)

Sub saveAttachtoDisk(itm As Outlook.MailItem)Dim objAtt As Outlook.Attachment
Dim saveFolder As String
saveFolder = "\\safedata\public\Virtual_Org\Process_Improvement\Chat"
For Each objAtt In itm.Attachments
objAtt.SaveAsFile saveFolder & "\" & objAtt.DisplayName
Set objAtt = Nothing
Next
End Sub

Then I have a rule in Outlook that when these emails come in, it will automatically take the attachment and move it to the specified location. It works flawlessly.

Here is the issue: I have another email I want to do the same exact thing for, except the attachment in the new email i receive is zipped. I am not sure how to extract the zip file based on this code... but what i want to do.. is extract it... then once extracted save it to my network with a name that i specify.

Can anyone help me tweak this code to accomplish this? I have searched the forums and nothing i have read makes sense.

DC

[skatonni]

Not going to win any prizes but ..

Sub UnzipSaveAttachtoDisk(itm As Outlook.mailItem)
    Dim objAtt As attachment
    Dim sFileName As String
    Dim oApp As Object
    Dim FileNameFolder As Variant
    
    Dim saveFolder As String
    saveFolder = "H:\UnzipFolder"
 
    If itm.Attachments.count > 0 Then
 
        For Each objAtt In itm.Attachments
 
            If Right(objAtt.FileName, 3) = "zip" Then
 
                FileNameFolder = "H:\Temp"
                sFileName = FileNameFolder & "\" & objAtt.FileName
 
                objAtt.SaveAsFile sFileName
 
                Set oApp = CreateObject("Shell.Application")
                oApp.Namespace((FileNameFolder)).CopyHere oApp.Namespace((sFileName)).Items
 
                Kill sFileName
                Rename_Files
            Else
                objAtt.SaveAsFile saveFolder & "\" & objAtt.DisplayName
        End If
 
        Next objAtt
 
    End If
 
    Set itm = Nothing
    Set oApp = Nothing
 
End Sub
 
Sub Rename_Files()
 
    Dim Path_FileNm_w_ext As String
    Dim FileNm_w_Ext As String
    Dim FileNm As String
    Dim ext As String
     
    Dim origPath As String
    Dim saveFolder As String
    Dim newName  As String
    
    origPath = "H:\Temp"
    saveFolder = "H:\UnzipFolder"
 
    FileNm_w_Ext = Dir(origPath & "\" & "*.*")
 
    Do While FileNm_w_Ext <> ""
 
        ext = Right$(FileNm_w_Ext, Len(FileNm_w_Ext) - InStrRev(FileNm_w_Ext, ".") + 1)
        Path_FileNm_w_ext = origPath & "\" & FileNm_w_Ext
 
        FileNm = FileNameNoExt(Path_FileNm_w_ext)
 
        newName = InputBox("Do not key the extension " & ext & vbCr & " Enter new name for " & FileNm, , FileNm)
        newName = Trim(newName)
        
        Debug.Print " saveFolder & newName & ext: " & saveFolder & newName & ext
 
        Name origPath & "\" & FileNm_w_Ext As saveFolder & "\" & newName & ext
 
        FileNm_w_Ext = Dir
 
    Loop
 
End Sub

Function FileNameNoExt(strPath As String) As String
Dim strTemp As String
strTemp = Mid$(strPath, InStrRev(strPath, "\") + 1)
FileNameNoExt = Left$(strTemp, InStrRev(strTemp, ".") - 1)
End Function

Private Sub UnzipSaveAttachtoDisk_test()
    Dim currItem As mailItem
    Set currItem = Application.ActiveInspector.currentItem
    Debug.Print "currItem.Subject: " & currItem.Subject
    UnzipSaveAttachtoDisk currItem
End Sub

Change the temp folder savefolder in both places.

Test with UnzipSaveAttachtoDisk_test. Unzips and saves if necessary, just saves if not a zipped file.

Run through the code with F8 in the editor. You should know what is happening, especially when the code includes a "Kill".