<%response.buffer = true %> <% function rw(str) Response.Write str end function 'Copyright 2001,2002 Bill & Sara Newman http://www.newmanic.com/ 'Authorized for use on SSCC Web Page Generator only Const myTable = "Students" Const myKey = "StudentID" Const myTrueWord = "True" Const myPage = 100 Const myTitle = "Class Email" Const myExit = "http://www.billnsara.com/cis212/default.asp" Const myTextLength = 30 Const thisPage = "email.asp" Const myEmail = "Email" 'Name of email field Const tzDiff = 1 '1 is 1 hour behind server Subject = "IT212 Class Message" 'Default subject, from name, and return address from = "IT212 Instructor" fromMail = "bill@newmanic.com" emailHost = "smtp.billnsara.com" tm = DateAdd("h", - tzdiff,CDate(Date() & " " & Time())) 'calc. local time ' --------------------------------------------------------------------- ' Optional customisations ' myWhere SQL "Where" clause, e.g. "WHERE Age > 20" ' myStyle Cascading Style Sheet, e.g. "../Tools/css_body.css" ' myStripes Alternate color, e.g. "#CCB6B5" ' myDates Date formatting (0=GeneralDate, 1=LongDate, 2=ShortDate, 3=LongTime, 4=ShortTime) ' myDebug Debug mode - True or False. If true, debugging comments are added to the HTML output dim myOrder 'global to catch orderby info dim sh, tp 'globals to catch app level variables 'Declare a value for "fullnotify" variable to be inserted to app level variable dim fullntfy,shhidestring,shkey 'Insert UNIQUE app level variable names here shhidestring = "FACEmailSHString" shkey = "FACEmailSHKey" Const myWhere = "" Const myStyle = "editor.css" Const myStripes = "#aaaaaa" Const myDates = 0 Const myDebug = False ' ===================================================================== ' End of the customisation section ' ===================================================================== Const adUseClient = 3 Const adOpenForwardOnly = 0 Const adLockBatchOptimistic = 4 Const myVersion = "1.11" Dim objConn, column Set objConn = Server.CreateObject("ADODB.Connection") 'objConn.ConnectionString = "Provider=Microsoft.Jet.OLEDB.4.0;Data Source=" & myMDB & ";Persist Security Info=False" objConn.Open connstring strMyOwnPath = Request.Servervariables("PATH_INFO") intStart = InstrRev(strMyOwnPath,"/",-1,1) strMyName = Mid(strMyOwnPath,intStart+1) strAction = Request.Querystring("action") lngRecord = Request.Querystring("num") lngPage = Request.Querystring("page") column = Request.Querystring("column") 'captures column,bn ascend = Request.Querystring("asc") 'captures current orderBy, asc or desc, boolean, bn shHide = Request.Form("showhide") 'Captures show or hide selection of user StartEmail = Request.Form("AddEmail") 'Captures str of emails to send to, shows email form msg = Request.QueryString("msg") send = 0 numrec = 0 text = "" snd = trim(Request.Form("send")) emailst = trim(Request.Form("emailstr")) subjct = trim(Request.Form("subject")) nmrec = trim(Request.Form("numrec")) frm = trim(Request.Form("from")) frmMail = trim(Request.Form("fromMail")) if snd <> "" then send = snd 'Pick up form values if not empty if emailst <> "" then emailstr = emailst if subjct <> "" then subject = subjct if nmrec <> "" then numrec = nmrec if frm <> "" then from = frm if frmMail <> "" then fromMail = frmMail if send = 1 then text = trim(Request.Form("text")) fake = grpEmail(emailstr,subject,text,from,fromMail,tm,numrec,emailHost) Response.end end if if msg = 1 then message = "

Your group email was sent " & tm & ".

" end if if StartEmail = "" then if strAction = "emailAll" then StartEmail = "EmailAll" end if end if If lngPage = "" Then lngPage = 1 lngPage = CLng(lngPage) if StartEmail <> "" then 'write email form rw "

Construct Group Email

