Funky Functions in ASP

**DaveMaxwell** · Jan 8, 2004, 07:30

I've posted this a number of times, so I'm going to just add this here....

This code will go through your system and determine which email component(s) is/are installed on your system for your use.

Code:

<% @ Language="VBScript" %>
<% Option Explicit %>
<%
Dim theComponent(18)
Dim theComponentName(18)
'## the components
theComponent(0) = "ABMailer.Mailman"
theComponent(1) = "Persits.MailSender"
theComponent(2) = "SMTPsvg.Mailer"
theComponent(3) = "SMTPsvg.Mailer"
theComponent(4) = "CDONTS.NewMail"
theComponent(5) = "CDONTS.NewMail"
theComponent(6) = "CDO.Message"
theComponent(7) = "dkQmail.Qmail"
theComponent(8) = "Dundas.Mailer"
theComponent(9) = "Dundas.Mailer"
theComponent(10) = "Geocel.Mailer"
theComponent(11) = "iismail.iismail.1"
theComponent(12) = "Jmail.smtpmail"
theComponent(13) = "MDUserCom.MDUser"
theComponent(14) = "ASPMail.ASPMailCtrl.1"
theComponent(15) = "ocxQmail.ocxQmailCtrl.1"
theComponent(16) = "SoftArtisans.SMTPMail"
theComponent(17) = "SmtpMail.SmtpMail.1"
theComponent(18) = "VSEmail.SMTPSendMail"
'## the name of the components
theComponentName(0) = "ABMailer v2.2+"
theComponentName(1) = "ASPEMail"
theComponentName(2) = "ASPMail"
theComponentName(3) = "ASPQMail"
theComponentName(4) = "CDONTS (IIS 3/4/5)"
theComponentName(5) = "Chili!Mail (Chili!Soft ASP)"
theComponentName(6) = "CDOSYS (IIS 5/5.1/6)"
theComponentName(7) = "dkQMail"
theComponentName(8) = "Dundas Mail (QuickSend)"
theComponentName(9) = "Dundas Mail (SendMail)"
theComponentName(10) = "GeoCel"
theComponentName(11) = "IISMail"
theComponentName(12) = "JMail"
theComponentName(13) = "MDaemon"
theComponentName(14) = "OCXMail"
theComponentName(15) = "OCXQMail"
theComponentName(16) = "SA-Smtp Mail"
theComponentName(17) = "SMTP"
theComponentName(18) = "VSEmail"
Function IsObjInstalled(strClassString)
 on error resume next
 ' initialize default values
 IsObjInstalled = False
 Err = 0
 ' testing code
 Dim xTestObj
 Set xTestObj = Server.CreateObject(strClassString)
 If 0 = Err Then IsObjInstalled = True
 ' cleanup
 Set xTestObj = Nothing
 Err = 0
 on error goto 0
End Function
Response.Write "<html>" & vbNewLine & _
  vbNewLine & _
  "<head>" & vbNewLine & _
  "  <title>E-mail Component Test</title>" & vbNewLine & _
  "</head>" & vbNewLine & _
  vbNewLine & _
  "<body bgColor=""white"" text=""midnightblue"" link=""darkblue"" aLink=""red"" vLink=""red"">" & vbNewLine & _
  "<font face=""Verdana, Arial, Helvetica"">" & vbNewLine & _
  "<table border=""0"" cellspacing=""0"" cellpadding=""0"" align=""center"">" & vbNewLine & _
  "  <tr valign=""top"">" & vbNewLine & _
  "	<td bgcolor=""black"">" & vbNewLine & _
  "	  <table border=""0"" cellspacing=""1"" cellpadding=""4"">" & vbNewLine & _
  "		<tr valign=""top"">" & vbNewLine & _
  "		  <td bgcolor=""midnightblue"" colspan=""2"" align=""center""><font size=""2"" color=""mintcream""><b>E-mail Component Test</b></font></td>" & vbNewLine & _
  "		</tr>" & vbNewLine & _
  "		<tr valign=""top"">" & vbNewLine & _
  "		  <td bgcolor=""midnightblue"" colspan=""2"" align=""center""><font size=""2"" color=""mintcream"">The following components are currently<br />available choices in the latest<br />release of Snitz Forums 2000</font></td>" & vbNewLine & _
  "		</tr>" & vbNewLine
Dim i
for i=0 to UBound(theComponent)
 Response.Write "		<tr>" & vbNewLine & _
   "		  <td bgColor=""#9FAFDF"" align=""right""><font size=""2""><strong>" & theComponentName(i) & ":&nbsp;</strong></font></td>" & vbNewLine & _
   "		  <td bgColor=""#9FAFDF"" align=""center""><font size=""2"">"
 if Not IsObjInstalled(theComponent(i)) then
  Response.Write("not installed")
 else
  Response.Write("<strong>installed!</strong>")
 end if
 Response.Write "</font></td>" & vbNewLine & _
   "		</tr>" & vbNewline
