Funky Functions in ASP

[mulletboy2]

This is possible in SQL Server in several ways. I'll PM you rather than get flamed for posting T-SQL instead of ASP ;-)

[Technosailor]

Originally posted by dhtmlgod
Heres a quick one to connect to a db:

connectDB()
Set getStuff = objDBCon.execute("SELECT stuff FROM tblsStuff")
' Write stuff...
Set getStuff = nothing
connectDB()

The best way tp do this is have it as na include file

Hey d....

Is there a reason for doing the connectDB() function twice? trying to figure it all out here.


Sketch

[dhtmlgod]

The function checks to see if objDBCon is an object and if it isn't, it creates one, and if it is, it destroys it. The first time the connectDB() is ran, it creates the database connection object, the we collect info from the database and do something with it:
[vbs]
Set getStuff = objDBCon.execute("SELECT stuff FROM tblsStuff")
' Write stuff...
[/vbs]
Then we call the connectDB function again which closes the object.

[spartan]

another function for converting dates.
but using the split function rather than the instr function to get the seperate dateparts. Its just easier than looping through a string looking for /'s...


[VBS]
function toDDMMYYYY(olddate)
str=split(olddate,"/",-1)
MM = str(0)
DD = str(1)
YYYY = str(2)
if len(MM)=1 then
MM="0" & MM
end if

if len(DD)=1 then
DD="0" & DD
end if

newdate=DD & "/" & MM & "/" & YYYY
toDDMMYYYY = newdate
end function[/VBS]

[[MOS]]

The best way I've found to work with databases is to have a little library that includes the declaration of the variables, and uses functions to connect and retrieve data or execute queries.

This way, you can do whatever you want each time you query the database. I use to count the number of queries and store the text of each of them, so I can print it later to debug the application and so.

So, here's the code. Please proof-read it because I'm editing my code to name the variables and functions in English. It's in Spanish in my code.

It has got error detecting and handling, so it displays beautifully the SQL error and the SQL string that caused it.

Last comment: it uses many Subs. The way I use to call them is like this:
[VBS]call AnySubWithParameters (param1, param2)[/VBS]

So you can use parenthesis, as you do with functions. It's easier to read for me.

[VBS]
<%
'### dblib.asp

'variable declarations
Dim oConn, bConn
Dim totalsql, totalrs, totalgetrows
Dim dicSQL, dicRS, dicGR
Dim strConnection

'initialize the 3 dictionary objects I use to store the queries
'if you don't want this feature, comment the following 3 lines
'and each call to "AddSQL" through the code (find & replace recommended!)
Set dicSQL = Server.CreateObject("Scripting.Dictionary")
Set dicRS = Server.CreateObject("Scripting.Dictionary")
Set dicGR = Server.CreateObject("Scripting.Dictionary")

'we're not connected yet, so...
bConn = false

totalsql = 0 'number of queries
totalrs = 0 'number of requested Recordsets
totalgetrows = 0 'number of GetRows executed

'some useful constants - instead of including ADOVBS.INC
Const adOpenForwardOnly = 0
Const adOpenKeyset = 1
Const adOpenDynamic = 2
Const adOpenStatic = 3
Const adLockReadOnly = 1
Const adLockPessimistic = 2
Const adLockOptimistic = 3
Const adLockBatchOptimistic = 4

'set up your connection string
'you can use your "DSN=MiDSN" or any OLEDB/ODBC string
strConnection = "Provider=SQLOLEDB; Data Source..."

'-----------------------------------------------------------------------------
Sub ConnectDB ()
'### Initializes the db connection, call it to start with the db
if not bConn then
set oConn = Server.CreateObject("ADODB.Connection")
oConn.Open strConnection
if Err > 0 then
Response.Clear
Response.Write "Error while connecting to the database. Check your connection string!"
Response.End
end if
bConn = true
end if
End Sub
'-----------------------------------------------------------------------------
Sub DisconnectDB ()
'### it's obvious, call it when finished with the db
if bConn then
if oConn.State then
oConn.Close
end if
set oConn = nothing
bConn = false
end if
End Sub
'-----------------------------------------------------------------------------
Function GetRows ( strSQL )
'### use this to return a 2-dimensional array with data instead of a Recordset.
'it's kind of a longer topic, so I'll explain another time. People who use GetRows
'will understand
Dim myrs
if not bConn then
ConnectDB
end if
'turn off VBS error features
on error resume next
set myrs = oConn.Execute(strSQL)
if oConn.Errors.Count > 0 then
response.clear
out "<b>Error in GetRows</b><br/>"
out "<b>SQL statement/b> " & strSQL & "<br>"
'display the common error messages
For Each unerror In oConn.Errors
out "<li>" & unerror.description & "</li>"
Next
response.end
end if
'check to see if we got any data, return null if there isn't
'so, to check it there is any data, use the IsArray() function
'### Example:
'myData = GetRows("SELECT * FROM table")
'if IsArray(myData) then
' Response.Write "There are records."
' ....
'### End of example

if myrs.EOF then
GetRows = null
else
'return the array if OK
GetRows = myrs.GetRows
end if
'close up everything
myrs.Close
set myrs = nothing
'add 1 to the getrows count
totalgetrows = totalgetrows + 1
'add the query to the GetRows dictionary
call AddSQL(strSQL, dicGR)
End Function
'-----------------------------------------------------------------------------
Sub ExecNoRows ( strSQL )
'### call this with an INSERT, DELETE or UPDATE statement, as they return no data.
'### Example: call ExecNoRows("DELETE FROM table WHERE id=1")

