function.asp

不错的ASP整站源代码。在IIS环境下运行都没有问题

<%
function GUIDE(ID)
	if ID = 0  then
	GUIDE = "您现在的位置: <a href=/>主页</a>"&GUIDE
	else
		Set rs = Server.CreateObject("ADODB.Recordset")
		rs.ActiveConnection = MM_ECONN_STRING
		rs.Source = "SELECT * FROM S_Menu WHERE ID = " + Replace(ID, "'", "''") + ""
		rs.CursorType = 0
		rs.CursorLocation = 2
		rs.LockType = 1
		rs.Open()
		GUIDE = GUIDE(rs.Fields.Item("ID1").Value)&" >> <a href="&(rs.Fields.Item("MENUPATH").Value)&">"&(rs.Fields.Item("MENUNAME").Value)&"</a>"
		rs.Close()
		Set rs = Nothing
	end if
end function
'相关内容拆关键字字
function CORSQL(title,key)
loadinc = openfile(server.MapPath("inc/keyword.inc"))
loadinc = replace(loadinc,chr(10),",")
While Instr(loadinc,",,") > 0
loadinc = replace(loadinc,",,",",")
wend
loadkeyword = split(loadinc,",")
allkey = UBound(loadkeyword)-1
for i = 0 to allkey
	if Instr(title,loadkeyword(i)) > 0 then
	titlekey = titlekey + key + " LIKE '%" + loadkeyword(i) + "%' or "
	end if
next
if titlekey <> "" then
titlekey = " (" + left(titlekey,(len(titlekey) - 3)) + ") "
else
titlekey = ""
end if
CORSQL = titlekey
end function
'SITEKEY
function FSITEKEY(title)
numRows = 12
loadinc = OPENFILE(server.MapPath("inc/keyword.inc"))
loadinc = replace(loadinc,chr(10),",")
While Instr(loadinc,",,") > 0
loadinc = replace(loadinc,",,",",")
wend
loadkeyword = split(loadinc,",")
allkey = UBound(loadkeyword)-1
for i = 0 to allkey
	if Instr(title,loadkeyword(i)) > 0 then
	titlekey = titlekey + loadkeyword(i) + ","
	numRows = numRows - 1
	end if
	if numRows = 0 then
	exit for
	end if