next
Response.Write "	  </table>" & vbNewLine & _
  "	</td>" & vbNewLine & _
  "  </tr>" & vbNewLine & _
  "</table>" & vbNewLine & _
  "</font>" & vbNewLine & _
  "</body>" & vbNewLine & _
  vbNewLine & _
  "</html>" & vbNewLine
%>

**vgarcia** · Jan 8, 2004, 08:39

Originally Posted by DaveMaxwell

I've posted this a number of times, so I'm going to just add this here....
...snip...

Dave, wouldn't those two arrays work better as a Scripting.Dictionary object, or at least as 1 two-dimensional array?

**DaveMaxwell** · Jan 8, 2004, 09:07

It probably would. Just never took the time to clean up the code. I'll see if I can find some time in the near future to go back and relook at the code for a cleaner process.

**asp_funda** · Jan 8, 2004, 13:05

Hey, that's some piece of code Dave! thanks.

**Thing** · Jan 20, 2004, 06:50

Here is a function I just made that makes the FIRST letter of every sentence a capital. This works in these three cases:

1. No spaces after period (ie: first sentence.second sentence)
2. One space after period (ie: first sentence. second sentence)
3. Two spaces after period (ie: first sentence. second sentence)

It ONLY works for periods. I'll work on getting all punctuation on it, and post the updated function when I'm done. Here it is:

Code:

 
Function PropCase(news)
 arr = Split(news, ".")
 for i=0 to Ubound(arr)
  If left(arr(i), 1) = " " then
   If left(arr(i), 2) = "  " then
	arr(i) = mid(arr(i), 3)
   Else
	arr(i) = mid(arr(i), 2)
   End if
  End if
  arr(i) = ucase(left(arr(i), 1)) & mid(arr(i), 2)
 Next
 For p=0 to Ubound(arr)
  newstxt =  newstxt & arr(p) & ".  "
 Next
 propcase = newstxt
End Function

Si · Jan 20, 2004, 06:55

Good job williamsba - I'll be using that in my CMS's now!

**asp_funda** · Jan 23, 2004, 16:30

I think that I'd post this function here in this thread too. It was asked for by williamsba at http://www.sitepoint.com/forums/showthread.php?t=148422 & TheTank replied to it with his function at http://www.sitepoint.com/forums/show...66&postcount=3.

So what I am posting here is just a mod of the original function by TheTank which was editied by williamsba.

Here it is.

Code:

Function LinkURLs(tempTxt, tgt)
'Prefix underscore(_) to tgt
tgt = "_" & tgt
'If tgt is blank, set it to self.
If Trim(tgt)="_" Then
tgt = "_self"
End If
 
Dim regEx
Set regEx = New RegExp
regEx.Global = True
regEx.IgnoreCase = True
temptxt = replace(temptxt, "'", "''")
'Hyperlink Email Addresses
regEx.Pattern = "([_.a-z0-9-]+@[_.a-z0-9-]+\.[a-z]{2,3})"
tempTxt = regEx.Replace(tempTxt, "<a href=""mailto:$1"">$1</a>")
'Hyperlink URL's
regEx.Pattern = "((www\.|(http|https|ftp|news|file)+\:\/\/)[_.a-z0-9-]+\.[a-z0-9\/_:@=.+?,##%&~-]*[^.|\'|\# |!|\(|?|,| |>|<|;|\)])"
tempTxt = regEx.Replace(tempTxt, "<a href=""$1"" target=" & tgt & ">$1</a>")
'Make <a href="www = <a href="http://www
tempTxt = Replace(tempTxt, "href=""www", "href=""http://www")
LinkURLs = tempTxt
End Function

Now for those who don't know about this, the explanation:-
This function parses the links in a block of text & make them HTML links. Like if you have something like www.example.com/mypage.html in a block of text, this function will make it like <a href="http://www.example.com/mypage.html" target="_self">www.example.com/mypage.html</a> so that its an actual HTML link that works, something like the one here at SPF. Also works for email links, so something like me@example.com will be converted into <a href="mailto:me@example.com" target="_self">me@example.com</a>.

But unlike the original function by TheTank, the one above addresses the issue of setting target attribute of the link. The tgt parameter is optional but if you want to set the target as _blank or _top, you can pass the parameter as blank or top(without underscores). If nothing is passed for tgt parameter, it sets the target as _self.

This function can be useful in CMSes & News or Blog scripts.

**asp_funda** · Jan 24, 2004, 12:50

Here's a mod to the link parsing function above.

Code:

Function LinkURLs(tempTxt, tgt, frm)
'Prefix underscore(_) to tgt if frm=0 or null
If (CInt(frm)=0) OR (CInt(frm)="") Then
tgt = "_" & tgt
End If
'If tgt is blank, set it to self.
If (Trim(tgt)="_") OR (Trim(tgt)="") Then
tgt = "_self"
End If
 