Dim unerror
if not bConn then
ConnectDB
end if
on error resume next
oConn.Execute(strSQL)
if oConn.Errors.Count > 0 then
response.clear
out "<b>Error in ExecNoRows</b><br/>"
out "<b>SQL statement/b> " & strSQL & "<br>"
For Each unerror In oConn.Errors
out "<li>" & unerror.description & "</li>"
Next
response.end
end if
'add to the NoRows count
totalsql = totalsql + 1
'and the NoRows dictionary
call AddSQL(strSQL, dicSQL)
End Sub
'-----------------------------------------------------------------------------
Sub ExecRows(ByRef myrs, strSQL )
'### executes the strSQL query and returns the read-only Recordset it creates
'### the ByRef means "use THIS variable, not a copy of it", so call this Sub with a
'### variable you declare on the page and it will fill it with data. For example:
'### Dim myRs
'### call ExecRows(myRs, "SELECT * FROM table")
'### do until MyRs.EOF ... etc

if not bConn then
ConnectDB
end if
on error resume next
set myrs = oConn.Execute(strSQL)
if oConn.Errors.Count > 0 then
response.clear
out "<b>Error in ExecNoRows</b><br/>"
out "<b>SQL statement/b> " & strSQL & "<br>"
For Each unerror In oConn.Errors
out "<li>" & unerror.description & "</li>"
Next
response.end
end if
'the same story: add to the proper variable and to the proper dictionary
totalrs = totalrs + 1
call AddSQL(strSQL, dicRS)
End Sub
'-----------------------------------------------------------------------------
Sub ExecRows2 (ByRef myrs, strSQL, cursor, lock)
'### Executes the strSQL query and returns a Recordset, with specified cursor and lock type
'### you can use the ADO names or numbers for them. As before, call it with the variable you
'### want to act as the Recordset in myrs.
'### Example:
'### call ExecRows2(myData, mySQLstring, adOpenKeyset, adLockPessimistic)
'### do until MyData.EOF
'### ...etc

if not bConn then
ConnectDB
end if
Set myrs = Server.CreateObject("ADODB.Recordset")
myrs.CursorType = cursor
myrs.LockType = lock
on error resume next
myrs.Open strSQL, oConn
if oConn.Errors.Count > 0 then
response.clear
out "<b>Error in ExecNoRows</b><br/>"
out "<b>SQL statement/b> " & strSQL & "<br>"
For Each unerror In oConn.Errors
out "<li>" & unerror.description & "</li>"
Next
response.end
end if
'add to the number of Recordsets and to the proper dictionary
totalrs = totalrs + 1
call AddSQL(strSQL, dicRS)
End Sub
'-----------------------------------------------------------------------------
Sub AddSQL (SQL, ByRef dic)
'adds the SQL string to the proper dictionary
dic.Add(dic.Count), SQL
End Sub
%>
[/VBS]

I find it useful for several reasons, but my experience tells me that it can be very useful to know the number of queries made in a complex ASP page, and to know which queries got called if there were many in the page.

Just write a Sub that iterates the 3 dictionaries and writes each SQL statement, or that simply prints the number of queries. If you're interested, I'll post one.

So, a full example using this "library" could be:

[VBS]
<!--#include file="dblib.asp"-->
<%
Dim myCustomers, mySQL
ConnectDB
mySQL = "SELECT customerid, name, address FROM customers ORDER BY name"

call ExecRows(myCustomers, mySQL)
if myCustomers.EOF then
Response.Write "You are broke."
else
do until myCustomes.EOF
Response.Write "<li>" & myCustomers("name") & "</li>"
loop
end if
'just an example, non sense in this case
Response.Write "Number of queries: " & totalsql
DisconnectDB
%>
[/VBS]

Hope you find it useful. Just have to get used to the names of the Subs and Functions, and then you'll forget about creating ADODB.Connections and ADODB.Recordsets.

Enhacements planned: adding support to execute stored procedures, and perhaps wrapping it all into a Class.

Hope it helps and I didn't bore you.

[Ikaro]

Originally posted by mulletboy2
I have an ASP page for creating ASP pages to call SQL Server stored proceudres for updates/inserts. It generates all of the ASP/HTML you need. It's *way* too long to post here, but if anyone would find it useful, let me know.

I need something like this, where can I look the code
Thanx

[markjrubin]

Originally posted by Ikaro


I need something like this, where can I look the code
Thanx

I second this!

[mulletboy2]

I'm working on a rewrite of the script as we speak. I'm making a few enhancements such as error checking, template files etc..

I'll get back to you in a couple of days, but most likely I'll upload a zip to my website for people to download.

[davedibiase]

<%
Function CheckField(FormFrom, FormTo)
	CheckField = 0
	  Do Until FormFrom = FormTo
		FieldName = "field_" & FormFrom
		If request.form(FieldName) = "" Then
			CheckField = CheckField + 1
			execute "" & FieldName & " = ""*"""
		End If
	      FormFrom = FormFrom + 1
	  Loop
End Function
%>

The shortest, most useful function for checking fields that I have seen/written. What you want to do is set your fields in a form with: field_ + a number (ie.field_1). Then you would want to call the function CheckField() with FormFrom as the the starting range and FormTo as the ending range. Then output the fieldname as variable beside the form and when you process it will tell the user the direct field that has the error.

