I am a beginner.
Here is the code that I managed to realize which has for objective that when a person sends me a mail, and that this mail contains an attachment, I want that it saves the piece in a folder.
Except that it writes me an error concerning the line: " typeatt = IsEmbedded(strID, PJ.Index)"
And this code is made for all the received mails and not only the concerned person.
Can anyone help me vsp?
Private Sub Application_NewMailEx(ByVal EntryIDCollection As String)
Dim olNS As Outlook.NameSpace
Dim MyMail As Outlook.MailItem
Dim expediteur
Set olNS = Application.GetNamespace("MAPI")
Set MyMail = olNS.GetItemFromID(strID.EntryID)
If MyMail.Attachments.Count > 0 Then
sender = Item.SenderEmailAddress
If sender = "e.marques#octo-am.com" Then 'changer adresse mail
expediteur = MyMail.SenderEmailAddress
Repertoire = "C:\Users\assistant.gestion.3\Desktop\TEST" & "\" 'changer adresse
If Repertoire <> "" Then
If "" = Dir(Repertoire, vbDirectory) Then
MkDir Repertoire
End If
End If
Dim PJ, typeatt
For Each PJ In MyMail.Attachments
typeatt = IsEmbedded(strID, PJ.Index)
If typeatt = "" Then
If "" <> Dir(Repertoire & PJ.FileName, vbNormal) Then
MsgBox Repertoire & PJ.FileName & "Deja Fait"
If "" = Dir(Repertoire & "old", vbDirectory) Then
MkDir Repertoire & "old"
End If
FileCopy Repertoire & PJ.FileName, Repertoire & "old\" & PJ.FileName
End If
PJ.SaveAsFile Repertoire & PJ.FileName
End If
Next PJ
MyMail.UnRead = False
MyMail.Save
Dim myDestFolder As Outlook.MAPIFolder
Set myDestFolder = MyMail.Parent.Folders("test")
MyMail.Move myDestFolder
Else: End Sub
End If
End If
Set MyMail = Nothing
Set olNS = Nothing
End Sub
define the function and solve the problem concerning the person sending the email
Related
I'm trying to set up a macro in ThisOutlookSession to save attachments to file.
I previously used rules and 'run a script', but it is not enabled for all users.
The below code either returns a 91 error (object or variable not set), or it runs without error, but doesn't save.
The code is looking at a subfolder, to save all attachments to a location based on subject. The emails are sent to the subfolder through a rule.
I want to rename the attachments based on the ReceivedTime, and I think this is where the issue arises. If I use Msg.ReceivedTime, I get the 91 error. If I use Item.ReceivedTime, there is no error, but the file is not saved.
Here is the source where I derived most of the code and customized. https://www.tachytelic.net/2017/10/how-to-run-a-vba-macro-when-new-mail-is-received-in-outlook/
Private WithEvents folderItems As Outlook.Items
Private Sub Application_Startup()
Dim outlookApp As Outlook.Application
Dim objectNS As Outlook.NameSpace
Set outlookApp = Outlook.Application
Set objectNS = outlookApp.GetNamespace("MAPI")
Set folderItems = objectNS.GetDefaultFolder(olFolderInbox).Folders("Operations").Folders("Test").Items
End Sub
Private Sub folderItems_ItemAdd(ByVal Item As Object)
On Error GoTo ErrorHandler
Dim att As Outlook.Attachment
Dim msg As Outlook.MailItem
Dim filepath As String, filedate As String
filepath = "C:\Documents\"
filedate = Format(Item.ReceivedTime, "YYYYMMDD") 'This is the line which I think is the problem. If I do Msg.ReceivedTime, I get 91 error, but if I do Item.ReceivedTime, it does not save
If TypeName(Item) = "MailItem" Then
If InStr(Item.Subject, "XXX") > 0 Then
For Each att In Item.Attachments
att.SaveAsFile filepath & "XXX\" & filedate & "_raw.csv"
Next
ElseIf InStr(Item.Subject, "YYY") > 0 Then
For Each att In Item.Attachments
att.SaveAsFile filepath & "YYY\" & filedate & "_raw.xlsx"
Next
ElseIf InStr(Item.Subject, "ZZZ") > 0 Then
For Each att In Item.Attachments
att.SaveAsFile filepath & "ZZZ.csv"
Next
End If
End If
ExitNewItem:
Exit Sub
ErrorHandler:
MsgBox Err.Number & " - " & Err.Description
Resume ExitNewItem
End Sub
My hypothesis is that the ReceivedTime is the issue. If I can use Msg.ReceivedTime, how do I set the variable? Or, if Item.ReceivedTime is correct, why does it not save?
Try the following
Dim att As Outlook.attachment
Dim msg As Outlook.MailItem
Dim filepath As String, filedate As String
filepath = "C:\Documents\"
If TypeName(Item) = "MailItem" Then
Set msg = Item
Debug.Print msg.ReceivedTime ' print on Immediate Window
filedate = Format(msg.ReceivedTime, "YYYYMMDD")
If InStr(msg.Subject, "XXX") > 0 Then
For Each att In msg.Attachments
att.SaveAsFile filepath & "XXX\" & filedate & "_raw.csv"
Next
ElseIf InStr(msg.Subject, "YYY") > 0 Then
For Each att In msg.Attachments
att.SaveAsFile filepath & "YYY\" & filedate & "_raw.xlsx"
Next
ElseIf InStr(msg.Subject, "ZZZ") > 0 Then
For Each att In msg.Attachments
att.SaveAsFile filepath & "ZZZ.csv"
Next
End If
End If
also you don't need outlookApp when the code is running within Outlook Application, simply use Application.
Example
Private Sub Application_Startup()
Dim objectNS As Outlook.NameSpace
Set objectNS = Application.GetNamespace("MAPI")
Set folderItems = objectNS.GetDefaultFolder(olFolderInbox) _
.Folders("Operations") _
.Folders("Test").Items
End Sub
I get a generated report by Oracle web app every week. I got a macro working to extract that attachment report from my email, but for some reason the date filter doesn't do anything and it saves all the attachments with the email subject "VERIPRD: XXVER Veritiv Aging Report Main: PETROP01" (which is the subject of the report that I want, but I get this weekly, and I only need to extract the most current one)
Also, the report comes with a .out extension which can be opened up with Excel, but if I save that file within the macros as xlsx it gets corrupted.
So what I need is for this macro to actually filter by date, and Subject line (mentioned above), save the .out file as an Excel file titled "Aging Report" and, if there's already an "Aging Report" in destination folder, to replace that previous excel file and not prompt with a message asking me if I want to replace it.
Here's the code I have so far which I put in MS outlook:
Public Sub Extract_Outlook_Email_Attachments()
Dim OutlookOpened As Boolean
Dim outApp As Outlook.Application
Dim outNs As Outlook.NameSpace
Dim outFolder As Outlook.MAPIFolder
Dim outAttachment As Outlook.attachment
Dim outItem As Object
Dim saveFolder As String
saveFolder = "C:\Users\borjax01\Desktop\aging reports"
Dim outMailItem As Outlook.MailItem
Dim inputDate As String, subjectFilter As String
If Right(saveFolder, 1) <> "\" Then saveFolder = saveFolder & "\" & "Aging
Report.out"
inputDate = InputBox("Enter date to filter the email subject", "Extract
Outlook email attachments")
If inputDate = "" Then Exit Sub
InputDateFilter = inputDate
subjectFilter = ("VERIPRD : XXVER Veritiv Aging Report Main : PETROP01")
OutlookOpened = False
On Error Resume Next
Set outApp = GetObject(, "Outlook.Application")
If Err.Number <> 0 Then
Set outApp = New Outlook.Application
OutlookOpened = True
End If
On Error GoTo 0
If outApp Is Nothing Then
MsgBox "Cannot start Outlook.", vbExclamation
Exit Sub
End If
Set outNs = outApp.GetNamespace("MAPI")
Set outFolder = outNs.PickFolder
If Not outFolder Is Nothing Then
For Each outItem In outFolder.Items
If outItem.Class = Outlook.OlObjectClass.olMail Then
Set outMailItem = outItem
If outMailItem.Subject = subjectFilter Then
Debug.Print outMailItem.Subject
For Each outAttachment In outMailItem.Attachments
outAttachment.SaveAsFile saveFolder
Set outAttachment = Nothing
Next
End If
End If
Next
End If
If OutlookOpened Then outApp.Quit
Set outApp = Nothing
End Sub
A post might get answers more quickly if broken into multiple single questions as is expected in this Q & A.
Public Sub Extract_Outlook_Email_Attachments()
Dim OutlookOpened As Boolean
Dim OutApp As outlook.Application
Dim outNs As outlook.Namespace
Dim outFolder As outlook.MAPIFolder
Dim outAttachment As outlook.Attachment
Dim outItem As Object
Dim saveFolder As String
Dim outMailItem As outlook.MailItem
Dim inputDate As String, subjectFilter As String
Dim fldrItems As Items
Dim resultItems As Items
Dim strFilter As String
saveFolder = "C:\Users\borjax01\Desktop\aging reports"
saveFolder = "H:\test2"
'If Right(saveFolder, 1) <> "\" Then saveFolder = saveFolder & "\" & "Aging Report.out"
If Right(saveFolder, 1) <> "\" Then saveFolder = saveFolder & "\"
' subjectFilter = ("VERIPRD : XXVER Veritiv Aging Report Main : PETROP01")
' No "Re:" nor "Fw:"
subjectFilter = "VERIPRD : XXVER Veritiv Aging Report Main : PETROP01"
OutlookOpened = False
On Error Resume Next
Set OutApp = getObject(, "Outlook.Application")
If Err.number <> 0 Then
Set OutApp = New outlook.Application
OutlookOpened = True
End If
On Error GoTo 0
If OutApp Is Nothing Then
MsgBox "Cannot start Outlook.", vbExclamation
Exit Sub
End If
Set outNs = OutApp.GetNamespace("MAPI")
Set outFolder = outNs.PickFolder
If Not outFolder Is Nothing Then
Set fldrItems = outFolder.Items
strFilter = "[Subject] = '" & subjectFilter & "'"
Debug.Print strFilter
Set resultItems = fldrItems.Restrict(strFilter)
'Debug.Print resultItems.count
resultItems.Sort "[ReceivedTime]", True
For Each outItem In resultItems
If outItem.Class = outlook.OlObjectClass.olMail Then
Set outMailItem = outItem
If outMailItem.subject = subjectFilter Then
Debug.Print " outMailItem.subject: " & outMailItem.subject
Debug.Print " outMailItem.ReceivedTime: " & outMailItem.ReceivedTime
For Each outAttachment In outMailItem.Attachments
Debug.Print " outAttachment.DisplayName: " & outAttachment.DisplayName
If InStr(outAttachment.DisplayNamem, ".out") Then
outAttachment.SaveAsFile saveFolder & outAttachment.DisplayName
Exit Sub '<-- exit when most recent is saved
End If
Next
End If
End If
Next
End If
If OutlookOpened Then OutApp.Quit
Set OutApp = Nothing
End Sub
I have macro that searches for a subject and if found copy the email in another folder. My problem is that it copies the email 4 times instead of only once. If i have 10 emails in the original folder "Left Ones" then, after search and copy i will have 40 emails in the folder "TO BE REMOVED" . Any help is welcomed, thank you.
Sub Search_Inbox()
Dim myOlApp As New Outlook.Application
Dim objNamespace As Outlook.NameSpace
Dim objFolder As Outlook.MAPIFolder
Dim filteredItems As Outlook.Items
Dim itm As Object
Dim Found As Boolean
Dim strFilter As String
Dim subject_to_find As String
Dim myDestFolder As Outlook.Folder
subject_to_find = "something"
Set objNamespace = myOlApp.GetNamespace("MAPI")
Set objFolder = OpenOutlookFolder("\\Mailbox - ME\Inbox\Left Ones")
strFilter = "#SQL=" & Chr(34) & "urn:schemas:httpmail:subject" & Chr(34) & " like '%" & subject_to_find & "%'"
Set filteredItems = objFolder.Items.Restrict(strFilter)
If filteredItems.Count = 0 Then
Debug.Print "No emails found"
Found = False
Else
Found = True
For Each itm In filteredItems
If itm.Class = olMail Then
Debug.Print itm.Subject
Debug.Print itm.ReceivedTime
End If
Set myDestFolder = Session.Folders("Mailbox - ME").Folders("TO BE REMOVED")
For i = filteredItems.Count To 1 Step -1
Dim myCopiedItem As Object
Set myCopiedItem = filteredItems(i).Copy
myCopiedItem.Move myDestFolder
Next i
Next itm
End If
'If the subject isn't found:
If Not Found Then
'NoResults.Show
Else
Debug.Print "Found " & filteredItems.Count & " items."
End If
Set myOlApp = Nothing
End Sub
After
Else
Found = True
add the line
Debug.Print filteredItems.Count
This is to check the number of items found. This way, you can definitely see if VBA actually finds 40 emails (for whatever reason), or if it just copies it 4 times later on.
Also try Changing
Next i
to
i = i + 1
Edit:
Cut the
Next itm
and move it to the end of this block:
For Each itm In filteredItems
If itm.Class = olMail Then
Debug.Print itm.Subject
Debug.Print itm.ReceivedTime
End If
Next itm 'move it here
For future searchers here is the working code to find all the emails with a given subject in a subfolder - Inbox\Left Ones - and copy them in another subfolder - Inbox\TO BE REMOVED - ( note that it will leave out the undelivered notification ) :
Sub Search_Inbox_Subfolder_Left_Ones()
Dim objFolder As Outlook.MAPIFolder
Dim filteredItems As Outlook.Items
Dim itm As Object
Dim Found As Boolean
Dim strFilter As String
Dim subject_to_find As String
Dim myDestFolder As Outlook.Folder
Dim myCopiedItem As Object
subject_to_find = "something to find"
Set objFolder = OpenOutlookFolder("\\Mailbox - ME\Inbox\Left Ones")
strFilter = "#SQL=" & Chr(34) & "urn:schemas:httpmail:subject" & Chr(34) & " like '%" & subject_to_find & "%'"
Set filteredItems = objFolder.Items.Restrict(strFilter)
If filteredItems.Count = 0 Then
Debug.Print "No emails found"
Found = False
Else
Found = True
Set myDestFolder = Session.Folders("Mailbox - ME").Folders("TO BE REMOVED")
For i = filteredItems.Count To 1 Step -1
If filteredItems(i).Class = olMail Then
Set myCopiedItem = filteredItems(i).Copy
myCopiedItem.Move myDestFolder
End If
Next i
End If
'If the subject isn't found:
If Not Found Then
'NoResults.Show
Else
Debug.Print "Found " & filteredItems.Count & " items."
End If
Set myOlApp = Nothing
End Sub
Private Function OpenOutlookFolder(strFolderPath As String) As Outlook.MAPIFolder
Dim arrFolders As Variant, _
varFolder As Variant, _
bolBeyondRoot As Boolean
On Error Resume Next
If strFolderPath = "" Then
Set OpenOutlookFolder = Nothing
Else
Do While Left(strFolderPath, 1) = "\"
strFolderPath = Right(strFolderPath, Len(strFolderPath) - 1)
Loop
arrFolders = Split(strFolderPath, "\")
For Each varFolder In arrFolders
Select Case bolBeyondRoot
Case False
Set OpenOutlookFolder = Outlook.Session.Folders(varFolder)
bolBeyondRoot = True
Case True
Set OpenOutlookFolder = OpenOutlookFolder.Folders(varFolder)
End Select
If Err.Number <> 0 Then
Set OpenOutlookFolder = Nothing
Exit For
End If
Next
End If
On Error GoTo 0
End Function
I would like to extract the values in a drop-down field with the title "email address".
I would like the name selected to appear in the email "To" line.
I'm adding the ActiveDocument details to the subject line but would like to remove the .docx portion of the subject line.
Do I need separate Outlook code?
Sub RunAll()
Call Save
Call sendeMail
End Sub
Sub Save()
Dim strPath As String
Dim strPlate As String
Dim strName As String
Dim strFilename As String
Dim oCC As ContentControl
strPath = "C:\Users\******x\Desktop\Test 4"
CreateFolders strPath
On Error GoTo err_Handler
Set oCC = ActiveDocument.SelectContentControlsByTitle("License Plate Number").Item(1)
If oCC.ShowingPlaceholderText Then
MsgBox "Complete the License plate number!"
oCC.Range.Select
GoTo lbl_Exit
Else
strPlate = oCC.Range.Text
End If
Set oCC = ActiveDocument.SelectContentControlsByTitle("Customer Name").Item(1)
If oCC.ShowingPlaceholderText Then
MsgBox "Complete the Customer Name!"
oCC.Range.Select
GoTo lbl_Exit
Else
strName = oCC.Range.Text
End If
strFilename = strPlate & "__" & strName & ".docx"
ActiveDocument.SaveAs2 FileName:=strPath & strFilename, FileFormat:=12
lbl_Exit:
Set oCC = Nothing
Exit Sub
err_Handler:
MsgBox Err.Number & vbCr & Err.Description
Err.Clear
GoTo lbl_Exit
End Sub
Private Sub CreateFolders(strPath As String)
Dim oFSO As Object
Dim lngPathSep As Long
Dim lngPS As Long
If Right(strPath, 1) <> "\" Then strPath = strPath & "\"
lngPathSep = InStr(3, strPath, "\")
If lngPathSep = 0 Then GoTo lbl_Exit
Set oFSO = CreateObject("Scripting.FileSystemObject")
Do
lngPS = lngPathSep
lngPathSep = InStr(lngPS + 1, strPath, "\")
If lngPathSep = 0 Then Exit Do
If Len(Dir(Left(strPath, lngPathSep), vbDirectory)) = 0 Then Exit Do
Loop
Do Until lngPathSep = 0
If Not oFSO.FolderExists(Left(strPath, lngPathSep)) Then
oFSO.CreateFolder Left(strPath, lngPathSep)
End If
lngPS = lngPathSep
lngPathSep = InStr(lngPS + 1, strPath, "\")
Loop
lbl_Exit:
Set oFSO = Nothing
Exit Sub
End Sub
Private Sub sendeMail()
Dim olkApp As Object
Dim strSubject As String
Dim strTo As String
Dim strBody As String
Dim strAtt As String
strSubject = "VR*** Request: " + ActiveDocument + " CUSTOMER IS xx xx xx"
strBody = ""
strTo = ""
If ActiveDocument.FullName = "" Then
MsgBox "activedocument not saved, exiting"
Exit Sub
Else
If ActiveDocument.Saved = False Then
If MsgBox("Activedocument NOT saved, Proceed?", vbYesNo, "Error") <> vbYes Then Exit Sub
End If
End If
strAtt = ActiveDocument.FullName
Set olkApp = CreateObject("outlook.application")
With olkApp.createitem(0)
.To = strTo
.Subject = strSubject
.body = strBody
.attachments.Add strAtt
'.send
.Display
End With
Set olkApp = Nothing
End Sub
To get the doc's name without the extension, you can use this:
Left(ActiveDocument.Name, InStrRev(ActiveDocument.Name, ".") - 1)
InStrRev finds the last "dot" .
Left truncates the name until that position
-1 applied to the found position is to also remove the . itself
For example,
strSubject = "VR*** Request: " & Left(ActiveDocument.Name, InStrRev(ActiveDocument.Name, ".") - 1) & " CUSTOMER IS xx xx xx"
Addendum
To get the email address from a content-control titled "email address", you can use this function:
Function getEmailAddress()
Dim sh As ContentControl
For Each sh In ThisDocument.Range.ContentControls
If sh.Title = "email address" Then
getEmailAddress = sh.Range.Text
Exit Function
End If
Next
End Function
i.e.
With olkApp.createitem(0)
.To = getEmailAddress
' etc...
I have this VBA code that allows to add contact from an Outlook selected folder or selected messages :
' The AddAddressesToContacts procedure can go in any Module
' Select the mail folder and any items to add to contacts, then run the macro
Public Sub AddAddressesToContacts()
Dim folContacts As Outlook.MAPIFolder
Dim colItems As Outlook.Items
Dim oContact As Outlook.ContactItem
Dim oMail As Outlook.MailItem
Dim obj As Object
Dim oNS As Outlook.NameSpace
Dim response As VbMsgBoxResult
Dim bContinue As Boolean
Dim sSenderName As String
On Error Resume Next
Set oNS = Application.GetNamespace("MAPI")
Set folContacts= oNS.GetDefaultFolder(olFolderContacts)
Set colItems= folContacts.Items
For Each obj In Application.ActiveExplorer.Selection
If obj.Class = olMail Then
Set oContact= Nothing
bContinue= True
sSenderName= ""
Set oMail = obj
sSenderName = oMail.SentOnBehalfOfName
If sSenderName = ";" Then
sSenderName = oMail.SenderName
End If
Set oContact = colItems.Find("[FullName] = '" & sSenderName & "'")
If Not (oContact Is Nothing) Then
response = MsgBox("This appears to be an existing contact: " & sSenderName & ". Do you still want to add it as a new contact?", vbQuestion + vbYesNo, "Contact Adder")
If response = vbNo Then
bContinue = False
End If
End If
If bContinue Then
Set oContact = colItems.Add(olContactItem)
With oContact
.Body = oMail.Subject
.Email1Address = oMail.SenderEmailAddress
.Email1DisplayName = sSenderName
.Email1AddressType = oMail.SenderEmailType
.FullName = oMail.SenderName
.Save
End With
End If
End If
Next
Set folContacts = Nothing
Set colItems = Nothing
Set oContact = Nothing
Set oMail = Nothing
Set obj = Nothing
Set oNS = Nothing
End Sub
I would like to go to the next address if the current address exists into the address book.
For the moment, I have this code :
If Not (oContact Is Nothing) Then
response = MsgBox("This appears to be an existing contact: " & sSenderName & ". Do you still want to add it as a new contact?", vbQuestion + vbYesNo, "Contact Adder")
If response = vbNo Then
bContinue = False
End If
But how to ignore the address already recorded in the address book ?
To go to the next address if the current address exists in the address book.
If Not (oContact Is Nothing) Then
bContinue = False
End If