Sending an email with a text file attached, this works (test email is received):
Set emailObj = CreateObject("CDO.Message")
emailObj.From = "sender#domain.tld"
emailObj.To = "recipient#domain.tld"
emailObj.Subject = "File attached"
emailObj.TextBody = "Please have a look at the attached file. Thanks."
emailObj.AddAttachment "d:\temp\test.txt"
Set emailConfig = emailObj.Configuration
emailConfig.Fields("http://schemas.microsoft.com/cdo/configuration/smtpserver") = "server.webhost.com"
emailConfig.Fields("http://schemas.microsoft.com/cdo/configuration/smtpserverport") = 465
emailConfig.Fields("http://schemas.microsoft.com/cdo/configuration/sendusing") = 2
emailConfig.Fields("http://schemas.microsoft.com/cdo/configuration/smtpauthenticate") = 1
emailConfig.Fields("http://schemas.microsoft.com/cdo/configuration/smtpusessl") = true
emailConfig.Fields("http://schemas.microsoft.com/cdo/configuration/sendusername") = "sender#domain.tld"
emailConfig.Fields("http://schemas.microsoft.com/cdo/configuration/sendpassword") = "top_secret"
emailConfig.Fields.Update
emailObj.Send
If err.number = 0 then Msgbox "Your file has been sent. Someone will respond as soon as possible."
But when I try to send a binary file, this does NOT work (test email message is not received):
Set emailObj = CreateObject("CDO.Message")
emailObj.From = "sender#domain.tld"
emailObj.To = "recipient#domain.tld"
emailObj.Subject = "File attached"
emailObj.TextBody = "Please have a look at the attached file. Thanks."
emailObj.AddAttachment "d:\temp\test.rtf"
Set emailConfig = emailObj.Configuration
emailConfig.Fields("http://schemas.microsoft.com/cdo/configuration/smtpserver") = "server.webhost.com"
emailConfig.Fields("http://schemas.microsoft.com/cdo/configuration/smtpserverport") = 465
emailConfig.Fields("http://schemas.microsoft.com/cdo/configuration/sendusing") = 2
emailConfig.Fields("http://schemas.microsoft.com/cdo/configuration/smtpauthenticate") = 1
emailConfig.Fields("http://schemas.microsoft.com/cdo/configuration/smtpusessl") = true
emailConfig.Fields("http://schemas.microsoft.com/cdo/configuration/sendusername") = "sender#domain.tld"
emailConfig.Fields("http://schemas.microsoft.com/cdo/configuration/sendpassword") = "top_secret"
emailConfig.Fields.Update
emailObj.Send
If err.number = 0 then Msgbox "Your file has been sent. Someone will respond as soon as possible."
What do I need to add/change to be able to attach a binary file?
Related
im using vbscript CDO for mail sending but i want to attachment as a body of the email can you please suggest me.
strSMTPFrom = "kampati.vinay#testing.in"
strSMTPTo = "kampati.vinay#testing.in"
strSMTPRelay = "testing.in"
strTextBody = "MDaemon Q status"
strSubject = "MDaemon Q status"
strAttachment = "C:\MDaemon\output.txt"
Set oMessage = CreateObject("CDO.Message")
oMessage.Configuration.Fields.Item("http://schemas.microsoft.com/cdo/configuration/sendusing") = 2
oMessage.Configuration.Fields.Item("http://schemas.microsoft.com/cdo/configuration/smtpserver") = strSMTPRelay
oMessage.Configuration.Fields.Item("http://schemas.microsoft.com/cdo/configuration/smtpserverport") = 25
oMessage.Configuration.Fields.Update
oMessage.Subject = strSubject
oMessage.From = strSMTPFrom
oMessage.To = strSMTPTo
oMessage.TextBody = strTextBody
oMessage.AddAttachment strAttachment
oMessage.Send
you can use create email body as HTML and
like
.............
body
.......
<div><img src="linkOfImage" height="50px" width="50px"/></div>
......
...............
for this you have to set one bit in your email header.
Example:
Dim fso, outFile
Set fso = CreateObject("Scripting.FileSystemObject")
Set outFile = fso.CreateTextFile("output.txt", True)
' The mailman object is used for sending and receiving email.
set mailman = CreateObject("Chilkat_9_5_0.MailMan")
' Any string argument automatically begins the 30-day trial.
success = mailman.UnlockComponent("30-day trial")
If (success <> 1) Then
outFile.WriteLine(mailman.LastErrorText)
WScript.Quit
End If
' Set the SMTP server.
mailman.SmtpHost = "smtp.comcast.net"
' Create a new email object
set email = CreateObject("Chilkat_9_5_0.Email")
' Add an embedded image to the HTML email.
fileOnDisk = "images/dude2.gif"
filePathInHtml = "dudeAbc.gif"
' Embed the GIF image in the email.
success = email.AddRelatedFile2(fileOnDisk,filePathInHtml)
If (success <> 1) Then
outFile.WriteLine(mailman.LastErrorText)
WScript.Quit
End If
' The src attribute for the image tag is set to the filePathInHtml:
htmlBody = "<html><body>Embedded Image:<br><img src=""dudeAbc.gif""></body></html>"
' Set the basic email stuff: HTML body, subject, "from", "to";
email.SetHtmlBody htmlBody
email.Subject = "VBScript HTML email with an embedded image."
success = email.AddTo("Admin","admin#chilkatsoft.com")
email.From = "Chilkat Support <support#chilkatsoft.com>"
success = mailman.SendEmail(email)
If (success <> 1) Then
outFile.WriteLine(mailman.LastErrorText)
Else
outFile.WriteLine("Mail Sent!")
End If
outFile.Close
I want to be able to send an attachment file just by dropping it on a script.
I've found this one that sends the file (it works for me):
Set fso=CreateObject("Scripting.FileSystemObject")
strSMTP="smtp.gmail.com"
strSubject="mail#gmail.com"
strSubject2="Attachment file"
strBody="-"
strAttach="FILEPATH"
If fso.FileExists(strAttach) then
Set iMsg = CreateObject("CDO.Message")
Set iConf = CreateObject("CDO.Configuration")
iConf.Load -1 ' CDO Source Defaults
Set Flds = iConf.Fields
With Flds
.Item("http://schemas.microsoft.com/cdo/configuration/sendusing") = 2
.Item("http://schemas.microsoft.com/cdo/configuration/smtpserver") = strSMTP
.Item("http://schemas.microsoft.com/cdo/configuration/smtpserverport") = 465
.Item("http://schemas.microsoft.com/cdo/configuration/smtpauthenticate") = 1
.Item("http://schemas.microsoft.com/cdo/configuration/sendusername") = "mail#gmail.com"
.Item("http://schemas.microsoft.com/cdo/configuration/sendpassword") = "password"
.Item("http://schemas.microsoft.com/cdo/configuration/smtpusessl") = 1
.Update
End With
With iMsg
Set .Configuration = iConf
.To = "mail2#gmail.com"
.CC = ""
.BCC = ""
.From = "mail1#gmail.com"
.Subject = strAttach
.TextBody = strBody
.AddAttachment strAttach
.Send
End With
Set iMsg = Nothing
Set iConf = Nothing
Else
MsgBox "The specified attachment does not exist"
End if
What I need is a modification to this script that allows me to change the 6th line strAttach="FILEPATH" with the path and the extension of the file that im dropping on it and then execute the "send mail script".
Found this two links related to my question, but I don't know how to use them, hope these can help you too.
How to get the fully qualified path for a file in VBScript?
http://vba-tutorial.com/parsing-a-file-string-into-path-filename-and-extension/
The first one just shows the filepath and the extension on a new window, but i need it to be overwritten on the 6th line.
Could someone help me? im not a programmer, just want to be able to send the files to my own mail because i need to print them later on another computer.
Sorry for my english. Im not a native speaker. Thanks in advance!
Use Arguments Property (WScript Object):
The Arguments property contains the WshArguments object (a
collection of arguments). Use a zero-based index to retrieve
individual arguments from this collection.
Set fso=CreateObject("Scripting.FileSystemObject")
strSMTP="smtp.gmail.com"
strSubject="mail#gmail.com"
strSubject2="Attachment file"
strBody="-"
''''''''''''''''''''''''''''''''''' strAttach="FILEPATH"
Set objArgs = WScript.Arguments
For ii = 0 to objArgs.Count - 1
SendMyMail fso.GetAbsolutePathName(CStr( objArgs( ii)))
Next
Sub SendMyMail( ByVal strAttach)
If fso.FileExists(strAttach) then
Set iMsg = CreateObject("CDO.Message")
Set iConf = CreateObject("CDO.Configuration")
iConf.Load -1 ' CDO Source Defaults
Set Flds = iConf.Fields
With Flds
.Item("http://schemas.microsoft.com/cdo/configuration/sendusing") = 2
.Item("http://schemas.microsoft.com/cdo/configuration/smtpserver") = strSMTP
.Item("http://schemas.microsoft.com/cdo/configuration/smtpserverport") = 465
.Item("http://schemas.microsoft.com/cdo/configuration/smtpauthenticate") = 1
.Item("http://schemas.microsoft.com/cdo/configuration/sendusername") = "mail#gmail.com"
.Item("http://schemas.microsoft.com/cdo/configuration/sendpassword") = "password"
.Item("http://schemas.microsoft.com/cdo/configuration/smtpusessl") = 1
.Update
End With
With iMsg
Set .Configuration = iConf
.To = "mail2#gmail.com"
.CC = ""
.BCC = ""
.From = "mail1#gmail.com"
.Subject = strAttach
.TextBody = strBody
.AddAttachment strAttach
.Send
End With
Set iMsg = Nothing
Set iConf = Nothing
Else
MsgBox strAttach & vbCrLf & "The specified attachment does not exist"
End if
End Sub
Should work
using file(s) drag&drop as well as
using SendTo… from right-click menu (see shell:sendto: Customize the Send To Menu in Windows 10, 8, 7, or Vista).
Please check Paul Sadowski's article Sending email with CDO to simplify your code.
set cdoConfig = CreateObject("CDO.Configuration")
with cdoConfig.Fields
.Item(cdoSendUsingMethod) = cdoSendUsingPort
.Item(cdoSMTPServer) = "localhost"
.Item(cdoSMTPAuthenticate) = 1
.Item(cdoSendUsername) = "contact#example.com"
.Item(cdoSendPassword) = "password"
.Update
end with
set cdoMessage = CreateObject("CDO.Message")
with cdomessage
set .Configuration = cdoConfig
.From = "contact#example.com"
.To = email
.Subject = subject
.HTMLBody = message
.AddAttachment "c:/i/report.pdf"
.Send
end with
set cdomessage = nothing
set cdoconfig = nothing
Everything sends find, but the recipient gets the message as "Untitled Attachment 000X.pdf"
How do I give the attachment a name?
I have something like this. But never tried.
'With cdomessage
.AddAttachment "c:/i/report.pdf"
.Attachments(1).Fields.Item("urn:schemas:mailheader:content-disposition") ="attachment;filename=" & NEWNAME
.Attachments(1).Fields.Update
'End With
I have set this up to auto email through the Outlook client, is it possible to change this code to work directly through an SMTP server? And could anyone possibly help me do it?
Any help would be much appreciated, thanks!
Set app = CreateObject("Excel.Application")
Set fso = CreateObject("Scripting.FileSystemObject")
For Each f In fso.GetFolder("Y:\Billing_Common\autoemail").Files
If LCase(fso.GetExtensionName(f)) = "xls" Then
Set wb = app.Workbooks.Open(f.Path)
set sh = wb.Sheets("Auto Email Script")
row = 2
name = "Customer"
email = sh.Range("A" & row)
subject = "Billing"
the = "the"
LastRow = sh.UsedRange.Rows.Count
For r = row to LastRow
If App.WorkSheetFunction.CountA(sh.Rows(r)) <> 0 Then
SendMessage email, name, subject, TRUE, _
NULL, "Y:\Billing_Common\autoemail\Script\energia-logo.gif", 143,393
row = row + 1
email = sh.Range("A" & row)
End if
Next
wb.Close
End If
Next
Sub SendMessage(EmailAddress, DisplayName, Subject, DisplayMsg, AttachmentPath, ImagePath, ImageHeight, ImageWidth)
' Create the Outlook session.
Set objOutlook = CreateObject("Outlook.Application")
template = FindTemplate()
' Create the message.
Set objOutlookMsg = objOutlook.CreateItem(0)
With objOutlookMsg
' Add the To recipient(s) to the message.
Set objOutlookRecip = .Recipients.Add(EmailAddress)
objOutlookRecip.resolve
objOutlookRecip.Type = 1
' Set the Subject, Body, and Importance of the message.
.Subject = Subject
.bodyformat = 3
.Importance = 2 'High importance
body = Replace(template, "{First}", name)
body = Replace(body, "{the}", the)
if not isNull(ImagePath) then
if not ImagePath = "" then
.Attachments.add ImagePath
image = split(ImagePath,"\")(ubound(split(ImagePath,"\")))
body = Replace(body, "{image}", "<img src='cid:" & image & _
"'" & " height=" & ImageHeight &" width=" & ImageWidth & ">")
end if
else
body = Replace(body, "{image}", "")
end if
if not isNull(AttachMentPath) then
.Attachments.add AttachmentPath
end if
.HTMLBody = body
.Save
.Send
End With
Set objOutlook = Nothing
End Sub
Function FindTemplate()
Set OL = GetObject("", "Outlook.Application")
set Drafts = OL.GetNamespace("MAPI").GetDefaultFolder(16)
Set oItems = Drafts.Items
For Each Draft In oItems
If Draft.subject = "Template" Then
FindTemplate = Draft.HTMLBody
Exit Function
End If
Next
End Function
If you want to send mail directly to an SMTP server, there's no need to go through Outlook in the first place. Just use CDO. Something like this:
schema = "http://schemas.microsoft.com/cdo/configuration/"
Set msg = CreateObject("CDO.Message")
msg.Subject = "Test"
msg.From = "sender#example.com"
msg.To = "recipient#example.org"
msg.TextBody = "This is some sample message text."
With msg.Configuration.Fields
.Item(schema & "sendusing") = 2
.Item(schema & "smtpserver") = "smtp.intern.example.com"
.Item(schema & "smtpserverport") = 25
.Update
End With
msg.Send
A while back i have searched for a flexible way to automatically generate a signature for different types of users. Our domain has multiple companies and each have different needs. The default scripts you find when googeling simply shows how to create a basic signature.
The script below takes is a few steps further. It fills in the username & initials when first starting up Microsoft Office. If no outlook profile is present it will set up outlook using a PRF file (you can use cached for laptops/tablets and non cached for desktops / servers). It then checks which signatures a user should get and builds them using the information in the signature file, template file and user information from active directory. All status information gets written to the application event log (filter WSH). When a signature file gets updated, the signature will be re-applied.
I am posting the entire script here hoping that someone else might find it usefull. Feel free to comment (or donate ofcourse :-)). It works for Outlook 2000, 2003, 2010 and 2013 (and should be pretty future proof).
Create a new Global Securitygroup in your domain. In my example i will use Signature-Marketing and Signature-HR.
Create a new GPO that applies on these groups. Place the Outlook.vbs script in User \ Policy \ Windows \ Scripts \ Logon.
'\\MyDomain.local\SysVol\WGIT.local\Policies\{MyPolicyID}\User\Scripts\Logon\Outlook.vbs
On Error Resume Next
' ##### CHANGE THESE SETTINGS #####
setup_GroupPrefix = "Signature-"
setup_Path_SignatureVBS = "\\MyDomain.local\NETLOGON\Outlook\Signatures" 'Signatures with the same name as this group (+.VBS) will be searched within this
setup_Path_Template = "\\MyDomain.local\NETLOGON\Outlook\Templates" 'Signatures with the same name as this group (+.VBS) will be searched within this
setup_PRF_CacheOn = "\\MyDomain.local\NETLOGON\Outlook\PRF\Outlook_Cached.PRF"
setup_PRF_CacheOff = "\\MyDomain.local\NETLOGON\Outlook\PRF\Outlook_NotCached.PRF"
' ##### START OF SCRIPT #####
Set oShell = CreateObject("WScript.Shell")
Set oAD = CreateObject("ADSystemInfo")
Set oFile = CreateObject("Scripting.FileSystemObject")
Set oOutlook = CreateObject("Outlook.Application")
Set oUser = GetObject("LDAP://" & oAD.UserName)
'Quit if no outlook is present!
If oOutlook = false Then
oShell.LogEvent 1, "Signature script error. Outlook application object was not found."
Wscript.Quit
End If
'Quit if version is lower then 10
v = Split(oOutlook.Version, ".")
outlook_Version = v(0) & "." & v(1)
If cInt(v(0)) < 10 Then
oShell.LogEvent 1, "Signature script error. Outlook version " & outlook_Version & " is not supported."
Wscript.Quit
ElseIf (cInt(v(0)) >= 10) And (cInt(v(0)) < 15) Then
reg_DefaultProfile = "HKCU\Software\Microsoft\Windows NT\CurrentVersion\Windows Messaging Subsystem\Profiles\DefaultProfile"
Else
reg_DefaultProfile = "HKCU\Software\Microsoft\Office\" & outlook_Version & "\Outlook\DefaultProfile"
End If
'Check if Office's Userinfo already exists
t1 = oShell.RegRead("HKCU\Software\Microsoft\Office\Common\UserInfo\UserName")
If t1 = "" Then
'Add userinfo to registry.
oShell.RegWrite "HKCU\Software\Microsoft\Office\Common\UserInfo\UserName", oUser.FullName
oShell.RegWrite "HKCU\Software\Microsoft\Office\Common\UserInfo\UserInitials", oUser.sAMAccountName
oShell.RegWrite "HKCU\Software\Microsoft\Office\Common\UserInfo\Company", oUser.company
oShell.LogEvent 0, "Office userinformation was imported from AD."
End If
'Check for a default mail profile
t2 = oShell.RegRead(reg_DefaultProfile)
oShell.LogEvent 0, "Default profile (" & reg_DefaultProfile & ") said " & t2
If t2 = "" Then 'No default profile was found! Import PRF file!
'Detect mobile devices. Enabled cached outlook if there is a battery present
MobileDevice = false
Set oBattery = GetObject("Winmgmts:").ExecQuery("Select * from Win32_Battery")
For Each x in oBattery
MobileDevice = true
Next
'Import PRF location into registry
If MobileDevice Then
oShell.RegWrite "HKCU\Software\Microsoft\Office\" & outlook_Version & "\Outlook\Setup\ImportPRF", setup_PRF_CacheOn
oShell.LogEvent 0, "Office Outlook has been set-up with cache."
Else
oShell.RegWrite "HKCU\Software\Microsoft\Office\" & outlook_Version & "\Outlook\Setup\ImportPRF", setup_PRF_CacheOff
oShell.LogEvent 0, "Office Outlook has been set-up without cache."
End If
'Delete First-Run key to simulate a first run for outlook. (i.e. if a profile was configured and deleted)
oShell.RegDelete "HKCU\Software\Microsoft\Office\" & outlook_Version & "\Outlook\Setup\First-Run"
'Outlook does not need to be run.
'When a signature is being applied outlook will fire up it's initial boot and import the PRF settings.
'With this PRF applied the signature will be applied immediately
End If
'Compare users' group membership against available signature settings
Set GroupsOfUser = GetMembership(oUser.distinguishedName, null)
tGroups = Array()
For Each GroupName in GroupsOfUser.Items()
If Mid(GroupName, 1, Len(setup_GroupPrefix)) = setup_GroupPrefix Then
ReDim Preserve tGroups(UBound(tGroups) + 1)
tGroups(UBound(tGroups)) = GroupName
end if
Next
tGroups = SortArray(tGroups)
For Each group in tGroups
sFile = setup_Path_SignatureVBS & "\" & group & ".VBS"
If oFile.FileExists(sFile) = True Then 'File containing specific signature settings were found
Set Signature = new Defaults 'Use defaults
'Evaluate signature settings
executeGlobal oFile.openTextFile(sFile).readAll()
'Check if signature needs updating
sUpdate = false
If oFile.FileExists(Signature.sPath) Then
Set f = oFile.GetFile(Signature.sPath)
If Signature.sVersion > f.DateLastModified Then
sUpdate = true
End If
Else
sUpdate = true
End If
If sUpdate Then 'Apply signature
'Replace defaults with user specific data
If Not oUser.FullName = "" Then Signature.uName = oUser.FullName
If Not oUser.mail = "" Then Signature.uMail = LCase(oUser.mail)
If Not oUser.telephoneNumber = "" Then Signature.uPhone = oUser.telephoneNumber
If Not oUser.mobile = "" Then Signature.uCell = oUser.mobile
If Not oUser.facsimileTelephoneNumber = "" Then Signature.uFax = oUser.facsimileTelephoneNumber
If Not oUser.Title = "" Then Signature.uTitle = oUser.Title
If Not oUser.department = "" Then Signature.uDepartment = oUser.department
If Not oUser.info = "" Then Signature.uDisclaimer = oUser.info
'Build signature
Set oWord = CreateObject("Word.Application")
Set oDoc = oWord.Documents.Add()
Set oSelection = oWord.Selection
executeGlobal oFile.openTextFile(setup_Path_Template & "\" & Signature.sTemplate).readAll() 'Evaluate signatre template
Set oSelection = oDoc.Range()
'Add signature to outlook
oWord.EmailOptions.EmailSignature.EmailSignatureEntries.Add Signature.sName, oSelection
WScript.Sleep 200 'Give outlook the time to create the necessary files
'Set as default signature
If Signature.sCompanyNew = "*" OR StrComp(oUser.company, Signature.sCompanyNew, vbTextCompare) = 0 Then oWord.EmailOptions.EmailSignature.NewMessageSignature = Signature.sName
If Signature.sCompanyReply = "*" OR StrComp(oUser.company, Signature.sCompanyReply, vbTextCompare) = 0 Then oWord.EmailOptions.EmailSignature.ReplyMessageSignature = Signature.sName
'Closure
oDoc.Saved = True
oWord.Quit
WScript.Sleep 300 'Give work some time to clean up
'Logging
oShell.LogEvent 0, "Signature " & Signature.sName & " applied with success!"
Else
oShell.LogEvent 0, "Signature " & Signature.sName & " is up to date."
End If
Else
oShell.LogEvent 1, "Signature script error. Cannot load signature settings from " & sFile
End If
Next
' ##### CLASSES AND FUNCTIONS ######
Class Defaults
'Signature properties
Public sName 'Name of this signature
Public sVersion 'Apply signature if version date is newer then client's signature date
Public sTemplate 'Signature template to be used
Public sCompanyNew 'If the user company field matches this value it will be set as the default 'new' signature
Public sCompanyReply 'If the user company field matches this value it will be set as the default 'reply' signature
'Company properties
Public cName
Public cStreet
Public cBox
Public cPostal
Public cCity
Public cState
Public cCountry
Public cMail
Public cVat
Public cWebsite
Public cUrl
Public cLogo
Public cLogoPath
Public cPhone
Public cFax
'User properties
Public uName
Public uMail
Public uPhone
Public uCell
Public uFax
Public uTitle
Public uDepartment
Public uDisclaimer
Private Sub Class_Initialize()
me.sName = "The name of my signature"
me.sVersion = CDate("1/10/2012")
me.sTemplate = "Default.vbs"
me.cName = "MY COMPANY NAME"
me.cStreet = "Street"
me.cBox = "123"
me.cPostal = "ZIP"
me.cCity = "CITY"
me.cMail = "info#company.com"
me.cVat = "VAT NUMBER"
me.cWebsite = "www.company.com"
me.cUrl = "http://www.company.com"
me.cPhone = "+32 3 456 780"
me.cFax = "+32 3 456 789"
me.uName = "John Doe"
me.uPhone = "+32 3 456 780"
me.uFax = "+32 3 456 780"
End Sub
Public Property Get sPath()
sPath = oShell.ExpandEnvironmentStrings("%AppData%") + "\Microsoft\" & oShell.RegRead("HKCU\Software\Microsoft\Office\" & outlook_Version & "\Common\General\Signatures") & "\" & me.sName & ".htm"
End Property
End Class
Function SortArray(arrShort)
Dim i, j, temp
For i = UBound(arrShort) - 1 To 0 Step -1
For j= 0 To i
If arrShort(j)>arrShort(j+1) Then
temp=arrShort(j+1)
arrShort(j+1)=arrShort(j)
arrShort(j)=temp
End If
Next
Next
SortArray = arrShort
End Function
Function GetMembership(sChild, dMembership)
'Get AD info on the given Child
Set oChild = GetObject("LDAP://" & sChild)
If TypeName(oChild) = "Object" Then
'Add the Child's canonical name to the array IF it's a group
If TypeName(dMembership) = "Dictionary" Then
dMembership.Add oChild.distinguishedName, oChild.CN
Else
Set dMembership = CreateObject("Scripting.Dictionary")
End If
'If the Child has any parents (=groups), run the same loop for these parents.
If TypeName(oChild.memberOf) = "Variant()" Then
oParents = oChild.GetEx("memberOf")
For Each sParent in oParents
If Not dMembership.Exists(sParent) Then
Set dMembership = GetMembership(sParent, dMembership)
End If
Next
End If
End If
Set GetMembership = dMembership
End Function
Below the signature 'guide'. These scripts MUST have the same name as the group created in AD to work. When a user is a member of the AD group Signature-Marketing, it will run \\MyDomain.local\NETLOGON\Outlook\Signatures\Signature-Marketing.vbs
'\\MyDomain.local\NETLOGON\Outlook\Signatures\MyGroupName.vbs
'Set specific default values
Signature.sVersion = CDate("3/12/2012 15:35")
Signature.sName = "The name of my signature"
Signature.sCompanyNew = "MY COMPANY NAME"
Signature.sCompanyReply = "MY COMPANY NAME"
Signature.cName = "MY COMPANY NAME"
Signature.cStreet = "Street"
Signature.cBox = "123"
Signature.cPostal = "ZIP"
Signature.cCity = "City"
Signature.cMail = "info#company.com"
Signature.cVat = "VAT NUMBER"
Signature.cWebsite = "www.company.com"
Signature.cUrl = "http://www.company.com"
Signature.cLogo = "\\MyDomain.local\NETLOGON\Outlook\IMG\MyCompanyLogo.png"
Signature.cPhone = "+32 3 456 780"
Signature.cFax = "+32 3 456 789"
Signature.uName = "John Doe"
Signature.uPhone = "+32 3 456 780"
Signature.uFax = "+32 3 456 789"
Below the default template. This script gets evaluated within Outlook.vbs
'\\MyDomain.local\NETLOGON\Outlook\Templates\Default.vbs
oSelection.Font.Name = "Calibri"
oSelection.Font.Size = 11
oSelection.TypeText Signature.uName
If Not Signature.uTitle = "" Then
oSelection.TypeText Chr(11)
oSelection.TypeText Signature.uTitle
End If
If Not Signature.uDisclaimer = "" Then oSelection.TypeText " (*)"
' ### Add company table & info
oSelection.TypeParagraph()
Set tbl = oDoc.Tables.Add(oSelection.Range, 1, 2)
Set oTable = oDoc.Tables(1)
tWidth = oTable.Cell(1, 1).width + oTable.Cell(1, 2).width
' Add company logo to cell 1
Set oCell = oTable.Cell(1, 1)
Set oCellRange = oCell.Range
oCell.Select
Set oLogo = oSelection.InlineShapes.AddPicture(Signature.cLogo)
oLogo.LockAspectRatio = true
oLogo.height = oWord.PixelsToPoints(50)
oCell.width = oLogo.width
' Add company info to cell 2
If Signature.cVat = "" Then
arrAddressInfo = Array(Signature.cName, Signature.cStreet & " " & Signature.cBox, Signature.cPostal & " " & Signature.cCity)
Else
arrAddressInfo = Array(Signature.cName, Signature.cStreet & " " & Signature.cBox, Signature.cPostal & " " & Signature.cCity, Signature.cVat)
End If
strAddressInfo = Join(arrAddressInfo, " | ")
Set oCell = oTable.Cell(1, 2)
Set oCellRange = oCell.Range
oCell.Select
oCell.width = tWidth - oLogo.width
oSelection.Font.Size = 10
oSelection.TypeText strAddressInfo
' Add phone number information
arrUserInfo = Array()
If Not Signature.uPhone = "" Then
ReDim Preserve arrUserInfo(UBound(arrUserInfo) + 1)
arrUserInfo(UBound(arrUserInfo)) = "T " & Signature.uPhone
End If
If Not Signature.uCell = "" Then
ReDim Preserve arrUserInfo(UBound(arrUserInfo) + 1)
arrUserInfo(UBound(arrUserInfo)) = "G " & Signature.uCell
End If
If Not Signature.uFax = "" Then
ReDim Preserve arrUserInfo(UBound(arrUserInfo) + 1)
arrUserInfo(UBound(arrUserInfo)) = "F " & Signature.uFax
End If
strUserInfo = Join(arrUserInfo, " | ")
If Not strUserInfo = "" Then
oSelection.TypeText Chr(11)
oSelection.TypeText strUserInfo
End If
oSelection.TypeText Chr(11)
' Add user mail address to cell 2
Set oLink = oSelection.Hyperlinks.Add(oSelection.Range, "mailto:" & Signature.uMail, , , Signature.uMail)
oLink.Range.Font.Color = oSelection.Font.Color
oLink.Range.Font.Size = 10
' Add company weblink to cell 2
oSelection.TypeText " | "
Set oLink = oSelection.Hyperlinks.Add(oSelection.Range, Signature.cUrl, , , Signature.cWebsite)
oLink.Range.Font.Color = oSelection.Font.Color
oLink.Range.Font.Size = 10
If Not Signature.uDisclaimer = "" Then oSelection.TypeText " | (*) " & Signature.uDisclaimer
tbl.Rows(1).Cells.VerticalAlignment = 1
oTable.AutoFitBehavior(1)
\\MyDomain.local\NETLOGON\Outlook\PRF\Outlook_Cached.PRF
\\MyDomain.local\NETLOGON\Outlook\PRF\Outlook_NotCached.PRF
Create your own PRF file (quote from Microsoft TechNet):
To create a PRF file by using the Office Customization Tool
From the root of the network installation point, run the following command line to start the Office Customization Tool: \server\share\setup.exe /admin
To edit an existing customization file (.msp), in the Select Product dialog box, click Open an existing Setup customization file. Or to create a new customization file, select the Office suite that you want to customize, and then click OK.
In the Outlook area, click Outlook Profile. Select how you want to customize profiles for users. To specify settings to be included in a .prf file, choose Modify Profile or New Profile.
To add and configure new accounts or to modify or remove existing accounts, click Add accounts, and then click Customize additional Outlook profile and account information.
Once you complete the Outlook profile configurations, in the Outlook area, click Export settings.
Click the Export Profile Settings button to create a new .prf file. Enter a file name and the path on which to save the file, and then click Save.
The open source project GenerateSignatureFromLDAP can generate Outlook signatures based on a template and values taken from Active Directory.
This can be set in a startup script (e.g. via GPO).
The templates can contain "if" statements to modify the template based on specific criteria (e.g. the current date or an AD attribute like location).
See: https://sourceforge.net/projects/gensignfromldap/