I'm new to VB and have been struggling to try and create a VBA macro that will automatically perform the following tasks upon email receival:
1) Checks to see if the email originated internally, or externally. (If external ignore)
2) Checks to see if the email has an attachment. (If no attachment, then ignore)
3) Checks the attachment name, should be like "report" (full name is generally "Report 12198 blah blah.pdf"). (If attachment name is not like "report" then ignore)
4) Save the attachment in G:\\Test
5) Move the email to an Outlook folder named "Completed"
I've seen many sites that have code for saving attachments, moving emails to folders but no one else seems to have had the same issue as me; combining these two.
I initially thought I could use Outlook Rules to help do some of this, but the code I have so far (for saving attachments) doesn't show up as a script.
In addition I've read on a site (can't remember which one) that you can't use a 'For Each' loop when trying to do things such as 'Move' or 'Delete', so I'm not too sure if the code below should be useable.
Any help would be greatly appreciated. This is the code I have at the moment:
Sub GetAttachments()
On Error GoTo GetAttachments_err
Dim ns As NameSpace
Dim Inbox As MAPIFolder
Dim Item As Object
Dim Atmt As Attachment
Dim StringLength As Long
Dim FileName As String
Dim i As Integer
Set ns = GetNamespace("MAPI")
Set Inbox = ns.GetDefaultFolder(olFolderInbox)
i = 0
If Inbox.Items.Count = 0 Then
MsgBox "There are no messages in the Inbox.", vbInformation, _
"Nothing Found"
Exit Sub
End If
For Each Item In Inbox.Items
For Each Atmt In Item.Attachments
If Left(Atmt.FileName, 6) Like "*REPORT*" Then
StringLength = Len(Atmt.FileName)
FileName = "G:\Test\" & Left(Atmt.FileName, (StringLength - 13)) & Format(Item.CreationTime, "ddmmmyyyy") & ".pdf"
Atmt.SaveAsFile FileName
i = i + 1
End If
Next Atmt
Next Item
If i > 0 Then
MsgBox "I found " & i & " attached files." _
& vbCrLf & "I have saved them into the Test Folder." _
& vbCrLf & vbCrLf & "Have a nice day.", vbInformation, "Finished!"
Else
MsgBox "I didn't find any attached files in your mail.", vbInformation, _
"Finished!"
End If
GetAttachments_exit:
Set Atmt = Nothing
Set Item = Nothing
Set ns = Nothing
Exit Sub
GetAttachments_err:
MsgBox "An unexpected error has occurred." _
& vbCrLf & "Please note and report the following information." _
& vbCrLf & "Macro Name: GetAttachments" _
& vbCrLf & "Error Number: " & Err.Number _
& vbCrLf & "Error Description: " & Err.Description _
, vbCritical, "Error!"
Resume GetAttachments_exit
Exit Sub
End Sub
I think the problem is in the declaration part.
Try to change this:
Dim ns As NameSpace
Dim Inbox As MAPIFolder
Dim Atmt As Attachment
Dim Item as Object
with this:
Dim ns As outlook.NameSpace
Dim Inbox As outlook.MAPIFolder
Dim Atmt As outlook.Attachment
Dim Item as outlook.MailItem
Then in your code, you only check for the attachments?
I can't seem to find the checking for internal or external?
to check every incoming mail when received you have to do the following:
First put in "ThisOutlookSession"
Option Explicit
Private WithEvents objInspectors As Outlook.Inspectors
Public WithEvents myreceivedItems As Outlook.Items
Private Sub Application_Startup()
Set objInspectors = Outlook.Inspectors
Dim folder As Outlook.MAPIFolder
Set folder = oNamespace.GetDefaultFolder(olFolderInbox)
Set myreceivedItems = folder.Items
End Sub
Private Sub myreceivedItems_ItemAdd(ByVal ItemMail As Object)
If ItemMail.Class = olMail Then Call whatdotowithyourincomingmails(ItemMail, true)
End Sub
whatdotowithyourincomingmails would be the Sub that is called with every mail you receive. This can be in any module, I would not put it into thisoutlooksession.
the code there could be like below. I did copy my own code and changed it to your Needs, I think it should work. The Folder completed has to be a subfolder of your inbox. The subject of the mail will be changed, as you can see in the code - this is just to make sure you know why the mail is in completed. If the attachment as file already exists in G:\\test, the attachment is ignored. Of course that could be changed in any way (adding timestamp, ideleting existing files,...) Only mails will be moved, that have exactly one attachment with "Report" at the beginning of the Name. Other attachments will be ignored.
Sub whatdotowithyourincomingmails (olitem As Outlook.MailItem, verschieben As Boolean)
'On Error GoTo exit_sub
Dim lngAttCount As Long, i As Long
Dim Datei As String
Dim anzahl_pdf As Integer
Dim anzahl As Integer
lngAttCount = olitem.Attachments.Count
anzahl_pdf = 0
'Zählen pdfs:
If lngAttCount = 0 Then GoTo Ende_nix
For i = lngAttCount To 1 Step -1
With olitem.Attachments.Item(i)
If LCase(Mid(.FileName, 1, 6)) = "report" Then anzahl_pdf = anzahl_pdf + 1
End With
Next i
'verarbeiten wenn 1 pdf
If Not anzahl_pdf = 1 Then GoTo Ende_nix
For i = lngAttCount To 1 Step -1
With olitem.Attachments.Item(i)
If not LCase(Mid(.FileName, 1, 6)) = "report" Then GoTo naechste
Datei = "g:\test\" & .FileName
If CreateObject("Scripting.FileSystemObject").FileExists(Datei) = True Then
GoTo Ende_nix
Else
.SaveAsFile Datei
anzahl = anzahl + 1
End If
End With
naechste:
Next i
olitem.Subject = olitem.Subject & " || autosaveandmove"
If verschieben = True Then
Call movesomewhereelse(olitem, "completed")
End If
Ende_nix:
exit_sub:
End Sub
Sub movesomewhereelse(olitem As MailItem, move_to_as string)
Dim olfolder As MAPIFolder
Dim folderPath As String
'the next line is looking in which Folder the item is; if you are always working with inbox it can be replaced by the path
folderPath = GetPath_auto(olitem)
Set olfolder = GetFolder(folderPath)
On Error GoTo exit_sub
Dim Subfolder As Outlook.MAPIFolder
Set Subfolder = olfolder.Folders(move_to_as)
olitem.UnRead = False
olitem.Move Subfolder
exit_sub: Exit Sub
End Sub
Public Function GetFolder(strFolderPath As String) As MAPIFolder
' strFolderPath needs to be something like
' "Public Folders\All Public Folders\Company\Sales" or
' "Personal Folders\Inbox\My Folder"
On Error GoTo schas
Dim objApp As Outlook.Application
Dim objNS As Outlook.NameSpace
Dim colFolders As Outlook.Folders
Dim objFolder As Outlook.MAPIFolder
Dim arrFolders() As String
Dim i As Long
' On Error Resume Next
strFolderPath = Replace(strFolderPath, "\\", "")
strFolderPath = Replace(strFolderPath, "/", "\")
arrFolders() = Split(strFolderPath, "\")
Set objApp = Application
Set objNS = objApp.GetNamespace("MAPI")
Set objFolder = objNS.Folders.Item(arrFolders(0))
If Not objFolder Is Nothing Then
For i = 1 To UBound(arrFolders)
Set colFolders = objFolder.Folders
Set objFolder = Nothing
Set objFolder = colFolders.Item(arrFolders(i))
If objFolder Is Nothing Then
Exit For
End If
Next
End If
Set GetFolder = objFolder
GoTo ende
schas:
'MsgBox ("Ordner für verschieben nicht gefunden")
ende:
Set colFolders = Nothing
Set objNS = Nothing
Set objApp = Nothing
End Function
Function GetPath_auto(Item As MailItem) As String
'gibt des gesamten Pfad des items zurück
Dim folder As Outlook.MAPIFolder
Dim folderPath As String
Set folder = Item.Parent
folderPath = folder.Name
Do Until folder.Parent = "Mapi" Or folder.Parent = "Freigegebene Daten" 'Or folder.Parent = "Stamm - Postfach"
Set folder = folder.Parent
folderPath = folder.Name & "\" & folderPath
Loop
GetPath_auto = folderPath
End Function
By the way, if you want to use your script as a rule, define function as
Sub GetAttachments(mItem As MailItem)
It will then appear in the list of functions when editing a rule
The technical post webpages of this site follow the CC BY-SA 4.0 protocol. If you need to reprint, please indicate the site URL or the original address.Any question please contact:yoyou2525@163.com.