ASP的自定义函数[6]

CFS編碼加密
Function CfsEnCode(CodeStr)

Dim CodeLen
Dim CodeSpace
Dim NewCode

CodeLen = 30
CodeSpace = CodeLen - Len(CodeStr)

If Not CodeSpace < 1 Then
For cecr = 1 To CodeSpace
CodeStr = CodeStr & Chr(21)
Next
End If

NewCode = 1

Dim Been
For cecb = 1 To CodeLen
Been = CodeLen + Asc(Mid(CodeStr,cecb,1)) * cecb
NewCode = NewCode * Been
Next

CodeStr = NewCode
NewCode = Empty

For cec = 1 To Len(CodeStr)
NewCode = NewCode & CfsCode(Mid(CodeStr,cec,3))
Next

For cec = 20 To Len(NewCode) - 18 Step 2
CfsEnCode = CfsEnCode & Mid(NewCode,cec,1)
Next

End Function

Function CfsCode(Word)
For cc = 1 To Len(Word)
CfsCode = CfsCode & Asc(Mid(Word,cc,1))
Next
CfsCode = Hex(CfsCode)
End Function

編碼函式 CfsEncode() 的使用：

Var = CfsEncode(字串來源)

範例：
<%Dim SourceDim Var1Source = "test"Var1 = CfsEncode(Source)Response.Write Var1%>

--------------------------------------------------------------------------------

-- VB版rc4算法
Public Sub main()
Dim key As String
For I = 1 To 16
Randomize
key = key & Chr(Rnd * 255)
Next I
MsgBox RC4(RC4("Welcome To Plindge Studio!", key), key)
End Sub
Public Function RC4(inp As String, key As String) As String
Dim S(0 To 255) As Byte, K(0 To 255) As Byte, I As Long
Dim j As Long, temp As Byte, Y As Byte, t As Long, x As Long
Dim Outp As String 

For I = 0 To 255
S(i) = I
Next

j = 1
For I = 0 To 255
If j > Len(key) Then j = 1
K(i) = Asc(Mid(key, j, 1))
j = j + 1
Next I

j = 0
For I = 0 To 255
j = (j + S(i) + K(i)) Mod 256
temp = S(i)
S(i) = S(j)
S(j) = temp
Next I

I = 0
j = 0
For x = 1 To Len(inp)
I = (I + 1) Mod 256
j = (j + S(i)) Mod 256
temp = S(i)
S(i) = S(j)
S(j) = temp
t = (S(i) + (S(j) Mod 256)) Mod 256
Y = S(t)

Outp = Outp & Chr(Asc(Mid(inp, x, 1)) Xor Y)
Next
RC4 = Outp
End Function

--------------------------------------------------------------------------------
-- 
用正则表达式写的HTML分离函数 
存成.asp文件，执行，你用ASPHTTP抓内容的时候用这个很爽，当然自己要改进一下了
<%
Option Explicit

Function stripHTML(strHTML)
'Strips the HTML tags from strHTML

Dim objRegExp, strOutput
Set objRegExp = New Regexp

objRegExp.IgnoreCase = True
objRegExp.Global = True
objRegExp.Pattern = "<.+?>"

'Replace all HTML tag matches with the empty string
strOutput = objRegExp.Replace(strHTML, "")

'Replace all < and > with < and >
strOutput = Replace(strOutput, "<", "<")
strOutput = Replace(strOutput, ">", ">")

stripHTML = strOutput 'Return the value of strOutput

Set objRegExp = Nothing
End Function

%>

<form method="post" id=form1 name=form1>
<b>Enter an HTML String:</b><br>
<textarea name="txtHTML" cols="50" rows="8" wrap="virtual"><%=Request("txtHTML")%></textarea>
<p>
<input type="submit" value="Strip HTML Tags!" id=submit1 name=submit1>
</form>

<% if Len(Request("txtHTML")) > 0 then %>
<p><hr><p>
<b><u>View of string <i>with no</i> HTML stripping:</u></b><br>
<xmp>
<%=Request("txtHTML")%>
</xmp><p>
<b><u>View of string <i>with</i> HTML stripping:</u></b><br>
<pre>
<%=StripHTML(Request("txtHTML"))%>
</pre>
<% End If %>

