I have a VBScript which opens Outlook 2016 and sends a message.
The problem I have is that I have several Outlook profiles.
I would like to set the actual profile I wish to open from which to send the message.
My existing script is:
Dim objOutlook, objEmail
Dim strEmailReceiver, strEmailCc, strEmailBcc, strEmailSubject, strEmailBody, strEmailAttachments
Set objOutlook = CreateObject("Outlook.Application")
Set objEmail = objOutlook.CreateItem(0)
strEmailSubject=InPutBox("Input your message")
With objEmail
.To = "here#there.com"
' .Cc = strEmailCc
' .Bcc = strEmailBcc
.Subject = strEmailSubject
' .Body = strEmailBody
' If (strEmailAttachments <> "") Then
' .Attachments.Add strEmailAttachments
' End If
.Send
End With
'Clear the memory
Set objOutlook = Nothing
Set objEmail = Nothing
I wish to use the profile called CEO
If outlook is closed, I get a messagebox asking which profile to use, once selected the script works. This is the step I wish to avoid.
Immediately after creating an instance of the Outlook.Application object, add code like the following
Set objOutlook = CreateObject("Outlook.Application")
set objNS = objOutlook.GetNamespace("MAPI")
objNS.Logon("The Profile name")
Set objEmail = objOutlook.CreateItem(0)
keep in mind that if Outlook is already running, Namespace.Logon will do nothing and you will end up with the running instance of Outlook (since it is a singleton) using whatever profile it was using at the moment
Related
Here is the code I have so far:
Option Explicit
Call OpenOutlook()
Function OpenOutlook()
Dim ObjShell
Set ObjShell = CreateObject("WScript.Shell")
ObjShell.Run("Outlook.exe")
Call SendEmail()
'I tried closing from here but this didn't work either
'ObjShell.Quit
End Function
Function SendEmail()
'Declaring variables used through out this function
Dim ObjOutlook
Dim objMail
Set ObjOutlook = CreateObject("Outlook.Application")
'CreateItem(0) opens a New Email window...MailItem
set objMail = ObjOutlook.CreateItem(0)
objMail.Display
'MailItem Options
objMail.to = "test#mail.com.com"
'objMail.cc = "test2#mail.com"
objMail.Subject = "Did it work!?"
objMail.Body = "If you got this email, my VBs test worked!"
'objMail.Attachments.Add("C:\Attachment\abc.jpg")
objMail.Send
'This didn't work either
'If objMail.Sent = True Then
'ObjOutlook.Quit
'End If
'Quit closes Outlook like I want but it doesn't wait for the email to send
'ObjOutlook.Quit
End Function
What I'm trying to automate using VBScript:
Open Outlook
Send an email
Wait for email to send (Outbox to finish sending)
Close Outlook AFTER the email has been sent
Where I'm stuck:
First of all, I was having trouble opening Outlook. Below is the code that I used to create an Outlook Object:
Set ObjOutlook = CreateObject("Outlook.Application")
'CreateItem(0) opens a New Email window...MailItem
set objMail = ObjOutlook.CreateItem(0)
objMail.Display
What I did (Not even sure if this is the right way to do it):
Set ObjShell = CreateObject("WScript.Shell")
ObjShell.Run("Outlook.exe")
Why can't I just do ObjShell.Quit after I call the SendEmail() Function? Using .Quit gives me an error.
I just want to close the Outlook application once the email has been sent and I can't figure out how.
MailItem has a Sent property that indicates when the message has been sent. Try this:
...
objMail.Send
Do Until objMail.Sent
WScript.Sleep 500
Loop
' Safe to close...
ObjOutlook.Quit
Try this:
Option Explicit
Sub SendMail()
Dim outobj, mailobj
Set outobj = CreateObject("Outlook.Application")
Set mailobj = outobj.CreateItem(0)
With mailobj
.To = "user#test.com"
.Subject = "Testmail"
.Body = "If you got this email, my VBs test worked!"
.Send
End With
'Clear the memory
Set outobj = Nothing
Set mailobj = Nothing
End Sub
SendMail()
Msgbox("Done")
Firstly, what if it was the user who opened Outlook? I don't think any user will appreciate your code closing Outlook. You might want to check that both Application.Explorers.Count and Application.Inspectors.Count are zero before closing Outlook. Newest version of Outlook will automatically exist if there are no open explorers or inspectors even if you hold a reference to an Outlook object - that was done to guard ageist misbehaving apps that leaked references. To prevent Outlook from closing, hodl a reference to an Explorer object t(even if you do not show it) - call Namespace.getDefaultFolder(olFolderInbox), then hold a reference to the object returned by MAPIFolder.GetExplorer .
Secondly, after calling Send, use Namespace,SyncObjects collection to retrieve the very first SyncObject. Hook up the SyncObject.SyncEnd event and call SyncObject.Start. When SyncEnd event fires, you will be all done. But I don't think you can work with events in VB script...
our team has a shared mailbox in which we receive hundred of mails daily and we have to drag them manually from inbox into its separate sub-inboxes. So is there any rule or macro to drag them automatically.
VBS sample
Set objOutlook = GetObject (, "Outlook.Application")
Set objNamespace = objOutlook.GetNameSpace ("MAPI")
Set objFolderRoot = objNamespace.Folders ("Y2013")
Set objFolderSource = objFolderRoot.Folders ("Inbox")
Set objFolderDistance = objFolderRoot.Folders ("test")
MsgBox "Total emails is Inbox folder: " & objFolderSource.Items.Count
Set objEmail = objFolderSource.Items (1)
MsgBox "Subject of first email: " & objEmail.Subject
objEmail.Move objFolderDistance
Set objEmail = Nothing
Set objFolderDistance = Nothing
Set objFolderSource = Nothing
Set objFolderRoot = Nothing
Set objNamespace = Nothing
Set objOutlook = Nothing
Of course you MUST add object validation in this code.
You could also take a look to VBA (not VBS which you are using) sample on http://msdn.microsoft.com/en-us/library/office/ff860683.aspx
Problem: Handle the incoming emails using vbscript.
Outlook Version: Outlook 2000
Description: I cannot use VBA for this as I believe Outlook 2000 doesn't let you run a VBA script from the rules wizard and hence I have to use the Run a Program | VBScript method.
What I know: I know how to handle email from VBA like this
Sub Sample(MyMail As MailItem)
Dim strID As String, olNS As Outlook.NameSpace
Dim olMail As Outlook.MailItem
strID = MyMail.EntryID
Set olNS = Application.GetNamespace("MAPI")
Set olMail = olNS.GetItemFromID(strID)
'~~> Rest of the code
Set olMail = Nothing
Set olNS = Nothing
End Sub
I also know how to run the vbscript on the email which is already in the inbox. To run a vbscript in OL2000, you have to use Run A Program and point it to the vbs file. The Run A Script is not available in OL2000.
What I do not know: And this is where I need help. How to get the mail object which has not hit the mail inbox in VBS. Once I get the object then I can do the rest of the necessary operations.
You are correct that OL2000 cannot run a VBA macro from a rule, if this article is to be believed.
Here's how I handle incoming emails. It does use VBA but as far as I know, there isn't a way to do so in VBScript.
Private WithEvents Items As Outlook.Items
Private Sub Application_Startup()
Dim olApp As Outlook.Application
Dim objNS As Outlook.NameSpace
Set olApp = Outlook.Application
Set objNS = olApp.GetNamespace("MAPI")
Set Items = objNS.GetDefaultFolder(olFolderInbox).Items
End Sub
Private Sub Items_ItemAdd(ByVal item As Object)
On Error Goto ErrorHandler
Dim Msg As Outlook.MailItem
If TypeName(item) = "MailItem" Then
Set Msg = item
'~~> do something with the new message here
End If
ProgramExit:
Exit Sub
ErrorHandler:
MsgBox Err.Number & " - " & Err.Description
Resume ProgramExit
End Sub
This code should be pasted into the ThisOutlookSession module, then Outlook should be restarted.
We want to upgrade our VB6 code to use Outlook 2010, but we're getting the following error:
Active x cannot create object
This is our current code:
Public Sub SendEmail()
Set emailOutlookApp = CreateObject("Outlook.Application.12")
Set emailNameSpace = emailOutlookApp.GetNamespace("MAPI")
Set emailFolder = emailNameSpace.GetDefaultFolder(olFolderInbox)
Set emailItem = emailOutlookApp.CreateItem(olMailItem)
Set EmailRecipient = emailItem.Recipients
EmailRecipient.Add (EmailAddress)
EmailRecipient.Add (EmailAddress2)
emailItem.Importance = olImportanceHigh
emailItem.Subject = "My Subject"
emailItem.Body = "The Body"
'-----Send the Email-----'
emailItem.Save
emailItem.Send
'-----Clear out the memory space held by variables-----'
Set emailNameSpace = Nothing
Set emailFolder = Nothing
Set emailItem = Nothing
Set emailOutlookApp = Nothing
Exit Sub
I'm not sure if "Outlook.Application.12" is correct. But I can't find a definitive answer for this.
For Outlook 2010, this is definitly corect Outlook.Application.14.
But, I don't know what about office 2007.
I think it's Outlook.Application.12 and for lower versions it is simply "Outlook.Application".
Here's the code I switched to for 2010:
Private Sub EmailBlahbutton_Click()
Dim mOutlookApp As Object
Dim OutMail As Object
Dim Intro As String
On Error GoTo ErrorHandler
Set mOutlookApp = GetObject("", "Outlook.application")
Set OutMail = mOutlookApp.CreateItem(0)
With Application
.EnableEvents = False
.ScreenUpdating = False
End With
'These are the ranges being emailed.
ActiveSheet.Range(blahblahblah).Select
'Intro is the first line of the email
Intro = "BLAHBLAHBLHA"
'Set the To and Subject lines. Send the message.
With OutMail
.To = "blahblah#blah.com"
.Subject = "More BLAH here"
.HTMLBody = Intro & RangetoHTML(Selection)
.Send
End With
With Application
.EnableEvents = True
.ScreenUpdating = True
End With
ActiveSheet.Range("A1").Select
ActiveWindow.ScrollColumn = ActiveCell.Column
ActiveWindow.ScrollRow = ActiveCell.Row
Set OutMail = Nothing
Set mOutlookApp = Nothing
Exit Sub
ErrorHandler:
Set mOutlookApp = CreateObject("Outlook.application")
Resume Next
End Sub
Function RangetoHTML(rng As Range)
' Changed by Ron de Bruin 28-Oct-2006
' Working in Office 2000-2010
Dim fso As Object
Dim ts As Object
Dim TempFile As String
Dim TempWB As Workbook
TempFile = Environ$("temp") & "/" & Format(Now, "dd-mm-yy h-mm-ss") & ".htm"
'Copy the range and create a new workbook to past the data in
rng.Copy
Set TempWB = Workbooks.Add(1)
With TempWB.Sheets(1)
.Cells(1).PasteSpecial Paste:=8
.Cells(1).PasteSpecial xlPasteValues, , False, False
.Cells(1).PasteSpecial xlPasteFormats, , False, False
.Cells(1).Select
Application.CutCopyMode = False
On Error Resume Next
.DrawingObjects.Visible = True
.DrawingObjects.Delete
On Error GoTo 0
End With
'Publish the sheet to a htm file
With TempWB.PublishObjects.Add( _
SourceType:=xlSourceRange, _
Filename:=TempFile, _
Sheet:=TempWB.Sheets(1).Name, _
Source:=TempWB.Sheets(1).UsedRange.address, _
HtmlType:=xlHtmlStatic)
.Publish (True)
End With
'Read all data from the htm file into RangetoHTML
Set fso = CreateObject("Scripting.FileSystemObject")
Set ts = fso.GetFile(TempFile).OpenAsTextStream(1, -2)
RangetoHTML = ts.ReadAll
ts.Close
RangetoHTML = Replace(RangetoHTML, "align=center x:publishsource=", _
"align=left x:publishsource=")
'Close TempWB
TempWB.Close savechanges:=False
'Delete the htm file we used in this function
Kill TempFile
Set ts = Nothing
Set fso = Nothing
Set TempWB = Nothing
End Function
Why do you explicitly specify the version? Why not simply
Set emailOutlookApp = CreateObject("Outlook.Application")
Try "Outlook.Application.14". Not sure if this is related though: 2007 to 2010 upgrade issue
I realize it's not the exact issue, but it may lead you down the right path.
How can I send an email to a group of recipients with CDO? I'm using VB6.
You can list multiple recipients on the .To line by separating them with ";", for example:
Set m = Server.CreateObject("CDO.Message")
m.Subject="subject..."
m.From="sender#example.com"
m.To="some#email.com;other#email.com;third#email.com"
m.TextBody="Message"
m.Send
This works in Office 97 and whatever Exchange we had back then:
Dim oOApp As Outlook.Application
Dim newMail As Outlook.MailItem
Set oOApp = CreateObject("Outlook.Application")
Set newMail = oOApp.CreateItem(olMailItem)
With newMail
.Display
.Body = whatever
.Subject = whatever
.Attachments.Add whatever
.Recipients.Add (whomever)
.Send
End With
Set newMail = Nothing
Set oOApp = Nothing