注册 登录
编程论坛 ASP技术论坛

asp函数持续更新中,大家一起来吧。辛苦了。

ysf0181 发布于 2012-07-23 11:24, 1342 次点击
<%
'以下是接口的例子及函数
Response.Clear   
On Error Resume Next   
response.Buffer=false   
err.clear   
server.ScriptTimeout=9999999   
   
'执行模块,整个程序的流程。由上至下的走..先看GetResStr(URL) 他首先打开网页.然后将网站的html下载回来后.   
'然后再用正则表达来处理你需要的值。而这里演示的是直接取得他的标题..   
'最后将值转换一下。然后输出到浏览器。。整个流程就如此了   
dim reg,vUrl,pUrl,VBody,title   
vUrl="http://www.baidu.com" '更换网站地址   
reg="\<meta.+ charset= {0,}([^\"" \>\/]*).+\/{0,1}\>"   
   if vUrl<>"" then  '取得网站标题   
       VBody=GetResStr(vUrl)   
       title=GetCode(VBody,"\<title\>(.*)\<\/title\>")   
   else   
       vUrl="地址取不到"   
   end if   
   if err.number<>0 then   
      response.write "标题出错"   
   else   
      if title<>"" then   
        response.write title   
      else   
        response.write "标题为空"   
       end if   
   end if   
response.End()   
   
   
'函数名:GetResStr   
'作用:获取指定URL的HTML代码   
'参数:URL-要获取的URL   
function GetResStr(URL)   
err.clear   
dim ResBody,ResStr,PageCode,ReturnStr   
Set Http=server.createobject("msxml2.serverxmlhttp.3.0") '先创建一个serverxmlhttp对像.并指明他是3.0版本的..可以省去   
Http.setTimeouts 10000, 10000, 10000, 10000 '设置超时时间   
Http.open "GET",URL,False '以上已设置后。就打开网址。参数1:提交方式,url地址,异步执行 一般选择异步执行   
Http.Send() '调用Send方法发送XML数据   
If Http.Readystate =4 Then '文档已经解析完毕,客户端可以接受返回消息   
  If Http.status=200 Then '接收返回的错误   
     ResStr=http.responseText '接收返回的信息..(源代码一般)   
     ResBody=http.responseBody '以html方式返回消息   
     PageCode=GetCode(ResStr,reg) '用正则表达式。将网站返回的title值进行匹配。如果有就返回。。否则返回gbk2312   
     ReturnStr=BytesToBstr(http.responseBody,PageCode) '需要将其转换一下..   
     GetResStr=ReturnStr '返回值   
  End If   
End If   
End Function   
   
   
'函数名:BytesToBstr   
'作用:转换二进制数据为字符   
'参数:Body-二进制数据,Cset-文本编码方式   
Function BytesToBstr(Body,Cset)   
  Dim Objstream   
  Set Objstream = Server.CreateObject("adodb.stream") '创建一个字符流....   
   objstream.Type = 1  '返回的数据类型 adTypeBinary   =1 adTypeText   =2   
   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   
   
'函数名:GetCode   
'作用:转换二进制为字符   
'参数:str-待查询字符串,regstr-正则表达式   
Function GetCode(str,regstr)   
Dim Reg,serStr   
set Reg= new RegExp '先创建一个正则表达式..   
Reg.IgnoreCase = True '设置是否区分字符大小写   
Reg.MultiLine = True  '多行方式保存   
Reg.Pattern =regstr '查找html中有没有 \<meta.+ charset= {0,}([^\"" \>\/]*).+\/{0,1}\> 匹配   
if Reg.test(str) then '若查询到匹配项   
   Set Cols = Reg.Execute(str)   
    serStr=Cols(0).SubMatches(0) '使用匹配到的第一个匹配项   
else '否则给个默认值gb2312,有点省懒法,如果页面没给出编码格式,想知道确实有点麻烦   
    serStr="gb2312"   
end if   
GetCode=serStr   
end function   


%>

[ 本帖最后由 ysf0181 于 2012-7-23 11:27 编辑 ]
17 回复
#2
ysf01812012-07-23 11:47
dim myHttp
set myHttp=new xhttp
myHttp.URL=http://www.
Response.Write(myHttp.html)

