实用ASP函数源代码

欢迎跟贴，灌水无分~

Function replaceplus(strContent, start_string, end_string, replace_string) '文档中，将所有开始，结束之间的所有字符删除
On Error Resume Next
MARKCOUNTS = UBound(Split(strContent, start_string))
PRESTRING = strContent
For I = 0 To MARKCOUNTS
STARTMARK = InStr(1, PRESTRING, start_string, 1)
If STARTMARK = 0 Then Exit For
COMPMARK = InStr(1, PRESTRING, end_string, 1) + Len(end_string)
VerString = Mid(PRESTRING, STARTMARK, COMPMARK - STARTMARK)
PRESTRING = Replace(PRESTRING, VerString, replace_string)
Next
replaceplus = PRESTRING
If Err.Number <> 0 Then Err.Clear
End Function

function update_html_files(HTMLDATA,COMLETE_HTML_FILE,needlogin)
on error resume next
set FileObject = server.createobject("Scripting.FileSystemObject")
Set fText = FileObject.Createtextfile(COMLETE_HTML_FILE,true)
if needlogin="1" then
Set objFSO = Server.CreateObject("Scripting.FileSystemObject")
if objFSO.FileExists(Server.MapPath("inc/inc_needlogin.asp")) then
Set objCountFile = objFSO.OpenTextFile(Server.MapPath("inc/inc_needlogin.asp"),1,True)
If Not objCountFile.AtEndOfStream Then loginstring = objCountFile.ReadAll
Set objCountFile=Nothing
else
loginstring = "缺少系统所需的文件,请联系系统供应商！"
end if
Set objFSO = Nothing
else
loginstring = "

"
end if
html_head= loginstring & "

"
html_foot="

"
fText.writeline html_head & HTMLDATA & html_foot
fText.close
Set fText = nothing
set FileObject = nothing
if err.number<>0 then
update_html_files = false
call Error("更新HTML文件失败,"& COMLETE_HTML_FILE,CurrentScript)
err.Clear
else
update_html_files = true
end if
end function

Function chkemail(strEmailAddr) ' vbs
Dim re
Set re = new RegExp
re.pattern = "^[a-zA-Z][A-Za-z0-9_.-]+@[a-zA-Z0-9_]+?\.[a-zA-Z]{2,3}$"
chkemail=re.Test(strEmailAddr)
end function

Function chkoicq(oicq) 'vbs
Dim re1
Set re1 = new RegExp
re1.IgnoreCase = false
re1.global = false
re1.Pattern = "[0-9]{4,9}$"
chkoicq = re1.Test(oicq)
End Function

function DeleteHTMLFile(HTMLFilename)
if HTMLFilename<>"" then
Set fso = server.CreateObject("Scripting.FileSystemObject")
if fso.FileExists(HTMLFilename) then
fso.DeleteFile HTMLFilename
end if
set fso = nothing
end if
end function

' ============== autoget ==============
function getHTTPPage(url)
on error resume next
dim http
set http=Server.createobject("Msxml2.XMLHTTP")
Http.open "GET",url,false
Http.send()
if Http.readystate<>4 then exit function
getHTTPPage=bytes2BSTR(Http.responseBody)
set http=nothing
if err.number<>0 then err.Clear
end function

Function bytes2BSTR(vIn)
dim strReturn
dim i,ThisCharCode,NextCharCode
strReturn = ""
For i = 1 To LenB(vIn)
ThisCharCode = AscB(MidB(vIn,i,1))
If ThisCharCode < &H80 Then
strReturn = strReturn & Chr(ThisCharCode)
Else
NextCharCode = AscB(MidB(vIn,i+1,1))
strReturn = strReturn & Chr(CLng(ThisCharCode) * &H100 + CInt(NextCharCode))
i = i + 1
End If
Next
bytes2BSTR = strReturn
End Function

---------------------------------------------------------------

我也凑个热闹:
'--------------------------------------------------------------
'重新排列记录的顺序号(数字间隔为5)：
sub sort_table_by_sortid(tablename)
Dim sSQL, rs, i
sSQL="select sortid from " & tablename & " order by sortid"
Set rs = Server.CreateObject("ADODB.Recordset")
rs.Open sSQL, S_conn, 3, 3
rs.MoveFirst
i=1
Do while not rs.eof
rs("sortid")=5*i
i=i+1
rs.MoveNext
Loop
set rs=nothing
end sub

'--------------------------------------------------------------
'生成顺序号
function makeSortid(tablename)
Dim sSQL, rs
sSQL="select max(sortid) as maxsortid from " & tablename
Set rs = Server.CreateObject("ADODB.Recordset")
rs.Open sSQL, S_conn, 1, 1
if isNull(rs("maxsortid")) then '表为空
makeSortid=5
else '表中有记录
makeSortid=rs("maxsortid") + 5
end if
set rs=nothing
end function

