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".