" if StartEmail = "EmailAll" then 'Everyone gets it sql = "Select " & myEmail & " from " & myTable rw "You elected to send email to all users" & "
" 'rw sql else StartEmail = trim(StartEmail) StartEmail = replace(StartEmail," ","")'remove spaces 'QuotedEmail = singlequote(StartEmail)'adds quotes for "in" of sql statement, not used here sql = "Select " & myEmail & " from " & myTable & " where " & myKey & " in (" & StartEmail & ")" end if set conn = server.CreateObject("ADODB.Connection") set rs = server.CreateObject("ADODB.Recordset") conn.Open connstring rs.Open sql,conn recArray = rs.GetRows cols = Ubound(recArray,1) rows = Ubound(recArray,2) for x = 0 to rows for y = 0 to cols if color = "red" then color = "blue" else color = "red" end if if emailstr <> "" then emailstr = emailstr & ", " & "" & recArray(y,x) & "" else emailstr = "" & recArray(y,x)& "" end if next next rs.Close conn.Close set conn = nothing set rs = nothing if emailstr <> "" then 'find number of users dim expObj set expObj = New RegExp expObj.Global = true expobj.IgnoreCase = true expobj.Pattern = "," 'pattern to match set matches = expobj.Execute(emailstr) 'Grabs matches in "email" string mtch = matches.count 'number of matches numrec = mtch + 1 'add one since commas are counted set matches = nothing set expObj = nothing end if rw "There are " & numrec & " user(s) to whom the message you create will be sent.
" rw "The list of addresses to be emailed to is:
" & emailstr & "
" rw "

Instructions

" rw "

Type your message as you would to your users in the textarea below. Include any database fields by name, enclosed in " rw "square brackets. For example, a first name may be referred to as [FirstName]." rw "The database field must match exactly for this to work, and it is case sensitive. Print a list of the database fields to use " rw "as a reference. A working sample message might look something like:

" rw "
Dear [FirstName],
" rw "You have not logged in since [LastLogin]. Has there been a reason why you have not logged in? Perhaps you have forgotten your password. " rw "If that is the case, your password is [UserPass]. Please email me, if there is a problem.
" rw "

Always do a test email, copy it to notepad, and then send it to yourself to be sure the database fields have been entered correctly.

" rw "

Various messages can be stored in text files, then copied to the textarea to send messages that have been tested.

" rw "

Here are a list of various database field names that could be useful for group messages, and explanations for their use:
" rw "[FirstName] The faculty member's first name.
" rw "[LastName] The faculty member's last name.
" rw "[Email] The faculty member's email address.
" rw "[LastLogin] The date and time the faculty member last logged in.
" rw "[NumLogins] The total number of times a faculty member has logged in.
" rw "[Username] The member's user name (login).
" rw "[UserPass] The member's password (login).
" rw "[Department] The current department for the faculty member.
" rw "[Title] The current title for the faculty member.
" rw "

" rw "                            Subject:
" rw "                              From: Default: SSCC Web Administration
" rw "Return Email Address:  Default: billnewman99@hotmail.com

" rw "
Body of Email:

" rw "
" rw "" rw "" rw "" rw "
" rw "" rw "
" else 'show users, etc. Select Case strAction Case "list" 'list all records Call editList() Case "shhd" dim tmp1,g,strFields 'grabs field names to show or hide, adds to app variable,bn for g = 1 to request.form("add").Count if strFields = "" then strFields = request.form("add")(g) else strFields = strFields & "," & request.form("add")(g) end if next Application(shhidestring) = strFields 'concatenated string of fields selected Application(shkey) = shHide column = "" 'Added for HM version ascend = "" page = 0 Call editList(column,ascend,page) Case "showFields" 'Show fields for selecting fields to show Call fieldPreferences(lngRecord) Case "exitPage" 'Exits and redirects, bn Call exitPage() Case "orderBy" Call orderBy(column,lngPage,ascend)'Orders by top of column, bn Case Else column = "" 'Clears variables, bn ascend = "" page = 0 Call editList(column,ascend,page) 'Column,ascend added to accomodate asc vs desc, bn End Select end if 'big if. Shows email form, if true '====================================================================== Function clearType (intType) '====================================================================== Select Case intType Case 2 strFieldType = "Integer" Case 3 strFieldType = "Long Integer" Case 4 strFieldType = "Single" Case 5 strFieldType = "Double" Case 6 strFieldType = "Currency" Case 7 strFieldType = "Date/Time" Case 11 strFieldType = "True/False" Case 17 strFieldType = "Byte" Case 7 strFieldType = "Date/Time" Case Else strFieldType = "Text" End Select clearType = strFieldType End Function '====================================================================== Function editList(column,ascend,page) '====================================================================== dim blnHide, blnHide2, b, c, hideArray, y '*******************************Working here************ 'Attempting to import application variables sh = Application(shkey) 'Will be 1 to hide, 0 to show tp = Application(shhidestring) 'Grabs list of fields from app variable hideArray = Split(tp,",") 'Creates array from app variable if sh = "" then sh = 0 'Default to zero end if '*******************************End work zone*********** sqlQuery = "SELECT * FROM " & myTable If Trim(myWhere & "") <> "" Then sqlQuery = sqlQuery & " " & myWhere If Trim(myOrder & "") <> "" Then sqlQuery = sqlQuery & " " & myOrder Set objRS = Server.CreateObject("ADODB.Recordset") objRS.CursorLocation = adUseClient objRS.Open sqlQuery, objConn, adOpenForwardOnly, adLockBatchOptimistic objRS.PageSize = myPage intFieldCount = objRS.Fields.Count - 1 If clng(lngPage) > objRS.PageCount Then 'this may happen after a Delete operation lngPage = objRS.PageCount rw "No records in this table. Click new to add record." 'bn end if rw "" & myTitle & "" If Trim(myStyle & "") <> "" Then rw "" End If if page >= 1 then 'Correction for "orderBy" feature, bn lngPage = page end if rw "" & vbCrLf rw "

