<% option explicit %> <%'************ FORM VALIDATION FUNCTIONS ***************** 'Mark Dane 'Feb 2005 'Version 1.1 '*********** SUMMARY ************** 'created from formFunctions.asp 'functions and globals to manage form validation 'CONTAINS THE FOLLOWING GLOBALS 'g_errors - Scripting.Dictionary 'g_formMethod 'CONTAINS THE FOLLOWING CONSTANTS 'g_errorTag 'g_errorPrefix 'g_errorClass 'CONTAINS THE FOLLOING METHODS 'sub formCleanup 'sub setFormMethod( x ) 'function hasError( name ) 'sub displayErrors( name ) 'function formHasErrors() 'function getFormValue( name ) 'sub vField( name, displayName ) 'sub vText( name, displayName, length ) 'sub vRegExp( name, displayName, regex, desc) 'sub vDate( name, displayName ) 'sub vDateRange( name, displayName, minStr, maxStr ) 'sub vSmallDate( name, displayName ) 'sub vRadio( name ,displayName ) 'sub showAllErrorsUL 'sub showAllErrorsFormat ( headerOpen, itemOpen, itemClose, headerClose ) '************** CODE *************************** 'create error list dim g_errors, g_formMethod set g_errors = Server.CreateObject("Scripting.Dictionary") 'tag to enclose error in dim g_errorTag : g_errorTag = "div" 'prefix error text with this dim g_errorPrefix : g_errorPrefix = "*" dim g_errorClass : g_errorClass = "error" sub showAllErrorsUL 'shows all the errors in an unorderd list showAllErrorsFormat "" end sub sub showAllErrorsFormat( headerOpen, itemOpen, itemClose, headerClose ) 'shows all the errors in g_errros. 'precedes list of errors with HTML in headerOpen 'each errors starts with itemOpen and ends with itemClose 'the list is finshed by headerClose 'ie showAllErrorsFormat( "" ) gives ' 'headerClose response.write( headerOpen ) dim xerror for each xerror in g_errors response.write( itemOpen & g_errors(xerror) & itemClose ) next response.write( headerClose ) end sub sub formCleanup 'cleans up after finished proscessing form set g_errors = nothing end sub sub setFormMethod( x ) 'sets what method the form was submitted by ' x = submission method ( "GET" or "POST") g_formMethod = x end sub function formHasErrors() 'returns if form has errors or not formHasErrors = ( g_errors.count > 0 ) end function function getFormValue( name ) if g_formMethod = "GET" then getFormValue = request.QueryString(name) else getFormValue = request.form(name) end if end function sub vField( name, displayName ) 'validates that a field was submitted 'name = name of form field 'displayName = human readable description of field dim val val = getFormValue(name) val = rtrim(val) val = ltrim(val) if isNull( val ) or val = "" then g_errors.add name, displayName & " is required" end if end sub sub vText( name, displayName, length ) 'validates text 'name = name of form field 'displayName = human readable description of field 'length = maximum length, if NULL does not check for length if isNull(length) then length = -1 dim val val = getFormValue(name) 'validate that somethign was submitted vField name, displayName 'if something was not submitted then we already have an error so quit if g_errors.exists(name) then exit sub if length > 0 AND len( val ) > length then g_errors.add name, displayName & " is too long. Maximum length of " & length & " characters." end if end sub sub vRegExp( name, displayName, regex, desc) 'validates field using regular expression, field is required 'name = name of form field 'displayName = human readable description of field 'regex = regular expression to check against 'desc = human readable description of what regexp is checking for dim r, val val = getFormValue(name) set r = new RegExp r.pattern = regex if isNull( val ) or val = "" and not g_errors.exists( name ) then g_errors.add name, displayName & " is required" elseif not r.test( val ) and not g_errors.exists(name) then g_errors.add name, displayName & " is not a valid " & desc end if end sub sub vDate( name, displayName ) 'validates that a string is a date in mm/dd/yyyy format 'name = name of field 'displayName = human readable label dim dateRE, d d = getFormValue(name) if isNull( d ) or d = "" then g_errors.add name, displayName & " is required" exit sub end if if not isDate(d) then g_errors.add name, displayName & " is not a valid date" exit sub end if set dateRE = new RegExp dateRE.pattern = "^\d{1,2}/\d{1,2}/\d{4}$" if not dateRE.test(d) then g_errors.add name, displayName & " is not formatted as mm/dd/yyyy" exit sub end if end sub sub vDateRange( name, displayName, minStr, maxStr ) 'checks for valid date that will fit into datetime type 'name = name of field 'displayName = human readable label 'minStr = minimum date in mm/dd/yyyy 'maxStr = maximum date in mm/dd/yyyy dim minDate, maxDate, myDate 'first check for valid date vDate name, displayName if g_errors.exists( name ) then exit sub 'make sure it fits minDate = cDate(minStr) maxDate = cDate(maxStr) myDate = cDate( getFormValue(name) ) 'check to make sure it falls within bounds if myDate < minDate or myDate > maxDate then g_errors.Item(name) = displayName & " must be between " & minStr & " and " & maxStr end if end sub sub vSmallDate( name, displayName ) 'validates a date for smalldatetime 'name = name of field 'displayName = human readable label vDateRange name, displayName, "1/1/1900", "6/1/2079" end sub sub vRadio( name ,displayName ) 'validates that an option has been selected for a radio button 'name = name of field 'displayName = human readable label dim val val = getFormValue(name) if isNull( val ) or val = "" then g_errors(name) = displayName & " is required" end if end sub function hasError( name ) 'returns true if field has error hasError = ( g_errors.exists(name) ) end function sub displayErrors( name ) 'displays any errors for the form field 'name = name of form field to get errors for if g_errors.exists(name) then Response.write( "<" & g_errorTag & " class=""" & g_errorClass &""">" & g_errorPrefix & g_errors(name) & "" & vbcrlf ) end if end sub %> <%'************ ESCAPE FUNCTIONS **************** 'Mark Dane 'Nov 2004 'Version 1.0 'functions to escape text strings 'CONTAINS THE FOLLOWING DECLARATIONS 'function SQLinsertable( x ) 'function HTMLescapeQuotes( x ) 'function HTMLescape(x) 'function JSescapeQuotes(x) 'function URLescapeQuotes(x) function SQLinsertable( x ) 'transforms var x into sql insertable value if isNull(x) or x = "" then SQLinsertable = "NULL" else x= cStr(x) x = replace( x, "'", "''") 'x = replace( x, """", """""") 'add surrounding quotes SQLinsertable = "'" & x & "'" end if end function function HTMLescapeQuotes( x ) 'escapes " with " for HTML output if isNull(x) or x = "" then HTMLescapeQuotes = "" else HTMLescapeQuotes = replace ( x, """", """) end if end function function HTMLescape(x) 'escapes a string for HTML use by replacing <, > ,&, and " , etc. with thier HTML escape chars 'x = string to escape if( isNull(x) or x = "" ) then HTMLescape = "" else HTMLescape = Server.HTMLEncode(x) end if end function function JSescapeQuotes( x ) 'escapes " with \" and ' with \' for JavaScript if isNull(x) or x = "" then JSescapeQuotes = "" else x = replace( x, """", "\""") x = replace( x, "'", "\'") JSescapeQuotes = x end if end function function URLescapeQuotes( x ) 'escapes " with %22 for use in href="" if isNull(x) or x = "" then URLescapeQuotes = "" else URLescapeQuotes = replace( x , """", "%22" ) end if end function %> <%'*********** SELECT OPTION GENERATION ***************** 'Mark Dane 'November 2004 'Version 1.0 'functions to handle genreation of select lists from db lookup tables 'interacts with database so can throw live errors 'REQUIRES the following error handling subroutine : 'throwErrow( INTEGER type, STRING Message ) 'THIS FILE CONTAINS THE FOLLOWING DECLARATIONS 'sub makeSelectOptions( table, labelCol, valueCol, conn, default ) 'class selectOption 'function newSelectOption( label, val ) 'function getSelectOptions( table, labelCol, valueCol, conn ) 'sub genSelectOptions( options, default ) class selectOption ' class used for storing information about options public optionValue public label public default property get desc desc = label end property end class function newSelectOption( label, val ) dim x set x = new selectOption x.optionValue = val x.label = label set newSelectOption = x end function function getSelectOptions( table, labelCol, valueCol, conn ) 'returns an array of select options from a lookup table ' table = talbe name ' lableCol = column in table with values for labels ' value col = column in table with values for value ' conn = connection to use to db on error resume next ' handle db errors dim o ' use for records set of select options set o = server.CreateObject("ADODB.Recordset") o.cursortype = adOpenStatic o.source = "SELECT "& labelCol&" AS 'label', " & valueCol &" AS 'value' FROM " & table o.activeConnection = conn o.open dim i, arrSize arrSize = o.recordcount - 1 ' size of array, starts at 0 so subract 1 redim options( arrSize ) ' array to store select options in for i = 0 to arrSize set options(i) = newSelectOption( o.fields.item("label").value, o.fields.item("value").value ) o.movenext next 'check for any problems if conn.errors.count > 0 then dim e : set e = conn.errors(0) err.raise e.number, e.source, e.description, e.helpfile, e.helpcontext end if if err.number <> 0 then throwError eDbError, "Error getting select options from database" end if o.close set o = nothing getSelectOptions = options end function sub genSelectOptions( options, default ) 'generates a list of select options 'default = value that should be set as default selected option 'options = array of selectOption objects 'convert value to string default = cStr( default) ' use string comparision so we done miss comapring numbers to strings dim selected, x for each x in options 'see if this option should be selected if cStr(x.optionValue) = default then selected = " selected" else selected = "" end if 'print Response.write( "" & vbcrlf ) next end sub sub makeSelectOptions( table, labelCol, valueCol, conn, default ) 'creates