Note: This only checks if user's have entered information. I will expand this code to include e-mail checking, postal code etc.

Any comments?

[writhe]

Dave-

Why not do something like this so you don't have to number the forms?

Function CheckField()
	For i = 1 To Request.Form.Count
		If Len(Request.Form.Item(i)) = 0 then
			Response.Write Request.Form.Key(i) & " = ""*"" <br>"
		End if
	Next
End Function

[Metallisoft]

Those 2 database examples seem a little excessive, involving multiple function calls, where you should be able to retrieve/store data with one function call(for each) like this: (Note that these functions check a variable DB_ACCESS, defined by my global.inc file, that holds all my page properties, to determine the database from which I'm pulling the data...Access or SQLServer)

Sub ExecuteSQL(ByVal sSQL)
Dim dbDatabase
	'Response.Write sSQL ' For debugging
	Set dbDatabase=Server.CreateObject("ADODB.Connection")
	If DB_ACCESS Then
		dbDatabase.Provider = "Microsoft.Jet.OLEDB.4.0"
		dbDatabase.Open "[path]\[database].mdb","[user]","[password]"
		dbDataBase.CommandTimeout = 120
	Else
		dbDatabase.Open "Driver={SQL Server}; Server=[Servername]","[user]","[password]"
		dbDatabase.DefaultDatabase="[DBName]"
	End If
	dbDatabase.Execute(sSQL)' Store the data
	dbDatabase.Close		' Close the connection object.
	Set dbDatabase = Nothing
End Sub
' **********************************************************************************************************************************
Function OpenRS(ByVal sSQL)
Dim dbDatabase, RS
	'Response.Write sSQL ' For debugging
	Set dbDatabase=Server.CreateObject("ADODB.Connection")
	Set RS = Server.CreateObject("ADODB.Recordset")
	If DB_ACCESS Then
		dbDatabase.Provider = "Microsoft.Jet.OLEDB.4.0"
		dbDatabase.Open "[path]\[database].mdb","[user]","[password]"
		dbDataBase.CommandTimeout = 120
	Else
		dbDatabase.Open "Driver={SQL Server}; Server=[Servername]","[user]","[password]"
		dbDatabase.DefaultDatabase="[DBName]"
	End If
	RS.CursorLocation = adUseClient			' Client side cursor
	RS.CursorType = adOpenForwardOnly		' Since we only need to move foward to display all the items...
	RS.Open sSQL, dbDatabase, adOpenForwardOnly, adLockReadOnly  
	Set RS.ActiveConnection = Nothing		' Disconnect the recordset.
	Set OpenRS = RS
	'RS.Close
	'Set RS = Nothing
	dbDatabase.Close						' Close the connection object.
	Set dbDatabase = Nothing
End Function

This way, you get a recordset back with no umbilical cord to the server. All you have to do is close the RS when you're finished iterating.

[davedibiase]

Does anyone have a VERY SHORT validation number generator function. I could write one, but atm I don't have much time. The function should output in the form of this:

xxx-xxxxxxx-xx

Your help is MUCH apperciated.

Thanks,

[vgarcia]

Originally posted by davedibiase
Does anyone have a VERY SHORT validation number generator function. I could write one, but atm I don't have much time. The function should output in the form of this:

xxx-xxxxxxx-xx

Your help is MUCH apperciated.

Thanks,

Try this one:
[vbs]
function GenValNumber()
dim thisYear, thisTime, thisSess
thisYear = Year(date)
thisTime = Now()
thisSess = Session.SessionID
thisSess = cStr(thisSess)
thisYear = mid(cStr(thisYear), 2, 3)
thisTime = right(cStr(thisTime), 2)
thisSess = left(thisSess, 2) & right(thisSess, 2) & mid(thisSess, (len(thisSess)/2), 2)
GenValNumber = thisYear & "-" & thisSess & "-" & thisTime
end function
[/vbs]

I'm pretty sure you'll get a unique identifier every time, unless you have to restart your ASP application a lot, in which case there is a chance that a duplicate SessionID can occur. This also assumes you can use Sessions (i.e. your site is not hosted by a company like Brinkster).

--Vinnie

[davedibiase]

Originally posted by vgarcia

I'm pretty sure you'll get a unique identifier every time, unless you have to restart your ASP application a lot, in which case there is a chance that a duplicate SessionID can occur. This also assumes you can use Sessions (i.e. your site is not hosted by a company like Brinkster).

--Vinnie

It wont really matter...the validation wont be used a one source user information code, it will require username and validation to perform certain account tasks, so I am not to worried about that. If I do need something like you say in the future...I will simply add 2 more fields depending on the users e-mail and name.

Thanks for your help!

[Goof]

I had posted the following function before in a thread of it's own while I was creating and debugging it, but now I have deemed it usable, so I will post it here.

This function is used for converting a boolean search string to SQL-compatible code for use in a WHERE clause. The parameters it takes are the field in the database that you want to search, and the text containing the boolean query. It supports parenthesis, AND, OR, NOT, and phrases (text within quotes) as well as every error-checking feature that I could think of - managing parenthesis so they pair up, using AND as the default joiner but also allowing the user to specify AND OR or NOT, managing phrases, etc. (for the time being, you can test the function here)

[vbs]
Function parseSearch(ByVal Field, ByVal SearchText)
dim outputStr 'output variable
dim parseArray 'our SearchText loaded into an Array split on " "
dim phraseTF 'boolean flag stating whether we are in a phrase
dim keywrdTF 'boolean flag stating whether there is a keyword provided between two search words
dim x 'loop variable
dim parenCount 'count the number of parens
dim tempChar 'temporary character variable
outputStr = ""
phraseTF = false
keywrdTF = true
parenCount = 0

'make the search string SQL safe
SearchText = replace(SearchText, "'", "''")
SearchText = replace(SearchText, "%", "[%]")
SearchText = replace(SearchText, "_", "[_]")
SearchText = replace(SearchText, "[", "[[]")
SearchText = replace(SearchText, "]", "[]]")

'error check the search string for paren equality and closed phrases (and pad quotes and parens while we're at it)
x = 0
do while(x < len(SearchText))
tempChar = mid(SearchText, x + 1, 1)
if (tempChar = """") then
if (phraseTF = false) then phraseTF = true else phraseTF = false
SearchText = left(SearchText, x) & " "" " & right(SearchText, len(SearchText) - (x + 1))
x = x + 2
elseif ((tempChar = "(") AND (phraseTF = false)) then
parenCount = parenCount + 1
SearchText = left(SearchText, x) & " ( " & right(SearchText, len(SearchText) - (x + 1))
x = x + 2
elseif ((tempChar = ")") AND (phraseTF = false)) then
parenCount = parenCount - 1
SearchText = left(SearchText, x) & " ) " & right(SearchText, len(SearchText) - (x + 1))
x = x + 2
end if
x = x + 1
loop
'if the phrase is still open after parsing through the string, close it
if (phraseTF = true) then
SearchText = SearchText & " "" "
phraseTF = false
end if
'if parenCount is greater than 0, add the needed ) chars
if (parenCount > 0) then
for x = 1 to parenCount
SearchText = SearchText & " ) "
parenCount = parenCount - 1
next
'else if parenCount is less than 0, add the needed ( chars
elseif (parenCount < 0) then
for x = 1 to abs(parenCount)
SearchText = " ( " & SearchText
parenCount = parenCount + 1
next
end if

'split the string on the space character
parseArray = split(SearchText, " ")

'go through the array and build the SQL code (outputStr)
for x = 0 to UBound(parseArray)
parseArray(x) = trim(parseArray(x))
select case UCase(parseArray(x))
'THE ELEMENT IS A QUOTE
case """"
'if we are not in a phrase, we want to begin a phrase
if (phraseTF = false) then
if (keywrdTF = false) then outputStr = outputStr & " AND " else keywrdTF = false
outputStr = outputStr & Field & " LIKE '%"
phraseTF = true
'if we are in a phrase, we want to end it
else
outputStr = left(outputStr, len(outputStr) - 1) & "%'"
phraseTF = false
end if
'THE ELEMENT IS A PAREN
case "(", ")"
'only process if we are outside of a phrase
if (phraseTF = false) then
if ((keywrdTF = false) AND (parseArray(x) = "(")) then
outputStr = outputStr & " AND "
keywrdTF = true
end if
outputStr = outputStr & parseArray(x)
'otherwise add the character with it's space to the phrase
else
outputStr = outputStr & parseArray(x)
end if
'THE ELEMENT IS "OR" OR "AND"
case "OR", "AND"
'only process if we are outside of a phrase
if (phraseTF = false) then
'if there is already a keyword, then we want to turn this into search criteria, so the db doesn't break
if (keywrdTF = true) then
outputStr = outputStr & Field & " LIKE '%" & parseArray(x) & "%'"
keywrdTF = false
else
outputStr = outputStr & " " & UCase(parseArray(x)) & " "
keywrdTF = true
end if
'if outside a phrase, add the word with the space to the SQL string
else
outputStr = outputStr & parseArray(x) & " "
end if
'THE ELEMENT IS "NOT"
case "NOT"
'only process if we are outside of a phrase
if (phraseTF = false) then
if (keywrdTF = false) then
outputStr = outputStr & " AND "
keywrdTF = true
end if
outputStr = outputStr & UCase(parseArray(x)) & " "
'otherwise we are outside of a phrase and just add the word with the space to the SQL string
else
outputStr = outputStr & parseArray(x) & " "
end if
'THE ELEMENT IS THE RESULT OF EXTRA SPACES
case EMPTY, NULL, ""
if (phraseTF = true) then outputStr = outputStr & " "
'THE ELEMENT IS ANOTHER WORD
case else
'only process if outside of a phrase
if (phraseTF = false) then
if (keywrdTF = false) then outputStr = outputStr & " AND " else keywrdTF = false
outputStr = outputStr & Field & " LIKE '%" & parseArray(x) & "%'"
'if inside a phrase, add the word to the SQL string
else
outputStr = outputStr & parseArray(x) & " "
end if
end select
next

'if the string ended in a keyword, don't brake the db!
if (keywrdTF = true) then
outputStr = outputStr & field & " LIKE '%%'"
keywrdTF = false
end if

parseSearch = outputStr 'return the output variable
End Function
[/vbs]

To give you an example, when this function is called with this code:

myWhere = parseSearch("myField", "jim and not (john or jean)")

myWhere will contain:

myField LIKE '%jim%' AND NOT (myField LIKE '%john%' OR myField LIKE '%jean%')

This function becomes extremely useful for searchable sites, because it is meant to be used like this:
[vbs]
dbSQL = "SELECT Body FROM myPages WHERE " & parseSearch("Body", Request.Querystring("SearchStr"))
[/vbs]

I know I will use it quite a bit, and I thought it might be useful to others here.

Enjoy!
Goof

[A. Rochkind]

This allows you to use SMS wireless messaging to send ringtones (melodies) to Nokia cell phones from Active Server Pages. Uses the Simplewire network.

The best way is to join the Simplewire Developer Program at http://devprogram.simplewire.com. Then download the SDK as listed. Then you will receive an email explaining what to do.

You will be able to use demo credits from the free evaluation version to do this!

<%
Set sms = Server.CreateObject( "Simplewire.SMS" )

' Subscriber Settings
sms.SubscriberID = "123-123-123-12345"
sms.SubscriberPassword = "Password Goes Here"

' Message Settings
sms.MsgPin = "+1 100 510 1234"
sms.MsgFrom = "Demo"
sms.MsgCallback = "+1 100 555 1212"

' Smart Message Settings
sms.OptPhone = "nokia"
sms.MsgRingtone = "Simplewire:d=4,o=5,b=63:8a,8e,32a,32e,
16a,8c6,8a,32c6,32a,16c6,8e6,8c6,32e6,32c6,16e6,8g6,32g,
32p,16g,32c6,32g,16c6,8e6,32p"

Response.Write("<b>Sending message to Simplewire...</b><br>")

' Send Message
sms.MsgSend

' Check For Errors
If (sms.Success) Then
Response.Write("<b>Message was sent!</b><br>")
Else
Response.Write("<b>Message was not sent!</b><br>")
Response.Write("Error Code: " & sms.ErrorCode & "<br>")
Response.Write("Error Desc: " & sms.ErrorDesc & "<br>")
End If

Set sms = Nothing
%>

[Goof]

The VBScript Hex() function is kinda nifty, but what's the use if you can't get the hex numbers back to decimal? The following function will take a positive hex string within the range of a double and give you the decimal equivilent.

[vbs]
Function Hex2Dec(ByVal Hex)
Dim hexLen 'lenth of Hex
Dim hexCheck 'string containing valid hex digits
Dim hexErrorTF 'true/false value flagging an invalid digit
Dim x 'loop variable

'make sure that Hex is a string variant
Hex = CStr(Hex)

hexLen = len(Hex)
hexCheck = "0123456789ABCDEF"

'make sure Hex is a valid hexidecimal number
hexErrorTF = False
For x = 1 To hexLen
If (inStr(hexCheck, uCase(mid(Hex, x, 1))) = 0) Then hexErrorTF = True
Next

If (hexErrorTF) Then
Hex2Dec = CDbl(0)
Else
If (hexLen = 1) Then
'return decimal number for hex digit
If (isNumeric(Hex)) Then
Hex2Dec = CDbl(hex)
Else
'figure out the decimal equivilent of the hex digit
Select Case uCase(Hex)
Case "A"
Hex2Dec = CDbl(10)
Case "B"
Hex2Dec = CDbl(11)
Case "C"
Hex2Dec = CDbl(12)
Case "D"
Hex2Dec = CDbl(13)
Case "E"
Hex2Dec = CDbl(14)
Case "F"
Hex2Dec = CDbl(15)
Case Else
Hex2Dec = CDbl(0)
End Select
End If
Else
'convert hex to decimal digit by digit using recursion
For x = 1 To hexLen
Hex2Dec = Hex2Dec + (Hex2Dec(mid(Hex, ((hexLen + 1) - x), 1)) * (16 ^ (x - 1)))
Next
End If
End If
End Function
[/vbs]

Notice the hex numbers must be positive. Windows Calculator actually computes a twos-compliment number for negative hex, but I couldn't figure out what the hex() function does for negative numbers (although it does seem to return something).

The only practical application I could think of for using hex in ASP would be its use in creating encryption keys and the like (for instance, a basic hash might be a string of hex digits representing the ascii code for the original string - I don't know, I'm just brain farting here).

Anyway, enjoy!
Goof

[iamnomad]

Nice job on the boolean search Mr Goof

[Goof]

Originally posted by iamnomad
Nice job on the boolean search Mr Goof

Thanks! I hope you guys find it useful!

Goof

[Goof]

Two code snippets:

1) A function which takes the connection string and an SQL query and returns an array of that recordset via GetRows(). This should make it as easy as ever get rid of those ADO objects hanging around in memory (and should stop the complaints about the "complexities" of GetRows).
[vbs]
Function dbGetRows(ByVal connStr, ByVal SQLStr)
'variable declarations:
dim grConn, grRS, grArray

