vba outlook - reply from a file from a folder - vba

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.

Related

Permission error running "Application.CreateItemFromTemplate" method on an EML file

I'm trying to run a macro that copies EML files into my inbox.
When I get to the Application.CreateItemFromTemplate line to apply it to an EML file I get a runtime error:
We can't open [filename.path]. It's possible the file is already open, or you don't have permission to open it.
I tried running Outlook as ADMIN. Also tried the Session.OpenSharedItem method. I'm using Outlook for Microsoft 365 MSO.
Full code:
Sub ImportMessagesToOutlookFolder()
Dim fso As Scripting.FileSystemObject
Dim SourceFolder As Scripting.Folder
Dim SourceFolderName As String
Dim FileItem As Scripting.File
Dim strFile, strFileType As String
Dim oMsg As Object
Dim objNS As NameSpace
Dim copiedMsg As MailItem
Dim Savefolder As Outlook.Folder
Set fso = New Scripting.FileSystemObject 'Source folder
'Ask for folder with items to import
SourceFolderName = BrowseForFolder("My Computer")
Set SourceFolder = fso.GetFolder(SourceFolderName)
'Set the Outlook folder name
Set objNS = Application.GetNamespace("MAPI")
Set Savefolder = objNS.PickFolder
For Each FileItem In SourceFolder.Files
'Set oMsg = FileItem
Set oMsg = Outlook.Application.CreateItemFromTemplate(FileItem.Path)
'On Error Resume Next
Set copiedMsg = oMsg.Copy
copiedMsg.Move Savefolder
Set copiedMsg = Nothing
Debug.Print FileItem.Name & " " & FileItem.DateCreated
oMsg.Delete
Set oMsg = Nothing
'FileItem.Delete
Next FileItem
Set FileItem = Nothing
Set SourceFolder = Nothing
Set fso = Nothing
End Sub
The Application.CreateItemFromTemplate method creates a new Microsoft Outlook item from an Outlook template (.oft) and returns the new item. It is not designed for EML files by default. You may try to use the ShellExecute method for opening EML in the default application (you can set Outlook, see Open .eml Files in Outlook for more information):
Dim objShell : Set objShell = CreateObject("Shell.Application")
Dim objFolder : Set objFolder = objShell.BrowseForFolder(0, "Select the folder containing eml-files", 0)
Dim Item
If (NOT objFolder is Nothing) Then
Set WShell = CreateObject("WScript.Shell")
Set objOutlook = CreateObject("Outlook.Application")
Set Folder = objOutlook.Session.PickFolder
If NOT Folder Is Nothing Then
For Each Item in objFolder.Items
If Right(Item.Name, 4) = ".eml" AND Item.IsFolder = False Then
objShell.ShellExecute Item.Path, "", "", "open", 1
WScript.Sleep 1000
Set MyInspector = objOutlook.ActiveInspector
Set MyItem = objOutlook.ActiveInspector.CurrentItem
MyItem.Move Folder
End If
Next
End If
End If
MsgBox "Import completed.", 64, "Import EML"
Set objFolder = Nothing
Set objShell = Nothing

How to exclude documents based on standard format name when sending e-mails?

