Funky Functions in ASP

[dhtmlgod]

There is already a thread like this, but it was filled with alot of general chit-chat and stuff, so I decided to start a new one. Please, keep chat to a minimal, just post your functions os other peopel can easily use them without siffing thru chat.

Thanks

<%
Function changeDate(timeStr,loc)
	splitterThingy = "/"
	firstSlashPos = inStr(timeStr, splitterThingy)
	secSlashPos = inStr(firstSlashPos, timeStr, splitterThingy)
	yearSlashPos = inStr(secSlashPos + 1, timeStr, splitterThingy)
	firstInfo = left(timeStr,(firstSlashPos - 1))
	secInfo = mid(timeStr,firstSlashPos+1,(secSlashPos - 1))
	yearInfo = mid(timeStr, (yearSlashPos + 1), len(timeStr))
	If loc = "us" then
		changeDate = secInfo & splitterThingy & firstInfo & splitterThingy & yearInfo
	elseIf loc = "uk" then
		changeDate = firstInfo & splitterThingy & secInfo & splitterThingy & yearInfo
	end if
end function
response.write(changeDate("05/09/2001","us"))
%>

Chages date UK -> US or US -> UK

function chkEmail(theAddress)
   dim atCnt
   chkEmail = theAddress
   if len(theAddress) < 5  then 
      chkEmail = 1
    elseif instr(theAddress,"@") = 0 then
      chkEmail = 1
   elseif instr(theAddress,".") = 0 then
      chkEmail = 1
   elseif len(theAddress) - instrrev(theAddress,".") > 3 then
      chkEmail = 1
   elseif instr(theAddress,"_") <> 0 and _
       instrrev(theAddress,"_") > instrrev(theAddress,"@")  then
      chkEmail = 1
   else
      atCnt = 0
      for i = 1 to len(theAddress)
         if  mid(theAddress,i,1) = "@" then
            atCnt = atCnt + 1
         end if
      next
      if atCnt > 1 then
         chkEmail = 1
      end if
      for i = 1 to len(theAddress)
        if  not isnumeric(mid(theAddress,i,1)) and _
		(lcase(mid(theAddress,i,1)) < "a" or _
		lcase(mid(theAddress,i,1)) > "z") and _
		mid(theAddress,i,1) <> "_" and _
		mid(theAddress,i,1) <> "." and _
		mid(theAddress,i,1) <> "@" and _
		mid(theAddress,i,1) <> "-" then
            chkEmail = 1
        end if
      next
  end if
end function

Non-RegExp way of validating an e-mail address

Function chkEmail(sEmail)
	Set objRegExp = New RegExp
	searchStr = "^[\w-\.]{1,}\@([\da-zA-Z-]{1,}\.){1,}[\da-zA-Z-]{2,3}$" 
	objRegExp.Pattern = searchStr
	objRegExp.IgnoreCase = true
	chkEmail = objRegExp.Test(sEmail)
End Function

A RegExp way of validating an e-mail address

<%
if isempty(request.querystring("PageNo")) then
	CurrPage = 1
else
	CurrPage = cint(request.querystring("PageNo"))
end if
Set RS = Server.CreateObject("ADODB.Recordset")
RS.CursorLocation = 3
RS.Open "SQL statement", connectString
RS.PageSize = 3
RS.AbsolutePage = CurrPage
DO UNTIL RS.AbsolutePage <> CurrPage OR RS.EOF
	' Write stuff to page
Loop

function getNext10(num)
	pageLen = len(num)
	if pageLen = 1 then
		next10 = 10
	elseif pageLen = 2 then
		pageRem = 10
		pageTen = right(num, 1)
		next10 = num + pageRem - pageTen
	elseif pageLen > 2 then
		pageRem = 10
		pageTen = right(num, 1)
		next10 = num + pageRem - pageTen
	end if
	getNext10 = next10
end function

