Funky Functions in ASP

**ac070** · Nov 16, 2004, 14:12

Here is another way to convert hex to digit, hex to decimal:

Code:

<% @language="VBScript" %>
<% option explicit %>
<%

  '--------------
  ' Hex2Dgt()
  '------------------------------------------
  ' input:  one hex-char 0..9, a..f, A..F
  ' return: a number 0..15
  ' note: no error-checking
  '------------------------------------------
Function Hex2Dgt(ByVal inHexChar)
  If ( inHexChar <= "9" ) Then
    Hex2Dgt = Asc(inHexChar) - Asc("0")
  Else
    Hex2Dgt = Asc(uCase(inHexChar)) - Asc("A") + 10
  End If
End Function

  '--------------
  ' Hex2Dec()
  '------------------------------------------
  ' input: a Hex string
  ' return:
  '     -2 null string
  '     -1 error (non-hex char)
  '   >= 0 the converted value
  '------------------------------------------
Function Hex2Dec(ByVal inHex)
  
  Dim oREX : Set oREX = New RegExp
  Dim nVal : nVal = 0
  Dim i

    ' test if null-string
    '
  If ( inHex="") Then
    Hex2Dec = -2
    Exit Function
  End If

    ' test any non-hex char
    '
  oREX.Pattern = "[^0-9A-Fa-f]"
  If ( oREX.Test(inHex)) Then
    Hex2Dec = -1
    Exit Function
  End If

    ' now do the conversion
    '
  For i=1 to Len(inHex)
    nVal = nVal * 16 + Hex2Dgt(Mid(inHex,i,1))
  Next

  Hex2Dec = nVal
  set oREX = Nothing

End Function


  ' test
  '
Dim aryHex(6) 
Dim ix

aryHex(0) = "00000000000000000000000000"
aryHex(1) = "7fffffff"            ' max for Hex()
aryHex(2) = "ffffffffffff"        ' 12-f
aryHex(3) = "deadbeef0123456789bad"
aryHex(4) = ""
aryHex(6) = "hex"

For ix=0 to UBound(aryHex)
  Response.Write aryHex(ix) & " : " & Hex2Dec(aryHex(ix)) & "<br/>" & vbCRLF
Next

%>

Results:

Code:

00000000000000000000000000 : 0
7fffffff : 2147483647
ffffffffffff : 281474976710655
deadbeef0123456789bad : 1.68251264662152E+25
: -2
: -2
hex : -1

**Markdidj** · Nov 17, 2004, 12:49

Just a little tip......

Text files are slow to read when using the

Code:

do while textFileOpen.AtEndOfStream=false
text=textFileOpen.readline
loop

method.

It is alot faster if the text file is read all at once and the lines put into an array

Code:

text=split(textFileOpen.readall,vbcrlf)

Which works ALOT faster

**bagadesunil** · Dec 1, 2004, 08:25

searching a character in a particular sentence and the count of it

Function search(pSearch, pSearchStr)
Dim tempSearch, tempSearchStr, startpos, endpos
startpos = 1
Dim ctr
ctr = 0

Do While (startpos > 0)
endpos = InStr(startpos, LCase(pSearch), LCase(pSearchStr))
If endpos > 0 Then
ctr = ctr + 1
startpos = endpos + Len(pSearchStr)
Else
Exit Do
End If
Loop
search = ctr
End Function

**nickcardwell** · Jan 13, 2005, 06:52

Get the user name only (drop domain name)

