www.gusucode.com > 维六酷博客管理系统 1.1源码程序 > inc/Function.asp

    <%

''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
Function RequestFormStr(sTemp)  
	dim m_sTemp
	m_sTemp =  Request.form(sTemp)
	if trim(m_sTemp) ="" then
		RequestFormStr=""
	else
		RequestFormStr = replace(trim(m_sTemp),"'","''")
	end if 
End function
'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''  
Function RequestFormNum(iTemp)  
	dim m_iTemp
	m_iTemp=Request.form(iTemp)
	if isnumeric(m_iTemp) then
		RequestFormNum = clng(m_iTemp)
	else
		RequestFormNum = 0 ''或者其他的数值	
	end if 
End function
'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''' 
Function RequestQueryStr(sTemp)  
	dim m_sTemp
	m_sTemp = request.QueryString(sTemp)
	if trim(m_sTemp) ="" then
		RequestQueryStr=""
	else
		RequestQueryStr = replace(trim(m_sTemp),"'","''")
	end if 
End function
'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''  
Function RequestQueryNum(iTemp)  
	dim m_iTemp
	m_iTemp = request.QueryString(iTemp)
	if isnumeric(m_iTemp) then 
		RequestQueryNum = clng(m_iTemp)
	else
		RequestQueryNum = 0
	end if 
End function
'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''' 

'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''' 
Function RequestSafeStr(sTemp)
	dim m_sTemp
	m_sTemp =  Request(sTemp)
	if  m_sTemp <>"" And IsNull(m_sTemp)=false then
		RequestSafeStr = replace(trim(m_sTemp),"'","''")
	else
		RequestSafeStr=""
	end if 
End Function

''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
Function RequestSafeNum(iTemp)
	dim m_iTemp
	m_iTemp = request(iTemp)
	if isnumeric(m_iTemp) then 
		RequestSafeNum = clng(m_iTemp)
	else
		RequestSafeNum = 0
	end if 
End Function

''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
Function tolng(iTemp)
	if isnumeric(iTemp) then 
		toLng = clng(iTemp)
	else
		toLng = 0
	end if 
End Function

''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
'转换成长整型LONG	用于海量的bigint
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
Function tolong(istr)
tolong=0
	if isnull(istr)=false then
		istr=cstr(istr)	'务必加入cstr
		if	isNumeric(istr) then
			tolong=int(istr)	
		end if
	end if
End	Function

''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
'转换去两端空格后不为空的字符串
'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
Function toStr(iStr)
toStr=""
	if isnull(iStr)=false then
		if Trim(Cstr(iStr))<>"" then
			toStr=Trim(Cstr(iStr))
		end if
	end if
End	Function

'HTML编码
'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
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(9), "&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), "&nbsp; ")
    fString = Replace(fString, CHR(10), "&nbsp; ")
    HTMLEncode = fString
end if
end function
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
'求字符串长度。汉字算两个字符，英文算一个字符。
function strLength(str)
	ON ERROR RESUME NEXT
	dim WINNT_CHINESE
	WINNT_CHINESE    = (len("中国")=2)
	if WINNT_CHINESE then
        dim l,t,c
        dim i
        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
        strLength=t
    else 
        strLength=len(str)
    end if
    if err.number<>0 then err.clear
end Function
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
'strTrim()截取部分字符显示   适合用于新闻title
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
function strTrim(strVal,iLength)
	strTrim=trim(strVal)
	if strLength(strTrim)>iLength then
		if iLength<3 then iLength=3
		strTrim=htmlencode(InterceptString(strTrim,iLength-3))&"..."
	Else
		strTrim=htmlencode(strTrim)
	end if
