<% Function QuoteValue(val) if IsWrappedInSingleQuotes(val) then QuoteValue = val Exit Function end if Select Case VarType(val) Case vbString QuoteValue = "'" & Replace(val, "'", "''") & "'" Case vbDate if conn.Provider = "Microsoft.Jet.OLEDB.4.0" or conn.Provider = "Microsoft.ACE.OLEDB.12.0" then QuoteValue = "#" & FormatDateTime(val, 0) & "#" else ' SQL Server QuoteValue = "'" & FormatDateTime(val, 0) & "'" end if Case vbNull, vbEmpty QuoteValue = "Null" Case vbBoolean ' Return boolean values without quotes QuoteValue = "'" & CStr(val) & "'" Case Else If IsNumeric(val) Then QuoteValue = CLng(val) Else QuoteValue = CStr(val) End If End Select End Function Public Function GetAppSetting(key) Dim cacheKey, xml, nodes, node, i cacheKey = "AppSetting_" & key ' Check Application cache first for performance If Not IsEmpty(Application(cacheKey)) Then GetAppSetting = Application(cacheKey) Exit Function End If ' Load from web.config only if not cached Set xml = Server.CreateObject("Microsoft.XMLDOM") xml.Load(Server.MapPath("web.config")) Set nodes = xml.selectNodes("//appSettings/add") For i = 0 To nodes.Length - 1 Set node = nodes.Item(i) If node.getAttribute("key") = key Then GetAppSetting = node.getAttribute("value") ' Cache the value for subsequent requests Application.Lock Application(cacheKey) = GetAppSetting Application.Unlock Exit Function End If Next GetAppSetting = "nothing" End Function Public Sub ShowServerVariables Dim varName, htmlTable htmlTable = "" htmlTable = htmlTable & "" ' Loop through all server variables For Each varName In Request.ServerVariables htmlTable = htmlTable & "" htmlTable = htmlTable & "" htmlTable = htmlTable & "" htmlTable = htmlTable & "" Next htmlTable = htmlTable & "
Variable NameValue
" & Server.HTMLEncode(varName) & "" & Server.HTMLEncode(Request.ServerVariables(varName)) & "
" ' Output the HTML table Response.Write(htmlTable) End Sub '------------------------------------------------------------------------------ ' Utility: IIf Function for VBScript ' Usage: result = IIf(condition, trueValue, falseValue) '------------------------------------------------------------------------------ Function IIf(condition, trueValue, falseValue) On Error Resume Next If CBool(condition) Then IIf = trueValue Else IIf = falseValue End If If Err.Number <> 0 Then ' Optional: handle or log error in conversion/evaluation Err.Clear End If On Error GoTo 0 End Function '----------------------------- ' Utility: Generic Error Reporter '----------------------------- Public Sub ErrorCheck(context) If Err.Number <> 0 Then Dim errHtml errHtml = "
" errHtml = errHtml & "Error occurred" & IIf(Not IsEmpty(context) And context <> "", ": " & context, "") & "
" errHtml = errHtml & "Time: " & Now() & "
" errHtml = errHtml & "Number: " & Err.Number & "
" errHtml = errHtml & "Description: " & Server.HTMLEncode(Err.Description) & "
" If Len(Err.Source) > 0 Then errHtml = errHtml & "Source: " & Server.HTMLEncode(Err.Source) & "
" End If errHtml = errHtml & "
" Response.Write errHtml Err.Clear End If End Sub '------------------------------------------------------------------------------ ' Utility: TrimQueryParams ' Removes everything from the first "?" or "&" onward. ' Usage: ' CleanPath = TrimQueryParams(rawPath) '------------------------------------------------------------------------------ Function TrimQueryParams(rawPath) Dim posQ, posA, cutPos ' find the first occurrences of "?" and "&" posQ = InStr(rawPath, "?") posA = InStr(rawPath, "&") ' determine the earliest cut position (>0) If posQ > 0 And posA > 0 Then cutPos = IIf(posQ < posA, posQ, posA) ElseIf posQ > 0 Then cutPos = posQ ElseIf posA > 0 Then cutPos = posA Else cutPos = 0 End If ' if found, return up to just before that char If cutPos > 0 Then TrimQueryParams = Left(rawPath, cutPos - 1) Else TrimQueryParams = rawPath End If End Function Sub Destroy(o) if isobject(o) then if not o is nothing then on error resume next o.close on error goto 0 set o = nothing end if end if End Sub 'prepends indents Private Sub puti(v) put Spaces(m_indent) & v End Sub Sub put(v) Select Case typename(v) Case "LinkedList_Class" : response.write join(v.TO_Array, ", ") Case "DynamicArray_Class" : response.write JoinList(v) Case "Variant()" : response.write join(v, ", ") Case else : response.write v End Select End Sub Sub put_ put "
" End Sub Sub putl(v) put v put_ End Sub '--------------------------------------------------------------------------------------------------------------------- 'Wrapper for Server.HTMLEncode() -- makes it easier on the eyes when reading the HTML code Function H(s) If Not IsEmpty(s) and Not IsNull(s) then H = Server.HTMLEncode(s) Else H = "" End If End Function '======================================================================================================================= ' Adapted from Tolerable library '======================================================================================================================= ' This subroutine allows us to ignore the difference ' between object and primitive assignments. This is ' essential for many parts of the engine. Public Sub Assign(ByRef var, ByVal val) If IsObject(val) Then Set var = val Else var = val End If End Sub ' This is similar to the ? : operator of other languages. ' Unfortunately, both the if_true and if_false "branches" ' will be evalauted before the condition is even checked. So, ' you'll only want to use this for simple expressions. Public Function Choice(ByVal cond, ByVal if_true, ByVal if_false) If cond Then Assign Choice, if_true Else Assign Choice, if_false End If End Function ' Allows single-quotes to be used in place of double-quotes. ' Basically, this is a cheap trick that can make it easier ' to specify Lambdas. Public Function Q(ByVal input) Q = Replace(input, "'", """") End Function Function SurroundString(inputVar) If VarType(inputVar) = vbString Then SurroundString = """" & inputVar & """" Else SurroundString = inputVar End If End Function Function SurroundStringInArray(arr) Dim i For i = LBound(arr) To UBound(arr) If IsString(arr(i)) Then arr(i) = """" & arr(i) & """" End If Next SurroundStringInArray = arr End Function '----------------------------------------------------------------------------------------------------------------------- 'Boolean type checkers 'Don't forget IsArray is built-in! Function IsString(value) IsString = Choice(typename(value) = "String", true, false) End Function Function IsDict(value) IsDict = Choice(typename(value) = "Dictionary", true, false) End Function Function IsRecordset(value) IsRecordset = Choice(typename(value) = "Recordset", true, false) End Function Function IsLinkedList(value) IsLinkedList = Choice(typename(value) = "LinkedList_Class", true, false) End Function Function IsArray(value) IsArray = Choice(typename(value) = "Variant()", true, false) End Function '-------------------------------------------------------------------- ' Returns True when the named key is present in Session.Contents ' • Handles scalars (String, Integer, etc.), objects, Empty, and Null '-------------------------------------------------------------------- Function SessionHasKey(keyName) 'Loop over the existing keys—Session.Contents is like a dictionary Dim k For Each k In Session.Contents If StrComp(k, keyName, vbTextCompare) = 0 Then SessionHasKey = True Exit Function End If Next SessionHasKey = False 'not found End Function Function RenderObjectsAsTable(arr,boolUseTabulator) Dim html, propNames, i, j, obj, val, pkName, isPk If IsEmpty(arr) Or Not IsArray(arr) Then RenderObjectsAsTable = "" Exit Function End If Set obj = arr(0) On Error Resume Next propNames = obj.Properties pkName = obj.PrimaryKey On Error GoTo 0 If IsEmpty(propNames) Or Len(pkName) = 0 Then RenderObjectsAsTable = "" Exit Function End If html = "
" & vbCrLf html = html & "" & vbCrLf html = html & " " & vbCrLf For i = 0 To UBound(propNames) html = html & " " & vbCrLf Next html = html & " " & vbCrLf html = html & " " & vbCrLf For j = 0 To UBound(arr) Set obj = arr(j) html = html & " " & vbCrLf For i = 0 To UBound(propNames) val = GetDynamicProperty(obj, propNames(i)) isPk = (StrComp(propNames(i), pkName, vbTextCompare) = 0) If IsNull(val) Or IsEmpty(val) Then val = " " ElseIf IsDate(val) Then val = FormatDateTime(val, vbShortDate) ElseIf VarType(val) = vbBoolean Then val = IIf(val, "True", "False") Else val = CStr(val) Dim maxLen : maxLen = CInt(GetAppSetting("TableCellMaxLength")) If maxLen <= 0 Then maxLen = 90 If Len(val) > maxLen Then val = Left(val, maxLen - 3) & "..." End If val = Server.HTMLEncode(val) End If If isPk and boolUseTabulator = False Then val = "" & val & "" End If html = html & " " & vbCrLf Next html = html & " " & vbCrLf Next html = html & " " & vbCrLf & "
" & Server.HTMLEncode(propNames(i)) & "
" & val & "
" & vbCrLf & "
" RenderObjectsAsTable = html End Function Function RenderFormFromObject(obj) Dim html, propNames, i, name, val, inputType Dim pkName, tableName, checkedAttr On Error Resume Next propNames = obj.Properties pkName = obj.PrimaryKey tableName = obj.TableName On Error GoTo 0 If IsEmpty(propNames) Or Len(pkName) = 0 Then RenderFormFromObject = "" Exit Function End If html = "
" & vbCrLf For i = 0 To UBound(propNames) name = propNames(i) val = GetDynamicProperty(obj, name) ' Handle nulls If IsNull(val) Then val = "" ' Primary key → hidden input If StrComp(name, pkName, vbTextCompare) = 0 Then html = html & " " & vbCrLf 'Continue For End If html = html & "
" & vbCrLf html = html & " " & vbCrLf Select Case True Case VarType(val) = vbBoolean checkedAttr = "" If val = True Then checkedAttr = " checked" html = html & " " & vbCrLf Case IsDate(val) html = html & " " & vbCrLf Case IsNumeric(val) html = html & " " & vbCrLf Case Len(val) > CInt(GetAppSetting("FormTextareaThreshold")) html = html & " " & vbCrLf Case Else html = html & " " & vbCrLf End Select html = html & "
" & vbCrLf Next html = html & " " & vbCrLf html = html & "
" & vbCrLf RenderFormFromObject = html End Function Function GetDynamicProperty(obj, propName) On Error Resume Next Dim result Execute "result = obj." & propName If Err.Number <> 0 Then result = "" Err.Clear End If GetDynamicProperty = result On Error GoTo 0 End Function Function FormatDateForInput(val) If IsDate(val) Then Dim yyyy, mm, dd yyyy = Year(val) mm = Right("0" & Month(val), 2) dd = Right("0" & Day(val), 2) FormatDateForInput = yyyy & "-" & mm & "-" & dd Else FormatDateForInput = "" End If End Function '------------------------------------------------------------- ' Returns obj. for any public VBScript class property '------------------------------------------------------------- Function GetObjProp(o, pName) Dim tmp ' Build a tiny statement like: tmp = o.UserID Execute "tmp = o." & pName GetObjProp = tmp End Function Function GenerateSlug(title) Dim slug slug = LCase(title) ' Convert to lowercase slug = Replace(slug, "&", "and") ' Replace ampersands slug = Replace(slug, "'", "") ' Remove apostrophes slug = Replace(slug, """", "") ' Remove quotes slug = Replace(slug, "–", "-") ' Replace en dash slug = Replace(slug, "—", "-") ' Replace em dash slug = Replace(slug, "/", "-") ' Replace slashes slug = Replace(slug, "\", "-") ' Replace backslashes ' Remove all non-alphanumeric and non-hyphen/space characters Dim i, ch, clean clean = "" For i = 1 To Len(slug) ch = Mid(slug, i, 1) If (ch >= "a" And ch <= "z") Or (ch >= "0" And ch <= "9") Or ch = " " Or ch = "-" Then clean = clean & ch End If Next ' Replace multiple spaces or hyphens with single hyphen Do While InStr(clean, " ") > 0 clean = Replace(clean, " ", " ") Loop clean = Replace(clean, " ", "-") Do While InStr(clean, "--") > 0 clean = Replace(clean, "--", "-") Loop ' Trim leading/trailing hyphens Do While Left(clean, 1) = "-" clean = Mid(clean, 2) Loop Do While Right(clean, 1) = "-" clean = Left(clean, Len(clean) - 1) Loop GenerateSlug = clean End Function Function GetRawJsonFromRequest() Dim stream, rawJson Set stream = Server.CreateObject("ADODB.Stream") stream.Type = 1 ' adTypeBinary stream.Open stream.Write Request.BinaryRead(Request.TotalBytes) stream.Position = 0 stream.Type = 2 ' adTypeText stream.Charset = "utf-8" rawJson = stream.ReadText stream.Close Set stream = Nothing GetRawJsonFromRequest = rawJson End Function Function Active(controllerName) On Error Resume Next If Replace(Lcase(router.Resolve(Request.ServerVariables("REQUEST_METHOD"), TrimQueryParams(Request.ServerVariables("HTTP_X_ORIGINAL_URL")))(0)),"controller","") = LCase(controllerName) Then Active = "active" Else Active = "" End If On Error GoTo 0 End Function '==================================================================== ' FormatDateForSql ' Converts a VBScript Date to a SQL Server-compatible string ' Output: 'YYYY-MM-DD HH:MM:SS' '==================================================================== Function FormatDateForSql(vbDate) If IsNull(vbDate) Or vbDate = "" Then FormatDateForSql = "NULL" Exit Function End If ' Ensure vbDate is a valid date If Not IsDate(vbDate) Then Err.Raise vbObjectError + 1000, "FormatDateForSql", "Invalid date: " & vbDate End If Dim yyyy, mm, dd, hh, nn, ss yyyy = Year(vbDate) mm = Right("0" & Month(vbDate), 2) dd = Right("0" & Day(vbDate), 2) hh = Right("0" & Hour(vbDate), 2) nn = Right("0" & Minute(vbDate), 2) ss = Right("0" & Second(vbDate), 2) ' Construct SQL Server datetime literal FormatDateForSql = "'" & yyyy & "-" & mm & "-" & dd & " " & hh & ":" & nn & ":" & ss & "'" End Function %>