'open the database
Set grConn = Server.CreateObject("ADODB.Connection")
grConn.ConnectionString = connStr
grConn.Open
set grRS = Server.CreateObject("ADODB.Recordset")
grRS.CursorType = 3 'Static
grRS.Open SQLStr, grConn

'get the rows and assign them to the return array
if ((NOT grRS.bof) AND (NOT grRS.eof)) then grArray = grRS.GetRows() else grArray = ""

'close the database
If (grRS.state <> 0) Then grRS.close
If (grConn.state <> 0) Then grConn.close
If (isObject(grRS)) Then Set grRS = Nothing
If (isObject(grConn)) Then Set grConn = Nothing

'return the array
dbGetRows = grArray
End Function
[/vbs]

2) A sub to be used like the above function but for queries that do not return a recordset (UPDATE/DELETE). By using this sub we make it impossible to forget to close our connection objects and recordset objects.
[vbs]
Sub dbExecute(connStr, SQLStr)
'variable declarations:
Dim execConn, execRS

'open the database
Set execConn = Server.CreateObject("ADODB.Connection")
execConn.ConnectionString = connStr
execConn.Open
Set execRS = Server.CreateObject("ADODB.Recordset")
execRS.CursorType = 3 'Static
execRS.Open SQLStr, execConn