We have a macro that sends e-mails of documents in a certain directory. We want to exclude documents whose file names begin with "AUT_XXXXXX" ETA: the Xs can be a string of letters and numbers that vary.
Sub SendScannedDocstoWellsFargo()
Dim Filename As Variant
Dim olApp As Outlook.Application
Dim olNewEmail As Outlook.MailItem
Dim strDirectory As String
Dim strPath As String
Dim FSO As FileSystemObject
Set FSO = CreateObject("Scripting.FileSystemObject")
Set olApp = Outlook.Application
Filename = Dir("\\kwa-file01\ClientFiles\Wells Fargo III\_Scanned_Documents\Pending Uploads\")
strDirectory = "\\kwa-file01\ClientFiles\Wells Fargo III\_Scanned_Documents\Pending Uploads\"
While Filename <> ""
'Comment out when completed
'Debug.Print Filename
'Set the filename to the next file
Filename = Dir
'Create a path for the item
strPath = strDirectory & Filename
If strPath = strDirectory Then GoTo StopThisNow
'Create a mail item
Set olNewEmail = olApp.CreateItem(olMailItem)
With olNewEmail
.To = "ccslegaldocuments#wellsfargo.com"
.Subject = Filename
.Attachments.Add (strPath)
.Send
End With
FSO.DeleteFile strPath, True
Set olNewEmail = Nothing
StopThisNow:
Wend
Set olApp = Nothing
Set olNewEmail = Nothing
strDirectory = ""
Filename = ""
strPath = ""
End Sub
I've seen posts showing how to exclude PDFs.
Give this a try.
Read the code's comments and adjust it to fit your needs.
EDIT: Changed to Like statement with wildcards
Public Sub SendScannedDocstoWellsFargo()
' Define the folder path
Dim folderPath As String
folderPath = "C:\Temp\" ' "\\kwa-file01\ClientFiles\Wells Fargo III\_Scanned_Documents\Pending Uploads\"
' Define the file name string to exclude
Dim stringExclude As String
stringExclude = "AUT_??????"
' Set a referece to the FSO object
Dim FSO As FileSystemObject
Set FSO = CreateObject("Scripting.FileSystemObject")
' Set a reference to Outlook application
Dim outlookApp As Outlook.Application
Set outlookApp = Outlook.Application
' Get files in folder
Dim fileName As String
fileName = Dir(folderPath)
' Loop through files
Do While fileName <> ""
If Not Left(fileName, Len(stringExclude)) Like stringExclude Then
' Build the file path
Dim filePath As String
filePath = folderPath & fileName
' Send the email by calling a procedure
sendEmail outlookApp, filePath, fileName
' Delete the file
FSO.DeleteFile filePath, True
End If
' Call next file
fileName = Dir
Loop
' Clean up outlook reference
Set outlookApp = Nothing
End Sub
Private Sub sendEmail(ByVal outlookApp As Outlook.Application, ByVal filePath As String, ByVal fileName As String)
Dim olNewEmail As Outlook.MailItem
'Create a mail item
Set olNewEmail = outlookApp.CreateItem(olMailItem)
With olNewEmail
.To = "ccslegaldocuments#wellsfargo.com"
.Subject = fileName
.Attachments.Add filePath
.Send
End With
Set olNewEmail = Nothing
End Sub
Let me know if it works

Move messages from file system to Outlook folder

I can move emails to my file system. Is it possible to do the reverse? This is what I have tried:
Sub GetMSG()
Dim StrFolder As String
StrFolder = "G:\CP-Purchasing\Completed Projects"
ListFilesInFolder StrFolder, True 'True includes subfolders, false check only this folder
End Sub
Sub ListFilesInFolder(SourceFolderName As String, IncludeSubfolders As Boolean)
Dim FileItem As Scripting.File
Dim strFile, strFileType
Dim MyMsg As MailItem
Dim FolderPick As Folder
Set FSO = New Scripting.FileSystemObject
Set SourceFolder = FSO.GetFolder(SourceFolderName)
Set FolderPick = Application.GetNamespace("MAPI").PickFolder
For Each FileItem In SourceFolder.Files
strFile = FileItem.Name
' This code looks at the last 4 characters in a filename
strFileType = LCase$(Right$(strFile, 4))
If strFileType = ".msg" Then
Debug.Print FileItem.Path
Set MyMsg = Application.CreateItemFromTemplate(FileItem.Path)
MyMsg.SaveAs (FolderPick)'This does not error, but also does not seem to work
MyMsg.Move (FolderPick)'This errors
Set objAttachments = Nothing
Set MyMsg = Nothing
End If
Next FileItem
If IncludeSubfolders Then
For Each SubFolder In SourceFolder.SubFolders
ListFilesInFolder SubFolder.Path, True
Next SubFolder
End If
Set FileItem = Nothing
Set SourceFolder = Nothing
Set FSO = Nothing
End Sub
On MyMsg.SaveAs (FolderPick) I get no error message, but it also does not save the msg in the specified folder.
MyMsg.Move (FolderPick) errors with
run-time error 424 "Object required".
For further processing after the move, you need another object since the reference to myMsg is lost.
Set myCopiedMsg = myMsg.Move(folderPick)
Debug.Print myCopiedMsg.Parent.FolderPath
In your code for moving only:
' no brackets
myMsg.Move folderPick

Save outlook email to my internal drive as .msg file

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

Extract Zipped file from Outlook mail

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.