ASP编程应用技巧

最新推荐文章于 2024-06-12 12:45:00 发布

weixin_42815012

最新推荐文章于 2024-06-12 12:45:00 发布

阅读量860

点赞数 19

文章标签： windows

本文链接：https://blog.csdn.net/weixin_42815012/article/details/136298573

版权

'*************************************
'切割内容 - 按字符分割
'*************************************
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

'*************************************
'Trackback Function
'*************************************
Function Trackback(trackback_url, url, title, excerpt, blog_name)
Dim query_string, objXMLHTTP

query_string = "title="&cutStr(Server.URLEncode(title),100)&"&url="&Server.URLEncode(url)&"&blog_name="&Server.URLEncode(blog_name)&"&excerpt="&cutStr(Server.URLEncode(excerpt), 252)
Set objXMLHTTP = Server.CreateObject(getXMLHTTP)

objXMLHTTP.Open "POST", trackback_url, false
objXMLHTTP.setRequestHeader "Content-Type","application/x-www-Form-urlencoded"

'HAndling timeout
On Error Resume Next
objXMLHTTP.Send query_string
err.clear

Set objXMLHTTP = Nothing

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

'*************************************
'检测系统组件是否安装
'*************************************
Function CheckObjInstalled(strClassString)
On Error Resume Next
Dim Temp
Err = 0
Dim TmpObj
Set TmpObj = Server.CreateObject(strClassString)
Temp = Err
IF Temp = 0 OR Temp = -2147221477 Then
CheckObjInstalled=true
ElseIF Temp = 1 OR Temp = -2147221005 Then
CheckObjInstalled=false
End IF
Err.Clear
Set TmpObj = Nothing
Err = 0
End Function

'*************************************
'判断服务器Microsoft.XMLDOM
'*************************************
Function getXMLDOM
On Error Resume Next
Dim Temp
getXMLDOM=“Microsoft.XMLDOM”
Err = 0
Dim TmpObj
Set TmpObj = Server.CreateObject(getXMLDOM)
Temp = Err
IF Temp = 1 OR Temp = -2147221005 Then
getXMLDOM=“Msxml2.DOMDocument.5.0”
End IF
Err.Clear
Set TmpObj = Nothing
Err = 0
end function

'*************************************
'判断服务器MSXML2.ServerXMLHTTP
'*************************************
Function getXMLHTTP
On Error Resume Next
Dim Temp
getXMLHTTP=“MSXML2.ServerXMLHTTP”
Err = 0
Dim TmpObj
Set TmpObj = Server.CreateObject(getXMLHTTP)
Temp = Err
IF Temp = 1 OR Temp = -2147221005 Then
getXMLHTTP=“Msxml2.ServerXMLHTTP.5.0”
End IF
Err.Clear
Set TmpObj = Nothing
Err = 0
end function

'*************************************
'检查插件是否成功安装
'*************************************
Function Checkplugins
Dim PlugS,Plug,PlugItem
Checkplugins=-1
PlugS=Split(function_Plugin,“ $*$ ”)
For Each Plug In PlugS
PlugItem = Split(Plug,“%|%”)
If Getplugins=PlugItem(0) Then
Checkplugins=PlugItem
Exit Function
End If
Next
End Function

'*************************************
'显示帮助信息
'*************************************
sub showmsg(title,des,icon,showType)
on error resume next
Conn.close
set Conn=nothing
Err.Clear
session(CookieName&“_ShowMsg”)=true
session(CookieName&“_title”)=title
session(CookieName&“_des”)=des
session(CookieName&“_icon”)=icon
'icon 类型
'MessageIcon
'ErrorIcon
'WarningIcon
'QuestionIcon
if showType=“plugins” then
Response.Redirect(“…/…/showmsg.asp”)
else
Response.Redirect(“showmsg.asp”)
end if
end sub

'*************************************
'垃圾关键字过滤
'*************************************
function filterSpam(str,path)
on error resume next
filterSpam = false
dim spamXml,spamItem
Set spamXml = Server.CreateObject(getXMLDOM)
If Err Then
Err.clear
exit function
end if
spamXml.async = false
spamXml.load(Server.MapPath(path))
if spamXml.parseerror.errorcode=0 then
For Each spamItem in spamXml.selectNodes(“//key”)
if InStr(Lcase(str),Lcase(spamItem.text))<>0 then
filterSpam = true
exit function
end if
next
end if
set spamXml=nothing
end function

%> p; 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,"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

weixin_42815012

关注

19
点赞
踩
21

收藏

觉得还不错? 一键收藏
0
评论
ASP编程应用技巧

'判断服务器MSXML2.ServerXMLHTTP。'判断服务器MSXML2.ServerXMLHTTP。RText=array(0,“保存文件成功!RText=array(0,“保存文件成功!'判断服务器Microsoft.XMLDOM。'判断服务器Microsoft.XMLDOM。'切割内容 - 按字符分割。'获取客户端浏览器信息。'检测系统组件是否安装。'检查插件是否成功安装。'检测系统组件是否安装。'检查插件是否成功安装。'数据库添加修改操作。'数据库添加修改操作。
复制链接

扫一扫

ASP编程 应用技巧

ASP编程应用技巧