'close the database
If (execRS.state <> 0) Then execRS.close
If (execConn.state <> 0) Then execConn.close
If (isObject(execRS)) Then Set execRS = Nothing
If (isObject(execConn)) Then Set execConn = Nothing

End Sub
[/vbs]

Hope you find those useful - I do!
Goof

[Kings]

A function to MD5 encrypt strings;
[VBS]
Private Const BITS_TO_A_BYTE=8
Private Const BYTES_TO_A_WORD=4
Private Const BITS_TO_A_WORD=32
Private m_lOnBits(30)
Private m_l2Power(30)
m_lOnBits(0)=CLng(1)
m_lOnBits(1)=CLng(3)
m_lOnBits(2)=CLng(7)
m_lOnBits(3)=CLng(15)
m_lOnBits(4)=CLng(31)
m_lOnBits(5)=CLng(63)
m_lOnBits(6)=CLng(127)
m_lOnBits(7)=CLng(255)
m_lOnBits(8)=CLng(511)
m_lOnBits(9)=CLng(1023)
m_lOnBits(10)=CLng(2047)
m_lOnBits(11)=CLng(4095)
m_lOnBits(12)=CLng(8191)
m_lOnBits(13)=CLng(16383)
m_lOnBits(14)=CLng(32767)
m_lOnBits(15)=CLng(65535)
m_lOnBits(16)=CLng(131071)
m_lOnBits(17)=CLng(262143)
m_lOnBits(18)=CLng(524287)
m_lOnBits(19)=CLng(1048575)
m_lOnBits(20)=CLng(2097151)
m_lOnBits(21)=CLng(4194303)
m_lOnBits(22)=CLng(8388607)
m_lOnBits(23)=CLng(16777215)
m_lOnBits(24)=CLng(33554431)
m_lOnBits(25)=CLng(67108863)
m_lOnBits(26)=CLng(134217727)
m_lOnBits(27)=CLng(268435455)
m_lOnBits(28)=CLng(536870911)
m_lOnBits(29)=CLng(1073741823)
m_lOnBits(30)=CLng(2147483647)

