?
Solved

VBS email template from SQL query - need guidance on grouping/looping

Posted on 2009-02-08
22
Medium Priority
?
379 Views
Last Modified: 2013-11-10
I have a VBS script that queries a SQL database for a list of managers and their subordinates. The script then loops through each line and emails the manager with a template displaying the user under them. Currently it generates a single email for each record returned. What I want to do is group all users under a single email to the supervisor. Sample recordset, template, and vbs script included.
---------Sample Recordset
 
Manager  ManagersEmail  User
-------- -------------- -----
John     john@a.com     Mike
Steve    steve@a.com    Chris
Steve    steve@a.com    Gina
Steve    steve@a.com    Tom
Steve    steve@a.com    Jenny
Cathy    cathy@a.com    Hal
Mary     mary@a.com     Arnold
Mary     mary@a.com     Irene
Mary     mary@a.com     Jan
 
 
 
 
---------Template Body
 
#############################################
 
To:       [$MANAGER$]
From:     IT
CC:       CC Person
Subject:  Quarterly Monitoring - Users Assigned To [$MANAGER$]
 
Please review the following users assigned to your area and confirm that these individuals are currently in your department and are properly authorized to have network access. Note any changes or updates below and email your response by responding to this message.
 
 
----------------------------------------------
Users assigned to [$MANAGER$]
[$USER$]
 
----------------------------------------------
 
 
## End of template.
#############################################
 
 
 
 
 
 
---------VBS Script
 
Const ForReading = 1, ForWriting = 2, ForAppending = 8
Const TEXTMSG = 0
Const HTMLMSG = 1
Const TemplateFile = "C:\Scripts\Template.txt"
 
if FileExists(TemplateFile) <> 0 then
  WScript.Echo "The email template file, " & Chr(34) & TemplateFile & Chr(34) & ", does not exit!"
  WScript.Quit
End If
 
Set fso = CreateObject("Scripting.FileSystemObject")
Set f = fso.OpenTextFile(TemplateFile, ForReading)
strBodyTextOrg = f.ReadAll
f.close
Set f = Nothing
set fso = Nothing
 
Set OBJdbConnection = CreateObject("ADODB.Connection") 
OBJdbConnection.Open "Provider=SQLOLEDB.1;Data Source=*************;Initial Catalog=*********","*******","**"
 
SQLQuery = "SELECT ****************"
Set Result = OBJdbConnection.Execute(SQLQuery) 
 
if Not Result.EOF then
  Do While Not Result.EOF
    strBodyText = strBodyTextOrg
    strBodyText = StripComments(strBodyText)
'This is the section of the script you customize for your template and database fields.
    strBodyText = ReplaceVariable(strBodyText, "[$MANAGER$]", Result("Manager"))
    strBodyText = ReplaceVariable(strBodyText, "[$MANAGERSEMAIL$]", Result("ManagersEmail"))
    strBodyText = ReplaceVariable(strBodyText, "[$USER$]", Result("User"))
    SendMail Result("ManagersEmail"), "from@address.com>", "Subject " & Result("Manager"), strBodyText, TEXTMSG, "cc@address.com"
'End customization.
    Result.MoveNext 
  loop
end If
 
OBJdbConnection.Close
 
Set Result = Nothing
Set OBJdbConnection = Nothing
 
Function ReplaceVariable(strTheString, strReplace, strReplaceWith)
ReplaceVariable = Replace (strTheString, strReplace, strReplaceWith, 1, -1, 1)
End Function
 
Function StripComments(strTheString)
Dim objRegExp
 
Set objRegExp = New RegExp
objRegExp.Global = True
objRegExp.Multiline = True
objRegExp.Pattern = "^##.*\n"
StripComments = objRegExp.Replace(strTheString, "")
 
Set objRegExp = Nothing
End Function
 
Function SendMail(strTo, strFrom, strSubject, strBody, msgType, strCC)
Set objMail = Wscript.CreateObject("CDO.Message")
 
objMail.To = strTo
objMail.From = strFrom
objMail.Subject = strSubject
objMail.CC = strCC
 
if msgType = TEXTMSG then
  objMail.TextBody = strBody
else
  objMail.HTMLBody = strBody
end if
 
objMail.Send
 
set objMail = Nothing
End Function
 
'return 0 if a file exists else -1
function FileExists(Fname)
Dim fs
 
Set fs = CreateObject("Scripting.FileSystemObject")
 
if fs.FileExists(Fname) = False then
  FileExists = -1
else
  FileExists = 0
end if
Set fs = Nothing
end function

Open in new window

0
Comment
Question by:naihelpdesk
  • 11
  • 11