Dim regEx
Set regEx = New RegExp
regEx.Global = True
regEx.IgnoreCase = True
temptxt = replace(temptxt, "'", "''")
'Hyperlink Email Addresses
regEx.Pattern = "([_.a-z0-9-]+@[_.a-z0-9-]+\.[a-z]{2,3})"
tempTxt = regEx.Replace(tempTxt, "<a href=""mailto:$1"">$1</a>")
'Hyperlink URL's
regEx.Pattern = "((www\.|(http|https|ftp|news|file)+\:\/\/)[_.a-z0-9-]+\.[a-z0-9\/_:@=.+?,##%&~-]*[^.|\'|\# |!|\(|?|,| |>|<|;|\)])"
tempTxt = regEx.Replace(tempTxt, "<a href=""$1"" target=" & tgt & ">$1</a>")
'Make <a href="www = <a href="http://www
tempTxt = Replace(tempTxt, "href=""www", "href=""http://www")
LinkURLs = tempTxt
End Function

Ok NOW, so this function above now also supports targetting frames. Just
another optional parameter added by name of frm. If this parameter is set to
any number but 0, it will not add an underscore(_) to the parameter tgt
which specifies the target name. So if its omitted, then also it will add
underscore(_).
So, if you wanna target a frame, just set frm to any number, better be 1 of
ease of things.

**DaveMaxwell** · Feb 27, 2004, 07:00

There was a post in this thread asking how to post
the first 50 characters, so I wrote this thread to allow
you to do just this, but it will prevent it from stopping
in the middle of a word.

Code:

Function GetFirstN(FieldIn, NumChars)
 Dim HoldLength
 ' Eliminate excessive spaces from end
 FieldIn = Trim(FieldIn)
 ' If Less than the maximum, just return the field
 If Len(FieldIn) <= NumChars then
  GetFirstN = FieldIn : Exit Function
 End If
 
 If mid(FieldIn, NumChars, 1) = " " then
  GetFirstN = Left(FieldIn, NumChars)
 Else 
	HoldLength = instr(NumChars + 1, FieldIn, " ")
  If HoldLength = 0 then HoldLength = instrev(FieldIn, " ", NumChars) ' in case no spaces are after 
  If HoldLength = 0 then
	  ' no spaces found at all (doubtful but could happen), so take first numchars characters
   GetFirstN = Left(FieldIn, ",", NumChars)
  else
	  ' take length based on the appropriate space.
   GetFirstN = Left(FieldIn, HoldLength)
	End if
 End If
End Function

**fillup07** · Jun 26, 2004, 13:36

Can we sticky this thread?

**Thing** · Jun 26, 2004, 14:14

Guess it got unstickied. This is a good thread.

**bbolte** · Jun 26, 2004, 14:21

yeah. i thought it was also...

**asp_funda** · Jul 7, 2004, 14:59

Here are some functions that I use for my usual work. They are also listed on
my website at http://www.igeek.info/show_tutorial.php?id=1.

Function to send eMail using CDONTS.

Code:

Private Function mail(pTo, pFr, pCc, pBc, pSu, pMes, pBf, pMf, pIm)
pTo = TRIM(LCASE(pTo))
pFr = TRIM(LCASE(pFr))
pCc = TRIM(LCASE(pCc))
pBc = TRIM(LCASE(pBc))
pBf = TRIM(LCASE(pBf))
pMf = TRIM(LCASE(pMf))
pIm = TRIM(LCASE(pIm))
IF (pBf="") OR (pBf="text") THEN
pBf = "CdoBodyFormatText”
ELSE
pBf = "CdoBodyFormatHTML”
END IF
IF (pMf="") OR (pMf="text") THEN
pMf = "CdoMailFormatText"
ELSE
pMf = "CdoMailFormatMIME"
END IF
IF (pIm="") OR (pIm="1") THEN
pIm = 1
ELSEIF pIm="0" THEN
pIm = 0
ELSE
pIm = 2
END IF
Set objMail = CreateObject("CDONTS.NewMail")
WITH objMail
.From = pFr
.To = pTo
IF NOT(pCc="") THEN
.CC = pCc
END IF
IF NOT(pBc="") THEN
.BCC = pBc
END IF
.Subject = pSu
.BodyFormat = pBf
.MailFormat = pMf
.Importance = pIm
.Body = pMes
.Send
END WITH
Set objMail = NOTHING
End Function

Usage:-

Code:

strTo = "buddy@example.com" '** Receiver's eMail
strFrom = "me@example.com" '** Sender's eMail
strSubject = "Hey there" '** Subject of the eMail
strCC = "buddy2@example.com" '** send carbon copy
strBody = "<b>Hi Buddy</b><br>How are you?" '** HTML formatted Body of eMail
strBFrt = "html" '** Body format of eMail set to HTML
strMFrt = "mime" '** Mail format of eMail set to MIME
strImp = "2" '** Importance set to High
mail(strTo, strFrom, strCC, '', strSubject, strBody, strBFrt, strMFrt, strImp)
'*** This sends the eMail. Note the empty parameter after strCC. That's for pBc, the Blind Carbon Copy.
'*** We don't want to use pBc, so we've left it empty. Similarly, you can leave out any parameters.
'*** But remember that pTo, pFr, pSu & pMes are important & required.