m_l2Power(0)=CLng(1)
m_l2Power(1)=CLng(2)
m_l2Power(2)=CLng(4)
m_l2Power(3)=CLng(8)
m_l2Power(4)=CLng(16)
m_l2Power(5)=CLng(32)
m_l2Power(6)=CLng(64)
m_l2Power(7)=CLng(128)
m_l2Power(8)=CLng(256)
m_l2Power(9)=CLng(512)
m_l2Power(10)=CLng(1024)
m_l2Power(11)=CLng(2048)
m_l2Power(12)=CLng(4096)
m_l2Power(13)=CLng(8192)
m_l2Power(14)=CLng(16384)
m_l2Power(15)=CLng(32768)
m_l2Power(16)=CLng(65536)
m_l2Power(17)=CLng(131072)
m_l2Power(18)=CLng(262144)
m_l2Power(19)=CLng(524288)
m_l2Power(20)=CLng(1048576)
m_l2Power(21)=CLng(2097152)
m_l2Power(22)=CLng(4194304)
m_l2Power(23)=CLng(8388608)
m_l2Power(24)=CLng(16777216)
m_l2Power(25)=CLng(33554432)
m_l2Power(26)=CLng(67108864)
m_l2Power(27)=CLng(134217728)
m_l2Power(28)=CLng(268435456)
m_l2Power(29)=CLng(536870912)
m_l2Power(30)=CLng(1073741824)

Private Function LShift(lValue,iShiftBits)
If iShiftBits=0 Then
LShift=lValue
Exit Function
ElseIf iShiftBits=31 Then
If lValue And 1 Then
LShift=&H80000000
Else
LShift=0
End If
Exit Function
ElseIf iShiftBits<0 Or iShiftBits>31 Then
Err.Raise 6
End If

If (lValue And m_l2Power(31-iShiftBits)) Then
LShift=((lValue And m_lOnBits(31-(iShiftBits+1)))*m_l2Power(iShiftBits)) Or &H80000000
Else
LShift=((lValue And m_lOnBits(31-iShiftBits))*m_l2Power(iShiftBits))
End If
End Function

Private Function RShift(lValue,iShiftBits)
If iShiftBits=0 Then
RShift=lValue
Exit Function
ElseIf iShiftBits=31 Then
If lValue And &H80000000 Then
RShift=1
Else
RShift=0
End If
Exit Function
ElseIf iShiftBits<0 Or iShiftBits>31 Then
Err.Raise 6
End If

RShift=(lValue And &H7FFFFFFE)\m_l2Power(iShiftBits)