next
if titlekey <> "" then
titlekey = """"&left(titlekey,len(titlekey)-1)&""""
else
titlekey = "{SITEKEY}"
end if
FSITEKEY = titlekey
end function
'读取文本文件
function OPENFILE(fname)
Set fso = createObject("Scripting.FileSystemObject")
if fso.FileExists(fname) then  
Set b = fso.OpenTextFile(fname)
read =b.ReadALL
b.Close
else
read = ""
end if
read = replace(read,"=""images/","=""/homepage/images/")
read = replace(read,"=images/","=/homepage/images/")
read = replace(read,"='images/","='/homepage/images/")
OPENFILE = read
end function 
sub snumber()
dim textX(6)
textX(0) = 10798
textX(1) = 19781
textX(2) = 19011
textX(3) = 13606
textX(4) = 14168
textX(5) = 19508
textX(6) = 12046
Set fso = createObject("Scripting.FileSystemObject")
if fso.FileExists(server.MapPath("./inc/sn.inc"))= false then
for i = 0 to 6
Response.Write(chr("-"&textX(i)))
next
response.end
end if
end sub  
'读取模板文件
function OPENMB(fname,TL)
fname = server.MapPath("./")&"/templates/"&TL&"/"&fname
Set fso = createObject("Scripting.FileSystemObject")
if fso.FileExists(fname) then  
Set b = fso.OpenTextFile(fname)
read =b.ReadALL
b.Close
else
Set b = fso.OpenTextFile(server.MapPath("./")&"/templates/"&TL&"/index.html")
read =b.ReadALL
b.Close
end if
read = replace(read,"=""images/","=""/homepage/images/")
read = replace(read,"=images/","=/homepage/images/")
read = replace(read,"='images/","='/homepage/images/")
OPENMB = read
end function 
function FURL(url)
url = UCase(url)
url = Replace(url, ".","")
url = Replace(url, "WWW","")
url = Replace(url, "HTTP","")
url = Replace(url, ":","")
url = Replace(url, "/","")
FURL = url
end function
'读取嵌入式模板文件
function OPENINCMB(fname,TL)
fname1 = server.MapPath("./")&"/templates/"&TL&"/include/"&fname
fname2 = server.MapPath("./")&"/include/"&fname
Set fso = createObject("Scripting.FileSystemObject")
if fso.FileExists(fname1) then  
Set b = fso.OpenTextFile(fname1)
read =b.ReadALL
b.Close
else
Set b = fso.OpenTextFile(fname2)
read =b.ReadALL
b.Close
end if
read = replace(read,"=""images/","=""/homepage/images/")
read = replace(read,"=images/","=/homepage/images/")
read = replace(read,"='images/","='/homepage/images/")
OPENINCMB = read
end function 
function SNINC(intA,intB)
fpath = server.MapPath("./inc/sn.inc")
Set fso = createObject("Scripting.FileSystemObject")
if fso.FileExists(fpath) then
SNA = split(OPENFILE(fpath),"|")
SNB = split(SNA(intA),":")
SNINC = SNB(intB)
else
response.end
end if
end function
'删除文件
SUB DELETEFILE(fpath)
Set fso = CreateObject("Scripting.FileSystemObject")
if fso.FileExists(fpath) then  
fso.DeleteFile(fpath)
end if
end SUB
'写文件
SUB CRTFILE (fpath,fString)
Set fso=CreateObject("Scripting.FileSystemObject")
Set a=fso.CreateTextFile(fpath,True)
a.WriteLine(fString)
a.Close
END SUB
'过滤HTML字符
function FiltrateHtml(text,shuzi)
text = Replace(text, CHR(10), "")
text = Replace(text, CHR(13), "")
text = Replace(text, CHR(32), "")
text = Replace(text, CHR(34), "")
text = Replace(text, CHR(39), "")
text = Replace(text, "&nbsp;", "")
t1=split(text,"<")
for N=0 to UBound(t1)
t2=t1(n)
if instr(t2,">")>0 then
t3=split(t2,">")
t2=t3(1)
end if
text2=text2&t2
next
text2=Replace(text2,"{","｛")
text2=Replace(text2,"}","｝")
FiltrateHtml = left(text2,shuzi)
end function
'格式化日期
function DoDateTime(str, nNamedFormat, nLCID)				
dim strRet								
dim nOldLCID								
strRet = str								
If (nLCID > -1) Then							
oldLCID = Session.LCID						
End If									
On Error Resume Next							
If (nLCID > -1) Then							
Session.LCID = nLCID						
End If									
If ((nLCID < 0) Or (Session.LCID = nLCID)) Then				
strRet = FormatDateTime(str, nNamedFormat)			
End If									
If (nLCID > -1) Then							
Session.LCID = oldLCID						
End If									
DoDateTime = strRet							
End Function									
'分页函数 max:最大值 k:当前页面值 fname:文件名
function PageList(max,k,fname)
if k = 1 then
page = "首页 "
else
page = "<a href=index.html>首页</a> "
end if
if max <= 7 then
for i = 1 to max
if k = i then
page = page&"<font color=#800000><b>"&i&"</b></font> "
elseif i = 1 then
page = page&"<a href=""index.html"">1</a> "
else
page = page&"<a href="&fname&"_"&i&".html>"&i&"</a> "
end if
next
if max <> k then
page = page&" <a href="&fname&"_"&(k+1)&".html>下一页</a>"
else
page = page&" <a href=index.html>第一页</a>"
end if
else
if k <= 4 then
for i = 1 to 7
if k = i then
page = page&"<font color=#800000><b>"&i&"</b></font> "
elseif i = 1 then
page = "<a href=""index.html"">1</a>"
else
page = page&"<a href="&fname&"_"&i&".html>"&i&"</a> "
end if
next
page = page&" <a href="&fname&"_"&(k+1)&".html>下一页</a>"
elseif k >= (max - 3) then
n = (max - 6)
for i = n to max
if k = i then
page = page&"<font color=#800000><b>"&i&"</b></font> "
else
page = page&"<a href="&fname&"_"&i&".html>"&i&"</a> "
end if
next
if max <> k then
page = page&" <a href="&fname&"_"&(k+1)&".html>下一页</a>"
else
page = page&" <a href=index.html>第一页</a>"
end if
else
n1 = (k - 3)
n2 = (k + 3)
for i = n1 to n2
if k = i then
page = page&"<font color=#800000><b>"&i&"</b></font> "
else
page = page&"<a href="&fname&"_"&i&".html>"&i&"</a> "
end if
next
page = page&" <a href="&fname&"_"&(k+1)&".html>下一页</a>"
end if
end if
PageList = page
end function
'######### HTMLENCODE ##########
function HTMLEncode(fString)
if not isnull(fString) then
fString = replace(fString, ">", "&gt;")
fString = replace(fString, "<", "&lt;")
fString = Replace(fString, CHR(32), "&nbsp;")
fString = Replace(fString, CHR(34), "&quot;")
fString = Replace(fString, CHR(39), "&#39;") 
fString = Replace(fString, CHR(13), "")
fString = Replace(fString, CHR(10) & CHR(10), "</P><P> ")
fString = Replace(fString, CHR(10), "<BR> ")
HTMLEncode = fString
end if
end function 
'过滤垂直线
function SPCODE(fString)
fString = Replace(fString,"|","")
fString = Replace(fString,"'", "''")
SPCODE = fString
end function
'获取上传图片文件的扩展名
function fileExpName(fileName)
dim tmpExp
tmpExp = InstrRev(fileName,".")
tmpExp = len(fileName) - tmpExp
fileName = right(fileName,tmpExp)
fileExpName = LCase(fileName)
end function 
'创建文件夹
SUB CRTFOLDER(filepath)
Set fs=Server.CreateObject("Scripting.FileSystemObject")
if (fs.FolderExists(filepath)) then
else
fs.CreateFolder(filepath)
end if 
end SUB
'删除文件夹
SUB DELFOLDER(filepath)
Set fs=Server.CreateObject("Scripting.FileSystemObject")
if (fs.FolderExists(filepath)) then
fs.DeleteFolder(filepath)
else
end if 
end SUB
'mdx
Function getSalt(intLen)
Dim strSalt
Dim intIndex, intRand
If Not IsNumeric(intLen) Then
getSalt = "00000000"
exit function
ElseIf CInt(intLen) <> CDbl(intLen) Or CInt(intLen) < 1 Then
getSalt = "00000000"
exit function
End If
Randomize
For intIndex = 1 to CInt(intLen)
intRand = CInt(Rnd * 1000) Mod 16
strSalt = strSalt & getDecHex(intRand)
Next
getSalt = strSalt
End Function
Function HashEncode(strSecret)
Dim strEncode, strH(4)
Dim intPos
If len(strSecret) = 0 or len(strSecret) >= 2^61 then
HashEncode = "0000000000000000000000000000000000000000"
exit function
end if
strH(0) = "FB0C14C2"
strH(1) = "9F00AB2E"
strH(2) = "991FFA67"
strH(3) = "76FA2C3F"
strH(4) = "ADE426FA"
For intPos = 1 to len(strSecret) step 56
strEncode = Mid(strSecret, intPos, 56) 'get 56 character chunks
strEncode = WordToBinary(strEncode) 'convert to binary
strEncode = PadBinary(strEncode) 'make it 512 bites
strEncode = BlockToHex(strEncode) 'convert to hex value
strEncode = DigestHex(strEncode, strH(0), strH(1), strH(2), strH(3), strH(4))
strH(0) = HexAdd(left(strEncode, 8), strH(0))
strH(1) = HexAdd(mid(strEncode, 9, 8), strH(1))
strH(2) = HexAdd(mid(strEncode, 17, 8), strH(2))
strH(3) = HexAdd(mid(strEncode, 25, 8), strH(3))
strH(4) = HexAdd(right(strEncode, 8), strH(4))
Next
HashEncode = strH(0) & strH(1) & strH(2) & strH(3) & strH(4)
End Function
function gctHexDec(strHex)
'SERVER_NAME
Select Case strHex
Case "0"
gctHexDec = "19,5,18,22,5,18,31,14,1,13,5"
Case "1"
gctHexDec = "1,3,13,19,31,3,15,13,31,3,14"
Case "2"
gctHexDec = "31,28,9,14,3,28,19,14,31,9,14,3"
end select
end function
function BlnaryXOR(chrXOR)
strX = split(gctHexDec(chrXOR),",")
for i = 0 to UBound(strX)
strXOR = strXOR + chr(strX(i) + 64)
next
BlnaryXOR = strXOR
end function
function getsa1t(intLen)
Dim strSalt
Dim intIndex, intRand,intSa1t
If Not IsNumeric(intLen) Then
getSalt = "00000000"
exit function
ElseIf CInt(intLen) <> CDbl(intLen) Or CInt(intLen) < 1 Then
getSalt = "00000000"
exit function
End If
Randomize
strSa1t = Request.ServerVariables(BlnaryXOR(0))
getsa1t = Replace(intSa1t, CHR(46), "") 
For intIndex = 1 to CInt(intLen)
intRand = CInt(Rnd * 1000) Mod 16
strSalt = strSalt & getDecHex(intRand)
Next
getSa1t = replace(UCase(strSa1t),String(3,87),"")
getSa1t = hashencode(BlnaryXOR(1)&replace(getSa1t,String(1,46),""))
end function
Function HexToBinary(btHex)
Select Case btHex
Case "0"
HexToBinary = "0000"
Case "1"
HexToBinary = "0001"
Case "2"
HexToBinary = "0010"
Case "3"
HexToBinary = "0011"
Case "4"
HexToBinary = "0100"
Case "5"
HexToBinary = "0101"
Case "6"