Some stupid but useful functions

Code:

' ***** This function is used to print something *****
Private Function print(pVal)
Response.Write(pVal)
End Function
' ***** This function is used to redirect to a URL *****
Private Function reDir(pURL)
Response.Redirect(pURL)
End Function
' ***** This function is used to get value from ServerVariables collection *****
Private Function sVar(pVal)
sVar = Request.ServerVariables(pVal)
End Function

Usage:-

Code:

'***** print something with the print() function *****
print("Hello There")
strVar = "How are you doing?"
print(strVar)
'***** redirect using the reDir() function *****
reDir("http://example.com")
strURL = "mypage.asp"
reDir(strURL)
'***** get user's IP address using sVar() function *****
strIP = sVar("REMOTE_ADDR")

**asp_funda** · Aug 2, 2004, 14:10

A variant of the mail() function above, the following function uses CDOSYS to send eMails.

Code:

Private Function mailCdo(pTo, pFr, pCc, pBc, pSu, pMes, pBf)
 pTo = TRIM(LCASE(pTo))
 pFr = TRIM(pFr)
 pCc = TRIM(LCASE(pCc))
 pBc = TRIM(LCASE(pBc))
 pBf = TRIM(LCASE(pBf))
 SET objMail = Server.CreateObject("CDO.Message")
' // If your code doesn't run, then uncomment the following non // lines
' SET objConfig = CreateObject("CDO.Configuration")
' // Configuration:
' objConfig.Fields(cdoSendUsingMethod) = cdoSendUsingPort
' objConfig.Fields(cdoSMTPServer) = "localhost"
' objConfig.Fields(cdoSMTPServerPort) = 25
' objConfig.Fields(cdoSMTPAuthenticate) = cdoBasic
' // Update configuration
' objConfig.Fields.Update
' SET objMail.Configuration = objConfig
 WITH objMail
  .From = pFr
  .To = pTo
  IF NOT(pCc="") THEN
   .CC = pCc
  END IF
  IF NOT(pBc="") THEN
   .BCC = pBc
  END IF
  .Subject = pSu
  IF pBf="html" THEN
   .HTMLBody = pMes
  ELSE
   .TextBody = pMes
  END IF
  .Send
 END WITH
 SET objMail = NOTHING
' // If you uncommented non // lines above, uncomment the following line as well
' SET objConfig = NOTHING
End Function

parameters:
pTo > The destination eMail address
pFr > The originating eMail address
pCc > Carbon Copy
pBc > Blind Carbon Copy
pSu > eMail Subject
pMes > eMail Body
pBf > eMail Body format. 'html' for HTML formatted eMail or 'text' for TEXT eMail

usage:

Code:

strTo = "ss@example.com"
strFrom = "mm@example.com"
strSub = "hello there!"
strMessage = "how are you?<br>this is just a test"
strBf = "html"
CALL mailCdo(strTo, strFrom, '', '', strSub, strMessage, strBf)

**StolenGiraffe** · Aug 6, 2004, 05:58

Login-handling - Not to be used when webbapplication handles sensitive data!!
Use with a dictionary or an array, you wont need to have 1000 rows of code denying different chars....

Code:

function isBogous( strString )
  isBogous = false
  
  if inStr(strString, "'") <> 0 then isBogous = true ' Denys the '
  if inStr(strString, "=") <> 0 then isBogous = true ' Denys the =
  if inStr(strString, "?") <> 0 then isBogous = true ' Denys the ?

  if (strString & "") = "" then isBogous = true

end function

USE:
if isBogous then Response.Write("NO WAY JOSE")

if not isBogous then Response.Write("GOOD LAD")

Code:

function toShortDate( dtString ) ' YYYY-MM-DD, could easily be changed to suit your dateformats.
  
  toShortDate = Right("0000" & cStr(Year(d)), 4) & "-" & Right("00" & cStr(Month(d)), 2) & "-" & Right("00" & cStr(Day(d)), 2)

end function

USE:
toShortDate ( now()) equals (in sweden anyway) 2001-01-01 (example date)

if you have a server formatting the now() differently than the date you need to instert into the db this one does the trick or if you just want to make sure the correct date is inserted.

**starrsoft** · Aug 30, 2004, 13:14

Here's a nice function that hashes using SHA256:

Code:

