兄弟的博客-【兄弟波段趋势操盘】-ASP各种函数功能木块集合 -

海外邮件中继，海外退信中继，美国高速VPS，不限流量VPN，邮局维护和管理，邮件网关，EMOS邮件中继，POSTFIX邮件中继，Winwebmail邮件中继,Winmail邮件中继,DBMail邮件中继,JDMail邮件中继,Exchange邮件中继,MDaemon邮件中继淘宝店：http://shantan.taobao.com 云邮科技官网：www.yunrelay.com

【字体设置：大中小】
在这里给大家献上ASP各种函数功能木块集合，这里几乎包含了常用的ASP函数，对网站开发时有着很大的帮助！

<%

call start()
'开始执行
Function start()
  call get_rq() '安全过滤
  'call Appeal() '防小偷程序
  call webAgent() '检测客户端
End Function
Function createRs()
   dim rsObj
   set rsObj=server.CreateObject("adodb.recordset")
   set createRs=rsObj
End Function

sub showError(strval)
  response.Write "<div style=""border:1 solid #0099FF; width:500px; height:250px;"">"
  response.Write strval
  response.Write "</div>"
  response.End()
end sub

'转向
Sub RedirectUrl(strHttp)
  Response.write "<script language='javascript'>location.href='"&strHttp&"';</script>"
End Sub

sub Alert(sText)
  Response.write "<script language='javascript'>alert('" & sText & "');</script>"
end sub

sub History(iStep)
  Response.write "<script>window.history(" & iStep & ");</script>"
End Sub

sub Funmsg(iStep,sText)
Response.Write "<script>alert('"&sText&"');location.href='"&iStep&"';</script>"
end sub

