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
Related
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
I am trying to find a string in the list of shared folder names in an IP address in VBA.
The below routine works for folders but does not work. The error it says is Err-76, path not found.
could any one tell me how to access shared folder names in an IP address.
Sub findfolder()
Dim myFolder As Folder
Dim objfile As Object
Dim subfolder As Object
Dim FSO As New FileSystemObject
Dim txt As String
Dim strname As String
txt = "\\10.4.32.33"
'spath = GetFolder(txt)
strname = InputBox(Prompt:="You Search String please.", _
Title:="ENTER SEARCH STRING", Default:="Your Search String here")
Set myFolder = FSO.GetFolder(txt)
For Each subfolder In myFolder.SubFolders
cnt = 0
If (InStr(LCase(subfolder.Name), strname)) Then MsgBox ("found string" & subfolder.Name)
Next
End Sub
Use Shell.Application ActiveX instead of FSO, here is an example:
Sub ShowSharedFolders()
Const SHCONTF_CHECKING_FOR_CHILDREN = &H10
Const SHCONTF_FOLDERS = &H20
Const SHCONTF_NONFOLDERS = &H40
Const SHCONTF_INCLUDEHIDDEN = &H80
Const SHCONTF_INIT_ON_FIRST_NEXT = &H100
Const SHCONTF_NETPRINTERSRCH = &H200
Const SHCONTF_SHAREABLE = &H400
Const SHCONTF_STORAGE = &H800
Const SHCONTF_NAVIGATION_ENUM = &H1000
Const SHCONTF_FASTITEMS = &H2000
Const SHCONTF_FLATLIST = &H4000
Const SHCONTF_ENABLE_ASYNC = &H8000
Const SHCONTF_INCLUDESUPERHIDDEN = &H10000
strPath = "\\10.4.32.33\"
Set objShellApp = CreateObject("Shell.Application")
Set objFolder = objShellApp.Namespace(strPath)
Set objFolderItems = objFolder.Items()
objFolderItems.Filter SHCONTF_FOLDERS + SHCONTF_INCLUDEHIDDEN, "*.*"
For Each objFolderItem In objFolderItems
Debug.Print objFolderItem.Name & vbTab & objFolderItem.Path
Next
End Sub
For early binding Set objShellApp = New Shell you have to add the reference to Microsoft Shell Controls and Automation (Shell32).
I am using the below VBscript to change group type of couple of groups to Security. I am getting an error "The server is unwilling to process the request" when executing objGroup.setinfo.
Appreciate if someone can help to resolve this.
Dim strOU, strGroup, objOU, objGroup
Dim strFile, objFile, objFSO
Const ADS_GROUP_TYPE_SECURITY_ENABLED = &H80000000
Const ForReading = 1
Const ADS_NAME_INITTYPE_GC = 3
Const ADS_NAME_TYPE_NT4 = 3
Const ADS_NAME_TYPE_1779 = 1
Const ADS_GROUP_TYPE_UNIVERSAL = &H8
strFile = "c:\Temp\GroupNames.txt"
Set objFSO = CreateObject("Scripting.FileSystemObject")
Set objFile = objFSO.OpenTextFile(strFile, ForReading)
Set objRootDSE = GetObject("LDAP://RootDSE")
strDNSDomain = objRootDSE.Get("defaultNamingContext")
Set objTrans = CreateObject("NameTranslate")
objTrans.Init ADS_NAME_INITTYPE_GC, ""
objTrans.Set ADS_NAME_TYPE_1779, strDNSDomain
strNetBIOSDomain = objTrans.Get(ADS_NAME_TYPE_NT4)
strNetBIOSDomain = Left(strNetBIOSDomain, _
Len(strNetBIOSDomain) - 1)
Do Until objFile.AtEndOfStream
strNTName = Trim(objFile.ReadLine)
If (strNTName <> "") Then
On Error Resume Next
objTrans.Set ADS_NAME_TYPE_NT4, strNetBIOSDomain & "\" & strNTName
End If
' Use Get method to retrieve Distinguished Name.
strUserDN = objTrans.Get(ADS_NAME_TYPE_1779)
wscript.echo strUSerDN
' Bind to user object in AD.
Set objGroup = GetObject("LDAP://servername
" & strUserDN)
objGroup.Put "groupType", ADS_GROUP_TYPE_SECURITY_ENABLED
objGroup.SetInfo
Loop
objFile.Close
You need to specify the group scope as well. Instead of just "ADS_GROUP_TYPE_SECURITY_ENABLED", you need "ADS_GROUP_TYPE_[type]_GROUP Or ADS_GROUP_TYPE_SECURITY_ENABLED", where [type] is GLOBAL, LOCAL, or UNIVERSAL.
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.