--------------------------------------------------------------------------------
-- 
如何检测备注字段的字节数
视服务器操作系统语种不同,而采取不同的方法: 
1.E文下,len(rs("field")),就行了.len("中文abc")=7 
2.Z文下,复杂一点,len("中文abc")=5 
lenB("中文abc")=10,所以需要自己写程序判断其长度. 
Function strLen(str) 
dim I,l,t,c 
l=len(str) 
t=l 
for i=1 to l 
c=asc(mid(str,I,1)) 
if c<0 then c=c+65536 
if c>255 then 
t=t+1 
end if 
next 
strLen=t 
end function
--------------------------------------------------------------------------------
-- 
FSO自写自用的几个函数 以前贴过的
''''使用FSO修改文件特定内容的函数
function FSOchange(filename,Target,String)
Dim objFSO,objCountFile,FiletempData
Set objFSO = Server.CreateObject("Scripting.FileSystemObject")
Set objCountFile = objFSO.OpenTextFile(Server.MapPath(filename),1,True)
FiletempData = objCountFile.ReadAll
objCountFile.Close
FiletempData=Replace(FiletempData,Target,String)
Set objCountFile=objFSO.CreateTextFile(Server.MapPath(filename),True)
objCountFile.Write FiletempData 
objCountFile.Close
Set objCountFile=Nothing
Set objFSO = Nothing
End Function
''''使用FSO读取文件内容的函数
function FSOFileRead(filename)
Dim objFSO,objCountFile,FiletempData
Set objFSO = Server.CreateObject("Scripting.FileSystemObject")
Set objCountFile = objFSO.OpenTextFile(Server.MapPath(filename),1,True)
FSOFileRead = objCountFile.ReadAll
objCountFile.Close
Set objCountFile=Nothing
Set objFSO = Nothing
End Function
''''使用FSO读取文件某一行的函数
function FSOlinedit(filename,lineNum)
if linenum < 1 then exit function
dim fso,f,temparray,tempcnt
set fso = server.CreateObject("scripting.filesystemobject")
if not fso.fileExists(server.mappath(filename)) then exit function
set f = fso.opentextfile(server.mappath(filename),1)
if not f.AtEndofStream then
tempcnt = f.readall
f.close
set f = nothing
temparray = split(tempcnt,chr(13)&chr(10))
if lineNum>ubound(temparray)+1 then
exit function
else
FSOlinedit = temparray(lineNum-1)
end if
end if
end function
''''使用FSO写文件某一行的函数
function FSOlinewrite(filename,lineNum,Linecontent)
if linenum < 1 then exit function
dim fso,f,temparray,tempCnt
set fso = server.CreateObject("scripting.filesystemobject")
if not fso.fileExists(server.mappath(filename)) then exit function
set f = fso.opentextfile(server.mappath(filename),1)
if not f.AtEndofStream then
tempcnt = f.readall
f.close
temparray = split(tempcnt,chr(13)&chr(10))
if lineNum>ubound(temparray)+1 then
exit function
else
temparray(lineNum-1) = lineContent
end if
tempcnt = join(temparray,chr(13)&chr(10))
set f = fso.createtextfile(server.mappath(filename),true)
f.write tempcnt
end if
f.close
set f = nothing
end function
''''使用FSO添加文件新行的函数
function FSOappline(filename,Linecontent)
dim fso,f
set fso = server.CreateObject("scripting.filesystemobject")
if not fso.fileExists(server.mappath(filename)) then exit function
set f = fso.opentextfile(server.mappath(filename),8,1)
f.write chr(13)&chr(10)&Linecontent
f.close
set f = nothing
end function
''''读文件最后一行的函数
function FSOlastline(filename)
dim fso,f,temparray,tempcnt
set fso = server.CreateObject("scripting.filesystemobject")
if not fso.fileExists(server.mappath(filename)) then exit function
set f = fso.opentextfile(server.mappath(filename),1)
if not f.AtEndofStream then
tempcnt = f.readall
f.close
set f = nothing
temparray = split(tempcnt,chr(13)&chr(10))
FSOlastline = temparray(ubound(temparray))
end if
end function
还有，创建文件夹：
sub CreateFolder(Foldername)
Set afso = Server.CreateObject("Scripting.FileSystemObject")
if afso.folderexists(server.mappath(Foldername))=true then
else
afso.createfolder(server.mappath(foldername))
end if
set afso=nothing
end sub

用法，createfolder(foldername)

--------------------------------------------------------------------------------

-- 平时编码时常用到的函数！
''检查字符串是否包含非法字符串
FUNCTION BadWords(strContent)
DIM objRegExp
Set objRegExp = new RegExp
objRegExp.IgnoreCase = true
objRegExp.Global = true
objRegExp.Pattern = "李.{0,10}洪.{0,10}志|法.{0,10}轮.{0,10}功|法.{0,10}轮.{0,10}大.{0,10}法|明.{0,10}慧.{0,10}网|六.{0,10}四.{0,10}真.{0,10}相|修炼.{0,10}大法"
BadWords = objRegExp.Test(strContent)
Set objRegExp = Nothing
END FUNCTION
　 
'******************************
'||Function GetRootDir()
'||Created by Cj, 2000/8/28
'||取得网站的URL的根目录
'******************************
Function GetRootDir()
If Application("RootDir") <> "" And Not isNull(Application("RootDir")) then
GetRootDir = Application("RootDir")
Exit Function
End if

dim strRoot, intRootEnd
strRoot = Request.ServerVariables("SCRIPT_NAME")
intRootEnd = Instr(2, strRoot, "/")
if intRootEnd > 1 then
strRoot = Left(strRoot, intRootEnd)
End if
Application.Lock()
Application("RootDir") = strRoot
Application.UnLock()
GetRootDir = strRoot 
End Function
--------------------------------------------------------------------------------