Lly's Blog

 asp用的xmlhttp方法集合,个人认为很有用

本站整理, 发表于:2015-05-29 21:42:53, 分类:资源共享 浏览( ) 评论( )  收藏这篇日志
Asp 代码
 
  1. <%
  2. '==================================================
  3. '函数名:GetHttpPage
  4. '作 用:获取网页源码
  5. '参 数:HttpUrl ------网页地址
  6. '==================================================
  7. Function GetHttpPage(HttpUrl)
  8. If IsNull(HttpUrl)=True Or Len(HttpUrl)<18 Or HttpUrl="$False$" Then
  9. GetHttpPage="$False$"
  10. Exit Function
  11. End If
  12. Dim Http
  13. Set Http=server.createobject("MSXML2.XMLHTTP")
  14. Http.open "GET",HttpUrl,False
  15. Http.Send()
  16. If Http.Readystate<>4 then
  17. Set Http=Nothing 
  18. GetHttpPage="$False$"
  19. Exit function
  20. End if
  21. GetHTTPPage=bytesToBSTR(Http.responseBody,"GB2312")
  22. Set Http=Nothing
  23. If Err.number<>0 then
  24. Err.Clear
  25. End If
  26. End Function
  27. '==================================================
  28. '函数名:BytesToBstr
  29. '作 用:将获取的源码转换为中文
  30. '参 数:Body ------要转换的变量
  31. '参 数:Cset ------要转换的类型
  32. '==================================================
  33. Function BytesToBstr(Body,Cset)
  34. Dim Objstream
  35. Set Objstream = Server.CreateObject("adodb.stream")
  36. objstream.Type = 1
  37. objstream.Mode =3
  38. objstream.Open
  39. objstream.Write body
  40. objstream.Position = 0
  41. objstream.Type = 2
  42. objstream.Charset = Cset
  43. BytesToBstr = objstream.ReadText 
  44. objstream.Close
  45. set objstream = nothing
  46. End Function
  47. '==================================================
  48. '函数名:PostHttpPage
  49. '作 用:登录
  50. '==================================================
  51. Function PostHttpPage(RefererUrl,PostUrl,PostData) 
  52. Dim xmlHttp 
  53. Dim RetStr 
  54. Set xmlHttp = CreateObject("Msxml2.XMLHTTP"
  55. 'Set xmlHttp = CreateObject("WinHTTP.WinHTTPRequest.5.1")
  56. xmlHttp.Open "POST", PostUrl, true
  57. XmlHTTP.setRequestHeader "Content-Length",Len(PostData) 
  58. xmlHttp.setRequestHeader "Content-Type""application/x-www-form-urlencoded"
  59. xmlHttp.setRequestHeader "Referer", RefererUrl
  60. xmlHttp.Send PostData 
  61. If Err.Number <> 0 Then 
  62. Set xmlHttp=Nothing
  63. PostHttpPage = "$False$"
  64. Exit Function
  65. End If
  66. 'PostHttpPage=bytesToBSTR(xmlHttp.responseBody,"GB2312")
  67. Set xmlHttp = nothing
  68. End Function
  69. '==================================================
  70. '函数名:UrlEncoding
  71. '作 用:转换编码
  72. '==================================================
  73. Function UrlEncoding(DataStr)
  74. Dim StrReturn,Si,ThisChr,InnerCode,Hight8,Low8
  75. StrReturn = ""
  76. For Si = 1 To Len(DataStr)
  77. ThisChr = Mid(DataStr,Si,1)
  78. If Abs(Asc(ThisChr)) < &HFF Then
  79. StrReturn = StrReturn & ThisChr
  80. Else
  81. InnerCode = Asc(ThisChr)
  82. If InnerCode < 0 Then
  83. InnerCode = InnerCode + &H10000
  84. End If
  85. Hight8 = (InnerCode And &HFF00)/ &HFF
  86. Low8 = InnerCode And &HFF
  87. StrReturn = StrReturn & "%" & Hex(Hight8) & "%" & Hex(Low8)
  88. End If
  89. Next
  90. UrlEncoding = StrReturn
  91. End Function
  92. '==================================================
  93. '函数名:GetBody
  94. '作 用:截取字符串
  95. '参 数:ConStr ------将要截取的字符串
  96. '参 数:StartStr ------开始字符串
  97. '参 数:OverStr ------结束字符串
  98. '参 数:IncluL ------是否包含StartStr
  99. '参 数:IncluR ------是否包含OverStr
  100. '==================================================
  101. Function GetBody(ConStr,StartStr,OverStr,IncluL,IncluR)
  102. If ConStr="$False$" or ConStr="" or IsNull(ConStr)=True Or StartStr="" or IsNull(StartStr)=True Or OverStr="" or IsNull(OverStr)=True Then
  103. GetBody="$False$"
  104. Exit Function
  105. End If
  106. Dim ConStrTemp
  107. Dim Start,Over
  108. ConStrTemp=Lcase(ConStr)
  109. StartStr=Lcase(StartStr)
  110. OverStr=Lcase(OverStr)
  111. Start = InStrB(1, ConStrTemp, StartStr, vbBinaryCompare)
  112. If Start<=0 then
  113. GetBody="$False$"
  114. Exit Function
  115. Else
  116. If IncluL=False Then
  117. Start=Start+LenB(StartStr)
  118. End If
  119. End If
  120. Over=InStrB(Start,ConStrTemp,OverStr,vbBinaryCompare)
  121. If Over<=0 Or Over<=Start then
  122. GetBody="$False$"
  123. Exit Function
  124. Else
  125. If IncluR=True Then
  126. Over=Over+LenB(OverStr)
  127. End If
  128. End If
  129. GetBody=MidB(ConStr,Start,Over-Start)
  130. End Function
  131. '==================================================
  132. '函数名:GetArray
  133. '作 用:提取链接地址,以$Array$分隔
  134. '参 数:ConStr ------提取地址的原字符
  135. '参 数:StartStr ------开始字符串
  136. '参 数:OverStr ------结束字符串
  137. '参 数:IncluL ------是否包含StartStr
  138. '参 数:IncluR ------是否包含OverStr
  139. '==================================================
  140. Function GetArray(Byval ConStr,StartStr,OverStr,IncluL,IncluR)
  141. If ConStr="$False$" or ConStr="" Or IsNull(ConStr)=True or StartStr="" Or OverStr="" or IsNull(StartStr)=True Or IsNull(OverStr)=True Then
  142. GetArray="$False$"
  143. Exit Function
  144. End If
  145. Dim TempStr,TempStr2,objRegExp,Matches,Match
  146. TempStr=""
  147. Set objRegExp = New Regexp 
  148. objRegExp.IgnoreCase = True 
  149. objRegExp.Global = True
  150. objRegExp.Pattern = "("&StartStr&").+?("&OverStr&")"
  151. Set Matches =objRegExp.Execute(ConStr) 
  152. For Each Match in Matches
  153. TempStr=TempStr & "$Array$" & Match.Value
  154. Next 
  155. Set Matches=nothing
  156. If TempStr="" Then
  157. GetArray="$False$"
  158. Exit Function
  159. End If
  160. TempStr=Right(TempStr,Len(TempStr)-7)
  161. If IncluL=False then
  162. objRegExp.Pattern =StartStr
  163. TempStr=objRegExp.Replace(TempStr,"")
  164. End if
  165. If IncluR=False then
  166. objRegExp.Pattern =OverStr
  167. TempStr=objRegExp.Replace(TempStr,"")
  168. End if
  169. Set objRegExp=nothing
  170. TempStr=Replace(TempStr,"""","")
  171. TempStr=Replace(TempStr,"'","")
  172. TempStr=Replace(TempStr," ","")
  173. If TempStr="" then
  174. GetArray="$False$"
  175. Else
  176. GetArray=TempStr
  177. End if
  178. End Function
  179. '==================================================
  180. '函数名:DefiniteUrl
  181. '作 用:将相对地址转换为绝对地址
  182. '参 数:PrimitiveUrl ------要转换的相对地址
  183. '参 数:ConsultUrl ------当前网页地址
  184. '==================================================
  185. Function DefiniteUrl(Byval PrimitiveUrl,Byval ConsultUrl)
  186. Dim ConTemp,PriTemp,Pi,Ci,PriArray,ConArray
  187. If PrimitiveUrl="" or ConsultUrl="" or PrimitiveUrl="$False$" or ConsultUrl="$False$" Then
  188. DefiniteUrl="$False$"
  189. Exit Function
  190. End If
  191. If Left(Lcase(ConsultUrl),7)<>"http://" Then
  192. ConsultUrl= "http://" & ConsultUrl
  193. End If
  194. ConsultUrl=Replace(ConsultUrl,"/","/")
  195. ConsultUrl=Replace(ConsultUrl,"://","://")
  196. PrimitiveUrl=Replace(PrimitiveUrl,"/","/")
  197. If Right(ConsultUrl,1)<>"/" Then
  198. If Instr(ConsultUrl,"/")>0 Then
  199. If Instr(Right(ConsultUrl,Len(ConsultUrl)-InstrRev(ConsultUrl,"/")),".")>0 then 
  200. Else
  201. ConsultUrl=ConsultUrl & "/"
  202. End If
  203. Else
  204. ConsultUrl=ConsultUrl & "/"
  205. End If
  206. End If
  207. ConArray=Split(ConsultUrl,"/")
  208. If Left(LCase(PrimitiveUrl),7) = "http://" then
  209. DefiniteUrl=Replace(PrimitiveUrl,"://","://")
  210. ElseIf Left(PrimitiveUrl,1) = "/" Then
  211. DefiniteUrl=ConArray(0) & PrimitiveUrl
  212. ElseIf Left(PrimitiveUrl,2)="./" Then
  213. PrimitiveUrl=Right(PrimitiveUrl,Len(PrimitiveUrl)-2)
  214. If Right(ConsultUrl,1)="/" Then 
  215. DefiniteUrl=ConsultUrl & PrimitiveUrl
  216. Else
  217. DefiniteUrl=Left(ConsultUrl,InstrRev(ConsultUrl,"/")) & PrimitiveUrl
  218. End If
  219. ElseIf Left(PrimitiveUrl,3)="../" then
  220. Do While Left(PrimitiveUrl,3)="../"
  221. PrimitiveUrl=Right(PrimitiveUrl,Len(PrimitiveUrl)-3)
  222. Pi=Pi+1
  223. Loop 
  224. For Ci=0 to (Ubound(ConArray)-1-Pi)
  225. If DefiniteUrl<>"" Then
  226. DefiniteUrl=DefiniteUrl & "/" & ConArray(Ci)
  227. Else
  228. DefiniteUrl=ConArray(Ci)
  229. End If
  230. Next
  231. DefiniteUrl=DefiniteUrl & "/" & PrimitiveUrl
  232. Else
  233. If Instr(PrimitiveUrl,"/")>0 Then
  234. PriArray=Split(PrimitiveUrl,"/")
  235. If Instr(PriArray(0),".")>0 Then
  236. If Right(PrimitiveUrl,1)="/" Then
  237. DefiniteUrl="http://" & PrimitiveUrl
  238. Else
  239. If Instr(PriArray(Ubound(PriArray)-1),".")>0 Then 
  240. DefiniteUrl="http://" & PrimitiveUrl
  241. Else
  242. DefiniteUrl="http://" & PrimitiveUrl & "/"
  243. End If
  244. End If 
  245. Else
  246. If Right(ConsultUrl,1)="/" Then 
  247. DefiniteUrl=ConsultUrl & PrimitiveUrl
  248. Else
  249. DefiniteUrl=Left(ConsultUrl,InstrRev(ConsultUrl,"/")) & PrimitiveUrl
  250. End If
  251. End If
  252. Else
  253. If Instr(PrimitiveUrl,".")>0 Then
  254. If Right(ConsultUrl,1)="/" Then
  255. If right(LCase(PrimitiveUrl),3)=".cn" or right(LCase(PrimitiveUrl),3)="com" or right(LCase(PrimitiveUrl),3)="net" or right(LCase(PrimitiveUrl),3)="org" Then
  256. DefiniteUrl="http://" & PrimitiveUrl & "/"
  257. Else
  258. DefiniteUrl=ConsultUrl & PrimitiveUrl
  259. End If
  260. Else
  261. If right(LCase(PrimitiveUrl),3)=".cn" or right(LCase(PrimitiveUrl),3)="com" or right(LCase(PrimitiveUrl),3)="net" or right(LCase(PrimitiveUrl),3)="org" Then
  262. DefiniteUrl="http://" & PrimitiveUrl & "/"
  263. Else
  264. DefiniteUrl=Left(ConsultUrl,InstrRev(ConsultUrl,"/")) & "/" & PrimitiveUrl
  265. End If
  266. End If
  267. Else
  268. If Right(ConsultUrl,1)="/" Then
  269. DefiniteUrl=ConsultUrl & PrimitiveUrl & "/"
  270. Else
  271. DefiniteUrl=Left(ConsultUrl,InstrRev(ConsultUrl,"/")) & "/" & PrimitiveUrl & "/"
  272. End If 
  273. End If
  274. End If
  275. End If
  276. If Left(DefiniteUrl,1)="/" then
  277. DefiniteUrl=Right(DefiniteUrl,Len(DefiniteUrl)-1)
  278. End if
  279. If DefiniteUrl<>"" Then
  280. DefiniteUrl=Replace(DefiniteUrl,"//","/")
  281. DefiniteUrl=Replace(DefiniteUrl,"://","://")
  282. Else
  283. DefiniteUrl="$False$"
  284. End If
  285. End Function
  286. '==================================================
  287. '函数名:ReplaceSaveRemoteFile
  288. '作 用:替换、保存远程图片
  289. '参 数:ConStr ------ 要替换的字符串
  290. '参 数:SaveTf ------ 是否保存文件,False不保存,True保存
  291. '参 数: TistUrl------ 当前网页地址
  292. '==================================================
  293. Function ReplaceSaveRemoteFile(ConStr,strInstallDir,strChannelDir,SaveTf,TistUrl)
  294. If ConStr="$False$" or ConStr="" or strInstallDir="" or strChannelDir="" Then
  295. ReplaceSaveRemoteFile=ConStr
  296. Exit Function
  297. End If
  298. Dim TempStr,TempStr2,TempStr3,Re,Matches,Match,Tempi,TempArray,TempArray2
  299. Dim Start1,Start2
  300. Set Re = New Regexp 
  301. Re.IgnoreCase = True 
  302. Re.Global = True
  303. Re.Pattern ="<img.+?[^/>]>"
  304. Set Matches =Re.Execute(ConStr) 
  305. For Each Match in Matches
  306. If TempStr<>"" then 
  307. TempStr=TempStr & "$Array$" & Match.Value
  308. Else
  309. TempStr=Match.Value
  310. End if
  311. Next
  312. If TempStr<>"" Then
  313. TempArray=Split(TempStr,"$Array$")
  314. TempStr=""
  315. For Tempi=0 To Ubound(TempArray)
  316. Re.Pattern ="src/s*=/s*.+?/.(gif|jpg|bmp|jpeg|psd|png|svg|dxf|wmf|tiff)"
  317. Set Matches =Re.Execute(TempArray(Tempi)) 
  318. For Each Match in Matches
  319. If TempStr<>"" then 
  320. TempStr=TempStr & "$Array$" & Match.Value
  321. Else
  322. TempStr=Match.Value
  323. End if
  324. Next
  325. Next
  326. End if
  327. If TempStr<>"" Then
  328. Re.Pattern ="src/s*=/s*"
  329. TempStr=Re.Replace(TempStr,"")
  330. End If
  331. Set Matches=nothing
  332. Set Re=nothing
  333. If TempStr="" or IsNull(TempStr)=True Then
  334. ReplaceSaveRemoteFile=ConStr
  335. Exit function
  336. End if
  337. TempStr=Replace(TempStr,"""","")
  338. TempStr=Replace(TempStr,"'","")
  339. TempStr=Replace(TempStr," ","")
  340. Dim RemoteFileurl,SavePath,PathTemp,DtNow,strFileName,strFileType,ArrSaveFileName,RanNum,Arr_Path
  341. DtNow=Now()
  342. If SaveTf=True then
  343. SavePath=strInstallDir & strChannelDir & "/UploadFiles/" & year(DtNow) & right("0" & month(DtNow),2) & "/"
  344. Arr_Path=Split(SavePath,"/")
  345. PathTemp=""
  346. For Tempi=0 To Ubound(Arr_Path)
  347. If Tempi=0 Then
  348. PathTemp=Arr_Path(0) & "/"
  349. ElseIf Tempi=Ubound(Arr_Path) Then
  350. Exit For
  351. Else
  352. PathTemp=PathTemp & Arr_Path(Tempi) & "/"
  353. End If
  354. If CheckDir(PathTemp)=False Then
  355. If MakeNewsDir(PathTemp)=False Then
  356. SaveTf=False
  357. Exit For
  358. End If
  359. End If
  360. Next
  361. End If
  362. '去掉重复图片开始
  363. TempArray=Split(TempStr,"$Array$")
  364. TempStr=""
  365. For Tempi=0 To Ubound(TempArray)
  366. If Instr(Lcase(TempStr),Lcase(TempArray(Tempi)))<1 Then
  367. TempStr=TempStr & "$Array$" & TempArray(Tempi)
  368. End If
  369. Next
  370. TempStr=Right(TempStr,Len(TempStr)-7)
  371. TempArray=Split(TempStr,"$Array$")
  372. '去掉重复图片结束
  373. '转换相对图片地址开始
  374. TempStr=""
  375. For Tempi=0 To Ubound(TempArray)
  376. TempStr=TempStr & "$Array$" & DefiniteUrl(TempArray(Tempi),TistUrl)
  377. Next
  378. TempStr=Right(TempStr,Len(TempStr)-7)
  379. TempStr=Replace(TempStr,Chr(0),"")
  380. TempArray2=Split(TempStr,"$Array$")
  381. TempStr=""
  382. '转换相对图片地址结束
  383. '图片替换/保存
  384. Set Re = New Regexp
  385. Re.IgnoreCase = True 
  386. Re.Global = True
  387. For Tempi=0 To Ubound(TempArray2)
  388. RemoteFileUrl=TempArray2(Tempi)
  389. If RemoteFileUrl<>"$False$" And SaveTf=True Then'保存图片
  390. ArrSaveFileName = Split(RemoteFileurl,".")
  391.    strFileType=Lcase(ArrSaveFileName(Ubound(ArrSaveFileName)))'文件类型
  392. If strFileType="asp" or strFileType="asa" or strFileType="aspx" or strFileType="cer" or strFileType="cdx" or strFileType="exe" or strFileType="rar" or strFileType="zip" then
  393. UploadFiles=""
  394. ReplaceSaveRemoteFile=ConStr
  395. Exit Function
  396. End If
  397. Randomize
  398. RanNum=Int(900*Rnd)+100
  399.    strFileName = year(DtNow) & right("0" & month(DtNow),2) & right("0" & day(DtNow),2) & right("0" & hour(DtNow),2) & right("0" & minute(DtNow),2) & right("0" & second(DtNow),2) & ranNum & "." & strFileType
  400. Re.Pattern =TempArray(Tempi)
  401.    If SaveRemoteFile(SavePath & strFileName,RemoteFileUrl)=True Then
  402. PathTemp=Replace(SavePath &strFileName,strInstallDir & strChannelDir & "/","[InstallDir_ChannelDir]")
  403. ConStr=Re.Replace(ConStr,PathTemp)
  404. Re.Pattern=strInstallDir & strChannelDir & "/"
  405. UploadFiles=UploadFiles & "|" & Re.Replace(SavePath &strFileName,"")
  406. Else
  407. PathTemp=RemoteFileUrl
  408. ConStr=Re.Replace(ConStr,PathTemp)
  409. 'UploadFiles=UploadFiles & "|" & RemoteFileUrl
  410. End If
  411. ElseIf RemoteFileurl<>"$False$" and SaveTf=False Then'不保存图片
  412. Re.Pattern =TempArray(Tempi)
  413. ConStr=Re.Replace(ConStr,RemoteFileUrl)
  414. UploadFiles=UploadFiles & "|" & RemoteFileUrl
  415. End If
  416. Next 
  417. Set Re=nothing
  418. If UploadFiles<>"" Then
  419. UploadFiles=Right(UploadFiles,Len(UploadFiles)-1)
  420. End If
  421. ReplaceSaveRemoteFile=ConStr
  422. End function
  423. '==================================================
  424. '过程名:SaveRemoteFile
  425. '作 用:保存远程的文件到本地
  426. '参 数:LocalFileName ------ 本地文件名
  427. '参 数:RemoteFileUrl ------ 远程文件URL
  428. '==================================================
  429. Function SaveRemoteFile(LocalFileName,RemoteFileUrl)
  430. On error resume next
  431. SaveRemoteFile=True
  432.   dim Ads,Retrieval,GetRemoteData
  433.   Set Retrieval = Server.CreateObject("Microsoft.XMLHTTP")
  434.   With Retrieval
  435.     .Open "Get", RemoteFileUrl, False""""
  436.     .Send
  437. If .Readystate<>4 then
  438. SaveRemoteFile=False
  439. Exit Function
  440. End If
  441.     GetRemoteData = .ResponseBody
  442.   End With
  443.   Set Retrieval = Nothing
  444.   Set Ads = Server.CreateObject("Adodb.Stream")
  445.   With Ads
  446.     .Type = 1
  447.     .Open
  448.     .Write GetRemoteData
  449.     .SaveToFile server.MapPath(LocalFileName),2
  450.     .Cancel()
  451.     .Close()
  452.   End With
  453.   Set Ads=nothing
  454. end Function
  455. '==================================================
  456. '函数名:FpHtmlEnCode
  457. '作 用:标题过滤
  458. '参 数:fString ------字符串
  459. '==================================================
  460. Function FpHtmlEnCode(fString)
  461. If IsNull(fString)=False or fString<>"" or fString<>"$False$" Then
  462. fString=nohtml(fString)
  463. fString=FilterJS(fString)
  464. fString = Replace(fString, CHR(9), "")
  465. fString = Replace(fString, CHR(34), "")
  466. fString = Replace(fString, CHR(39), "")
  467. fString = Replace(fString, CHR(13), "")
  468. fString = Replace(fString, CHR(10), " ")
  469. fString=Trim(fString)
  470. fString=dvhtmlencode(fString)
  471. FpHtmlEnCode=fString
  472. Else
  473. FpHtmlEnCode="$False$"
  474. End If
  475. End Function
  476. '==================================================
  477. '函数名:GetPaing
  478. '作 用:获取分页
  479. '==================================================
  480. Function GetPaing(Byval ConStr,StartStr,OverStr,IncluL,IncluR)
  481. If ConStr="$False$" or ConStr="" Or StartStr="" Or OverStr="" or IsNull(ConStr)=True or IsNull(StartStr)=True Or IsNull(OverStr)=True Then
  482. GetPaing="$False$"
  483. Exit Function
  484. End If
  485. Dim Start,Over,ConTemp,Erri
  486. ConStr=LCase(ConStr)
  487. StartStr=LCase(StartStr)
  488. OverStr=LCase(OverStr)
  489. Over=InstrB(1,ConStr,OverStr,vbBinaryCompare)
  490. If Over<=0 Then
  491. GetPaing="$False$"
  492. Exit Function
  493. Else
  494. Over=Over+Lenb(OverStr)
  495. End If
  496. Start=Over-5
  497. If Start<=0 Then
  498. GetPaing="$False$"
  499. Exit Function
  500. End If
  501. ConTemp=MidB(ConStr,Start,Over-Start)
  502. Do While InstrB(1,ConTemp,StartStr,vbBinaryCompare)<=0
  503. Erri=Erri+1
  504. If Erri>50 then
  505. GetPaing="$False$"
  506. Exit Function
  507. End If 
  508. Start=Start-5
  509. if Start<=0 then
  510. GetPaing="$False$"
  511. Exit Do
  512. Exit Function
  513. Else
  514. ConTemp=MidB(ConStr,Start,Over-Start)
  515. End If
  516. Loop
  517. Start=InstrB(1,ConTemp,StartStr,vbBinaryCompare)
  518. If IncluL=False Then
  519. Start=Start+LenB(StartStr)
  520. End If
  521. Over=InstrB(Start,ConTemp,OverStr,vbBinaryCompare)
  522. If IncluR=True Then
  523. Over=Over+LenB(OverStr)
  524. End If
  525. If Start>=Over then
  526. GetPaing="$False$"
  527. Exit Function
  528. End If
  529. GetPaing=MidB(ConTemp,Start,Over-Start)
  530. GetPaing=Trim(GetPaing)
  531. GetPaing=Replace(GetPaing," ","")
  532. GetPaing=Replace(GetPaing,",","")
  533. GetPaing=Replace(GetPaing,"'","")
  534. GetPaing=Replace(GetPaing,"""","")
  535. GetPaing=Replace(GetPaing,">","")
  536. GetPaing=Replace(GetPaing,"<","")
  537. End Function
  538. '==================================================
  539. '函数名:ScriptHtml
  540. '作 用:过滤html标记
  541. '参 数:ConStr ------ 要过滤的字符串
  542. '==================================================
  543. Function ScriptHtml(Byval ConStr,TagName,FType)
  544. Dim Re
  545. Set Re=new RegExp
  546. Re.IgnoreCase =true
  547. Re.Global=True
  548. Select Case FType
  549. Case 1
  550. Re.Pattern="<" & TagName & "([^>])*>"
  551. ConStr=Re.Replace(ConStr,"")
  552. Case 2
  553. Re.Pattern="<" & TagName & "([^>])*>.*?</" & TagName & "([^>])*>"
  554. ConStr=Re.Replace(ConStr,"")
  555. Case 3
  556. Re.Pattern="<" & TagName & "([^>])*>"
  557. ConStr=Re.Replace(ConStr,"")
  558. Re.Pattern="</" & TagName & "([^>])*>"
  559. ConStr=Re.Replace(ConStr,"")
  560. End Select
  561. ScriptHtml=ConStr
  562. Set Re=Nothing
  563. End Function
  564. Function CheckDir(byval FolderPath)
  565.   dim fso
  566.   Set fso = Server.CreateObject("Scripting.FileSystemObject")
  567.   If fso.FolderExists(Server.MapPath(folderpath)) then
  568.   '存在
  569.     CheckDir = True
  570.   Else
  571.   '不存在
  572.     CheckDir = False
  573.   End if
  574.   Set fso = nothing
  575. End Function
  576. Function MakeNewsDir(byval foldername)
  577.   dim fso
  578.   Set fso = Server.CreateObject("Scripting.FileSystemObject")
  579. fso.CreateFolder(Server.MapPath(foldername))
  580. If fso.FolderExists(Server.MapPath(foldername)) Then
  581. MakeNewsDir = True
  582. Else
  583. MakeNewsDir = False
  584. End If
  585.   Set fso = nothing
  586. End Function
  587. '**************************************************
  588. '函数名:IsObjInstalled
  589. '作 用:检查组件是否已经安装
  590. '参 数:strClassString ----组件名
  591. '返回值:True ----已经安装
  592. ' False ----没有安装
  593. '**************************************************
  594. Function IsObjInstalled(strClassString)
  595.   On Error Resume Next
  596.   IsObjInstalled = False
  597.   Err = 0
  598.   Dim xTestObj
  599.   Set xTestObj = Server.CreateObject(strClassString)
  600.   If 0 = Err Then IsObjInstalled = True
  601.   Set xTestObj = Nothing
  602.   Err = 0
  603. End Function
  604. '**************************************************
  605. '过程名:WriteErrMsg
  606. '作 用:显示错误提示信息
  607. '参 数:无
  608. '**************************************************
  609. sub WriteErrMsg(ErrMsg)
  610.   dim strErr
  611.   strErr=strErr & "<html><head><title>错误信息</title><meta http-equiv='Content-Type' content='text/html; charset=gb2312'>" & vbcrlf
  612.   strErr=strErr & "<link href='../admin/Admin_STYLE.CSS' rel='stylesheet' type='text/css'></head><body><br><br>" & vbcrlf
  613.   strErr=strErr & "<table cellpadding=2 cellspacing=1 border=0 width=400 class='border' align=center>" & vbcrlf
  614.   strErr=strErr & " <tr align='center' class='title'><td height='22'><strong>错误信息</strong></td></tr>" & vbcrlf
  615.   strErr=strErr & " <tr class='tdbg'><td height='100' valign='top'><b>产生错误的可能原因:</b>" & ErrMsg &"</td></tr>" & vbcrlf
  616.   strErr=strErr & " <tr align='center' class='tdbg'><td><a href='javascript:history.go(-1)'><< 返回上一页</a></td></tr>" & vbcrlf
  617.   strErr=strErr & "</table>" & vbcrlf
  618.   strErr=strErr & "</body></html>" & vbcrlf
  619.   response.write strErr
  620. end sub
  621. '**************************************************
  622. '过程名:WriteSucced
  623. '作 用:显示成功提示信息
  624. '参 数:无
  625. '**************************************************
  626. sub WriteSucced(ErrMsg)
  627.   dim strErr
  628.   strErr=strErr & "<html><head><title>成功信息</title><meta http-equiv='Content-Type' content='text/html; charset=gb2312'>" & vbcrlf
  629.   strErr=strErr & "<link href='../admin/Admin_STYLE.CSS' rel='stylesheet' type='text/css'></head><body><br><br>" & vbcrlf
  630.   strErr=strErr & "<table cellpadding=2 cellspacing=1 border=0 width=400 class='border' align=center>" & vbcrlf
  631.   strErr=strErr & " <tr align='center' class='title'><td height='22'><strong>恭喜你!</strong></td></tr>" & vbcrlf
  632.   strErr=strErr & " <tr class='tdbg'><td height='100' valign='top' align='center'>" & ErrMsg &"</td></tr>" & vbcrlf
  633.   'strErr=strErr & " <tr align='center' class='tdbg'><td><a href='javascript:history.go(-1)'><< 返回上一页</a></td></tr>" & vbcrlf
  634.   strErr=strErr & "</table>" & vbcrlf
  635.   strErr=strErr & "</body></html>" & vbcrlf
  636.   response.write strErr
  637. end sub
  638. '**************************************************
  639. '函数名:ShowPage
  640. '作 用:显示“上一页 下一页”等信息
  641. '参 数:sFileName ----链接地址
  642. ' TotalNumber ----总数量
  643. ' MaxPerPage ----每页数量
  644. ' ShowTotal ----是否显示总数量
  645. ' ShowAllPages ---是否用下拉列表显示所有页面以供跳转。有某些页面不能使用,否则会出现JS错误。
  646. ' strUnit ----计数单位
  647. '返回值:“上一页 下一页”等信息的HTML代码
  648. '**************************************************
  649. function ShowPage(sFileName,TotalNumber,MaxPerPage,ShowTotal,ShowAllPages,strUnit)
  650.   dim TotalPage,strTemp,strUrl,i
  651.   if TotalNumber=0 or MaxPerPage=0 or isNull(MaxPerPage) then
  652.     ShowPage=""
  653.     exit function
  654.   end if
  655.   if totalnumber mod maxperpage=0 then
  656.   TotalPage= totalnumber / maxperpage
  657.   else
  658.   TotalPage= totalnumber / maxperpage+1
  659.   end if
  660.   if CurrentPage>TotalPage then CurrentPage=TotalPage
  661.     
  662.   strTemp= "<table align='center'><tr><td>"
  663.   if ShowTotal=true then 
  664.     strTemp=strTemp & "共 <b>" & totalnumber & "</b> " & strUnit & "  "
  665.   end if
  666.   strUrl=JoinChar(sfilename)
  667.   if CurrentPage<2 then
  668.   strTemp=strTemp & "首页 上一页 "
  669.   else
  670.   strTemp=strTemp & "<a href='" & strUrl & "page=1'>首页</a> "
  671.   strTemp=strTemp & "<a href='" & strUrl & "page=" & (CurrentPage-1) & "'>上一页</a> "
  672.   end if
  673.   if CurrentPage>=TotalPage then
  674.   strTemp=strTemp & "下一页 尾页"
  675.   else
  676.   strTemp=strTemp & "<a href='" & strUrl & "page=" & (CurrentPage+1) & "'>下一页</a> "
  677.   strTemp=strTemp & "<a href='" & strUrl & "page=" & TotalPage & "'>尾页</a>"
  678.   end if
  679.   strTemp=strTemp & " 页次:<strong><font color=red>" & CurrentPage & "</font>/" & TotalPage & "</strong>页 "
  680. strTemp=strTemp & " <b>" & maxperpage & "</b>" & strUnit & "/页"
  681.   if ShowAllPages=True then
  682.     strTemp=strTemp & "  转到第<input type='text' name='page' size='3' maxlength='5' value='" & CurrentPage & "' onKeyPress=""if (event.keyCode==13) window.location='" & strUrl & "page=" & "'+this.value;""'>页"
  683.   end if
  684.   strTemp=strTemp & "</td></tr></table>"
  685.   ShowPage=strTemp
  686. end function
  687. '**************************************************
  688. '函数名:JoinChar
  689. '作 用:向地址中加入 ? 或 &
  690. '参 数:strUrl ----网址
  691. '返回值:加了 ? 或 & 的网址
  692. '**************************************************
  693. function JoinChar(strUrl)
  694.   if strUrl="" then
  695.     JoinChar=""
  696.     exit function
  697.   end if
  698.   if InStr(strUrl,"?")<len(strUrl) then 
  699.     if InStr(strUrl,"?")>1 then
  700.       if InStr(strUrl,"&")<len(strUrl) then 
  701.         JoinChar=strUrl & "&"
  702.       else
  703.         JoinChar=strUrl
  704.       end if
  705.     else
  706.       JoinChar=strUrl & "?"
  707.     end if
  708.   else
  709.     JoinChar=strUrl
  710.   end if
  711. end function
  712. '**************************************************
  713. '函数名:CreateKeyWord
  714. '作 用:由给定的字符串生成关键字
  715. '参 数:Constr---要生成关键字的原字符串
  716. '返回值:生成的关键字
  717. '**************************************************
  718. Function CreateKeyWord(byval Constr)
  719. If Constr="" or IsNull(Constr)=True or Constr="$False$" Then
  720. CreateKeyWord="$False$"
  721. Exit Function
  722. End If
  723. Constr=Replace(Constr,CHR(32),"")
  724. Constr=Replace(Constr,CHR(9),"")
  725. Constr=Replace(Constr," ","")
  726. Constr=Replace(Constr," ","")
  727. Constr=Replace(Constr,"(","")
  728. Constr=Replace(Constr,")","")
  729. Constr=Replace(Constr,"<","")
  730. Constr=Replace(Constr,">","")
  731. Dim i,ConstrTemp
  732. For i=1 To Len(Constr)
  733. ConstrTemp=ConstrTemp & "|" & Mid(Constr,i,2)
  734. Next
  735. If Len(ConstrTemp)<254 Then
  736. ConstrTemp=ConstrTemp & "|"
  737. Else
  738. ConstrTemp=Left(ConstrTemp,254) & "|"
  739. End If
  740. CreateKeyWord=ConstrTemp
  741. End Function
  742. Function CheckUrl(strUrl)
  743. Dim Re
  744. Set Re=new RegExp
  745. Re.IgnoreCase =true
  746. Re.Global=True
  747. Re.Pattern="http://([/w-]+/.)+[/w-]+(/[/w-./?%&=]*)?"
  748. If Re.test(strUrl)=True Then
  749. CheckUrl=strUrl
  750. Else
  751. CheckUrl="$False$"
  752. End If
  753. Set Rs=Nothing
  754. End Function
  755. %>

 

 暂无标签
正在读取日志的评论数据,请稍后……
正在加载日志评论签写框,请稍后……
 成员登录通道
正在载入成员登录通道...
 BLOG 日历助手
正在载入日历助手...
 BLOG 统计信息
正在载入统计信息...
 BLOG 日志归档
 BLOG 推荐日志
  • 暂时没有推荐日志
 BLOG 最新评论
{$SideComment}
 BLOG 最新留言
{$SideGB}
 BLOG 站内搜索

Tags Cloud: