'Date —— 显示系统日期 —— 11
'gotTopic —— 截字符串，汉字一个算两个字符，英文算一个字符 46
'JoinChar —— 向地址中加入 ? 或 & —— 80
'showpage —— 显示“上一页 下一页”等信息 —— 106
'IsValidEmail —— 检查Email地址合法性 —— 156
'IsObjInstalled —— 检查组件是否已经安装 —— 204
'strLength —— 求字符串长度。汉字算两个字符，英文算一个字符 —— 204
'SendMail —— 用Jmail组件发送邮件 —— 254
'WriteErrMsg —— 显示错误提示信息 —— 293
'WriteSuccessMsg —— 显示成功提示信息 —— 313
'Data_ConnAccess —— 连接数据库[Access] —— 332
'Data_ConnSQL —— 连接数据库[SQL] —— 349
'=================================================
'过程称：Date
'作 用：显示系统日期
'参 数：无
'=================================================
Sub Date()
%>
<script language="JavaScript">
var day="";
var month="";
var ampm="";
var ampmhour="";
var myweekday="";
var year="";
mydate=new Date();
myweekday=mydate.getDay();
mymonth=mydate.getMonth()+1;
myday= mydate.getDate();
myyear= mydate.getYear();
year=(myyear > 200) ? myyear : 1900 + myyear;
if(myweekday == 0)
weekday=" 星期日 ";
else if(myweekday == 1)
weekday=" 星期一 ";
else if(myweekday == 2)
weekday=" 星期二 ";
else if(myweekday == 3)
weekday=" 星期三 ";
else if(myweekday == 4)
weekday=" 星期四 ";
else if(myweekday == 5)
weekday=" 星期五 ";
else if(myweekday == 6)
weekday=" 星期六 ";
document.write(year+"年"+mymonth+"月"+myday+"日 "+weekday);
</script>
<%
End Sub
'*************************************************
'函数名：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
'***********************************************
'函数名：JoinChar
'作 用：向地址中加入 ? 或 &
'参 数：strUrl ----网址
'返回值：加了 ? 或 & 的网址
'***********************************************
function JoinChar(strUrl)
if strUrl="" then
JoinChar=""
exit function
end if
if InStr(strUrl,"?")<len(strUrl) then
if InStr(strUrl,"?")>1 then
if InStr(strUrl,"&")<len(strUrl) then
JoinChar=strUrl & "&"
else
JoinChar=strUrl
end if
else
JoinChar=strUrl & "?"
end if
else
JoinChar=strUrl
end if
end function
'***********************************************
'过程名：showpage
'作 用：显示“上一页 下一页”等信息
'参 数：sfilename ----链接地址
' totalnumber ----总数量
' maxperpage ----每页数量
' ShowTotal ----是否显示总数量
' ShowAllPages ---是否用下拉列表显示所有页面以供跳转。有某些页面不能使用，否则会出现JS错误。
' strUnit ----计数单位
'***********************************************
sub showpage(sfilename,totalnumber,maxperpage,ShowTotal,ShowAllPages,strUnit)
dim n, i,strTemp,strUrl
if totalnumber mod maxperpage=0 then
n= totalnumber \ maxperpage
else
n= totalnumber \ maxperpage+1
end if
strTemp= "<table align='center'><form method='Post' action='" & sfilename & "'><tr><td>"
if ShowTotal=true then
strTemp=strTemp & "共 <b>" & totalnumber & "</b> " & strUnit & " "
end if
strUrl=JoinChar(sfilename)
if CurrentPage<2 then
strTemp=strTemp & "首页 上一页 "
else
strTemp=strTemp & "<a href='" & strUrl & "page=1'>首页</a> "
strTemp=strTemp & "<a href='" & strUrl & "page=" & (CurrentPage-1) & "'>上一页</a> "
end if
if n-currentpage<1 then
strTemp=strTemp & "下一页 尾页"
else
strTemp=strTemp & "<a href='" & strUrl & "page=" & (CurrentPage+1) & "'>下一页</a> "
strTemp=strTemp & "<a href='" & strUrl & "page=" & n & "'>尾页</a>"
end if
strTemp=strTemp & " 页次：<strong><font color=red>" & CurrentPage & "</font>/" & n & "</strong>页 "
strTemp=strTemp & " <b>" & maxperpage & "</b>" & strUnit & "/页"
if ShowAllPages=True then
strTemp=strTemp & " 转到：<select size='1' >"
for i = 1 to n
strTemp=strTemp & "<option value='" & i & "'"
if cint(CurrentPage)=cint(i) then strTemp=strTemp & " selected "
strTemp=strTemp & ">第" & i & "页</option>"
next
strTemp=strTemp & "</select>"
end if
strTemp=strTemp & "</td></tr></form></table>"
response.write strTemp
end sub
'********************************************
'函数名：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
'***************************************************
'函数名：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
'**************************************************
'函数名：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
'****************************************************
'函数名：SendMail
'作 用：用Jmail组件发送邮件
'参 数：ServerAddress ----服务器地址
' AddRecipient ----收信人地址
' Subject ----主题
' Body ----信件内容
' Sender ----发信人地址
'****************************************************
function SendMail(MailServerAddress,AddRecipient,Subject,Body,Sender,MailFrom)
on error resume next
Dim JMail
Set JMail=Server.CreateObject("JMail.SMTPMail")
if err then
SendMail= "<br><li>没有安装JMail组件</li>"
err.clear
exit function
end if
JMail.Logging=True
JMail.Charset="gb2312"
JMail.ContentType = "text/html"
JMail.ServerAddress=MailServerAddress
JMail.AddRecipient=AddRecipient
JMail.Subject=Subject
JMail.Body=MailBody
JMail.Sender=Sender
JMail.From = MailFrom
JMail.Priority=1
JMail.Execute
Set JMail=nothing
if err then
SendMail=err.description
err.clear
else
SendMail="OK"
end if
end function
'****************************************************
'过程名：WriteErrMsg
'作 用：显示错误提示信息
'参 数：无
'****************************************************
sub WriteErrMsg(errmsg)
dim strErr
strErr=strErr & "<html><head><title>错误信息</title><meta http-equiv='Content-Type' content='text/html; charset=gb2312'>" & vbcrlf
strErr=strErr & "<link href="/blog/style.css" rel='stylesheet' type='text/css'></head><body>" & vbcrlf
strErr=strErr & "<table cellpadding=2 cellspacing=2 border=0 width=400 align=center>" & vbcrlf
strErr=strErr & " <tr align='center'><td height='20' ><strong>错误信息</strong></td></tr>" & vbcrlf
strErr=strErr & " <tr><td height='100' valign='top'><b>产生错误的可能原因：</b><br>" & errmsg &"</td></tr>" & vbcrlf
strErr=strErr & " <tr align='center'><td ><a href=';【返回】</a></td></tr>" & vbcrlf
strErr=strErr & "</table>" & vbcrlf
strErr=strErr & "</body></html>" & vbcrlf
response.write strErr
end sub
'****************************************************
'过程名：WriteSuccessMsg
'作 用：显示成功提示信息
'参 数：无
'****************************************************
sub WriteSuccessMsg(SuccessMsg)
dim strSuccess
strSuccess=strSuccess & "<html><head><title>成功信息</title><meta http-equiv='Content-Type' content='text/html; charset=gb2312'>" & vbcrlf
strSuccess=strSuccess & "<link href="/blog/style.css" rel='stylesheet' type='text/css'></head><body>" & vbcrlf
strSuccess=strSuccess & "<table cellpadding=2 cellspacing=2 border=0 width=400 align=center>" & vbcrlf
strSuccess=strSuccess & " <tr align='center'><td height='20' ><strong>恭喜你！</strong></td></tr>" & vbcrlf
strSuccess=strSuccess & " <tr><td height='100' valign='top'><br>" & SuccessMsg &"</td></tr>" & vbcrlf
strSuccess=strSuccess & " <tr align='center'><td ><a href=';【返回】</a></td></tr>" & vbcrlf
strSuccess=strSuccess & "</table>" & vbcrlf
strSuccess=strSuccess & "</body></html>" & vbcrlf
response.write strSuccess
end sub
'****************************************************
'过程名：Data_ConnAccess
'作 用：连接数据库[Access]
'参 数：
'****************************************************
Sub Data_ConnAccess(DataFile)
dim conn
Set Conn=Server.createobject("Adodb.Connection")
Conn.open "DRIVER={Microsoft Access Driver (*.mdb)};Dbq="&server.mappath(DataFile)
If Err Then
err.Clear
Set Conn = Nothing
Response.Write "数据库连接出错，请检查连接字串。"
Response.End
End If
End Sub
'****************************************************
'过程名：Data_ConnSQL
'作 用：连接数据库[SQL]
'参 数：
'****************************************************
Sub Data_ConnSQl(servername,datafile,uid,pwd)
dim conn
Set Conn=Server.createobject("Adodb.Connection")
Conn.open "DRIVER={SQl Server};Server="&servername&";dataname="&datafile&";uid="&uid&";pwd="&pwd
If Err Then
err.Clear
Set Conn = Nothing
Response.Write "数据库连接出错，请检查连接字串。"
Response.End
End If
End Sub
'****************************************************
'过程名：Conn_Close
'作 用：关闭数据连接
'参 数：无
'****************************************************
Sub Conn_Close(conn_name)
conn_name.Close
Set conn_name=Nothing
End sub
function send_mail(s_username,s_email,s_topic,s_body)
dim temp1
temp1=s_username&"，你好！" & _
vbcrlf& _
vbcrlf& s_body & _
vbcrlf& _
vbcrlf&"--------------------------------------------------------" & _
vbcrlf&"更多精彩信息请访问：" & _
vbcrlf& _
vbcrlf& web_dim(1) & _
vbcrlf& web_dim(2) & _
vbcrlf& _
vbcrlf&"欢迎您的光临！" & _
vbcrlf&"--------------------------------------------------------" & _
vbcrlf&"注：本邮件为系统邮件！" & _
vbcrlf&"邮件发送时间："&joekoe_cms.time_type(joekoe_cms.now_time,2)
send_mail=send_jmail(s_email,"系统邮件："&s_topic&"（LBQQ.com）",temp1,"海心在线系统邮件管理员","webmaster@26818.com")
end function
'****************************************************
'函数名：send_jmail
'作 用：用Jmail组件发送邮件
'参 数：ServerAddress ----服务器地址
' AddRecipient ----收信人地址
' Subject ----主题
' Body ----信件内容
' Sender ----发信人地址
'****************************************************
function send_jmail(j_sendname,j_Subject,j_HTMLBody,j_name,j_email)
on error resume next
dim Jmail
Set Jmail=server.createobject("Jmail.Message")
Jmail.Charset="gb2312"
Jmail.Priority=2 '优先级
Jmail.MailServerUserName="kgdyga" '这里换成您的SMTP验证帐号
Jmail.MailServerPassword="kgdyga" '这里填写您的SMTP认证密码
Jmail.From=j_email '发信人邮件地址
Jmail.FromName=j_name '发信人姓名
Jmail.Subject=j_Subject '信件主题
Jmail.AddRecipient j_sendname '收信人地址
Jmail.Body=j_HTMLBody 'TXT Mailbody参数是信件正文
'JMail.HTMLBody=j_HTMLBody 'HTML信件正文
Jmail.Send("mail.163.com") '发信的邮件服务器
Set Jmail=nothing
send_jmail=true
if err then
err.clear
send_jmail=false
end if
end function
'-------------根据指定名称生成目录---------
Function MakeNewsDir(foldername)
Set fso1 = CreateObject("Scripting.FileSystemObject")
Set f = fso1.CreateFolder(server.MapPath(foldername))
MakeNewsDir = True
Set fso1 = nothing
End Function
'------------------检查某一目录是否存在-------------------
Function CheckDir(FolderPath)
folderpath=Server.MapPath(".")&"\"&folderpath
Set fso1 = CreateObject("Scripting.FileSystemObject")
If fso1.FolderExists(FolderPath) then
'存在
CheckDir = True
Else
'不存在
CheckDir = False
End if
Set fso1 = nothing
End Function
'------------------备份数据库-------------------
sub backupdata()
Dbpath=request.form("Dbpath")
Dbpath=server.mappath(Dbpath)
bkfolder=request.form("bkfolder")
bkdbname=request.form("bkdbname")
Set Fso=server.createobject("scripting.filesystemobject")
if fso.fileexists(dbpath) then
If CheckDir(bkfolder) = True Then
fso.copyfile dbpath,bkfolder& "\"& bkdbname
else
MakeNewsDir bkfolder
fso.copyfile dbpath,bkfolder& "\"& bkdbname
end if
response.write "备份数据库成功，您备份的数据库路径为" &bkfolder& "\"& bkdbname
Else
response.write "找不到您所需要备份的文件。"
End if
end sub
Sub Jmail(Email,Topic,Mailbody)
On Error Resume Next
Dim JMail
Set JMail = Server.CreateObject("JMail.Message")
JMail.silent=true
JMail.Logging = True
JMail.Charset = "gb2312"
If Not(Dvbbs.Forum_info(12) = "" or Dvbbs.Forum_info(13) = "") Then
JMail.MailServerUserName = Dvbbs.Forum_info(12) '您的邮件服务器登录名
JMail.MailServerPassword = Dvbbs.Forum_info(13) '登录密码
End If
JMail.ContentType = "text/html"
JMail.Priority = 1
JMail.From = Dvbbs.Forum_info(5)
JMail.FromName = Dvbbs.Forum_info(0)
JMail.AddRecipient Email
JMail.Subject = Topic
JMail.Body = Mailbody
JMail.Send (Dvbbs.Forum_info(4))
Set JMail = Nothing
SendMail = "OK"
If Err Then SendMail = "False"
End Sub
Sub Cdonts(Email,Topic,Mailbody)
On Error Resume Next
Dim ObjCDOMail
Set ObjCDOMail = Server.CreateObject("CDONTS.NewMail")
ObjCDOMail.From = Dvbbs.Forum_info(5)
ObjCDOMail.To = Email
ObjCDOMail.Subject = Topic
ObjCDOMail.BodyFormat = 0
ObjCDOMail.MailFormat = 0
ObjCDOMail.Body = Mailbody
ObjCDOMail.Send
Set ObjCDOMail = Nothing
SendMail = "OK"
If Err Then SendMail = "False"
End Sub
Sub Aspemail(Email,Topic,Mailbody)
On Error Resume Next
Dim Mailer
Set Mailer = Server.CreateObject("Persits.MailSender")
Mailer.Charset = "gb2312"
Mailer.IsHTML = True
Mailer.username = Dvbbs.Forum_info(12) '服务器上有效的用户名
Mailer.password = Dvbbs.Forum_info(13) '服务器上有效的密码
Mailer.Priority = 1
Mailer.Host = Dvbbs.Forum_info(4)
Mailer.Port = 25 ' 该项可选.端口25是默认值
Mailer.From = Dvbbs.Forum_info(5)
Mailer.FromName = Dvbbs.Forum_info(0) ' 该项可选
Mailer.AddAddress Email,Email
Mailer.Subject = Topic
Mailer.Body = Mailbody
Mailer.Send
SendMail = "OK"
If Err Then SendMail = "False"
End Sub
'---------------------------------汉字判断-----------------------------------
function isChinese(para)
on error resume next
dim str
dim i
if isNUll(para) then
isChinese=false
exit function
end if
str=cstr(para)
if trim(str)="" then
isChinese=false
exit function
end if
for i=1 to len(str)
c=asc(mid(str,i,1))
if c>=0 then
isChinese=false
exit function
end if
next
isChinese=true
if err.number<>0 then err.clear
end function
'----------------------------------------------------------------------------
'-----------------------替换指定文件内字符串的函数---------------------------
function FSOlineedit(filename,Target,String)
Dim objFSO,objCountFile,FiletempData
Set objFSO = Server.CreateObject("Scripting.FileSystemObject")
Set objCountFile = objFSO.OpenTextFile(Server.MapPath(filename),1,True)
FiletempData = objCountFile.ReadAll
objCountFile.Close
FiletempData=Replace(FiletempData,Target,String)
Set objCountFile=objFSO.CreateTextFile(Server.MapPath(filename),True)
objCountFile.Write FiletempData
objCountFile.Close
Set objCountFile=Nothing
Set objFSO = Nothing
End Function
'---------------------------------ip限制函数---------------------------------
'******************************
'Function CheckIp(cInput_Ip,cBound_Ip)
'Created by qqdao, qqdao@263.net 2001/11/28
'说明：首先需要根据;号循环，然后判断是否含有"-"，如果有则进行拆分处理，最后判断是否在范围内
'参数： cInput_Ip,代检查的ip
' cBound_Ip,给定的范围格式为,单个ip,和范围ip，范围ip最后使用”-“分割，如果是“*”则必须放到最后一位
' 每个范围后添加":ALLOW"表示允许登陆，添加":REFUSE"表示拒绝登陆。多个范围用”;“隔开
' 例如192.168.1*.*:ALLOW;192.168.1.1:ALLOW;192.168.1.1-10:REFUSE"
'返回值: true/false
'更新：2001/12/05 支持ALLOW,REFUSE支持’*‘,不想对？支持，因为和*差不多
'******************************
function CheckIp(cInput_Ip,cBound_Ip)
dim cSingle_Ip,cTemp_IP,cStart_IP,cEnd_Ip
CheckIp = false
cSingle_Ip=split(cBound_Ip,";")
for i=0 to ubound(cSingle_Ip)
if Instr(cSingle_Ip(i),"REFUSE") <> 0 then '就是拒绝了
cTemp_IP = left(cSingle_Ip(i),instr(cSingle_Ip(i),":")-1)
if Instr(cTemp_IP,"*") <> 0 then '是宽范围
cStart_IP = left(cTemp_IP,instr(cTemp_IP,"*")-1)
if left(cInput_Ip,len(cStart_IP))=cStart_IP then
CheckIp = false
exit function
end if
end if
if Instr(cTemp_IP,"-") = 0 then
cStart_IP = cTemp_IP
cEnd_Ip = cTemp_IP
else
cStart_IP = left(cTemp_IP,instr(cTemp_IP,"-")-1)
cEnd_Ip = left(cStart_IP,InStrRev(cStart_IP,".")-1)+"."+mid(cTemp_IP,instr(cTemp_IP,"-")+1)
end if
if Ip2Str(cInput_Ip)>=Ip2Str(cStart_IP) and Ip2Str(cInput_Ip)<=Ip2Str(cEnd_Ip) then
CheckIp = false
exit function
end if
elseif Instr(cSingle_Ip(i),"ALLOW") <> 0 then '允许
cTemp_IP = left(cSingle_Ip(i),instr(cSingle_Ip(i),":")-1)
if Instr(cTemp_IP,"*") <> 0 then '是宽范围
cStart_IP = left(cTemp_IP,instr(cTemp_IP,"*")-1)
if left(cInput_Ip,len(cStart_IP))=cStart_IP then
CheckIp = true
end if
end if
if Instr(cTemp_IP,"-") = 0 then
cStart_IP = cTemp_IP
cEnd_Ip = cTemp_IP
else
cStart_IP = left(cTemp_IP,instr(cTemp_IP,"-")-1)
cEnd_Ip = left(cStart_IP,InStrRev(cStart_IP,".")-1)+"."+mid(cTemp_IP,instr(cTemp_IP,"-")+1)
end if
if Ip2Str(cInput_Ip)>=Ip2Str(cStart_IP) and Ip2Str(cInput_Ip)<=Ip2Str(cEnd_Ip) then
CheckIp =true
else
CheckIp =false
end if
end if
next
end function
'******************************
'Function Ip2Str(cIp)
'Created by qqdao, qqdao@263.net 2001/11/28
'参考动网ip算法
'参数：cIp ip地址
'返回值: 转换后数值
'******************************
function Ip2Str(cIp)
Dim str1,str2,str3,str4
Dim cIp_Temp
if cIp="127.0.0.1" then cIp="192.168.0.1"
str1=left(cIp,instr(cIp,".")-1)
cIp_Temp=mid(cIp,instr(cIp,".")+1)
str2=left(cIp_Temp,instr(cIp_Temp,".")-1)
cIp_Temp=mid(cIp_Temp,instr(cIp_Temp,".")+1)
str3=left(cIp_Temp,instr(cIp_Temp,".")-1)
str4=mid(cIp_Temp,instr(cIp_Temp,".")+1)
if isNumeric(str1)=0 or isNumeric(str2)=0 or isNumeric(str3)=0 or isNumeric(str4)=0 then
else
Ip2Str=cint(str1)*256*256*256+cint(str2)*256*256+cint(str3)*256+cint(str4)-1
end if
end function
'代码调用演示
'if CheckIp("192.168.1.1","192.168.1.*:REFUSE") then
' response.write "登陆成功"
'else
' response.write "您的ip不被允许"
'end if
'cinput_ip就是要检查的ip，也就是Request.ServerVariables("REMOTE_ADDR")
'cbound_ip是范围，可以存到库里，范围的写法，我已详细说明了。
Function Check_submit(str,restr)
if str="" then
response.write "<script>"
response.write "alert('"&restr&"');"
response.write "history.go(-1)"
response.write "</script>"
response.end
else
Check_submit=str
end if
End Function
Function Alert_submit(str)
response.write "<script>"
response.write "alert('"&str&"');"
'response.write "location.reload();"
response.write "</script>"
End Function
Function localhost_submit(str,urls)
response.write "<script>"
if str<>"" then
response.write "alert('"&str&"');"
end if
response.write "location='"&urls&"';"
response.write "</script>"
End Function
' ---生成自定义位随机数 Being-----------------------------
Function makerndid(byVal maxLen)
Dim strNewPass
Dim whatsNext, upper, lower, intCounter
RANdomize
For intCounter = 1 To maxLen
whatsNext = int(2 * Rnd)
If whatsNext = 0 Then
upper = 80
lower = 70
Else
upper = 48
lower = 39
End If
strNewPass = strNewPass & Chr(Int((upper - lower + 1) * Rnd + upper))
Next
makerndid = strNewPass
End Function
'rem ---生成四位随机数 Being-----------------------------
Function get_rand()
dim num1
dim rndnum
Randomize
Do While Len(rndnum)<4
num1=CStr(Chr((57-48)*rnd+48))
rndnum=rndnum&num1
loop
get_rand=rndnum
End Function
'rem ---判断数据是否整型 Being-----------------------------
Function IsInteger(para)
on error resume next
dim str
dim l,i
if isNUll(para) then
isInteger=false
exit function
end if
str=cstr(para)
if trim(str)="" then
isInteger=false
exit function
end if
l=len(str)
for i=1 to l
if mid(str,i,1)>"9" or mid(str,i,1)<"0" then
isInteger=false
exit function
end if
next
isInteger=true
if err.number<>0 then err.clear
End Function
'rem ---数据库链接函数 Being-----------------------------
Function OpenCONN
Set conn = Server.CreateObject("ADODB.Connection")
connstr="Provider=Microsoft.Jet.OLEDB.4.0;Data Source=" & Server.MapPath(DB_login)
conn.Open connstr
End Function
'rem ---中文字符转Uncode代码函数 Being-----------------------------
Function URLEncoding(vstrIn)
strReturn = ""
For i = 1 To Len(vstrIn)
ThisChr = Mid(vStrIn,i,1)
If Abs(Asc(ThisChr)) < &HFF Then
strReturn = strReturn & ThisChr
Else
innerCode = Asc(ThisChr)
If innerCode < 0 Then
innerCode = innerCode + &H10000
End If
Hight8 = (innerCode And &HFF00)\ &HFF
Low8 = innerCode And &HFF
strReturn = strReturn & "%" & Hex(Hight8) & "%" & Hex(Low8)
End If
Next
URLEncoding = strReturn
End Function
'rem ---Html过滤函数 Being-----------------------------
Function Htmlout(str)
dim result
dim l
if isNULL(str) then
Htmlout=""
exit function
end if
l=len(str)
result=""
dim i
for i = 1 to l
select case mid(str,i,1)
case "<"
result=result+"<"
case ">"
result=result+">"
case chr(13)
if session("admin_system")="" then
result=result+"<br>"
end if
case chr(34)
result=result+"""
case "&"
result=result+"&"
case chr(32)
'result=result+" "
if i+1<=l and i-1>0 then
if mid(str,i+1,1)=chr(32) or mid(str,i+1,1)=chr(9) or mid(str,i-1,1)=chr(32) or mid(str,i-1,1)=chr(9) then
result=result+" "
else
result=result+" "
end if
else
result=result+" "
end if
case chr(9)
result=result+" "
case else
result=result+mid(str,i,1)
end select
next
Htmlout=result
End Function
'rem ---textarea显示用---
function htmlencode1(fString)
if fString<>"" and not isnull(fString) then
fString = replace(fString, ">", ">")
fString = replace(fString, "<", "<")
fString = Replace(fString, " ", chr(32))
fString = Replace(fString, "</p><p>", CHR(10) & CHR(10))
fString = Replace(fString, "<br>", CHR(10))
htmlencode1=fString
else
htmlencode1=""
end if
end function
'rem ---页面显示用---
function htmlencode2(fString)
if fString<>"" and not isnull(fString) then
fString = replace(fString, ">", ">")
fString = replace(fString, "<", "<")
fString = Replace(fString, chr(32), " ")
fString = Replace(fString, CHR(10) & CHR(10), "</p><p>")
fString = Replace(fString, CHR(10), "<br>")
htmlencode2=fString
else
htmlencode2=""
end if
end function
'rem ---取出指定字符串前后的字符串方法---
function GetStrs(str1,CharFlag,Dflag)
dim tmpstr
if Dflag=0 then'取左
pos1=instr(str1,charFlag)
if pos1<=20 then
tmpstr=left(str1,pos1-1)
else
tmpstr=mid(str1,pos1-20,20)
end if
else '取右
pos1=instr(str1,charFlag)+len(charFlag)
if len(str1)-pos1<=20 then
tmpstr=right(str1,len(str1)-pos1)
else
tmpstr=mid(str1,pos1+1,20)
end if
end if
GetStrs=tmpstr
end function
'rem ---取出文件名---
function getfilename(str)
pos=instr(str,".")
if str<>"" then
str=mid(str,pos,len(str))
end if
getfilename=str
end function
'rem ---取到浏览器版本转换字符串---
function browser()
dim text
text = Request.ServerVariables("HTTP_USER_AGENT")
if Instr(text,"MSIE 5.5")>0 then
browser="IE 5.5"
elseif Instr(text,"MSIE 6.0")>0 then
browser="IE 6.0"
elseif Instr(text,"MSIE 5.01")>0 then
browser="IE 5.01"
elseif Instr(text,"MSIE 5.0")>0 then
browser="IE 5.00"
elseif Instr(text,"MSIE 4.0")>0 then
browser="IE 4.01"
else
browser="未知"
end if
end function
'rem ---取到系统脚本转换字符串---
function system(text)
if Instr(text,"NT 5.1")>0 then
system=system+"Windows XP"
elseif Instr(text,"NT 5")>0 then
system=system+"Windows 2000"
elseif Instr(text,"NT 4")>0 then
system=system+"Windows NT4"
elseif Instr(text,"4.9")>0 then
system=system+"Windows ME"
elseif Instr(text,"98")>0 then
system=system+"Windows 98"
elseif Instr(text,"95")>0 then
system=system+"Windows 95"
else
system=system+"未知"
end if
end function
'rem ---=删除文件---
function delfile(filepath)
imangepath=trim(filepath)
path=server.MapPath(imangepath)
SET fs=server.CreateObject("Scripting.FileSystemObject")
if FS.FileExists(path) then
FS.DeleteFile(path)
end if
set fs=nothing
end function
'rem ---得到真实的客户端IP---
Public Function GetClientIP()
dim uIpAddr
' 本函数参考webcn.Net/AspHouse 文献<取真实的客户IP>
uIpAddr = Request.ServerVariables("HTTP_X_FORWARDED_FOR")
If uIpAddr = "" Then uIpAddr = Request.ServerVariables("REMOTE_ADDR")
GetClientIP = uIpAddr
uIpAddr = ""
End function
'------用正则表达式突出显示字符串中查询到的单词的函数
Function BoldWord(strContent,word)
dim objRegExp
Set objRegExp=new RegExp
objRegExp.IgnoreCase =true
objRegExp.Global=True
objRegExp.Pattern="(" & word & ")"
strContent=objRegExp.Replace(strContent,"<font color=""#FF0000"">$1</font>" )
Set objRegExp=Nothing
BoldWord=strContent
End Function
'----------------------------------------
'检查sql字符串中是否有单引号，有则进行转化
function CheckStr(str)
dim tstr,l,i,ch
l=len(str)
for i=1 to l
ch=mid(str,i,1)
if ch="'" then
tstr=tstr+"'"
end if
tstr=tstr+ch
next
CheckStr=tstr
end function
'-------判断文章中文字符数量
function strLength(str)
ON ERROR RESUME NEXT
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
'-------------------------------------
'遍历目录以及目录下文件的函数
function bianli(path)
set fso=server.CreateObject("scripting.filesystemobject")
on error resume next
set objFolder=fso.GetFolder(path)
set objSubFolders=objFolder.Subfolders
for each objSubFolder in objSubFolders
nowpath=path + "\" + objSubFolder.name
Response.Write nowpath
set objFiles=objSubFolder.Files
for each objFile in objFiles
Response.Write "<br>---"
Response.Write objFile.name
next
Response.Write "<p>"
bianli(nowpath)'递归
next
set objFolder=nothing
set objSubFolders=nothing
set fso=nothing
end function
'------------------------------------------
'控制输出字符串的长度，可以区别中英文
'函数在下面，是方法是：
'strvalue("复请Email通知如果不填写则取注册Email",26)
'这里26是指26个英文字母，也就是13个汉字
function strlen(str)
dim p_len
p_len=0
strlen=0
if trim(str)<>"" then
p_len=len(trim(str))
for xx=1 to p_len
if asc(mid(str,xx,1))<0 then
strlen=int(strlen) + 2
else
strlen=int(strlen) + 1
end if
next
end if
end function
function strvalue(str,lennum)
dim p_num
dim i
if strlen(str)<=lennum then
strvalue=str
else
p_num=0
x=0
do while not p_num > lennum-2
x=x+1
if asc(mid(str,x,1))<0 then
p_num=int(p_num) + 2
else
p_num=int(p_num) + 1
end if
strvalue=left(trim(str),x)&"…"
loop
end if
end function
'----------------------------------------
'显示左边的n个字符(自动识别汉字)函数(探索者)
'rem 显示左边的n个字符(自动识别汉字)
Function LeftTrue(str,n)
If len(str)<=n/2 Then
LeftTrue=str
Else
Dim TStr
Dim l,t,c
Dim i
l=len(str)
t=l
TStr=""
t=0
for i=1 to l
c=asc(mid(str,i,1))
If c<0 then c=c+65536
If c>255 then
t=t+2
Else
t=t+1
End If
If t>n Then exit for
TStr=TStr&(mid(str,i,1))
next
LeftTrue = TStr
End If
End Function
'----------------------------------------
'生成一个不重复的随即数字
Sub CalCaPiao()
Dim strCaiPiaoNoArr()
Dim strSQL
Dim strCaiPiaoNo
strCaiPiaoNo = "01,02,03,04,05,06,07,08,09,10,11,12,13,14,15,16,17,18,19,20,21,22,23,24,25,26,27,28,29,30,31,32,33"
Dim StrTempArr(7)
Dim strZhongJiangArr(7)
strCaiPiaoNoArr = Split(strCaiPiaoNo, ",")
Dim intRand
Dim i
Dim j
i = 0
Dim find
Do While True
find = False
Randomize
intRand = Int((33 * Rnd) + 1)
For j = 0 To i - 1
If StrTempArr(j) = CStr(intRand) Then
find = True
End If
Next
If Not find Then
StrTempArr(j) = CStr(intRand)
strZhongJiangArr(i) = CStr(intRand)
'Text1(i) = strZhongJiangArr(i)
i = i + 1
If i = 7 Then
Exit Do
End If
End If
Loop
End Sub
'------------------------------------
'本函数计算两个时间的差
Function TimeDiff(sBegin, sEnd)
Dim iHourB, iMinuteB, iSecondB, iMiniSecondB
Dim iHourE, iMinuteE, iSecondE, iMiniSecondE
Dim dTimeB, dTimeE, dTimeDiff
Dim iHour, iMinute, iSecond, iMiniSecond
iHourB = clng(Left(sBegin, 2))
iMinuteB = clng(Mid(sBegin, 4, 2))
iSecondB = clng(Mid(sBegin, 7, 2))
iMiniSecondB = clng(Mid(sBegin, 10, 4))
iHourE = clng(Left(sEnd, 2))
iMinuteE = clng(Mid(sEnd, 4, 2))
iSecondE = clng(Mid(sEnd, 7, 2))
iMiniSecondE = clng(Mid(sEnd, 10, 4))
dTimeB = iHourB * 3600 + iMinuteB * 60 + iSecondB + iMiniSecondB / 1000
dTimeE = iHourE * 3600 + iMinuteE * 60 + iSecondE + iMiniSecondE / 1000
dTimeDiff = dTimeE - dTimeB
iHour = Int(dTimeDiff / 3600)
dTimeDiff = dTimeDiff - iHour * 3600
iMinute = Int(dTimeDiff / 60)
dTimeDiff = dTimeDiff - iMinute * 60
iSecond = Int(dTimeDiff)
dTimeDiff = dTimeDiff - Int(dTimeDiff)
iMiniSecond = dTimeDiff
TimeDiff = iHour & "小时" & iMinute & "分钟" & iSecond & FormatNumber(iMiniSecond, 3) & "秒"
End Function
'如何检测备注字段的字节数
'视服务器操作系统语种不同,而采取不同的方法:
'1.E文下,len(rs("field")),就行了.len("中文abc")=7
'2.Z文下,复杂一点,len("中文abc")=5
'lenB("中文abc")=10,所以需要自己写程序判断其长度.
function strLen(str)
dim i,l,t,c
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
strLen=t
end function
'------------------------------------
'FSO自写自用的几个函数
'''''使用FSO修改文件特定内容的函数
function FSOchange(filename,Target,String)
Dim objFSO,objCountFile,FiletempData
Set objFSO = Server.CreateObject("Scripting.FileSystemObject")
Set objCountFile = objFSO.OpenTextFile(Server.MapPath(filename),1,True)
FiletempData = objCountFile.ReadAll
objCountFile.Close
FiletempData=Replace(FiletempData,Target,String)
Set objCountFile=objFSO.CreateTextFile(Server.MapPath(filename),True)
objCountFile.Write FiletempData
objCountFile.Close
Set objCountFile=Nothing
Set objFSO = Nothing
End Function
'''''使用FSO读取文件内容的函数
function FSOFileRead(filename)
Dim objFSO,objCountFile,FiletempData
Set objFSO = Server.CreateObject("Scripting.FileSystemObject")
Set objCountFile = objFSO.OpenTextFile(Server.MapPath(filename),1,True)
FSOFileRead = objCountFile.ReadAll
objCountFile.Close
Set objCountFile=Nothing
Set objFSO = Nothing
End Function
''''使用FSO读取文件某一行的函数
function FSOlinedit(filename,lineNum)
if linenum < 1 then exit function
dim fso,f,temparray,tempcnt
set fso = server.CreateObject("scripting.filesystemobject")
if not fso.fileExists(server.mappath(filename)) then exit function
set f = fso.opentextfile(server.mappath(filename),1)
if not f.AtEndofStream then
tempcnt = f.readall
f.close
set f = nothing
temparray = split(tempcnt,chr(13)&chr(10))
if lineNum>ubound(temparray)+1 then
exit function
else
FSOlinedit = temparray(lineNum-1)
end if
end if
end function
''''使用FSO写文件某一行的函数
function FSOlinewrite(filename,lineNum,Linecontent)
if linenum < 1 then exit function
dim fso,f,temparray,tempCnt
set fso = server.CreateObject("scripting.filesystemobject")
if not fso.fileExists(server.mappath(filename)) then exit function
set f = fso.opentextfile(server.mappath(filename),1)
if not f.AtEndofStream then
tempcnt = f.readall
f.close
temparray = split(tempcnt,chr(13)&chr(10))
if lineNum>ubound(temparray)+1 then
exit function
else
temparray(lineNum-1) = lineContent
end if
tempcnt = join(temparray,chr(13)&chr(10))
set f = fso.createtextfile(server.mappath(filename),true)
f.write tempcnt
end if
f.close
set f = nothing
end function
''''使用FSO添加文件新行的函数
function FSOappline(filename,Linecontent)
dim fso,f
set fso = server.CreateObject("scripting.filesystemobject")
if not fso.fileExists(server.mappath(filename)) then exit function
set f = fso.opentextfile(server.mappath(filename),8,1)
f.write chr(13)&chr(10)&Linecontent
f.close
set f = nothing
end function
''''读文件最后一行的函数
function FSOlastline(filename)
dim fso,f,temparray,tempcnt
set fso = server.CreateObject("scripting.filesystemobject")
if not fso.fileExists(server.mappath(filename)) then exit function
set f = fso.opentextfile(server.mappath(filename),1)
if not f.AtEndofStream then
tempcnt = f.readall
f.close
set f = nothing
temparray = split(tempcnt,chr(13)&chr(10))
FSOlastline = temparray(ubound(temparray))
end if
end function
'''''还有，创建文件夹：
sub CreateFolder(Foldername)
Set afso = Server.CreateObject("Scripting.FileSystemObject")
if afso.folderexists(server.mappath(Foldername))=true then
else
afso.createfolder(server.mappath(foldername))
end if
set afso=nothing
end sub
'用法，createfolder(foldername)
''----------------------------------------
''检查字符串是否包含非法字符串
FUNCTION BadWords(strContent)
DIM objRegExp
Set objRegExp = new RegExp
objRegExp.IgnoreCase = true
objRegExp.Global = true
objRegExp.Pattern = "李.{0,10}某.{0,10}人|他.{0,10}妈.{0,10}的|你.{0,10}他.{0,10}妈.{0,10}的|我操.{0,10}你妈"
BadWords = objRegExp.Test(strContent)
Set objRegExp = Nothing
END FUNCTION
'---------------------------------------
'取得网站的URL的根目录
'******************************
'||Function GetRootDir()
'||Created by Cj, 2000/8/28
'||取得网站的URL的根目录
'******************************
Function GetRootDir()
If Application("RootDir") <> "" And Not isNull(Application("RootDir")) then
GetRootDir = Application("RootDir")
Exit Function
End if
dim strRoot, intRootEnd
strRoot = Request.ServerVariables("SCRIPT_NAME")
intRootEnd = Instr(2, strRoot, "/")
if intRootEnd > 1 then
strRoot = Left(strRoot, intRootEnd)
End if
Application.Lock()
Application("RootDir") = strRoot
Application.UnLock()
GetRootDir = strRoot
End Function
'------------------------------------
'这是一个后台管理的文章发布系统里的一个将copy的文字转换成html代码的函数，如果是空格会自动加 如果换行会自动加<br>也可以自己直接写HTML代码
'自建Asp函数库
'HTML/*********************
'将部分字符串转化为Html代码
function htmlencode2(str)
dim result
dim l
if isNULL(str) then
htmlencode2=""
exit function
end if
l=len(str)
result=""
dim i
for i = 1 to l
select case mid(str,i,1)
case "'"
result=result+"’"
'case ""
' result=result+">"
case chr(13)
result=result+"<br>"
'case chr(34)
' result=result+""
case "&"
result=result+"&"
case chr(32)
'result=result+" "
if i+1<=l and i-1>0 then
if mid(str,i+1,1)=chr(32) or mid(str,i+1,1)=chr(9) or mid(str,i-1,1)=chr(32) or mid(str,i-1,1)=chr(9) then
result=result+" "
else
result=result+" "
end if
else
result=result+" "
end if
case chr(9)
result=result+" "
case else
result=result+mid(str,i,1)
end select
next
htmlencode2=result
end function
'----------------------------------------
'无级分类的函数，分表格显示与下拉列表显示两种：
'数据库Db_category: CategoryID | ParentID | CategoryName
'调用：Sub CategoryType(CategoryID,num,Action,SelectedID,Style)
'Category.asp:
Sub CategoryType(CategoryID,num,Action,SelectedID,Style)
'style = 1 , 以表格显示
'style = 2 , 以下拉列表显示
if Style = 0 then
response.write "<table border='1' width='100%' cellspacing='0' cellpadding='2' bordercolorlight='#000000' bordercolordark='#FFFFFF' >"
response.write "<tr align='center'>"
response.write "<td width='10%'> 分类ID </td>"
response.write "<td width='10%'> 上级ID </td>"
response.write "<td width='*'> 分类名称 </td>"
response.write "<td width='15%'> 操作 </td></tr>"
call CategoryList(CategoryID,num,Action)
response.write "</table>"
else
response.write "<select >"
response.write "<option value='0'> ---产品根目录--- </option>"
call CategorySel(CategoryID,num,SelectedID)
response.write "</select>"
end if
end sub
Sub CategoryList(ParentID,num,Action)
sql="select CategoryID,ParentID,CategoryName from Db_Category where ParentID="&ParentID
set rs=server.createobject("adodb.recordset")
rs.open sql,conn,1,1
if not rs.eof then
Category = rs.getrows
end if
rs.close
set rs=nothing
snum = num + 1
str = Makeblank(snum,0)
if isArray(Category) then
for l=0 to ubound(Category,2)
response.Write("<tr>")
for k=0 to ubound(Category,1)
if k = ubound(Category,1) then '当显示CategoryName 时加[],其他不加
response.Write("<td>"&str&" [ "&Category(k,l)&"] "&"</td>")
else
response.Write("<td> "&Category(k,l)&" "&"</td>")
end if
next
if Action = 1 then '添加目录
response.Write("<td align='center'> <a href="/blog/CategoryAdd.asp?CategoryID="&Category(0,l)&"'>添加子类</a> </td></tr>")
elseif Action = 2 then '修改目录
response.Write("<td align='center'> <a href="/blog/CategoryEdit.asp?CategoryID="&Category(0,l)&"'>修改类别</a> </td></tr>")
elseif Action = 3 then '删除目录
response.Write("<td align='center'> <a href="/blog/CategoryDel.asp?CategoryID="&Category(0,l)&"'>删除类别</a> </td></tr>")
else '没有操作，仅浏览
response.Write("<td align='center'> --------- </td></tr>")
end if
'调用递归函数，列出下级目录
call CategoryList(Category(0,l),snum,Action)
next
set Category = nothing
end if
End Sub
Sub CategorySel(CategoryID,num,SelectedID)
sql="select CategoryID,ParentID,CategoryName from Db_Category where ParentID="&CategoryID
set rs=server.createobject("adodb.recordset")
rs.open sql,conn,1,1
if not rs.eof then
Category = rs.getrows
end if
rs.close
set rs = nothing
snum = num + 1
str = Makeblank(snum,1)
if isArray(Category) then
for l=0 to ubound(Category,2)
if Category(0,l) = SelectedID then '当显示已选择的ID时加[Selected],表示已选择
response.Write("<option value='"&Category(0,l)&"' Selected>"&str&Category(2,l)&"</option>")
else
response.Write("<option value='"&Category(0,l)&"'>"&str&Category(2,l)&"</option>")
end if
'调用递归函数，列出下级目录
call CategorySel(Category(0,l),snum,SelectedID)
next
set Category = nothing
end if
End Sub
Function Makeblank(num,Style)
if Style = 0 then
for i = 2 to num
TempStr = TempStr&" "
next
Makeblank = TempStr&"├"
else
for i = 2 to num
TempStr = TempStr&" "
next
Makeblank = TempStr&"└ "
end if
'不同的表格线:└┌┍┕┎┖┐┘┑┙┒┚┓┛├ ┤┝ ┥┞ ┦┼ ╄ ┽ ╅┣ ┫
End function
'----------------------------------------
'qq在线显示程序核心代码
Function Geturl(/blog/url)
Set Retrieval = CreateObject("Microsoft.XMLHTTP")
With Retrieval
.Open "GET", url, False, "", ""
.Send
GetURL = .ResponseText
End With
Set Retrieval = Nothing
End Function
'-----------------------------------------------
'程序说明:函数ShowChar(num)可根据num值返回0-9的位图。注意num取值范围0-9。当前只可生成一位数字代码，任意位数代码待续开放~
'ShowChar(2)
function ShowChar(num)
dim tempstr
tempstr="0x3c,0x42,0x42,0x42,0x42,0x42,0x42,0x42,0x42,0x3c|0x20,0x30,0x28,0x20,0x20,0x20,0x20,0x20,0x20,0x20|0x3c,0x66,0x60,0x60,0x30,0x18,0x0c,0x06,0x06,0x7e|0x3c,0x42,0x40,0x40,0x38,0x40,0x40,0x40,0x42,0x3c|0x20,0x30,0x30,0x28,0x28,0x24,0x24,0x7e,0x20,0x20|0x7c,0x04,0x04,0x02,0x3e,0x42,0x40,0x40,0x42,0x3c|0x3c,0x42,0x02,0x02,0x3a,0x46,0x42,0x42,0x42,0x3c|0x7e,0x20,0x20,0x10,0x10,0x08,0x08,0x04,0x04,0x04|0x3c,0x42,0x42,0x42,0x3c,0x42,0x42,0x42,0x42,0x3c|0x3c,0x42,0x42,0x42,0x5c,0x40,0x40,0x40,0x22,0x1c"
CharItem=split(tempstr,"|")
Response.ContentType ="image/x-xbitmap"
response.write "#define counter_width 8"&chr(10)&chr(13)
response.write "#define counter_height 10"&chr(10)&chr(13)
response.write "static unsigned char counter_bits[]={"&chr(10)&chr(13)
response.write CharItem(num)
response.write "};"&chr(10)&chr(13)
end function
sub show_img(num)
Dim Image
Dim Width, Height
Dim digtal
Dim Length
Dim sort
Dim imgdata(10,10)
imgdata(0,1)="0x3c":imgdata(0,2)="0x42":imgdata(0,3)="0x42":imgdata(0,4)="0x42":imgdata(0,5)="0x42":imgdata(0,6)="0x42":imgdata(0,7)="0x42":imgdata(0,8)="0x42":imgdata(0,9)="0x42":imgdata(0,10)="0x3c"
imgdata(1,1)="0x20":imgdata(1,2)="0x30":imgdata(1,3)="0x28":imgdata(1,4)="0x20":imgdata(1,5)="0x20":imgdata(1,6)="0x20":imgdata(1,7)="0x20":imgdata(1,8)="0x20":imgdata(1,9)="0x20":imgdata(1,10)="0x20"
imgdata(2,1)="0x3c":imgdata(2,2)="0x66":imgdata(2,3)="0x60":imgdata(2,4)="0x60":imgdata(2,5)="0x30":imgdata(2,6)="0x18":imgdata(2,7)="0x0c":imgdata(2,8)="0x06":imgdata(2,9)="0x06":imgdata(2,10)="0x7e"
imgdata(3,1)="0x3c":imgdata(3,2)="0x42":imgdata(3,3)="0x40":imgdata(3,4)="0x40":imgdata(3,5)="0x38":imgdata(3,6)="0x40":imgdata(3,7)="0x40":imgdata(3,8)="0x40":imgdata(3,9)="0x42":imgdata(3,10)="0x3c"
imgdata(4,1)="0x20":imgdata(4,2)="0x30":imgdata(4,3)="0x30":imgdata(4,4)="0x28":imgdata(4,5)="0x28":imgdata(4,6)="0x24":imgdata(4,7)="0x24":imgdata(4,8)="0x7e":imgdata(4,9)="0x20":imgdata(4,10)="0x20"
imgdata(5,1)="0x7c":imgdata(5,2)="0x04":imgdata(5,3)="0x04":imgdata(5,4)="0x02":imgdata(5,5)="0x3e":imgdata(5,6)="0x42":imgdata(5,7)="0x40":imgdata(5,8)="0x40":imgdata(5,9)="0x42":imgdata(5,10)="0x3c"
imgdata(6,1)="0x3c":imgdata(6,2)="0x42":imgdata(6,3)="0x02":imgdata(6,4)="0x02":imgdata(6,5)="0x3a":imgdata(6,6)="0x46":imgdata(6,7)="0x42":imgdata(6,8)="0x42":imgdata(6,9)="0x42":imgdata(6,10)="0x3c"
imgdata(7,1)="0x7e":imgdata(7,2)="0x20":imgdata(7,3)="0x20":imgdata(7,4)="0x10":imgdata(7,5)="0x10":imgdata(7,6)="0x08":imgdata(7,7)="0x08":imgdata(7,8)="0x04":imgdata(7,9)="0x04":imgdata(7,10)="0x04"
imgdata(8,1)="0x3c":imgdata(8,2)="0x42":imgdata(8,3)="0x42":imgdata(8,4)="0x42":imgdata(8,5)="0x3c":imgdata(8,6)="0x42":imgdata(8,7)="0x42":imgdata(8,8)="0x42":imgdata(8,9)="0x42":imgdata(8,10)="0x3c"
imgdata(9,1)="0x3c":imgdata(9,2)="0x42":imgdata(9,3)="0x42":imgdata(9,4)="0x42":imgdata(9,5)="0x5c":imgdata(9,6)="0x40":imgdata(9,7)="0x40":imgdata(9,8)="0x40":imgdata(9,9)="0x22":imgdata(9,10)="0x1c"
Length = 10 '自定计数器长度
Redim sort( Length )
digital =right(string(length,"0")&num,length)
For I = 1 To Len( digital )
sort(I) = Mid( digital, I, 1 )
Next
Width = 8 * Len( digital ) '图像的宽度
Height = 10 '图像的高度，在本例中为固定值
Response.ContentType="image/x-xbitmap"
hc=chr(13) & chr(10)
Image = "#define counter_width " & Width & hc
Image = Image & "#define counter_height " & Height & hc
Image = Image & "static unsigned char counter_bits[]={" & hc
For I = 1 To Height
For J = 1 To Length
Image = Image & imgdata(sort(J),I) & ","
Next
Next
Image = Left( Image, Len( Image ) - 1 ) '去掉最后一个逗号
Image = Image & "};" & hc
Response.Write Image
end sub
'----------------------------------------
'一套加解密字符串的函数
Function Encrypt(theNumber)
On Error Resume Next
Dim n, szEnc, t, HiN, LoN, i
n = CDbl((theNumber + 1570) ^ 2 - 7 * (theNumber + 1570) - 450)
If n < 0 Then szEnc = "R" Else szEnc = "J"
n = CStr(abs(n))
For i = 1 To Len(n) step 2
t = Mid(n, i, 2)
If Len(t) = 1 Then
szEnc = szEnc & t
Exit For
End If
HiN = (CInt(t) And 240) / 16
LoN = CInt(t) And 15
szEnc = szEnc & Chr(Asc("M") + HiN) & Chr(Asc("C") + LoN)
Next
Encrypt = szEnc
End Function
Function Decrypt(theNumber)
On Error Resume Next
Dim e, n, sign, t, HiN, LoN, NewN, i
e = theNumber
If Left(e, 1) = "R" Then sign = -1 Else sign = 1
e = Mid(e, 2)
NewN = ""
For i = 1 To Len(e) step 2
t = Mid(e, i, 2)
If Asc(t) >= Asc("0") And Asc(t) <= Asc("9") Then
NewN = NewN & t
Exit For
End If
HiN = Mid(t, 1, 1)
LoN = Mid(t, 2, 1)
HiN = (Asc(HiN) - Asc("M")) * 16
LoN = Asc(LoN) - Asc("C")
t = CStr(HiN or LoN)
If Len(t) = 1 Then t = "0" & t
NewN = NewN & t
Next
e = CDbl(NewN) * sign
Decrypt = CLng((7 + sqr(49 - 4 * (-450 - e))) / 2 - 1570)
End Function
'-----------------------------------------------
'access数据库表改名的一段代码
'Call RenameTable("Provider=Microsoft.Jet.OLEDB.4.0; Data
'Source=c:\example.mdb", "test", "changed")
Sub RenameTable (conStr, oldName, newName)
'Has to be OLE DB connection
'Create object and connect to DB...
Dim objADOXDatabase
Set objADOXDatabase = Server.CreateObject("ADOX.Catalog")
objADOXDatabase.ActiveConnection = conStr
'Change the name...
objADOXDatabase.Tables(oldName).Name = newName
'Clean up...
Set objADOXDatabase = Nothing
End Sub
'---------------------------------------------------
'分行模块，自动识别英文和型号数
Function cuttextlen(intext, lens)
If Len(intext) <= lens Then
cuttextlen = intext
Else
tmptext = intext
GetTexts = ""
Do While Not Len(tmptext) <= lens
GetTexts = GetTexts + Left(tmptext, lens)
tmptext = Right(tmptext, Len(tmptext) - lens)
Do While (Asc(Left(tmptext, 1)) >= 65 And Asc(Left(tmptext, 1)) <= 90) or (Asc(Left(tmptext, 1)) >= 97 And Asc(Left(tmptext, 1)) <= 122) or (Asc(Left(tmptext, 1)) >= 45 And Asc(Left(tmptext, 1)) <= 57)
GetTexts = GetTexts + Left(tmptext, 1)
tmptext = Right(tmptext, Len(tmptext) - 1)
'If Len(tmptext) <= lens Then Exit Do
Loop
GetTexts = GetTexts & "<br>"
Loop
cuttextlen = GetTexts & tmptext
End If
End Function
'---------------------------------------------------
';如何利用ASP将一段包含html的标签的文本转换成纯文本，并且去掉其中的所有空格和换行？难啊！
'这有何难？替换换行和空格用replace函数，去除HTML标记用下面的函数
function str_replace(s_string,start_char,end_char,place_str)
start_pos=instr(s_string,start_char)
if start_pos>0 then
end_pos=instr(start_pos,s_string,end_char)
if end_pos>0 then
s_string=left(s_string,start_pos-1)&place_str&right(s_string,len(s_string)-end_pos-len(end_char)+1)
call str_replace(s_string,start_char,end_char,place_str)
end if
end if
str_replace=s_string
end function
'受<! ＃i nclude file="filename.asp" --> 宏限制
''必须存在该文件并且会预先编译（不管前面是否加以条件）
'经常有这样的要求，根据不同的需求要求include不同的文件
'如各个人的不同设置，所以要求能动态include文件。'
'
'代码如下：
Function include(filename)
Dim re,content,fso,f,aspStart,aspEnd
set fso=CreateObject("Scripting.FileSystemObject")
set f=fso.OpenTextFile(server.mappath(filename))
content=f.ReadAll
f.close
set f=nothing
set fso=nothing
set re=new RegExp
re.pattern="^\s*="
aspEnd=1
aspStart=inStr(aspEnd,content,"<%")+2
do while aspStart>aspEnd+1
Response.write Mid(content,aspEnd,aspStart-aspEnd-2)
aspEnd=inStr(aspStart,content,"%\>")+2
Execute(re.replace(Mid(content,aspStart,aspEnd-aspStart-2),"Response.Write "))
aspStart=inStr(aspEnd,content,"<%")+2
loop
Response.write Mid(content,aspEnd)
set re=nothing
End Function
'检查是否有效邮件地址
Function CheckEmail(strEmail)
Dim re
Set re = New RegExp
re.Pattern = "^[w-.]{1,}@([da-zA-Z-]{1,}.){1,}[da-zA-Z-]{2,3}$"
re.IgnoreCase = True
CheckEmail = re.Test(strEmail)
End Function
'测试变量是否为空值，空值的含义包括：变量不存在/为空，对象为Nothing，0，空数组，字符串为空
Function IsBlank(ByRef Var)
IsBlank = False
Select Case True
Case IsObject(Var)
If Var Is Nothing Then IsBlank = True
Case IsEmpty(Var), IsNull(Var)
IsBlank = True
Case IsArray(Var)
If UBound(Var) = 0 Then IsBlank = True
Case IsNumeric(Var)
If (Var = 0) Then IsBlank = True
Case Else
If Trim(Var) = "" Then IsBlank = True
End Select
End Function
'得到浏览器目前的URL
Function GetCurURL()
If Request.ServerVariables("HTTPS") = "on" Then
GetCurrentURL = "https://"
Else
GetCurrentURL = "http://"
End If
GetCurURL = GetCurURL & Request.ServerVariables("SERVER_NAME")
If (Request.ServerVariables("SERVER_PORT") <> 80) Then GetCurURL = GetCurURL & ":" & Request.ServerVariables("SERVER_PORT")
GetCurURL = GetCurURL & Request.ServerVariables("URL")
If (Request.QueryString <> "") Then GetCurURL = GetCurURL & "?" & Request.QueryString
End Function