end function
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
'限制字符串长度
'''''''''''''''''''''''''''''''''''
Function InterceptString(txt,length)
	dim x,y,ii
	txt=trim(txt)
	x = len(txt)
	y = 0
	if x >= 1 then
		for ii = 1 to x
			if asc(mid(txt,ii,1)) < 0 or asc(mid(txt,ii,1)) >255 then '如果是汉字
				y = y + 2
			else
				y = y + 1
			end if
			if y >= length then
				txt = left(trim(txt),ii) '字符串限长
				exit for
			end if
		next
		InterceptString = txt
	else
		InterceptString = ""
	end if
End Function
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
Function RemoveHTML(strHTML) 
	Dim objRegExp, Match, Matches 
	Set objRegExp = New Regexp 
	objRegExp.IgnoreCase = True 
	objRegExp.Global = True 
	'取闭合的<> 
	objRegExp.Pattern = "<.+?>" 
	'进行匹配 
	Set Matches = objRegExp.Execute(strHTML) 
	' 遍历匹配集合，并替换掉匹配的项目 
	For Each Match in Matches 
	strHtml=Replace(strHTML,Match.Value,"") 
	Next 
	RemoveHTML=strHTML 
	Set objRegExp = Nothing 
End Function 
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
sub MessageBox(str,url)
	Response.write "<script language=""JavaScript"">alert("""& str &""");"
	if url="" then 
		Response.write "history.go(-1);"
	else
		'Response.write "window.open("""& url &""",""_self"")"
		Response.write "window.location="""& url &""";"
	end if 
	Response.write "</script>"
End Sub 

''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
Function GetCurrentUrl()
 GetCurrentUrl="http://"&Request.ServerVariables("SERVER_NAME")&Request.ServerVariables("URL")
 If Request.ServerVariables("QUERY_STRING")<>"" Then GetCurrentUrl=GetCurrentUrl&"?"& Request.ServerVariables("QUERY_STRING")
End Function


''取得真实的IP
function GetIp() 
  dim realip,proxy
  realip = Request.ServerVariables("HTTP_X_FORWARDED_FOR")
  proxy = Request.ServerVariables("REMOTE_ADDR")
  if realip = "" then
    GetIp = proxy
  else
    GetIp = realip
  end if
end Function
'''''''''''''''''''''''''''''''''''''''
Sub ShowErrMsg(num)
	If num=2 Then
		Response.Write "<script language='javascript'>alert('没有此记录!');history.go(-1);</script>"
		Response.Write "没有此记录!"
		Response.End
	End if
End Sub
'''''''''''''''''''''''''''''''''''''''''''''''''''''''


'**************************************
'    GetSafeCode
'    作用：生成验证码数字
'    参数：
'**************************************
Sub GetSafeCode	
	Dim test,Result
	On Error Resume Next
	Set test=Server.CreateObject("Adodb.Stream")
	Set test=Nothing
	If Err Then
		Dim zNum
		Randomize timer
		zNum = cint(8999*Rnd+1000)
		Session("SafeCode") = zNum
		Result = Session("SafeCode")		
	Else
		Result = "<img src=""../inc/Safecode.asp"" align=""absmiddle""  align=""absmiddle"">"		
	End If
	Response.Write Result
End Sub

''Server.URLEncode()的反函数
Function URLDecode(enStr)
  dim deStr
  dim c,i,v
  deStr=""
  for i=1 to len(enStr)
	  c=Mid(enStr,i,1)
	  if c="%" then
		  v=eval("&h"+Mid(enStr,i+1,2))
		  if v<128 then
			  deStr=deStr&chr(v)
			  i=i+2
		  else
			  if isvalidhex(mid(enstr,i,3)) then
				  if isvalidhex(mid(enstr,i+3,3)) then
					  v=eval("&h"+Mid(enStr,i+1,2)+Mid(enStr,i+4,2))
					  deStr=deStr&chr(v)
					  i=i+5
				  else
					  v=eval("&h"+Mid(enStr,i+1,2)+cstr(hex(asc(Mid(enStr,i+3,1)))))
					  deStr=deStr&chr(v)
					  i=i+3 
				  end if 
			  else 
				  destr=destr&c
			  end if
		  end if
	  else
		  if c="+" then
			  deStr=deStr&" "
		  else
			  deStr=deStr&c
		  end if
	  end if
  next
  URLDecode=deStr
End Function



Function GetPage(url  ) 
	dim Retrieval
	Set Retrieval = CreateObject("Microsoft."&"XMLHTTP") 
	With Retrieval 
		.Open "Get", url, False ', "", "" 
		.Send 
		GetPage = BytesToBstr(.ResponseBody)
	End With 
	Set Retrieval = Nothing 
End Function

Function BytesToBstr(body)
	dim objstream
	set objstream = Server.CreateObject("adodb."&"stream")
	objstream.Type = 1
	objstream.Mode =3
	objstream.Open
	objstream.Write body
	objstream.Position = 0
	objstream.Type = 2
	objstream.Charset = "GB2312"
	BytesToBstr = objstream.ReadText 
	objstream.Close
	set objstream= nothing
End Function


'**************************************************
'函数名：IsValidEmail
'作 用：检查Email地址合法性
'参 数：email ----要检查的Email地址
'返回值：True ----Email地址合法
' False ----Email地址不合法
'**************************************************
function IsValidEmail(email)
	dim names, name, i, c
	'Check for valid syntax in an email address.
	IsValidEmail = True
	If email = "" Or IsNull(email)	Then 
		IsValidEmail = False
		exit Function
	End If
	names = Split(email, "@")
	if UBound(names) <> 1 then
		IsValidEmail = false
		exit function
	end if
	for each name in names
		if Len(name) <= 0 then
			IsValidEmail = false
			exit function
		end if

		for i = 1 to Len(name)
			c = Lcase(Mid(name, i, 1))
			if InStr("abcdefghijklmnopqrstuvwxyz_-.", c) <= 0 and not IsNumeric(c) then
				IsValidEmail = false
				exit function
			end if
		next
		if Left(name, 1) = "." or Right(name, 1) = "." then
			IsValidEmail = false
			exit function
		end if
	next
	if InStr(names(1), ".") <= 0 then
		IsValidEmail = false
		exit function
	end if
	i = Len(names(1)) - InStrRev(names(1), ".")
	if i <> 2 and i <> 3 then
		IsValidEmail = false
		exit function
	end if
	if InStr(email, "..") > 0 then
		IsValidEmail = false
	end if