one line version:
useridonly = MID(request.servervariables("LOGON_USER"), INSTR(USername,"\")+1, LEN(request.servervariables("LOGON_USER")))

USername = request.servervariables("LOGON_USER") ' Get the username
Lenusername = LEN(USername) ' get the length of the username
findslashinst = INSTR(USername,"\") 'find out where abouts the \ is
findslashinst = findslashinst + 1 ' increment the value so it starts where the actual userid is.
useridonly = MID(USername, findslashinst,lenusername) ' extract the userid only

Si · Feb 21, 2005, 09:40

I've just built this little function for printing the date that the current document was last saved (maybe useful for static content on an ASP page):

Code:

 function lastUpdated
 
 	Set fso = CreateObject("Scripting.FileSystemObject")
 	thispage = replace(request.ServerVariables("URL"), "/", "\")
 	Set fileObject = fso.GetFile(server.MapPath(thispage))
 		datemodified = fileObject.DateLastModified
 		lastUpdated = (FormatDateTime(datemodified,1))
 	Set fileObject = Nothing
 	Set fso = Nothing 
 
 end function
 
 ' usage:
 Response.write ("Last Updated: " & lastUpdated)

**RhythmAddict** · Mar 10, 2005, 13:59

Hey everyone!
A couple of simlpe ones I use pretty often..

Convert a mm/dd/yy or mm/dd/yyyy Oracle date format that is...DD-MMM-YY

Code:

Function OracleDate( dt ) 
	dt = CDate( dt ) ' just to be sure 
    OracleDate = Right( "0" & Day(dt), 2 ) & "-" _ 
                     & UCase( MonthName(Month(dt), True) ) & "-" _ 
                     & Year(dt)
End Function

I didn't write this one, but one of the developers here did and it's convenient..
I thnik you could use the getRows() method and do a couple of other things to optimize but..

Code:

Function xdirlookup(uid, fld)
Dim conn, cmd, rs, i
	Set conn = CreateObject("ADODB.Connection")
	Set cmd = CreateObject("ADODB.Command")
	conn.Provider = "ADSDSOObject"
	conn.Open "Active Directory Provider","DC=domainName,CN=ValidAccount","AccountPassword"
	Set cmd.ActiveConnection = conn
	cmd.CommandText = "<LDAP://yourLdapServer>;(&(objectClass=organizationalPerson)(uid=" & uid & "));uid,sn,givenName,mail;subtree"
	Set rs = cmd.Execute
	
	If (Not (rs.EOF And rs.BOF)) Then
		xdirlookup = rs.Fields(fld).Value
	End If
End Function

Runs an A/D lookup given domainId, Field you want to return.
Real handy if you do something like...

Code:

dim myVar
myVar = dirLookUp(Right(Trim(Request.ServerVariables ("AUTH_USER")), iLength), 1)

here are a bunch more ADSI related functions/subs..
http://www.15seconds.com/issue/020130.htm

Yet another function to remove special chars..

Code:

Function RemQuotes(pString)
	if Not IsNull(pString) then 
		RemQuotes =  Replace(Replace(Replace(Replace(Replace(pString,";","-"),"'","''"),"&"," and "),"""",""),",","")  
	else RemQuotes = pString end if
End Function

Function returns true/false..checks to see if it is daylights savings time...
..I didnt write this!

Code:

Private Function CheckDayLightSavings(dtDateTime)
	'Author: Olin Hamilton
	'
	'Email:  olin@oct.net
	'
	'Pupose: This function returns true if a passed datetime value is in Daylight Savings time,
	'		 Returns false if the datetime value is in Standard Time
	'
	'Usage:  Use a date, or datetime formatted string as the parameter
	'		 If the parameter is not a valid date, the function will return False
	'		 If no Time part is passed with the string, it will assume the time is after
	'		 2 AM, so would return true on the first sunday of April, and False on the last Sunday in October.
	'		 Since a null time part for a datetime value defaults to exactly "00:00:00", if a date is passed with 
	'		 a time value equal to "00:00:00" the function will assume that the time value was not passed
	'		 and that the time is after 2 Am.  This may cause unexpected results if you are passing a valid datetime
	'		 value with a time value of exactly midnight.  Unfortunately, I could not think of any other way to handle
	'		 no time values, and figured it was best to consider it past 2AM.  
	'		 However, you can control this limitation by checking the time value for the date before passing it
	'		 to this function, and if it has a time value of "00:00:00", increasing it by one second will cause
	'		 the function to accurately return false if the date is the start day for DST,
	'		 or return True if it's the end day for DST.
	'		 If there are any questions, suggestions, comments, or modifications made, 
	'        please send me an email letting me know.
	
	Dim retVal, x, sTempDate
	'if the date time has the milliseconds, clean them off
	If InStr(1,CStr(dtDateTime),".") <> 0 Then
		dtDateTime = Left(dtDateTime, Len(dtDateTime) - 4)
	End If
	
	'If the passed string is a valid date, let's begin checking, otherwise
	'just return False.
	If IsDate(dtDateTime) Then
		'We know what to do with any dates within these months
		If Month(dtDateTime) <> 10 And Month(dtDateTime) <> 4 Then
			Select Case Month(dtDateTime)
				'Jan
				Case 1
					retVal = False
				'Feb
				Case 2
					retVal = False
				'Mar
				Case 3
					RetVal = False
				'May
				Case 5 
					retVal = True
				'Jun
				Case 6
					retVal = True
				'Jul
				Case 7
					retVal = True
				'Aug
				Case 8
					retVal = True
				'Sep
				Case 9
					retVal = True
				'Nov
				Case 11
					retVal = False
				'Dec
				Case 12
					retVal = False
			End Select	
		Else
			'If the month is April, let's check to see if the date is before or after
			'2 AM on the first Sunday of the month
			If Month(dtDateTime) = 4 Then
				If Day(dtDateTime) < 8 Then
					For x = 1 To Day(dtDateTime)
						sTempDate = CStr(Month(dtDateTime)) & "/" & x & "/" & CStr(Year(dtDateTime))
						If Weekday(sTempDate) = 1 Then
							If Day(sTempDate) < Day(dtDateTime) Then
								'First sunday in April has already passed, so we are now in DST
								retVal = True
								Exit For
							Else
								'It's the first Sunday in April!
								'Let's see if it's past 2 AM. If there is no time part in dtDateTime (time part = "00:00:00"), 
								'we are going to assume it's past 2 AM
								If (Hour(dtDateTime) >= 2) Or (Hour(dtDateTime) = 0 And Minute(dtDateTime) = 0 And Second(dtDateTime) = 0) Then
									retVal = True
									Exit For
								Else
									retVal = False
								End If
							End If
						Else 
							retVal = False
						End If 
					Next
				Else
					'we know what to do if the day is equal to or greater than the 8th
					retval = True
				End If
			'If the month is October, let's check to see if date is before or after
			'2 AM on the last Sunday of the month
			ElseIf Month(dtDateTime) = 10 Then
				'We know what to do if the day is less than then 25th
				If Day(dtDateTime) < 25 Then
					retval = True
				Else
					For x = 25 To Day(dtDateTime)
						sTempDate = CStr(Month(dtDateTime)) & "/" & x & "/" & CStr(Year(dtDateTime))
						If Weekday(sTempDate) = 1 Then
							If Day(sTempDate) < Day(dtDateTime) Then
								'last sunday in oct has already passed, so we aren't in DST anymore
								retVal = False
								Exit For
							Else
								'It's the last Sunday in October!
								'Let's see if it's past 2 AM. If there is no time part in dtDateTime (time part = "00:00:00"), 
								'we are going to assume it's past 2 AM
								If (Hour(dtDateTime) >= 2) Or (Hour(dtDateTime) = 0 And Minute(dtDateTime) = 0 And Second(dtDateTime) = 0) Then
									retVal = False
									Exit For
								Else
									retVal = True
								End If
							End If
						Else 
							retVal =True
						End If 
					Next
				End If
			End If
		End If
	Else 
		'if the string passed to the function is not a valid date, let's return false.
		retVal = False	
	End If
	CheckDayLightSavings = retVal
End Function

show an array in at table (think this works for multidimensional..but havent used it in awhile)

Code:

Sub ShowArrayInTable(ArrayToShow)
	Dim I           ' Simple Looping Var
	Dim iArraySize  ' Var to store array size

	' If you want to know how big an array is, you can use this
	' to find out. This even works in VB where they don't have
	' to be zero-based.  The LBound and UBound return the
	' indecies of the lowest and highest array elements so to
	' get the size we take the difference and add one since you
	' can store a value at both end points.
	iArraySize = (UBound(ArrayToShow) - LBound(ArrayToShow)) + 1

	Response.Write "<p>The array has " & iArraySize _
		& " elements.  They are:</p>" & vbCrLf
	
	Response.Write "<table border=""1"">" & vbCrLf

	Response.Write "<thead>" & vbCrLf
	Response.Write "<tr>" & vbCrLf
	Response.Write "<th>Index</th>" & vbCrLf
	Response.Write "<th>Value</th>" & vbCrLf
	Response.Write "</tr>" & vbCrLf
	Response.Write "</thead>" & vbCrLf

	Response.Write "<tbody>" & vbCrLf
	
	' Simple loop over a table outputting a row for each element
	For I = LBound(ArrayToShow) To UBound(ArrayToShow)
		Response.Write "<tr>" & vbCrLf
		' Write out the index of the element we're currently on
		Response.Write "<td>" & I & "</td>" & vbCrLf
		' Write out the value of the element we're currently on
		Response.Write "<td>" & ArrayToShow(I) & "</td>" & vbCrLf
		Response.Write "</tr>" & vbCrLf
	Next 'I
	Response.Write "</tbody>" & vbCrLf

	Response.Write "</table>" & vbCrLf
End Sub

didnt write that one either!
Enjoy!

**wavman** · Apr 6, 2005, 03:49

Date format. Had a look through and can't see a function to make a date into the format YYYY-MM-DD HH:MI:SS

Anyone got one? Or can the built in functions do it?

Cheers

**awasson** · Apr 7, 2005, 10:09

I've never had need of this function because ASP handles time a bit diffferently than *nix scripting languages like PHP but here's a quick and dirty function you can use:

Code:

  <%
  function XnixTime(thetime)
  	if thetime = "" then thetime = now()
  	XnixTime = year(thetime) & "-"_ 
  			& month(thetime) & "-"_ 
  			& day(thetime) & " "_ 
  			& hour(thetime) & ":"_ 
  			& minute(thetime) & ":"_ 
  			& second(thetime)
  end function
  %>

Use it as follows:
<%=XnixTime("")%>
or
<%=XnixTime("4/7/2005 9:39:25")%>

It's not pretty but it should do the job. It would be even better made into a class.

**mcjimbo** · Apr 12, 2005, 10:04

This is a great thread, here are a number of functions i use on a regular basis:

Cleans string of unwanted chars:

Code:

<%
Function cleanString(strInput)
  Dim regEx
' Create a regular expression
  Set regEx = New RegExp

' Match any character NOT in this list
  'regEx.Pattern="abcdefghijklmnopqrstuvwxyz.1234567890_-"
  regEx.Pattern = "[`¬¦!£$%^&*()+=#~'@;:?/><,/*|\}{]"
  regEx.IgnoreCase = True
  regEx.Global = True
  strInput=RMSpace(strInput)
' Replace matches with zero length string
  cleanString = regEx.Replace(strInput, "")
End Function
%>

Fixes issue of Line breaks not being interpreted with plain text:

Code:

<%
'************ "LBR" Inserts line breaks into a text string ************
Function LBR( strText )
if len(strText) <> 0 then
	LBR = Replace( strText, chr(13), "<br>" )
else LBR=strText
end if
End Function
%>

Strips HTML code from string:

Code:

<%
'************ "RemoveHTML" Strips any HTML from a text string ************
Function RemoveHTML( strText )
	Dim RegEx
	Set RegEx = New RegExp
	RegEx.Pattern = "<[^>]*>"
	RegEx.Global = True
	strText = Replace(LCase(strText), "<br>", chr(10))
	RemoveHTML = RegEx.Replace(strText, "")
End Function
%>

This function is great, capitlizes first letter of everyone, useful on forms where getting name and address information:

Code:

<%
'************ "Pcase" This function capitalizes the first letter of each word ************
Function PCase(strInput)
    Dim iPosition ' Our current position in the string (First character = 1)
    Dim iSpace ' The position of the next space after our iPosition
    Dim strOutput ' Our temporary string used to build the function's output

    iPosition = 1

    Do While InStr(iPosition, strInput, " ", 1) <> 0
            iSpace = InStr(iPosition, strInput, " ", 1)
            strOutput = strOutput & UCase(Mid(strInput, iPosition, 1))
            strOutput = strOutput & LCase(Mid(strInput, iPosition + 1, iSpace - iPosition))
            iPosition = iSpace + 1
    Loop

    strOutput = strOutput & UCase(Mid(strInput, iPosition, 1))
    strOutput = strOutput & LCase(Mid(strInput, iPosition + 1))

    PCase = strOutput
End Function
%>

Great function to shorten a string by adding a trailing ... after specified number of chars:

Code:

<%
'************ "clipText" Reduces length of text to 15 chars + adds "..." to end to symbolise more text to be displayed ************
Function clipText (strTheText) 
if Len(strTheText) > 50 then strTheText = Left(strTheText, 50) & " ..." 
clipText = strTheText 
End Function 
%>

**jimfraser** · Apr 22, 2005, 13:06

This is something I developed to sort XML in asp and return a node object. It's by no means perfect but it does work rather well if you are careful

I use Microsoft's MSXML object - I've tested it with MSXML4 SP2.

Code:

Function SortXML(oMain, sXPath, sBy)
	Dim oSS, oNS, sName, aSortBy, aSortField, aSortFieldType, aSortFieldDirection, sXSL

	Set oSS = Server.CreateObject("MSXML.DOMDocument")
	Set oNS = Server.CreateObject("MSXML.DOMDocument")

	sName = oMain.nodeName

	aSortBy = Split(sBy, ",")
	
	aSortField = Split(aSortBy(0), "\")
	aSortFieldType = Split(aSortBy(1), "\")
	aSortFieldDirection = Split(aSortBy(2), "\")

	If UBound(aSortFieldType) <> UBound(aSortField) Or UBound(aSortFieldDirection) <> UBound(aSortField) Then
		Response.Write "Coding error - there must be the same number of sort elements"
	Else
	
		sXSL = "<?xml version='1.0'?>" & _
			"<xsl:stylesheet version=""1.0"" xmlns:xsl=""http://www.w3.org/1999/XSL/Transform"">" & _
			"<xsl:template match=""" & sName & """>" & _
			"<" & sName & ">" & _
			"<xsl:apply-templates select=""" & sXPath & """>"
		
		For i = 0 To UBound(aSortField)
			sXSL = sXSL & "<xsl:sort select="""	& aSortField(i) & """ order=""" & aSortFieldDirection(i) & """ data-type=""" & aSortFieldType(i) & """/>"
		Next
		
		sXSL = sXSL & "</xsl:apply-templates>" & _
		"</" & sName & ">" & _
		"</xsl:template>" & _
		"<xsl:template match=""* | @* | node()"">" & _
	   	"<xsl:copy><xsl:apply-templates select=""@* | node()""/></xsl:copy>" & _
	  	"</xsl:template>" & _
		"</xsl:stylesheet>"

		oSS.async = false 
		oSS.loadXML sXSL
		
		oMain.transformNodeToObject oSS, oNs
		
	End If

	Set SortXML = oNs

End Function

Syntax:

Set oSortedNode = SortXML(oNode, sXPath, sSort)

oNode (IXMLDOMNode) - the containing node of the nodes you wish to sort
sXPath (String) - an XPath expression to select from oNode the nodes you want to sort
sSort (String) - a sort by expression, comma separated, including the criteria to sort, the type of data and the sort direction (see example)

Sample XML:

Code:

<?xml version="1.0" ?>
<main>
	<item id="1" title="President">
		<name>Bill</name>
		<lname>Smith</lname>
	</item>
	<item id="2" title="Director of Sales">
		<name>Sarah</name>
		<lname>Smith</lname>
	</item>
	<item id="3" title="Operations Manager">
		<name>George</name>
		<lname>Jones</lname>
	</item>
	<item id="4" title="Floor Sweeper">
		<name>Pete</name>
		<lname>Pobahushi</lname>
	</item>
</main>

EXAMPLES:
Let's do a simple sort by the attribute "title":
Set oSorted = SortXML(oDOM.selectSingleNode("main"), "item", "@title,text,ascending")

And by id:
Set oSorted = SortXML(oDOM.selectSingleNode("main"), "item", "@id,number,ascending")

Now, let's sort by lastname and firstname:
Set oSorted = SortXML(oDOM.selectSingleNode("main"), "item", "lname\name,text\text,ascending\ascending")
(see how I used \ to delimit the separate sort fields etc)

Finally, sort by firstname and lastname but only select records with id less than 3:
Set oSorted = SortXML(oDOM.selectSingleNode("main"), "item[@id &lt '3']", "name\lname,text\text,ascending\descending")

There you have it. It's not perfect but it works - any suggestions welcome.

Jim

**PuritysDisciple** · Jun 21, 2005, 08:43

Here is my library. I use PHP a lot and have brought some nice functions over to ASP

Functions:
printr_r - will display all of the data in an array. Supports Infinate demensions as well as dictionaries.
IsArray - returns true or false whether the variable is an array
IsDictionary - returns true or false whether the variable is a dictionary
MakeTimestamp - returns a timestamp from a datetime
UnMakeTimestamp - returns a datetime from a timestamp
DateFormat - returns a date that is formatted to your liking
DebugMode - returns true or false based on ?debug=1 in the URL
AddSlashes - makes a string usable in SQL by doubling quotes from ' to ''
RunQuery - runs a query on the specified database and returns an array of dictionaries containing the results of a query
RunNonQuery - runs a query on the specified database and returns nothing
ShowSQLError - neatly displays an sql error that occured in RunQuery or RunNonQuery
SQLDump - displays a table with all of the data from a RunQuery (may also use print_r for a pure text display)
echo - response.write with a line break at the end to help with code formatting

Code:

<%
'Used by the check form functions
dim forms
dim errors

'Used to store SQL errors
dim sqlerr
set sqlerr = Server.CreateObject("Scripting.Dictionary")

'When false sql errors will be displayed only by manual request
'When true sql errors will be displayed when they occur
dim AUTO_SQL_ERROR
AUTO_SQL_ERROR = false


function AddSlashes(str)
	AddSlashes = replace(str,"'","''")
end function

'Checks the URL for ?debug=1 allows for setting up debug sections
function DebugMode()
	if request.querystring("debug") = 1 then
		DebugMode = true
	else
		DebugMode = false
	end if
end function

'Runs an query does not use the global.asa but allows selection of any database.
'returns a 2 dementional array
'	array(rownumber)("colname")
'	ex: arr(0)("APTCODE")
'allows for all caps and all lowercase colnames all others will not be shown
'if an error occurs it will set the sqlerr variable with all of the information
function RunQuery(sql,database)
	srv = "yourserver"
	uid = "yourusername"
	pwd = "yourpassword"
	connect = "DRIVER={SQL Server};SERVER="&srv&";DATABASE="&database&";UID="&uid&";PWD="&pwd
	sqlerr.RemoveAll

	set RQRS = Server.CreateObject("ADODB.RecordSet")

	on error resume next
	RQRS.Open sql,connect
		
	if err.number > 0 then
		sqlerr.Add "err",true
		sqlerr.Add "num",err.number
		sqlerr.Add "desc",err.Description
		sqlerr.Add "sql",sql
		if AUTO_SQL_ERROR then
			show = ShowSQLError()
		end if
	else
		sqlerr.Add "err",false
	end if
	
	If Err.number <> 0 or temp = -1 Then
		Err.Clear
		RunQuery = false
	else
		RQArr = array()

		do until RQRS.EOF
			if UBOUND(RQArr) = -1 then
				redim preserve RQArr(0)
			else
				redim preserve RQArr(UBOUND(RQArr)+1)
			end if
			set RQArr(UBOUND(RQArr)) = Server.CreateObject("Scripting.Dictionary")
				for stlctr = 0 to RQRS.Fields.count - 1
				key = replace(lcase(RQRS.Fields(stlctr).Name)," ","_")
				val = RQRS.Fields(stlctr)

				if not IsNumeric(key) then
					RQArr(UBOUND(RQArr)).Add lcase(key),val
					RQArr(UBOUND(RQArr)).Add ucase(key),val
				else
					RQArr(UBOUND(RQArr)).Add lcase(key),val
				end if
			next
			RQRS.MoveNext
		loop
		RQRS.Close

		set RQRS = nothing
		RunQuery = RQArr
		set RQArr = nothing
	End If
	On Error Goto 0
end function

'Displays a nice clean description of the error that occured when a query was run.
function ShowSQLError()
	echo "<div style='background: #FFE6E6; border: 1px solid #FDA6A6; padding: 5px; font: 12px verdana; color: #000000;'>"
	echo "	<b>Number:</b> "&sqlerr("num")&"<br>"
	echo "	<b>Description:</b> "&sqlerr("desc")&"<br>"
	echo "	<b>SQL:</b> "&sqlerr("sql")
	echo "</div>"
end function

'Runs the same as RunQuery but does not return anything
function RunNonQuery(sql,database)
	srv = "yourserver"
	uid = "yourusername"
	pwd = "yourpassword"
	connect = "DRIVER={SQL Server};SERVER="&srv&";DATABASE="&database&";UID="&uid&";PWD="&pwd
	sqlerr.RemoveAll

	set RQRS = Server.CreateObject("ADODB.RecordSet")
	on error resume next
	RQRS.Open sql,connect

	if err.number > 0 then
		sqlerr.Add "err",true
		sqlerr.Add "num",err.number
		sqlerr.Add "desc",err.Description
		if AUTO_SQL_ERROR then
			show = ShowSQLError()
		end if
	else
		sqlerr.Add "err",false
	end if

	set RQRS = nothing
	RunNonQuery = ""
	set RQArr = nothing
	on error goto 0
end function

'This will loop through the array supplied by RunQuery and will display a table of all the data that is in the array
function SqlDump(obj)
	if IsArray(obj) = true then
		response.write("<table border=1 cellpadding=3 cellspacing=0 bordercolor='#000000'><tr>")
		for each stlctr2 in obj(0)
			response.write("<td>"&stlctr2&"</td>")
		next
		response.write("</tr>")
		for stlctr = 0 to Ubound(obj)
			response.write("<tr>")
			for each stlctr2 in obj(stlctr)
				if len(obj(stlctr)(stlctr2)) < 100 then
					response.write("<td nowrap>&nbsp;"&obj(stlctr)(stlctr2)&"</td>")
				else
					response.write("<td nowrap>Long Text</td>")
				end if
			next
			response.write("</tr>")
		next
		response.write("</table>")
	else
		response.write("no data<br><br>")
	end if
end function

'Outputs normally, but adds a line break at the end of the string to help formating
function echo(str)
	response.write(str&vbcrlf)
end function

'Returns true if it is an array false if it is not
function IsArray(arr)
	on error resume next
	temp = ubound(arr)
	If Err.number <> 0 or temp = -1 Then
		IsArray = false
		Err.Clear
	else
		IsArray = true
	End If
	On Error Goto 0
end function

'Adds a value to an array. This avoids the need for redim
function AddArray(byref arr,newval)
	dim ctr
	dim newarr

	newarr = arr
	if not IsArray(arr) then
		redim arr(0)
		arr(0) = newval
	else
		redim preserve arr(ubound(arr)+1)
		arr(ubound(arr)) = newval
	end if
end function

'Used by Print_r
function Echor(arr,tablevel)
	if tablevel = 0 then
		echo "Array"
		echo "("
	end if

	dim ctr
	
	if not IsDictionary(arr) and not IsArray(arr) then
	else
		if IsDictionary(arr) then
			for each ctr in arr
				for tabs = 0 to ((tablevel+1)*4)
					response.write(" ")
				next
					
				if IsArray(arr(ctr)) = true then
					echo "["&ctr&"] => Array("
					x = Echor(arr(ctr),(tablevel+1))
					for tabs = 0 to ((tablevel+1)*4)
						response.write(" ")
					next
					echo ")"
				else
					if IsDictionary(arr(ctr)) then
						echo "["&ctr&"] => dictionary("
						x = Echor(arr(ctr),(tablevel+1))
						for tabs = 0 to ((tablevel+1)*4)
							response.write(" ")
						next
						echo ")"
					else
						echo "["&ctr&"] => {"&arr(ctr)&"}"
					end if
				end if
			next
		else
			for ctr=0 to ubound(arr)
				for tabs = 0 to ((tablevel+1)*4)
					response.write(" ")
				next
		
				if IsArray(arr(ctr)) = true then
					echo "["&ctr&"] => Array("
					x = Echor(arr(ctr),(tablevel+1))
					for tabs = 0 to ((tablevel+1)*4)
						response.write(" ")
					next
					echo ")"
				else
					if IsDictionary(arr(ctr)) then
						echo "["&ctr&"] => dictionary("
						x = Echor(arr(ctr),(tablevel+1))
						for tabs = 0 to ((tablevel+1)*4)
							response.write(" ")
						next
						echo ")"
					else
						echo "["&ctr&"] => {"&arr(ctr)&"}"
					end if
				end if
			next
		end if
	end if

	if tablevel = 0 then
		echo ")"
	end if
end function

'Checks to see if the variable is a Scripting.Dictionary
'returns true if it is, false if it is not
function IsDictionary(dictionary)
	on error resume next
	for each i in dictionary
		x = dictionary(i)
		
		if err.number > 0 then
			IsDictionary = false
			on error goto 0
			exit function
		else
			IsDictionary = true
			on error goto 0
			exit function
		end if
	next
	on error goto 0
end function

'will display the contents of the supplied array. Used for debugging purposes
'	Array(
'			[0] = a
'			[1] = b
'			[2] = c
'			[3] = Array (
'							[0] = aa
'							[1] = bb
'							[2] = cc
'						)
'		 }
function Print_r(arr)
	x = echor(arr,0)
end function

'Returns a Unix Timestamp
function MakeTimestamp(datetime)
	MakeTimestamp = DateDiff("s", "01/01/1970 00:00:00", datetime)
end function

'Returns a datetime
function UnMakeTimestamp(timestamp)
	UnMakeTimestamp = DateAdd("s",timestamp, "01/01/1970 00:00:00")
end function

'used by DateFormat
function AddZeros(num,length)
	str = num
	if len(str) <> length then
		while len(str) <> length
			str = "0"&str
		wend
	end if
	AddZeros = str
end function


'This function takes in a date or a timestamp as well as a format and will return the date in the specified format
'	ex: DateFormat("1/1/2005","%M %j %Y") would return Jan 1 2005
function DateFormat(datetime,format)
	if IsNumeric(datetime) then
		datein = UnMakeTimestamp(datetime)
	else
		if IsDate(datetime) then
			datein = datetime
		else
			DateFormat = "date invalid"
			exit function
		end if
	end if

	arr = split(datein," ")
	arr2 = split(arr(0),"/")
	arr3 = split(arr(1),":")

	amlow = lcase(arr(2))
	amup = ucase(arr(2))
	m = AddZeros(arr2(0),2)
	m2 = arr2(0)
	mname = monthname(arr2(0))
	mshortname = left(monthname(arr2(0)),3)
	d = AddZeros(arr2(1),2)
	d2 = arr2(1)
	hsmall = AddZeros(arr3(0),2)
	hsmall2 = arr3(0)

	if amlow = "pm" then
		hbig = AddZeros(arr3(0)+12,2)
		hbig2 = arr3(0)+12
	else
		hbig = AddZeros(arr3(0),2)
		hbig2 = arr3(0)
	end if

	mn = AddZeros(arr3(1),2)
	mn2 = arr3(1)
	s = AddZeros(arr3(2),2)
	s2 = arr3(2)
	y = right(arr2(2),2)
	y2 = arr2(2)

	format = replace(format,"%A",amlow)			'%A - AM or PM
	format = replace(format,"%a",amup)			'%a - am or pm
	format = replace(format,"%m",m)				'%m - Month with leading zeroes (01 - 12)
	format = replace(format,"%n",m2)			'%n - Month without leading zeroes (1 - 12)
	format = replace(format,"%F",mname)			'%F - Month name (January - December)
	format = replace(format,"%M",mshortname)	'%M - Three letter month name (Jan - Dec)
	format = replace(format,"%d",d)				'$d - Day with leading zeroes (01 - 31)
	format = replace(format,"%j",d2)			'%j - Day without leading zeroes (1 - 31)
	format = replace(format,"%H",hsmall)		'%H - Hour with leading zeroes (12 hour)
	format = replace(format,"%h",hbig)			'%h - Hour with leading zeroes (24 hour)
	format = replace(format,"%G",hsmall2)		'%G - Hour without leading zeroes (12 hour)
	format = replace(format,"%g",hbig2)			'%g - Hour without leading zeroes (24 hour)
	format = replace(format,"%i",mn)			'%i - Minute with leading zeroes (01 to 60)
	format = replace(format,"%I",mn2)			'%I - Minute without leading zeroes (1 to 60)
	format = replace(format,"%s",s)				'%s - Second with leading zeroes (01 to 60)
	format = replace(format,"%S",s2)			'%S - Second without leading zeroes (1 to 60)
	format = replace(format,"%y",y)				'%y - Two digit year (03)
	format = replace(format,"%Y",y2)			'%Y - Four digit year (2003)

	DateFormat = format
end function

'This function is used with CheckForm
'typein is a regex used to test the value
'fail is the message to display when the value fails the test
function RegisterForm(namein,test,errname,fail)
	AddArray forms,array(namein,test,errname,fail)
end function

'This function is used with CheckForm
'namein is the name of the field
'fail is the message to display
function RegisterError(namein,errname,fail)
	AddArray errors,array(namein,errname,fail)
end function

'This function builds an array full of the errors that were contained in the array
'created by RegisterForm. If the IsArray(errors) then the form contained errors.
function CheckForm()
	set regex = new regexp
	regex.Global = true
	regex.IgnoreCase = true

	if IsArray(forms) then
		for frmctr = 0 to ubound(forms)
			regex.Pattern = forms(frmctr)(1)
			if not regex.Test(request.form(forms(frmctr)(0))) then
				err = RegisterError(forms(frmctr)(0),forms(frmctr)(2),forms(frmctr)(3))
			end if
		next
	end if
end function
%>

**asprookie** · Jun 22, 2005, 13:16

Originally Posted by hillsy

A function to list all files in a site, with hyperlinks. Useful for search engine crawlers or links pages. I asked about one of these a long time ago and eventually had to write my own

Code:

<%
	Dim objFileScripting, objFolder, strDirectoryPath

	' Subroutine to recursively list the contents of any subfolders
	Sub IterateThroughDirectory(objFolder, strUrlPathName)
		Dim objFileCollection
		Dim strFilename
		Dim objSubFolder

		' Return file collection in folder
		Set objFileCollection = objFolder.Files

		' Create the links
		For Each strFilename In objFileCollection
			strFilename = Right(strFilename, Len(strFilename) - InStrRev(strFilename, "\"))
			Response.Write "<li><a href=""" & strUrlPathName & strFileName & """>" & strFileName & "</a>" & vbCrLf
		Next

		' Now that we've processed root files, do it for all the subdirectories
		For Each objSubFolder in objFolder.SubFolders
			IterateThroughDirectory objSubFolder, strUrlPathName & objSubFolder.Name & "/"
		Next

		' Close the file collection
		Set objFileCollection = Nothing
	End Sub

	' Get file scripting object
	Set objFileScripting = CreateObject("Scripting.FileSystemObject")

	' Dynamically assign the filesystem path
	' Allows the script to use different physical dirs where logical URL path remains the same
	strDirectoryPath = Server.MapPath("/site root directory/") & "\"

	' Return folder object
	Set objFolder = objFileScripting.GetFolder(strDirectoryPath)

	' Call the subroutine
	IterateThroughDirectory objFolder, ""

	' Close all of the open objects
	Set objFolder = Nothing
	Set objFileScripting = Nothing
%>

Put it between <ol> tags for best effect.

I've put it between <ol> </ol> tags in a file at the root directory, it's not working, what do I have to change in your code to have it work on my website?

**jwadeo** · Sep 6, 2005, 14:45

Are you aware that you are redefining isArray() and DateFormat() in vbscript with your IsArray and DateFormat function below?

Originally Posted by PuritysDisciple

Here is my library. I use PHP a lot and have brought some nice functions over to ASP

Functions:
printr_r - will display all of the data in an array. Supports Infinate demensions as well as dictionaries.
IsArray - returns true or false whether the variable is an array
IsDictionary - returns true or false whether the variable is a dictionary
MakeTimestamp - returns a timestamp from a datetime
UnMakeTimestamp - returns a datetime from a timestamp
DateFormat - returns a date that is formatted to your liking
DebugMode - returns true or false based on ?debug=1 in the URL
AddSlashes - makes a string usable in SQL by doubling quotes from ' to ''
RunQuery - runs a query on the specified database and returns an array of dictionaries containing the results of a query
RunNonQuery - runs a query on the specified database and returns nothing
ShowSQLError - neatly displays an sql error that occured in RunQuery or RunNonQuery
SQLDump - displays a table with all of the data from a RunQuery (may also use print_r for a pure text display)
echo - response.write with a line break at the end to help with code formatting

Code:

<%
'Used by the check form functions
dim forms
dim errors

'Used to store SQL errors
dim sqlerr
set sqlerr = Server.CreateObject("Scripting.Dictionary")

'When false sql errors will be displayed only by manual request
'When true sql errors will be displayed when they occur
dim AUTO_SQL_ERROR
AUTO_SQL_ERROR = false


function AddSlashes(str)
	AddSlashes = replace(str,"'","''")
end function

'Checks the URL for ?debug=1 allows for setting up debug sections
function DebugMode()
	if request.querystring("debug") = 1 then
		DebugMode = true
	else
		DebugMode = false
	end if
end function

'Runs an query does not use the global.asa but allows selection of any database.
'returns a 2 dementional array
'	array(rownumber)("colname")
'	ex: arr(0)("APTCODE")
'allows for all caps and all lowercase colnames all others will not be shown
'if an error occurs it will set the sqlerr variable with all of the information
function RunQuery(sql,database)
	srv = "yourserver"
	uid = "yourusername"
	pwd = "yourpassword"
	connect = "DRIVER={SQL Server};SERVER="&srv&";DATABASE="&database&";UID="&uid&";PWD="&pwd
	sqlerr.RemoveAll

	set RQRS = Server.CreateObject("ADODB.RecordSet")

	on error resume next
	RQRS.Open sql,connect
		
	if err.number > 0 then
		sqlerr.Add "err",true
		sqlerr.Add "num",err.number
		sqlerr.Add "desc",err.Description
		sqlerr.Add "sql",sql
		if AUTO_SQL_ERROR then
			show = ShowSQLError()
		end if
	else
		sqlerr.Add "err",false
	end if
	
	If Err.number <> 0 or temp = -1 Then
		Err.Clear
		RunQuery = false
	else
		RQArr = array()

		do until RQRS.EOF
			if UBOUND(RQArr) = -1 then
				redim preserve RQArr(0)
			else
				redim preserve RQArr(UBOUND(RQArr)+1)
			end if
			set RQArr(UBOUND(RQArr)) = Server.CreateObject("Scripting.Dictionary")
				for stlctr = 0 to RQRS.Fields.count - 1
				key = replace(lcase(RQRS.Fields(stlctr).Name)," ","_")
				val = RQRS.Fields(stlctr)

				if not IsNumeric(key) then
					RQArr(UBOUND(RQArr)).Add lcase(key),val
					RQArr(UBOUND(RQArr)).Add ucase(key),val
				else
					RQArr(UBOUND(RQArr)).Add lcase(key),val
				end if
			next
			RQRS.MoveNext
		loop
		RQRS.Close

		set RQRS = nothing
		RunQuery = RQArr
		set RQArr = nothing
	End If
	On Error Goto 0
end function

'Displays a nice clean description of the error that occured when a query was run.
function ShowSQLError()
	echo "<div style='background: #FFE6E6; border: 1px solid #FDA6A6; padding: 5px; font: 12px verdana; color: #000000;'>"
	echo "	<b>Number:</b> "&sqlerr("num")&"<br>"
	echo "	<b>Description:</b> "&sqlerr("desc")&"<br>"
	echo "	<b>SQL:</b> "&sqlerr("sql")
	echo "</div>"
end function

'Runs the same as RunQuery but does not return anything
function RunNonQuery(sql,database)
	srv = "yourserver"
	uid = "yourusername"
	pwd = "yourpassword"
	connect = "DRIVER={SQL Server};SERVER="&srv&";DATABASE="&database&";UID="&uid&";PWD="&pwd
	sqlerr.RemoveAll

	set RQRS = Server.CreateObject("ADODB.RecordSet")
	on error resume next
	RQRS.Open sql,connect

	if err.number > 0 then
		sqlerr.Add "err",true
		sqlerr.Add "num",err.number
		sqlerr.Add "desc",err.Description
		if AUTO_SQL_ERROR then
			show = ShowSQLError()
		end if
	else
		sqlerr.Add "err",false
	end if

	set RQRS = nothing
	RunNonQuery = ""
	set RQArr = nothing
	on error goto 0
end function

'This will loop through the array supplied by RunQuery and will display a table of all the data that is in the array
function SqlDump(obj)
	if IsArray(obj) = true then
		response.write("<table border=1 cellpadding=3 cellspacing=0 bordercolor='#000000'><tr>")
		for each stlctr2 in obj(0)
			response.write("<td>"&stlctr2&"</td>")
		next
		response.write("</tr>")
		for stlctr = 0 to Ubound(obj)
			response.write("<tr>")
			for each stlctr2 in obj(stlctr)
				if len(obj(stlctr)(stlctr2)) < 100 then
					response.write("<td nowrap>&nbsp;"&obj(stlctr)(stlctr2)&"</td>")
				else
					response.write("<td nowrap>Long Text</td>")
				end if
			next
			response.write("</tr>")
		next
		response.write("</table>")
	else
		response.write("no data<br><br>")
	end if
end function

'Outputs normally, but adds a line break at the end of the string to help formating
function echo(str)
	response.write(str&vbcrlf)
end function

'Returns true if it is an array false if it is not
function IsArray(arr)
	on error resume next
	temp = ubound(arr)
	If Err.number <> 0 or temp = -1 Then
		IsArray = false
		Err.Clear
	else
		IsArray = true
	End If
	On Error Goto 0
end function

'Adds a value to an array. This avoids the need for redim
function AddArray(byref arr,newval)
	dim ctr
	dim newarr

	newarr = arr
	if not IsArray(arr) then
		redim arr(0)
		arr(0) = newval
	else
		redim preserve arr(ubound(arr)+1)
		arr(ubound(arr)) = newval
	end if
end function

'Used by Print_r
function Echor(arr,tablevel)
	if tablevel = 0 then
		echo "Array"
		echo "("
	end if

	dim ctr
	
	if not IsDictionary(arr) and not IsArray(arr) then
	else
		if IsDictionary(arr) then
			for each ctr in arr
				for tabs = 0 to ((tablevel+1)*4)
					response.write(" ")
				next
					
				if IsArray(arr(ctr)) = true then
					echo "["&ctr&"] => Array("
					x = Echor(arr(ctr),(tablevel+1))
					for tabs = 0 to ((tablevel+1)*4)
						response.write(" ")
					next
					echo ")"
				else
					if IsDictionary(arr(ctr)) then
						echo "["&ctr&"] => dictionary("
						x = Echor(arr(ctr),(tablevel+1))
						for tabs = 0 to ((tablevel+1)*4)
							response.write(" ")
						next
						echo ")"
					else
						echo "["&ctr&"] => {"&arr(ctr)&"}"
					end if
				end if
			next
		else
			for ctr=0 to ubound(arr)
				for tabs = 0 to ((tablevel+1)*4)
					response.write(" ")
				next
		
				if IsArray(arr(ctr)) = true then
					echo "["&ctr&"] => Array("
					x = Echor(arr(ctr),(tablevel+1))
					for tabs = 0 to ((tablevel+1)*4)
						response.write(" ")
					next
					echo ")"
				else
					if IsDictionary(arr(ctr)) then
						echo "["&ctr&"] => dictionary("
						x = Echor(arr(ctr),(tablevel+1))
						for tabs = 0 to ((tablevel+1)*4)
							response.write(" ")
						next
						echo ")"
					else
						echo "["&ctr&"] => {"&arr(ctr)&"}"
					end if
				end if
			next
		end if
	end if

	if tablevel = 0 then
		echo ")"
	end if
end function

'Checks to see if the variable is a Scripting.Dictionary
'returns true if it is, false if it is not
function IsDictionary(dictionary)
	on error resume next
	for each i in dictionary
		x = dictionary(i)
		
		if err.number > 0 then
			IsDictionary = false
			on error goto 0
			exit function
		else
			IsDictionary = true
			on error goto 0
			exit function
		end if
	next
	on error goto 0
end function

'will display the contents of the supplied array. Used for debugging purposes
'	Array(
'			[0] = a
'			[1] = b
'			[2] = c
'			[3] = Array (
'							[0] = aa
'							[1] = bb
'							[2] = cc
'						)
'		 }
function Print_r(arr)
	x = echor(arr,0)
end function

'Returns a Unix Timestamp
function MakeTimestamp(datetime)
	MakeTimestamp = DateDiff("s", "01/01/1970 00:00:00", datetime)
end function

'Returns a datetime
function UnMakeTimestamp(timestamp)
	UnMakeTimestamp = DateAdd("s",timestamp, "01/01/1970 00:00:00")
end function

'used by DateFormat
function AddZeros(num,length)
	str = num
	if len(str) <> length then
		while len(str) <> length
			str = "0"&str
		wend
	end if
	AddZeros = str
end function


'This function takes in a date or a timestamp as well as a format and will return the date in the specified format
'	ex: DateFormat("1/1/2005","%M %j %Y") would return Jan 1 2005
function DateFormat(datetime,format)
	if IsNumeric(datetime) then
		datein = UnMakeTimestamp(datetime)
	else
		if IsDate(datetime) then
			datein = datetime
		else
			DateFormat = "date invalid"
			exit function
		end if
	end if

	arr = split(datein," ")
	arr2 = split(arr(0),"/")
	arr3 = split(arr(1),":")

	amlow = lcase(arr(2))
	amup = ucase(arr(2))
	m = AddZeros(arr2(0),2)
	m2 = arr2(0)
	mname = monthname(arr2(0))
	mshortname = left(monthname(arr2(0)),3)
	d = AddZeros(arr2(1),2)
	d2 = arr2(1)
	hsmall = AddZeros(arr3(0),2)
	hsmall2 = arr3(0)

	if amlow = "pm" then
		hbig = AddZeros(arr3(0)+12,2)
		hbig2 = arr3(0)+12
	else
		hbig = AddZeros(arr3(0),2)
		hbig2 = arr3(0)
	end if

	mn = AddZeros(arr3(1),2)
	mn2 = arr3(1)
	s = AddZeros(arr3(2),2)
	s2 = arr3(2)
	y = right(arr2(2),2)
	y2 = arr2(2)

	format = replace(format,"%A",amlow)			'%A - AM or PM
	format = replace(format,"%a",amup)			'%a - am or pm
	format = replace(format,"%m",m)				'%m - Month with leading zeroes (01 - 12)
	format = replace(format,"%n",m2)			'%n - Month without leading zeroes (1 - 12)
	format = replace(format,"%F",mname)			'%F - Month name (January - December)
	format = replace(format,"%M",mshortname)	'%M - Three letter month name (Jan - Dec)
	format = replace(format,"%d",d)				'$d - Day with leading zeroes (01 - 31)
	format = replace(format,"%j",d2)			'%j - Day without leading zeroes (1 - 31)
	format = replace(format,"%H",hsmall)		'%H - Hour with leading zeroes (12 hour)
	format = replace(format,"%h",hbig)			'%h - Hour with leading zeroes (24 hour)
	format = replace(format,"%G",hsmall2)		'%G - Hour without leading zeroes (12 hour)
	format = replace(format,"%g",hbig2)			'%g - Hour without leading zeroes (24 hour)
	format = replace(format,"%i",mn)			'%i - Minute with leading zeroes (01 to 60)
	format = replace(format,"%I",mn2)			'%I - Minute without leading zeroes (1 to 60)
	format = replace(format,"%s",s)				'%s - Second with leading zeroes (01 to 60)
	format = replace(format,"%S",s2)			'%S - Second without leading zeroes (1 to 60)
	format = replace(format,"%y",y)				'%y - Two digit year (03)
	format = replace(format,"%Y",y2)			'%Y - Four digit year (2003)

	DateFormat = format
end function

'This function is used with CheckForm
'typein is a regex used to test the value
'fail is the message to display when the value fails the test
function RegisterForm(namein,test,errname,fail)
	AddArray forms,array(namein,test,errname,fail)
end function

'This function is used with CheckForm
'namein is the name of the field
'fail is the message to display
function RegisterError(namein,errname,fail)
	AddArray errors,array(namein,errname,fail)
end function

'This function builds an array full of the errors that were contained in the array
'created by RegisterForm. If the IsArray(errors) then the form contained errors.
function CheckForm()
	set regex = new regexp
	regex.Global = true
	regex.IgnoreCase = true

	if IsArray(forms) then
		for frmctr = 0 to ubound(forms)
			regex.Pattern = forms(frmctr)(1)
			if not regex.Test(request.form(forms(frmctr)(0))) then
				err = RegisterError(forms(frmctr)(0),forms(frmctr)(2),forms(frmctr)(3))
			end if
		next
	end if
end function
%>

**MadDog** · Feb 8, 2006, 22:38

Here is a function i created to open a ASP file and execute its contents (instead of using an Include):

Code:

Function GetConfig(strConfigFilePath)
 	'Get the new settings
 	Dim fso
 	Dim stream
 	Dim strConfigText
 
 	Set fso = Server.CreateObject("Scripting.FileSystemObject")
 
 	Set stream = fso.OpenTextFile(strConfigFilePath)
 
 	strConfigText = stream.ReadAll()
 
 	stream.Close
 	Set stream = Nothing
 	Set fso = Nothing
 
 	'Remove open and close ASP tags
 	strConfigText = Replace(strConfigText, "<" & "%", "")
 	strConfigText = Replace(strConfigText, "%" & ">", "")
 
 	Execute strConfigText
 End Function

To use:

Code:

Call GetConfig(Server.MapPath("aspfile.asp"))

**asp_funda** · Feb 9, 2006, 02:59

But this function won't work if the file its gonna execute doesn't contain only ASP code, is it?

**awasson** · Feb 9, 2006, 11:04

MadDog,
Excuse me if I'm way off here. I've only had one cup of coffee so far and my brain isn't up to speed yet but couldn't you use Server.Execute() instead?

Code ASP:

<%
include = aspfile.asp
Server.Execute(include)
%>

**MadDog** · Feb 9, 2006, 12:58

asp_funda,
The page has to be pure ASP code or it will error out.

awasson,

The problem with Server.Execute() is that it just executes the code, but you can not use any of the variables or functions within your page that you are executing it.

**awasson** · Feb 9, 2006, 13:14

Of course

I ran into that problem about a month ago and ended up using includes and calling the subroutines. I'll have to play around with that function of yours.

Thanks,

**bumpyride** · Apr 22, 2006, 14:07

Keyword Function

This is a clunky function I wrote to strip out the keywords from common search engine referrals to my site, as per this article:
<snip/> - broken link removed

Code ASP:

<%
''---------------------------------------------------
''SPLIT OUT THE KEYWORDS
''---------------------------------------------------
 
Function keywords(str)
 
	fr = str
	fr_len = len(fr)
 
	str_g =    InStr(fr,"google")
	str_y =    InStr(fr,"yahoo")
	str_w =    InStr(fr,"wanadoo")
	str_m =    InStr(fr,"msn")
	str_a =    InStr(fr,"aol")
 
	if str_g > 0 then tag = "google"
	if str_y > 0 then tag = "yahoo"
	if str_w > 0 then tag = "wanadoo"
	if str_m > 0 then tag = "msn"
	if str_a > 0 then tag = "aol"
 
	if str_g = 0 AND str_y = 0 AND str_w = 0 AND str_m = 0 AND str_a = 0 then
		keywords = "<a href="""&str&""">" &left(fr,50)& "</a>"
	end if
 
	mail =     InStr(fr,"mail")
 
	if str_g > 0 OR str_w > 0 OR str_m > 0 then qs = "q=" AND offset = 1
	if str_y > 0 then qs = "p=" AND offset = 1
	if str_a > 0 then qs = "query=" AND offset = 5
 
	if str_g > 0 OR str_w > 0 OR str_m > 0 OR str_y > 0 then
		offset = 1
	else
		offset = 5
	end if
 
	if (str_g>0 OR str_y>0 OR str_w>0 OR str_m>0 OR str_a>0) AND mail = 0 then
 
		a01 = instr(fr,qs)
		a02 = instr(fr,"&")
 
			a2 = right(fr,(fr_len-a01)-offset)
			a3 = instr(a2,"&")
 
			if a3 > 0 then
				a4 = len(a2)
				a5 = left(a2,a3-1)
				a6 = replace(a5,"+"," ")
			else
				a6 = replace(a2,"+"," ")
			end if
 
	keywords = "<a href="""&str&""">" & tag & "</a> - " & a6
 
	end if
 
End Function
%>

Clean Form Data

I use this one a lot to "clean" form data before putting it into the db:

Code ASP:

Function newstr(str)
	newstr = Server.HTMLencode(str)
	newstr = Replace(newstr, "'","''")
	newstr = Replace(newstr, "\","\\")
	newstr = Replace(newstr, chr(10), "<br />")
End Function

e.g. form_description = newstr(request.form("form_stuff")

Debug

I use this one quite a lot to debug variables:

Code ASP:

Sub debug( varName )
    Dim varValue
    varValue = Eval( varName )
    response.write "<p style=""border-bottom:1px solid #ccc;border-top:1px solid #eaeaea;background-color:white;padding:10px;color:red;text-align:left;""><strong>" & varName & "</strong>: " & varvalue & "</p>"
End Sub

e.g.

the_date = now()
debug "the_date"

I know I could just use:

response.write "the_date: " & the_date

but my way seemed a bit quicker

Convert Hyperlinks

And finally, I use the following to conver hyperlinks into clickable links. It originates from here:
http://www.4guysfromrolla.com/webtec...110900-1.shtml

And I just tweaked it a bit to produce a sensible length of URL if the URL is over 50 chars, and also to not convert email addresses to hyperlinks, but instead convert them to "bob [at] site [dot] com" formats

Code ASP:

'----------------------------------------------
'URL function
'----------------------------------------------
 
Function InsertHyperlinks(inText)
Dim objRegExp, strBuf
Dim objMatches, objMatch
Dim Value, ReplaceValue, iStart, iEnd
 
  strBuf = ""
  iStart = 1
  iEnd = 1
  Set objRegExp = New RegExp
 
  objRegExp.Pattern = "\b(www|http|\S+@)\S+\b"  ' Match URLs and emails
  objRegExp.IgnoreCase = True                   ' Set case insensitivity.
  objRegExp.Global = True                       ' Set global applicability.
  Set objMatches = objRegExp.Execute(inText)
  For Each objMatch in objMatches
    iEnd = objMatch.FirstIndex
    strBuf = strBuf & Mid(inText, iStart, iEnd-iStart+1)
    If InStr(1, objMatch.Value, "@") Then
      strBuf = strBuf & GetHref(objMatch.Value, "EMAIL", "_BLANK")
    Else
      strBuf = strBuf & GetHref(objMatch.Value, "WEB", "_BLANK")
    End If
    iStart = iEnd+objMatch.Length+1
  Next
  strBuf = strBuf & Mid(inText, iStart)
  InsertHyperlinks = strBuf
End Function
 
 
Function GetHref(url, urlType, Target)
Dim strBuf
 
  lenurl = len(url)
  if lenurl > 50 then
  	lenurl1 = left(url,40)
  	lenurl2 = right(url,10)
  	url2 = lenurl1 & "..." & lenurl2
  else
  	url2 = url
  end if
  strBuf = "<b><a href="""
  If UCase(urlType) = "WEB" Then
    If LCase(Left(url, 3)) = "www" Then
      strBuf = "<a href=""http://" & url & """>" & url2 & "</a>"
    Else
      strBuf = "<a href=""" & url & """>" & url2 & "</a>"
    End If
  ElseIf UCase(urlType) = "EMAIL" Then
    strBuf = url
	strBuf = Replace(strBuf, "@", " [at] " )
	strBuf = Replace(strBuf, "."," [dot] ")
	strBuf = "<strong>" & strBuf & "</strong>"
  End If
 
  GetHref = strBuf
 
End Function

**Gradiation** · Feb 15, 2007, 13:51

In the spirit of sharing, here are a couple of scripts that don't seem to be on here yet

Decodes a URL encoded string

Code ASP:

Function GUrlDecode (ByVal arg)
	  Dim Pos, pPos
 
	  arg = Replace(arg, "+", " ")
 
	  On Error Resume Next
	  Dim Stream: Set Stream = CreateObject("ADODB.Stream")
	  If err = 0 Then
		On Error GoTo 0
		Stream.Type = 2 'String
		Stream.Open
 
		Pos = InStr(1, arg, "%")
		pPos = 1
		Do While Pos > 0
		  Stream.WriteText Mid(arg, pPos, Pos - pPos) + _
			Chr(CLng("&H" & Mid(arg, Pos + 1, 2)))
		  pPos = Pos + 3
		  Pos = InStr(pPos, arg, "%")
		Loop
		Stream.WriteText Mid(arg, pPos)
 
		Stream.Position = 0
 
		GUrlDecode = Stream.ReadText
 
		Stream.Close
	  Else
		on error goto 0
		Pos = InStr(1, arg, "%")
		Do While Pos>0 
		  arg = Left(arg, Pos-1) + _
			Chr(Clng("&H" & Mid(arg, Pos+1, 2))) + _
			Mid(arg, Pos+3)
		  Pos = InStr(Pos+1, arg, "%")
		Loop
		GUrlDecode = arg
	  End If
End Function

Adds working days to a date

Code ASP:

Function GDateAddWorkingDays(ByVal intDays, ByVal dtmDate)
 
	Dim dtmReturnDate		' We return this date
	Dim intDayCount			' Loop counter
	Dim intUnit				' Either +1 day or -1 day
 
	If intDays >= 0 Then
		intUnit = +1
	Else
		intUnit = -1
	End If
 
	If IsNumeric( intDays ) AND IsDate( dtmDate ) Then
 
		intDays			= Abs( intDays )
		intDayCount		= 0
		dtmReturnDate	= dtmDate
 
		Do Until( intDayCount >= intDays ) AND GIsWorkingDay( dtmReturnDate )
			dtmReturnDate = DateAdd("d", intUnit, dtmReturnDate)
			If GIsWorkingDay( dtmReturnDate ) Then
				intDayCount = intDayCount + 1
			End If
		Loop
	Else
		dtmReturnDate = False
	End If
 
	GDateAddWorkingDays = dtmReturnDate
 
End Function

Checks to see if a date is a working day

Code ASP:

Function GIsWorkingDay( ByVal dateToCheck )
	Dim theDay
 
	theDay = Weekday( dateToCheck )
 
	If theDay = vbSaturday Or theDay = vbSunday Then
		GIsWorkingDay = False
	Else
		GIsWorkingDay = True
	End If
 
End Function

I also saw a post on here about executing a file, well the function below will handle files that aren't 100% asp code. Any none asp code is wrapped by a response.write

Execute a file

Code ASP:

'=======================================================
' Get file contents
'=======================================================
 
Function getFileContents(strFilename)
	'response.write "-Openfile-"
	Const ForReading = 1
 
	' Setup File System Object
	Dim fso
	Set fso = Server.CreateObject("Scripting.FilesystemObject")
 
	' Open Text File
	Dim ts
	Set ts = fso.OpenTextFile(Server.MapPath(strFilename), ForReading)
 
	' Read File Contents
	getFileContents = ts.ReadAll
	ts.close
 
	' Clean Up
	Set ts = nothing
	Set fso = Nothing
End Function
 
'=======================================================
' Convert a string to ASP code
'=======================================================
 
Function convertStringToASP(strContents)
 
	' Declare Variables
	Dim output, pos1, pos2, before, middle, after
 
	' Setup variables
	output = ""
 
	' Find First ASP Start Tag
	pos1 = instr(strContents,"<%")
 
	' Find First ASP End Tag
	pos2 = instr(strContents,"%"& ">")
 
	' Start Tag Exists
	if pos1 > 0 then
 
		' Get Plain Text Before ASP Start Tag
		before = mid(strContents, 1, pos1-1)
 
		' Remove Line Breaks
		before = Replace(Replace(before, """", """"""), vbcrlf, """& vbcrlf & _"& vbcrlf &"""")
 
		' Build ASP String
		If before <> "" Then
			before = vbcrlf &"Response.Write """& before &""""& vbcrlf
		End If
 
		' Get ASP Code Between ASP Start & End Tags
		middle = mid(strContents, pos1+2,(pos2-pos1-2))
 
		If Left(middle, 1) = "=" Then
			middle = "Response.Write "& Right(middle, Len(middle)-1)
		End If
 
		' Get Plain Text After ASP End Tag
		after = mid(strContents, pos2+2, len(strContents))
 
		' Recurse Through Remaining String
		output = before & middle & convertStringToASP(after)
 
	' No ASP Start Tag Found
	else
		If LTrim(RTrim(strContents)) <> "" Then
			' Remove Line Breaks
			strContents = Replace(Replace(strContents, """", """"""), vbcrlf, """& vbcrlf & _"& vbcrlf &"""")
			output = vbcrlf &"Response.Write """& strContents &""""& vbcrlf & "Response.Flush()"
		End If
	end if
 
	' Return Output
	convertStringToASP = output
 
End Function
 
'=======================================================
' Execute a file from within an ASP page
'=======================================================
 
Function executeFile(strFilename)
 
	' Declare Variables
	Dim strContents
 
	' Load File Contents
	strContents = getFileContents(strFilename)
 
	' Convert To ASP
	strContents = convertStringToASP(strContents)
 
	'Response.Write(strContents)
 
	' Execute
	execute(strContents)
 
End Function

Hopefully they are pretty self explanatory

**aspapp** · Mar 29, 2007, 05:30

Haven't seen this one posted here, but maybe useful:

Code ASP:

Function PadLeft(sString, nReturnLength, sPadChar)
''============================
'' pad string with zeros (0's) or other char
 
If nReturnLength > Len(sString) Then
  PadLeft = sString & String(nReturnLength - Len(sString), sPadChar)  
Else
  PadLeft = Left(sString, nReturnLength)
End If
 
End Function

**gabru** · Jul 2, 2007, 10:50

whole bunch of string functions:

http://www.webdevbros.net/2006/11/20...r-classic-asp/

free caching component:
http://www.webdevbros.net/2006/11/18...r-classic-asp/

Templating:
http://www.webdevbros.net/2007/06/28...r-classic-asp/

**steoates** · Mar 20, 2009, 10:05

Add to query string.

Code VB:

FUNCTION addToQuerystring(qs,param,value)
	Dim newqs, amp
	IF isNull(qs) THEN qs = "" END IF
	IF Len(qs) = 0 THEN
		amp = ""
	ELSE
		amp = "&"
	END IF
	addToQuerystring = qs & amp & param & "=" & value
END FUNCTION

Remove from query string.

Code VB:

FUNCTION removeFromQuerystring(qs,param)
	Dim arrQS,pair,newqs, arrPairs
	arrQS = split(qs,"&")
	FOR EACH pair IN arrQS
		arrPairs = split(pair,"=")
		IF arrPairs(0) <> param THEN
			newqs = newqs & pair & "&"
		END IF
	NEXT
	IF Len(newqs) > 0 THEN
		newqs = Left(newqs, Len(newqs)-1)
	END IF
	removeFromQuerystring = newqs
END FUNCTION

**awasson** · Nov 13, 2009, 18:39

In Array Function

I found the following function at: http://www.visualbasicscript.com/m41079.aspx

I though this was a unique way to check an array because rather than taking an obvious approach of looping through the array it uses InStr().

It takes an array and a key and returns a boolean (true/false) if the key is found in the array.

Code ASP:

Function InArray(oItem,sSearchString)
 InArray = False
 If IsNull(sSearchString) OR IsNull(oItem) Then Exit Function End If
  If IsArray(oItem) Then
   If InStr(LCase(Chr(7)&Join(oItem,Chr(7))&Chr(7)),Chr(7) & LCase(sSearchString) & Chr(7)) <> 0 Then InArray = True
  Else
    If InStr(LCase(oItem),LCase(sSearchString)) <> 0 Then InArray = True
  End If 
End Function

**ChrisBristow** · Jan 25, 2010, 16:29

Here's a neat little snippet that I found sometime ago when all the SQL injections were being attempted on our webiste. Hopefully you will find this useful.

Code ASP:

<%
function cleanInput(str)
  dim re
  set re = new RegExp
  '(</?(?:u|i|b|a\s+href="[^">]*"|(?<=/)a)>)|</?[^>]*>
  re.Pattern = "[^0-9a-zA-Z\s\@\:\.\,\-\_\!\?\+]"
  re.Global = True
  cleanInput = re.Replace(str, "")
  set re = nothing
end function
%>

used like this:

I use them for all form submissions

Code ASP:

<%MyValue=cleanInput(Request.Form("SubmittedVariable"))%>

User Tag List

Thread: Funky Functions in ASP

Thread Tools

Display

hex to number functions: hex2dgt(), hex2dec()

Faster reading of text files

Function to sort XML

I do I get it to work

reformatting bbcode tags

Bookmarks

Bookmarks

Posting Permissions