Auto generate outlook signature by GPO using multiple signatures - vbscript

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/

Related

Outlook Rule will not run script unless manually ran

Whenever I add my script to a rule i have setup in outlook it sets my rule to client-side only. The rule is used to get a specific word in the subject line and a specific word in the body then move the email to a subfolder of the Inbox then run a script. The current rule runs when I receive the email by moving the email to the directed folder but the script does not run unless I manually click the rule to run now. How could I make it to where it would be processed on server side only so I won't have to manually run the rule to run the script. Here is my script below:
Public Sub Application_NewMail(myMail As MailItem)
Dim con As ADODB.Connection
Dim rs As ADODB.Recordset
Dim dbName As String
dbName = "M:\CRM\Custom CRM\CRM.accdb"
Set con = New ADODB.Connection
con.ConnectionString = _
"Provider = Microsoft.ACE.OLEDB.12.0; " & _
"Data Source = " & dbName & "; " & _
"Persist Security Info = False; " & _
"Mode = readwrite;"
con.Open
' Create 2 recordset objects for data manipulation throughout the project
Set rs = New ADODB.Recordset
With rs
.CursorLocation = adUseClient
.ActiveConnection = con
.CursorType = adOpenDynamic
.LockType = adLockOptimistic
End With
Dim ns As Outlook.NameSpace
Dim InBoxFolder As MAPIFolder
Dim InBoxItem As Object 'MailItem
Dim Contents As String, Delimiter As String
Dim Prop, Result
Dim i As Long, j As Long, k As Long
Dim myOlApp As Object
Set myOlApp = CreateObject("Outlook.Application")
'Setup an array with all properties that can be found in the mail
Prop = Array("Name", "Email", "Phone", "I am an")
'The delimiter after the property
Delimiter = ":"
Set ns = Session.Application.GetNamespace("MAPI")
'Access the inbox folder
Set InBoxFolder = ns.GetDefaultFolder(olFolderInbox)
Set InBoxFolder = InBoxFolder.Folders("MBAA LEADS")
For Each InBoxItem In InBoxFolder.Items
'Only process mails
If Not TypeOf InBoxItem Is MailItem Then GoTo SkipItem
'Already processed?
If Not InBoxItem.UnRead Then GoTo SkipItem
'Mark as read
InBoxItem.UnRead = False
'Get the body
Contents = InBoxItem.Body
'Create space for the result
ReDim Result(LBound(Prop) To UBound(Prop)) As String
'Search each property
i = 1
rs.Open ("Prospects")
rs.AddNew
For k = LBound(Prop) To UBound(Prop)
'MsgBox k
'Find the property (after the last position)
i = InStr(i, Contents, Prop(k), vbTextCompare)
If i = 0 Then GoTo NextProp
'Find the delimiter after the property
i = InStr(i, Contents, Delimiter)
If i = 0 Then GoTo NextProp
'Find the end of this line
j = InStr(i, Contents, vbCr)
If j = 0 Then GoTo NextProp
'Store the related part
Result(k) = Trim$(Mid$(Contents, i + Len(Delimiter), j - i - Len(Delimiter)))
If (k = 0) Then
'First Name
rs![First Name] = StrConv(Trim(Mid(CStr(Result(k)), 1, InStr(CStr(Result(k)), " "))), vbProperCase)
'Last Name
rs![Last Name] = StrConv(Trim(Mid(CStr(Result(k)), InStrRev(CStr(Result(k)), " ") + 1)), vbProperCase)
MkDir ("M:\CRM\PROSPECTS\" & StrConv(Trim(Mid(CStr(Result(k)), 1, InStr(CStr(Result(k)), " "))), vbProperCase) & " " & StrConv(Trim(Mid(CStr(Result(k)), InStrRev(CStr(Result(k)), " ") + 1)), vbProperCase) & "")
'Copy Initial Email Inquiry
InBoxItem.SaveAs "M:\CRM\PROSPECTS\" & StrConv(Trim(Mid(CStr(Result(k)), 1, InStr(CStr(Result(k)), " "))), vbProperCase) & " " & StrConv(Trim(Mid(CStr(Result(k)), InStrRev(CStr(Result(k)), " ") + 1)), vbProperCase) & "\Initial Email-MBAA WEBSITE.msg"
ElseIf (k = 1) Then
rs![E-mail Address] = Trim(Mid(CStr(Result(k)), 1, InStr(CStr(Result(k)), " ")))
ElseIf (k = 2) Then
rs![Home Phone] = Result(k)
ElseIf (k = 3) Then
'Check customer type
If CStr(Result(k)) Like "*Self Insured Group*" Then
rs![Lead Type] = 1 'Self Insured Group
ElseIf CStr(Result(k)) Like "*Insurance Company*" Then
rs![Lead Type] = 2 'Insurance Company
ElseIf CStr(Result(k)) Like "*Individual Patient*" Then
rs![Lead Type] = 3 'Consumer
ElseIf CStr(Result(k)) Like "*Attorney*" Then
rs![Lead Type] = 4 'Attorney
ElseIf CStr(Result(k)) Like "*Government*" Then
rs![Lead Type] = 5 'Attorney
ElseIf CStr(Result(k)) Like "*Physician*" Then
rs![Lead Type] = 6 'Physician
ElseIf CStr(Result(k)) Like "*International Company*" Then
rs![Lead Type] = 7 'International Company
ElseIf CStr(Result(k)) Like "*Broker*" Then
rs![Lead Type] = 8 'Broker
ElseIf CStr(Result(k)) Like "*Association/Organization*" Then
rs![Lead Type] = 19 'Association/Organization
ElseIf CStr(Result(k)) Like "*Other*" Then
rs![Lead Type] = 9 'Other
End If
End If
NextProp:
Next
rs![CreatedOn] = InBoxItem.SentOn
rs![Source] = 13 'MBAA WEBSITE
rs.Update
rs.Close
SkipItem:
Next
con.Close
End Sub
I'll assume that your mailbox is on an Exchange server or Office365 (which is also Exchange).
Server side rules only work for a limited set of actions. Mostly those actions that are simple, like moving items, replying, etc.
Anything more complicated than that becomes a client-only rule. In the case of a rule that runs a script, those will always be client-only rules because the script is actually part of, and executed by Outlook, not the mail server. So, even though the rule is stored in your mailbox, the execution is such that it requires Outlook to work some parts of the action.
You'll see when you finish making a rule, on the last page of the rule wizard, it will indicate whether it is a client-only rule or not.
The only option for a server side rule using a script, or some code as at the server level as either a Transport Rule, or a Transport Agent.
I would suggest that you break up the action in to 2 parts, one that will be a server-side rule and will run with or without Outlook, then a rule that you can run "on-demand" to do the more complicated bits. It's not fully automated, but at least you can get the items moved to some temporary folder and out of the way.

Access Microsoft Outlook to print the List of members

Please advice how to get the following
From Microsoft outlook
Type SOMETHING in the “search address books”
Click properties
In the Members list we see all the members names
The target is to print all the members names to a file.
How to do this task with VB script or with any other Code?
example:
I found this, but I not understand how to set my distribution list in the VB code to print the distribution list members
For example If I have the distribution list MY_HOME
how do I insert the MY_HOME in the VB code to print all members?
Const olFolderContacts = 10
Set objOutlook = CreateObject("Outlook.Application")
Set objNamespace = objOutlook.GetNamespace("MAPI")
Set colContacts = objNamespace.GetDefaultFolder(olFolderContacts).Items
intCount = colContacts.Count
For i = 1 To intCount
If TypeName(colContacts.Item(1)) = "DistListItem" Then
Set objDistList = colContacts.Item(i)
Wscript.Echo objDistList.DLName
For j = 1 To objDistList.MemberCount
Wscript.Echo objDistList.GetMember(j).Name & " -- " & _
objDistList.GetMember(j).Address
Next
Wscript.Echo
End If
Next
Call Namespace.CreateRecipient / Recipient.Resolve / Recipient.AddressEntry.Members.
UPDATE:
Set objOutlook = CreateObject("Outlook.Application")
Set objNamespace = objOutlook.GetNamespace("MAPI")
objNamespace.Logon
set objRecip = objNamespace.CreateRecipient("MY_HOME")
if objRecip.Resolve Then
set objMembers = objRecip.AddressEntry.Members
if not (objMembers Is Nothing) Then
for each objMember in objMembers
Wscript.Echo objMember.Name & " : " & objMember.Address
next
end If
End If

Recordset Operation is Not allowed when object is closed VBS

In the code bellow I get an error on the line reading recset.Close.
Char: 5
Error: Operation is not allowed when the object is closed.
Code: 800A0E78
Source: ADODB.Recordset
If the program reaches the line PQ_ID_number = InputBox("Enter PQ Database ID number, Do not use / ? < > \ : * | !", "PQ ID Number", "Replace Text") it seems to work fine (taking manual input) but when it tries to get the ID from the URL of a browser (automaticaly) it gives the error.
valid_name = 0
Dim objInstances, objIE, counterTab
Do While valid_name = 0 'Flag to exit the loop if the Id number has content in the SQL Database'
'-----------------------------------------------------------------------------------------'
Set objInstances = CreateObject("Shell.Application").windows
If objInstances.Count > 0 Then '/// make sure we have IE instances open.
'Loop through each tab.'
For Each objIE In objInstances
'Split the url of current tab using /'
splitURL = Split(objIE.LocationURL,"/")
'Count how many sub strings are in the URL when split'
counter = UBound(splitURL)
if counter = 7 Then
lastSplit = Split(splitURL(7),".")
lastURL = splitURL(0) & "//" & splitURL(2) & "/" & splitURL(3) & "/" & splitURL(4) & "/" & splitURL(5) & "/" & splitURL(6) & "/" & lastSplit(0)
if lastURL = "URL" Then
Set IE = objIE
counterTab = counterTab + 1
end if
end if
'End if
Next
Else
'If no internet explorer window is open.'
MsgBox "No Internet Explorer window found."
wscript.quit
End if
'Check if no [] is open in internet explorer'
if IsObject(IE) Then
url = Split(IE.LocationURL,"=")
url2 = Split(url(1),"&")
PQ_ID_number = url2(0)
else
MsgBox "No incident found."
wscript.quit
end if
'counterTab counts how many [] are open. If there is more than 1, ask for confirmation of last [] number.'
if counterTab > 1 Then
confirm = msgbox("Please confirm Incident ID: " & incidentID,vbYesNo,"Confirmation")
'If no is pressed, ask for manual entry.'
if confirm = vbNo Then
PQ_ID_number = InputBox("Enter PQ Database ID number, Do not use / ? < > \ : * | !", "PQ ID Number", "Replace Text")
On Error Resume Next
If PQ_ID_number = False Then
wscript.quit
End If
end if
end if
'-----------------------------------------------------------------------------------------'
'Open connection in Database'
dbConnectStr = "connection string"
Set con = CreateObject("ADODB.Connection")
Set recset = CreateObject("ADODB.Recordset")
con.Open dbConnectStr
'Get PQ Database title and status of incident number provided.
SQL_String = "Select title, status_id from incident_TBL where incident_ID = " & PQ_ID_number
recset.Open SQL_String, con
title = recset.Fields(0).Value
incidentStatus = recset.Fields(1).Value
con.Close
recset.Close
If title = False Then 'check if PQ_ID given has content in SQL Database
wscript.echo "Invalid PQ Database ID number, please type correct number"
valid_name = 0
Else
valid_name = 1
End If
Loop
Thanks for the help!
you need close Recordset first and only after that close connection
con.Close
recset.Close
change to:
recset.Close
con.Close

Autogenerate an email in an outlook and attach the currently open word document with VBS

I want to write a VBS macro to auto generate an email in outlook and attach a word document. I currently have a macro that does this for excel, but I can't get it to work for Word. I can't figure out for the life of me what my "FName= " should be. Any suggestions or help would be greatly appreciated. Here is what I have:
Sub AutoEmail()
On Error GoTo Cancel
Dim Resp As Integer
Resp = MsgBox(prompt:=vbCr & "Yes = Review Email" & vbCr & "No = Immediately Send" & vbCr & "Cancel = Cancel" & vbCr, _
Title:="Review email before sending?", _
Buttons:=3 + 32)
Select Case Resp
'Yes was clicked, user wants to review email first
Case Is = 6
Dim myOutlook As Object
Dim myMailItem As Object
Set otlApp = CreateObject("Outlook.Application")
Set otlNewMail = otlApp.CreateItem(olMailItem)
FName = ActiveWord & "\" & ActiveWord.Name
With otlNewMail
.To = ""
.CC = ""
.Subject = ""
.Body = "Good Morning," & vbCr & vbCr & "" & Format(Date, "MM/DD") & "."
.Attachments.Add FName
.Display
End With
Set otlNewMail = Nothing
Set otlApp = Nothing
Set otlAttach = Nothing
Set otlMess = Nothing
Set otlNSpace = Nothing
'If no is clicked
Case Is = 7
Dim myOutlok As Object
Dim myMailItm As Object
Set otlApp = CreateObject("Outlook.Application")
Set otlNewMail = otlApp.CreateItem(olMailItem)
FName = ActiveWorkbook.Path & "\" & ActiveWorkbook.Name
With otlNewMail
.To = ""
.CC = ""
.Subject = ""
.Body = "Good Morning," & vbCr & vbCr & " " & Format(Date, "MM/DD") & "."
.Attachments.Add FName
.Send
'.Display
'Application.Wait (Now + TimeValue("0:00:01"))
'Application.SendKeys "%s"
End With
'otlApp.Quit
Set otlNewMail = Nothing
Set otlApp = Nothing
Set otlAttach = Nothing
Set otlMess = Nothing
Set otlNSpace = Nothing
'If Cancel is clicked
Case Is = 2
Cancel:
MsgBox prompt:="No Email has been sent.", _
Title:="EMAIL CANCELLED", _
Buttons:=64
End Select
End Sub
May it is a bit late, but I want to solve it for future use.
You want to have the active document as your file name (FName).
FName = Application.ActiveDocument.Path + "\" + Application.ActiveDocument.Name
' .Path returns only the Path where the file is saved without the file name like "C:\Test"
' .Name returns only the Name of the file, including the current type like "example.doc"
' Backslash is needed because of the missing backslash from .Path
otlNewMail.Attachements.Add FName
May you also want to save your current document before sending it via outlook, otherwise you will send the document without the changes made.
Function SaveDoc()
ActiveDocument.Save
End Function
I hope that this will help others, because the code from the question helped me a lot while scripting a similar script.

VBS Script for modifying multi-value Active Directory display specifier

Following the howto Extending the Active Directory Schema To Track Custom Info I'm able to setup a single-value schema attribute that is easily changeable via a context menu in ADUC. Multi-value schema attributes get considerably more complicated. Say (for the sake of argument) my value is "Projects" and each user may be a list as many projects as necessary.
Following is a sad little script that will set Project to a single value:
Dim oproject
Dim oUser1
Dim temp1
Set oproject = Wscript.Arguments
Set oUser1 = GetObject(oproject(0))
temp1 = InputBox("Project: " & oUser1.project & vbCRLF & vbCRLF & "Project")
if temp1 <> "" then oUser1.Put "project",temp1
oUser1.SetInfo
Set oUser1 = Nothing
Set oproject = Nothing
Set temp1 = Nothing
WScript.Quit
How can I modify this to allow, assign, and modify multiple values?
I gave up on an elegant UI and just went with the semicolon delimited list. Here's the code if anyone cares:
Dim objProject
Dim objUser
Dim temp1, title, message, default
Dim projects
title = "Projects"
Set objProject = Wscript.Arguments
Set objUser = GetObject(objProject(0))
'Find our current projects
projects = objUser.projects
If Not isArray(projects) Then
projects = Array(projects)
End If
'Setup our message box
message = "Semicolon-delimited list of Projects"
default = arrayToStr(projects)
temp1 = InputBox(message, title, default)
'catch cancels
if IsEmpty(temp1) Then
WScript.Quit
End If
' update our data
projects = strToArray(temp1)
objUser.Put "projects",projects
objUser.SetInfo
'Clean up and quit
Set projects = Nothing
Set objUser = Nothing
Set objProject = Nothing
Set temp1 = Nothing
Set title = Nothing
Set message = Nothing
Set default = Nothing
WScript.Quit
'Functions
Function strToArray(s)
Dim a
Dim token
' discard blank entries
For Each token in split(s, ";")
token = trim(token)
If token <> "" Then
If isEmpty(a) Then
a = token
Else
a = a & ";" & token
End If
End If
Next
' return array
strToArray = split(a, ";")
End Function
Function arrayToStr(a)
Dim s
Dim token
For Each token in a
If isEmpty(s) Then
s = token
Else
s = s & ";" & token
End If
Next
' return string
arrayToStr = s
End Function

Resources