I am currently using the following VBS script to send an email and it works fine, however the image is sent as an attachment. I would instead like to embed the image into the email. I understand that I must reference the attachment in the HTML body of the email but I am struggling to do this.
Any suggestions?
Dim ToAddress
Dim FromAddress
Dim MessageSubject
Dim MyTime
Dim MessageBody
Dim MessageAttachment
Dim ol, ns, newMail
MyTime = Now
ToAddress = "email#address.com"
MessageSubject = "Auto Stats " & MyTime
MessageBody = "Stats Attached" & vbCrLf & "Produced at " & MyTime
MessageAttachment = "P:\stats.png"
Set ol = WScript.CreateObject("Outlook.Application")
Set ns = ol.getNamespace("MAPI")
Set newMail = ol.CreateItem(olMailItem)
newMail.Subject = MessageSubject
newMail.Body = MessageBody
newMail.RecipIents.Add(ToAddress)
newMail.Attachments.Add(MessageAttachment)
newMail.Send
use the code below
Const PR_ATTACH_MIME_TAG = "http://schemas.microsoft.com/mapi/proptag/0x370E001E"
Const PR_ATTACH_CONTENT_ID = "http://schemas.microsoft.com/mapi/proptag/0x3712001E"
Const PR_ATTACHMENT_HIDDEN = "http://schemas.microsoft.com/mapi/proptag/0x7FFE000B"
Sub testing2()
Dim ToAddress
Dim FromAddress
Dim MessageSubject
Dim MyTime
Dim MessageBody
Dim MessageAttachment
Dim ol, ns, newMail
Dim realAttachment
MyTime = Now
ToAddress = "testing#address.com"
MessageSubject = "Auto Stats " & MyTime
MessageBody = "Stats Attached" & vbCrLf & "Produced at " & MyTime
MessageAttachment = "C:\Users\Public\Pictures\Sample Pictures\Penguins.jpg"
Set ns = Outlook.GetNamespace("MAPI")
Set newMail = Outlook.CreateItem(olMailItem)
newMail.Subject = MessageSubject
newMail.Body = MessageBody
newMail.Recipients.Add (ToAddress)
Set realAttachment = newMail.Attachments.Add(MessageAttachment)
Set oPA = realAttachment.PropertyAccessor
oPA.SetProperty PR_ATTACH_MIME_TAG, "image/jpeg"
oPA.SetProperty PR_ATTACH_CONTENT_ID, "myident" 'change myident for another other image
newMail.HTMLBody = newMail.HTMLBody & "<IMG align=baseline border=0 hspace=0 src=cid:myident>" 'need to match the "myident" above
newMail.Send
End Sub
Hope it helps
I tested this in outlook 2003 and 2016
'I do have a solution, and that is to convert the Body to HTML
Dim ToAddress
Dim FromAddress
Dim MessageSubject
Dim MyTime
Dim MessageBody
Dim MessageAttachment
Dim ol, ns, newMail
MyTime = Now
ToAddress = "email#address.com"
MessageSubject = "Auto Stats " & MyTime
' The trick is to convert all the message body into HTML
' Don't mix script text and HTML. Then simply add an HTML image reference.
' Remember if the recipient can't get to the image
' it won't appear in the email body, and will be blank. So don't use a local image.
' Use an recipient reachable image.
MessageBody = "<html>Stats Attached" & "<p>Produced at " & MyTime & _
"<p><img src=""http://somedomain.com/.../stats.png""></html><br>"
'MessageAttachment = "P:\stats.png" ! Now Uneccessary
Set ol = CreateObject("Outlook.Application")
Set ns = ol.getNamespace("MAPI")
Set newMail = ol.CreateItem(olMailItem)
newMail.Subject = MessageSubject
newMail.htmlBody = MessageBody 'Changed the newmMail.Body to newMail.htmlBody
newMail.RecipIents.Add(ToAddress)
'newMail.Attachments.Add(MessageAttachment) !This was removed because it would just appear as email attachment
newMail.Display
Related
Dear StackOverflowers.
I know a few programming languages, but unfortunately VBA is not one of them.
I'm trying to make a script that saves the headers from selected mails in Outlook as .msg-files.
I found a script that opens the headers as new messages, but how to I save them as e.g. [senders domain]_[date recieved].msg instead of opening them as new mails?
The script that I have:
Sub ViewInternetHeader()
Dim olItem As Outlook.MailItem, olMsg As Outlook.MailItem
Dim strHeader As String
For Each olItem In Application.ActiveExplorer.Selection
strHeader = GetInetHeaders(olItem)
Set olMsg = Application.CreateItem(olMailItem)
With olMsg
.BodyFormat = olFormatPlain
.Body = strHeader
.Display
End With
Next
Set olMsg = Nothing
End Sub
Function GetInetHeaders(olkMsg As Outlook.MailItem) As String
' Purpose: Returns the internet headers of a message.'
' Written: 4/28/2009'
' Author: BlueDevilFan'
' //techniclee.wordpress.com/
' Outlook: 2007'
Const PR_TRANSPORT_MESSAGE_HEADERS = "http://schemas.microsoft.com/mapi/proptag/0x007D001E"
Dim olkPA As Outlook.PropertyAccessor
Set olkPA = olkMsg.PropertyAccessor
GetInetHeaders = olkPA.GetProperty(PR_TRANSPORT_MESSAGE_HEADERS)
Set olkPA = Nothing
End Function
Use the MailItem.SaveAs method which saves the Microsoft Outlook item to the specified path and in the format of the specified file type. If the file type is not specified, the MSG format (.msg) is used. For example:
Sub SaveAsTXT()
Dim myItem As Outlook.Inspector
Dim objItem As Object
Set myItem = Application.ActiveInspector
If Not TypeName(myItem) = "Nothing" Then
Set objItem = myItem.CurrentItem
strname = objItem.Subject
'Prompt the user for confirmation
Dim strPrompt As String
strPrompt = "Are you sure you want to save the item? " & _
"If a file with the same name already exists, " & _
"it will be overwritten with this copy of the file."
If MsgBox(strPrompt, vbYesNo + vbQuestion) = vbYes Then
objItem.SaveAs Environ("HOMEPATH") & "\My Documents\" & strname & ".txt", olTXT
End If
Else
MsgBox "There is no current active inspector."
End If
End Sub
So you want an MSG file that has no recipients, attachments, subject, etc, only the MIME headers as the body? Why do you want the MSG format then?
You can create an populate a text file using the Scripting.FileSystemObject and use its CreateTextFile method.
Thank you, Eugene.
I managed to put in your code.
But it doesn't give the file a name, it's only called ".msg", and it doesn't work, when I try to select more than one email.
Also, how do I avoid, that it opens a new mail with the header?
I have this script now:
Sub ViewInternetHeader()
Dim olItem As Outlook.MailItem, olMsg As Outlook.MailItem
Dim strHeader As String
For Each olItem In Application.ActiveExplorer.Selection
strHeader = GetInetHeaders(olItem)
Set olMsg = Application.CreateItem(olMailItem)
With olMsg
.BodyFormat = olFormatPlain
.Body = strHeader
.Display
End With
Next
Set olMsg = Nothing
Dim myItem As Outlook.Inspector
Dim objItem As Object
Set myItem = Application.ActiveInspector
If Not TypeName(myItem) = "Nothing" Then
Set objItem = myItem.CurrentItem
strname = objItem.SenderEmailAddress
'Prompt the user for confirmation
Dim strPrompt As String
strPrompt = "Are you sure you want to save the item? " & _
"If a file with the same name already exists, " & _
"it will be overwritten with this copy of the file."
If MsgBox(strPrompt, vbYesNo + vbQuestion) = vbYes Then
objItem.saveas "C:\temp\" & strname & ".msg", OLTXT
End If
Else
MsgBox "There is no current active inspector."
End If
End Sub
Function GetInetHeaders(olkMsg As Outlook.MailItem) As String
Const PR_TRANSPORT_MESSAGE_HEADERS = "http://schemas.microsoft.com/mapi/proptag/0x007D001E"
Dim olkPA As Outlook.PropertyAccessor
Set olkPA = olkMsg.PropertyAccessor
GetInetHeaders = olkPA.GetProperty(PR_TRANSPORT_MESSAGE_HEADERS)
Set olkPA = Nothing
End Function
I can't get this to work. Anytime I use VBScript with the .PropertyAccessor I get an error. "Ojbect doesn't support this property or method: 'PropertyAccessor' - Code: 800A01B6"
Const PR_ATTACH_MIME_TAG = "http://schemas.microsoft.com/mapi/proptag/0x370E001E"
Const PR_ATTACH_CONTENT_ID = "http://schemas.microsoft.com/mapi/proptag/0x3712001E"
Const PR_ATTACHMENT_HIDDEN = "http://schemas.microsoft.com/mapi/proptag/0x7FFE000B"
Dim ToAddress
Dim FromAddress
Dim MessageSubject
Dim MyTime
Dim MessageBody
Dim MessageAttachment
Dim ol, ns, newMail
Dim realAttachment
MyTime = Now
ToAddress = "testing#address.com"
MessageSubject = "Auto Stats " & MyTime
MessageBody = "Stats Attached" & vbCrLf & "Produced at " & MyTime
MessageAttachment = "f:\test\LOGO.jpg"
Set Outlook = CreateObject("Outlook.Application")
Set ns = Outlook.GetNamespace("MAPI")
Set newMail = Outlook.CreateItem(olMailItem)
newMail.Subject = MessageSubject
newMail.Body = MessageBody
newMail.Recipients.Add (ToAddress)
Set realAttachment = newMail.Attachments.Add(MessageAttachment)
Set oPA = realAttachment.PropertyAccessor
oPA.SetProperty PR_ATTACH_MIME_TAG, "image/jpeg"
oPA.SetProperty PR_ATTACH_CONTENT_ID, "myident" 'change myident for another other image
newMail.HTMLBody = newMail.HTMLBody & "<IMG align=baseline border=0 hspace=0 src=cid:myident>" 'need to match the "myident" above
newMail.Display
newMail.Send
I'm trying to list all the calendar names in Outlook (my own and shared calendars).
dim oApp
dim oNameSpace
dim oFolder
dim fChild
dim fParent
dim sNames
fChild = Folder
fParent = Folder
sNames = ""
set oApp = CreateObject("Outlook.Application")
set oNameSpace = oApp.GetNamespace("MAPI")
for each fParent in oNameSpace.Folders
for each fChild in fParent.Folders
if fChild.DefaultItemType = 9 then
sNames = sNames & fParent.Name & " -- " & fChild.Name & vbCrLf
end If
next
next
MsgBox(sNames)
Am I on the right track?
Tou can use the NavigationModule object to iterate through all the groups of folders. Typically you could use objNavMod.NavigationGroups.GetDefaultNavigationGroup(olPeopleFoldersGroup), but if the user has added groups of calendars manually then this won't get you all the calendars. Also it's possible that permissions prevent accessing the folder programmatically; the code below allows for this.
const olFolderCalendar = 9
const olModuleCalendar = 1
Dim objOL
Dim objNS
Dim objExpCal
Dim objNavMod
Dim objNavGroup
Dim objNavFolder
Dim objFolder
Dim colExpl
dim s
s = ""
set oApp = CreateObject("Outlook.Application")
Set objNS = oApp.Session
Set colExpl = oApp.Explorers
Set objExpCal = objNS.GetDefaultFolder(olFolderCalendar).GetExplorer
Set objNavMod = objExpCal.NavigationPane.Modules.GetNavigationModule(olModuleCalendar)
For Each objNavGroup In objNavMod.NavigationGroups
For Each objNavFolder In objNavGroup.NavigationFolders
On Error Resume Next
Set objFolder = objNavFolder.Folder
If Err = 0 Then
s = s & objNavGroup.Name & " -- " & left(objFolder.FolderPath,30) & vbcrlf
Else
s = s & objNavGroup.Name & " -- " & objNavFolder.DisplayName & " [no permission]" & vbcrlf
End If
On Error GoTo 0
Next
Next
Set oApp = Nothing
Set objNS = Nothing
Set objNavMod = Nothing
Set objNavGroup = Nothing
Set objNavFolder = Nothing
Set objFolder = Nothing
Set colExpl = Nothing
msgbox s
In VBA:
Sub IterateAllCalendars()
Dim s As String
Dim objOL As Outlook.Application
Dim objNS As Outlook.namespace
Dim objExpCal As Outlook.Explorer
Dim objNavMod As Outlook.CalendarModule
Dim objNavGroup As Outlook.NavigationGroup
Dim objNavFolder As Outlook.NavigationFolder
Dim objFolder As Outlook.Folder
Dim colExpl As Outlook.Explorers
s = ""
Set objOL = Application
Set objNS = objOL.Session
Set colExpl = objOL.Explorers
Set objExpCal = objNS.GetDefaultFolder(olFolderCalendar).GetExplorer
Set objNavMod = objExpCal.NavigationPane.Modules.GetNavigationModule(olModuleCalendar)
For Each objNavGroup In objNavMod.NavigationGroups
For Each objNavFolder In objNavGroup.NavigationFolders
On Error Resume Next
Set objFolder = objNavFolder.Folder
If Err = 0 Then
s = s & objNavGroup.Name & " -- " & Left(objFolder.FolderPath, 30) & vbCrLf
Else
s = s & objNavGroup.Name & " -- " & objNavFolder.DisplayName & " [no permission]" & vbCrLf
End If
On Error GoTo 0
Next
Next
Set objOL = Nothing
Set objNS = Nothing
Set objNavMod = Nothing
Set objNavGroup = Nothing
Set objNavFolder = Nothing
Set objFolder = Nothing
Set colExpl = Nothing
MsgBox s
End Sub
#Geoff: Because this was the only slim, structured and working code I found - and I searched quite a while - I add my translation to pure WSH JScript.
var olAppointmentItem = 1;
var olFolderCalendar = 9;
var olFolderNotes = 12;
var olModuleCalendar = 1;
var olMyFoldersGroup = 1;
var oOtlk = new ActiveXObject('Outlook.Application' );
var oMAPI = oOtlk.getNameSpace("MAPI");
var oFldCldr = oMAPI.getDefaultFolder(olFolderCalendar);
var oExpl = oFldCldr.GetExplorer;
var oNavMod = oExpl.NavigationPane.Modules.GetNavigationModule(olModuleCalendar);
var msg = "";
var eGrps = new Enumerator(oNavMod.NavigationGroups);
for (; !eGrps.atEnd(); eGrps.moveNext()) {
var oGrp = eGrps.item();
msg += oGrp.Name + "\n";
var eFlds = new Enumerator(oGrp.NavigationFolders);
for (; !eFlds.atEnd(); eFlds.moveNext()) {
var oFld = eFlds.item();
msg += "\t" + oFld.DisplayName + "\n";
}
}
WScript.echo(msg);
My vbscript sends email to automatically to a recipient, but does anyone know how to add more than one recipient to it?
...
Dim ToAddress
Dim FromAddress
Dim MessageSubject
Dim MyTime
Dim MessageBody
Dim MessageAttachment
Dim ol, ns, newMail
MyTime = Now
ToAddress = "email#address.com"
MessageSubject = "It works!."
MessageBody = "Good job on that script."
MessageAttachment = some attachment
Set ol = WScript.CreateObject("Outlook.Application")
Set ns = ol.getNamespace("MAPI")
Set newMail = ol.CreateItem(olMailItem)
newMail.Subject = MessageSubject
newMail.Body = MessageBody & vbCrLf & MyTime
newMail.RecipIents.Add(ToAddress)
newMail.Attachments.Add(MessageAttachment)
newMail.Send
This is what I have right now. And it works fine. But, I'd like to have more than one recipients. Thanks in advance.
newMail.CC = "person1#domain1.org;person2#domain2.org;person3#domain3.org"
This above line worked!
And it works the same way with .BCC, in case anyone wants to not to display the contacts' list.
Call MailItem.Recipients.Add for each recipient or set the To/CC/BCC properties to a ";" separated list of addresses.
How could we automatically/programmatically set the sender/contact image in outlook 2007? They are colleagues, and all employees pictures are stored in netshare.
I see that Outlook.ContactItem has an AddPicture method. Here's an example straight out of the help file:
Sub AddPictureToAContact()
Dim myNms As Outlook.NameSpace
Dim myFolder As Outlook.Folder
Dim myContactItem As Outlook.ContactItem
Dim strName As String
Dim strPath As String
Dim strPrompt As String
Set myNms = Application.GetNamespace("MAPI")
Set myFolder = myNms.GetDefaultFolder(olFolderContacts)
strName = InputBox("Type the name of the contact: ")
Set myContactItem = myFolder.Items(strName)
If myContactItem.HasPicture = True Then
strPrompt = MsgBox("The contact already has a picture associated with it. Do you want to overwrite the existing picture?", vbYesNo)
If strPrompt = vbNo Then
Exit Sub
End If
End If
strPath = InputBox("Type the file name for the contact: ")
myContactItem.AddPicture (strPath)
myContactItem.Save
myContactItem.Display
End Sub