<% 'encryption functions 'useful for specific kinds of page-to-page encryption 'a side benefit is that these require no installed objects 'Gus Mueller 'November 26 1999 if strTransform="" then strTransform="bkpoghqwzx" end if if strBaseKey="" then strBaseKey="kldijhh" end if function checksum(byval strIn) dim intParse, chrThis, intSum strIn=ucase(cstr(strIn)) intSum=0 for intParse=1 to len(strIn) chrThis=mid(strIn, intParse, 1) intSum=intSum+asc(chrThis) next checksum=intSum end function function addStrings(strIn1, strIn2) dim intParse, chrThis1, chrThis2, chrSum, strOut strIn1=ucase(cstr(strIn1)) strIn2=ucase(cstr(strIn2)) strOut="" for intParse=1 to len(strIn1) if intParse<= len(strIn1) then chrThis1=mid(strIn1, intParse, 1) else chrThis1="" end if if intParse mod len(strIn2)>0 then chrThis2=mid(strIn2, (intParse mod len(strIn2)), 1) else chrThis2=mid(strIn2, len(strIn2), 1) end if chrSum=addCharacter(chrthis1, chrthis2) strOut=strOut & chrSum next addStrings=strOut end function function subtractStrings(strIn1, strIn2) dim intParse, chrThis1, chrThis2, chrSum, strOut strIn1=ucase(cstr(strIn1)) strIn2=ucase(cstr(strIn2)) strOut="" for intParse=1 to len(strIn1) if intParse<= len(strIn1) then chrThis1=mid(strIn1, intParse, 1) else chrThis1="" end if if intParse mod len(strIn2)>0 then chrThis2=mid(strIn2, (intParse mod len(strIn2)), 1) else chrThis2=mid(strIn2, len(strIn2), 1) end if chrSum=subtractCharacter(chrthis1, chrthis2) strOut=strOut & chrSum next subtractStrings=strOut end function function addCharacter(byval chrIn1, byval chrIn2) dim int1, int2, intSum if chrIn1<>"" then int1=asc(ucase(chrIn1))-64 else int1=0 end if if chrIn2<>"" then int2=asc(ucase(chrIn2))-64 else int2=0 end if intSum=(int1+int2) mod 26 if intSum=0 then intSum=26 intSum=intSum+64 addCharacter=chr(intSum) end function function subtractCharacter(byval chrIn1, byval chrIn2) dim int1, int2, intSum if chrIn1<>"" then int1=asc(ucase(chrIn1))-64 else int1=0 end if if chrIn2<>"" then int2=asc(ucase(chrIn2))-64 else int2=0 end if intSum=(int1-int2) mod 26 if intSum<1 then intSum=intSum+26 end if if intSum=0 then intSum=26 intSum=intSum+64 subtractCharacter=chr(intSum) end function function characterchecksum(strIn) dim intcheck, strOut intCheck=checksum(strIn) mod 26 strOut=chr(intCheck +65) characterchecksum=strOut end function function encryptString(strIn, strKey) dim strTemp strTemp=addstrings(strIn, strKey) strTemp = characterchecksum(strIn) & strTemp & characterchecksum(strTemp) encryptString=strTemp end function function decryptString(byval strIn, byval strKey) dim strPossibleChecksum, strRest, strCloserChecksum, strUltraRest, strOut strPossibleChecksum=left(strIn, 1) strRest=mid(strIn, 2) strCloserChecksum=right(strRest,1) strUltraRest=left(strRest, len(strRest)-1) strDecrypted=subtractstrings(strUltraRest, strKey) if characterchecksum(strDecrypted)=strPossibleChecksum and characterchecksum(strUltraRest)=strCloserChecksum then strOut=strDecrypted else strOut="error" end if decryptString=strOut end function function randomkey() dim strOut, t strOut="" randomize for t=1 to 4 strOut=chr(int(rnd(1)*26)+65) & strOut next randomkey=strOut end function function enc(strIn) dim strKey, strFirst, strLast, strOut if strBaseKey="" then response.write "You must supply a strBaseKey" response.end end if strKey=randomkey() strFirst=left(strKey, 2) strLast=right(strKey, 2) strKey=AddStrings(strKey, strBaseKey) strOut=strFirst & encryptstring(ucase(strIn), strKey) & strLast enc=strOut end function function decr(strIn) dim strMid, strFirst, strLast, strOut, strKey if strBaseKey="" then response.write "You must supply a strBaseKey" response.end end if strFirst=left(strIn, 2) strLast=right(strIn, 2) strKey=ucase(strFirst & strLast) strKey=AddStrings(strKey, strBaseKey) strMid=ucase(mid(strIn, 3, len(strIn)-4)) strOut=decryptstring(strMid, strKey) decr=strOut end function function numberstoletters(byval strIn, byval strTransform) dim t, strOut strOut="" strIn=cstr(strIn) for t=1 to len(strIn) strOut=strOut & digittoLetter(mid(strIn, t, 1), strTransform) next numberstoletters = strOut end function function letterstonumbers(byval strIn, byval strTransform) dim t, strOut strOut="" strIn=cstr(strIn) for t=1 to len(strIn) strOut=strOut & lettertodigit(mid(strIn, t, 1), strTransform) next letterstonumbers = strOut end function function encryptid(strIn) dim strOut if len(strTransform)<10 then response.write vbNewLine & "Encryption Library Error: You need some sort of ten character" & vbNewLine response.write "strTransform set up where each unique character " & vbNewLine response.write "corresponds to a digit."& vbNewLine response.end end if strOut=enc(numberstoletters(strIn, strTransform)) encryptid=lcase(strOut) end function function decryptid(strIn) if strIn<>"" then dim strOut if len(strTransform)<10 then response.write vbNewLine & "Encryption Library Error: You need some sort of ten character" & vbNewLine response.write "strTransform set up where each unique character " & vbNewLine response.write "corresponds to a digit."& vbNewLine response.end end if strOut=letterstonumbers(decr(ucase(strIn)), strTransform) else strOut="error" end if decryptid=strOut end function function digittoLetter(byval digIn, byval strTransform) dim strOut if isnumeric(digin) then strOut=mid(strTransform, cint(digin)+1, 1) end if digittoLetter=ucase(strOut) end function function lettertodigit(byval chrIn, byval strTransform) dim strOut, bwlDone, t bwlDone=false t=0 do until bwlDone or t>10 if lcase(chrIn)=mid(strTransform, t+1, 1) then strOut=cstr(t) bwlDone=true end if t=t+1 loop lettertodigit=strOut end function function badword(strIn) dim strbadwords, t, arrBadwords, bwlBad strbadwords="fuc|tit|shit|pis|as|dam|ana|god|dic|pus" arrBadwords=split(strbadwords, "|") t=0 bwlBad=false do until t=ubound(arrBadwords) or bwlBad if instr(lcase(strIn), arrBadwords(t)) then bwlBad=true t=t+1 loop badword=bwlBad end function function goodword(strIn) dim strbadwords, t, arrBadwords, bwlGood strbadwords="the|flo|are|man|can|don|ita|dog" arrBadwords=split(strbadwords, "|") t=0 bwlGood=false do until t=ubound(arrBadwords) or bwlGood if instr(lcase(strIn), arrBadwords(t)) then bwlGood=true t=t+1 loop goodword=bwlGood end function %>