<% ' ===================================================================================== ' = File: incForm.asp ' = File Version: 5.1 (beta) ' = Copyright (c)1997-2003 American Web Services, Inc. All rights reserved. ' = Description: ' = Email, HTML Form and Database utilities ' = Revision History: ' = 14jul2000 (5.1 beta) ssutterfield: general code cleanup/documentation ' = Description of Customizations: ' = ' ===================================================================================== ' Short-cuts ' -------------- TextInput ------------------ Public Sub TextInput(ByVal strName, ByVal intSize, ByVal intMaxSize, ByRef rstDefault) Call FormInput("text", strName, strName, intSize, intMaxSize, rstDefault, "") End Sub ' -------------- PasswordInput ------------------ Public Sub PasswordInput(ByVal strName, ByVal intSize, ByVal intMaxSize, ByRef rstDefault) Call FormInput("password", strName, strName, intSize, intMaxSize, rstDefault, "") End Sub ' -------------- HiddenInput ------------------ Public Sub HiddenInput(ByVal strName, ByRef rstDefault) Call FormInput("hidden", strName, strName, 0, 0, rstDefault, "") End Sub ' -------------- TextArea ------------------ Public Sub TextArea(ByVal strName, ByVal intRows, ByVal intCols, ByRef rstDefault) Call FormInput("textarea", strName, strName, intRows, intCols, rstDefault, "") End Sub ' -------------- RadioButton ------------------ Public Sub RadioButton(ByVal strName, ByVal strValue, ByRef rstDefault) Call FormInput("radio", strName, strValue, 0, 0, rstDefault, "") End Sub ' -------------- CheckBox ------------------ Public Sub CheckBox(ByVal strName, ByVal strValue, ByRef rstDefault) Call FormInput("checkbox", strName, strValue, 0, 0, rstDefault, "") End Sub ' -------------- FormInput ------------------ ' Standard FORM INPUTs with default from Recordset ' strType: text, hidden, password, textarea, radio, checkbox ' strName: Form item NAME and visible value of form item ' strValue: Hidden value of form item ' intSize1, intSize2: "Size, Maxlength" or "Rows, Cols" ' rstDefault: Request or Recordset with default values ' strDefault: if not empty, overrides rstDefault Public Sub FormInput(ByVal strType, ByVal strName, ByVal strValue, ByVal intSize1, ByVal intSize2, ByRef rstDefault, ByVal strDefault) Dim strCheckedName strCheckedName = strDefault & "" If strDefault = "" then if IsObject(rstDefault) then strCheckedName = rstDefault(strName) & "" else strCheckedname = rstDefault & "" end if strCheckedName = Server.HTMLEncode(strCheckedName) End If Select Case strType Case "textarea" Response.Write "" Response.Write strCheckedName Response.Write "" Case "radio", "checkbox" Response.Write "" Case Else ' text, hidden, password Response.Write "" End Select End Sub ' -------------- ArrayPulldown ------------------ ' for backwards compatibility Public Sub ArrayPulldown(strName, strFirstOption, rstDefault, dctContent) Call FormMultiDct(strName, strName, 0, strFirstOption, "", rstDefault, dctContent) End Sub ' -------------- Pulldown ------------------ ' for backwards compatibility Public Sub Pulldown(strName, strValue, strFirstOption, strLabel, rstDefault, rstContent) Call FormMultiRS(strName, strValue, 0, strFirstOption, strLabel, rstDefault, rstContent) End Sub ' -------------- FormMultiRS ------------------ ' Standard SELECTs with default from Recordset ' strName: Form item NAME ' strValue: field name in rstContent for form item VALUE ' intSize: 0 = Pulldown, 1-n = Multibox ' strFirstOption: optional first OPTION (if selected, will have a value of "") ' strLabel: field name in rstContent for form item label ' rstDefault: Request or Recordset with default values ' rstContent: Recordset with content of pulldown/multibox Public Sub FormMultiRS(ByVal strName, ByVal strValue, ByVal intSize, ByVal strFirstOption, ByVal strLabel, ByRef rstDefault, ByRef rstContent) Dim strCheckedValue strCheckedValue = "" If Not IsNull(rstDefault(strName)) Then strCheckedValue = CStr(rstDefault(strName)) End If rstContent.MoveFirst ' Set rstTemp = rstContent.Clone Response.Write "" & vbcrlf If Not (strFirstOption = "") Then Response.Write "" & strFirstOption End If Do While Not rstContent.EOF Response.Write " 0 Then Response.Write " SELECTED" End If End If Response.Write ">" Response.Write rstContent(strLabel) & vbcrlf rstContent.MoveNext Loop Response.Write "" End Sub ' -------------- FormMultiDct ------------------ ' Standard SELECTs with default from Dictionary object ' strName: Form item NAME ' strValue: form item VALUE ' intSize: 0 = Pulldown, 1-n = Multibox ' strFirstOption: optional first OPTION ' strLabel: Visible value of OPTION ' rstDefault: Request or Recordset with default values ' dctContent: Dictionary with content of pulldown/multibox Public Sub FormMultiDct(ByVal strName, ByVal strValue, ByVal intSize, ByVal strFirstOption, ByVal strLabel, ByRef rstDefault, ByRef dctContent) Dim strCheckedValue Dim i, aryKeys, aryValues strCheckedValue = "" If Not IsNull(rstDefault(strValue)) Then strCheckedValue = CStr(rstDefault(strValue)) End If aryKeys = dctContent.Keys aryValues = dctContent.Items Response.Write "" & vbcrlf If Not (strFirstOption = "") Then Response.Write "" & strFirstOption & """" End If For i = 0 To dctContent.Count - 1 Response.Write " 0 Then Response.Write " SELECTED" End If End If Response.Write ">" Response.Write aryValues(i) & vbcrlf Next Response.Write "" End Sub function GetArrayValueX(strKey, dctList, strDefault) if strKey & "" = "" then GetArrayValueX = strDefault else GetArrayValueX = GetArrayValue(strKey, dctList) end if end function function GetArrayValue(byVal strKey, dctList) ' Returns the VALUE when Passed the KEY from a dictionary object dim i, k, c, x strKey = strKey & "" if strKey <> "" then GetArrayValue = "?? " & strKey & " ??" end if x = dctList.count - 1 k = dctList.keys i = dctList.items for c = 0 to x if CStr(k(c)) = strKey then GetArrayValue = i(c) exit function end if next end function ' -------------- JSEncode ------------------ ' Replaces Single Quotes with JavaScript Escape for Single Quote Function JSEncode(strInput) JSEncode = Replace(strInput & "","'","\'") End Function ' -------------- SQLEncode ----------------- ' Replaces Single Quotes with 2 Single Quotes in Input String Function SQLEncode(strInput) SQLEncode = Replace(strInput & "","'","''") End Function ' -------------- SQLChar ------------------- ' Checks if Input Value is Null, then builds SQL Input Line for Char Function SQLChar(InputRS, fieldname) IF InputRS(fieldname) & "" = "" THEN SQLChar = fieldname & " = NULL" ELSE SQLChar = fieldname & " = '" & SQLEncode(InputRS(fieldname)) & "'" END IF End Function ' -------------- SQLInt -------------------- ' Checks if Input Value is Null, then builds SQL Input Line for Number Function SQLInt(InputRS, fieldname) IF InputRS(fieldname) & "" = "" THEN SQLInt = fieldname & " = NULL" ELSE SQLInt = fieldname & " = " & InputRS(fieldname) END IF End Function ' -------------- SQLMoney ------------------ ' Checks if Input Value is Null, then builds SQL Input Line for Money Function SQLMoney(InputRS, fieldname) IF InputRS(fieldname) & "" = "" THEN SQLMoney = fieldname & " = NULL" ELSE SQLMoney = fieldname & " = CONVERT(money, '" & InputRS(fieldname) & "')" END IF End Function ' -------------- BuildDict ----------------- ' Builds Dictionary Object from Lookup Table function BuildDict(tablename, strKey, strItem, strWhere, strSort) dim dctTemp, rsTemp, sql set dctTemp = Server.CreateObject("Scripting.Dictionary") sql = "SELECT * FROM " & tablename sql = sql & " WHERE " & strWhere if not strSort = "" then sql = sql & " ORDER BY " & strSort end if set rsTemp = gobjConn.execute(sql) do while not rsTemp.EOF dctTemp.Add rsTemp(strKey) & "", rsTemp(strItem) & "" rsTemp.MoveNext loop set BuildDict = dctTemp end function ' -------------- ArrayRadioButtons ------------------ ' Builds Radion Buttons from an Array. This is dependant on the ASP Style Sheet function "stlText" Sub ArrayRadioButtons(InputName, InputRS, InputArray) Dim InputKeys, InputValues, i InputKeys = InputArray.Keys InputValues = InputArray.Items For i = 0 To InputArray.Count - 1 Response.Write "" Response.Write "" stlText InputValues(i) Response.Write "" Next End Sub function iif(tfCondition, varTrue, varFalse) ' if tfCondition is true, will return varTrue, else varFalse ' beware: both expressions are evaluated, do not use anything ' that has side-effects if tfCondition = true then iif = varTrue else iif = varFalse end if end function Sub SetFieldFocus(strFormName, strFieldName) %> <% End Sub function SaveDataRecord(strTable, rsInput, ByVal intRecID, dctSaveList) ' dctSaveList contains a list of key,item pairs ' key = field name in table ' item = new value ' the key may be prefixed with one or more of the following: ' (note: if more than one prefix, they must be in the order shown here) ' - = do not include ' * = only include if inserting a new record ' & = only include if updating an existing record ' $ = don't use NULL values, use default single space for varchars or 0 for numeric ' ! = use the value of rsInput(item) (or rsInput(key) if item is "" ' (note: the following are mutually exclusive and may not be used together...) ' % = the value is a date/time value ' @ = the value is a function - do not quote or otherwise encode the value ' # = the field is numeric - do not quote, but verify the field is numeric dim sql, n, x, c, i, k, s, strField, strValue, strFormat, tfUseInput, tfForceValue x = dctSaveList.count - 1 i = dctSaveList.items k = dctSaveList.keys for c = 0 to x strField = k(c) strValue = i(c) if left(strField,1) = "*" then ' "insert-only" field if intRecID <> 0 then k(c) = "-" & strField strField = "" else strField = mid(strField,2) end if end if if left(strField,1) = "&" then ' "update-only" field if intRecID = 0 then k(c) = "-" & strField strField = "" else strField = mid(strField,2) end if end if if strField <> "" then if left(strField,1) = "$" then ' force a value tfForceValue = true strField = mid(strField,2) else tfForceValue = false end if if left(strField,1) = "!" then ' use value from rsInput tfUseInput = true strField = mid(strField,2) else tfUseInput = false end if strFormat = "" if left(strField,1) = "#" then ' numeric field strFormat = "#" strField = mid(strField,2) end if if left(strField,1) = "@" then ' function field strFormat = "@" strField = mid(strField,2) end if if left(strField,1) = "%" then ' date/time field strFormat = "%" strField = mid(strField,2) end if if tfUseInput then if strValue = "" then strValue = strField end if if IsNull(rsInput(strValue)) then strValue = "" else strValue = rsInput(strValue) end if end if if strValue = "" then if tfForceValue then select case strFormat case "#": strValue = "0" case "%": strValue = "GETDATE()" case else: strValue = "' '" end select else strValue = "NULL" end if else ' format the value correctly select case strFormat case "#": if IsNumeric(strValue) then ' filter out $, %, commas strValue = strValue else ' illegal value if tfForceValue then strValue = "0" else strValue = "NULL" end if end if case "%": if IsDate(strValue) then strValue = CDate(strValue) strValue = "'" & Month(strValue) & "/" & Day(strValue) & "/" & Year(strValue) & " " & Hour(strValue) & ":" & Minute(strValue) & ":" & Second(strValue) & "'" else ' illegal value if tfForceValue then strValue = "GETDATE()" else strValue = "NULL" end if end if case "@": 'strValue = strValue case else: strValue = "'" & SQLEncode(strValue) & "'" end select end if k(c) = strField i(c) = strValue end if next if intRecID = 0 then ' insert a new record sql = "INSERT INTO " & strTable & "(" n = 0 for c = 0 to x if left(k(c),1) <> "-" then if n > 0 then sql = sql & "," end if sql = sql & k(c) n = n + 1 end if next sql = sql & ") VALUES (" n = 0 for c = 0 to x if left(k(c),1) <> "-" then if n > 0 then sql = sql & "," end if sql = sql & i(c) n = n + 1 end if next sql = sql & ")" gobjConn.execute(sql) dim rsTemp set rsTemp = gobjConn.execute("SELECT MAX(intID) AS intID FROM " & strTable) intRecID = rsTemp("intID") set rsTemp = nothing else ' update an existing record sql = "UPDATE " & strTable & " SET " n = 0 for c = 0 to x if left(k(c),1) <> "-" then if n > 0 then sql = sql & "," end if sql = sql & k(c) & "=" & i(c) n = n + 1 end if next sql = sql & " WHERE intID=" & intRecID gobjConn.execute(sql) end if SaveDataRecord = intRecID end function function SafeFormatCurrency(strBadValue, varValue, intDecimalPlaces) if IsNumeric(varValue) then SafeFormatCurrency = FormatCurrency(varValue, intDecimalPlaces) else SafeFormatCurrency = strBadValue end if end function function SafeFormatNumber(strBadValue, varValue, intDecimalPlaces) if IsNumeric(varValue) then SafeFormatNumber = FormatNumber(varValue, intDecimalPlaces) else SafeFormatNumber = strBadValue end if end function function GetStatusStr(chrStatus, tfUseColor) dim s, strColor select case chrStatus case "A": s = "Active": strColor = "#000000" case "I": s = "Inactive": strColor = "#FF0000" case "P": s = "Pending": strColor = "#FF0000" case else: s = "?? " & chrStatus & " ??": strColor = "#FF0000" end select if tfUseColor then s = "" & s & "" end if GetStatusStr = s end function function TrimLeftPadd(byVal strValue, intDesiredLength, chrPadd) dim x strValue = trim(strValue) x = len(strValue) if x < intDesiredLength then strValue = string(intDesiredLength - x, chrPadd) & strValue end if TrimLeftPadd = strValue end function function TrimRightPadd(byVal strValue, intDesiredLength, chrPadd) dim x strValue = trim(strValue) x = len(strValue) if x < intDesiredLength then strValue = strValue & string(intDesiredLength - x, chrPadd) end if TrimRightPadd = strValue end function function FormatDateTimeNoSeconds(dtmDate) ' formats the date: MM/DD/YYYY HH:MM XM dim s, intHour s = Month(dtmDate) & "/" & Day(dtmDate) & "/" & right(Year(dtmDate),2) & " " intHour = Hour(dtmDate) if intHour = 0 then s = s & "12" else s = s & intHour end if s = s & ":" & Minute(dtmDate) if intHour > 11 then s = s & " PM" else s = s & " AM" end if FormatDateTimeNoSeconds = s end function Sub SendMail(fromName,toName,ccName,bccName,subject,bodyText) dim awscopy ' awscopy = "mred@americanwebservices.com" ' if IsValid(bccName) then ' if bccName <> awscopy then ' bccName = bccName & "," & awscopy ' end if ' else ' bccName = awscopy ' end if dim m set m = CreateObject("CDONTS.NewMail") m.From = fromName m.To = toName m.CC = ccName m.bcc = bccName m.Subject = subject m.Body = bodyText m.Importance = 1 m.Send() Set m = Nothing End Sub sub SendHTMLMail(fromName,toName,ccName,bccName,subject,bodyText) dim awscopy ' awscopy = "mred@americanwebservices.com" ' if IsValid(bccName) then ' if bccName <> awscopy then ' bccName = bccName & "," & awscopy ' end if ' else ' bccName = awscopy ' end if dim m set m = CreateObject("CDONTS.NewMail") m.From = fromName m.To = toName m.CC = ccName m.bcc = bccName m.Subject = subject m.MailFormat = 0 m.BodyFormat = 0 m.Body = bodyText m.Importance = 1 m.Send() Set m = Nothing end sub sub OpenConn() if not gblnConnOpen then set gobjConn = Server.CreateObject("ADODB.Connection") gobjConn.Open gstrConnectString gblnConnOpen = true end if end sub sub CloseConn() if gblnConnOpen and IsObject(gobjConn) then gobjConn.Close set gobjConn = nothing gblnConnOpen = false end if end sub sub ConnExecute(strSQL) OpenConn gobjConn.execute(strSQL) end sub function ConnOpenRS(strSQL) OpenConn set ConnOpenRS = gobjConn.execute(strSQL) end function %>