I have developed a form in excel, which is sending an email to a mailbox. This part is working fine.
Now i'm looking to develop an "back-office" excel workbook Which would allow to :
Drag and drop email from outlook to an excel button
Save this email to a folder
Reading this email, and saving all parts (sender's email, subject, body, ...) in an excel spreadsheet.
I'm trying to do the import phase (drag and drop from outlook) but didn't find the way to do this...
Thanks for your help
You cannot drop an email on a button (well, you can but ...)
Instead create an editbox (Outlookbox) and tie it to an event handler.
Here's some code to get you started:
Private Sub Outlookbox_Change()
Dim olApp As Object 'Outlook.Application
Dim olExp As Object 'Outlook.Explorer
Dim olSel As Object 'Outlook.Selection
Dim i As Integer
Dim theSender as String
Dim theDate as String
Dim theRecipient as String
Dim theSubject as String
Dim theMessage as String
Set olApp = GetObject("", "Outlook.Application")
Set olExp = olApp.ActiveExplorer
Set olSel = olExp.Selection
For i = 1 To olSel.Count ' If multiple emails dropped
With olSel.Item(i) ' For each email
theSender = .Sender
theDate = .ReceivedTime
theRecipient = .To
theSubject = .Subject
theMessage = .Body
End With
Next i
End Sub
Related
I want to send the body of a Word document as an email from MS Word 2016.
I want the user to select recipients from the address book. I want them to only be put in the BCC field.
How do I monitor the to/from/CC/BCC fields for changes, and then move those changes to BCC?
The documentation indicates the use of Inspectors, but nothing specific about accessing the contents of these fields.
I have two approaches:
open a new Outlook mail item, load the contents of the Word file to it, and then try to monitor the fields that way.
send directly from Word using the Quick Access Toolbar option "Send to Mail Recipient".
I don't know if that is an option based on what I was reading and if those fields are accessible via VBA.
Code example of what I have so far:
Sub SendDocumentInMail()
Dim bStarted As Boolean
Dim oOutlookApp As Outlook.Application
Dim oItem As Outlook.MailItem
On Error Resume Next
'Get Outlook if it's running
Set oOutlookApp = GetObject(, "Outlook.Application")
If Err <> 0 Then
'Outlook wasn't running, start it from code
Set oOutlookApp = CreateObject("Outlook.Application")
bStarted = True
End If
'Create a new mailitem
Set oItem = oOutlookApp.CreateItem(olMailItem)
With oItem
'Set the recipient for the new email
.To = "recipient#mail.com"
'Set the recipient for a copy
.CC = "recipient2#mail.com"
'Set the subject
.Subject = "New subject"
'The content of the document is used as the body for the email
.Body = ActiveDocument.Content
.Send
End With
If bStarted Then
'If we started Outlook from code, then close it
oOutlookApp.Quit
End If
'Clean up
Set oItem = Nothing
Set oOutlookApp = Nothing
End Sub
It seems you are interested in the SelectNamesDialog object which displays the Select Names dialog box for the user to select entries from one or more address lists, and returns the selected entries in the collection object specified by the property SelectNamesDialog.Recipients.
The dialog box displayed by SelectNamesDialog.Display is similar to the Select Names dialog box in the Outlook user interface. It observes the size and position settings of the built-in Select Names dialog box. However, its default state does not show Message Recipients above the To, Cc, and Bcc edit boxes.
The following code sample shows how to create a mail item, allow the user to select recipients from the Exchange Global Address List in the Select Names dialog box, and if the user has selected recipients that can be completely resolved, then send the mail item.
Sub SelectRecipients()
Dim oMsg As MailItem
Set oMsg = Application.CreateItem(olMailItem)
Dim oDialog As SelectNamesDialog
Set oDialog = Application.Session.GetSelectNamesDialog
With oDialog
.InitialAddressList = _
Application.Session.GetGlobalAddressList
.Recipients = oMsg.Recipients
If .Display Then
'Recipients Resolved
oMsg.Subject = "Hello"
oMsg.Send
End If
End With
End Sub
In VBA scripting ,I am trying to write a Sub Function which has the following signature
Sub(taskName As String , myGroup As String, myFile As String ,myPer As String, RelatedTasks() As String )
Dim olApp As Outlook.Application
Dim m As Outlook.MailItem
Set olApp = New Outlook.Application
Set m = olApp.CreateItem(olMailItem)
With m
.display
.To = "somewhere#someplace.com"
.Subject = "Test Events"
.HTMLBody/.body = ...
End Sub
Email Body is as follows:
Hello All,
Please find the following information.
TASK: taskName
RELATED TASK:RelatedTasks()
FILE : myFile
PERSON : myPer
In the Sub function , the pattern to the left of colon is always constant.And the right side will change based on the inputs to the function.
For that I am reading the Template.htm which contains the required signature.
Template.htm contains:
Hello All,
Please find the following information.
TASK: {{mytask}}
RELATED TASK:{{myRelatedTasks}}
FILE : {{myFile}}
PERSON : {{myPerson}}
In VBA code,I am replacing all the fields.
The issue that I am facing is {{mytask}} and {{related tasks}} also should have a HTML reference. I have succeeded in adding the link to mytask .Clicking on the mytask in the mail will jump to the respective weblink.
<a href = "www.something.com&id ={{taskID}}>
{{mytask}}.....<a href = "www.xxx.com&id={{}}>{{myRelatedTasks}}
but having trouble in adding the same to Related tasks since it is an array.
My VBA code :
Option Explicit
Sub CreateNewMail()
Dim olApp As Outlook.Application
Dim m As Outlook.MailItem
Dim sigPath As String, sigText As String
Dim fso As Scripting.FileSystemObject
Dim ts As Scripting.TextStream
Dim t As String
Dim r(5) As Variant
t = "233444:dshfjhdjfdhjfhjdhfjdhfjd"
r(0) = "122343:dsjdhfjhfjdh"
r(1) = "323243:jfjfghfjhjddj"
r(2) = "834783:gffghjkjkgjkj"
Set olApp = New Outlook.Application
Set m = olApp.CreateItem(olMailItem)
sigPath = "C:\Users\Pavan-Kumar\Desktop\vbs\TestEvents.htm"
Set fso = New Scripting.FileSystemObject
Set ts = fso.OpenTextFile(sigPath)
sigText = ts.ReadAll
ts.Close
Set fso = Nothing
sigText = Replace(sigText, "{{mytask}}", t)
sigText = Replace(sigText, "{{myRelatedTasks}}", Join(r, "<br>"))
With m
.display
.To = "somewhere#someplace.com"
.Subject = "Test Events"
.HTMLBody = sigText
End With
End Sub
And also when I am joining the related tasks , I want them to come one below another with indentation. I tried it with giving "\t" as the delimiter with no success.
My current O/P in outlook mail:
Here is what I did to solve the same issue:
Write an email with exactly the format you want
In the email, use something unique for the fields, like {{recipient name}}
Save the email as HTML. This is now your template for the email body. You might keep several different templates for different situations.
In VBA, open the appropriate template file and read the whole thing into a string.
Using the VBA command Replace, fill in your fields. For example strHTMLTemplate = Replace(strHTMLTemplate, "{{recipient name}}", "Jane Doe")
Assign the final string to .htmlBody
For the RelatedTasks, it looks like you just want them to be on a single row. In that case, just make a "field" in your template, {{RelatedTasks}} and then do a replace like so strHTMLTemplate = Replace(strHTMLTemplate, "{{RelatedTasks}}", Join(RelatedTasks, ", ")).
If you want to get fancy, you can write functions that converts arrays of strings into html lists or tables
I have VBA code whose main functions are:
Load a form
Allow a user to choose a stock email response
Open a word document with the full response text
Create a reply using the text
Search the email and create a collection of strings containing corporate file numbers
Add the file numbers to an Excel list
Send the response
Now I want to save one copy of the sent item in a Windows folder, for each file number. I’ve been trying to wait until the item is sent and moved to Sent Items. The problem is that after calling the send method, the mailitem doesn’t send or move to Sent Items until after the code finishes so I end up in an infinite loop.
All the options I found involve using a class module and WithEvents. That would work if I wanted to copy every sent item to the folder. I can’t think of any criteria that would differentiate the emails created by this macro from normal emails. I could go into the Excel list of files, but that would bog everybody’s machine down on every send.
Is there a way to just have the email send find out when it has been sent and moved to sent items? My code to send, wait for it to go to sent items, and to save the emails is below. Note I have two global variables: cReply (Outlook.MailItem – the reply) and fNums (Collection – the file numbers).
I'm coding in Outlook 2016, but hope to move the module to Outlook 2010 at work.
Sub Send()
Dim badChar As String
badChar = "\/:*?™""® <>|.&##_+`©~;-+=^$!,'" & Chr(34)
Dim x As Integer
Dim fName As String
Dim inSentItems As Boolean
Dim olApp As Outlook.Application
Dim olNS As Outlook.NameSpace
Dim olFldr As Outlook.MAPIFolder
Dim cSent As Outlook.MailItem
Dim sentMoment As Date
fName = cReply.Subject
For x = 1 To Len(badChar)
fName = Replace(fName, Mid(badChar, x, 1), "-")
Next x
Set olApp = GetObject(, "Outlook.Application")
Set olNS = olApp.GetNamespace("MAPI")
Set olFldr = olNS.GetDefaultFolder(olFolderSentMail)
inSentItems = True
x = olFldr.Items.Count
sentMoment = Now
cReply.Send
Do While olFldr.Items.Count <> x + 1
If Now - sentMoment > TimeValue("0:00:10") Then
inSentItems = False
Exit Do
End If
DoEvents
Loop
If inSentItems Then
Set cSent = olFldr.Items(olFldr.Items.Count)
For x = 1 To fNums.Count
cSent.SaveAs sentFldrPth & fNums.Item(x) & " - " & fName & ".msg", olMSG
Next x
'cSent.Delete
End If
Set olApp = Nothing
Set olNS = Nothing
Set olFldr = Nothing
End Sub
You could use SaveSentMessageFolder to save to another folder.
https://msdn.microsoft.com/en-us/library/office/ff868473.aspx
Monitor this other folder with ItemAdd code. You could move the mail to the Sent Items folder once done.
I got a code VBA code for extracting email addresses from PST files.
It is very useful as I can choose the folder to have the addresses extracted.
The code is extracting from the "To" field.
I need it to extract from the message body and also the "From" field.
What must I change in the code?
Sub ExtractEmail()
Dim OlApp As Outlook.Application
Dim Mailobject As Object
Dim Email As String
Dim NS As NameSpace
Dim Folder As MAPIFolder
Set OlApp = CreateObject("Outlook.Application")
' Setup Namespace
Set NS = ThisOutlookSession.Session
' Display select folder dialog
Set Folder = NS.PickFolder
' Create Text File
Set fs = CreateObject("Scripting.FileSystemObject")
Set a = fs.CreateTextFile("c:\email addresses.txt", True)
' loop to read email address from mail items.
For Each Mailobject In Folder.Items
Email = Mailobject.To
a.WriteLine (Email)
Next
Set OlApp = Nothing
Set Mailobject = Nothing
a.Close
End Sub
Thank you.
You have the mailItem object so use it to get the fields. Mailobject.Sender, Mailobject.SenderEmailAddress, Mailobject.SenderName and Mailobject.Body, Mailobject.HTMLBody or Mailobject.RTFBody – Sorceri
You are extracting the value of the To property, whcih is a ";" separated list of recipient names. You need to loop through all items in the MailItem.Recipients.Collection and for each recipient read the Recipient.Address property. – Dmitry Streblechenko
Question with no answers, but issue solved in the comments
I am trying to extract email addresses of all emails in my Outlook inbox. I found this code on the Internet.
Sub GetALLEmailAddresses()
Dim objFolder As MAPIFolder
Dim strEmail As String
Dim strEmails As String
''' Requires reference to Microsoft Scripting Runtime
Dim dic As New Dictionary
Dim objItem As Object
''Set objFolder = Application.ActiveExplorer.Selection
Set objFolder = Application.GetNamespace("Mapi").PickFolder
For Each objItem In objFolder.Items
If objItem.Class = olMail Then
strEmail = objItem.SenderEmailAddress
If Not dic.Exists(strEmail) Then
strEmails = strEmails + strEmail + vbCrLf
dic.Add strEmail, ""
End If
I am using outlook 2007. When I run this code from the Outlook Visual Basic Editor with F5 I get an error on the following line.
Dim dic As New Dictionary
"user defined type not defined"
I have provided updated code below
to dump the Inbox email addresses to a CSV file "c:\emails.csv" (the current code provides no "outlook" for the collected addresses
the code above works on a selected folder rather than Inbox as per your request
[Update: For clarity this is your old code that uses "early binding", setting this reference is unnecessary for my updated code below which uses "late binding"]
Part A: Your existing code (early binding)
In terms of the error you received:
The code sample aboves uses early binding, this comment "Requires reference to Microsoft Scripting Runtime" indciates that you need to set the reference
Goto the Tools menu
Select 'References'
check "Microdoft Scripting Runtime"
Part B: My new code (late binding - setting the reference is unnecessary)
Working Code
Sub GetALLEmailAddresses()
Dim objFolder As MAPIFolder
Dim strEmail As String
Dim strEmails As String
Dim objDic As Object
Dim objItem As Object
Dim objFSO As Object
Dim objTF As Object
Set objDic = CreateObject("scripting.dictionary")
Set objFSO = CreateObject("scripting.filesystemobject")
Set objTF = objFSO.createtextfile("C:\emails.csv", 2)
Set objFolder = Application.GetNamespace("Mapi").GetDefaultFolder(olFolderInbox)
For Each objItem In objFolder.Items
If objItem.Class = olMail Then
strEmail = objItem.SenderEmailAddress
If Not objDic.Exists(strEmail) Then
objTF.writeline strEmail
objDic.Add strEmail, ""
End If
End If
Next
objTF.Close
End Sub
export the file to C:\Users\Tony\Documents\sent file.CSV
Then use ruby
email_array = []
r = Regexp.new(/\b[a-zA-Z0-9._%+-]+#[a-zA-Z0-9.-]+\.[a-zA-Z]{2,4}\b/)
CSV.open('C:\Users\Tony\Documents\sent file.CSV', 'r') do |row|
email_array << row.to_s.scan(r)
end
puts email_array.flatten.uniq.inspect
Here's an updated version for those using Exchange. It converts Exchange format addresses to normal email addresses (with the # symbol).
' requires reference to Microsoft Scripting Runtime
Option Explicit
Sub Write_Out_Email_Addresses()
' dictionary for storing email addresses
Dim email_list As New Scripting.Dictionary
' file for output
Dim fso As New Scripting.FileSystemObject
Dim out_file As Scripting.TextStream
Set out_file = fso.CreateTextFile("C:\emails.csv", True)
' open the inbox
Dim ns As Outlook.NameSpace
Set ns = Application.GetNamespace("MAPI")
Dim inbox As MAPIFolder
Set inbox = ns.GetDefaultFolder(olFolderInbox)
' loop through all items (some of which are not emails)
Dim outlook_item As Object
For Each outlook_item In inbox.Items
' only look at emails
If outlook_item.Class = olMail Then
' extract the email address
Dim email_address As String
email_address = GetSmtpAddress(outlook_item, ns)
' add new email addresses to the dictionary and write out
If Not email_list.Exists(email_address) Then
out_file.WriteLine email_address
email_list.Add email_address, ""
End If
End If
Next
out_file.Close
End Sub
' get email address form a Mailoutlook_item
' this entails converting exchange format addresses
' (like " /O=ROOT/OU=ADMIN GROUP/CN=RECIPIENTS/CN=FIRST.LAST")
' to proper email addresses
Function GetSmtpAddress(outlook_item As Outlook.MailItem, ns As Outlook.NameSpace) As String
Dim success As Boolean
success = False
' errors can happen if a user has subsequently been removed from Exchange
On Error GoTo err_handler
Dim email_address As String
email_address = outlook_item.SenderEmailAddress
' if it's an Exchange format address
If UCase(outlook_item.SenderEmailType) = "EX" Then
' create a recipient
Dim recip As Outlook.Recipient
Set recip = ns.CreateRecipient(outlook_item.SenderEmailAddress)
' extract the email address
Dim user As Outlook.ExchangeUser
Set user = recip.AddressEntry.GetExchangeUser()
email_address = user.PrimarySmtpAddress
email_address = user.Name + " <" + user.PrimarySmtpAddress + ">"
success = True
End If
err_handler:
GetSmtpAddress = email_address
End Function
Kudos to http://forums.codeguru.com/showthread.php?441008-Extract-sender-s-email-address-from-an-Exchange-email and Brettdj
In outlook, export a folder to a csv file, then open in Excel. A simple MID function should be able to extract the email address if it's not been placed in a "from" column already.