'--------------------------------------------------------------------------------------------------
' Last Updated: 05/11/2005
'--------------------------------------------------------------------------------------------------
' These scripts retrieved from the Ohman Automation Corp. website, http://www.OhmanCorp.com/reference.asp,
' and may be copied with this header intact.  Author: Jay R. Ohman
'--------------------------------------------------------------------------------------------------

'--------------------------------------------------------------------------------------------------
' INDEX
' Functions
'   FillDateZeros
'   FillLeadZeros
'   JetSQLFixup
'   ListSrvVars
'   MonthAbbrev
'   DayOfWeekLong
'   ReplaceStr
'   SpaceHTML
'   TrimBefBS
'   XLookup
' Subroutines
'  LinkContinue

'--------------------------------------------------------------------------------------------------
' NOTE: database lookup functions assume connector already exists
'--------------------------------------------------------------------------------------------------
' Some functions will output debug mode text, I usually create my functions in an include file
' Then set the xDbg value in the page before the include statement
' xDbg = 0          ' set debug mode: on = -1, off = 0
' output using fixed font, little easier to read debug stuff
' tf1 = "<FONT FACE=""Courier New, Courier"" SIZE=""-1"">"
'--------------------------------------------------------------------------------------------------
' other favorite font string settings
' tf1 = "<FONT FACE=""Courier New, Courier"" SIZE=""-1"">"
' tf2 = "<FONT FACE=""Courier New, Courier"" SIZE=""+0"">"
' vf1 = "<FONT FACE=""Verdana"" SIZE=""-1"">"



'--------------------------------------------------------------------------------------------------
' Purpose: Converts Null to zero
' Inputs:  xStr = the original value
' Returns: The processed value
'--------------------------------------------------------------------------------------------------
Function N2Z( xStr )
  If IsNull(xStr) Then Nze = 0 Else Nze = xStr
End Function

'--------------------------------------------------------------------------------------------------
' Purpose: If value is null, then converts null value to a string
' Inputs:  xStr = the original value
'          rStr = tre replacement string
' Returns: The processed value
'--------------------------------------------------------------------------------------------------
Function Nz( xStr, sValueIfNull )
  If IsNull(xStr) Then Nz = sValueIfNull Else Nz = xStr
End Function

'--------------------------------------------------------------------------------------------------
' Purpose: Fills leading zeros in date strings
' Inputs:  xStr = the original string
' Returns: The processed value
'--------------------------------------------------------------------------------------------------
Function FillDateZeros( xStr )
  If IsDate( Trim( xStr ) ) Then
    FillDateZeros = FillLeadZeros( Month( Trim( xStr )), 2 ) & "/" & FillLeadZeros( Day( Trim( xStr )), 2 ) & "/" & Year( Trim( xStr ))
  End If
End Function

'--------------------------------------------------------------------------------------------------
' Purpose: Fills leading zeros
' Inputs:  xStr = the original string
'          StrLen = the length of processed string
' Returns: The processed value
'--------------------------------------------------------------------------------------------------
Function FillLeadZeros( xStr, StrLen )
  xOrigLen = Len( Trim( xStr ) )
  If xOrigLen > 0 AND xOrigLen < StrLen Then
    For xFLZeros = 1 to ( StrLen - xOrigLen )
      xLeadStr = "0" & xLeadStr
    Next
  End If
  FillLeadZeros = xLeadStr & Trim( xStr )
End Function

'--------------------------------------------------------------------------------------------------
' Purpose: make special characters in a JET SQL statement acceptable
' extracted from http://support.microsoft.com/default.aspx?scid=kb;EN-US;178070
'--------------------------------------------------------------------------------------------------
Function JetSQLFixup(TextIn)
  TextIn = Replace(TextIn, "'", "''")
  JetSQLFixup = Trim( Replace(TextIn, "|", "' & chr(124) & '"))
End Function

'--------------------------------------------------------------------------------------------------
' Purpose: extract a boolean value from a bitmask
' input: (decimal number, bit to be extracted counting from RIGHT end)
'--------------------------------------------------------------------------------------------------
Function GetBitVal( sNumber, sBitNum )
  xBinExpr = Dec2Bin(sNumber)
  xCheckBit = Mid( xBinExpr, 1 + (Len(xBinExpr) - sBitNum), 1)
  GetBitVal = (CBool(xCheckBit))
End Function