'保存远程图片到本地
myHttp.URL="http://www.baidu.com/page/asp.gif"
myHttp.saveimage="myfile.gif"
'为防止xhttp卡死的情况,使用超时,错误处理
dim sHtmlcode,iStep
myHttp.URL="http://www. "
sHtmlcode=myHttp.html
do while myHttp.xhttpError=""
Response.Error("ERROR: AGAIN!<br />")
sHtmlcode=myHttp.html
iStep=iStep+1
if iStep>100 then
Response.Write("ERROR:OVER!<hr />")
exit do
end if
loop
Response.Write(sHtmlcode)

set myHttp=nothing
'--------------------------------------------------------------------
Class xhttp
private cset,sUrl,sError
Private Sub Class_Initialize()
'cset="UTF-8"
cset="GB2312"
sError=""
end sub

Private Sub Class_Terminate()
End Sub

Public Property LET URL(theurl)
sUrl=theurl
end property
public property GET BasePath()
BasePath=mid(sUrl,1,InStrRev(sUrl,"/")-1)
end property
public property GET FileName()
FileName=mid(sUrl,InStrRev(sUrl,"/")+1)
end property
public property GET Html()
Html=BytesToBstr(getBody(sUrl))
end property

public property GET xhttpError()
xhttpError=sError
end property

private Function BytesToBstr(body)
on error resume next
'Cset:GB2312 UTF-8
dim objstream
set objstream = Server.CreateObject("adodb.stream")
with objstream
.Type = 1 '
.Mode = 3 '
.Open
.Write body '
.Position = 0 '
.Type = 2 '
.Charset = Cset '
BytesToBstr = .ReadText '
.Close
end with
set objstream = nothing
End Function

private function getBody(surl)
on error resume next
dim xmlHttp
'Set xmlHttp=server.createobject("Msxml2.XMLHTTP.4.0")
'set xmlHttp=server.createobject("Microsoft.XMLHTTP")
set xmlHttp=server.createobject("MSXML2.ServerXMLHTTP")
xmlHttp.setTimeouts 10000,10000,10000,30000
xmlHttp.open "GET",surl,false
xmlHttp.send
if xmlHttp.readystate=4 then
'if xmlHttp.status=200 then
getBody=xmlhttp.responsebody
'end if
else
getBody=""
end if

if Err.Number<>0 then
sError=Err.Number
Err.clear
else
sError=""
end if
set xmlHttp=nothing
end function

Public function saveimage(tofile)
on error resume next
dim objStream,imgs
imgs=getBody(sUrl)
Set objStream = Server.CreateObject("ADODB.Stream")
with objStream
.Type =1
.Open
.write imgs
.SaveToFile server.mappath(tofile),2
.Close()
end with
set objstream=nothing
end function
end class

提示:Server.UrlEncode 在这里起到很关键作用,没这个系统可能一下可以一下不行。原因就是Server.UrlEncode的功能,接受处理页面获取得到值是乱码,程序给你不执行的。所有传递汉字参数的都要加这个 Server.UrlEndcode
错误写法:myHttp.URL=“http://www.汉字&id=11&rnum="&now()
正确写法:myHttp.URL=“http://www.("汉字")&"&id=11&rnum="&now()
更正确的写法:myHttp.URL=“http://220.110.777.99/test.asp?test_hanzi="&Server.UrlEncode("汉字")&"&id=11&rnum="&now()
'这个可以在对方不能上网的服务器(dns)也能连。

这个代码加上我的提示,你写的接口连接一般会很稳定。

[ 本帖最后由 ysf0181 于 2012-7-23 13:42 编辑 ]
#3
ysf01812012-07-30 10:58
Dim strstr
strstr="全能播放器CorePlayer v1.36.7427"  
response.write   ReplaceChina("[^\u4e00-\u9fa5]",strstr,"")  
Function ReplaceChina(NeiRong,str,str1)  
  Dim CNregEx
  set CNregEx = new RegExp  
      CNregEx.pattern=NeiRong  
      CNregEx.IgnoreCase=true  
      CNregEx.Global=true  
      ReplaceChina=CNregEx.replace(str,str1)  
  set CNregEx = nothing
