I'm trying to extract an zip file from my Outlook mail.
Below is my script but its throwing an error object variable or with block variable not set.
On
oApp.NameSpace((FileNameFolder)).CopyHere oApp.NameSpace((Atchmt.FileName)).Items
How I fix it.
Sub Unzip()
Dim ns As NameSpace
Dim Inbox As MAPIFolder
Dim SubFolder As MAPIFolder
Dim Atchmt As Attachment
Dim FileName As String
Dim msg As Outlook.MailItem
Dim FileNameFolder As String
Dim FSO As Object 'variables for unzipping
Dim oApp As Object
Set ns = GetNamespace("MAPI")
Set Inbox = ns.GetDefaultFolder(olFolderInbox)
Set SubFolder = Inbox.Folders("TEST")
For Each msg In SubFolder.Items
If msg.UnRead = True Then
If LCase(msg.Subject) Like "*motor*" Then
For Each Atchmt In msg.Attachments
If (Right(Atchmt.FileName, 3) = "zip") Then
MsgBox "1"
FileNameFolder = "C:\Users\xxxx\Documents\test\"
Set oApp = CreateObject("Shell.Application")
oApp.NameSpace((FileNameFolder)).CopyHere oApp.NameSpace((Atchmt.FileName)).Items
End If
Next
End If
End If
Next
End Sub
Try saving the zip file first then extract it, if you want to delete the zip file then try Kill (zippath & zipname )
Dim TempFile As String
For Each msg In SubFolder.Items
If msg.UnRead = True Then
If LCase(msg.Subject) Like "*motor*" Then
For Each Atchmt In msg.Attachments
If (Right(Atchmt.FileName, 3) = "zip") Then
' MsgBox "1"
FileNameFolder = "C:\Temp\Folders\"
Debug.Print FileNameFolder ' Immediate Window
Debug.Print Atchmt.FileName ' Immediate Window
TempFile = FileNameFolder & Atchmt.FileName
Atchmt.SaveAsFile TempFile
Set oApp = CreateObject("Shell.Application")
oApp.NameSpace((FileNameFolder)).CopyHere oApp.NameSpace((Atchmt.FileName)).Items
Kill (TempFile)
End If
Next
End If
End If
Next
Declare msg as a generic Object - you can have objects other than MailItem in the Inbox, such as ReportItem or MeetingItem.
Related
I'm trying to save Outlook emails into my H:Drive. I want it as a run a script rule but I can't get it to work. There are no attachments involved and all I need it is to save it as a .msg file. Please lmk if you find a different way to tackle this problem.
Thanks
Sub ExtractEmailToFolder2(itm As Outlook.MailItem)
Dim OlApp As Outlook.Application
Set OlApp = New Outlook.Application
Dim Mailobject As Object
Dim Email As String
Dim NS As NameSpace
Dim Folder As MAPIFolder
Set OlApp = CreateObject("Outlook.Application")
Dim fso As Object
Dim fldrname As String
Dim fldrpath As String
' Setup Namespace
Set NS = ThisOutlookSession.Session
' Display select folder dialog
Set Folder = NS.PickFolder
' Create Folder File
Set fso = CreateObject("Scripting.FileSystemObject")
' loop to read email address from mail items.
For Each Mailobject In Folder.Items
fldrpath = "H:\Backup stuff\"
If Not fso.folderexists(fldrpath) Then
fso.createfolder (fldrpath)
End If
Set objCopy = Mailobject.Copy
objCopy.SaveAs fldrpath & "\" & objCopy.Subject, olMSG
Next
Set OlApp = Nothing
Set Mailobject = Nothing
End Sub
First of all, there is no need to create a new Outlook Application instance (twice in your sample code!) if your VBA macro is run by the rule. Instead, you can use the global Application property:
Sub ExtractEmailToFolder2(itm As Outlook.MailItem)
Dim fso As Object
Dim fldrname As String
Dim fldrpath As String
' Create Folder if required
Set fso = CreateObject("Scripting.FileSystemObject")
fldrpath = "H:\Backup stuff\"
If Not fso.folderexists(fldrpath) Then
fso.createfolder (fldrpath)
End If
itm.SaveAs fldrpath & "\" & "your_unique_filename.msg", olMSG
Set OlApp = Nothing
Set Mailobject = Nothing
End Sub
The sample code which is shown above saves the item against which the rule is run to the folder specified/hardcoded.
Problem:
Folder Check was included in the Loop
FileName had Subject in it. That always creates problem unless some kind of manipulation is done. Because it contains various characters that are not permitted in the Name of a File in Windows.
Note:
Put it in any Module in Outlook and Run using F5 or by Creating a Shortcut.
Try:
Sub ExtractEmailToFolder2()
Dim OlApp As Outlook.Application
Set OlApp = New Outlook.Application
Dim Mailobject As Object
Dim Email As String
Dim NS As NameSpace
Dim Folder As MAPIFolder
Set OlApp = CreateObject("Outlook.Application")
Dim fso As Object
Dim fldrname As String
Dim fldrpath As String
' Setup Namespace
Set NS = ThisOutlookSession.Session
' Display select folder dialog
Set Folder = NS.PickFolder
' Create Folder File
Set fso = CreateObject("Scripting.FileSystemObject")
fldrpath = "H:\Backup stuff\"
If Not fso.folderexists(fldrpath) Then
fso.createfolder (fldrpath)
End If
' loop to read email address from mail items.
i = 1
For Each Mailobject In Folder.Items
Mailobject.SaveAs fldrpath & "\mail" & i & ".msg", olMsg
i = i + 1
Next
Set OlApp = Nothing
Set Mailobject = Nothing
End Sub
I need to extract attachments from Emails received in a user preferred time frame.
Say like extract for Emails received between 2PM to 4PM.
Please find the below code I've that extract files perfectly - but it did for all the Emails in the folder.
Please help me to resolve it.
Sub Unzip()
Dim ns As NameSpace 'variables for the main functionality
Dim Inbox As MAPIFolder
Dim SubFolder As MAPIFolder
Dim Atchmt As Attachment
Dim FileName As Variant
Dim msg As Outlook.MailItem
Dim FSO As Object 'variables for unzipping
Dim oApp As Object
Dim FileNameFolder As Variant
Dim Totalmsg As Object
Dim oFrom
Dim oEnd
Set ns = GetNamespace("MAPI")
Set Inbox = ns.GetDefaultFolder(olFolderInbox)
Set SubFolder = Inbox.Folders("TEST")
Set Totalmsg = msg.ReceivedTime
oFrom = InputBox("Please give start time", ("Shadowserver report"))
oEnd = InputBox("Please give End time", ("Shadowserver report"))
If Totalmsg <= oFrom And Totalmsg >= oEnd Then
For Each msg In SubFolder.Items
For Each Atchmt In msg.Attachments
If (Right(Atchmt.FileName, 3) = "zip") Then
MsgBox "1"
FileNameFolder = "C:\Users\xxxx\Documents\test\"
FileName = FileNameFolder & Atchmt.FileName
Atchmt.SaveAsFile FileName
Set oApp = CreateObject("Shell.Application")
oApp.NameSpace(FileNameFolder).CopyHere oApp.NameSpace(FileName).Items
Kill (FileName)
On Error Resume Next
Set FSO = CreateObject("scripting.filesystemobject")
FSO.deletefolder Environ("Temp") & "\Temporary Directory*", True
End If
Next
Next
End If
End Sub
Made a few improvements to improve performance and clarity :
Test received time inside the loop on the messages
Defined related variables as Date (like MsG.ReceivedTime) and improved input messages
Added Option Explicit to avoid mishaps in future coding (VERY GOOD PRACTICE)
Use Environ$("USERPROFILE") to get User directory's path
Reorganize variables and initialisation outside of the loops
Added LCase to be sure to get all zips (including .ZIP)
Code :
Option Explicit
Sub Unzip()
'''Variables for the main functionality
Dim NS As NameSpace
Dim InboX As MAPIFolder
Dim SubFolder As MAPIFolder
Dim MsG As Outlook.MailItem
Dim AtcHmt As Attachment
Dim ReceivedHour As Date
Dim oFrom As Date
Dim oEnd As Date
'''Variables for unzipping
Dim FSO As Object
Dim ShellApp As Object
Set FSO = CreateObject("Scripting.FileSystemObject")
Set ShellApp = CreateObject("Shell.Application")
Dim FileNameFolder As Variant
Dim FileName As Variant
'''Define the Outlook folder you want to scan
Set NS = GetNamespace("MAPI")
Set InboX = NS.GetDefaultFolder(olFolderInbox)
Set SubFolder = InboX.Folders("TEST")
'''Define the folder where you want to save attachments
FileNameFolder = Environ$("USERPROFILE") & "\Documents\test\"
'''Define the hours in between which you want to apply the extraction
oFrom = CDate(InputBox("Please give Start time" & vbCrLf & _
"Example: 9AM", ("Shadowserver report"), "9AM"))
oEnd = CDate(InputBox("Please give End time" & vbCrLf & _
"Example: 6PM", ("Shadowserver report"), "6PM"))
For Each MsG In SubFolder.items
ReceivedHour = MsG.ReceivedTime
If oFrom <= TimeValue(ReceivedHour) And _
TimeValue(ReceivedHour) <= oEnd Then
For Each AtcHmt In MsG.Attachments
FileName = AtcHmt.FileName
If LCase(Right(FileName, 3)) <> "zip" Then
Else
FileName = FileNameFolder & FileName
AtcHmt.SaveAsFile FileName
ShellApp.NameSpace(FileNameFolder).CopyHere _
ShellApp.NameSpace(FileName).items
Kill (FileName)
On Error Resume Next
FSO.deletefolder Environ$("Temp") & "\Temporary Directory*", True
End If
Next AtcHmt
End If
Next MsG
End Sub
I am just going to include the part that you need to change. Other lines will be the same. Basically, what you need to do is to set the Totalmsg inside your loop for each msg;
Sub Unzip()
'... copy your code till here
Set SubFolder = Inbox.Folders("TEST")
oFrom = InputBox("Please give start time", ("Shadowserver report"))
oEnd = InputBox("Please give End time", ("Shadowserver report"))
For Each msg In SubFolder.Items
Set Totalmsg = msg.ReceivedTime
If Totalmsg <= oFrom And Totalmsg >= oEnd Then 'You check it for each msg
'rest will be the same until ...
FSO.deletefolder Environ("Temp") & "\Temporary Directory*", True
End If
Next
End If
Next
End Sub
I dragged an outlook msg to a specific folder named "email temp folder" and would like to reply on that msg automatically.
The title name of the msg which I saved in "email temp folder" could be anything. It is not possible for me to get the file's title name. So I try to loop through the file in "email temp folder" and Set FileItemToUse = objFile
However, there is an error: object doesn't support this property or method on this line. .ReplyAll
How am I able to turn FileItemToUse into an outlook item?
Sub outlookActivate1()
Dim OutApp As Outlook.Application
Dim OutMail As Outlook.MailItem
Dim fso As New FileSystemObject
Dim objFolder As Object
Dim objFile As Object
Dim FileItemToUse As Object
Dim i As Long
Set OutApp = CreateObject("Outlook.Application")
strPath = "C:\Users\admin\Desktop\email temp folder" & "\"
strFiles = Dir(strPath & "*.*")
Set objFolder = fso.GetFolder(strPath)
For Each objFile In objFolder.Files
If i = 0 Then
Set FileItemToUse = objFile
End If
Next objFile
With FileItemToUse
.ReplyAll
.BCC = ""
.Subject = "Hi"
.HTMLBody = "testing"
.BodyFormat = olFormatHTML
.display
End With
Set OutMail = Nothing
Set OutApp = Nothing
End Sub
Your code should look similar to the following:
Sub ReplyToFilesInFolder(SourceFolderName As String)
Dim FSO As Scripting.FileSystemObject
Dim SourceFolder As Scripting.Folder
Dim FileItem As Scripting.File
Dim strFile
Dim strFileType
Dim openMsg As MailItem
Dim strFolderpath As String
Set FSO = New Scripting.FileSystemObject
Set SourceFolder = FSO.GetFolder(SourceFolderName)
For Each FileItem In SourceFolder.Files
strFile = FileItem.name
' This code looks at the last 4 characters in a filename
' If we wanted more than .msg, we'd use Case Select statement
strFileType = LCase$(Right$(strFile, 4))
If strFileType = ".msg" Then
Debug.Print FileItem.Path
Set openMsg = Application.CreateItemFromTemplate(FileItem.Path)
' do whatever is needed to reply
openMsg.Close olDiscard
Set openMsg = Nothing
' end do whatever
End If
Next FileItem
Set FileItem = Nothing
Set SourceFolder = Nothing
Set FSO = Nothing
End Sub
This (untested) snipped was inspired by this article. Microsoft Scripting Runtime has to be included as project reference.
So I try to loop through the file in "email temp folder" and Set FileItemToUse = objFile
It is not possible to get the job done that way.
When you drag a message file (.msg) file to a specific folder the ItemAdd event is fired. So, you need to handle the event to get a MailItem object which corresponds a dropped file. Then you can use the Reply or ReplyAll methods.
I have the following code which I am using to save an email attachment into a folder. I want to make this vba run automatically each time I open outlook and check all emails in my creditchecks#hewden.co.uk inbox (non default inbox).
At the moment though it only checks the email which is selected in the active inbox. can someone please show me how I can edit my code to get it to do what I need. thanks
Public Sub SaveAttachments()
Dim objOL As Outlook.Application
Dim objMsg As Outlook.MailItem 'Object
Dim objAttachments As Outlook.Attachments
Dim objSelection As Outlook.Selection
Dim i As Long
Dim lngCount As Long
Dim strFile As String
Dim strFolderPath As String
Dim strDeletedFiles As String
Dim withParts As String
Dim withoutParts As String
' Get the path to your My Documents folder
On Error Resume Next
' Instantiate an Outlook Application object.
Set objOL = CreateObject("Outlook.Application")
' Get the collection of selected objects.
Set objSelection = objOL.ActiveExplorer.Selection
' The attachment folder needs to exist
' You can change this to another folder name of your choice
' Set the Attachment folder.
strFolderPath = "\\UKSH000-FILE06\Purchasing\New_Supplier_Set_Ups_&_Audits\ATTACHMENTS\"
' Check each selected item for attachments.
For Each objMsg In objSelection
Set objAttachments = objMsg.Attachments
lngCount = objAttachments.Count
If lngCount > 0 Then
' Use a count down loop for removing items
' from a collection. Otherwise, the loop counter gets
' confused and only every other item is removed.
For i = lngCount To 1 Step -1
' Get the file name.
strFile = objAttachments.item(i).FileName
If Right(strFile, 3) = "pdf" Then
' Combine with the path to the Temp folder.
withParts = strFile
withoutParts = Replace(withParts, ".pdf", "")
strFile = strFolderPath & withoutParts & "\" & strFile
' Save the attachment as a file.
objAttachments.item(i).SaveAsFile strFile
End If
Next i
End If
Next
ExitSub:
Set objAttachments = Nothing
Set objMsg = Nothing
Set objSelection = Nothing
Set objOL = Nothing
End Sub
Just need to edit some lines. Use something like objOL.GetNamespace("MAPI").GetDefaultFolder(olFolderInbox).Parent.Folders("credutchecks#hewden.co.uk") to a folder in the same level of your Inbox folder. Here is your code modified:
Public Sub SaveAttachments()
Dim objOL As Outlook.Application
Dim objMsg As Outlook.MailItem 'Object
Dim objAttachments As Outlook.Attachments
Dim objSelection As Outlook.Selection
Dim i As Long
Dim lngCount As Long
Dim strFile As String
Dim strFolderPath As String
Dim strDeletedFiles As String
Dim withParts As String
Dim withoutParts As String
' Get the path to your My Documents folder
On Error Resume Next
' Instantiate an Outlook Application object.
Set objOL = CreateObject("Outlook.Application")
' Get the collection of selected objects.
'Set objSelection = objOL.ActiveExplorer.Selection
'Istead set this to the selected objects you just need to set to your email folder
'This is for a inbox same level folder
Set objSelection = objOL.GetNamespace("MAPI").GetDefaultFolder(olFolderInbox).Parent.Folders("credutchecks#hewden.co.uk")
'This is for a folder inside the inbox folder
'Set objSelection = objOL.GetNamespace("MAPI").GetDefaultFolder(olFolderInbox).Folders("credutchecks#hewden.co.uk")
' The attachment folder needs to exist
' You can change this to another folder name of your choice
' Set the Attachment folder.
strFolderPath = "\\UKSH000-FILE06\Purchasing\New_Supplier_Set_Ups_&_Audits\ATTACHMENTS\"
' Check each selected item for attachments.
For Each objMsg In objSelection
Set objAttachments = objMsg.Attachments
lngCount = objAttachments.Count
If lngCount > 0 Then
' Use a count down loop for removing items
' from a collection. Otherwise, the loop counter gets
' confused and only every other item is removed.
For i = lngCount To 1 Step -1
' Get the file name.
strFile = objAttachments.item(i).FileName
If Right(strFile, 3) = "pdf" Then
' Combine with the path to the Temp folder.
withParts = strFile
withoutParts = Replace(withParts, ".pdf", "")
strFile = strFolderPath & withoutParts & "\" & strFile
' Save the attachment as a file.
objAttachments.item(i).SaveAsFile strFile
End If
Next i
End If
Next
ExitSub:
Set objAttachments = Nothing
Set objMsg = Nothing
Set objSelection = Nothing
Set objOL = Nothing
End Sub
To run it automatically when the Outlook starts just put it on the 'ThisOutlookSession' in the objects folder and name it 'Sub Application_Startup()'. Don't forget to enable macros before.
I have code that saves attachments in message in a specific Outlook folder.
My script will work if the email has an attachment, but will not work if the email was sent as an attachment with an attachment.
In this case my emails contains other emails as attachments (from an auto-forward rule). The embedded email attachments then contain excel files.
Please see my current vba below:
Public Sub SaveOlAttachments()
Dim isAttachment As Boolean
Dim olFolder As Outlook.MAPIFolder
Dim msg As Outlook.MailItem
Dim att As Outlook.Attachment
Dim fsSaveFolder, sSavePathFS, ssender As String
On Error GoTo crash
fsSaveFolder = "C:\Documents and Settings\user\Desktop\"
isAttachment = False
Set olFolder = Outlook.GetNamespace("MAPI").Folders("...email server...")
Set olFolder = olFolder.Folders("Inbox")
If olFolder Is Nothing Then Exit Sub
For Each msg In olFolder.Items
If UCase(msg.Subject) = "TEST EMAIL WITH ATTACHMENT" Then
If msg.Attachments.Count > 0 Then
While msg.Attachments.Count > 0
sSavePathFS = fsSaveFolder & msg.Attachments(1).Filename
msg.Attachments(1).SaveAsFile sSavePathFS
msg.Attachments(1).Delete
isAttachment = True
Wend
msg.Delete
End If
End If
Next
crash:
If isAttachment = True Then Call findFiles(fsSaveFolder)
End Sub
Any help would be much appreciated.
The code below uses this approach to work on the email as an attachment
Tests whether the attachment is an email message or not (if the filename ends in msg)
If the attachment is a message, it is saved as "C:\temp\KillMe.msg".
CreateItemFromTemplate is used to access the saved file as a new message (msg2)
The code then processes this temporary message to strip the attachmnets to fsSaveFolder
If the attachment is not a message then it is extracted as per your current code
Note that as I didnt have your olFolder structure, Windoes version, Outlook variable etc I have had to add in my own file paths and Outlook folders to test. You will need to change these
Sub SaveOlAttachments()
Dim olFolder As Outlook.MAPIFolder
Dim msg As Outlook.MailItem
Dim msg2 As Outlook.MailItem
Dim att As Outlook.Attachment
Dim strFilePath As String
Dim strTmpMsg As String
Dim fsSaveFolder As String
fsSaveFolder = "C:\test\"
'path for creating attachment msg file for stripping
strFilePath = "C:\temp\"
strTmpMsg = "KillMe.msg"
'My testing done in Outlok using a "temp" folder underneath Inbox
Set olFolder = Application.GetNamespace("MAPI").GetDefaultFolder(olFolderInbox)
Set olFolder = olFolder.Folders("Temp")
If olFolder Is Nothing Then Exit Sub
For Each msg In olFolder.Items
If msg.Attachments.Count > 0 Then
While msg.Attachments.Count > 0
bflag = False
If Right$(msg.Attachments(1).FileName, 3) = "msg" Then
bflag = True
msg.Attachments(1).SaveAsFile strFilePath & strTmpMsg
Set msg2 = Application.CreateItemFromTemplate(strFilePath & strTmpMsg)
End If
If bflag Then
sSavePathFS = fsSaveFolder & msg2.Attachments(1).FileName
msg2.Attachments(1).SaveAsFile sSavePathFS
msg2.Delete
Else
sSavePathFS = fsSaveFolder & msg.Attachments(1).FileName
msg.Attachments(1).SaveAsFile sSavePathFS
End If
msg.Attachments(1).Delete
Wend
msg.Delete
End If
Next
End Sub