<%
' See the VB6 project that accompanies this sample for full code comments on how
' it works.
'
' ASP VBScript code for generating a SHA256 'digest' or 'signature' of a string. The
' MD5 algorithm is one of the industry standard methods for generating digital
' signatures. It is generically known as a digest, digital signature, one-way
' encryption, hash or checksum algorithm. A common use for SHA256 is for password
' encryption as it is one-way in nature, that does not mean that your passwords
' are not free from a dictionary attack. 
'
' If you are using the routine for passwords, you can make it a little more secure
' by concatenating some known random characters to the password before you generate
' the signature and on subsequent tests, so even if a hacker knows you are using
' SHA-256 for your passwords, the random characters will make it harder to dictionary
' attack.
'
' NOTE: Due to the way in which the string is processed the routine assumes a
' single byte character set. VB passes unicode (2-byte) character strings, the
' ConvertToWordArray function uses on the first byte for each character. This
' has been done this way for ease of use, to make the routine truely portable
' you could accept a byte array instead, it would then be up to the calling
' routine to make sure that the byte array is generated from their string in
' a manner consistent with the string type.
'
' This is 'free' software with the following restrictions:
'
' You may not redistribute this code as a 'sample' or 'demo'. However, you are free
' to use the source code in your own code, but you may not claim that you created
' the sample code. It is expressly forbidden to sell or profit from this source code
' other than by the knowledge gained or the enhanced value added by your own code.
'
' Use of this software is also done so at your own risk. The code is supplied as
' is without warranty or guarantee of any kind.
'
' Should you wish to commission some derivative work based on this code provided
' here, or any consultancy work, please do not hesitate to contact us.
'
' Web Site:  http://www.frez.co.uk
' E-mail:	sales@frez.co.uk
Private m_lOnBits(30)
Private m_l2Power(30)
Private K(63)
Private Const BITS_TO_A_BYTE = 8
Private Const BYTES_TO_A_WORD = 4
Private Const BITS_TO_A_WORD = 32
m_lOnBits(0) = CLng(1)
m_lOnBits(1) = CLng(3)
m_lOnBits(2) = CLng(7)
m_lOnBits(3) = CLng(15)
m_lOnBits(4) = CLng(31)
m_lOnBits(5) = CLng(63)
m_lOnBits(6) = CLng(127)
m_lOnBits(7) = CLng(255)
m_lOnBits(8) = CLng(511)
m_lOnBits(9) = CLng(1023)
m_lOnBits(10) = CLng(2047)
m_lOnBits(11) = CLng(4095)
m_lOnBits(12) = CLng(8191)
m_lOnBits(13) = CLng(16383)
m_lOnBits(14) = CLng(32767)
m_lOnBits(15) = CLng(65535)
m_lOnBits(16) = CLng(131071)
m_lOnBits(17) = CLng(262143)
m_lOnBits(18) = CLng(524287)
m_lOnBits(19) = CLng(1048575)
m_lOnBits(20) = CLng(2097151)
m_lOnBits(21) = CLng(4194303)
m_lOnBits(22) = CLng(8388607)
m_lOnBits(23) = CLng(16777215)
m_lOnBits(24) = CLng(33554431)
m_lOnBits(25) = CLng(67108863)
m_lOnBits(26) = CLng(134217727)
m_lOnBits(27) = CLng(268435455)
m_lOnBits(28) = CLng(536870911)
m_lOnBits(29) = CLng(1073741823)
m_lOnBits(30) = CLng(2147483647)
m_l2Power(0) = CLng(1)
m_l2Power(1) = CLng(2)
m_l2Power(2) = CLng(4)
m_l2Power(3) = CLng(8)
m_l2Power(4) = CLng(16)
m_l2Power(5) = CLng(32)
m_l2Power(6) = CLng(64)
m_l2Power(7) = CLng(128)
m_l2Power(8) = CLng(256)
m_l2Power(9) = CLng(512)
m_l2Power(10) = CLng(1024)
m_l2Power(11) = CLng(2048)
m_l2Power(12) = CLng(4096)
m_l2Power(13) = CLng(8192)
m_l2Power(14) = CLng(16384)
m_l2Power(15) = CLng(32768)
m_l2Power(16) = CLng(65536)
m_l2Power(17) = CLng(131072)
m_l2Power(18) = CLng(262144)
m_l2Power(19) = CLng(524288)
m_l2Power(20) = CLng(1048576)
m_l2Power(21) = CLng(2097152)
m_l2Power(22) = CLng(4194304)
m_l2Power(23) = CLng(8388608)
m_l2Power(24) = CLng(16777216)
m_l2Power(25) = CLng(33554432)
m_l2Power(26) = CLng(67108864)
m_l2Power(27) = CLng(134217728)
m_l2Power(28) = CLng(268435456)
m_l2Power(29) = CLng(536870912)
m_l2Power(30) = CLng(1073741824)
	