End Function '提取汉字函数。。。。。。。。。。。。。。。。。。。。。。。。。。。。。。。。。。。
#4
ysf01812012-07-30 10:59
Function LiuYiKongGe_config1(strng) '去除所有的空格
   Dim regEx ' 建立变量。
   Set regEx = New RegExp   ' 建立正则表达式。
   regEx.Pattern = " +"  ' 设置模式。
   regEx.IgnoreCase = True   ' 设置是否区分字符大小写。
   regEx.Global = True   ' 设置全局可用性。
   LiuYiKongGe_config1 = regEx.Replace(strng,"")
   'LiuYiKongGe_config1 = regEx.Replace(strng," ")
   Set regEx = nothing
End Function
 'response.write "  dfrg     refrfe   eee"
 'response.write (LiuYiKongGe_config1("  dfrg       refrfe   eee"))
 'response.write (replace("dfrg        refrfe   eee"," ",""))
 'response.end
#5
ysf01812012-07-30 10:59
Function RegExpTest(strng)  '以数组返回
          i = 0
          Set regEx = New RegExp
          regEx.Pattern = "(\d+)" '"[0-9]"
          regEx.IgnoreCase = True
          regEx.Global = True
          Set Matches = regEx.Execute(strng)
          For Each Match in Matches
              RetStr = RetStr &""& Match.Value '输出提取出来的数字
               i = i + 1
          Next
          RegExpTest = RetStr
End Function  '输出提取出来的数字
#6
ysf01812012-07-30 11:15
********************************************************************************
'    function(公有)
'    名称 :   字符串截取函数
'    作用 :    按指定首尾字符串截取内容(本函数为从左向右截取)
'    参数 :    scontent ---- 被截取的内容
'        sstart ------ 首字符串
'        istartno ---- 当首字符串不是唯一时取第几个
'        bincstart --- 是否包含首字符串(1/true为包含,0/false为不包含)
'        istartcusor - 首偏移值(指针单位为字符数量,左偏用负值,右偏用正值,不偏为0)
'        sover ------- 尾字符串
'        ioverno ----- 当尾字符串不是唯一时取第几个
'        bincover ---- 是否包含尾字符串((1/true为包含,0/false为不包含)
'        iovercusor -- 尾偏移值(指针单位为字符数量,左偏用负值,右偏用正值,不偏为0)
'********************************************************************************
public function senfe_cut(scontent, sstart, istartno, bincstart, istartcusor, sover, ioverno, bincover, iovercusor)
    if scontent<>"" then
        dim istartlen, ioverlen, istart, iover, istartcount, iovercount, i
        istartlen = len(sstart)    '首字符串长度
        ioverlen  = len(sover)    '尾字符串长度
        '首字符串第一次出现的位置
        istart = instr(scontent, sstart)
        '尾字符串在首字符串的右边第一次出现的位置
        iover = instr(istart + istartlen, scontent, sover)
        if istart>0 and iover>0 then
            if istartno < 1 or isnumeric(istartno)=false then istartno = 1
            if ioverno < 1 or isnumeric(ioverno)=false then ioverno  = 1
            '取得首字符串出现的次数
            istartcount = ubound(split(scontent, sstart))
            if istartno>1 and istartcount>0 then
                if istartno>istartcount then istartno = istartcount
                for i = 1 to istartno
                    istart = instr(istart, scontent, sstart) + istartlen
                next
                iover = instr(istart, scontent, sover)
                istart = istart - istartlen    '还原默认状态:包含首字符串
            end if
            '取得尾字符串出现的次数
            iovercount = ubound(split(mid(scontent, istart + istartlen), sover))
            if ioverno>1 and iovercount>0 then
                if ioverno>iovercount then ioverno = iovercount
                for i=1 to ioverno
                    iover = instr(iover, scontent, sover) + ioverlen
                next
                iover = iover - ioverlen    '还原默认状态:不包含尾字符串
            end if
            if cbool(bincstart)=false then istart = istart + istartlen    '不包含首字符串
            if cbool(bincover)  then iover = iover + ioverlen        '包含尾字符串
            istart = istart + istartcusor    '加上首偏移值
            iover  = iover + iovercusor    '加上尾偏移值
            if istart<1 then istart = 1
            if iover<=istart then iover = istart + 1
            '按指定的开始和结束位置截取内容
            senfe_cut = mid(scontent, istart, iover - istart)
        else
            'senfe_cut = scontent
            senfe_cut = "没有找到您想要的内容,可能您设定的首尾字符串不存在!"
        end if
    else
        senfe_cut = "没有内容!"
    end if