22 Comments
 
LVL 24

Expert Comment

by:purplepomegranite
ID: 23589185
I would suggest something like the below.  Read the recordset and use temporary structures to store the users for each manager.  Once the recordset has been completely read, you can send the emails out.

The below code should do this, but it is impossible to test this due to the nature of the code, so post back if there are any issues.

Const ForReading = 1, ForWriting = 2, ForAppending = 8
Const TEXTMSG = 0
Const HTMLMSG = 1
Const TemplateFile = "C:\Scripts\Template.txt"
 
if FileExists(TemplateFile) <> 0 then
  WScript.Echo "The email template file, " & Chr(34) & TemplateFile & Chr(34) & ", does not exit!"
  WScript.Quit
End If
 
Set fso = CreateObject("Scripting.FileSystemObject")
Set f = fso.OpenTextFile(TemplateFile, ForReading)
strBodyTextOrg = f.ReadAll
f.close
Set f = Nothing
set fso = Nothing
 
Set OBJdbConnection = CreateObject("ADODB.Connection") 
OBJdbConnection.Open "Provider=SQLOLEDB.1;Data Source=*************;Initial Catalog=*********","*******","**"
 
SQLQuery = "SELECT ****************"
Set Result = OBJdbConnection.Execute(SQLQuery) 
 
dim arrEmails()
dim dicManagers
 
set dicManagers=CreateObject("Scripting.Dictionary")
redim arrEmails(0,2)
 
if Not Result.EOF then
	Do While Not Result.EOF
		if dicManagers.Exists(Result("Manager")) then
			arrEmails(dicManagers.Item(Result("Manager")),2)=arrEmails(dicManagers.Item(Result("Manager")),2) & ", " & Result("User")
		else
			redim preserve arrEmails(UBound(arrEmails,0)+1,2)
			arrEmails(UBound(arrEmails,0),0)=Result("Manager")
			arrEmails(UBound(arrEmails,0),1)=Result("ManagersEmail")
			arrEmails(UBound(arrEmails,0),2)=Result("User")
			dicManagers.Add Result("Manager"), UBound(arrEmails,0)
		end if			
		Result.MoveNext 
	loop
	Result.Close
	' Now loop through array and send emails
	dim i
	for i=1 to UBound(arrEmails,0)
		strBodyText = strBodyTextOrg
		strBodyText = StripComments(strBodyText)
		'This is the section of the script you customize for your template and database fields.
		strBodyText = ReplaceVariable(strBodyText, "[$MANAGER$]", arrEmail(i,0))
		strBodyText = ReplaceVariable(strBodyText, "[$MANAGERSEMAIL$]", arrEmail(i,1))
		strBodyText = ReplaceVariable(strBodyText, "[$USER$]", arrEmail(i,2))
		SendMail Result("ManagersEmail"), "from@address.com>", "Subject " & Result("Manager"), strBodyText, TEXTMSG, "cc@address.com"
	next
end If
 
OBJdbConnection.Close
 
Set Result = Nothing
Set OBJdbConnection = Nothing
 
Function ReplaceVariable(strTheString, strReplace, strReplaceWith)
ReplaceVariable = Replace (strTheString, strReplace, strReplaceWith, 1, -1, 1)
End Function
 
Function StripComments(strTheString)
Dim objRegExp
 
Set objRegExp = New RegExp
objRegExp.Global = True
objRegExp.Multiline = True
objRegExp.Pattern = "^##.*\n"
StripComments = objRegExp.Replace(strTheString, "")
 
Set objRegExp = Nothing
End Function
 
Function SendMail(strTo, strFrom, strSubject, strBody, msgType, strCC)
Set objMail = Wscript.CreateObject("CDO.Message")
 
objMail.To = strTo
objMail.From = strFrom
objMail.Subject = strSubject
objMail.CC = strCC
 
if msgType = TEXTMSG then
  objMail.TextBody = strBody
else
  objMail.HTMLBody = strBody
end if
 
objMail.Send
 
set objMail = Nothing
End Function
 
'return 0 if a file exists else -1
function FileExists(Fname)
Dim fs
 
Set fs = CreateObject("Scripting.FileSystemObject")
 
if fs.FileExists(Fname) = False then
  FileExists = -1
else
  FileExists = 0
end if
Set fs = Nothing
end function

Open in new window

0
 

Author Comment

by:naihelpdesk
ID: 23616615
Thanks for helping with this.

I got the following:
Line: 35
Char: 4
Error: Subscript out of range: 'UBound'
Code: 800A0009
0
 
LVL 24

Expert Comment

