SitePoint Sponsor |
|
User Tag List
Results 101 to 125 of 127
Thread: Funky Functions in ASP
-
Nov 16, 2004, 14:12 #101
- Join Date
- Sep 2004
- Location
- california, usa
- Posts
- 50
- Mentioned
- 0 Post(s)
- Tagged
- 0 Thread(s)
hex to number functions: hex2dgt(), hex2dec()
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 %>
Code:00000000000000000000000000 : 0 7fffffff : 2147483647 ffffffffffff : 281474976710655 deadbeef0123456789bad : 1.68251264662152E+25 : -2 : -2 hex : -1
-
Nov 17, 2004, 12:49 #102
- Join Date
- Sep 2002
- Location
- Bournemouth, South UK
- Posts
- 1,551
- Mentioned
- 1 Post(s)
- Tagged
- 0 Thread(s)
Faster reading of text files
Just a little tip......
Text files are slow to read when using the
Code:do while textFileOpen.AtEndOfStream=false text=textFileOpen.readline loop
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)
LiveScript: Putting the "Live" Back into JavaScript
if live output_as_javascript else output_as_html end if
-
Dec 1, 2004, 08:25 #103
- Join Date
- Nov 2004
- Location
- India
- Posts
- 9
- Mentioned
- 0 Post(s)
- Tagged
- 0 Thread(s)
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
-
Jan 13, 2005, 06:52 #104
- Join Date
- Jan 2005
- Location
- Northern Ireland
- Posts
- 3
- Mentioned
- 0 Post(s)
- Tagged
- 0 Thread(s)
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
-
Feb 21, 2005, 09:40 #105
- Join Date
- Sep 2002
- Location
- Walsall, UK
- Posts
- 1,911
- Mentioned
- 0 Post(s)
- Tagged
- 0 Thread(s)
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)
-
Mar 10, 2005, 13:59 #106
- Join Date
- Feb 2005
- Posts
- 53
- Mentioned
- 0 Post(s)
- Tagged
- 0 Thread(s)
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
Real handy if you do something like...
Code:dim myVar myVar = dirLookUp(Right(Trim(Request.ServerVariables ("AUTH_USER")), iLength), 1)
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
..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
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
Enjoy!
-
Apr 6, 2005, 03:49 #107
- Join Date
- Jul 2002
- Location
- Isle of Wight
- Posts
- 59
- Mentioned
- 0 Post(s)
- Tagged
- 0 Thread(s)
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
-
Apr 7, 2005, 10:09 #108
- Join Date
- Oct 2001
- Location
- Vancouver BC Canada
- Posts
- 2,037
- Mentioned
- 5 Post(s)
- Tagged
- 0 Thread(s)
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 %>
<%=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.Andrew Wasson | www.lunadesign.org
Principal / Internet Development
-
Apr 12, 2005, 10:04 #109
- Join Date
- Mar 2005
- Location
- Milwaukee
- Posts
- 14
- Mentioned
- 0 Post(s)
- Tagged
- 0 Thread(s)
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 %>
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 %>
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 %>
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 %>
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 %>
-
Apr 22, 2005, 13:06 #110
- Join Date
- Nov 2004
- Location
- Nelson BC
- Posts
- 2,310
- Mentioned
- 0 Post(s)
- Tagged
- 0 Thread(s)
Function to sort XML
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
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>
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 < '3']", "name\lname,text\text,ascending\descending")
There you have it. It's not perfect but it works - any suggestions welcome.
Jim
-
Jun 21, 2005, 08:43 #111
- Join Date
- Jun 2005
- Posts
- 36
- Mentioned
- 0 Post(s)
- Tagged
- 0 Thread(s)
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> "&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 %>
-
Jun 22, 2005, 13:16 #112
I do I get it to work
Originally Posted by hillsy
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?
-
Sep 6, 2005, 14:45 #113
- Join Date
- Sep 2005
- Posts
- 1
- Mentioned
- 0 Post(s)
- Tagged
- 0 Thread(s)
Are you aware that you are redefining isArray() and DateFormat() in vbscript with your IsArray and DateFormat function below?
Originally Posted by PuritysDisciple
-
Feb 8, 2006, 22:38 #114
- Join Date
- Aug 2002
- Location
- Oregon, USA
- Posts
- 247
- Mentioned
- 0 Post(s)
- Tagged
- 0 Thread(s)
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
Code:Call GetConfig(Server.MapPath("aspfile.asp"))
Last edited by MadDog; Feb 10, 2006 at 14:08. Reason: updated code
-
Feb 9, 2006, 02:59 #115
- Join Date
- Jun 2003
- Location
- ether
- Posts
- 4,497
- Mentioned
- 1 Post(s)
- Tagged
- 0 Thread(s)
But this function won't work if the file its gonna execute doesn't contain only ASP code, is it?
Our lives teach us who we are.
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
Me - Photo Blog - Personal Blog - Dev Blog
iG:Syntax Hiliter -- Colourize your code in WordPress!!
-
Feb 9, 2006, 11:04 #116
- Join Date
- Oct 2001
- Location
- Vancouver BC Canada
- Posts
- 2,037
- Mentioned
- 5 Post(s)
- Tagged
- 0 Thread(s)
reformatting bbcode tags
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) %>
Last edited by Mittineague; Nov 15, 2010 at 23:50.
Andrew Wasson | www.lunadesign.org
Principal / Internet Development
-
Feb 9, 2006, 12:58 #117
- Join Date
- Aug 2002
- Location
- Oregon, USA
- Posts
- 247
- Mentioned
- 0 Post(s)
- Tagged
- 0 Thread(s)
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.
-
Feb 9, 2006, 13:14 #118
- Join Date
- Oct 2001
- Location
- Vancouver BC Canada
- Posts
- 2,037
- Mentioned
- 5 Post(s)
- Tagged
- 0 Thread(s)
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,Andrew Wasson | www.lunadesign.org
Principal / Internet Development
-
Apr 22, 2006, 14:07 #119
- Join Date
- Dec 2004
- Posts
- 419
- Mentioned
- 0 Post(s)
- Tagged
- 0 Thread(s)
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
Last edited by Mittineague; Nov 15, 2010 at 23:44. Reason: reformatting bbcode tags
-
Feb 15, 2007, 13:51 #120
- Join Date
- Feb 2007
- Posts
- 4
- Mentioned
- 0 Post(s)
- Tagged
- 0 Thread(s)
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 explanatoryLast edited by Mittineague; Nov 15, 2010 at 23:35. Reason: reformatting bbcode tags
-
Mar 29, 2007, 05:30 #121
- Join Date
- Nov 2001
- Location
- RI, USA
- Posts
- 140
- Mentioned
- 0 Post(s)
- Tagged
- 0 Thread(s)
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
-
Jul 2, 2007, 10:50 #122
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/ajaxed Library - Free Ajax Library for classic ASP
execute server side procedures directly from client side
ajaxed - the first classic ASP Ajax Library
-
Mar 20, 2009, 10:05 #123
- Join Date
- Mar 2009
- Location
- St Helens - Merseyside
- Posts
- 4
- Mentioned
- 0 Post(s)
- Tagged
- 0 Thread(s)
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
-
Nov 13, 2009, 18:39 #124
- Join Date
- Oct 2001
- Location
- Vancouver BC Canada
- Posts
- 2,037
- Mentioned
- 5 Post(s)
- Tagged
- 0 Thread(s)
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
Last edited by Mittineague; Nov 15, 2010 at 23:24. Reason: reformatting bbcode tags
Andrew Wasson | www.lunadesign.org
Principal / Internet Development
-
Jan 25, 2010, 16:29 #125
- Join Date
- Jan 2010
- Posts
- 1
- Mentioned
- 0 Post(s)
- Tagged
- 0 Thread(s)
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"))%>
Last edited by Mittineague; Nov 15, 2010 at 23:18. Reason: reformatting bbcode tags
Bookmarks