<%
SetLocale(1033)
Dim vbCrLf
vbCrLf = Chr(13) & Chr(10)
' Constants for I/O
Const ForReading = 1
Const ForWriting = 2
Const ForAppending = 8
' VarType constants
'Const vbEmpty = 0
'Const vbNull = 1
'Const vbInteger = 2
'Const vbLong = 3
'Const vbSingle = 4
'Const vbDouble = 5
'Const vbCurrency = 6
'Const vbDate = 7
'Const vbString = 8
'Const vbObject = 9
'Const vbError = 10
'Const vbBoolean = 11
'Const vbVariant = 12
'Const vbDataObject = 13
'Const vbByte = 17
'Const vbArray = 8192
'Const vbBinaryCompare = 0
'Const vbTextCompare = 1
' Constants for ADO
Const adOpenUnspecified = -1
Const adOpenForwardOnly = 0
Const adOpenKeyset = 1
Const adOpenDynamic = 2
Const adOpenStatic = 3
Const adLockUnspecified = -1
Const adLockReadOnly = 1
Const adLockPessimistic = 2
Const adLockOptimistic = 3
Const adLockBatchOptimistic = 4
' Constants for XML
Const NODE_ELEMENT = 1
Const NODE_ATTRIBUTE = 2
Const NODE_TEXT = 3
Const NODE_CDATA_SECTION = 4
Const NODE_ENTITY_REFERENCE = 5
Const NODE_ENTITY = 6
Const NODE_PROCESSING_INSTRUCTION = 7
Const NODE_COMMENT = 8
Const NODE_DOCUMENT = 9
Const NODE_DOCUMENT_TYPE = 10
Const NODE_DOCUMENT_FRAGMENT = 11
Const NODE_NOTATION = 12
' ------------------------------------------------------------------
' General functions
' ------------------------------------------------------------------
Public Function SafeUBound(array)
SafeUBound = -1
On Error Resume Next
SafeUBound = UBound(array)
On Error GoTo 0
End Function
Public Function Iff(condition, valuetrue, valuefalse)
If condition Then
Iff = valuetrue
Else
Iff = valuefalse
End If
End Function
Public Function ApplyDefault(value, default)
If IsNull(value) Then
ApplyDefault = default
Else
ApplyDefault = value
End If
End Function
Public Function ZeroPad(number, length)
ZeroPad = "" & number
If Len(ZeroPad) < length Then
ZeroPad = String(length - Len(ZeroPad), "0") & ZeroPad
End If
End Function
' ------------------------------------------------------------------
' String helpers
' ------------------------------------------------------------------
Function SpanExcluding(str, exclude)
Dim I
For I = 1 To Len(str)
If Instr(exclude, Mid(str, I, 1)) Then Exit For
Next
SpanExcluding = Left(str, I - 1)
End Function
Function IsEmptyString(str)
IsEmptyString = IsNull(str) Or IsEmpty(str) Or (str = "")
End Function
Function Equal(v1, v2)
If IsNull(v1) And IsNull(v2) Then
Equal = True
ElseIf IsNull(v1) Or IsNull(v2) Then
Equal = False
ElseIf IsEmpty(v1) And IsEmpty(v2) Then
Equal = True
ElseIf IsEmpty(v1) Or IsEmpty(v2) Then
Equal = False
Else
Equal = (v2 = v1)
End If
End Function
Function LTrimEx(text, t)
Dim I
For I = 1 To Len(text)
If InStr(t, Mid(text, I, 1)) = 0 Then Exit For
Next
LTrimEx = Mid(text, I)
End Function
Function RTrimEx(str, t)
Dim I
For I = Len(str) To 1 Step -1
If InStr(t, Mid(str, I, 1)) = 0 Then Exit For
Next
RTrimEx = Left(str, I)
End Function
Function TrimEx(str, t)
TrimEx = LtrimEx(RTrimEx(str, t), t)
End Function
' ------------------------------------------------------------------
' Array helpers
' ------------------------------------------------------------------
Public Function SafeUBound(array)
SafeUBound = -1
On Error Resume Next
SafeUBound = UBound(array)
On Error GoTo 0
End Function
Public Sub ArrayAppend(ByRef array, element)
If SafeUBound(array) = -1 Then
Redim array(0)
Else
Redim Preserve array(UBound(array) + 1)
End If
array(UBound(array)) = element
End Sub
Public Sub ArrayAppendObject(ByRef array, ByRef element)
If SafeUBound(array) = -1 Then
Redim array(0)
Else
Redim Preserve array(UBound(array) + 1)
End If
Set array(UBound(array)) = element
End Sub
Public Sub RemoveAt(ByRef array, index)
Dim I
For I = index To SafeUBound(array) - 1
'Response.Write "Shift: " & array(I) & " <- " & array(I + 1)
array(I) = array(I + 1)
Next
If SafeUBound(array) > 0 Then
'Response.Write "Redim Preserve" & index & " " & SafeUBound(array) & " "
Redim Preserve array(SafeUBound(array) - 1)
'Response.Write "New dim:" & SafeUBound(array) & " "
Else
Erase array
End If
End Sub
Public Sub SetAtGrow(ByRef array, index, element)
If SafeUBound(array) < index Then RedimPreserve array, index
array(index) = element
End Sub
Public Sub SetAtGrowObject(ByRef array, index, ByRef element)
If SafeUBound(array) < index Then RedimPreserve array, index
Set array(index) = element
End Sub
Public Sub RedimPreserve(ByRef array, index)
If SafeUBound(array) > 0 Then
Redim Preserve array(index)
Else
Redim array(index)
End If
End Sub
' ------------------------------------------------------------------
' Type conversion
' ------------------------------------------------------------------
Public Function SafeCBool(value)
'Response.Write "Bool: " & value & "|"
If value <> "" Then
SafeCBool = CBool(value)
Else
SafeCBool = False
End If
End Function
Public Function SafeCInt(value)
If IsNumeric(value) Then
SafeCInt = CInt(value)
Else
SafeCInt = 0
End If
End Function
Public Function SafeCLng(value)
On Error Resume Next
SafeCLng = 0
SafeCLng = CLng(value)
On Error Goto 0
End Function
Public Function SafeCDouble(value)
If IsNumeric(value) Then
SafeCDouble = CDbl(value)
Else
SafeCDouble = 0
End If
'SafeCDouble = value
End Function
Public Function SafeCDate(value)
On Error Resume Next
SafeCDate = Null
SafeCDate = CDate(value)
On Error Goto 0
End Function
' ------------------------------------------------------------------
' Date/time functions
' ------------------------------------------------------------------
Public Function IsoDate(value)
If IsDate(value) Then
IsoDate = ZeroPad(Year(value), 4) & "-" & ZeroPad(Month(value), 2) & "-" & ZeroPad(Day(value), 2)
Else
IsoDate = Null
End If
End Function
Public Function IsoTime(value)
If IsDate(value) Then
IsoTime = ZeroPad(Hour(value), 2) & ":" & ZeroPad(Minute(value), 2) & ":" & ZeroPad(Second(value), 2)
Else
IsoTime = Null
End If
End Function
Public Function IsoDateTime(value)
If IsDate(value) Then
IsoDateTime = IsoDate(value) & " " & IsoTime(value)
Else
IsoDateTime = Null
End If
End Function
Public Function MonthName(month)
Select Case month
Case 1:
MonthName = "January"
Case 2:
MonthName = "February"
Case 3:
MonthName = "March"
Case 4:
MonthName = "April"
Case 5:
MonthName = "May"
Case 6:
MonthName = "June"
Case 7:
MonthName = "July"
Case 8:
MonthName = "August"
Case 9:
MonthName = "September"
Case 10:
MonthName = "October"
Case 11:
MonthName = "November"
Case 12:
MonthName = "December"
End Select
End Function
Public Function NiceDate(value)
If IsDate(value) Then
NiceDate = MonthName(Month(value))
NiceDate = NiceDate & " " & Day(value)
If Day(value) Mod 100 <= 13 Then
Select Case Day(value) Mod 100
Case 1:
NiceDate = NiceDate & "st"
Case 2:
NiceDate = NiceDate & "nd"
Case 3:
NiceDate = NiceDate & "rd"
Case Else
NiceDate = NiceDate & "th"
End Select
Else
Select Case Day(value) Mod 10
Case 1:
NiceDate = NiceDate & "st"
Case 2:
NiceDate = NiceDate & "nd"
Case 3:
NiceDate = NiceDate & "rd"
Case Else
NiceDate = NiceDate & "th"
End Select
End If
If Year(value) <> Year(Now) Then NiceDate = NiceDate & ", " & Year(value)
End If
End Function
Public Function NiceTime(value)
If IsDate(value) Then
NiceTime = ZeroPad(Hour(value), 2) & ":" & ZeroPad(Minute(value), 2)
If DateDiff("d", value, Now) <> 0 Then
NiceTime = NiceTime & ", " & NiceDate(value)
Else
NiceTime = NiceTime & ":" & ZeroPad(Second(value), 2)
End If
End If
End Function
' ------------------------------------------------------------------
' Randomization functions
' ------------------------------------------------------------------
Public Function Random(lowerbound, upperbound)
Random = Int((upperbound - lowerbound + 1) * Rnd + lowerbound)
End Function
Public Function RandomChar(chars)
RandomChar = Mid(chars, Random(1, Len(chars)), 1)
End Function
Public Function GeneratePassword(length)
Dim Chars(2)
Dim UseChar
Chars(0) = "bcdfghjklmpqrstvwxz"
Chars(1) = "aeiouy"
Chars(2) = "0123456789"
Randomize
UseChar = 0
Do Until Len(GeneratePassword) >= length
GeneratePassword = GeneratePassword & RandomChar(Chars(UseChar))
If UseChar = 0 Then
If Rnd < 0.7 Then UseChar = 1 Else UseChar = 2
ElseIf UseChar = 1 Then
If Rnd < 0.7 Then UseChar = 0 Else UseChar = 2
Else
UseChar = 0
End If
Loop
End Function
' ------------------------------------------------------------------
' Communication functions
' ------------------------------------------------------------------
Public Function SendMail(FromName, FromMail, ToName, ToMail, Subject, Text)
Set myMail = Server.CreateObject("CDONTS.NewMail")
myMail.From = FromName & "<" & FromMail & ">"
myMail.To = ToMail
myMail.Subject = Subject
myMail.Body = Text
SendMail = myMail.Send
Set myMail = Nothing
End Function
' ------------------------------------------------------------------
' HTTP functions
' ------------------------------------------------------------------
Function UrlDecode(ByVal Text)
Dim F, Result, I
Text = Replace(Text, "+", " ")
Result = ""
Do Until Text = ""
F = Instr(Text, "%")
If F = 0 Then
Result = Result & Text
Text = ""
Else
Result = Result & Left(Text, F - 1) & Chr(CInt("&h" & Mid(Text, F + 1, 2)))
Text = Mid(Text, F + 3)
End If
Loop
UrlDecode = Result
End Function
Function ThisPage()
ThisPage = Request.ServerVariables("SCRIPT_NAME")
If Len(Request.ServerVariables("QUERY_STRING")) > 0 Then
ThisPage = ThisPage & "?" & Request.ServerVariables("QUERY_STRING")
End If
End Function
Function ThisPageParam()
ThisPageParam = Request.ServerVariables("SCRIPT_NAME") & "?"
If Len(Request.ServerVariables("QUERY_STRING")) > 0 Then
ThisPageParam = ThisPageParam & Request.ServerVariables("QUERY_STRING") & "&"
End If
End Function
Function FilterQueryString(url, filter)
Dim Tmp, BaseUrl, Query, FilterItems, I, J
Tmp = Split(url, "?", 2, vbBinaryCompare)
If SafeUBound(Tmp) > 0 Then Query = Tmp(1) Else Query = Empty
BaseUrl = Tmp(0)
Query = Split(Query, "&", -1, vbBinaryCompare)
FilterItems = Split(filter, "&", -1, vbBinaryCompare)
For I = 0 To SafeUBound(FilterItems)
For J = SafeUBound(Query) To 0 Step -1
If Left(Query(J), Len(FilterItems(I)) + 1) = FilterItems(I) & "=" Then
RemoveAt Query, J
End If
Next
Next
If SafeUBound(Query) >= 0 Then
BaseUrl = BaseUrl & "?"
For J = 0 To SafeUBound(Query)
BaseUrl = BaseUrl & Query(J) & "&"
Next
End If
FilterQueryString = RTrimEx(BaseUrl, "&")
End Function
Function AppendQueryString(url, addendum)
If InStr(url, "?") > 0 Then
AppendQueryString = url & "&" & addendum
Else
AppendQueryString = url & "?" & addendum
End if
End Function
' ------------------------------------------------------------------
' HTML functions
' ------------------------------------------------------------------
Dim HtmlIndent
Function Indent(count)
Indent = String(count, Chr(9))
End Function
Sub IndentInc()
HtmlIndent = HtmlIndent + 1
End Sub
Sub IndentDec()
HtmlIndent = HtmlIndent - 1
End Sub
Sub Out(text)
Response.Write Indent(HtmlIndent) & text & vbCrLf
End Sub
Sub OutInc(text)
Response.Write Indent(HtmlIndent) & text & vbCrLf
IndentInc()
End Sub
Sub OutDec(text)
IndentDec()
Response.Write Indent(HtmlIndent) & text & vbCrLf
End Sub
Function FixUrlReference(Url)
If LCase(Left(Url, 4)) = "www." Then
Url = "http://" & Url
ElseIf LCase(Left(Url, 4)) = "ftp." Then
Url = "ftp://" & Url
End If
FixUrlReference = Url
End Function
' ------------------------------------------------------------------
' XML functions
' ------------------------------------------------------------------
Function GetAttributeValue(Node, Attribute)
If Node.attributes.getNamedItem(Attribute) Is Nothing Then
GetAttributeValue = Null
Else
GetAttributeValue = Node.attributes.getNamedItem(Attribute).Value
End If
End Function
' ------------------------------------------------------------------
' SQL functions
' ------------------------------------------------------------------
Function ConnectDatabase()
Dim Conn
Set Conn = Server.CreateObject("ADODB.Connection")
With Conn
.ConnectionString = DatabaseConnectStr
.ConnectionTimeout = 10
.Open
End With
Set ConnectDatabase = Conn
End Function
Function SafeSqlString(text)
SafeSqlString = "'" & Replace(text, "'", "''") & "'"
End Function
Function SafeSqlBool(value)
If IsEmptyString(value) Or value = False Then
SafeSqlBool = 0
Else
SafeSqlBool = 1
End If
End Function
Function SqlNullBool(value)
If IsEmptyString(value) Then
SqlNullBool = "NULL"
Else
SqlNullBool = SafeSqlBool(value)
End If
End Function
Function SqlNullString(text)
If IsEmptyString(text) Then
SqlNullString = "NULL"
Else
SqlNullString = SafeSqlString(text)
End If
End Function
Function SafeSqlNumber(text)
'SafeSqlNumber = Replace(SafeCDouble(text), ",", ".")
SafeSqlNumber = SafeCDouble(text)
End Function
Function SqlNullNumber(text)
If IsEmptyString(text) Then
SqlNullNumber = "NULL"
Else
SqlNullNumber = SafeSqlNumber(text)
End If
End Function
Function SafeSqlDate(value)
If VarType(value) = vbDate Then
SafeSqlDate = "'" & IsoDateTime(value) & "'"
End If
End Function
Function SqlNullDate(value)
If VarType(value) = vbDate Then
SqlNullDate = "'" & IsoDateTime(value) & "'"
Else
SqlNullDate = "NULL"
End If
End Function
Function SqlVar(value)
Select Case VarType(value)
Case vbEmpty, vbNull:
SqlVar = "NULL"
Case vbByte, vbInteger, vbLong, vbSingle, vbDouble, vbCurrency:
SqlVar = value
Case vbDate:
SqlVar = SafeSqlString(IsoDate(value) & " " & IsoTime(value))
Case vbString:
SqlVar = SafeSqlString(value)
Case vbBoolean:
If value = True Then
SqlVar = "1"
Else
SqlVar = "0"
End If
Case Else:
Response.Write "Invalid type (" & VarType(value) & "): " & value
Err.Raise 13
End Select
End Function
Function Null2Empty(ByVal value)
If IsNull(value) Then
Null2Empty = Empty
Else
Null2Empty = value
End If
End Function
' ------------------------------------------------------------------
' Math helpers
' ------------------------------------------------------------------
Function Min(a, b)
If a < b Then Min = a Else Min = b
End Function
Function Max(a, b)
If a > b Then Max = a Else Max = b
End Function
' ------------------------------------------------------------------
' Other
' ------------------------------------------------------------------
Sub Assign(ByRef Target, ByRef Value)
If IsObject(Value) Then
Set Target = Value
Else
Target = Value
End If
End Sub
Class clsOptionItem
Dim m_Value
Dim m_Text
Public Property Get Value()
If IsEmpty(m_Value) Or IsNull(m_Value) Then
Value = m_Text
Else
Value = m_Value
End If
End Property
Sub Output(selection)
Dim selected
If ("" & selection) = ("" & Value) Then selected = " selected"
Out "