by:purplepomegranite
ID: 23617076
Change it as below.  UBound starts from 1, not zero - I thought I was referring to the first dimension.  Having just checked though, this is the default, so the below should work as I have omitted the second parameter from the UBound call.

Const ForReading = 1, ForWriting = 2, ForAppending = 8
Const TEXTMSG = 0
Const HTMLMSG = 1
Const TemplateFile = "C:\Scripts\Template.txt"
 
if FileExists(TemplateFile) <> 0 then
  WScript.Echo "The email template file, " & Chr(34) & TemplateFile & Chr(34) & ", does not exit!"
  WScript.Quit
End If
 
Set fso = CreateObject("Scripting.FileSystemObject")
Set f = fso.OpenTextFile(TemplateFile, ForReading)
strBodyTextOrg = f.ReadAll
f.close
Set f = Nothing
set fso = Nothing
 
Set OBJdbConnection = CreateObject("ADODB.Connection") 
OBJdbConnection.Open "Provider=SQLOLEDB.1;Data Source=*************;Initial Catalog=*********","*******","**"
 
SQLQuery = "SELECT ****************"
Set Result = OBJdbConnection.Execute(SQLQuery) 
 
dim arrEmails()
dim dicManagers
 
set dicManagers=CreateObject("Scripting.Dictionary")
redim arrEmails(0,2)
 
if Not Result.EOF then
        Do While Not Result.EOF
                if dicManagers.Exists(Result("Manager")) then
                        arrEmails(dicManagers.Item(Result("Manager")),2)=arrEmails(dicManagers.Item(Result("Manager")),2) & ", " & Result("User")
                else
                        redim preserve arrEmails(UBound(arrEmails)+1,2)
                        arrEmails(UBound(arrEmails),0)=Result("Manager")
                        arrEmails(UBound(arrEmails),1)=Result("ManagersEmail")
                        arrEmails(UBound(arrEmails),2)=Result("User")
                        dicManagers.Add Result("Manager"), UBound(arrEmails)
                end if                  
                Result.MoveNext 
        loop
        Result.Close
        ' Now loop through array and send emails
        dim i
        for i=1 to UBound(arrEmails,0)
                strBodyText = strBodyTextOrg
                strBodyText = StripComments(strBodyText)
                'This is the section of the script you customize for your template and database fields.
                strBodyText = ReplaceVariable(strBodyText, "[$MANAGER$]", arrEmail(i,0))
                strBodyText = ReplaceVariable(strBodyText, "[$MANAGERSEMAIL$]", arrEmail(i,1))
                strBodyText = ReplaceVariable(strBodyText, "[$USER$]", arrEmail(i,2))
                SendMail Result("ManagersEmail"), "from@address.com>", "Subject " & Result("Manager"), strBodyText, TEXTMSG, "cc@address.com"
        next
end If
 
OBJdbConnection.Close
 
Set Result = Nothing
Set OBJdbConnection = Nothing
 
Function ReplaceVariable(strTheString, strReplace, strReplaceWith)
ReplaceVariable = Replace (strTheString, strReplace, strReplaceWith, 1, -1, 1)
End Function
 
Function StripComments(strTheString)
Dim objRegExp
 
Set objRegExp = New RegExp
objRegExp.Global = True
objRegExp.Multiline = True
objRegExp.Pattern = "^##.*\n"
StripComments = objRegExp.Replace(strTheString, "")
 
Set objRegExp = Nothing
End Function
 
Function SendMail(strTo, strFrom, strSubject, strBody, msgType, strCC)
Set objMail = Wscript.CreateObject("CDO.Message")
 
objMail.To = strTo
objMail.From = strFrom
objMail.Subject = strSubject
objMail.CC = strCC
 
if msgType = TEXTMSG then
  objMail.TextBody = strBody
else
  objMail.HTMLBody = strBody
end if
 
objMail.Send
 
set objMail = Nothing
End Function
 
'return 0 if a file exists else -1
function FileExists(Fname)
Dim fs
 
Set fs = CreateObject("Scripting.FileSystemObject")
 
if fs.FileExists(Fname) = False then
  FileExists = -1
else
  FileExists = 0
end if
Set fs = Nothing
end function

Open in new window

0
What does it mean to be "Always On"?

Is your cloud always on? With an Always On cloud you won't have to worry about downtime for maintenance or software application code updates, ensuring that your bottom line isn't affected.

 
LVL 24

Expert Comment

by:purplepomegranite
ID: 23617086
Sorry, missed a line!  Needed to change all the UBound calls.  I think I have got them all below.  If I have missed one though, just remove the ,0 from the call.

Const ForReading = 1, ForWriting = 2, ForAppending = 8
Const TEXTMSG = 0
Const HTMLMSG = 1
Const TemplateFile = "C:\Scripts\Template.txt"
 
