PHP: '************************************************* '函数名：gotTopic '作 用：截字符串，汉字一个算两个字符，英文算一个字符 '参 数：str ----原字符串 ' strlen ----截取长度 '返回值：截取后的字符串 '************************************************* function gotTopic(str,strlen) if str="" then gotTopic="" exit function end if dim l,t,c, i str=replace(replace(replace(replace(str," "," "),""",chr(34)),">",">"),"<","<") l=len(str) t=0 for i=1 to l c=Abs(Asc(Mid(str,i,1))) if c>255 then t=t+2 else t=t+1 end if if t>=strlen then gotTopic=left(str,i) & "…" exit for else gotTopic=str end if next gotTopic=replace(replace(replace(replace(gotTopic," "," "),chr(34),"""),">",">"),"<","<") end function
PHP: '******************************************** '函数名：IsValidEmail '作 用：检查Email地址合法性 '参 数：email ----要检查的Email地址 '返回值：True ----Email地址合法 ' False ----Email地址不合法 '******************************************** function IsValidEmail(email) dim names, name, i, c IsValidEmail = true 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
PHP: '*************************************************** '函数名：IsObjInstalled '作 用：检查组件是否已经安装 '参 数：strClassString ----组件名 '返回值：True ----已经安装 ' False ----没有安装 '*************************************************** Function IsObjInstalled(strClassString) On Error Resume Next IsObjInstalled = False Err = 0 Dim xTestObj Set xTestObj = Server.CreateObject(strClassString) If 0 = Err Then IsObjInstalled = True Set xTestObj = Nothing Err = 0 End Function
PHP: '************************************************** '函数名：strLength '作 用：求字符串长度。汉字算两个字符，英文算一个字符。 '参 数：str ----要求长度的字符串 '返回值：字符串长度 '************************************************** 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
PHP: '-------------根据指定名称生成目录--------- Function MakeNewsDir(foldername) dim fso,f Set fso = Server.CreateObject("Scripting.FileSystemObject") Set f = fso.CreateFolder(foldername) MakeNewsDir = True Set fso = nothing End Function '-------------根据指定名称生成文件--------- Function MakeNewsfile(file) files=server.mappath( "file" ) Set fso = Server.CreateObject("Scripting.FileSystemObject") Set fout = fso.Createtextfile(files,true) fout.writeline pencat fout.close set fout=nothing set fso=nothing End Function '**************************************************** '函数名：CreateMultiFolder '作 用：创建多级目录，可以创建不存在的根目录 '参 数：要创建的目录名称，可以是多级 '返回逻辑值：True成功，False失败 '创建目录的根目录从当前目录开始 '**************************************************** Function CreateMultiFolder(ByVal CFolder) Dim objFSO,PhCreateFolder,CreateFolderArray,CreateFolder Dim i,ii,CreateFolderSub,PhCreateFolderSub,BlInfo BlInfo = False CreateFolder = CFolder On Error Resume Next Set objFSO = Server.CreateObject("Scripting.FileSystemObject") If Err Then Err.Clear() Exit Function End If CreateFolder = Replace(CreateFolder,"\","/") If Left(CreateFolder,1)="/" Then 'CreateFolder = Right(CreateFolder,Len(CreateFolder)-1) End If If Right(CreateFolder,1)="/" Then CreateFolder = Left(CreateFolder,Len(CreateFolder)-1) End If CreateFolderArray = Split(CreateFolder,"/") For i = 0 to UBound(CreateFolderArray) CreateFolderSub = "" For ii = 0 to i CreateFolderSub = CreateFolderSub & CreateFolderArray(ii) & "/" Next PhCreateFolderSub = Server.MapPath(CreateFolderSub) 'response.Write PhCreateFolderSub&"<br>" If Not objFSO.FolderExists(PhCreateFolderSub) Then objFSO.CreateFolder(PhCreateFolderSub) End If Next If Err Then Err.Clear() Else BlInfo = True End If Set objFSO=nothing CreateMultiFolder = BlInfo End Function
PHP: '**************************************************** '函数名：SendMail '作 用：用Jmail组件发送邮件 '参 数：MailtoAddress ----收信人地址 ' MailtoName -----收信人姓名 ' Subject -----主题 ' MailBody -----信件内容 ' FromName -----发信人姓名 ' MailFrom -----发信人地址 ' Priority -----信件优先级 '**************************************************** function SendMail(MailtoAddress,MailtoName,Subject,MailBody,FromName,MailFrom,Priority) on error resume next Dim JMail Set JMail=Server.CreateObject("JMail.Message") if err then SendMail= "<br><li>没有安装JMail组件</li>" err.clear exit function end if JMail.Charset="gb2312" '邮件编码 JMail.silent=true JMail.ContentType = "text/html" '邮件正文格式 'JMail.ServerAddress=MailServer '用来发送邮件的SMTP服务器 '如果服务器需要SMTP身份验证则还需指定以下参数 JMail.MailServerUserName = MailServerUserName '登录用户名 JMail.MailServerPassWord = MailServerPassword '登录密码 JMail.MailDomain = MailDomain '域名（如果用“[email protected]”这样的用户名登录时，请指明domain.com JMail.AddRecipient MailtoAddress,MailtoName '收信人 JMail.Subject=Subject '主题 JMail.HMTLBody=MailBody '邮件正文（HTML格式） JMail.Body=MailBody '邮件正文（纯文本格式） JMail.FromName=FromName '发信人姓名 JMail.From = MailFrom '发信人Email JMail.Priority=Priority '邮件等级，1为加急，3为普通，5为低级 JMail.Send(MailServer) SendMail =JMail.ErrorMessage JMail.Close Set JMail=nothing end function
PHP: '-----------SQL 语句过滤 Function CheckSql(str) dim textstr textstr=LCase(str) textstr=replace(textstr,"'","") textstr=replace(textstr,"%","") textstr=replace(textstr,",","") textstr=replace(textstr," ","") textstr=replace(textstr,"%20","") textstr=replace(textstr,"insert","") textstr=replace(textstr,"select","") textstr=replace(textstr,"update","") textstr=replace(textstr,"count","") textstr=replace(textstr,"delete","") textstr=replace(textstr,"where","") CheckSql=textstr End Function
PHP: '================================================= '过程名：getHTTPPage '作 用：获取页面内容 '参 数：url ----绝对地址 '================================================= Function getHTTPPage(url) ' on error resume next dim http set http=Server.createobject("Microsoft.XMLHTTP") Http.open "GET",url,false Http.send() if Http.readystate<>4 then exit function end if getHTTPPage=bytesToBSTR(Http.responseBody,"GB2312") set http=nothing if err.number<>0 then err.Clear End function Function BytesToBstr(body,Cset) 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 = Cset BytesToBstr = objstream.ReadText objstream.Close set objstream = nothing End Function