end function

收集最实用的网页特效代码!
#7
ysf01812012-08-03 12:06
参数传值的一个很容易找不到原因的问题。。


例如:
abc = request("abc")
response.write abc '这个参数的值就有问题了,就是函数和参数名重合了。
response.end
sub abc()
end sub
#8
ysf01812012-08-04 11:57
aa = 1
call ceshi()
sub ceshi()
   bb = 2
   aa = 2
end sub
response.write bb '该值是空的,asp不支持里面过程传到外面
response.write aa '支持里面对参数的变化
response.end
#9
ysf01812012-08-21 16:14
sql2000这样的语句更新不了。。。
rs_zhaopin.open"select * from xueyuanfaduanxink where xueyuan = '戴丞' and fasongzhuantai= 0 order by id desc",conn_zhaopin,1,3
         
       rs_zhaopin("fasongzhuantai") = 1
       rs_zhaopin.update
    rs_zhaopin.close

该怎么写呢 ?
终于找到原因了,xueyuanfaduanxink  表没有主键的缘故,使很多 sql语句莫名的不能执行,大家可要注意了。

我搞了2天才找到原因,唉,希望大家千万不要忘了每个表必须有个主键。一定要的。


我没有,因为我用asp添加表,没注意到主键添加,使得代码执行时,sql更新删除动作其实不起效果的。

怪不得,我最近写的代码老是出问题,以为asp变量没搞好,原来是表的主键没有,造成sql语句更新删除根本就不执行。

千万记住,每个表一定要有个主键。主键。主键
#10
hu9jj2012-08-22 07:47
好东西,留记号备用。
#11
aspic2012-08-22 10:30
编辑器这里有个东西叫“程序代码” 乱七八糟没有格式化的东西 看都不想看
#12
ysf01812012-08-22 14:25
这样的SQL语句是错误的。
<%
Set rs=Server.CreateObject("ADODB.Recordset")
rs.open "Select * from 表名 where abc='' or abc is null",conn,1,1
%>
查询所有不为空的字段:
<%
Set rs=Server.CreateObject("ADODB.Recordset")
rs.open "Select * from 表名 where abc<>'' or is abc not null",conn,1,1
%>
正确的语句:
下面的语句在access 和 sql是都可以执行的。
查询所有为空的字段:
<%
Set rs=Server.CreateObject("ADODB.Recordset")
rs.open "Select * from 表名 where  abc is null",conn,1,1
%>
查询所有不为空的字段:
<%
Set rs=Server.CreateObject("ADODB.Recordset")
rs.open "Select * from 表名 where abc is not null",conn,1,1
%>

#13
ysf01812012-11-07 15:59
Bad Request (Invalid Hostname) 的原因:


www.baidu.com 了,基本上说域名没绑定主机就是主机头设置,

还有一种情况就是 :服务器80端口被不同的IIs占用,也可以出现这个情况。
#14
ysf01812012-11-08 08:37
'取得星期几
Function getweekday(date1)
 Dim day1
 day1=Weekday(date1)
 If day1=1 Then
 day1=7
 Else
 day1=day1-1
 End If
 getweekday=day1
 'response.write day1
 'response.end
End Function


[ 本帖最后由 ysf0181 于 2012-11-8 08:38 编辑 ]
#15
ysf01812012-11-10 14:21
程序代码:
Function ReDBTableCount(rsSchema)
        Dim DbTCount
        DbTCount=0
        Do Until rsSchema.EOF
           DbTCount=DbTCount+1
           rsSchema.MoveNext
        Loop
        rsSchema.MoveFirst
        ReDBTableCount=DbTCount
     End Function
     '返回数据库所有表名方法(适用于Access数据库)
     '参数ADODB.Connection ,Dim定义的数组
     Function ReDBAllTableName(con,TbNAry())
        Dim rsSchema
        Dim TbAryL
        TbAryL=0
        Set rsSchema=con.OpenSchema(20)
        ReDim TbNAry(ReDBTableCount(rsSchema))
        Do Until rsSchema.EOF
           IF TbAryL<UBound(TbNAry) Then
              IF InStr(rsSchema("TABLE_NAME"),"MSys")=0 And InStr(rsSchema("TABLE_NAME"),"查询")=0 Then
                 TbNAry(TbAryL)=rsSchema("TABLE_NAME")
              Else
                 TbNAry(TbAryL)=""
              End IF
           End IF
           TbAryL=TbAryL+1
           rsSchema.MoveNext
        Loop
        rsSchema.Close
        Set rsSchema=Nothing
     End Function