function getPrev10(num)
	pageLen = len(num)
	if pageLen = 1 then
		prev10 = 1
	elseif pageLen = 2 then
		firstDig = left(num, 1)
		secondDig = right(num, 1)
		prev10 = num - secondDig - 10
	elseif pageLen > 2 then
		firstDig = right(num, 2)
		secondDig = right(num, 1)
		prev10 = num - secondDig - 10
	end if
	if prev10 = 0 then
		prev10 = 1
	end if
	getPrev10 = prev10
end function

RSPrevPage = CurrPage -1
RSNextPage = CurrPage + 1
next10 = getNext10(currPage)
prev10 = getPrev10(currPage)

if Next10 > RS.PageCount then
	next10 = RS.PageCount
end if

if prev10 = 1 AND next10 - 1 < 10 then
	start = 1
else
	start = Next10 - 10
if right(start, 1) > 0 then
	start = replace(start, right(start, 1), "0")
	start = start + 10
end if
end if

if RS.PageCount > 1 then
	if next10 > 10 then
		response.write("<p class=""para1""><a href=""" & request.servervariables("SCRIPT_NAME") & "?PageNo=" & Prev10 & """><<</a>   ")
	end if
	if not RSPrevPage = 0 then
		response.write("<a href=""" & request.servervariables("SCRIPT_NAME") & "?PageNo=" & RSPrevPage & """><</a>   ")
	end if
	for P = start to Next10
		if not P = CurrPage then
			response.write("<a href=""" & request.servervariables("SCRIPT_NAME") & "?PageNo=" & P & """>" & P & "</a> ")
		else
			response.write(" <b>" & P & " </b>")
		end if
	Next
	
	if not RSNextPage > RS.PageCount then
		response.write("<a href=""" & request.servervariables("SCRIPT_NAME") & "?PageNo=" & RSNextPage & """>></a>  ")
	end if
	if not Next10 = RS.PageCount then
		response.write("   <a href=""" & request.servervariables("SCRIPT_NAME") & "?PageNo=" & Next10 & """>>></a>")
	end if
end if

An RS Paging Technique


I will post some more soon.

[aspapp]

here's a simple one that I use a lot...

function displayCode(page_to_display)

set fsObj = CreateObject("Scripting.FileSystemObject")
set fileObj = fsObj.OpenTextFile(server.mappath(page_to_display),1,false)

do while not fileObj.AtEndOfStream

''' read the current line and write it to the browser
response.write server.htmlencode(fileObj.readline)  &  "<br>"

loop

fileObj.Close
set fileObj = NOTHING
set fsObj = NOTHING

end function

[KodeKrash]

Here is a function to remove or escape any quotes (3 types) or apostrophes (3 types)

Public Function CleanQuotes( ByVal strDirty, boolRemove )
	strData = Replace( Replace( strDirty, Chr(147), Chr(34) ), Chr(148), Chr(34) )
	strData = Replace( Replace( strData, Chr(146), Chr(39) ), Chr(96), Chr(39) )
	If Not CBool( boolRemove ) Then
		strData = Replace( strData, Chr(39), String( 2, Chr(39) ) )
		strData = Replace( strData, Chr(34), Chr(39) & Chr(34) )
	ElseIf CBool( boolRemove ) Then
		strData = Replace( strData, Chr(39), Chr(32) )
		strData = Replace( strData, Chr(34), Chr(32) )
		Do While InStr( 1, strData, String( 2, Chr(32) ) ) > 0
			strData = Replace( strData, String( 2, Chr(32) ), Chr(32) )
		Loop
	End If
	CleanQuotes = Trim( strData )
End Function

Sample:

' to escape for SQL statements
strClean = CleanQuotes( strDirtyData, False )
'or to remove the quotes entirly
strClean = CleanQuotes( strDirtyData, True )

And a function to remove tabs, newlines, carriage returns, and extra spaces.

Public Function CleanString( ByVal strDirty )
	strData = Trim( strDirty )
	arrRemove = Array( Chr(9), Chr(10), Chr(13) )
	For Each Item In arrRemove
		strData = Replace( strData, Item, Chr(32) )
	Next
	Do While InStr( 1, strData, String( 2, Chr(32) ) )
		strData = Replace( strData, String(2, Chr(32) ), Chr(32) )
	Loop
	CleanString = Trim( Replace( strData, Chr(62) & Chr(32) & Chr(60), Chr(62) & Chr(60) ) )
End Function

Sample:

strClean = CleanString( strDirtyData )

A function like String() except that it supports multiple character strings to repeat.

Public Function NString( lngQuanity, strExpression )
	For Idx = 1 To CLng( lngQuanity )
		strData = strData & strExpression
	Next
	NString = strData
End Function

Sample:

strManyBlahs = NString( 10, "blah " )

A function to get the data between 2 tags ("<title>blah</title>" for example)

Public Function TagData( ByVal strTag, ByVal strSource )
	lngStart = InStr( 1, LCase( strSource ), Chr(60) & LCase( strTag ) )
	If lngStart > 0 Then
		lngStart = InStr( lngStart, LCase( strSource ), Chr(62) ) + 1
		lngStop = InStr( lngStart, LCase( strSource ), Chr(60) & Chr(47) & LCase( strTag ) & Chr(62) )
		If lngStart > 0 And lngStop > lngStart Then strData = Trim( Mid( strSource, lngStart, lngStop - lngStart ) )
	End If
	TagData = strData
End Function

Sample:

'this will return the <title> value from the string
strTitle = TagData( "title", strHTMLorXML )

Maybe you can tell that I do a lot of parsing work?

[dhtmlgod]

Heres a quick one to connect to a db:

Public Function connectDB()
	If not isObject(objDBCon) OR cStr(typeName(objDBCon)) = "Nothing" then
		Set objDBCon = Server.CreateObject("ADODB.Connection") : strConnect = "connectString" : objDBCon.open strConnect
	else
		objDBCon.close : Set objDBCon = nothing
	end if
End Function

and use it like this:

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

[aspapp]

function CheckCard(CardNo)

''''''''''''''''''''''''''''''''''''''''''''''''''''
'' algorithm to check validity of credit card number
''''''''''''''''''''''''''''''''''''''''''''''''''''

i = 0

luntil = len(cardNo)
x = 0
do
lside = left(cardno,((luntil)-x)-1)
rside = mid(cardno,((luntil)-x),1)

if i = 1 then
rside = cint(rside) * 2
if len(rside) > 1 then
mlside = left(rside,1)
mrside = right(rside,1)
rside = cint(mlside) + cint(mrside)
end if
end if
saverside = cint(saverside) + cint(rside)

if i = 0 then i = 1 else i = 0
x = x + 1
loop until x = luntil

modCheck = saverside mod 10

if modCheck = 0 then
CheckCard = 1
else
CheckCard = 0
end if

end function

[Jeremy W.]

Does the above func take into account Amex, independent cards, etc? There are some pretty whacked out lengths (up to 23 numbers) and beginning numbers (unregistered gems like 1100)...

I was just thinking of how to validate cards, so maybe I'll give this one a go.

[aspapp]

that only works for mc and visa.. I know amex is a little more complicated.

[writhe]

I've been learning XML and how to use it with ASP. Here's a function I found on XML101.com (http://xml101.com/articles/michael/s...ml/default.asp). It's pretty handy for converting a XML file in combination with an XSL file into HTML on the server.

Function loadXMLFile(strXMLFile, strXSLFile)

' Declare local variables
Dim objXML
Dim objXSL

' Instantiate the XMLDOM Object that will hold the XML file.
set objXML = Server.CreateObject("Microsoft.XMLDOM")

' Turn off asyncronous file loading.
objXML.async = false

' Load the XML file.
objXML.load(strXMLFile)

' Instantiate the XMLDOM Object that will hold the XSL file.
set objXSL = Server.CreateObject("Microsoft.XMLDOM")

' Turn off asyncronous file loading.
objXSL.async = false

' Load the XSL file.
objXSL.load(strXSLFile)

' Use the "transformNode" method of the XMLDOM to apply the XSL
' stylesheet to the XML document. Then the output is written to the
' client
Response.Write(objXML.transformNode(objXSL))
End Function

[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

<%
	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.

[MarcusJT]

I posted this in another thread, but then realised it would probably be more usefulo to everyone here. It's a function which returns the MIME type for a given file extension:

'returns the MIME type for a given extension
Function GetMIMEType(extension)
	select case UCASE(extension)

		'Common documents
		case "TXT","TEXT","JS"
			sMIME = "text/plain"
		case "HTM","HTML","ASP","CGI","PL"
			sMIME = "text/html"
		case "PDF"
			sMIME = "application/pdf"
		case "RTF"
			sMIME = "text/richtext"
		case "XML"
			sMIME = "text/xml"
		case "WPD"
			sMIME = "application/wordperfect"
		case "WRI"
			sMIME = "application/mswrite"
		case "XLS","XLS3","XLS4","XLS5","XLW"
			sMIME = "application/msexcel"
		case "DOC"
			sMIME = "application/msword"
		case "PPT","PPS"
			sMIME = "application/mspowerpoint"
		
		'WAP/WML files	
		case "WML"
			sMIME = "text/vnd.wap.wml"
		case "WMLS"
			sMIME = "text/vnd.wap.wmlscript"
		case "WBMP"
			sMIME = "image/vnd.wap.wbmp"
		case "WMLC"
			sMIME = "application/vnd.wap.wmlc"
		case "WMLSC"
			sMIME = "application/vnd.wap.wmlscriptc"
			
		'Images
		case "GIF"
			sMIME = "image/gif"
		case "JPG","JPE","JPEG"
			sMIME = "image/jpeg"
		case "PNG"
			sMIME = "image/x-png"
		case "BMP"
			sMIME = "image/bmp"
		case "TIF","TIFF"
			sMIME = "image/tiff"
		case "AI","EPS","PS"
			sMIME = "application/postscript"
			
		'Sound files
		case "AU","SND"
			sMIME = "audio/basic"
		case "WAV"
			sMIME = "audio/wav"
		case "RA","RM","RAM"
			sMIME = "audio/x-pn-realaudio"
		case "MID","MIDI"
			sMIME = "audio/x-midi"
		case "MP3"
			sMIME = "audio/mp3"
		case "M3U"
			sMIME = "audio/m3u"
			
		'Video/Multimedia files
		case "AVI"
			sMIME = "video/avi"
		case "MPG","MPEG"
			sMIME = "video/mpeg"
		case "QT","MOV","QTVR"
			sMIME = "video/quicktime"
		case "SWA"
			sMIME = "application/x-director"
		case "SWF"
			sMIME = "application/x-shockwave-flash"
			
		'Miscellaneous
		case "COM","EXE","DLL","OCX"
			sMIME = "application/octet-stream"
		case "PDB"
			sMIME = "chemical/x-pdb"
		case "ZIP"
			sMIME = "application/x-zip-compressed"
			
		'Unknown
		case else
			sMIME = "application/octet-stream"
	end select
	
	GetMimeType = sMIME
End Function

Use it like this:

FileExtension = Mid(FileName,InstrRev(FileName,".")+1)
Response.ContentType = GetMimeType(FileExtension)

Of course, there are plenty more MIME types out there which I have not included, but that lot should cover most that you come across. Add your own!

EDIT: Changed VBS tags to CODE tags to preserve whitespace

[wdmny]

I like the function to get the data between tags. Anyone have a function to grab data out of an attribute of a single tag? Such as grabbing the keywords out of the META keywords tag?

[MarcusJT]

Wes, this seems to do the job, although I would recommend using a non-greedy RegEx match really.

http://www.intelidev.com/script/htmlparser/


M@rco

[MarcusJT]

I wrote the following function years ago as a quick & dirty solution to the problem of checking if session & form variables (and cookies) have been initialised. This usually requires doing multiple checks for IsNull, IsEmpty, etc. I wrapped these up (and more in this function) in this function to save time, and make my coding more efficient.

It returns true if the variable is an array with no dimensions, and object (which by definition must mean that the variable is initialised, and thus not empty), or a plain old variant which is either Null, Empty, or equal to "". In all other cases it returns false. I've found it to cover all the bases for me! :-)

'Check a variable isn't "empty"
Function IsBlank(byref TempVar)

	'by default, assume it's not blank
	IsBlank = False

	'now check by variable type
	select case VarType(TempVar)
	
		'Empty & Null
		case 0, 1
			IsBlank = True
		
		'String
		case 8
			if Len(TempVar) = 0 then
				IsBlank = True
			end if
			
		'Object
		case 9
			tmpType = TypeName(TempVar)
			If (tmpType = "Nothing") Or (tmpType = "Empty") Then
				IsBlank = True
			End If
		
		'Array
		case 8192, 8204, 8209
			'does it have at least one element?
			if UBound(TempVar) = -1 then
				IsBlank = True
			end if
	end select
end function

Example usage:

<% 
If IsBlank(Session("username"))Then 
	response.redirect("LoginFail.htm") 
End If 
%>

EDIT: Updated the code to my current version, and changed VBS tags to CODE tags to preserve whitespace.

[MarcusJT]

These functions make ouputting dynamic bits of JavaScript from your code a lot easier!

'Wraps JavaScript tags around a string of code
Function JSCode(TheCode)
	dim str
	str = vbCRLF & "<SCRIPT LANGUAGE=""javascript"">" & vbcrlf
	str = str & "<!--" & vbcrlf
	str = str & TheCode & vbcrlf
	str = str & "//-->" & vbcrlf
	str = str & "</SCRIPT>" & vbcrlf
	JSCode = str
end Function


'Converts a string (with blips) for use with JavaScript 
Function JSString(TheString)
	if not IsNull(TheString) and TheString <> "" then
		JSString = replace(TheString,"'","\'")
		JSString = replace(JSString,"""","\'\'")
		JSString = replace(JSString,vbCRLF,"<BR>")
		JSString = replace(JSString,vbCR,"<BR>")
		JSString = replace(JSString,vbLF,"<BR>")
	else
		JSString = ""
	end if
End Function

[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.

[KodeKrash]

A function to pad strings to specified length. This function is basically the same as PHP's str_pad() function. Very useful for creating nice, even columns of data inside of <pre /> tags or for nice looking flat text files.
[vbs]
Public Function StringPad( ByVal strData, ByVal intPad, ByVal strPad, ByVal strDirection )
Dim strOutput : strOutput = vbNullString
Do While Len( strOutput ) + Len( Trim( strData ) ) < intPad
strOutput = strOutput & strPad
Loop
Select Case LCase( strDirection )
Case "l", "left", "1": strOutput = strOutput & Trim( strData )
Case "r", "right", "2": strOutput = Trim( strData ) & strOutput
Case Else: strOutput = Trim( strData )
End Select
StringPad = strOutput
End Function
[/vbs]

Sample:
[vbs]
strColumn = StringPad( "text", 8, Chr(32), "right" )
[/vbs]

Output:

"text    "    (the word "text" with four spaces on the right)

[KodeKrash]

Regarding M@rco's post with the InteliDev link. InteliDev.com is currently unavailable because of a fluke combination of events that happened about 3 weeks ago. My apologies if you were looking for the HTMLParser class at InteliDev. I am trying to get the site back online, but I can't seem to find the time. I will post a function for getting XML/ish attribute values without using RegExp in a little bit.

[KodeKrash]

OK, I put all my functions (that are posted here) at the Bad Syntax Code Library, and added a couple more. I will be updating the Code Library every day until I get all my functions and schemas posted. Right now I will be concentrating on posting ASP, PHP, and SQL, but will expand to add Python, Java, VB, JS, etc as time allows and the become available. When I have some time, I will make it all DB driven, search, etc - might even add a comment system, etc and see if it can become the #1 code library on the net.

If anyone has anything to contribute, just drop me an email and we can discuss it. WARNING: any contributed snippets will be subject to formatting and/or syntax changes. I will NOT post ugly code.

[addstravel]

Hi DHTML god,

With regards to your previous posting on RS paging. Cool functions except I struggled when reaching page numbers => 110....!!
Do you have any idea why this happens? is it something to do with assuming pages will be less than 3 numbers and therefore the function assumes a 1?

Not quite sure about this....
anybody any ideas?

Thanks again for the great posting though....

Cheers

[mulletboy2]

addstravel - did you try replacing "pageRem = 10
" with "pageRem = 100" in line 9 of Function getNextTen(num)? I haven't used that code, or looked too hard, but that bit looks wrong to me.

Not sure if there are any mistakes in the accompanying getPrevTen(num) function too, but it looks ok to me.

HTH

[addstravel]

Thanks...but checked this out and the pagerem var is the number of pages you want visible, ie the number of pages seen between the '<<' (view previous 20) and '>>' (view next 20).

I have looked more closely and think the problem lies within this line:

elseif pageLen > 2 then
firstDig = right(iPage, 2)
secondDig = right(iPage, 1)
prev20 = iPage - secondDig - 20


Any suggestions?

[scumboss]

So you have a main page which you would like quicker. If your hitting the database everytime someone visits your page and the database has the same data why do it?

Use caching instead. The following sub procedure when you call it will fetch the page you wish to cache and write this to a static HTML file.
[VBS]
Sub CachePage (PageToCache, HTMLPageToWrite)
Dim objFSO
Set objFSO = Server.CreateObject("Scripting.FileSystemObject")

Dim xml
Set xml = Server.CreateObject("Microsoft.XMLHTTP")

'Opens the connection to the page you wish to cache
xml.Open "GET", PageToCache, False

'Actually Sends the request and returns the data from the page you wish to cache
xml.Send

'Open the text file
Dim objTextStream
Set objTextStream = objFSO.OpenTextFile(HTMLPageToWrite, 2, True)

'Write the contents of your cached page to a static HTML file
objTextStream.Write xml.responseText

'Close the file
objTextStream.Close

'Clean up our objects
Set objTextStream = Nothing
Set objFSO = Nothing
Set xml = Nothing
End Sub
[/VBS]
For example I use this for my index page when someone updates the news I call this sub procedure which will get the latest page from index_0.asp and write it to a HTML file called index.htm therefore my index page is much quicker as I am not hitting the database every time.

To call the procedure:
[VBS]
CachePage "http://www.yourdomain.co.uk/index_0.asp", "D:\yourhostdirectory\index.htm"
[/VBS]
You need to have microsoft's free XMLHTTP component installed which most hosts do, to use this caching technique.

To use the latest version of XMLHTTP use this line instead:
[VBS]
Set xml = Server.CreateObject("MSXML2.ServerXMLHTTP.3.0")
[/VBS]

[addstravel]

Thanks this is a very useful of removing to need to always call the DB. Cheers...

However.. my point was the ability to acurately group pages drawn from a database into page numbers. Whilst this is fine for pages up to 110, on recordsets larger than this fails when a user clicks upon it based upon DHTML two functions previously posted. I was enquiring how this could be fixed to have the 'previous' and 'next' buttons working efficiently...Does this make sense?

Cheers

[mulletboy2]

adds - which DBMS are you using? There are often better ways to do paging than this in DBMS's such as Oracle, SQL Server, Postgres etc...

[addstravel]

I am using SQL7.0.

I have seen another way to do this ny just retrieving the records for that page. But I cannot use Stored Procedures because I require to dynamically change the order field. I understand this is not possible because you cannot assign a local var to this.

What do you suggest?

Cheers