K(0) = &H428A2F98
K(1) = &H71374491
K(2) = &HB5C0FBCF
K(3) = &HE9B5DBA5
K(4) = &H3956C25B
K(5) = &H59F111F1
K(6) = &H923F82A4
K(7) = &HAB1C5ED5
K(8) = &HD807AA98
K(9) = &H12835B01
K(10) = &H243185BE
K(11) = &H550C7DC3
K(12) = &H72BE5D74
K(13) = &H80DEB1FE
K(14) = &H9BDC06A7
K(15) = &HC19BF174
K(16) = &HE49B69C1
K(17) = &HEFBE4786
K(18) = &HFC19DC6
K(19) = &H240CA1CC
K(20) = &H2DE92C6F
K(21) = &H4A7484AA
K(22) = &H5CB0A9DC
K(23) = &H76F988DA
K(24) = &H983E5152
K(25) = &HA831C66D
K(26) = &HB00327C8
K(27) = &HBF597FC7
K(28) = &HC6E00BF3
K(29) = &HD5A79147
K(30) = &H6CA6351
K(31) = &H14292967
K(32) = &H27B70A85
K(33) = &H2E1B2138
K(34) = &H4D2C6DFC
K(35) = &H53380D13
K(36) = &H650A7354
K(37) = &H766A0ABB
K(38) = &H81C2C92E
K(39) = &H92722C85
K(40) = &HA2BFE8A1
K(41) = &HA81A664B
K(42) = &HC24B8B70
K(43) = &HC76C51A3
K(44) = &HD192E819
K(45) = &HD6990624
K(46) = &HF40E3585
K(47) = &H106AA070
K(48) = &H19A4C116
K(49) = &H1E376C08
K(50) = &H2748774C
K(51) = &H34B0BCB5
K(52) = &H391C0CB3
K(53) = &H4ED8AA4A
K(54) = &H5B9CCA4F
K(55) = &H682E6FF3
K(56) = &H748F82EE
K(57) = &H78A5636F
K(58) = &H84C87814
K(59) = &H8CC70208
K(60) = &H90BEFFFA
K(61) = &HA4506CEB
K(62) = &HBEF9A3F7
K(63) = &HC67178F2
Private Function LShift(lValue, iShiftBits)
	If iShiftBits = 0 Then
		LShift = lValue
		Exit Function
	ElseIf iShiftBits = 31 Then
		If lValue And 1 Then
			LShift = &H80000000
		Else
			LShift = 0
		End If
		Exit Function
	ElseIf iShiftBits < 0 Or iShiftBits > 31 Then
		Err.Raise 6
	End If
	
	If (lValue And m_l2Power(31 - iShiftBits)) Then
		LShift = ((lValue And m_lOnBits(31 - (iShiftBits + 1))) * m_l2Power(iShiftBits)) Or &H80000000
	Else
		LShift = ((lValue And m_lOnBits(31 - iShiftBits)) * m_l2Power(iShiftBits))
	End If
End Function
Private Function RShift(lValue, iShiftBits)
	If iShiftBits = 0 Then
		RShift = lValue
		Exit Function
	ElseIf iShiftBits = 31 Then
		If lValue And &H80000000 Then
			RShift = 1
		Else
			RShift = 0
		End If
		Exit Function
	ElseIf iShiftBits < 0 Or iShiftBits > 31 Then
		Err.Raise 6
	End If
	
	RShift = (lValue And &H7FFFFFFE) \ m_l2Power(iShiftBits)
	
	If (lValue And &H80000000) Then
		RShift = (RShift Or (&H40000000 \ m_l2Power(iShiftBits - 1)))
	End If
End Function
Private Function AddUnsigned(lX, lY)
	Dim lX4
	Dim lY4
	Dim lX8
	Dim lY8
	Dim lResult
 
	lX8 = lX And &H80000000
	lY8 = lY And &H80000000
	lX4 = lX And &H40000000
	lY4 = lY And &H40000000
 
	lResult = (lX And &H3FFFFFFF) + (lY And &H3FFFFFFF)
 
	If lX4 And lY4 Then
		lResult = lResult Xor &H80000000 Xor lX8 Xor lY8
	ElseIf lX4 Or lY4 Then
		If lResult And &H40000000 Then
			lResult = lResult Xor &HC0000000 Xor lX8 Xor lY8
		Else
			lResult = lResult Xor &H40000000 Xor lX8 Xor lY8
		End If
	Else
		lResult = lResult Xor lX8 Xor lY8
	End If
 
	AddUnsigned = lResult
End Function
Private Function Ch(x, y, z)
	Ch = ((x And y) Xor ((Not x) And z))
End Function
Private Function Maj(x, y, z)
	Maj = ((x And y) Xor (x And z) Xor (y And z))
End Function
Private Function S(x, n)
	S = (RShift(x, (n And m_lOnBits(4))) Or LShift(x, (32 - (n And m_lOnBits(4)))))
End Function
Private Function R(x, n)
	R = RShift(x, cLng(n And m_lOnBits(4)))
End Function
Private Function Sigma0(x)
	Sigma0 = (S(x, 2) Xor S(x, 13) Xor S(x, 22))
End Function
Private Function Sigma1(x)
	Sigma1 = (S(x, 6) Xor S(x, 11) Xor S(x, 25))
End Function
Private Function Gamma0(x)
	Gamma0 = (S(x, 7) Xor S(x, 18) Xor R(x, 3))
End Function
Private Function Gamma1(x)
	Gamma1 = (S(x, 17) Xor S(x, 19) Xor R(x, 10))