'--------------------------------------------------------------
function hasFile(Fn)
Set Fso1 = CreateObject("Scripting.FileSystemObject")
if Fso1.FileExists(Fn) then
hasFile=true
else
hasFile=false
end if
set Fso1=nothing
end function

'--------------------------------------------------------------
function FormatStr(sStr,nLen)
FormatStr=sSTR
if len(sStr)>nLen then
FormatStr=left(sStr,nLen) & "…"
end if
end function

'--------------------------------------------------------------
function htmlspaces(n)
Dim sTmp,i
sTmp=""
if n>=1 then
for i=1 to n
sTmp=sTmp+" "
next
end if
htmlspaces=sTmp
end function

'--------------------------------------------------------------
function ChangeChr2Html(str)
changechr2html=replace(replace(str,chr(13),"

1<br/>

")," "," ")
changechr2html=replace(replace(replace(replace(str,"<","<"),">",">"),chr(13),"

1<br/>

")," "," ")
end function

'--------------------------------------------------------------
function ChangeHtml2Chr(str)
changehtml2chr=replace(str, " ", " ")
changehtml2chr=replace(changehtml2chr, "

1<br/>

", "")
end function

'--------------------------------------------------------------
function make_auto_id()
make_auto_id = now()
make_auto_id = replace(make_auto_id,"-","")
make_auto_id = replace(make_auto_id," ","")
make_auto_id = replace(make_auto_id,":","")
make_auto_id = replace(make_auto_id,"PM","")
make_auto_id = replace(make_auto_id,"AM","")
make_auto_id = replace(make_auto_id,"上午","")
make_auto_id = replace(make_auto_id,"下午","")
end function

'--------------------------------------------------------------
function save2file(aPath_and_aFilename, aStr)
Set myfso = Server.CreateObject("Scripting.FileSystemObject")
Set myFile = myfso.CreateTextFile(aPath_and_aFilename)
myFile.WriteLine aStr
myFile.close
set myfso=nothing
end function

%>
---------------------------------------------------------------

实现分页的一个程序
Sub LastNextPage(pagecount,page,resultcount)
Dim query, a, x, temp
action = "http://" & Request.ServerVariables("HTTP_HOST") & Request.ServerVariables("SCRIPT_NAME")

query = Split(Request.ServerVariables("QUERY_STRING"), "&")
For Each x In query
a = Split(x, "=")
If StrComp(a(0), "page", vbTextCompare) <> 0 Then
temp = temp & a(0) & "=" & a(1) & "&"
End If
Next

Response.Write("

 1<table border="0" cellpadding="0" cellspacing="0">" &amp; vbCrLf )   
 2Response.Write("<form +="" document.location='" &amp; action &amp; "?" &amp; temp &amp; "Page=' false;""="" method="get" onsubmit="" this.page.value;return=""><tr>" &amp; vbCrLf )   
 3Response.Write("<td align="right">" &amp; vbCrLf )   
 4' Response.Write(font_style &amp; vbCrLf )   
 5  
 6if page&lt;=1 then   
 7Response.Write ("首页 " &amp; vbCrLf)   
 8Response.Write ("上一页 " &amp; vbCrLf)   
 9else   
10Response.Write("<a "page="1" &="" ?"="" href=" &amp; action &amp; " temp="">首页</a> " &amp; vbCrLf)   
11Response.Write("<a "page=" &amp; (Page-1) &amp; " &="" ?"="" href=" &amp; action &amp; " temp="">上一页</a> " &amp; vbCrLf)   
12end if   
13  
14if page&gt;=pagecount then   
15Response.Write ("下一页 " &amp; vbCrLf)   
16Response.Write ("尾页" &amp; vbCrLf)   
17else   
18Response.Write("<a "page=" &amp; (Page+1) &amp; " &="" ?"="" href=" &amp; action &amp; " temp="">下一页</a> " &amp; vbCrLf)   
19Response.Write("<a "page=" &amp; pagecount &amp; " &="" ?"="" href=" &amp; action &amp; " temp="">尾页</a>" &amp; vbCrLf)   
20end if   
21  
22Response.Write(" 第" &amp; "<input 12px""tyep="TEXT" 19px;font-size:="" height:="" maxlength="4" name="page" size="2" style="" value=" &amp; page &amp; "/>" &amp; "页" &amp; vbCrLf &amp; "&lt;I</td></tr></form></table>
Published At
Categories with Web编程
comments powered by Disqus