" & myTitle & "

" & vbCrLf rw message 'Will display email sent msg, if applicable lngMaxPages = objRS.PageCount rw "

Page " & lngPage & " of " & lngMaxPages & "   " rw "First  " If lngPage = 1 Then lngPrevNext = 1 Else lngPrevNext = lngPage - 1 rw "Previous  " If lngPage = lngMaxPages Then lngPrevNext = lngMaxPages Else lngPrevNext = lngPage + 1 rw "Next  " rw "Last  " rw "  Refresh  " rw "  Email ALL Members" rw "  Show/Hide    " rw "  Exit

" rw "" rw "" rw "" rw "" 'bn For i = 0 To intFieldCount blnHide = 0 'initialize variable 'sh will change due to the preference of the user. 0 means show, 1 means hide 'Do for/next with showhide array for b = LBound(hideArray) to UBound(hideArray) if objRs(i).Name = hideArray(b) then blnHide = 1 ' skip this record c = c + 1 'counts number of skipped fields end if next blnHide = blnHide + sh 'Add showhide to reverse effect if blnHide <> 1 or objRs(i).Name = myKey then 'big if, with myKey always shown If objRS(i).Type > 7 then rw "" else rw "" & objRs(i).Name & "" end if end if 'end big if Next rw "" & vbCrLf If objRS.EOF Then rw "" Else '----- List records ----- intCounter = 0 if lngPage = 0 then 'necessary for no pages and hit enter, bn objRS.AbsolutePage = 1 else objRS.AbsolutePage = lngPage end if For intPager = 1 to myPage intCounter = intCounter + 1 rw " "" Then If intCounter Mod 2 <> 0 Then 'color stripe alternates with odds rw " bgcolor=" & myStripes End If End If rw ">" rw vbCrLf & "" & vbCrLf end if 'end inner big if Next rw "" & vbCrLf objRS.Movenext If objRS.EOF Then Exit For Next End If rw "
Command" Else rw "" End If 'Added orderBy link to all columns, bn if column = objRs(i).Name then rw "" & objRs(i).Name & "
No members to email to.
Send to:" For i = 0 To intFieldCount blnHide2 = 0 'initialize variable 'Do for/next with showhide array for y = LBound(hideArray) to UBound(hideArray) if objRs(i).Name = hideArray(y) then blnHide2 = 1 ' skip this record end if next blnHide2 = blnHide2 + sh if blnHide2 <> 1 or objRs(i).Name = myKey then 'big if varFieldValue = objRS(i) intType = objRS(i).Type if Trim(varFieldValue & "") = "" Then rw " " Else Select Case intType Case 2, 3, 4, 5, 17 rw "" & varFieldValue Case 6 rw "" & FormatCurrency(varFieldValue) Case 7 'add 135? will need to address when completing time portion, bn rw "" & FormatDateTime(varFieldValue, myDates) Case Else dim valueLength, valueTrimmed 'Will trim the text field, bn valueLength = Len(varFieldValue) if valueLength > myTextLength then valueTrimmed = Left(varFieldValue,myTextLength) valueTrimmed = valueTrimmed & "..." rw "" & valueTrimmed else rw "" & varFieldValue end if End Select End If rw "
" rw "

 

