save attachment from outlook 2010 to folder without Zip format

[Saravanan1]

Hi I am very new to vba. I am using outlook 2010. I want to save the attachment from outlook inbox to particular folder like in C drive. In mail I am getting file with Zip format. so i want to unzip the file and rename the file with system date and need to save in folder like "C:\test\".

The file will be excel, pdf or text file... Kindly help to get it done..

Thanks in advance
Saravanan S

[gmayor]

Nothing like jumping in at the deep end. Running before you can walk comes to mind :) However it should be possible.
Insert a module into Outlook VBA and copy the following into that module.

Modify the line - Const strPath As String = "C:\ZipTest\"
to reflect where you want to store the unzipped files. This folder will be created if not present.
Modify the line - strDate = Format(Now, " dd-mm-yy")
to reflect the date format you wish to add
The macro creates a dated sub folder e.g C:\ZipTest\Unzip 23-09-14 - with the name at - Const strSubFolder As String = "Unzip"
that contains the files from the zip.
The UnzipAttachments sub is intended as a script to be run from an Outlook rule which identified the messages to be processed. The process is tghus run as the messages arrive in the inbox. I have included TestUnzip to test the macro on a selected function.
Thanks to Ron de Bruin for suggesting the method used for the extraction routine - http://www.rondebruin.nl/win/s7/win002.htm (http://www.rondebruin.nl/win/s7/win002.htm)



Option Explicit

Sub UnzipAttachments(Item As Outlook.MailItem)
Dim olAtt As Attachment
Dim strFilename As String
Const strPath As String = "C:\ZipTest\" 'Folder to save temporary files
If Item.Attachments.Count > 0 Then
For Each olAtt In Item.Attachments
If Right(LCase(olAtt.Filename), 3) = "zip" Then
If Not FileExists(strPath) Then MkDir strPath
olAtt.SaveAsFile strPath & olAtt.Filename
UnZipFile strPath & olAtt.Filename, strPath
Kill strPath & olAtt.Filename
End If
Next olAtt
End If
lbl_Exit:
Set olAtt = Nothing
End Sub

Private Sub UnZipFile(Fname As Variant, strPath As String)
Dim FSO As Object
Dim oShell As Object
Dim FileNameFolder As Variant
Dim strDate As String
Const strSubFolder As String = "Unzip"

'Create the folder name
strDate = Format(Now, " dd-mm-yy")
FileNameFolder = strPath & strSubFolder & strDate & "\"

'Make the normal folder in DefPath
MkDir FileNameFolder

'Extract the files into the newly created folder
Set oShell = CreateObject("Shell.Application")
oShell.NameSpace(FileNameFolder).CopyHere oShell.NameSpace(Fname).Items
'MsgBox "You find the unzipped file(s) here: " & FileNameFolder
On Error Resume Next
Set FSO = CreateObject("scripting.filesystemobject")
FSO.DeleteFolder Environ("Temp") & "\Temporary Directory*", True
lbl_Exit:
Set FSO = Nothing
Set oShell = Nothing
Exit Sub
End Sub

Private Function FolderExists(ByVal PathName As String) As Boolean
Dim lngAttr As Long
On Error GoTo NoFolder
lngAttr = GetAttr(PathName)
If (lngAttr And vbDirectory) = vbDirectory Then
FolderExists = True
End If
NoFolder:
Exit Function
End Function

Sub TestUnzip()
Dim olMsg As MailItem
On Error Resume Next
Set olMsg = ActiveExplorer.Selection.Item(1)
UnzipAttachments olMsg
End Sub

[Saravanan1]

Thank you very much for your reply. I will check and get back to you soon...

Regards
Saravanan S

[aseabroo]

Thank you for this. I am trying to see if it is possible to unzip the file in the destination folder without creating a new folder. I know that the website you gave credit for, example 3, it is possible. However, I tried to change "FileNameFolder" to "FileNameFolder = strPath" and commented out the MkDir FileNameFolder to see if it would extract in that way... but I end up getting a zipped attachment downloaded and no unzipped files.&amp;nbsp;&lt;br&gt;<br>

[gmayor]

The files are unzipped into a dated sub folder of strPath. You can unzip them into strPath without the sub folder by changing the UnZipFile macro as below. Whether I would recommend that is another issue entirely. It rather depends on the object of the exercise.

Note also there is a typo in the UnzipAttachments macro.

If Not FileExists(strPath) Then MkDir strPath
should be

If Not FolderExists(strPath) Then MkDir strPath


Private Sub UnZipFile(Fname As Variant, strPath As String)
Dim FSO As Object
Dim oShell As Object
Dim FileNameFolder As Variant
'Dim strDate As String
'Const strSubFolder As String = "Unzip"

'Create the folder name
'strDate = Format(Now, " dd-mm-yy")
FileNameFolder = strPath '& strSubFolder & strDate & "\"

'Make the normal folder in DefPath
'MkDir FileNameFolder

'Extract the files into the newly created folder
Set oShell = CreateObject("Shell.Application")
oShell.NameSpace(FileNameFolder).CopyHere oShell.NameSpace(Fname).Items
'MsgBox "You find the unzipped file(s) here: " & FileNameFolder
On Error Resume Next
Set FSO = CreateObject("scripting.filesystemobject")
FSO.DeleteFolder Environ("Temp") & "\Temporary Directory*", True
lbl_Exit:
Set FSO = Nothing
Set oShell = Nothing
Exit Sub
End Sub