if FileExists(TemplateFile) <> 0 then
  WScript.Echo "The email template file, " & Chr(34) & TemplateFile & Chr(34) & ", does not exit!"
  WScript.Quit
End If
 
Set fso = CreateObject("Scripting.FileSystemObject")
Set f = fso.OpenTextFile(TemplateFile, ForReading)
strBodyTextOrg = f.ReadAll
f.close
Set f = Nothing
set fso = Nothing
 
Set OBJdbConnection = CreateObject("ADODB.Connection") 
OBJdbConnection.Open "Provider=SQLOLEDB.1;Data Source=*************;Initial Catalog=*********","*******","**"
 
SQLQuery = "SELECT ****************"
Set Result = OBJdbConnection.Execute(SQLQuery) 
 
dim arrEmails()
dim dicManagers
 
set dicManagers=CreateObject("Scripting.Dictionary")
redim arrEmails(0,2)
 
if Not Result.EOF then
        Do While Not Result.EOF
                if dicManagers.Exists(Result("Manager")) then
                        arrEmails(dicManagers.Item(Result("Manager")),2)=arrEmails(dicManagers.Item(Result("Manager")),2) & ", " & Result("User")
                else
                        redim preserve arrEmails(UBound(arrEmails)+1,2)
                        arrEmails(UBound(arrEmails),0)=Result("Manager")
                        arrEmails(UBound(arrEmails),1)=Result("ManagersEmail")
                        arrEmails(UBound(arrEmails),2)=Result("User")
                        dicManagers.Add Result("Manager"), UBound(arrEmails)
                end if                  
                Result.MoveNext 
        loop
        Result.Close
        ' Now loop through array and send emails
        dim i
        for i=1 to UBound(arrEmails)
                strBodyText = strBodyTextOrg
                strBodyText = StripComments(strBodyText)
                'This is the section of the script you customize for your template and database fields.
                strBodyText = ReplaceVariable(strBodyText, "[$MANAGER$]", arrEmail(i,0))
                strBodyText = ReplaceVariable(strBodyText, "[$MANAGERSEMAIL$]", arrEmail(i,1))
                strBodyText = ReplaceVariable(strBodyText, "[$USER$]", arrEmail(i,2))
                SendMail Result("ManagersEmail"), "from@address.com>", "Subject " & Result("Manager"), strBodyText, TEXTMSG, "cc@address.com"
        next
end If
 
OBJdbConnection.Close
 
Set Result = Nothing
Set OBJdbConnection = Nothing
 
Function ReplaceVariable(strTheString, strReplace, strReplaceWith)
ReplaceVariable = Replace (strTheString, strReplace, strReplaceWith, 1, -1, 1)
End Function
 
Function StripComments(strTheString)
Dim objRegExp
 
Set objRegExp = New RegExp
objRegExp.Global = True
objRegExp.Multiline = True
objRegExp.Pattern = "^##.*\n"
StripComments = objRegExp.Replace(strTheString, "")
 
Set objRegExp = Nothing
End Function
 
Function SendMail(strTo, strFrom, strSubject, strBody, msgType, strCC)
Set objMail = Wscript.CreateObject("CDO.Message")
 
objMail.To = strTo
objMail.From = strFrom
objMail.Subject = strSubject
objMail.CC = strCC
 
if msgType = TEXTMSG then
  objMail.TextBody = strBody
else
  objMail.HTMLBody = strBody
end if
 
objMail.Send
 
set objMail = Nothing
End Function
 
'return 0 if a file exists else -1
function FileExists(Fname)
Dim fs
 
Set fs = CreateObject("Scripting.FileSystemObject")
 
if fs.FileExists(Fname) = False then
  FileExists = -1
else
  FileExists = 0
end if
Set fs = Nothing
end function

Open in new window

0
 

Author Comment

by:naihelpdesk
ID: 23617136
I'm getting the same error, line 35, char 25
0
 
LVL 24

Expert Comment

by:purplepomegranite
ID: 23617422
Ah, on looking into it the problem is with the preserve... can only redim preserve changing the last dimension of the array.  The below code has the array dimensions swapped.  I've tested the array part, and that works... so hopefully it'll get a bit further this time!

Const ForReading = 1, ForWriting = 2, ForAppending = 8
Const TEXTMSG = 0
Const HTMLMSG = 1
Const TemplateFile = "C:\Scripts\Template.txt"
 
if FileExists(TemplateFile) <> 0 then
  WScript.Echo "The email template file, " & Chr(34) & TemplateFile & Chr(34) & ", does not exit!"
  WScript.Quit