" rw "
" 'bn rw "" objRS.Close Set objRS = Nothing myOrder = "" 'resets order clause, bn End Function '====================================================================== Function exitPage()'bn '====================================================================== response.redirect (myExit) End Function '====================================================================== Function orderBy(column,page,ascend)'bn '====================================================================== dim order if ascend = 1 then order = " ASC" ascend = 0 else order = " DESC" ascend = 1 end if myOrder = "ORDER BY " & column & order Call editList(column,ascend,page) End Function '====================================================================== Function optOutput(lower,upper,optName,optValue)'bn used for time drop down boxes '====================================================================== rw "" End Function '====================================================================== Function showHide(column,ascend,page,shHide)'bn '====================================================================== dim temp,x,strFields 'added to aid quick deletes,bn for x = 1 to request.form("add").Count if strFields = "" then strFields = request.form("add")(x) else strFields = strFields & "'" & request.form("add")(x) end if next Application("showHideList") = strFields 'concatenated string of fields selected Application("myKey") = shHide Call editList(column,ascend,page) End Function '====================================================================== Function fieldPreferences(lngRecord)'Displays fields for show/hide selection, bn '====================================================================== 'sqlQuery = "SELECT * FROM " & myTable & " WHERE " & myKey & "=" & lngRecord sqlQuery = "SELECT TOP 1 * FROM " & myTable & " WHERE " & myKey & " > 0" Set objRS = objConn.Execute(sqlQuery) intFieldCount = objRS.Fields.Count - 1 rw "" & myTitle & "" If Trim(myStyle & "") <> "" Then rw "" End If rw "" rw "

Fields to Show or Hide

" rw "
" rw "" rw "
" For i = 0 To intFieldCount strName = objRS(i).Name strValue = objRS(i).Value intType = objRS(i).Type rw "" If strName = myKey Then rw "" Else rw "" rw "" End If Next rw "
Show Hide
" & strName & "
(" & clearType(intType) & ")Add Field

 

" rw "

 

" Set objRS = Nothing End Function '====================================================================== Function grpEmail(emailStr,sbj,text,from,fromMail,tm,numrec,emailHost)'bn '====================================================================== subject = sbj 'Could be database sql = "Select * from " & myTable & " where " & myKey & " in (" & emailStr & ")" 'rw sql set conn = server.CreateObject("ADODB.Connection") set rs = server.CreateObject("ADODB.Recordset") conn.Open connstring rs.Open sql,conn rs.movefirst While not rs.EOF txt = text '*****Original, non-execute version of replace 'text = replace(text,"[",""" & rs(""") 'text = replace(text,"]",""") & """) '************Execute const. zone 'Execute("rw ""Hello""") 'str = "rw rs(""Email"")" '***works 'str = "rw ""blah""" '***works 'str = "rw ""Emails are"":" '***works 1 of 2 'str = str & "rw rs(""Email"")" '***2 of 2 'str = "rw ""My email is"": rw rs(""Email"")" 'works 'str = "rw ""The emails are"" & rs(""Email"")" 'works 'str = "rw ""Email "" & rs(""Email"") & ""
""" 'works 'execute(str) 'str = "rw ""First name "" & rs(""First"") & "" is the first name.""" ' 'execute("rw ""First name "" & rs(""First"") & "" is your first name.""") ' '*****Applies to rw execute only 'text = """rw """"" & text 'asdf 'text = replace(text,"[",""""" & rs(""""") 'text = replace(text,"]",""""") & """"") 'text = text & """""""" '*****end txt = replace(txt,"""","""""") 'Allows quotes in user's text txt = "txt= """ & txt txt = replace(txt,"[",""" & rs(""") txt = replace(txt,"]",""") & """) txt = replace (txt,vbCrLf,""" & vbCrLf & """) txt = txt & """" ' execute(txt) Set Mailer = Server.CreateObject("SMTPsvg.Mailer") Mailer.FromName = from Mailer.FromAddress= fromMail Mailer.RemoteHost = emailHost Mailer.AddRecipient rs("FirstName") & " " & rs("LastName"), rs("Email") Mailer.Subject = subject Mailer.BodyText = txt if Mailer.SendMail then xyz = 1 'fake else Response.Write "Mail send failure. Error was " & Mailer.Response end if rs.movenext Wend redir = thisPage & "?msg=1" response.redirect(redir) End Function '====================================================================== function singlequote(str) 'frames values in single quotes '====================================================================== strArray = split(str,",") for x = LBound(strArray) to UBound(strArray) if singlequote <> "" then singlequote = singlequote & ",'" & strArray(x) & "'" else singlequote = "'" & strArray(x) & "'" end if next end function %>