If (lValue And &H80000000) Then
RShift=(RShift Or (&H40000000\m_l2Power(iShiftBits-1)))
End If
End Function

Private Function RotateLeft(lValue,iShiftBits)
RotateLeft=LShift(lValue,iShiftBits) Or RShift(lValue,(32-iShiftBits))
End Function

Private Function AddUnsigned(lX,lY)
Dim lX4
Dim lY4
Dim lX8
Dim lY8
Dim lResult

lX8=lX And &H80000000
lY8=lY And &H80000000
lX4=lX And &H40000000
lY4=lY And &H40000000

lResult=(lX And &H3FFFFFFF)+(lY And &H3FFFFFFF)

If lX4 And lY4 Then
lResult=lResult Xor &H80000000 Xor lX8 Xor lY8
ElseIf lX4 Or lY4 Then
If lResult And &H40000000 Then
lResult=lResult Xor &HC0000000 Xor lX8 Xor lY8
Else
lResult=lResult Xor &H40000000 Xor lX8 Xor lY8
End If
Else
lResult=lResult Xor lX8 Xor lY8
End If

AddUnsigned=lResult
End Function

Private Function F(x,y,z)
F=(x And y) Or ((Not x) And z)
End Function

Private Function G(x,y,z)
G=(x And z) Or (y And (Not z))
End Function

Private Function H(x,y,z)
H=(x Xor y Xor z)
End Function

Private Function I(x,y,z)
I=(y Xor (x Or (Not z)))
End Function

Private Sub FF(a,b,c,d,x,s,ac)
a=AddUnsigned(a,AddUnsigned(AddUnsigned(F(b,c,d),x),ac))
a=RotateLeft(a,s)
a=AddUnsigned(a,b)
End Sub

Private Sub GG(a,b,c,d,x,s,ac)
a=AddUnsigned(a,AddUnsigned(AddUnsigned(G(b,c,d),x),ac))
a=RotateLeft(a,s)
a=AddUnsigned(a,b)
End Sub

Private Sub HH(a,b,c,d,x,s,ac)
a=AddUnsigned(a,AddUnsigned(AddUnsigned(H(b,c,d),x),ac))
a=RotateLeft(a,s)
a=AddUnsigned(a,b)
End Sub

Private Sub II(a,b,c,d,x,s,ac)
a=AddUnsigned(a,AddUnsigned(AddUnsigned(I(b,c,d),x),ac))
a=RotateLeft(a,s)
a=AddUnsigned(a,b)
End Sub

Private Function ConvertToWordArray(sMessage)
Dim lMessageLength
Dim lNumberOfWords
Dim lWordArray()
Dim lBytePosition
Dim lByteCount
Dim lWordCount

Const MODULUS_BITS=512
Const CONGRUENT_BITS=448

lMessageLength=Len(sMessage)

lNumberOfWords=(((lMessageLength+((MODULUS_BITS-CONGRUENT_BITS)\BITS_TO_A_BYTE))\(MODULUS_BITS\BITS_TO_A_BYTE))+1)*(MODULUS_BITS\BITS_TO_A_WORD)
ReDim lWordArray(lNumberOfWords-1)

lBytePosition=0
lByteCount=0
Do Until lByteCount >=lMessageLength
lWordCount=lByteCount\BYTES_TO_A_WORD
lBytePosition=(lByteCount Mod BYTES_TO_A_WORD)*BITS_TO_A_BYTE
lWordArray(lWordCount)=lWordArray(lWordCount) Or LShift(Asc(Mid(sMessage,lByteCount+1,1)),lBytePosition)
lByteCount=lByteCount+1
Loop

lWordCount=lByteCount\BYTES_TO_A_WORD
lBytePosition=(lByteCount Mod BYTES_TO_A_WORD)*BITS_TO_A_BYTE

lWordArray(lWordCount)=lWordArray(lWordCount) Or LShift(&H80,lBytePosition)

lWordArray(lNumberOfWords-2)=LShift(lMessageLength,3)
lWordArray(lNumberOfWords-1)=RShift(lMessageLength,29)

ConvertToWordArray=lWordArray
End Function

Private Function WordToHex(lValue)
Dim lByte
Dim lCount

For lCount=0 To 3
lByte=RShift(lValue,lCount*BITS_TO_A_BYTE) And m_lOnBits(BITS_TO_A_BYTE-1)
WordToHex=WordToHex & Right("0" & Hex(lByte),2)
Next
End Function

Public Function MD5(sMessage)
Dim x
Dim k
Dim AA
Dim BB
Dim CC
Dim DD
Dim a
Dim b
Dim c
Dim d

Const S11=7
Const S12=12
Const S13=17
Const S14=22
Const S21=5
Const S22=9
Const S23=14
Const S24=20
Const S31=4
Const S32=11
Const S33=16
Const S34=23
Const S41=6
Const S42=10
Const S43=15
Const S44=21

x=ConvertToWordArray(sMessage)

a=&H67452301
b=&HEFCDAB89
c=&H98BADCFE
d=&H10325476

For k=0 To UBound(x) Step 16
AA=a
BB=b
CC=c
DD=d

