• English
  • Inuktitut
  • Inuinnaqtun
Les Infirmières de Nunavut mettra à disposition la traduction du contenu de ce site Web en Francais dès sa disponibilité.

The Nunavut Nurses Newsletter
The Nunavut Nurses Newsletter
Téléchargez le document PDF (2.6 MO)

<% ''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''' ' NEWSLETTER SUBSCRIPTION FORM ' ' @Usage ' Process email subscription for newsletter ' @Desciption ' data was being saved to subscription/data/subscribe.mdb under root folder of the site ' if jquery was enabled, form will be processed by ajax mode without reload the page ' if not, form will besing posted as normal forms ' ' @Programmer ' Keen ' @Designer ' Jeff '''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''' %>
<% '''''''''''''''''''''' ' including libraries '''''''''''''''''''''' %> <% Class HashTable ' HashTable Object v1.0 [VBScript] ' http://www.aspemporium.com/ ' -------------------------------------------- ' Purpose: ' -------------------------------------------- ' Allows a VBScript programmer to use hash tables. ' ' A Hash table is what is known as an ' associative-array. An associative-array stores ' name and value pairs. The name and value pairs ' are associated with each other and remembered ' so they can be called on to return information ' about themselves. ' ' This class is meant to mimick the scripting ' dictionary (just in case it's not available ' on your server)... ' ' For Example, US States and state postal ' abbreviations are associated with each other ' and can be stored in a hash table for later ' reference: ' ' Dim oHash ' Set oHash = New HashTable ' oHash.Add "AK", "Alaska" ' oHash.Add "AL", "Alabama" ' oHash.Add "AR", "Arkansas" ' oHash.Add "AZ", "Arizona" ' Response.Write( oHash.GetValue("AZ") ) '<- returns "Arizona" ' ' A second example would be, storing a date ' in International and US Standard formats: ' ' Dim oHash ' Set oHash = New HashTable ' oHash.Add "US", "3/13/2001" ' oHash.Add "Intl", "13/3/2001" ' Response.Write( oHash.GetValue("Intl") ) '<- returns "13/3/2001" ' ' -------------------------------------------- ' Syntax: ' -------------------------------------------- ' Dim var1 ' Set var1 = New HashTable ' ' -------------------------------------------- ' Properties: ' -------------------------------------------- ' There are no exposed properties. ' ' -------------------------------------------- ' Methods: ' -------------------------------------------- ' Add(Key, Item) ' adds a key/item pair to the current hash ' table. (keys are case-sensitive). No ' duplicate Keys can be in the hash table. ' An error occurs if a duplicate is entered. ' Use the Exists() method to check to see if ' a key already exists before adding it. If ' a key already exists, you can use the ' UpdateHashValue() method to update that ' key's value in the hash table or the Remove() ' method to delete the key. ' ' The following Keys are not considered ' to be the same: ' "State" "state" ' because keys are case-sensitive. The Key ' and Item arguments can be a string, integer, ' double, single, boolean, variant or any ' other data type except for an array or ' object. ' ' ' UpdateHashValue(Key, NewValue) ' Updates an existing value in the hash table ' based on the key specified in Key. The ' value of the specified key that was replaced ' by NewValue is returned as a variant. (keys ' are case-sensitive). If key is not found, ' no new keys are added. You must call the ' Add( ) method to add keys. ' ' ' Remove(Key) ' Deletes the key/item pair as represented ' by the Key argument. Returns a variant (array) ' containing the key/item pair deleted ' as an array with 2 elements: Array(key, item) ' ' ' RemoveAll() ' clears the hash table of all entries. ' ' ' Count() ' returns integer indicating the number of ' key/item pairs entered into the current ' hash table. Returns 0 if the hash table ' is empty. ' ' ' Exists(Key) ' returns boolean indicating if the key ' specified in Key is already in the ' hash table. (keys are case-sensitive) ' ' ' GetValue(Key) ' returns a variant representing the value ' of the key specified in the Key argument. ' (keys are case-sensitive) ' ' ' NamesCollection() ' returns a collection (array) of names that ' have already entered into the HashTable ' ' ' ValuesCollection() ' returns a collection (array) of values that ' have already entered into the HashTable ' ' -------------------------------------------- ' Version History: ' -------------------------------------------- ' 1.0 [March 13, 2001] ' Initial Release ' ' -------------------------------------------- ' Requirements/Dependencies: ' -------------------------------------------- ' - VBScript Scripting Engine Version 5.1 or better ' - ASP 2.0/3.0 ' ' -------------------------------------------- ' Example Usage: ' -------------------------------------------- ' - Example 1: cheesy shopping cart info ' stored in the dictionary (temporarily) ' ' Dim oHash, item, vNames, vVals ' Set oHash = New HashTable ' With oHash ' ' 'add some purchases and the sessionID ' .Add "sessionID", Session.SessionID ' .Add "purchaseID1", 12 ' .Add "purchaseID2", 157 ' .Add "purchaseID3", 1548 ' .Add "purchaseID4", 810 ' .Add "purchaseID5", 503 ' ' 'remove one of the purchases. ' 'discard the returned value ' 'of the remove function... ' .Remove "purchaseID5" ' ' 'change the ID of one of the other purchases ' 'discard the old value (returned by the function ' 'below) ' .UpdateHashValue "purchaseID4", 5 ' ' 'attempt to add a new pair to the ' 'hash table ' If Not .Exists("purchaseID5") Then ' .Add "purchaseID5", 778 ' Else ' 'if that purchase already exists, ' 'display it: ' Response.Write(.GetValue("purchaseID5") & "
") ' End If ' ' 'show all the purchases: ' vNames = .NamesCollection ' vVals = .ValuesCollection ' For i = 0 to .Count ' Response.Write(vNames(i) & " " & vVals(i) & "
") ' Next ' ' 'show all the purchases a different way: ' For Each Item In .NamesCollection ' Response.Write(Item & " " & .GetValue(Item) & "
") ' Next ' ' 'remove all the items from the dictionary: ' .RemoveAll ' End With ' Set oHash = Nothing ' ' ' - Example 2: use the Hash table to eliminate duplicate ' entries in an array: ' ' Dim oldArray, newArray, oHash ' ' 'array with 3 duplicate entries ' oldArray = Array("ab", "bc", "cd", "de", "ed", "bc", "ab", "de") ' Set oHash = New HashTable ' With oHash ' ' 'loop through the array and add each element ' 'to the hash table. ' For i = 0 To UBound(OldArray) ' ' 'if the element is not already ' 'in the hash table, add it ' If Not .Exists(oldArray(i)) Then ' .Add oldArray(i), oldArray(i) ' End If ' Next ' ' 'return the collection of non-duplicate keys. ' 'the original array minus the duplicates... ' newArray = .NamesCollection ' End With ' Set oHash = Nothing ' ' -------------------------------------------- ' Disclaimer/Warning: ' -------------------------------------------- ' Search the site and read the license yourself. If ' you eat and/or consume digestable materials for fuel, ' you're bound to the license. By using this software ' or any piece of it in any medium, you have taken your ' server into your own hands... and any burdens, issues ' or otherwise that may result from using this code ' are your problem and not mine. ' ' Please leave this documentation in the class as it ' is the only copy of the properties and methods for ' this object. I no longer keep object reference sheets ' at the ASP Emporium. Instead, documentation for ' each object is imbedded within the class definitions ' to make it easier for anyone to use the class. ' 'first two variables are un-dimensioned arrays. These two arrays 'hold all of the contents of the hash table. By bending the rules 'as much as possible, these two arrays by themselves can fake a 'hash table. The class interface only provides an easier way to work 'with the 2 array variables with less confusion. The third variable is 'a global counter indicating the total number of elements in the 'first 2 global array variables. Private HashTable_Names() Private HashTable_Values() Private HashTable_Count Private Sub Class_Initialize() 'class initialize event... 'set the global array incrementer variable 'at -1 to start HashTable_Count = -1 End Sub Private Sub Class_Terminate() 'class terminate event... 'call the class's removeall( ) method 'to redimension the two hash table 'arrays and reset the global counter, 'freeing up memory. RemoveAll End Sub Public Function UpdateHashValue(ByVal sName, ByVal sNewValue) 'updates the value of a key, returns the old value 'of the key (the value that was just replaced) Dim i, sOut sOut = "" 'loop through the array of names, looking for an 'exact (case sensitive) match For i = 0 to UBound(HashTable_Names) If sName = HashTable_Names(i) Then 'if the key is found, return the 'old value and replace the old 'value with the new value specified 'in the hash table's values array. sOut = HashTable_Values(i) HashTable_Values(i) = sNewValue Exit For End If Next UpdateHashValue = sOut End Function Public Function Remove(ByVal sName) 'removes a key/value pair by key Dim i, j, vOut 'loop through the hash table's names array looking for 'an exact match. For i = 0 to UBound(HashTable_Names) If sName = HashTable_Names(i) Then 'if found, return the key/value pair to be removed 'as an array with 2 elements... vOut = Array(HashTable_Names(i), HashTable_Values(i)) HashTable_Names(i) = "" HashTable_Values(i) = "" 'loop through the name/value arrays and move all the 'hash table entries up one element, starting at the 'element we just removed. For j = i to UBound(HashTable_Names) if j + 1 > UBound(HashTable_Names) then Exit For HashTable_Names(j) = HashTable_Names(j + 1) HashTable_Values(j) = HashTable_Values(j + 1) Next 'drop 1 from the global count of array elements cause 'were redimming the array - 1 element HashTable_Count = HashTable_Count - 1 'use the Preserve keyword so that the values 'already entered stay in the arrays Redim Preserve HashTable_Names(HashTable_Count), _ HashTable_Values(HashTable_Count) Remove = vOut Exit Function End If Next Remove = "" End Function Public Sub RemoveAll() 'clean out the hash table. Redim the array to -1, 'removing all elements. reset the internal element 'counter so that it matches... Redim HashTable_Names(-1), HashTable_Values(-1) HashTable_Count = -1 End Sub Public Sub Add(ByVal sName, ByVal sValue) 'add a key/value pair to the dictionary. Key is case 'sensitive. Dim i 'if this is the first entry into the hash table If HashTable_Count < 0 then 'set the hash table element counter to a number 'that represents the first element in an array '(that's always 0) HashTable_Count = 0 'redimension the array's that fake the hash table. Redim HashTable_Names(0), HashTable_Values(0) 'set the value of the first elements equal to 'what was entered in the arguments... HashTable_Names(0) = sName HashTable_Values(0) = sValue Else 'if other elements exist in the hash table, 'increment the hash table element variable HashTable_Count = HashTable_Count + 1 'redimension the internal arrays, this time 'using the preserve keyword so that other 'entries in the hash table are still there. Redim Preserve HashTable_Names(HashTable_Count), _ HashTable_Values(HashTable_Count) 'loop through the hash table elements, trying to 'match the name. if it's found, raise an error cause 'no duplicate key's are allowed. For i = 0 to UBound(HashTable_Names) If sName = HashTable_Names(i) Then Err.Raise 35675, _ "No Duplicate Key Names " & _ "Allowed In Hash Table" Exit Sub End If Next 'set the new key/value pair in the hash table. HashTable_Names(HashTable_Count) = sName HashTable_Values(HashTable_Count) = sValue End If End Sub Public Function Count() 'return the global counter variable + 1 Count = HashTable_Count + 1 End Function Public Function Exists(ByVal sName) 'determine whether or not a key exists already in the 'hash table. Dim i If Count() > 0 Then 'loop through the hash table For i = 0 to UBound(HashTable_Names) 'if the name is found, return true If sName = HashTable_Names(i) Then Exists = True Exit Function End If Next End If 'otherwise return false. Exists = False End Function Public Function GetValue(ByVal sName) 'returns the value of a specified key Dim i, sOut sOut = "" If Count() > 0 Then 'loop through hash table looking for 'a key name that matches exactly. For i = 0 to UBound(HashTable_Names) If sName = HashTable_Names(i) Then 'if key found, return the value of the key sOut = HashTable_Values(i) Exit For End If Next End If GetValue = sOut End Function Public Function NamesCollection() 'return the internal array of hash table keys NamesCollection = HashTable_Names End Function Public Function ValuesCollection() 'return the internal array of hash table values ValuesCollection = HashTable_Values End Function End Class %> <% '########################################### '# Create n random characters '########################################### function MyRandc(n) dim thechr thechr = "" for i=1 to n dim zNum,zNum2 Randomize zNum = cint(25*Rnd) zNum2 = cint(10*Rnd) if zNum2 mod 2 = 0 then zNum = zNum + 97 else zNum = zNum + 65 end if thechr = thechr & chr(zNum) next MyRandc = thechr end function '########################################### '# Read the content of a text file '########################################### function ReadTextFile(FilePath) ReadTextFile = "" Dim fs,f,readf Set fs = CreateObject("Scripting.FileSystemObject") Set f = fs.GetFile(FilePath) Set readf = f.OpenAsTextStream(1,0) 'Set readf = f.OpenAsTextStream(ForReading,TristateFalse) 'ForReading=1 readonly 'ForWriting=2 read&write 'ForAppending=3 append 'TristateUseDefault=-2 system default format 'TristateTrue=-1 Unicode format 'TristateFalse=0 ASCII format s = readf.ReadLine ReadTextFile = ReadTextFile & s Do While readf.AtEndOfLine <> True s = readf.ReadLine ReadTextFile = ReadTextFile & s Loop readf.close end function ' ----------------------------------------- ' URL decode to retrieve the original value ' ----------------------------------------- Function URLDecode(sConvert) Dim aSplit Dim sOutput Dim I If IsNull(sConvert) Then URLDecode = "" Exit Function End If ' convert all pluses to spaces sOutput = REPLACE(sConvert, "+", " ") ' next convert %hexdigits to the character aSplit = Split(sOutput, "%") If IsArray(aSplit) Then sOutput = aSplit(0) For I = 0 to UBound(aSplit) - 1 sOutput = sOutput & _ Chr("&H" & Left(aSplit(i + 1), 2)) &_ Right(aSplit(i + 1), Len(aSplit(i + 1)) - 2) Next End If URLDecode = sOutput End Function ' ----------------------------------------- ' HTML decode to retrieve the original value ' ----------------------------------------- Function HTMLDecode(sText) Dim I sText = Replace(sText, """, Chr(34)) sText = Replace(sText, "<" , Chr(60)) sText = Replace(sText, ">" , Chr(62)) sText = Replace(sText, "&" , Chr(38)) sText = Replace(sText, " ", Chr(32)) For I = 1 to 255 sText = Replace(sText, "&#" & I & ";", Chr(I)) Next HTMLDecode = sText End Function '########################################### '# Send Mail '########################################### function SendJmail(strSenderName,strFrom,strReplyTo,strTo,strSubject,strBody) Dim Mailer Set Mailer = Server.CreateObject("jmail.smtpmail") Mailer.ContentType = "text/html" Mailer.ServerAddress = "mail.outcrop.com" Mailer.logging = true mailToList = split(strTo,";") for mailIndex = 0 to ubound(mailToList) Mailer.AddRecipient(mailToList(mailIndex)) next 'Mailer.AddRecipient(strTo) Mailer.Sender = strFrom Mailer.SenderName = strSenderName Mailer.ReplyTo = strReplyTo Mailer.Subject = strSubject Mailer.Body = strBody Mailer.Execute() 'Response.Write Mailer.Log & "
" Set Mailer = Nothing end function '########################################### '# Get Server Name '########################################### function getMachineName Set WshNetwork = server.CreateObject("WScript.Network") IntMachinName=WshNetwork.ComputerName set WshNetwwork = nothing getMachineName = IntMachinName end function '########################################### '# Disable Client Cache '########################################### Function DisableCache() Response.Buffer = true Response.ExpiresAbsolute = dateadd("s",-1,Now) Response.Expires = 0 Response.CacheControl = "no-cache" response.AddHeader "Pragma","no-cache" response.AddHeader "Cache-Control","no-store" response.AddHeader "Expires",-1 End Function function TransMonthName(month) select case month case 1 TransMonthName = "January" case 2 TransMonthName = "February" case 3 TransMonthName = "March" case 4 TransMonthName = "April" case 5 TransMonthName = "May" case 6 TransMonthName = "June" case 7 TransMonthName = "July" case 8 TransMonthName = "August" case 9 TransMonthName = "September" case 10 TransMonthName = "October" case 11 TransMonthName = "November" case 12 TransMonthName = "December" end select end function function DTFormat(dateSrc,dateFormat) Dim dateString if isDate(dateSrc) then dateFormat = replace(dateFormat,"MMMM",TransMonthName(month(dateSrc))) dateFormat = replace(dateFormat,"MMM",Left(TransMonthName(month(dateSrc)),3)) dateFormat = replace(dateFormat,"MM",month(dateSrc)) dateFormat = replace(dateFormat,"DD",day(dateSrc)) dateFormat = replace(dateFormat,"YYYY",Year(dateSrc)) dateFormat = replace(dateFormat,"YY",Year(dateSrc)) dateFormat = replace(dateFormat,"hh",right("00" & Hour(dateSrc),2)) dateFormat = replace(dateFormat,"ss",right("00" & second(dateSrc),2)) dateFormat = replace(dateFormat,"mm",right("00" & Minute(dateSrc),2)) DTFormat = dateFormat else if isNull(dateSrc) then DTFormat = "" else DTFormat = cstr(dateSrc) end if end if end function function CurrencyFormat(strMoney) if inStr(strMoney,"$") > 0 then CurrencyFormat = strMoney else CurrencyFormat = "$" & strMoney end if end function function CheckForBlank(chkField,chkName) if trim(Request.Form(chkField)) = "" then CheckForBlank = "
  • " & chkName & "
  • " else CheckForBlank = "" end if end function function CheckForBlankEnhance(chkField,chkName,js_collection, js_index) ret = "" if trim(Request.Form(chkField)) = "" then ret = ret & "
  • " & chkName & "
  • " ret = ret & AddToJsCollection(js_collection, js_index) CheckForBlankEnhance = ret else CheckForBlankEnhance = "" end if end function function AddToJsCollection(js_collection, js_index) ret = ret & "" AddToJsCollection = ret end function function disableHtml(strContent) if isNull(strContent) then disableHtml = "" else disableHtml = Server.HTMLEncode(strContent) end if end function function GetDblValue(obj) if isNull(obj) or trim(obj) = "" then GetDblValue = 0 exit function end if if isNumeric(cStr(obj)) then GetDblValue = cDbl(cStr(obj)) else GetDblValue = 0 end if end function function GetIntValue(obj) if isNull(obj) or trim(obj) = "" then GetIntValue = 0 exit function end if if isNumeric(cStr(obj)) then GetIntValue = cInt(cStr(obj)) else GetIntValue = 0 end if end function function isEmptyEx(obj) if isNull(obj) or isEmpty(obj) then isEmptyEx = true else if Trim(cStr(obj)) = "" then isEmptyEx = true else isEmptyEx = false end if end if end function Function isValidEmail(chkEmail) dim isValidE dim regEx isValidE = True set regEx = New RegExp regEx.IgnoreCase = False regEx.Pattern = "^[a-zA-Z][\w\.-]*[a-zA-Z0-9]@[a-zA-Z0-9][\w\.-]*[a-zA-Z0-9]\.[a-zA-Z][a-zA-Z\.]*[a-zA-Z]$" isValidE = regEx.Test(chkEmail) isValidEmail = isValidE End Function function RemovePhoneEmptyField(phone) ret = phone ret = Replace(ret, "(___) ___-____ ext ____", "") ret = Replace(ret , "ext ____", "") ret = Replace(ret, "_", "") RemovePhoneEmptyField = ret end function %> <% intLocale = SetLocale(4105) public SiteUrl select case lcase(getMachineName) case "keenwu", "europe" MailAdmin = "keen@outcrop.com" SiteUrl = "http://nu-nurses.clients.outcrop.com" RootDir = "/" ContactUrl = "mailto:brian@outcrop.com" case "archives", "webdev" MailAdmin = "test@outcrop.com" SiteUrl = "http://nu-nurses.clients.outcrop.com" RootDir = "/" ContactUrl = "mailto:brian@outcrop.com" case "tourism" MailAdmin = "brian@outcrop.com" SiteUrl = "http://nunavutnurses.ca" RootDir = "/" ContactUrl = "mailto:brian@outcrop.com" case else ''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''' 'could not match virtual server parameters with existing configuration! ''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''' %>

    Errors

    Failed to find site configuration parameters for virtual server:

    <%=getMachineName%>

    Please contact the system administrator.

    <% Response.End() end select MailTransfer = "routing@outcrop.com" %> <% if Request.Form("#formpost") <> "yes" then '''''''''''''''''''''' ' form initialization '''''''''''''''''''''' %> <% Email = "Enter your email" if Trim(Request.Form("subscribe")) <> "" then Email = Trim(Request.Form("subscribe")) end if if SubscriptionSuccess then Email = "Enter your email" end if %>

    Subscribe today and receive
    new issues of the
    Nunavut Nurses Newsletter.

    <% else '''''''''''''''''''''''''''''''''''''''''' ' process form post values initialization '''''''''''''''''''''''''''''''''''''''''' Email = Request.Form("subscribe") Dim formErrors Set formErrors = New HashTable Set formScripts = New HashTable '''''''''''''''''''''''''''''''''''''''''' ' form validation '''''''''''''''''''''''''''''''''''''''''' if trim(Email) = "" then formErrors.Add "subscribe", "Please enter your email." else if not isValidEmail(Email) then formErrors.Add "subscribe", "'" & disableHTML(Email) & "' is not a valid email address." end if end if if formErrors.Count() > 0 then %> <% Email = "Enter your email" if Trim(Request.Form("subscribe")) <> "" then Email = Trim(Request.Form("subscribe")) end if if SubscriptionSuccess then Email = "Enter your email" end if %>

    Subscribe today and receive
    new issues of the
    Nunavut Nurses Newsletter.

      <% '''''''''''''''''''''''''''''''''''''''''' ' show validation errors '''''''''''''''''''''''''''''''''''''''''' With formErrors vNames = .NamesCollection vVals = .ValuesCollection For i = 0 to .Count() - 1 %>
    • <%=vVals(i)%>
    • <% Next End With %>
    <% else 'build notice NoticeToAdminSubject = "New subscription of news letter" NoticeToAdmin = ReadTextFile(Server.MapPath("subscription/subscribe-newsletter-notice.txt")) NoticeToAdmin = Replace(NoticeToAdmin, "%subscribe-email%", Email) NoticeToAdmin = Replace(NoticeToAdmin, "%site-url%", SiteUrl) NoticeSent = true on error resume next err.clear 'send notice SendJmail "newsletter subscriber",MailTransfer,Email,MailAdmin,NoticeToAdminSubject,NoticeToAdmin if err then NoticeSent = False %> <% Email = "Enter your email" if Trim(Request.Form("subscribe")) <> "" then Email = Trim(Request.Form("subscribe")) end if if SubscriptionSuccess then Email = "Enter your email" end if %>

    Subscribe today and receive
    new issues of the
    Nunavut Nurses Newsletter.

    • Unfortunately, there was an error in submitting your request. Please try again later. If you keep getting this error, please contact us for help.
    <% end if 'save log to database on error goto 0 dim conn set conn = Server.CreateObject("adodb.connection") sConnectString = "PROVIDER=MICROSOFT.JET.OLEDB.4.0;DATA SOURCE=" & Server.Mappath("subscription/data/subscribe.mdb") & ";" conn.open sConnectString set conn = CreateObject("adodb.connection") conn.Open sConnectString set rsReg = Server.CreateObject("adodb.recordset") rsReg.Open "select * from log where 1=2", conn, 2,3,1 rsReg.AddNew rsReg("Email") = Email rsReg("logIP") = Request.ServerVariables("REMOTE_ADDR") rsReg("logDate") = Now rsReg("logNotice") = NoticeToAdmin rsReg("logNoticeSubject") = NoticeToAdminSubject if NoticeSent then rsReg("logNoticeSent") = -1 else rsReg("logNoticeSent") = 0 end if rsReg.Update rsReg.Close set rsReg = nothing conn.Close set conn = nothing SubscriptionSuccess = TRUE %> <% Email = "Enter your email" if Trim(Request.Form("subscribe")) <> "" then Email = Trim(Request.Form("subscribe")) end if if SubscriptionSuccess then Email = "Enter your email" end if %>

    Subscribe today and receive
    new issues of the
    Nunavut Nurses Newsletter.

    <% on error goto 0 end if end if %>

    The Nunavut Nurses Newsletter
    Jeter les assises d’une collectivité en santé
    Téléchargez le document PDF (1.28 MO)