'执行非法提交检测
Sub get_rq()
dim qs,errc,iii
qs=request.servervariables("query_string")
dim nothis(18)
nothis(0)="net user"
nothis(1)="xp_cmdshell"
nothis(2)="/add"
nothis(3)="exec%20master.dbo.xp_cmdshell"
nothis(4)="net localgroup administrators"
nothis(5)="select"
nothis(6)="count"
nothis(7)="asc"
nothis(8)="char"
nothis(9)="mid"
nothis(10)="'"
nothis(11)="::"
nothis(12)=""""
nothis(13)="insert"
nothis(14)="delete"
nothis(15)="drop"
nothis(16)="truncate"
nothis(17)="from"
nothis(18)="and user>0"
errc=false
for iii= 0 to ubound(nothis)
   if instr(qs,nothis(iii))<>0 then
    errc=true
   end if
next
if errc then
' Response.Write("对不起，非法URL地址请求!")
  response.Write "<meta http-equiv=""Refresh"" content=""3;URL=index.html"">"
  response.Write "<div style='border:1px solid #CCCCCC;width:600px;height:25px;padding:5px;padding-left:15px;'>"
  response.Write "<font style='font-size:14px'>Diggcms系统友情提示：<br>"
  response.Write "  HTTP 错误 404 -URL地址请求出错<br>"
  response.Write "</div>"
  response.end
end if
End Sub
'初始化被过滤的客户端列表
Function webAgent()
  dim strAgentFilter
  strAgentFilter="webzip|||flashget|||offline|||teleport"
  If ChkAgent(strAgentFilter)=False Then
   response.Write "错误"
   response.End()
   ' AddErrCode(1)
   ' Call ChkError()
  End If
End Function
' * 检查浏览站点的客户端
' * strAL  —— 屏蔽的客户端标志列表
Function ChkAgent(strAL)
  Dim Agent,iijj

  ChkAgent=True
  Agent=Trim(Lcase(Request.Servervariables("HTTP_USER_AGENT")))
  If (Not IsNull(strAL)) Then
    strAL=Split(strAL,"|||")
    For iijj=0 To Ubound(strAL)
      If Instr(Agent,strAL(iijj))>0 Then
       ChkAgent=False
      end if
    Next
  End If
End Function

'/*
' 防网站小偷来采摘数据
' */
function Appeal()
Dim AppealNum,AppealCount
   AppealNum=30 '同一IP10秒内请求限制30次
   AppealCount=Request.Cookies("AppealCount")
   If AppealCount="" Then
    response.Cookies("AppealCount")=1
    AppealCount=1
    response.cookies("AppealCount").expires=dateadd("s",10,now())
   Else
    response.Cookies("AppealCount")=AppealCount+1
    response.cookies("AppealCount").expires=dateadd("s",10,now())
  End If
  if int(AppealCount)>int(AppealNum) then
   response.Write "<FIELDSET style='width:350px'><LEGEND>描述</LEGEND>"
   response.write "<font style='font-size:14px'>抓取很累，歇一会儿吧！<br><a href="&Website&">"&Website&"</a></font>"
   response.Write "</FIELDSET>"
   response.end
  End If
end function

'/*
' 防外部提交
' 结合Chkpost函数
' */
function chpost()
If Not ChkPost(Website) then
  response.Write "<center>"
  response.Write "<FIELDSET style='width:350px'><LEGEND>系统提示</LEGEND>"
  Response.Write "<font style='font-size:14px'>"
  response.Write "   <a href=http://www.diggcms.com>返回</a>"
  response.Write "</font></FIELDSET>"
  response.Write "<br><br><div style='border:1px solid #CCCCCC;width:235px;height:25px;padding:5px;padding-left:15px;'><a href=http://www.diggcms.com target=_blank title=免费的Diggcms内容管理系统>Diggcms－给你最好的</a></div>"
  response.Write "</center>"
response.End()
end if
End function

'/*
' 处部提交数据查
' */
Function ChkPost(web_url)
dim Server_V1,Server_V2
ChkPost=False
Server_V1=Cstr(Request.ServerVariables("HTTP_REFERER"))
Server_V2=Cstr(Request.ServerVariables("SERVER_NAME"))
''--------------------------------------------
  ''Instr(所有，其中),包括>0,否则=0
''--------------------------------------------
If Mid(Server_V1,8,Len(Server_V2))<>Server_V2 or Instr(web_url,Server_V2)=0 Then
    ChkPost=False
Else
    ChkPost=True
End If
End Function
'========================================================文件操作
'/*
' 删除文件
' */
Function DelFile(DelFilePath)
On Error Resume Next
DelFile= False
set MyFileObject=Server.CreateOBject("Scripting.FileSystemObject")
MyFileObject.DeleteFile""&Server.MapPath(""&DelFilePath&"")&""
Set MyFileObject= Nothing
If 0 = Err or 53 = Err Then
   DelFile= True
else
   CatchError(""&DelFilePath&"文件无法删除！")
end if
On Error GoTo 0
End Function

'/*
' 检查多层目录不存在，则生成
' */
function CreateDIR(LocalPath)
  dim patharr,path_level,i,pathtmp,cpath,FileObject
  on error resume next
  LocalPath = Server.MapPath(LocalPath)
  LocalPath = replace(LocalPath,"\","/")
  set FileObject = server.createobject("Scripting.FileSystemObject")
   patharr = split(LocalPath,"/")
   path_level = ubound(patharr)
   for i = 0 to path_level
   if i=0 then pathtmp = patharr(0) & "/" else pathtmp = pathtmp & patharr(i) & "/"
   cpath = left(pathtmp,len(pathtmp)-1)
   if not FileObject.FolderExists(cpath) then FileObject.CreateFolder(cpath)
   next
   set FileObject = nothing
   if err.number<>0 then
   CreateDIR = false
   err.Clear
   else
   CreateDIR = true
   end if
end function

'/*
' cookie编码加密
' */
Function CodeCookie(Str)
  Dim i
  Dim StrRtn
  For i = Len(Str) To 1 Step -1
    StrRtn = StrRtn & AscW(Mid(Str, i, 1))
    If (i <> 1) Then StrRtn = StrRtn & "a"
  Next
  CodeCookie = StrRtn
End Function
'/*
'cookie解密
' */
Function DecodeCookie(Str)
  Dim i
  Dim StrArr, StrRtn
  StrArr = Split(Str, "a")
  For i = 0 To UBound(StrArr)
    If IsNumeric(StrArr(i)) = True Then
      StrRtn = ChrW(StrArr(i)) & StrRtn
    Else
      StrRtn = Str
      Exit Function
    End If
  Next
  DecodeCookie = StrRtn
End Function

'/*
' * 设置Cookies
' * vparameter:参数，val:值
' */
Function SetCookies(vparameter,val)
response.Cookies(vparameter)=val
response.Cookies(vparameter).Expires=dateadd("H",12,now())
End Function

'/*
' *　读取Cookies
' */
Function GetCookies(vparameter)
GetCookies=request.Cookies(vparameter)
End Function

'============================================================安全过滤
'/*
' 安全过滤
' */
Function SafeSql(Str,Flag)
SafeSql=Str
If Flag=1 Then
  If Not IsNumeric(SafeSql) Or Trim(SafeSql)="" Then
   ' response.Write "<meta http-equiv=""Refresh"" content=""3;URL=index.asp"">"
   response.Write "<FIELDSET style='width:350px'><LEGEND>描述</LEGEND>"
   Response.Write "<font style='font-size:14px'>参数错误,参数类型应为数值型。<br>当前值是："&Str&""
   response.Write "</font></FIELDSET>"
   response.Write "<br><br><div style='border:1px solid #CCCCCC;width:235px;height:25px;padding:5px;padding-left:15px;'><a href=http://www.hcj123.com target=_blank title=行业黄页门户>好财经－给你最好的</a></div>"
   Response.End
  End If
ElseIf Flag=2 Then
    Str =trim(Str)
    Str = replace(Str, ">", ">")
    Str = replace(Str, "<", "<")
    Str=Replace(Str,"\","\")
    Str=Replace(Str,"--","--")
    Str = Replace(Str, CHR(34), """) '过滤''
    Str = Replace(Str, CHR(39), "'") '过滤'
   ' Str = Replace(Str, CHR(13)&CHR(10), "<BR>") '回车换行
   Str =Replace(Str,CHR(42),"*")  '“*”
   Str =Replace(Str,CHR(44),",")  '“,”
    Str = Replace(Str, "select", "select")
    Str = Replace(Str, "join", "join")
    Str = Replace(Str, "union", "union")
    Str = Replace(Str, "where", "where")
    Str = Replace(Str, "insert", "insert")
    Str = Replace(Str, "delete", "delete")
    Str = Replace(Str, "update", "update")
    Str = Replace(Str, "like", "like")
    Str = Replace(Str, "drop", "drop")
    Str = Replace(Str, "create", "create")
    Str = Replace(Str, "modify", "modify")
    Str = Replace(Str, "rename", "rename")
    Str = Replace(Str, "alter", "alter")
    Str = Replace(Str, "cast", "cast")
  SafeSql=Str
Else
  response.Write "<FIELDSET style='width:350px'><LEGEND>描述</LEGEND>"
  Response.Write "<font style='font-size:14px'>参数错误SafeSql方法参数在1,2范围内"
  response.Write "</font></FIELDSET>"
  response.Write "<br><br><div style='border:1px solid #CCCCCC;width:235px;height:25px;padding:5px;padding-left:15px;'><a href=http://www.hcj123.com target=_blank title=行业黄页门户>好财经－给你最好的</a></div>"
  Response.End
End If
End Function

