savindrasingh
Board Regular
- Joined
- Sep 10, 2009
- Messages
- 183
I am facing a strange problem with For Each Loop. While debugging my code I have found that as soon as I enter the line highlighted below (having For Each Associate In empList) it is changing the cell contents with user's display name without even running the code? It is so strange, I am not able to figure-out how this is happening.. I am using F8 to try step by step debugging and as soon as I hit F8 at above mentioned line, the contents of cell A2 changes. Please suggest how to fix this.
</ldap:>
Code:
Option Explicit
Public Enum MessageType
Birthday
Anniversary
End Enum
Public BCCList
Sub AutoMailer()
Application.OnTime TimeValue("09:00:00"), Code.TrackEvents
End Sub
Sub TrackEvents()
'*** Prevent repeated run by checking value in this cell ***'
Dim userResponse
If ThisWorkbook.Sheets("Details").Range("G1").Value = Date Then
If MsgBox("The emails were already sent for today." & vbCrLf & _
"Do you still want to re-run?", vbYesNo, "Auto-wish-mailer") = vbYes Then
'*** Continue with the code ***'
Else
'ThisWorkbook.Close SaveChanges:=True
Exit Sub
End If
End If
'*** Employee list from this column using email Alias/login ID ***'
Dim empList, Associate As Range
Set empList = ThisWorkbook.Sheets("Details").Range("A2:A" & _
ThisWorkbook.Sheets("Details").Range("A" & ThisWorkbook.Sheets("Details").Rows.Count).End(xlUp).Row)
'*** Other variables required for the code ***'
Dim MonthOfJoining, MonthOfBirth, DOJ, DOB, CurrentDay, CurrentMonth, YearsCompleted, TimeSpan, PersonNumber
'*** Determine todays day and month for considering wishes ***'
CurrentDay = Day(Date): CurrentMonth = Month(Date)
[U][B]For Each Associate In empList
[/B][/U] If UserExists(Associate, Associate) Then
Debug.Print Associate.Offset(0, 3).Value
If Associate.Offset(0, 3).Value = "Mithun" Then
Debug.Assert Associate.Offset(0, 3).Value = "Mithun"
End If
'*** Values for Joining Anniversary ***'
If Associate.Offset(0, 1).Value = "?" Or Associate.Offset(0, 1).Value = "" Then
'** Do Nothing as no data available for this associate ***'
Else
'** Determine Month and Day values **'
MonthOfJoining = Month(Associate.Offset(0, 1).Value): DOJ = Day(Associate.Offset(0, 1).Value)
MonthOfBirth = Month(Associate.Offset(0, 2).Value): DOB = Day(Associate.Offset(0, 2).Value)
CurrentDay = Day(Date): CurrentMonth = Month(Date)
'** Determine # of years for joining anniversary **'
TimeSpan = Year(Date) - Year(Associate.Offset(0, 1).Value)
If TimeSpan > 1 Then
YearsCompleted = TimeSpan & " Glorious years "
Else
YearsCompleted = TimeSpan & " year "
End If
'** Send emails to team members having birthdays today **'
If MonthOfBirth = CurrentMonth And DOB = CurrentDay Then
SendEmail Associate.Offset(0, 3).Value, Associate.Value, Birthday
End If
'** Send emails to team members having Anniversaries today **'
If TimeSpan >= 1 Then
If MonthOfJoining = CurrentMonth And DOJ = CurrentDay Then
SendEmail Associate.Offset(0, 3).Value, Associate.Value, Anniversary, YearsCompleted
End If
End If
End If
End If
Next
'** Lock repeat execution due to accidental opening of workbook by setting value in this cell **'
ThisWorkbook.Sheets("Details").Range("G1").Value = Date
'ThisWorkbook.Close SaveChanges:=True
End Sub
Sub SendEmail(ByVal EmpName As String, ByVal e_Mail As String, ByVal WishType As MessageType, Optional ByVal Period As String)
Dim olApp, olMail, MessageText, objFSO, strImage
Set olApp = CreateObject("Outlook.Application")
Set olMail = olApp.CreateItem(0)
Set objFSO = CreateObject("Scripting.FileSystemObject")
Select Case WishType
Case MessageType.Birthday
olMail.Attachments.Add (ThisWorkbook.Path & "\" & "bday.jpg")
olMail.Subject = "May your birthday be filled with excitement, joy, and laughter"
olMail.HTMLBody = [HTML]" "background='cid:bday.jpg'>
" & _
"Dear " & EmpName & "
We wish you a very special Birthday today
" & _
"Your birthday is a special time to celebrate the gift of ‘you’ to the world...
" & _
"Happy Birthday !!
" & _
"" & _
"Regards,
EUC Family
"[/HTML]
Case MessageType.Anniversary
olMail.Attachments.Add (ThisWorkbook.Path & "\" & "anniv.jpg")
olMail.Subject = "Congratulations!!! On Completing " & Period & "at Wells Fargo"
olMail.HTMLBody = "[HTML] "background='cid:anniv.jpg'>
" & _
"Dear " & EmpName & "
Congratulations to you for completing " & Period & " and achieving a
" & _
"Milestone in your career with us.
" & _
"We recognize your contribution to the organization.
" & _
"" & _
"Regards,
EUC Family
"[/HTML]
Case Else
olMail.Subject = "Test mail"
olMail.HTMLBody = [HTML]"Hello " & EmpName & ",
This is test email. Please ignore."[/HTML]
End Select
olMail.To = e_Mail
'olMail.SentonBehalfOfName = "[EMAIL="dis.tea.events@xyz.com"]dis.tea.events@xyz.com[/EMAIL]"
Code.GetBCC
olMail.BCC = BCCList & "; GPlatformEngineering; EUCCoreSupportTeam"
'*** Change from olMail.Send to olMail.Display to toggle between sending or just displaying email ***'
olMail.Display
Set objFSO = Nothing
Set olApp = Nothing
Set olMail = Nothing
End Sub
Sub GetBCC()
BCCList = ""
Dim BCCRange, BCCItem
Set BCCRange = Range("E2:E" & Range("E" & Rows.Count).End(xlUp).Row)
For Each BCCItem In BCCRange
If BCCList <> "" Then
BCCList = BCCList & "; " & BCCItem
Else
BCCList = BCCItem
End If
Next
End Sub
Function UserName()
UserName = UCase(Environ("UserName"))
End Function
Function UserExists(sUser, sDisName)
Dim oConn, oCMD, oRoot, sDNSDomain, sQuery, sFilter, oResults
UserExists = False
sDisName = sUser
On Error Resume Next
' Use ADO to search the domain for all users.
Set oConn = CreateObject("ADODB.Connection")
Set oCMD = CreateObject("ADODB.Command")
oConn.Provider = "ADsDSOOBject"
oConn.Open "Active Directory Provider"
Set oCMD.ActiveConnection = oConn
' Determine the DNS domain from the RootDSE object.
Set oRoot = GetObject("[URL]ldap://RootDSE[/URL]")
sDNSDomain = oRoot.Get("DefaultNamingContext")
sFilter = "(&(ObjectClass=user)(ObjectCategory=person)(samAccountName=" & sUser & "))"
sQuery = "<ldap: "="" &="" sdnsdomain="">;" & sFilter & ";displayName;subtree"
oCMD.CommandText = sQuery
oCMD.Properties("Page Size") = 100
oCMD.Properties("Timeout") = 30
oCMD.Properties("Cache Results") = False
Set oResults = oCMD.Execute
Do Until oResults.EOF
If oResults.Fields("displayName") <> "" Then
sDisName = oResults.Fields("displayName")
UserExists = True
End If
oResults.MoveNext
Loop
On Error GoTo 0
End Function