End If
 
Set fso = CreateObject("Scripting.FileSystemObject")
Set f = fso.OpenTextFile(TemplateFile, ForReading)
strBodyTextOrg = f.ReadAll
f.close
Set f = Nothing
set fso = Nothing
 
Set OBJdbConnection = CreateObject("ADODB.Connection") 
OBJdbConnection.Open "Provider=SQLOLEDB.1;Data Source=*************;Initial Catalog=*********","*******","**"
 
SQLQuery = "SELECT ****************"
Set Result = OBJdbConnection.Execute(SQLQuery) 
 
dim arrEmails()
dim dicManagers
 
set dicManagers=CreateObject("Scripting.Dictionary")
redim arrEmails(2,0)
 
if Not Result.EOF then
        Do While Not Result.EOF
                if dicManagers.Exists(Result("Manager")) then
                        arrEmails(2,dicManagers.Item(Result("Manager")))=arrEmails(2,dicManagers.Item(Result("Manager"))) & ", " & Result("User")
                else
                        redim preserve arrEmails(2,UBound(arrEmails,2)+1)
                        arrEmails(0,UBound(arrEmails,2))=Result("Manager")
                        arrEmails(1,UBound(arrEmails,2))=Result("ManagersEmail")
                        arrEmails(2,UBound(arrEmails,2))=Result("User")
                        dicManagers.Add Result("Manager"), UBound(arrEmails)
                end if                  
                Result.MoveNext 
        loop
        Result.Close
        ' Now loop through array and send emails
        dim i
        for i=1 to UBound(arrEmails,2)
                strBodyText = strBodyTextOrg
                strBodyText = StripComments(strBodyText)
                'This is the section of the script you customize for your template and database fields.
                strBodyText = ReplaceVariable(strBodyText, "[$MANAGER$]", arrEmail(0,i))
                strBodyText = ReplaceVariable(strBodyText, "[$MANAGERSEMAIL$]", arrEmail(1,i))
                strBodyText = ReplaceVariable(strBodyText, "[$USER$]", arrEmail(2,i))
                SendMail Result("ManagersEmail"), "from@address.com>", "Subject " & Result("Manager"), strBodyText, TEXTMSG, "cc@address.com"
        next
end If
 
OBJdbConnection.Close
 
Set Result = Nothing
Set OBJdbConnection = Nothing
 
Function ReplaceVariable(strTheString, strReplace, strReplaceWith)
ReplaceVariable = Replace (strTheString, strReplace, strReplaceWith, 1, -1, 1)
End Function
 
Function StripComments(strTheString)
Dim objRegExp
 
Set objRegExp = New RegExp
objRegExp.Global = True
objRegExp.Multiline = True
objRegExp.Pattern = "^##.*\n"
StripComments = objRegExp.Replace(strTheString, "")
 
Set objRegExp = Nothing
End Function
 
Function SendMail(strTo, strFrom, strSubject, strBody, msgType, strCC)
Set objMail = Wscript.CreateObject("CDO.Message")
 
objMail.To = strTo
objMail.From = strFrom
objMail.Subject = strSubject
objMail.CC = strCC
 
if msgType = TEXTMSG then
  objMail.TextBody = strBody
else
  objMail.HTMLBody = strBody
end if
 
objMail.Send
 
set objMail = Nothing
End Function
 
'return 0 if a file exists else -1
function FileExists(Fname)
Dim fs
 
Set fs = CreateObject("Scripting.FileSystemObject")
 
if fs.FileExists(Fname) = False then
  FileExists = -1
else
  FileExists = 0
end if
Set fs = Nothing
end function

Open in new window

0
 

Author Comment

by:naihelpdesk
ID: 23617466
Line 33, Char 25
Subscript out of range 'Item(...)'
0
 
LVL 24

Expert Comment

by:purplepomegranite
ID: 23617911
Please change line 39 to the below.

dicManagers.Add Result("Manager"), UBound(arrEmails,2)

Open in new window

0
 

Author Comment

by:naihelpdesk
ID: 23618418
OK, so we got past that section. Now this is breaking... Line 53, Char 3, (Null) Exception occurred
Here is the real line I'm using for 53:

The same line (below) will work in the original script, so I know there is no problem with it
SendMail Result("ManagersEmail"), "helpdesk@nai-online.com", "Users assigned to " & Result("Manager"), strBodyText, TEXTMSG, "helpdesk@nai-online.com"

Open in new window

0
 
LVL 24

Expert Comment

by:purplepomegranite
ID: 23618491
Please change line 53 to the below.

