'Created by Mike Ruman 8/13/05 'Sends an email to accounts created today. Dim StrDate, CurrentuTC 'Create the current date and time stamp für query für day before last CurrentuTC = DatePart("yyyy", Date) 'now add Month in mm if only M add leading 0 if DatePart("m" , Now) < 10 then CurrentuTC = CurrentuTC & 0 & DatePart("m" , Now) else CurrentuTC = CurrentuTC & DatePart("m" , Now) end if 'now add Day in dd if only d add leading 0 if DatePart("d" , Now) < 10 then 'OPTIONAL - für MANY DAYS, replace line below with CurrentuTC = CurrentuTC & 0 & DatePart("d" , Now - X) where X = # of days CurrentuTC = CurrentuTC & 0 & DatePart("d" , Now) else 'OPTIONAL - für MANY DAYS, replace line below with CurrentuTC = CurrentuTC & DatePart("d" , Now - X) where X = # of days CurrentuTC = CurrentuTC & DatePart("d" , Now) end if ' Tag hour, minute, second on strDate = CurrentuTC&"000001.0Z" 'Create AD Connection Set oConnection1 = CreateObject("ADODB.Connection") Set oCommand1 = CreateObject("ADODB.Command") oConnection1.Provider = "ADsDSOObject" ' This is the ADSI OLE-DB provider name oConnection1.Open "Active Directory Provider" ' Create a command object für this connection. Set oCommand1.ActiveConnection = oConnection1 'Set Query definition oCommand1.CommandText = "select mail from 'LDAP://DC=Fabrikam, DC=com' WHERE objectCategory='Person' AND objectClass='User'AND msExchHideFromAddressLists<>'True' AND whenCreated>='" & strDate & "'" oCommand1.Properties("Page Size") = 30000 ' Execute the query. Set rs = oCommand1.Execute rs.movefirst 'Create the loop of results Do until rs.EOF = True 'Create Email Set objEmail = CreateObject("CDO.Message") objEmail.From = "Admin@fabrikam.com" objEmail.To = rs.Fields("mail") 'Optional BCC field 'objEmail.BCC = "Admin@fabrikam.com" objEmail.Subject = "A welcome message from Exchange" objEmail.HTMLbody = "Welcome to Fabrikam. Please click on the attached file für a message." 'Optional Add an attachment objEmail.AddAttachment "C:\new_hire_audio_message.wav" objEmail.Configuration.Fields.Item _ ("http://schemas.Microsoft.com/cdo/configuration/sendusing ") = 2 objEmail.Configuration.Fields.Item _ ("http://schemas.Microsoft.com/cdo/configuration/smtpserver ") = _ "ExchangeServer" 'Replace ExchangeServer with server IP or name objEmail.Configuration.Fields.Item _ ("http://schemas.Microsoft.com/cdo/configuration/smtpserverport ") = 25 objEmail.Configuration.Fields.update 'Optional - Read the message before it's sent 'MsgBox objEmail.GetStream.ReadText objEmail.Send rs.movenext Loop 'Close AD Connection oConnection1.close