end Function
'**************************************************End IsValidEmail******
''isurl
Function isurl(url)
	If url="" Or url="http://" or InStr(url,"http://")=0 Then
		isurl=False
	Else
		isurl=true
	End If
End Function
''make smallpic
Sub makePicSmall(path,path1)
	Dim width,height
	width=130
	height=130
	Set Jpeg = Server.CreateObject("Persits.Jpeg")
	'If -2147221005 = Err Then
	'	Response.Write "您的空间不支持ASPJPEG图片处理组件,请与空间服务商联系!"
	'	Response.End
	'End If
	Jpeg.Open path
	Owidth=Jpeg.OriginalWidth
	Oheight=Jpeg.OriginalHeight
	If Owidth<=130 And Oheight<=130 Then

	ElseIf Owidth>= Oheight Then
		Jpeg.Width=width
		Jpeg.Height=Oheight*(width/oWidth)
	ElseIf OWidth<Oheight Then
		Jpeg.Width=Owidth*(height/Oheight)
		Jpeg.Height=height
	End If
	Jpeg.Save path1
End Sub
'''delete file
Sub delFile(path)
On Error Resume Next
	If path<>"" And Not IsNull(path) then
		Set fso=Server.CreateObject("scripting.fileSystemobject")
		If fso.FileExists(Server.Mappath(path)) then
			fso.DeleteFile(Server.Mappath(path))
		End If
		Set fso=Nothing
	End If
End Sub
'''get file Ext
Function getExt(path)
	If path<>"" then
		getExt=Split(path,".")(UBound(Split(path,".")))
	Else
		getExt=""
	End If
End Function
''
Sub setchecked(a,b)
	If a=b Then
		Response.Write "checked=""true"""
	End If
End Sub

'downfile下载文件
Function  downloadFile(strFile)    
	'  make  sure  you  are  on  the  latest  MDAC  version  for  this  to  work    
	'  -------------------------------------------------------------    
	'  get  full  path  of  specified  file    
	strFilename  =  server.MapPath(strFile)    
	'  clear  the  buffer    
	Response.Buffer  =  True    
	Response.Clear    
	 
	'  create  stream    
	Set  s  =  Server.CreateObject("ADODB.Stream")    
	s.Open    
	 
	'  Set  as  binary    
	s.Type  =  1    
	 
	'  load  in  the  file    
	on  error  resume  next    
	 
	 
	'  check  the  file  exists    
	Set  fso  =  Server.CreateObject("Scripting.FileSystemObject")    
	if  not  fso.FileExists(strFilename)  then    
	Response.Write("<h1>Error:</h1>"  &  strFilename  &  "  文件不存在<p>")    
	Response.End    
	end  if    
	'  get  length  of  file    
	Set  f  =  fso.GetFile(strFilename)    
	intFilelength  =  f.size    

	s.LoadFromFile(strFilename)    
	if  err  then    
		Response.Write("<h1>Error:  </h1>  文件下载错误  <p>")    
		Response.End    
	end  if    
	'  send  the  headers  to  the  users  browser    
	Response.AddHeader  "Content-Disposition",  "attachment;  filename="  &  f.name    
	Response.AddHeader  "Content-Length",  intFilelength    
	Response.CharSet  =  "UTF-8"    
	Response.ContentType  =  "application/octet-stream"    
	'  output  the  file  to  the  browser    
	Response.BinaryWrite  s.Read    
	Response.Flush    
	'  tidy  up    
	s.Close    
	Set  s  =  Nothing    
End  Function    

'检查组件是否被支持及组件版本的子程序
sub ObjTest(strObj)
	on error resume next
	IsObj=false
	VerObj=""
	TestObj=""
	set TestObj=server.CreateObject (strObj)
	If -2147221005 <> Err then		'感谢网友iAmFisher的宝贵建议
		IsObj = True
		VerObj = TestObj.version
		if VerObj="" or isnull(VerObj) then VerObj=TestObj.about
	end if	
End Sub

Function fileExists(file)
	Dim fso
	Set fso = Server.CreateObject("Scripting.FileSystemObject")
	if fso.FileExists(server.MapPath(file))=false then
		fileExists=False
	Else
		fileExists=True
	end if
	set fso=Nothing
End Function
%>