SendMail arrEmail(1,i)), "from@address.com>", "Subject " & arrEmail(0,i), strBodyText, TEXTMSG, "cc@address.com"

Open in new window

0
 
LVL 24

Accepted Solution

by:
purplepomegranite earned 2000 total points
ID: 23618497
Sorry, typo crept in... Should be:

SendMail arrEmail(1,i), "from@address.com>", "Subject " & arrEmail(0,i), strBodyText, TEXTMSG, "cc@address.com"

Open in new window

0
 

Author Closing Comment

by:naihelpdesk
ID: 31544332
Great Success! I tweaked it a little to get User &vbCrLf User instead of User, User
Thanks a lot!
0
 

Author Comment

by:naihelpdesk
ID: 23619179
Problem - Only one email went out, the first manager in the query got the entire set of users, regerdless of manager.  
0
 

Author Comment

by:naihelpdesk
ID: 23619307
Would it be easier to do a SELECT DISTINCT statement to build this 'Manager' array as a temp file, then loop this against the file?
0
 
LVL 24

Expert Comment

by:purplepomegranite
ID: 23621296
I can't see if you accepted the solution and then posted the problem, or resolved the problem then accepted... Is this script now working or does it need more work?
0
 

Author Comment

by:naihelpdesk
ID: 23622737
I accepted it originally because it worked when i wan running a more narrow query, only my username. When I ran it with the unfiltered query, that's when I noticed the issue. So, the problem still exists - Only one email went out, the first manager in the query got the entire set of users, regerdless of manager.
0
 
LVL 24

Expert Comment

by:purplepomegranite
ID: 23623122
Think I've found it.  Please change line 39 to the below.

dicManagers.Add Result("Manager"), UBound(arrEmails,2)

Open in new window

0
 

Author Comment

by:naihelpdesk
ID: 23624073
That looks like what I have in there right now. I'll repost my current version so we are on the same page
Const ForReading = 1, ForWriting = 2, ForAppending = 8
Const TEXTMSG = 0
Const HTMLMSG = 1
Const TemplateFile = "C:\Scripts\TEST-BaanUsers-ManagerReviewEmail-Template.txt"
 
if FileExists(TemplateFile) <> 0 then
  WScript.Echo "The email template file, " & Chr(34) & TemplateFile & Chr(34) & ", does not exit!"
  WScript.Quit
End If
 
Set fso = CreateObject("Scripting.FileSystemObject")
Set f = fso.OpenTextFile(TemplateFile, ForReading)
strBodyTextOrg = f.ReadAll
f.close
Set f = Nothing
set fso = Nothing
 
Set OBJdbConnection = CreateObject("ADODB.Connection") 
OBJdbConnection.Open "Provider=SQLOLEDB.1;Data Source=SQUAWVALLEY;Initial Catalog=ActiveDirectoryExports","***","***"
 
SQLQuery = "SELECT Boss.displayName AS Manager, Boss.mail AS ManagersEmail, ActiveDirectory.displayName AS [User] FROM ActiveDirectory INNER JOIN ActiveDirectory AS Boss ON ActiveDirectory.manager = Boss.distinguishedName INNER JOIN baandb.dbo.tttaad200000 ON baandb.dbo.tttaad200000.t_user = ActiveDirectory.samAccountName ORDER BY Boss.displayName, ActiveDirectory.displayName"
Set Result = OBJdbConnection.Execute(SQLQuery) 
 
dim arrEmails()
dim dicManagers
 
set dicManagers=CreateObject("Scripting.Dictionary")
redim arrEmails(2,0)
 
if Not Result.EOF then
        Do While Not Result.EOF
                if dicManagers.Exists(Result("Manager")) then
                        arrEmails(2,dicManagers.Item(Result("Manager")))=arrEmails(2,dicManagers.Item(Result("Manager"))) &vbCrLf & Result("User")
                else
                        redim preserve arrEmails(2,UBound(arrEmails,2)+1)
                        arrEmails(0,UBound(arrEmails,2))=Result("Manager")
                        arrEmails(1,UBound(arrEmails,2))=Result("ManagersEmail")
                        arrEmails(2,UBound(arrEmails,2))=Result("User")
                        dicManagers.Add Result("Manager"), UBound(arrEmails,2)
                end if                  
                Result.MoveNext 
        loop
        Result.Close
        ' Now loop through array and send emails
        dim i
        for i=1 to UBound(arrEmails,2)
                strBodyText = strBodyTextOrg
                strBodyText = StripComments(strBodyText)
                'This is the section of the script you customize for your template and database fields.
                strBodyText = ReplaceVariable(strBodyText, "[$MANAGER$]", arrEmails(0,i))
                strBodyText = ReplaceVariable(strBodyText, "[$MANAGERSEMAIL$]", arrEmails(1,i))
                strBodyText = ReplaceVariable(strBodyText, "[$USER$]", arrEmails(2,i))
                SendMail arrEmails(1,i), "NAI - Technology Services <helpticket@nai-online.com>", "TEST ONLY: Baan Users Assigned To " & arrEmails(0,i) &" - Sarbanes-Oxley (SOX) Quarterly Monitoring", strBodyText, TEXTMSG, "sean@nai-online.com"
        next