FF a,b,c,d,x(k+0),S11,&HD76AA478
FF d,a,b,c,x(k+1),S12,&HE8C7B756
FF c,d,a,b,x(k+2),S13,&H242070DB
FF b,c,d,a,x(k+3),S14,&HC1BDCEEE
FF a,b,c,d,x(k+4),S11,&HF57C0FAF
FF d,a,b,c,x(k+5),S12,&H4787C62A
FF c,d,a,b,x(k+6),S13,&HA8304613
FF b,c,d,a,x(k+7),S14,&HFD469501
FF a,b,c,d,x(k+8),S11,&H698098D8
FF d,a,b,c,x(k+9),S12,&H8B44F7AF
FF c,d,a,b,x(k+10),S13,&HFFFF5BB1
FF b,c,d,a,x(k+11),S14,&H895CD7BE
FF a,b,c,d,x(k+12),S11,&H6B901122
FF d,a,b,c,x(k+13),S12,&HFD987193
FF c,d,a,b,x(k+14),S13,&HA679438E
FF b,c,d,a,x(k+15),S14,&H49B40821

GG a,b,c,d,x(k+1),S21,&HF61E2562
GG d,a,b,c,x(k+6),S22,&HC040B340
GG c,d,a,b,x(k+11),S23,&H265E5A51
GG b,c,d,a,x(k+0),S24,&HE9B6C7AA
GG a,b,c,d,x(k+5),S21,&HD62F105D
GG d,a,b,c,x(k+10),S22,&H2441453
GG c,d,a,b,x(k+15),S23,&HD8A1E681
GG b,c,d,a,x(k+4),S24,&HE7D3FBC8
GG a,b,c,d,x(k+9),S21,&H21E1CDE6
GG d,a,b,c,x(k+14),S22,&HC33707D6
GG c,d,a,b,x(k+3),S23,&HF4D50D87
GG b,c,d,a,x(k+8),S24,&H455A14ED
GG a,b,c,d,x(k+13),S21,&HA9E3E905
GG d,a,b,c,x(k+2),S22,&HFCEFA3F8
GG c,d,a,b,x(k+7),S23,&H676F02D9
GG b,c,d,a,x(k+12),S24,&H8D2A4C8A

HH a,b,c,d,x(k+5),S31,&HFFFA3942
HH d,a,b,c,x(k+8),S32,&H8771F681
HH c,d,a,b,x(k+11),S33,&H6D9D6122
HH b,c,d,a,x(k+14),S34,&HFDE5380C
HH a,b,c,d,x(k+1),S31,&HA4BEEA44
HH d,a,b,c,x(k+4),S32,&H4BDECFA9
HH c,d,a,b,x(k+7),S33,&HF6BB4B60
HH b,c,d,a,x(k+10),S34,&HBEBFBC70
HH a,b,c,d,x(k+13),S31,&H289B7EC6
HH d,a,b,c,x(k+0),S32,&HEAA127FA
HH c,d,a,b,x(k+3),S33,&HD4EF3085
HH b,c,d,a,x(k+6),S34,&H4881D05
HH a,b,c,d,x(k+9),S31,&HD9D4D039
HH d,a,b,c,x(k+12),S32,&HE6DB99E5
HH c,d,a,b,x(k+15),S33,&H1FA27CF8
HH b,c,d,a,x(k+2),S34,&HC4AC5665

II a,b,c,d,x(k+0),S41,&HF4292244
II d,a,b,c,x(k+7),S42,&H432AFF97
II c,d,a,b,x(k+14),S43,&HAB9423A7
II b,c,d,a,x(k+5),S44,&HFC93A039
II a,b,c,d,x(k+12),S41,&H655B59C3
II d,a,b,c,x(k+3),S42,&H8F0CCC92
II c,d,a,b,x(k+10),S43,&HFFEFF47D
II b,c,d,a,x(k+1),S44,&H85845DD1
II a,b,c,d,x(k+8),S41,&H6FA87E4F
II d,a,b,c,x(k+15),S42,&HFE2CE6E0
II c,d,a,b,x(k+6),S43,&HA3014314
II b,c,d,a,x(k+13),S44,&H4E0811A1
II a,b,c,d,x(k+4),S41,&HF7537E82
II d,a,b,c,x(k+11),S42,&HBD3AF235
II c,d,a,b,x(k+2),S43,&H2AD7D2BB
II b,c,d,a,x(k+9),S44,&HEB86D391

a=AddUnsigned(a,AA)
b=AddUnsigned(b,BB)
c=AddUnsigned(c,CC)
d=AddUnsigned(d,DD)
Next

MD5=LCase(WordToHex(a) & WordToHex(b) & WordToHex(c) & WordToHex(d))
End Function
[/VBS]

Use it like this
[VBS]
Response.Write MD5("This sentence will be encrypted")
[/VBS]

[SubKamran]

EXACTLY what I need, but how to DECRYPT IT!? I wanna use it for passwords and usernames...

[Kings]

You can't decrypt it, it's one way encryption. If you want to veryify passwords just use the encrypted versions. e.g a user logs in with his password, then you encrypt his password and veryify it against the encrypted password in your database.

[SubKamran]

The problem is, all my passwords are plain text ALREADY in the database...

I COULD write a script to open the database, then update the password with the encrypted password...

Cool. Thanks Kings...

[fillup07]

Originally posted by mulletboy2
I'm working on a rewrite of the script as we speak. I'm making a few enhancements such as error checking, template files etc..

I'll get back to you in a couple of days, but most likely I'll upload a zip to my website for people to download.

How's this coming? I definately could use this. Please link me to where I could download it.