'用法
'
假设conn为ADODB.Connection
Dim i,TBNAry()
ReDBAllTableName conn,TBNAry
For i=0 To UBound(TBNAry)-1
     IF TBNAry(i)<>"" Then
        Response.Write "表名:"&TBNAry(i)&"<br>"
     End IF  
Next
#16
ysf01812013-01-06 15:35
’我手动测试通过了。
ceshi = "2a2b334dA"
ceshi2 = "abcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZ"
response.write quzifu_config1(ceshi,ceshi2)

Function quzifu_config1(str,str2) '只取里面有的字符
  dim str1,dengzimu,linshi,enChar
  str1 = str
  dengzimu = ""
  linshi = ""
  enChar= str2 '"abcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZ"'大小写你转化下lcase ucase
  'onChar=split(enChar,",")
  for i=1 to len(str1)
      linshi = instr(enChar,mid(str1,i,1))
      if linshi > 0 then     
         if dengzimu = "" then
            dengzimu = mid(str1,i,1)
         else
            dengzimu =  cstr(dengzimu) + cstr(mid(str1,i,1))
         end if
         str1 = replace(str1,mid(str1,1,i),mid(str1,1,i-1)&"`")   
      end if
  next
  quzifu_config1 = dengzimu
End Function

#17
ysf01812013-01-07 16:14
程序代码:
Function FuZhiwenjian(wenjianming,wenjianWZmulu) 'wenjianming 要复制的文件名 ,wenjianWZmulu 要复制的网站目录位置
   dim fs,f,WZmulu,yaojianming,ii,zhende
   WZmulu = Server.MapPath("/")
   set fs=Server.CreateObject("Scripting.FileSystemObject")
   set f=fs.GetFile(""&WZmulu&"\"&wenjianming&"")
   yaojianming = ""
   ii = 0
   zhende = 0
   do while zhende = 0
      ii = clng(ii) + 1
      yaojianming = WZmulu&"\"&wenjianWZmulu&"\"&ii&"_"&wenjianming
      if fs.FileExists(yaojianming) = false then
         exit do
      end if
   loop
   f.Copy ""&yaojianming&"",false
   set f = nothing
   set fs = nothing
End Function  'Function FuZhiwenjian()
#18
ysf01812013-05-10 12:43
'dim str
'str="怎样从一个Html页面中提取所有汉字呢?不能有其它Html代码。11111 ,白555 QC020-1白tr色"
'response.write  RegExpTest_inc("[\u4e00-\u9fa5]",str,0)&"<br>" '提取所有汉字
'response.write  RegExpTest_inc("[0-9]",str,0)&"<br>"  '提取所有数字
'response.write  RegExpTest_inc("[a-z]",str,0) &"<br>" '提取所有字母
'response.write  RegExpTest_inc("[a-z0-9]",str,0)&"<br>"  '提取所有字母

'RegExpTest_inc(patrn, strng,shuzu) 函数
'patrn 为提取类
'strng 为要提取的所有字符串
'shuzu 0 为所有,1为数组提取
Function RegExpTest_inc(patrn, strng,shuzu)
   Dim regEx, Match, Matches,i  ' 建立变量。
   i = 0
   Set regEx = New RegExp   ' 建立正则表达式。
   regEx.Pattern = patrn   ' 设置模式。
   regEx.IgnoreCase = True   ' 设置是否区分大小写。
   regEx.Global = True   ' 设置全局替换。
   Set Matches = regEx.Execute(strng)   ' 执行搜索。
   if int(shuzu) = int(0) then
      For Each Match in Matches   ' 遍历 Matches 集合。
          RetStr = RetStr  &  Match.Value
      Next
   'if int(shuzu) = 0 then
   else
      dim RetStr()
      For Each Match in Matches   ' 遍历 Matches 集合。
          'RetStr = RetStr  &  Match.Value
          Redim Preserve RetStr(i)
          RetStr(i) = Match.Value
          i = i + 1
      Next
   end if 'if int(shuzu) = 0 then else
   RegExpTest_inc = RetStr
End Function
1