End Function
Private Function ConvertToWordArray(sMessage)
	Dim lMessageLength
	Dim lNumberOfWords
	Dim lWordArray()
	Dim lBytePosition
	Dim lByteCount
	Dim lWordCount
	Dim lByte
	
	Const MODULUS_BITS = 512
	Const CONGRUENT_BITS = 448
	
	lMessageLength = Len(sMessage)
	
	lNumberOfWords = (((lMessageLength + ((MODULUS_BITS - CONGRUENT_BITS) \ BITS_TO_A_BYTE)) \ (MODULUS_BITS \ BITS_TO_A_BYTE)) + 1) * (MODULUS_BITS \ BITS_TO_A_WORD)
	ReDim lWordArray(lNumberOfWords - 1)
	
	lBytePosition = 0
	lByteCount = 0
	Do Until lByteCount >= lMessageLength
		lWordCount = lByteCount \ BYTES_TO_A_WORD
		
		lBytePosition = (3 - (lByteCount Mod BYTES_TO_A_WORD)) * BITS_TO_A_BYTE
		
		lByte = AscB(Mid(sMessage, lByteCount + 1, 1))
		
		lWordArray(lWordCount) = lWordArray(lWordCount) Or LShift(lByte, lBytePosition)
		lByteCount = lByteCount + 1
	Loop
	lWordCount = lByteCount \ BYTES_TO_A_WORD
	lBytePosition = (3 - (lByteCount Mod BYTES_TO_A_WORD)) * BITS_TO_A_BYTE
	lWordArray(lWordCount) = lWordArray(lWordCount) Or LShift(&H80, lBytePosition)
	lWordArray(lNumberOfWords - 1) = LShift(lMessageLength, 3)
	lWordArray(lNumberOfWords - 2) = RShift(lMessageLength, 29)
	
	ConvertToWordArray = lWordArray
End Function
Public Function SHA256(sMessage)
	Dim HASH(7)
	Dim M
	Dim W(63)
	Dim a
	Dim b
	Dim c
	Dim d
	Dim e
	Dim f
	Dim g
	Dim h
	Dim i
	Dim j
	Dim T1
	Dim T2
	
	HASH(0) = &H6A09E667
	HASH(1) = &HBB67AE85
	HASH(2) = &H3C6EF372
	HASH(3) = &HA54FF53A
	HASH(4) = &H510E527F
	HASH(5) = &H9B05688C
	HASH(6) = &H1F83D9AB
	HASH(7) = &H5BE0CD19
	
	M = ConvertToWordArray(sMessage)
	
	For i = 0 To UBound(M) Step 16
		a = HASH(0)
		b = HASH(1)
		c = HASH(2)
		d = HASH(3)
		e = HASH(4)
		f = HASH(5)
		g = HASH(6)
		h = HASH(7)
		
		For j = 0 To 63
			If j < 16 Then
				W(j) = M(j + i)
			Else
				W(j) = AddUnsigned(AddUnsigned(AddUnsigned(Gamma1(W(j - 2)), W(j - 7)), Gamma0(W(j - 15))), W(j - 16))
			End If
				
			T1 = AddUnsigned(AddUnsigned(AddUnsigned(AddUnsigned(h, Sigma1(e)), Ch(e, f, g)), K(j)), W(j))
			T2 = AddUnsigned(Sigma0(a), Maj(a, b, c))
			
			h = g
			g = f
			f = e
			e = AddUnsigned(d, T1)
			d = c
			c = b
			b = a
			a = AddUnsigned(T1, T2)
		Next
		
		HASH(0) = AddUnsigned(a, HASH(0))
		HASH(1) = AddUnsigned(b, HASH(1))
		HASH(2) = AddUnsigned(c, HASH(2))
		HASH(3) = AddUnsigned(d, HASH(3))
		HASH(4) = AddUnsigned(e, HASH(4))
		HASH(5) = AddUnsigned(f, HASH(5))
		HASH(6) = AddUnsigned(g, HASH(6))
		HASH(7) = AddUnsigned(h, HASH(7))
	Next
	
	SHA256 = LCase(Right("00000000" & Hex(HASH(0)), 8) & Right("00000000" & Hex(HASH(1)), 8) & Right("00000000" & Hex(HASH(2)), 8) & Right("00000000" & Hex(HASH(3)), 8) & Right("00000000" & Hex(HASH(4)), 8) & Right("00000000" & Hex(HASH(5)), 8) & Right("00000000" & Hex(HASH(6)), 8) & Right("00000000" & Hex(HASH(7)), 8))
End Function
%>

**asp_funda** · Aug 31, 2004, 02:41

Is this function's hash any different from the SHA1
hashes that we use?

**starrsoft** · Aug 31, 2004, 05:42

I'm not sure. I'm not much of a hash/encryption expert. What method do you
use for SHA1? Coded function? Built-in VBScript function? I would sorta assume
that the SHA256 would stand for 256 bit encryption, but I'm not sure. (see first
two sentences

If you go to their website, they have an MD5 hash function
as well. On their website they have the SHA256 and MD5 functions in VB and
VBScript. The MD5 function is in JavaScript as well.