end If
 
OBJdbConnection.Close
 
Set Result = Nothing
Set OBJdbConnection = Nothing
 
Function ReplaceVariable(strTheString, strReplace, strReplaceWith)
ReplaceVariable = Replace (strTheString, strReplace, strReplaceWith, 1, -1, 1)
End Function
 
Function StripComments(strTheString)
Dim objRegExp
 
Set objRegExp = New RegExp
objRegExp.Global = True
objRegExp.Multiline = True
objRegExp.Pattern = "^##.*\n"
StripComments = objRegExp.Replace(strTheString, "")
 
Set objRegExp = Nothing
End Function
 
Function SendMail(strTo, strFrom, strSubject, strBody, msgType, strCC)
Set objMail = Wscript.CreateObject("CDO.Message")
 
objMail.To = strTo
objMail.From = strFrom
objMail.Subject = strSubject
objMail.CC = strCC
 
if msgType = TEXTMSG then
  objMail.TextBody = strBody
else
  objMail.HTMLBody = strBody
end if
 
objMail.Send
 
set objMail = Nothing
End Function
 
'return 0 if a file exists else -1
function FileExists(Fname)
Dim fs
 
Set fs = CreateObject("Scripting.FileSystemObject")
 
if fs.FileExists(Fname) = False then
  FileExists = -1
else
  FileExists = 0
end if
Set fs = Nothing
end function

Open in new window

0
 
LVL 24

Expert Comment

by:purplepomegranite
ID: 23626101
Hmm... interesting.  I can't see anything wrong with the code to only send one mail out.

I have modified it as below, so the script will now log to window what it is doing.  Could you post back (obviously changing names as appropriate) what gets output?

Best way to run scripts in my view is from a batch file such as:

cscript script.vbs
pause

Then the output all goes to the command window, and once the script is complete it pauses so you can read it.  If you run the script in wscript you'll get lots of irritating pop-ups...

Const ForReading = 1, ForWriting = 2, ForAppending = 8
Const TEXTMSG = 0
Const HTMLMSG = 1
Const TemplateFile = "C:\Scripts\TEST-BaanUsers-ManagerReviewEmail-Template.txt"
 
if FileExists(TemplateFile) <> 0 then
  WScript.Echo "The email template file, " & Chr(34) & TemplateFile & Chr(34) & ", does not exit!"
  WScript.Quit
End If
 
Set fso = CreateObject("Scripting.FileSystemObject")
Set f = fso.OpenTextFile(TemplateFile, ForReading)
strBodyTextOrg = f.ReadAll
f.close
Set f = Nothing
set fso = Nothing
 
Set OBJdbConnection = CreateObject("ADODB.Connection") 
OBJdbConnection.Open "Provider=SQLOLEDB.1;Data Source=SQUAWVALLEY;Initial Catalog=ActiveDirectoryExports","***","***"
 
SQLQuery = "SELECT Boss.displayName AS Manager, Boss.mail AS ManagersEmail, ActiveDirectory.displayName AS [User] FROM ActiveDirectory INNER JOIN ActiveDirectory AS Boss ON ActiveDirectory.manager = Boss.distinguishedName INNER JOIN baandb.dbo.tttaad200000 ON baandb.dbo.tttaad200000.t_user = ActiveDirectory.samAccountName ORDER BY Boss.displayName, ActiveDirectory.displayName"
Set Result = OBJdbConnection.Execute(SQLQuery) 
 
dim arrEmails()
dim dicManagers
 
set dicManagers=CreateObject("Scripting.Dictionary")
redim arrEmails(2,0)
dim sUser, sManager, sManagerEmail, sUserList
 
