ASP开发中有用的function集合
2020-03-05 15:58
1106 查看
'************************************* '日期转换函数 '************************************* Function DateToStr(DateTime,ShowType) Dim DateMonth,DateDay,DateHour,DateMinute,DateWeek,DateSecond Dim FullWeekday,shortWeekday,Fullmonth,Shortmonth,TimeZone1,TimeZone2 TimeZone1="+0800" TimeZone2="+08:00" FullWeekday=Array("Sunday","Monday","Tuesday","Wednesday","Thursday","Friday","Saturday") shortWeekday=Array("Sun","Mon","Tue","Wed","Thu","Fri","Sat") Fullmonth=Array("January","February","March","April","May","June","July","August","September","October","November","December") Shortmonth=Array("Jan","Feb","Mar","Apr","May","Jun","Jul","Aug","Sep","Oct","Nov","Dec") DateMonth=Month(DateTime) DateDay=Day(DateTime) DateHour=Hour(DateTime) DateMinute=Minute(DateTime) DateWeek=weekday(DateTime) DateSecond=Second(DateTime) If Len(DateMonth)<2 Then DateMonth="0"&DateMonth If Len(DateDay)<2 Then DateDay="0"&DateDay If Len(DateMinute)<2 Then DateMinute="0"&DateMinute Select Case ShowType Case "Y-m-d" DateToStr=Year(DateTime)"-"&DateMonth"-"&DateDay Case "Y-m-d H:I A" 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 DateToStr=Year(DateTime)"-"&DateMonth"-"&DateDay" "&DateHour":"&DateMinute" "&DateAMPM Case "Y-m-d H:I:S" If Len(DateHour)<2 Then DateHour="0"&DateHour If Len(DateSecond)<2 Then DateSecond="0"&DateSecond DateToStr=Year(DateTime)"-"&DateMonth"-"&DateDay" "&DateHour":"&DateMinute":"&DateSecond Case "YmdHIS" DateSecond=Second(DateTime) If Len(DateHour)<2 Then DateHour="0"&DateHour If Len(DateSecond)<2 Then DateSecond="0"&DateSecond DateToStr=Year(DateTime)&DateMonth&DateDay&DateHour&DateMinute&DateSecond Case "ym" DateToStr=Right(Year(DateTime),2)&DateMonth Case "d" DateToStr=DateDay Case "ymd" DateToStr=Right(Year(DateTime),4)&DateMonth&DateDay Case "mdy" Dim DayEnd select Case DateDay Case 1 DayEnd="st" Case 2 DayEnd="nd" Case 3 DayEnd="rd" Case Else DayEnd="th" End Select DateToStr=Fullmonth(DateMonth-1)" "&DateDay&DayEnd" "&Right(Year(DateTime),4) Case "w,d m y H:I:S" DateSecond=Second(DateTime) If Len(DateHour)<2 Then DateHour="0"&DateHour If Len(DateSecond)<2 Then DateSecond="0"&DateSecond DateToStr=shortWeekday(DateWeek-1)","&DateDay" "& Left(Fullmonth(DateMonth-1),3) " "&Right(Year(DateTime),4)" "&DateHour":"&DateMinute":"&DateSecond" "&TimeZone1 Case "y-m-dTH:I:S" If Len(DateHour)<2 Then DateHour="0"&DateHour If Len(DateSecond)<2 Then DateSecond="0"&DateSecond DateToStr=Year(DateTime)"-"&DateMonth"-"&DateDay"T"&DateHour":"&DateMinute":"&DateSecond&TimeZone2 Case Else If Len(DateHour)<2 Then DateHour="0"&DateHour DateToStr=Year(DateTime)"-"&DateMonth"-"&DateDay" "&DateHour":"&DateMinute End Select End Function '************************************* '分页函数 '************************************* dim FirstShortCut,ShortCut FirstShortCut=false Function MultiPage(Numbers,Perpage,Curpage,Url_Add,aname,Style) CurPage=Int(Curpage) Numbers=Int(Numbers) Dim URL URL=Request.ServerVariables("Script_Name")&Url_Add MultiPage="" Dim Page,Offset,PageI ' If Int(Numbers)>Int(PerPage) Then Page=9 Offset=4 Dim Pages,FromPage,ToPage If Numbers Mod Cint(Perpage)=0 Then Pages=Int(Numbers/Perpage) Else Pages=Int(Numbers/Perpage)+1 End If FromPage=Curpage-Offset ToPage=Curpage+Page-Offset-1 If Page>Pages Then FromPage=1 ToPage=Pages Else If FromPage<1 Then Topage=Curpage+1-FromPage FromPage=1 If (ToPage-FromPage)<Page And (ToPage-FromPage)<Pages Then ToPage=Page ElseIF Topage>Pages Then FromPage =Curpage-Pages +ToPage ToPage=Pages If (ToPage-FromPage)<Page And (ToPage-FromPage)<Pages Then FromPage=Pages-Page+1 End If End If MultiPage="<div class=""page"" style="""&Style"""><ul>" 'if Curpage<>1 then MultiPage=MultiPage&"<li class=""PageL""><a href="""&Url&"page=1"" class=""PageLbutton"" title=""第一页""></a></li>" MultiPage=MultiPage"<li class=""pageNumber"">" if Curpage<>1 then MultiPage=MultiPage"<a href="""&Url"page=1"" title=""第一页"" style=""text-decoration:none""><</a> | " if not FirstShortCut then ShortCut=" accesskey="",""" else ShortCut="" if Curpage<>1 then MultiPage=MultiPage"<a href="""&Url"page="&CurPage-1""" title=""上一页"" style=""text-decoration:none;"""&ShortCut"></a>" For PageI=FromPage TO ToPage If PageI<>CurPage Then MultiPage=MultiPage"<a href="""&Url"page="&PageI&aname""">"&PageI"</a> | " Else MultiPage=MultiPage"<strong>"&PageI"</strong>" if PageI<>Pages then MultiPage=MultiPage" | " End If Next if not FirstShortCut then ShortCut=" accesskey="".""" else ShortCut="" if Curpage<>pages then MultiPage=MultiPage"<a href="""&Url"page="&CurPage+1""" title=""下一页"" style=""text-decoration:none"""&ShortCut"></a>" if Curpage<>pages then MultiPage=MultiPage"<a href="""&Url"page="&Pages&aname""" title=""最后一页"" style=""text-decoration:none"">></a>" MultiPage=MultiPage"</li>" 'If Int(Pages)>Int(Page) Then ' MultiPage=MultiPage&"<li>...</li><li><a href="""&Url&"page="&Pages&aname&""">"&pages&"</a></li>" 'End If 'if Curpage<>pages then MultiPage=MultiPage&"<li class=""PageR""><a href="""&Url&"page="&Pages&aname&""" class=""PageRbutton"" title=""最后一页""></a></li>" MultiPage=MultiPage"</ul></div>" ' End If FirstShortCut=true End Function '************************************* '切割内容 - 按行分割 '************************************* Function SplitLines(byVal Content,byVal ContentNums) Dim ts,i,l ContentNums=int(ContentNums) If IsNull(Content) Then Exit Function i=1 ts = 0 For i=1 to Len(Content) l=Lcase(Mid(Content,i,5)) If l="<br/>" Then ts=ts+1 End If l=Lcase(Mid(Content,i,4)) If l="<br>" Then ts=ts+1 End If l=Lcase(Mid(Content,i,3)) If l="<p>" Then ts=ts+1 End If If ts>ContentNums Then Exit For Next If ts>ContentNums Then Content=Left(Content,i-1) End If SplitLines=Content End Function '************************************* '切割内容 - 按字符分割 '************************************* Function CutStr(byVal Str,byVal StrLen) Dim l,t,c,i If IsNull(Str) Then CutStr="":Exit Function l=Len(str) StrLen=int(StrLen) t=0 For i=1 To l c=Asc(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 DelQuote(strContent) If IsNull(strContent) Then Exit Function Dim re Set re=new RegExp re.IgnoreCase =True re.Global=True re.Pattern="/[quote/](.[^/]]*?)/[//quote/]" strContent= re.Replace(strContent,"") re.Pattern="/[quote=(.[^/]]*)/](.[^/]]*?)/[//quote/]" strContent= re.Replace(strContent,"") Set re=Nothing DelQuote=strContent End Function '************************************* '获取客户端IP '************************************* function getIP() dim strIP,IP_Ary,strIP_list strIP_list=Replace(Request.ServerVariables("HTTP_X_FORWARDED_FOR"),"'","") If InStr(strIP_list,",")<>0 Then IP_Ary = Split(strIP_list,",") strIP = IP_Ary(0) Else strIP = strIP_list End IF If strIP=Empty Then strIP=Replace(Request.ServerVariables("REMOTE_ADDR"),"'","") getIP=strIP End Function '************************************* '获取客户端浏览器信息 '************************************* function getBrowser(strUA) dim arrInfo,strType,temp1,temp2 strType="" strUA=LCase(strUA) arrInfo=Array("Unkown","Unkown") '浏览器判断 if Instr(strUA,"mozilla")>0 then arrInfo(0)="Mozilla" if Instr(strUA,"icab")>0 then arrInfo(0)="iCab" if Instr(strUA,"lynx")>0 then arrInfo(0)="Lynx" if Instr(strUA,"links")>0 then arrInfo(0)="Links" if Instr(strUA,"elinks")>0 then arrInfo(0)="ELinks" if Instr(strUA,"jbrowser")>0 then arrInfo(0)="JBrowser" if Instr(strUA,"konqueror")>0 then arrInfo(0)="konqueror" if Instr(strUA,"wget")>0 then arrInfo(0)="wget" if Instr(strUA,"ask jeeves")>0 or Instr(strUA,"teoma")>0 then arrInfo(0)="Ask Jeeves/Teoma" if Instr(strUA,"wget")>0 then arrInfo(0)="wget" if Instr(strUA,"opera")>0 then arrInfo(0)="opera" if Instr(strUA,"gecko")>0 then strType="[Gecko]" arrInfo(0)="Mozilla" if Instr(strUA,"aol")>0 then arrInfo(0)="AOL" if Instr(strUA,"netscape")>0 then arrInfo(0)="Netscape" if Instr(strUA,"firefox")>0 then arrInfo(0)="FireFox" if Instr(strUA,"chimera")>0 then arrInfo(0)="Chimera" if Instr(strUA,"camino")>0 then arrInfo(0)="Camino" if Instr(strUA,"galeon")>0 then arrInfo(0)="Galeon" if Instr(strUA,"k-meleon")>0 then arrInfo(0)="K-Meleon" arrInfo(0)=arrInfo(0)+strType end if if Instr(strUA,"bot")>0 or Instr(strUA,"crawl")>0 then strType="[Bot/Crawler]" arrInfo(0)="" if Instr(strUA,"grub")>0 then arrInfo(0)="Grub" if Instr(strUA,"googlebot")>0 then arrInfo(0)="GoogleBot" if Instr(strUA,"msnbot")>0 then arrInfo(0)="MSN Bot" if Instr(strUA,"slurp")>0 then arrInfo(0)="Yahoo! Slurp" arrInfo(0)=arrInfo(0)+strType end if if Instr(strUA,"applewebkit")>0 then strType="[AppleWebKit]" arrInfo(0)="" if Instr(strUA,"omniweb")>0 then arrInfo(0)="OmniWeb" if Instr(strUA,"safari")>0 then arrInfo(0)="Safari" arrInfo(0)=arrInfo(0)+strType end if if Instr(strUA,"msie")>0 then strType="[MSIE" temp1=mid(strUA,(Instr(strUA,"msie")+4),6) temp2=Instr(temp1,";") temp1=left(temp1,temp2-1) strType=strType & temp1 "]" arrInfo(0)="Internet Explorer" if Instr(strUA,"msn")>0 then arrInfo(0)="MSN" if Instr(strUA,"aol")>0 then arrInfo(0)="AOL" if Instr(strUA,"webtv")>0 then arrInfo(0)="WebTV" if Instr(strUA,"myie2")>0 then arrInfo(0)="MyIE2" if Instr(strUA,"maxthon")>0 then arrInfo(0)="Maxthon" if Instr(strUA,"gosurf")>0 then arrInfo(0)="GoSurf" if Instr(strUA,"netcaptor")>0 then arrInfo(0)="NetCaptor" if Instr(strUA,"sleipnir")>0 then arrInfo(0)="Sleipnir" if Instr(strUA,"avant browser")>0 then arrInfo(0)="AvantBrowser" if Instr(strUA,"greenbrowser")>0 then arrInfo(0)="GreenBrowser" if Instr(strUA,"slimbrowser")>0 then arrInfo(0)="SlimBrowser" arrInfo(0)=arrInfo(0)+strType end if '操作系统判断 if Instr(strUA,"windows")>0 then arrInfo(1)="Windows" if Instr(strUA,"windows ce")>0 then arrInfo(1)="Windows CE" if Instr(strUA,"windows 95")>0 then arrInfo(1)="Windows 95" if Instr(strUA,"win98")>0 then arrInfo(1)="Windows 98" if Instr(strUA,"windows 98")>0 then arrInfo(1)="Windows 98" if Instr(strUA,"windows 2000")>0 then arrInfo(1)="Windows 2000" if Instr(strUA,"windows xp")>0 then arrInfo(1)="Windows XP" if Instr(strUA,"windows nt")>0 then arrInfo(1)="Windows NT" if Instr(strUA,"windows nt 5.0")>0 then arrInfo(1)="Windows 2000" if Instr(strUA,"windows nt 5.1")>0 then arrInfo(1)="Windows XP" if Instr(strUA,"windows nt 5.2")>0 then arrInfo(1)="Windows 2003" end if if Instr(strUA,"x11")>0 or Instr(strUA,"unix")>0 then arrInfo(1)="Unix" if Instr(strUA,"sunos")>0 or Instr(strUA,"sun os")>0 then arrInfo(1)="SUN OS" if Instr(strUA,"powerpc")>0 or Instr(strUA,"ppc")>0 then arrInfo(1)="PowerPC" if Instr(strUA,"macintosh")>0 then arrInfo(1)="Mac" if Instr(strUA,"mac osx")>0 then arrInfo(1)="MacOSX" if Instr(strUA,"freebsd")>0 then arrInfo(1)="FreeBSD" if Instr(strUA,"linux")>0 then arrInfo(1)="Linux" if Instr(strUA,"palmsource")>0 or Instr(strUA,"palmos")>0 then arrInfo(1)="PalmOS" if Instr(strUA,"wap ")>0 then arrInfo(1)="WAP" 'arrInfo(0)=strUA getBrowser=arrInfo end function '************************************* '计算随机数 '************************************* function randomStr(intLength) dim strSeed,seedLength,pos,str,i strSeed = "abcdefghijklmnopqrstuvwxyz1234567890" seedLength=len(strSeed) str="" Randomize for i=1 to intLength str=str+mid(strSeed,int(seedLength*rnd)+1,1) next randomStr=str end function '************************************* '自动闭合UBB '************************************* function closeUBB(strContent) dim arrTags,i,OpenPos,ClosePos,re,strMatchs,j,Match Set re=new RegExp re.IgnoreCase =True re.Global=True arrTags=array("code","quote","list","color","align","font","size","b","i","u","html") for i=0 to ubound(arrTags) OpenPos=0 ClosePos=0 re.Pattern="/["+arrTags(i)+"(=[^/[/]]+|)/]" Set strMatchs=re.Execute(strContent) For Each Match in strMatchs OpenPos=OpenPos+1 next re.Pattern="/[/"+arrTags(i)+"/]" Set strMatchs=re.Execute(strContent) For Each Match in strMatchs ClosePos=ClosePos+1 next for j=1 to OpenPos-ClosePos strContent=strContent+"[/"+arrTags(i)+"]" next next closeUBB=strContent end function '************************************* '自动闭合HTML '************************************* function closeHTML(strContent) dim arrTags,i,OpenPos,ClosePos,re,strMatchs,j,Match Set re=new RegExp re.IgnoreCase =True re.Global=True arrTags=array("p","div","span","table","ul","font","b","u","i","h1","h2","h3","h4","h5","h6") for i=0 to ubound(arrTags) OpenPos=0 ClosePos=0 re.Pattern="/<"+arrTags(i)+"( [^/</>]+|)/>" Set strMatchs=re.Execute(strContent) For Each Match in strMatchs OpenPos=OpenPos+1 next re.Pattern="/</"+arrTags(i)+"/>" Set strMatchs=re.Execute(strContent) For Each Match in strMatchs ClosePos=ClosePos+1 next for j=1 to OpenPos-ClosePos strContent=strContent+"</"+arrTags(i)+">" next next closeHTML=strContent end function '************************************* '读取文件 '************************************* Function LoadFromFile(ByVal File) Dim objStream Dim RText RText=array(0,"") On Error Resume Next Set objStream = Server.CreateObject("ADODB.Stream") If Err Then RText=array(Err.Number,Err.Description) LoadFromFile=RText Err.Clear exit function End If With objStream .Type = 2 .Mode = 3 .Open .Charset = "utf-8" .Position = objStream.Size .LoadFromFile Server.MapPath(File) If Err.Number<>0 Then RText=array(Err.Number,Err.Description) LoadFromFile=RText Err.Clear exit function End If RText=array(0,.ReadText) .Close End With LoadFromFile=RText Set objStream = Nothing End Function '************************************* '保存文件 '************************************* Function SaveToFile(ByVal strBody,ByVal File) Dim objStream Dim RText RText=array(0,"") On Error Resume Next Set objStream = Server.CreateObject("ADODB.Stream") If Err Then RText=array(Err.Number,Err.Description) Err.Clear exit function End If With objStream .Type = 2 .Open .Charset = "utf-8" .Position = objStream.Size .WriteText = strBody .SaveToFile Server.MapPath(File),2 .Close End With RText=array(0,"保存文件成功!") SaveToFile=RText Set objStream = Nothing End Function '************************************* '数据库添加修改操作 '************************************* function DBQuest(table,DBArray,Action) dim AddCount,TempDB,i,v if Action<>"insert" or Action<>"update" then Action="insert" if Action="insert" then v=2 else v=3 if not IsArray(DBArray) then DBQuest=-1 exit function else Set TempDB=Server.CreateObject("ADODB.RecordSet") On Error Resume Next TempDB.Open table,Conn,1,v if err then DBQuest=-2 exit function end if if Action="insert" then TempDB.addNew AddCount=UBound(DBArray,1) for i=0 to AddCount TempDB(DBArray(i)(0))=DBArray(i)(1) next TempDB.update TempDB.close set TempDB=nothing DBQuest=0 end if end Function
- 点赞
- 收藏
- 分享
- 文章举报
相关文章推荐
- ASP开发中有用的函数(function)集合
- asp.net控件开发基础(10) --------再谈属性,实现自定义控件集合属性
- asp.net控件开发基础(10) -- 集合属性的使用
- 【转】 Asp.NET大文件上传开发总结集合
- ASP.NET控件开发基础之实现控件集合属性
- 《纵向切入ASP.NET 3.5控件和组件开发技术》笔记:高效率事件集合对象
- ASP 实用Function集合
- ASP.NET程序开发中经典常用的三十三种代码实例[确实有用]
- asp.net控件开发集合(转载)
- ASP编程常用的函数function集合
- 几个有用的ASP Function
- asp.net开发的调试方法集合
- 【安卓开源集合】最全最有用的第三方开源库收集整理,快速开发必备,还能提升效率
- [web开发] php优势 - PHP与ASP.NET的比较
- ASP.NET MVC+LINQ开发一个图书销售站点(10):作者管理
- 用ASP.NET Web API技术开发HTTP接口(二)
- Asp.net开发必备51种代码(非常实用)(转)
- 在移动端开发中,容易遇到的问题集合。
- Asp.net网站开发(一)LINQ TO SQL 之八大字句
- 泛型集合List 相关(转) 可能对你有用