'--------------------------------------------------------------------------------------------------
' Purpose: Converts a decimal value to binary (in string value format).
' String mask is set with iMaxVal: 16 = 1111,  256 = 1111 1111,  65536 = 1111 1111 1111 1111
' Returns Null if input value is too large.
'--------------------------------------------------------------------------------------------------
Function Dec2Bin( sNumber )
  iMaxVal = 65536
  If sNumber > iMaxVal Then
    Dec2Bin = Null
  Else
    sRes = "" : iVal = sNumber : iExp = (iMaxVal / 2)
    while iExp >= 1
      if iVal >= iExp then iVal = iVal - iExp : sRes = sRes & "1" else sRes = sRes & "0"
      iExp = iExp / 2
    wend
    Dec2Bin = sRes
  End If
End Function

'--------------------------------------------------------------------------------------------------
' Purpose: list passed variables:
' - URL string variables
' - Form variable
' - Cookies
' Sample invocation: If xDbg Then ListSrvVars
'--------------------------------------------------------------------------------------------------
Function ListSrvVars() %><br>
  <table align="center" border="1" cellspacing="0"><!-- ----Begin ListSrvVars---- -->
    <tr><td align="center"><tt>
      <b>Listing of Form Variables</b></tt></td></tr>
    <tr><td><tt><%
  For Each xVar in Request.QueryString                ' Enumerate QueryString values
    Response.Write vbCrLf & "      QueryStringVar; " & xVar & ": <b>" & Request.QueryString(xVar) & "</b><br>"
  Next
  For Each xVar in Request.Form                       ' Enumerate passed form values
    Response.Write vbCrLf & "      FormVar; " & xVar & ": <b>" & Request.Form(xVar) & "</b><br>"
  Next
  For Each cookie in Request.Cookies                  ' Enumerate entire cookie collection.
     If Not Request.Cookies(cookie).HasKeys Then      ' No sub-keys, so display the cookie string value
       Response.Write vbCrLf & "      Cookie; " & cookie & ": <b>" & Request.Cookies(cookie) & "</b><br>"
     Else                                             ' Cookie has sub-keys so enumerate sub-values
       For Each key in Request.Cookies(cookie)        ' and display the sub-values
         Response.Write vbCrLf & "      CookieDict; " & cookie & _
             "(" & key & "): <b>" & Request.Cookies(cookie)(key) & "</b><br>"
       Next
     End If
  Next
  For Each xVar In Session.Contents                   ' Enumerate all Session values
    If IsArray(Session(xVar)) Then                    ' test for array type Session values
      For x = LBound(Session(xVar)) To UBound(Session(xVar))
        Response.Write vbCrLf & "      SessionVar; Session(""" & xVar & "(" & x & ")""): <b>" & Session(xVar)(x) & "</b><br>"
      Next
    Else                                              ' just display the Session value
      Response.Write vbCrLf & "      SessionVar; Session(""" & xVar & """): <b>" & Session.Contents(xVar) & "</b><br>"
    End If
  Next
  For Each xVar In Application.Contents               ' Enumerate all Application values
    If IsArray(Application(xVar)) Then                ' test for array type Application values
      For x = LBound(Application(xVar)) To UBound(Application(xVar))
        Response.Write vbCrLf & "      ApplicationVar; Application(""" & xVar & "(" & x & ")""): <b>" & Application(xVar)(x) & "</b><br>"
      Next
    Else                                              ' just display the Application value
      Response.Write vbCrLf & "      ApplicationVar; Application(""" & xVar & """): <b>" & Application.Contents(xVar) & "</b><br>"
    End If
  Next
  Response.Write vbCrLf & "      Session.SessionID:                <b>" & Session.SessionID & "</b><br>" %>
      </tt></td></tr>
  </table><!-- ----End ListSrvVars---- --><%
End Function

'--------------------------------------------------------------------------------------------------
' Purpose: write <TT>, usually in debug mode
' Sample invocation: If xDbg Then TTWrite(StrSQL)
'--------------------------------------------------------------------------------------------------
Function TTWrite(xStr) %>
  <tt><%= xStr %></tt><br><br><%
End Function

'--------------------------------------------------------------------------------------------------
' Same as above, but older version, no table formatting
'--------------------------------------------------------------------------------------------------
Function OldListSrvVars()
  Response.Write tf1 & "Listing of Form Variables:<BR>"
  For Each xVar in Request.QueryString
    Response.Write "QueryStringVar; " & xVar & ": <B>" & Request.QueryString(xVar) & "</B><BR>"
  Next
  For Each xVar in Request.Form
    Response.Write "FormVar; " & xVar & ": <B>" & Request.Form(xVar) & "</B><BR>"
  Next
  For Each cookie in Request.Cookies                    ' Print out the entire cookie collection.
     If Not Request.Cookies(cookie).HasKeys Then       ' Print out the cookie string
       Response.Write "Cookie; " & cookie & ": <B>" & Request.Cookies(cookie) & "</B><BR>"
     Else                                              'Print out the cookie collection
       For Each key in Request.Cookies(cookie)
         Response.Write "CookieDict; " & cookie & "(" & key & "): <B>" & Request.Cookies(cookie)(key) & "</B><BR>"
       Next
     End If
  Next
  Response.Write "Session.SessionID: <B>" & Session.SessionID & "</B><BR>"
  Response.Write fe1 & "<BR>"
End Function

'--------------------------------------------------------------------------------------------------
' Purpose: Converts month number to month abbreviation
' Inputs:  xStr = the month number
' Returns: The month abbreviation
'--------------------------------------------------------------------------------------------------
Function MonthAbbrev( xStr )
  If Trim( xStr ) = "" OR IsNull( Trim( xStr )) OR CInt( xStr ) < 1 OR CInt( xStr ) > 12 Then
    MonthAbbrev = xStr
  Else
    Select Case CInt( xStr )
    Case 1
      MonthAbbrev = "Jan"
    Case 2
      MonthAbbrev = "Feb"
    Case 3
      MonthAbbrev = "Mar"
    Case 4
      MonthAbbrev = "Apr"
    Case 5
      MonthAbbrev = "May"
    Case 6
      MonthAbbrev = "Jun"
    Case 7
      MonthAbbrev = "Jul"
    Case 8
      MonthAbbrev = "Aug"
    Case 9
      MonthAbbrev = "Sep"
    Case 10
      MonthAbbrev = "Oct"
    Case 11
      MonthAbbrev = "Nov"
    Case 12
      MonthAbbrev = "Dec"
    End Select
  End If
End Function

'-------------------------------------------------------------------------------
' Purpose: Converts DayOfWeek number to day name
' Inputs:  xStr = the DayOfWeek number (assumes Sunday is DayNo = 1)
' Returns: The day name
'-------------------------------------------------------------------------------
Function DayOfWeekLong( xStr )
  If Trim( xStr ) = "" OR IsNull( Trim( xStr )) OR CInt( xStr ) < 1 OR CInt( xStr ) > 7 Then
    DayOfWeekLong = xStr
  Else
    Select Case CInt( xStr )
    Case 1
      DayOfWeekLong = "Sunday"
    Case 2
      DayOfWeekLong = "Monday"
    Case 3
      DayOfWeekLong = "Tuesday"
    Case 4
      DayOfWeekLong = "Wednesday"
    Case 5
      DayOfWeekLong = "Thursday"
    Case 6
      DayOfWeekLong = "Friday"
    Case 7
      DayOfWeekLong = "Saturday"
    End Select
  End If
End Function

'--------------------------------------------------------------------------------------------------
' Purpose: Replace characters in a text string
' extracted from http://support.microsoft.com/default.aspx?scid=kb;EN-US;178070
' CompMode: 0=vbBinaryCompare=binary comparison, 1=vbTextCompare=textual comparison.
'   (this was a work-around, before the 'Replace' function)
'--------------------------------------------------------------------------------------------------
Function ReplaceStr (TextIn, SearchStr, Replacement, CompMode)
  If IsNull(TextIn) Then
    ReplaceStr = Null
  Else
    WorkText = TextIn
    Pointer = InStr(1, WorkText, SearchStr, CompMode)
    Do While Pointer > 0
      WorkText = Left(WorkText, Pointer - 1) & Replacement & Mid(WorkText, Pointer + Len(SearchStr))
      Pointer = InStr(Pointer + Len(Replacement), WorkText, SearchStr, CompMode)
    Loop
    ReplaceStr = WorkText
  End If
End Function

'--------------------------------------------------------------------------------------------------
' Purpose: Converts empty string to "&nbsp;"
' Inputs:  xStr = the original string
' Returns: The processed value
'--------------------------------------------------------------------------------------------------
Function SpaceHTML( xStr )
  If Trim( xStr ) = "" OR IsNull( Trim( xStr )) Then
    SpaceHTML = "&nbsp;"
  Else
    SpaceHTML = Trim( xStr )
  End If
End Function

'--------------------------------------------------------------------------------------------------
' Purpose: Chop off text before the last BackSlash
'--------------------------------------------------------------------------------------------------
Function TrimBefBS( xOrigStr )
  TrimBefBS = Right( xOrigStr , Len( xOrigStr ) - InStrRev( xOrigStr, "\") )
End Function

'--------------------------------------------------------------------------------------------------
' subsitute for VBA DLookup, fetch value from a table (or query) : [] not allowed though around Field Names
' Expr = Field Name, Domain = Table Name, Criteria = WHERE clause without the WHERE
'--------------------------------------------------------------------------------------------------
Function XLookup( Expr, Domain, Criteria )
  Set rstx = CreateObject("ADODB.Recordset")
  StrSQL = "SELECT " & Expr & " FROM " & Domain & " WHERE " & Criteria & ";"
  If xDbg Then Response.Write tf1 & StrSQL & "</FONT><BR>"
  rstx.Open StrSQL, ConnX, 3, 1
  If rstx.EOF Then
    XLookup = ""
  Else
    XLookup = rstx.Fields( Expr )
  End If
End Function

'------------------------------------------------------------------------------------------------
' subsitute for VBA DCount, fetch count of values from a table (or query) : [] not allowed though around Field Names
' Expr = Field Name, Domain = Table Name, Criteria = WHERE clause without the WHERE
'------------------------------------------------------------------------------------------------
Function XCount( Expr, Domain, Criteria )
  Set rstx = CreateObject("ADODB.Recordset")
  StrSQL = "SELECT Count(" & Expr & ") AS " & Expr & "Count FROM " & Domain & " WHERE (" & Criteria & ")"
  ' If xDbg Then TTWrite(StrSQL)
  rstx.Open StrSQL, ConnL, 3, 1
  If rstx.EOF Then
    XCount = ""
  Else
    XCount = rstx( Expr & "Count" )
  End If
  Set rstx = Nothing
End Function

'--------------------------------------------------------------------------------------------------
' Easy way to provide a cancel button
'--------------------------------------------------------------------------------------------------
<form action="GoToPage.asp?rParam=<%=xParam%>" method="post" name="CancelForm"></form>
....
<input type="button" value="Cancel" onclick="javascript:document.CancelForm.submit()">

'--------------------------------------------------------------------------------------------------
' Easy way to provide link in debug mode, auto-continue otherwise
'--------------------------------------------------------------------------------------------------
Sub LinkContinue %>
  <FORM ACTION="./<%= DocName %>" METHOD=POST NAME="form1x">
  <INPUT TYPE="HIDDEN" NAME=rFld VALUE="ListVal"></FORM>
  <script type=text/javascript>function doIt() { document.form1x.submit(); }</script><%
  If xDbg Then %>
    <A HREF="javascript:document.form1x.submit()">continue</A><%
  Else %>
    <script>doIt()</script><%
  End If
End Sub

'--------------------------------------------------------------------------------------------------
' Different Database connectors (stolen from SnitzForum freeware, http://forum.snitz.com)
'--------------------------------------------------------------------------------------------------
'strConnX = "Provider=Microsoft.Jet.OLEDB.4.0;Data Source=c:\InetPub\dbroot\MyAccessDB.mdb" '## MS Access 2000/97
'strConnX = "Provider=Microsoft.Jet.OLEDB.4.0;Data Source=" & Server.MapPath("MyAccessDB.mdb") '## MS Access 2000 using virtual path
'strConnX = "DRIVER={Microsoft Access Driver (*.mdb)}; DBQ=" & Server.MapPath("MyAccessDB.mdb") '## MS Access 97 using virtual path
'strConnX = "Provider=SQLOLEDB;Data Source=SERVER_NAME;database=MySQLServerDB;uid=UID;pwd=PWD;" '## MS SQL Server 6.x/7.x/2000 (OLEDB connection)
'strConnX = "driver={SQL Server};server=SERVER_NAME;uid=UID;pwd=PWD;database=MySQLServerDB" '## MS SQL Server 6.x/7.x/2000 (ODBC connection)
'strConnX = "DSN_NAME" '## DSN

'--- simple ODBC name, System DSN -----
'Set ConnX = CreateObject("ADODB.Connection")
'ConnX.open strConnX
'Set rst1 = CreateObject("ADODB.Recordset")

'--------------------------------------------------------------------------------------------------
' Quick-copy database connections
'--------------------------------------------------------------------------------------------------
Const adOpenDynamic = 2
Const adOpenStatic = 3
Const adLockReadOnly = 1
Const adLockOptimistic = 3
rst1.Open StrSQL, strConnX, adOpenStatic, adLockReadOnly

'--------------------------------------
' Not really a function, but a demonstration of assigning values to a multi-dimensional array
' (it would be nice if VBScript supported a method as is found in JavaScript)
'--------------------------------------
ReDim arrFilterStr(2)                       ' edit the value, according to number of rows (zero-based)
Dim arrTemp
arrFilterStr(0) = "1, Ford, Black, Excellent"
arrFilterStr(1) = "2, GM, Blue, Good"
arrFilterStr(2) = "3, Mopar, Green, Fair"
ReDim arrPFilters(3, UBound(arrFilterStr))  ' edit the first value, according to number of columns (zero-based)
For i = 0 To UBound(arrFilterStr)
  arrTemp = Split(arrFilterStr(i), ",")     ' edit the last parameter, delimiter character
  For j = 0 To UBound(arrTemp)              '   (comma character can be a problem)
    arrPFilters(j, i) = Trim(arrTemp(j))
  Next
Next