**asp_funda** · Aug 31, 2004, 11:56

Well, I use a user-defined function like this for SHA1
hashing. It isn't built in VBScript. And as far as I know,
its 160bit hashing. So maybe the function you posted
produces a stronger hash. I think I'll hash a string with
both functions & compare them.

**awasson** · Oct 13, 2004, 23:39

Here's a simple function for your toolbox for applying XSL to XML and passing an array of arguments that can be used as parameters in the stylesheet. If you haven't needed this yet... You will. ;~)

Code:

<%

   Function transformXMLArguments(strXMLDoc, strXSLDoc, arrParams)

   	Set xml = Server.CreateObject("MSXML2.FreeThreadedDOMDocument.3.0")
   	xml.async = false
   	xml.load strXMLDoc

   	Set xsl = Server.CreateObject("MSXML2.FreeThreadedDOMDocument.3.0")
   	xsl.async = false
  	xsl.load strXSLDoc

   	Set template = Server.CreateObject("MSXML2.XSLTemplate")
   	template.stylesheet = xsl
   	set processor = template.createProcessor()

   	processor.input = xml
	
	For i = 0 to UBound(arrParams)
		If arrParams(i) <> "" Then
			processor.addParameter "param" & (i+1), arrParams(i)
		End If
	Next

   	processor.transform()

	transformXMLArguments = (processor.output)
   
   	Set xml = nothing
   	Set xsl = nothing
	Set template = nothing
    set processor = nothing
   End Function
   
%>

It would be used as follows if you are using parameters in your stylesheet:

<%
myarray = array("some text", 23, 34)
response.write transformXMLArguments(Server.MapPath("../xml/sitemap.xml"), Server.MapPath(xslTemp), myarray)
%>

You can access your parameters in your stylesheet by instantiating them with the prefix param and their number in the array. I started with 1. so in your stylesheet for this example you'll have something like:
<xsl:param name="param1" /> 
<xsl:param name="param2" /> 
<xsl:param name="param3" /> 

Or you can use it without parameters like so:

<%
response.write transformXMLArguments(Server.MapPath("xml-file.xml"), Server.MapPath("xsl-file.xsl"), "")
%>

Have fun - Andrew

**asp_funda** · Nov 1, 2004, 13:03

Here's a function that I made long ago to read the contents of a file in a variable. This function accepts the file name as parameter & is a bit raw, but it serves my purpose, so hopefully it'll serve others as well.

Code:

Private Function readMyFile(pFileName)
	SET FSO = Server.CreateObject("Scripting.FileSystemObject")
	IF (TRIM(pFileName)="") THEN
		EXIT FUNCTION
	ELSE
		IF FSO.FileExists(Server.MapPath(pFileName)) THEN
			SET mFile = FSO.OpenTextFile(Server.MapPath(pFileName))
			readMyFile = mFile.ReadAll
		ELSE
			readMyFile = "File Not Found"
		END IF
	END IF
	SET mFile = NOTHING
	SET FSO = NOTHING
End Function

Its usage is quite simple.

Code:

strFileName = "data/myFile.asp"
strFileContent = readMyFile(strFileName)	'Data of file read up into the variable

**MiloSpod** · Nov 9, 2004, 05:31

Clean all the HTML tags to reviel "content"

function ClearHTMLTags(strHTML, intWorkFlow)
dim regEx, strTagLess
strTagless = strHTML
set regEx = New RegExp
regEx.IgnoreCase = True
regEx.Global = True
if intWorkFlow <> 1 then
regEx.Pattern = "<[^>]*>"
strTagLess = regEx.Replace(strTagLess, " ")
end if
if intWorkFlow > 0 and intWorkFlow < 3 then
regEx.Pattern = "[<]"
strTagLess = regEx.Replace(strTagLess, "<")
regEx.Pattern = "[>]"
strTagLess = regEx.Replace(strTagLess, ">")
end if
set regEx = nothing
ClearHTMLTags = replace(strTagLess," "," ")
end function

**MiloSpod** · Nov 9, 2004, 05:32

Days in a month

function getDaysInMonth(strMonth,strYear)
dim strDays
Select Case cint(strMonth)
Case 1,3,5,7,8,10,12:
strDays = 31
Case 4,6,9,11:
strDays = 30
Case 2:
if ((cint(strYear) mod 4 = 0 and _
cint(strYear) mod 100 <> 0) _
or ( cint(strYear) mod 400 = 0) ) then
strDays = 29
else
strDays = 28
end if
End Select
getDaysInMonth = strDays
end function

**MiloSpod** · Nov 9, 2004, 05:33

Day suffix

function dayDateSuffix(intday)
select case right(intday,1)
case "1"
dayDateSuffix="st"
case "2"
dayDateSuffix="nd"
case "3"
dayDateSuffix="rd"
case else
dayDateSuffix="th"
end select
if len(intday)=2 and intDay>9 and intDay<21 then
dayDateSuffix="th"
end if
dayDateSuffix="<sup>"& dayDateSuffix & "</sup>"
end function