if Not Result.EOF then
	Do While Not Result.EOF
		sUser=Result("User")
		sManager=Result("Manager")
		sManagerEmail=Results("ManagersEmail")
		if dicManagers.Exists(sManager) then
			arrEmails(2,dicManagers.Item(sManager))=arrEmails(2,dicManagers.Item(sManager)) & vbCrLf & sUser
			wscript.echo "Added user " & sUser & " to Manager " & sManager
		else
			redim preserve arrEmails(2,UBound(arrEmails,2)+1)
			arrEmails(0,UBound(arrEmails,2))=sManager
			arrEmails(1,UBound(arrEmails,2))=sManagerEmail
			arrEmails(2,UBound(arrEmails,2))=sUser
			dicManagers.Add sManager, UBound(arrEmails,2)
		end if                  
		Result.MoveNext 
	loop
	Result.Close
	' Now loop through array and send emails
	dim i
	wscript.echo UBound(arrEmails,2) & " emails to send"
	for i=1 to UBound(arrEmails,2)
		sManager=arrEmails(0,i)
		sManagerEmail=arrEmails(1,i)
		sUserList=arrEmails(2,i)
		strBodyText = strBodyTextOrg
		strBodyText = StripComments(strBodyText)
		'This is the section of the script you customize for your template and database fields.
		strBodyText = ReplaceVariable(strBodyText, "[$MANAGER$]", sManager)
		strBodyText = ReplaceVariable(strBodyText, "[$MANAGERSEMAIL$]", sManagerEmail)
		strBodyText = ReplaceVariable(strBodyText, "[$USER$]", sUserList)
		wscript.echo "Sending email to " & sManager & " (" & sManagerEmail & ")"
		wscript.echo sManager & " users: " & sUserList
		' Next line commented out until testing complete... just saves sending the emails out until they're right!
		'SendMail arrEmails(1,i), "NAI - Technology Services <helpticket@nai-online.com>", "TEST ONLY: Baan Users Assigned To " & arrEmails(0,i) &" - Sarbanes-Oxley (SOX) Quarterly Monitoring", strBodyText, TEXTMSG, "sean@nai-online.com"
	next
end If
 
OBJdbConnection.Close
 
Set Result = Nothing
Set OBJdbConnection = Nothing
 
Function ReplaceVariable(strTheString, strReplace, strReplaceWith)
ReplaceVariable = Replace (strTheString, strReplace, strReplaceWith, 1, -1, 1)
End Function
 
Function StripComments(strTheString)
Dim objRegExp
 
Set objRegExp = New RegExp
objRegExp.Global = True
objRegExp.Multiline = True
objRegExp.Pattern = "^##.*\n"
StripComments = objRegExp.Replace(strTheString, "")
 
Set objRegExp = Nothing
End Function
 
Function SendMail(strTo, strFrom, strSubject, strBody, msgType, strCC)
Set objMail = Wscript.CreateObject("CDO.Message")
 
objMail.To = strTo
objMail.From = strFrom
objMail.Subject = strSubject
objMail.CC = strCC
 
if msgType = TEXTMSG then
  objMail.TextBody = strBody
else
  objMail.HTMLBody = strBody
end if
 
objMail.Send
 
set objMail = Nothing
End Function
 
'return 0 if a file exists else -1
function FileExists(Fname)
Dim fs
 
Set fs = CreateObject("Scripting.FileSystemObject")
 
if fs.FileExists(Fname) = False then
  FileExists = -1
else
  FileExists = 0
end if
Set fs = Nothing
end function

Open in new window

0
 

Author Comment

by:naihelpdesk
ID: 23626347
OK, outputting it to the console looked like it worked.
I got 60 lines of "Added user [Name] to Manager [Name]", which covers all the users.
Then "28 emails to send"
Then:
"Sending email to [Name] (email)
[Name] users: [Name]
[Name]
[Name]
[Name]
Sending email to [Name] (email)
[Name] users: [Name]
[Name]
[Name]
[Name]"
..etc.

Based on this, i'll uncomment the email line and give it another shot.
0
 

Author Comment

by:naihelpdesk
ID: 23626551
Ok - I think we're all set. The mails went out, I CCed myself on all of them and they look perfect.
Thanks for the additional help!
0
 
LVL 24

Expert Comment

by:purplepomegranite
ID: 23626660
No problem - glad it's sorted in the end!
0

Featured Post

Vote for the Most Valuable Expert

It’s time to recognize experts that go above and beyond with helpful solutions and engagement on site. Choose from the top experts in the Hall of Fame or on the right rail of your favorite topic page. Look for the blue “Nominate” button on their profile to vote.

Question has a verified solution.

If you are experiencing a similar issue, please ask a related question

In this post we will learn how to make Android Gesture Tutorial and give different functionality whenever a user Touch or Scroll android screen.
Today, the web development industry is booming, and many people consider it to be their vocation. The question you may be asking yourself is – how do I become a web developer?
Introduction to Processes
Loops Section Overview

830 members asked questions and received personalized solutions in the past 7 days.

Join the community of 500,000 technology professionals and ask your questions.

Join & Ask a Question