'/*
' HTML解码函数
' */
Function HTMLDecode(refStringing)
  Dim fString
    fString=refStringing
  If Not IsNull(fString) Then
   fString = Replace(fString, ">", ">")
   fString = Replace(fString, "<", "<")
   fString=Replace(fString,"\","\")
   fString=Replace(fString,"--","--")
   fString = Replace(fString, """,CHR(34)) '还原''
   fString = Replace(fString, "'", "'") '还原'
'   if instr(fString,CHR(13)&CHR(10))>0 then
'     fString = Replace(fString, CHR(13)&CHR(10), "<BR>") '回车换行
'   end if
   fString = Replace(fString, "select", "select")
   fString = Replace(fString, "join", "join")
   fString = Replace(fString, "union", "union")
   fString = Replace(fString, "where", "where")
   fString = Replace(fString, "insert", "insert")
   fString = Replace(fString, "delete", "delete")
   fString = Replace(fString, "update", "update")
   fString = Replace(fString, "like", "like")
   fString = Replace(fString, "drop", "drop")
   fString = Replace(fString, "create", "create")
   fString = Replace(fString, "modify", "modify")
   fString = Replace(fString, "rename", "rename")
   fString = Replace(fString, "alter", "alter")
   fString = Replace(fString, "cast", "cast")
   HTMLDecode = fString
  End If
End Function
'/*
' 防注入
' */
Function FunSQL(Str)
If Isnull(Str) Then
FunSQL = ""
Exit Function
End If
  Str=trim(Str)
Str = Replace(Str,Chr(0),"", 1, -1, 1)
Str = Replace(Str, """", """, 1, -1, 1)
Str = Replace(Str,"<","<", 1, -1, 1)
Str = Replace(Str,">",">", 1, -1, 1)
  Str = Replace(Str,CHR(42),"*")  '“*”
  Str = Replace(Str,CHR(44),",")  '“,”
Str = Replace(Str, "script", "script", 1, -1, 0)
Str = Replace(Str, "SCRIPT", "SCRIPT", 1, -1, 0)
Str = Replace(Str, "Script", "Script", 1, -1, 0)
Str = Replace(Str, "script", "Script", 1, -1, 1)
Str = Replace(Str, "object", "object", 1, -1, 0)
Str = Replace(Str, "OBJECT", "OBJECT", 1, -1, 0)
Str = Replace(Str, "Object", "Object", 1, -1, 0)
Str = Replace(Str, "object", "Object", 1, -1, 1)
Str = Replace(Str, "applet", "applet", 1, -1, 0)
Str = Replace(Str, "APPLET", "APPLET", 1, -1, 0)
Str = Replace(Str, "Applet", "Applet", 1, -1, 0)
Str = Replace(Str, "applet", "Applet", 1, -1, 1)
Str = Replace(Str, "[", "[")
Str = Replace(Str, "]", "]")
' Str = Replace(Str, "=", "=", 1, -1, 1)
' Str = Replace(Str, "'", "''", 1, -1, 1)
Str = Replace(Str, "select", "select", 1, -1, 1)
Str = Replace(Str, "execute", "&#101xecute", 1, -1, 1)
Str = Replace(Str, "exec", "&#101xec", 1, -1, 1)
Str = Replace(Str, "join", "join", 1, -1, 1)
Str = Replace(Str, "union", "union", 1, -1, 1)
Str = Replace(Str, "where", "where", 1, -1, 1)
Str = Replace(Str, "insert", "insert", 1, -1, 1)
Str = Replace(Str, "delete", "delete", 1, -1, 1)
Str = Replace(Str, "update", "update", 1, -1, 1)
Str = Replace(Str, "like", "like", 1, -1, 1)
Str = Replace(Str, "drop", "drop", 1, -1, 1)
Str = Replace(Str, "create", "create", 1, -1, 1)
Str = Replace(Str, "rename", "rename", 1, -1, 1)
Str = Replace(Str, "count", "count", 1, -1, 1)
Str = Replace(Str, "chr", "chr", 1, -1, 1)
Str = Replace(Str, "mid", "mid", 1, -1, 1)
Str = Replace(Str, "truncate", "truncate", 1, -1, 1)
Str = Replace(Str, "nchar", "nchar", 1, -1, 1)
Str = Replace(Str, "char", "char", 1, -1, 1)
Str = Replace(Str, "alter", "alter", 1, -1, 1)
Str = Replace(Str, "cast", "cast", 1, -1, 1)
Str = Replace(Str, "exists", "exists", 1, -1, 1)
Str = Replace(Str,Chr(13),"<br>", 1, -1, 1)
' Str = Replace(Str, "*", "＊")
Str = Replace(Str, "%", "％")
Str = Replace(Str, "-", "–")
FunSQL =Replace(Str,"'","'", 1, -1, 1)
End Function

'/*
' 帖子内容过滤
' */
Function HtmlEditEncode(Str)
Str=trim(Str)
  Str=Replace(Str,"\","\")
  Str=Replace(Str,"'","'")
'  Str = replace(Str, ">", ">")
'  Str = replace(Str, "<", "<")
  'Str = replace(Str, CHR(91), "[")
  vfilterKey=Split(urldecode(filterKey),",")
for vi=0 to Ubound(vfilterKey)
Str=Replace(Str,vfilterKey(vi),"*")
  next

  HtmlEditEncode=Str
End Function

'UBB
Function BBCode(str)
  str=ReplaceText(str,"\[(\/|)(b|i|u|strike|center|marquee)\]","<$1$2>")
  str=ReplaceText(str,"\[COLOR=([^[]*)\]","<FONT COLOR=$1>")
  str=ReplaceText(str,"\[FONT=([^[]*)\]","<FONT face=$1>")
  str=ReplaceText(str,"\[SIZE=([0-9]*)\]","<FONT size=$1>")
  str=ReplaceText(str,"\[\/(SIZE|FONT|COLOR)\]","</FONT>")
  'str=ReplaceText(str,"\[URL\]([^[]*)","<a target=_blank href=$1>$1")
  'str=ReplaceText(str,"\[URL=([^[]*)\]","<a target=_blank href=$1>")
  'str=ReplaceText(str,"\[\/URL\]","</A>")
  str=ReplaceText(str,"\[EMAIL\](\S+\@[^[]*)(\[\/EMAIL\])","<a href=mailto:$1>$1</a>")
  str=ReplaceText(str,"\[IMG\]([^("&CHR(34)&"|[|#)]*)(\[\/IMG\])","<img border=0 src=$1>")
  str=ReplaceText(str,"\[quote\]","<blockquote>")
  str=ReplaceText(str,"\[quote user="&CHR(34)&"([^[]*)"&CHR(34)&"\]","<blockquote> <b>以下是引用$1的发言</b><br>")
  str=ReplaceText(str,"\[\/quote\]","</blockquote>")
  if instr(str,":&bq")>0 then
    for qi=1 to 16
      str=Replace(str,":&bq"&qi&";","<img src='../../style/images/biaoqing/"&qi&".gif'>")
    next
  end if
  BBCode=str
End Function

'替换模块
Function ReplaceText(fString,patrn,replStr)
  Set regEx = New RegExp   ' 建立正则表达式。
    regEx.Pattern = patrn ' 设置模式。
    regEx.IgnoreCase = True ' 设置是否区分大小写。
    regEx.Global = True ' 设置全局可用性。
    ReplaceText = regEx.Replace(""&fString&"",""&replStr&"") ' 作替换。
  Set regEx=nothing
End Function

'===============================================================
'urldecode解码
function urldecode(encodestr)
  newstr=""
  havechar=false
  lastchar=""
  for i=1 to len(encodestr)
  char_c=mid(encodestr,i,1)
  if char_c="+" then
    newstr=newstr & " "
  elseif char_c="%" then
    next_1_c=mid(encodestr,i+1,2)
    next_1_num=cint("&H" & next_1_c)

  if havechar then
    havechar=false
    newstr=newstr & chr(cint("&H"&lastchar&next_1_c))
  else
  if abs(next_1_num)<=127 then
    newstr=newstr & chr(next_1_num)
  else
    havechar=true
    lastchar=next_1_c
  end if
  end if
    i=i+2
  else
    newstr=newstr&char_c
  end if
  next
  urldecode=newstr
end function

'/*
' 去掉HTML标记(正规表达式)
' */
Function Replacehtml(Textstr)
  Dim Str,re
  Str=Textstr
  Set re=new RegExp
    re.IgnoreCase =True
    re.Global=True
    re.Pattern="<(.[^>]*)>"
    Str=re.Replace(Str, "")
    Set Re=Nothing
    Str=Replace(Str,"<script","")
    Replacehtml=Str
End Function

'/*
' *去掉链接代码,有时候失效
' */
function MV_link(str)
  dim re
  set re=new RegExp
    re.global=true
    re.ignorecase=true
    re.pattern="<a [^>]*>([^<]*)</a>"
    str=re.Replace(str,"$1")
    MV_link=str
  set re=nothing
end function

'=========================================================
'** 函数：RemoveHref 方法1
'** 作用：正则表达式去除字符串中所有的超级链接
'=========================================================
Function RemoveHref(HTMLstr)
Set ra = New RegExp
ra.IgnoreCase = True
ra.Global = True
ra.Pattern = "<a[^>]+>(.+?)<\/a>"
RemoveHref= ra.replace(HTMLstr,"$1")
End Function

'=========================================================
'** 函数：RemoveHref　方法2
'** 作用：去除字符串中所有的超级链接
'=========================================================
Function RemoveHref_2(HTMLstr)
Dim n,str1,str2,str3,str4
HTMLstr = Lcase(HTMLstr)
For n=1 to Ubound(Split(HTMLstr,"<a"))
str1 = Instr(HTMLstr,"<a")
str2 = Instr(str1,HTMLstr,">")
HTMLstr = left(HTMLstr,str1-1)&right(HTMLstr,len(HTMLstr)-len(left(HTMLstr,str2)))
HTMLstr = replace (HTMLstr,"</a>","")
Next
RemoveHref_2=HTMLstr
End Function

'=========================================================
'** 函数：RemoveHref
'** 作用：去除字符串中所有的图片
'=========================================================
Function RemoveImg(HTMLstr)
Dim n,str1,str2,str3,str4
HTMLstr = Lcase(HTMLstr)
For n=1 to Ubound(Split(HTMLstr,"<img"))
str1 = Instr(HTMLstr,"<img")
str2 = Instr(str1,HTMLstr,">")
HTMLstr = left(HTMLstr,str1-1)&right(HTMLstr,len(HTMLstr)-len(left(HTMLstr,str2)))
Next
RemoveImg=HTMLstr
End Function
'=========================================================
'** 函数：RepScript
'** 作用：去除字符串中所有的script
'=========================================================
Function RepScript(HTMLstr)
Dim n,str1,str2,str3,str4
HTMLstr = Lcase(HTMLstr)
For n=1 to Ubound(Split(HTMLstr,"<script"))
str1 = Instr(HTMLstr,"<script")
str2 = Instr(str1,HTMLstr,"</script>")
HTMLstr = left(HTMLstr,str1-1)&right(HTMLstr,len(HTMLstr)-len(left(HTMLstr,str2)))
Next
HTMLstr=Replace(HTMLstr,"/script>","")
RepScript=HTMLstr
End Function

'/*
' 得到IP
' */
function GetIp()
   dim getclientip
   getclientip = Request.ServerVariables("HTTP_X_FORWARDED_FOR")
   If getclientip = "" Then
     getclientip = Request.ServerVariables("REMOTE_ADDR")
   end if
   GetIp = getclientip
End Function

'/*
' 检查元素是否在数组中
' */
Function inarr(arr,e)
  Dim j
  inarr = false
  If Not IsArray(arr) Then Exit Function
  For j = 0 To UBound(arr)
    If e = arr(j) Then inarr = true : Exit For
  Next
End Function

'/*
' * 截取指定长度的字符串
' * str      —— 被截取的字符串
' * strlen  —— 要截取的长度
' */
Function CutStr(Str,StrLen)
  Dim l,t,c,i
  l=Len(str)
  t=0
  For i=1 To l
    c=AscW(Mid(str,i,1))
    If c<0 Or c>255 Then t=t+2 Else t=t+1
    IF t>=StrLen Then
      CutStr=left(Str,i)&"..."
      Exit For
    Else
      CutStr=Str
    End If
  Next
End Function

'/*
' 日期转换
' */
Function DateToStr(DateTime,ShowType) '日期转换函数
  Dim DateMonth,DateDay,DateHour,DateMinute
  DateMonth=Month(DateTime)
  DateDay=Day(DateTime)
  DateHour=Hour(DateTime)
  DateMinute=Minute(DateTime)
  If Len(DateMonth)<2 Then DateMonth="0"&DateMonth
  If Len(DateDay)<2 Then DateDay="0"&DateDay
  Select Case ShowType
  Case "YMD"
    DateToStr = Year(DateTime)&"年"&DateMonth&"月"&DateDay&"日"
  Case "Y-m-d" '2006-09-19 年－月－日
    DateToStr=Year(DateTime)&"-"&DateMonth&"-"&DateDay
  Case "M-D-Y" '09-19-2006 月－日－年
    DateToStr = DateMonth&"-"&DateDay&"-"&Year(DateTime)
  Case "Y/M/D" '2006/09/19 年/月/日
    DateToStr = Year(DateTime)&"/"&DateMonth&"/"&DateDay
  Case "M/D/Y" '09/19/2006 月/日/年
    DateToStr = DateMonth&"/"&DateDay&"/"&Year(DateTime)
  Case "D/M/Y" '19/09/2006 日/月/年
    DateToStr = DateDay&"/"&DateMonth&"/"&Year(DateTime)
  Case "M.D.Y" '09.19.2006 月.日.年
    DateToStr = DateMonth&"."&DateDay&"."&Year(DateTime)
  Case "Y.M.D" '2006.09.19 年.月.日
    DateToStr = Year(DateTime)&"."&DateMonth&"."&DateDay
  Case "M-D H:M" '10-1 15:2
    DateToStr = DateMonth&"-"&DateDay&" "&DateHour&":"&DateMinute&""
  Case "MD" '09月19日月日
    DateToStr = DateMonth&"月"&DateDay&"日"
  Case "DH" '19日17时日时
    DateToStr = DateDay&"日"&DateHour&"时"
  Case "DH." '19日17点日点
    DateToStr = DateDay&"日"&DateHour&"点"
  Case "HMin"
    DateToStr = DateHour&"时"&DateMinute&"分"
  Case "H:Min"
    DateToStr = DateHour&":"&DateMinute
  Case "Y/M/D H:M"
    DateToStr = Year(DateTime)&"/"&DateMonth&"/"&DateDay&" "&DateHour&":"&DateMinute
  Case "Y-m-d H:I A" '2006-09-19 05:37 PM
    Dim DateAMPM
    If DateHour>12 Then
      DateHour=DateHour-12
      DateAMPM="PM"
    Else
      DateHour=DateHour
      DateAMPM="AM"
    End If
    If Len(DateHour)<2 Then DateHour="0"&DateHour
    If Len(DateMinute)<2 Then DateMinute="0"&DateMinute
    DateToStr=Year(DateTime)&"-"&DateMonth&"-"&DateDay&" "&DateHour&":"&DateMinute&" "&DateAMPM
  Case "Y-m-d H:I:S" '2006-09-19 17:37:53
    Dim DateSecond
    DateSecond=Second(DateTime)
    If Len(DateHour)<2 Then DateHour="0"&DateHour
    If Len(DateMinute)<2 Then DateMinute="0"&DateMinute
    If Len(DateSecond)<2 Then DateSecond="0"&DateSecond
    DateToStr=Year(DateTime)&"-"&DateMonth&"-"&DateDay&" "&DateHour&":"&DateMinute&":"&DateSecond
  Case "m/d H:I" '07/02 19:02
    DateSecond=Second(DateTime)
    If Len(DateHour)<2 Then DateHour="0"&DateHour
    If Len(DateMinute)<2 Then DateMinute="0"&DateMinute
    If Len(DateSecond)<2 Then DateSecond="0"&DateSecond
    DateToStr=DateMonth&"/"&DateDay&" "&DateHour&":"&DateMinute
  Case "YmdHIS" '20060919173753
    DateSecond=Second(DateTime)
    If Len(DateHour)<2 Then DateHour="0"&DateHour
    If Len(DateMinute)<2 Then DateMinute="0"&DateMinute
    If Len(DateSecond)<2 Then DateSecond="0"&DateSecond
    DateToStr=Year(DateTime)&DateMonth&DateDay&DateHour&DateMinute&DateSecond
  Case "ym" '0609年月
    DateToStr=Right(Year(DateTime),2)&DateMonth
  Case "d" '19日
    DateToStr=DateDay
  Case Else '2006-09-19 17:37
    If Len(DateHour)<2 Then DateHour="0"&DateHour
    If Len(DateMinute)<2 Then DateMinute="0"&DateMinute
    DateToStr=Year(DateTime)&"-"&DateMonth&"-"&DateDay&" "&DateHour&":"&DateMinute
  End Select
End Function
'/*
' 随机英文+数字
' */
Function GetRamCode(f_number)
  Randomize
  Dim f_Randchar,f_Randchararr,f_RandLen,f_Randomizecode,f_iR
  f_Randchar="0,1,2,3,4,5,6,7,8,9,A,B,C,D,E,F,G,H,I,J,K,L,M,N,O,P,Q,R,S,T,U,V,W,X,Y,Z"
  f_Randchararr=split(f_Randchar,",")
  f_RandLen=f_number '定义密码的长度或者是位数
  for f_iR=1 to f_RandLen
    f_Randomizecode=f_Randomizecode&f_Randchararr(Int((21*Rnd)))
  next
  GetRamCode = f_Randomizecode
End Function

'/*
' 分页函数
' iRecordCount记录总数,iRecordCount每页记录数
' iPageCount总页数,Filegs处理页
' * /
Function pagination(iRecordCount,iPageSize,iPageCount,Filegs)
Dim wzpage,wzpagecount,pagenum,arrValue(2)
dim beginpage,endpage '两者之间
  If Len(Request.QueryString("page"))<>0 Then
   wzpage = clng(Request.QueryString("page")) '当前页
   Else
   wzpage =1
  End If
  If wzpage <= 0 Then wzpage =1
  if (wzpage-4>=1) then
   beginpage=wzpage-4
  else
   beginpage=1
  end if
  if (wzpage+4<=iPageCount) then
   endpage=wzpage+4
  else
   endpage=iPageCount
  end if
  if beginpage=1 and iPageCount>=9 then '保持有9页选择
   beginpage=1:endpage=9
  end if
  if endpage=iPageCount and iPageCount>=9 then '保持有9页选择
     beginpage=endpage-8
  end if
  if wzpage>=2 then
   arrValue(0)=arrValue(0)&"<a href="""&Filegs&"page="&wzpage-1&""" title=""上一页"">上一页</a>"
  end if
  '+----------------出现首页数字
  if beginpage=>2 then
   arrValue(0)=arrValue(0)&" <a href="""&Filegs&"page=1"" title=""首页"">[1..]</a> "
  end if
  for beginpage=beginpage to endpage
   If beginpage = wzpage Then
       arrValue(0)=arrValue(0)&"<font color=""#ff0000"">"
       arrValue(0)=arrValue(0)&" ["& wzpage &"] "
       arrValue(0)=arrValue(0)&"</font>"
     Else
       arrValue(0)=arrValue(0)&" <a href="""&Filegs&"page="& beginpage &""">"
       arrValue(0)=arrValue(0)&"["& beginpage &"]"
       arrValue(0)=arrValue(0)&"</a> "
    End If
   If beginpage >= iPageCount Then Exit For
  next
  '+----------------出现尾页数字
  if endpage<iPageCount then
   arrValue(0)=arrValue(0)&" <a href="""&Filegs&"page="& iPageCount &""" title=""末页"">[.."&iPageCount&"]</a> "
  end if
  if wzpage<iPageCount then
   arrValue(0)=arrValue(0)&"<a href="""&Filegs&"page="& wzpage+1 &""" title=""下一页"">下一页</a>"
  end if

  arrValue(1) = " 当前第"&wzpage&"页 "&iPageSize&"条/页共"&iPageCount&"页/"&iRecordCount&"条记录"
  pagination=arrValue
End Function

'/*
' 分页函数(用于无刷新)
' iRecordCount:记录总数,iPageSize:每页记录数
' iPageCount:总页数,Filegs:处理页
' inowpage：当前页
' * /
Function pagination_ajax(iRecordCount,iPageSize,iPageCount,inowpage,Filegs)
Dim wzpage,wzpagecount,pagenum,arrValue(2)
dim beginpage,endpage '两者之间
  If Len(inowpage)<>0 Then
   wzpage = clng(inowpage) '当前页
   Else
   wzpage =1
  End If
  If wzpage <= 0 Then wzpage =1
  if (wzpage-4>=1) then
   beginpage=wzpage-4
  else
   beginpage=1
  end if
  if (wzpage+4<=iPageCount) then
   endpage=wzpage+4
  else
   endpage=iPageCount
  end if
  if beginpage=1 and iPageCount>=9 then '保持有9页选择
   beginpage=1:endpage=9
  end if
  if endpage=iPageCount and iPageCount>=9 then '保持有9页选择
     beginpage=endpage-8
  end if
  if wzpage>=2 then
   arrValue(0)=arrValue(0)&"<a href=#_p onclick=""showRdPL('"&Filegs&"page="&wzpage-1&"')"" title=""上一页"">上一页</a>"
  end if
  '+----------------出现首页数字
  if beginpage=>2 then
   arrValue(0)=arrValue(0)&" <a href=#_p onclick=""showRdPL('"&Filegs&"page=1')"" title=""首页"">[1..]</a> "
  end if
  for beginpage=beginpage to endpage
   If beginpage = wzpage Then
       arrValue(0)=arrValue(0)&"<font color=""#ff0000"">"
       arrValue(0)=arrValue(0)&" ["& wzpage &"] "
       arrValue(0)=arrValue(0)&"</font>"
     Else
       arrValue(0)=arrValue(0)&" <a href=#_p onclick=""showRdPL('"&Filegs&"page="& beginpage &"')"">"
       arrValue(0)=arrValue(0)&"["& beginpage &"]"
       arrValue(0)=arrValue(0)&"</a> "
    End If
   If beginpage >= iPageCount Then Exit For
  next
  '+----------------出现尾页数字
  if endpage<iPageCount then
   arrValue(0)=arrValue(0)&" <a href=#_p onclick=""showRdPL('"&Filegs&"page="& iPageCount &"')"" title=""末页"">[.."&iPageCount&"]</a> "
  end if
  if wzpage<iPageCount then
   arrValue(0)=arrValue(0)&"<a href=#_p onclick=""showRdPL('"&Filegs&"page="& wzpage+1 &"')"" title=""下一页"">下一页</a>"
  end if

  arrValue(1) = " <b>总数"&iRecordCount&"</b>"
  pagination_ajax=arrValue
End Function

'/*
' 分页函数生成html
' iRecordCount记录总数,iPageSize每页记录数
' iPageCount总页数,Filegs处理页,nowPage:当前页
' * /
Function pagination_html(iRecordCount,iPageSize,iPageCount,Filegs,nowPage)
Dim wzpage,wzpagecount,pagenum,arrValue(2)
dim beginpage,endpage '两者之间
If Len(nowPage)<>0 Then
   wzpage = clng(nowPage) '当前页
   Else
   wzpage =1
End If
If wzpage <= 0 Then wzpage =1
if (wzpage-4>=1) then
beginpage=wzpage-4
else
beginpage=1
end if
if (wzpage+4<=iPageCount) then
endpage=wzpage+4
else
endpage=iPageCount
end if
if beginpage=1 and iPageCount>=9 then '保持有9页选择
beginpage=1:endpage=9
end if
if endpage=iPageCount and iPageCount>=9 then '保持有9页选择
   beginpage=endpage-8
end if
if wzpage>=2 then
   arrValue(0)=arrValue(0)&"<a href="""&Filegs&wzpage-1&".html"" title=""上一页"">«上一页</a>"
end if
'+----------------出现首页数字
if beginpage=>2 then
arrValue(0)=arrValue(0)&" <a href="""&Filegs&"1.html"" title=""首页"">[1..]</a> "
end if
for beginpage=beginpage to endpage
   If beginpage = wzpage Then
       arrValue(0)=arrValue(0)&"<font color=""#ff0000"">"
       arrValue(0)=arrValue(0)&" ["& wzpage &"] "
       arrValue(0)=arrValue(0)&"</font>"
     Else
       arrValue(0)=arrValue(0)&" <a href="""&Filegs&beginpage &".html"">"
       arrValue(0)=arrValue(0)&"["& beginpage &"]"
       arrValue(0)=arrValue(0)&"</a> "
    End If
   If beginpage >= iPageCount Then Exit For
next
'+----------------出现尾页数字
if endpage<iPageCount then
arrValue(0)=arrValue(0)&" <a href="""&Filegs&iPageCount &".html"" title=""末页"">[.."&iPageCount&"]</a> "
end if
if wzpage<iPageCount then
arrValue(0)=arrValue(0)&"<a href="""&Filegs& wzpage+1 &".html"" title=""下一页"">下页更精彩»</a>"
end if

arrValue(1) = " 当前第"&wzpage&"页 "&iPageSize&"条/页共"&iPageCount&"页/"&iRecordCount&"条记录"
pagination_html=arrValue
End Function

'/*
' 文章内容加上{{page}}作为某处的分页标识
' 长文章指定{{page}}分页
' --pid：文章的ID
' --ntext:文章的内容
' --lfile：连接文件
' */
Function opage(pid,ntext,lfile)
dim temp_text,startStr,anum
temp_text=ntext
   listPage="{{page}}" '分布符
if instr(temp_text,listPage)>0 then
   anum=split(temp_text,listPage)
   page=request.QueryString("page")
   if page="" or page=0 then
     page=1
   else
     page=Clng(page)
   end if
     for i=1 to ubound(anum)+1   '分页开始
       if i=page then
         if i=1 then '特别处理page=1的情况
         numPage=numPage&"[<A href="&lfile&"?pid="&pid&"><font color=red>1</font></a>]"
         else
       numPage=numPage&"[<A href="&lfile&"?pid="&pid&"&page="&i&"><font color=red>"&i&"</font></a>]"
     end if
       else
         if i=1 then
         numPage=numPage&"[<A href="&lfile&"?pid="&pid&">1</a>]"
         else
       numPage=numPage&"[<A href="&lfile&"?pid="&pid&"&page="&i&">"&i&"</a>]"
       end if
       end if
     next

     if page>ubound(anum)+1 then
       page=ubound(anum)+1
     end if

     temp_text=anum(page-1)&"<div align=center>{{page}}</div>"
     temp_text=replace(temp_text,"{{page}}",numPage)
   end if
opage=temp_text
End Function
'/*
' *写入特定行
' *使用方法，在文件14行加入内容
' *Call FSOlinewrite("/Common/aspcodes/Variable.asp",14,"annouce="""&request("annouce")&"""")
' */
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) = temparray(lineNum-1)&chr(13)&chr(10)&lineContent '保留原内容
  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
''此函数返回下拉列表字符串，arrayname为传入的数组名称, arrayvalue为传入的数组值，sltname为此下拉列表的名称，sltclass为此下拉列表的样式，sltvalue为此下拉列表默认选择的值

Function writeselect(arrayname,arrayvalue,sltname,sltclass,sltvalue)
dim slt,i
slt="<select name=" & sltname & " class=" & sltclass & ">"
for i=0 to ubound(arrayname)
if sltvalue<>"" and trim(sltvalue)=trim(arrayvalue(i)) then
slt=slt & "<option value=" & arrayvalue(i) &" selected>" & arrayname(i) & "</option>"
else
slt=slt & "<option value=" & arrayvalue(i) &">" & arrayname(i) & "</option>"
end if
next
slt=slt & "</select>"
writeselect=slt
End function
'+--------------------------------------
' 函数功能：用户权限
' 参数：pstr当前有效值
'+--------------------------------------
Function limits(pstr)
dim tpstr,tresult
tpstr=pstr
   if Instr(Session("czy_right"),tpstr)>0 then
   tresult=true
   else
   tresult=false
   end if
limits=tresult
End Function

'/*
' * 获取当前Url参数的函数　
' */
Function GetUrl()
  Dim ScriptAddress,M_ItemUrl, M_item
  ScriptAddress = "http://"&request.ServerVariables("SERVER_NAME")&CStr(Request.ServerVariables("SCRIPT_NAME")) '取得当前地址
  M_ItemUrl = ""
  If (Request.QueryString <> "") Then
    ScriptAddress = ScriptAddress & "?"
    For Each M_item In Request.QueryString
    '如果页面传递参数是用page变量，那么判断一下page是否已经使用，避免重复！
      If InStr("pavge",M_Item)=0 Then
        M_ItemUrl = M_ItemUrl & M_Item &"="& Server.URLEncode(Request.QueryString(""&M_Item&"")) & "&"
      End If
    Next
  end if
  GetUrl = ScriptAddress & M_ItemUrl
  if instr(1,GetUrl,"?",1)<1 then
    GetUrl=GetUrl&"?"
  end if
End Function

'过滤关键字
'str原字符串
'keylist以|分隔的要过滤关键字
Function ReplaceKey(str,keylist)
dim tKey,tkeylist
tkeylist=Split(keylist,"|")
for i=0 to Ubound(tkeylist)
tKey=replace(str,tkeylist(i),"")
   str=tKey
next
'大写再转换一次
tkeylist=Split(UCase(keylist),"|")
for i=0 to Ubound(tkeylist)
tKey=replace(str,tkeylist(i),"")
   str=tKey
next
ReplaceKey=tKey
end function

'/*
' * 页脚信息
' */
Function endpageMsn()
endpageMsn="<script src='"&Website&"/ShowWebcount.asp'></script></font>"
End Function

'/*
' * 网站维护
' */
Sub Webunkeep()
  if webIsopen=0 then
   response.Write "<font style='font-size:14px;line-height:20px'>"
   Response.Write "Diggcms系统温馨提示：网站正在维护中……,请稍候访问！</font>"
   Response.End
  end if
End Sub

'/*
' * 验证码　
' */
Function GetCode()
Randomize
nowRand=Int((10*Rnd))
Verification_code=Split("涨,一日千里,yes,Dig,GOOD,拉升,打板,帅,COOL,明日,成",",")
GetCode=Verification_code(nowRand)
end Function
'+-----------------
' 显示验证码
'+-----------------
Sub ShowCode()
response.Write "<script>"&VBCRLF
response.Write "function copyTxt(str){"&VBCRLF
response.Write "var clipBoardContent="""";"&VBCRLF
response.Write " clipBoardContent+=str;"&VBCRLF
response.Write " window.clipboardData.setData('Text',clipBoardContent);"&VBCRLF
response.Write "  alert('验证码复制成功！');"&VBCRLF
response.Write "}"&VBCRLF
response.Write "</script>"&VBCRLF
Randomize
showRand=Int((9999999*Rnd))
nowgetcode=getcode()
response.Cookies("hao123.com")=nowgetcode
response.Write "<div title='点击复制验证码' onclick='copyTxt("""&request.Cookies("hao123.com")&""")' style='padding:2px;background-color:#F7F7F7;width:60px;text-align:center;border:1px dashed #2BA239;cursor:pointer' id='"&showRand&"'>"&request.Cookies("hao123.com")&"</div>"
end sub
'+---------------
' 存在再显示
'+---------------
Sub ShowCodeOver()
response.Write "<script>"&VBCRLF
response.Write "function copyTxt(str){"&VBCRLF
response.Write "var clipBoardContent="""";"&VBCRLF
response.Write " clipBoardContent+=str;"&VBCRLF
response.Write " window.clipboardData.setData('Text',clipBoardContent);"&VBCRLF
response.Write "  alert('验证码复制成功！');"&VBCRLF
response.Write "}"&VBCRLF
response.Write "</script>"&VBCRLF
response.Write "<div title='点击复制验证码' onclick='copyTxt("""&request.Cookies("hao123.com")&""")' style='padding:2px;background-color:#F7F7F7;width:8px;border:1px dashed #2BA239;cursor:pointer' id='"&showRand&"'>"&request.Cookies("hao123.com")&"</div>"
End Sub

'防刷新
sub refreshtime()
if DateDiff("s",Session("RefreshTime"),Now())<iRefreshTime then
Call FunMsg("#","温馨提示：请不要在"&iRefreshTime&"秒内快速发帖\n　　　　　还剩"&iRefreshTime-DateDiff("s",Session("RefreshTime"),now())&"秒")
   Response.End
end if
Session("RefreshTime")=Now()
end sub

'/*
' * 读取模板文件内容
' */
Function Readtemplate(vdir,val)
dim p_template
  set FSO = createobject("Scripting.FileSystemObject")
  if FSO.FileExists(server.mappath(vdir&TemplateDir &"\"& val)) then
    set oFile = FSO.OpenTextFile(server.mappath(vdir&TemplateDir &"\"& val), 1)
    p_template = oFile.ReadAll
    oFile.Close
    set oFile = nothing
    if vdir<>"" then
     response.Write "更新"&val&"完成<br>"
    end if
  else
    response.write "<b>ASPTemplate Error: File [" & val & "] does not exists!</b><br>"
  end if
  set FSO = nothing
  Readtemplate=p_template
end Function

'/*
' * 设置帖子列表小图
' */
Function SetImgWH(IMGPath,MaxW,MaxH)
On Error Resume Next
  if instr(Lcase(IMGPath),"http://")>0 then
   IMGPath=IMGPath:W=MaxW:H=MaxH
  else
    Set PP = New ImgWHInfo
    W = PP.imgW(lcase(Server.Mappath(IMGPath)))
    H = PP.imgH(lcase(Server.Mappath(IMGPath)))
    Set pp = Nothing
    if W>MaxW then
      H=H*MaxW/W
      W=MaxW
    end if
    if H >MaxH then
      W=W*MaxH/H
      H=MaxH
    end if
    pp=null
  end if
  SetImgWH = "src='"&IMGPath&"' width='"&int(W)&"' height='"&int(H)&"' "
End Function

'/*
' * 更新模板缓存
' */
Sub updatetemplate()
if Application("diggcms_index")="" then
    Application.Lock
    Application("diggcms_index")=Readtemplate("","index.htm")
    Application("diggcms_top")=Readtemplate("","top.htm")
    Application("diggcms_top_list")=Readtemplate("","top_list.htm")
    Application("diggcms_search")=Readtemplate("","search.htm")
    Application("diggcms_register")=Readtemplate("","Register.htm")
    Application("diggcms_mlist")=Readtemplate("","mlist.htm")
    Application("diggcms_login")=Readtemplate("","login.htm")
    Application("diggcms_list_tyle2")=Readtemplate("","list_tyle2.htm")
    Application("diggcms_list_tyle1")=Readtemplate("","list_tyle1.htm")
    Application("diggcms_list")=Readtemplate("","list.htm")
    Application("diggcms_html")=Readtemplate("","html.htm")
    Application("diggcms_end")=Readtemplate("","end.htm")
    Application("diggcms_channel")=Readtemplate("","channel.htm")
    Application.UnLock
    'response.Write "成功"
end if
End Sub
%>

暂时没有评论

发表评论 - 不要忘了输入验证码哦！

作者：

用户：密码：我要注册验证码：
为防止广告注册机程序,验证码不会自动显示,请点击此处显示或者(刷新)验证码!

评论：

禁止表情
禁止UBB
禁止图片
识别链接
识别关键字
确定发布？


最多可以输入200个字,目前你已经输入了0个字;你今日还可以发表10条评论!