<%
'***********************************
'功能描述：将日期转换成指定的显示格式
'入口参数：
'dtDateValue 想显示的日期
'iDateFormat 日期显示的方式
'iDataFormat=0 2000-10-10 下午 12:17:45
'iDataFormat=1 2000-10-10 23:17:45
'iDataFormat=2 2000-10-10 23:45
'iDataFormat=3 00-10-10 23:45
'iDataFormat=4 10-10 23:45
'iDataFormat=5 2000-10-10
'iDataFormat=6 00-10-10
'iDataFormat=7 10-10
'iDataFormat=8 2000年10月10日
'出口参数：转换后的日期格式
'函数作者：徐仪
'修改时间：2002-9-3
'***********************************
Public Function FormatDT(dtDateValue, iDateFormat)
Dim nowdate, y, m, d, h, i, s, t, APM, hAPM
y = Year(dtDateValue)
m = Month(dtDateValue)
d = Day(dtDateValue)
h = Hour(dtDateValue)
i = Minute(dtDateValue)
s = Second(dtDateValue)
IF h > 12 Then
APM = "下午 "
hAPM = CStr(CInt(h) Mod 12)
Else
APM = "上午 "
hAPM = h
End IF
Select Case iDateFormat
Case 0
FormatDT = y & "-" & m & "-" & d & " " & APM & hAPM & ":" & i & ":" & s
Case 1
FormatDT = y & "-" & m & "-" & d & " " & h & ":" & i & ":" & s
Case 2
FormatDT = y & "-" & m & "-" & d & " " & h & ":" & i
Case 3
FormatDT = Right(y, 2) & "-" & m & "-" & d & " " & h & ":" & i
Case 4
FormatDT = m & "-" & d & " " & h & ":" & i
Case 5
FormatDT = y & "-" & m & "-" & d
Case 6
FormatDT = Right(y, 2) & "-" & m & "-" & d
Case 7
FormatDT = m & "-" & d
Case 8
FormatDT = y & "年" & m & "月" & d & "日"
End Select
End Function
'***********************************
'功能描述：将文字转化为用于适合网页显示的格式
'入口参数：
'sStr 需要转换的字符串
'出口参数：转换后的字符串
'函数作者：徐仪
'修改时间：2002-9-3
'***********************************
Public Function HtmlOut(sStr)
IF isnull(sStr) or sStr="" Then
htmlOut=sStr
exit Function
End IF
sStr=Replace(sStr," "," ")
sStr=Replace(sStr," ","`nbsp;")
' sStr=server.asplencode(sStr)
sStr=Replace(sStr,"nbsp;"," ")
sStr=Replace(sStr,vbcrlf,"<BR>")
sStr=Replace(sStr,vbTab," ")
' HtmlOut=" "&sStr
HtmlOut=sStr
End Function
'***********************************
'功能描述：跳到用户指定的网页
'入口参数：
'sHtmlUrl 跳转的新网页
'出口参数：无
'函数作者：徐仪
'修改时间：2002-9-3
'***********************************
Public Function URL(sHtmlUrl)
Response.Write "<meta http-equiv='refresh' content='0; url="&sHtmlUrl&"'>"
End Function
'***********************************
'功能描述：显示用户给出的提示信息（弹出窗口）
'入口参数：
'sMsg 显示日期
'出口参数：无
'函数作者：徐仪
'修改时间：2002-9-3
'***********************************
Public Function MsgBox(sMsg)
Response.Write "<script language=JavaScript>{alert('提示："&sMsg&"！！');location.href = 'javascript:history.go(-1)';}</script>"
Response.End
End Function
'***********************************
'功能描述：根据用户指定的日期生成对应的中文星期
'入口参数：
'dtDateValue 显示日期
'出口参数：格式化后的中文星期
'函数作者：徐仪
'修改时间：2002-9-3
'***********************************
Public Function DispChinaWeek(dtDateValue)
Select Case weekday(dtDateValue)
Case "1" DispChinaWeek="星期日"
Case "2" DispChinaWeek="星期一"
Case "3" DispChinaWeek="星期二"
Case "4" DispChinaWeek="星期三"
Case "5" DispChinaWeek="星期四"
Case "6" DispChinaWeek="星期五"
Case "7" DispChinaWeek="星期六"
End Select
End Function
'***********************************
'功能描述：在字符串的前或后的位置加上指定的重复的字符串
'例： Response.Write FillChar("1",3,"0",1)
' 输出结果 001
'入口参数：
'sStr 要操作的字符串
'iLen 填充后字符中的总长度
'sMode 填充文字
'iPosition 填充的位置 1：加在字符串前面 其他：加在字符串后面
'出口参数：无
'函数作者：徐仪
'修改时间：2002-9-3
'***********************************
Public Function FillChar(sStr,iLen,sFillChar,iPosition)
if (sFillChar<>"") then
sStr=trim(sStr)
sStrLen=len(sStr)
iAddLen=iLen - sStrLen
IF (iAddLen<1) Then
iAddLen=0
End IF
IF (iAddLen>=1) Then
For i=1 to iAddLen
AddsStr=AddsStr&sFillChar
Next
end IF
IF (iPosition=1) Then
sStr=AddsStr&sStr
else
sStr=sStr&AddsStr
End IF
FillChar=sStr
else
FillChar=sStr
end if
End Function
'***********************************
'从数据库中提取内容生成下拉菜单
'Conn 为数据库联接
'table为表名
'style下接菜单样式
'column1显示的字段
'column2字段的值
Public Function makesqlSelect(name,sql,value,Conn,column1,column2)
SET Re=Server.CreateObject("ADODB.Recordset")
Re.Open sql,Conn,adOpenStatic, adLockReadOnly, adCmdText
Response.Write ("<Select Class=""Select"" name="&name&">")
While Re.EOF<>true
IF trim(re(""&column2&""))=trim(value) Then
Selected=" Selected "
else
Selected=" "
End IF
Response.Write("<Option" & Selected & "value=""" & trim(re(""&column2&"")) & """>" & trim(re(""&column1&"")) & "</Option>")
Re.MoveNext
wEnd
SET Re=Nothing
Response.Write ("</Select>")
End Function
Function CheckValue(Title,CheckString,Mode,LengMin,LengMax)
'Mode 说明
'0 程序检查
'1 （用户名） 数字、字母、下划线检查
'2 （密码） 数字、字母检查
'3 （电子邮件）
'4 （网站）
'5 （电话） 数字中划线
'6 （邮编） 数字检查
CharNumDownLinePattern="[a-zA-Z0-9_-]"
CharNumPattern="[a-zA-Z0-9]"
EmailPattern="^(\w-)+(\.(\w-)+)*@(\w-)+(\.((\w-)*))*+\.[a-zA-Z]{2,3}$"
HttpPattern="^[a-zA-z]+://(\w+(-\w+)*)(\.(\w+(-\w+)*))*(\?\S*)?$"
PhonePattern="^[0-9]+[0-9-]+[0-9]"
NumPattern="^[0-9]+[0-9]+[0-9]"
CodePattern="^[0-9]+[0-9]+[0-9]"
ErrLEndown=Title&" 的长度太短了！不能少于"&LengMin&"个字符！<BR>"
ErrLenUp=Title&" 的长度太长了！不能超过"&LengMax&"个字符！<BR>"
ErrEqual=Title&" 的长度必须是"&LengMax&"个字符！<BR>"
ErrEmpty=Title&" 不能不写！<BR>"
ErrCharNumDownLinePattern=Title&" 的格式错误！"&Title&"只能用字符、数字和下划线组成。<BR>"
ErrCharNumPattern=Title&" 的格式错误！"&Title&"只能用字符和数字组成。<BR>"
ErrEmail=Title&" 的格式错误！正确的格式应该是 yourname@domain.com ！<BR>"
ErrHttp=Title&" 的格式错误！正确的格式应该是 www.yoursite.com ！<BR>"
ErrPhone=Title&" 的格式错误！"&Title&"只能用数字和中划线组成。注：请不要使用全角的符号！也不要用（）号<BR>"
ErrNum=Title&" 的格式错误！"&Title&"只能用数字组成。<BR>"
ErrCode="请不要在 "&Title&" 的输入框中输入<"&"% 或 %"&">！<BR>"
mode =int(mode)
if (LengMin) and (LengMin<>LengMax) then
if (len(CheckString)<LengMin) then
if (LengMin<>1) then
CheckMsg = CheckMsg& ErrLEndown
else
CheckMsg = CheckMsg& ErrEmpty
End if
End if
End if
if (LengMax) and (LengMin<>LengMax) then
if (len(CheckString)>LengMax) then
CheckMsg = CheckMsg& ErrLenUp
End if
End if
if (LengMin=LengMax) and (LengMin<>0) then
if (len(CheckString)<>LengMax) then
CheckMsg = CheckMsg& ErrEqual
End if
End if
Select Case Mode
Case "1" Pattern=CharNumDownLinePattern
Case "2" Pattern=CharNumPattern
Case "3" Pattern=EmailPattern
Case "4" Pattern=HttpPattern
Case "5" Pattern=PhonePattern
Case "6" Pattern=NumPattern
Case Else Pattern=CodePattern
' Case "7" week="星期六"
End Select
Dim re
Set re = new RegExp
re.IgnoreCase = false
re.global = false
re.Pattern = Pattern
ErrMsgCheck=""
if (Not re.Test(CheckString)) and (len(CheckString)>0) then
Select Case Mode
Case "1" ErrMsgCheck = ErrCharNumDownLinePattern
Case "2" ErrMsgCheck = ErrCharNumPattern
Case "3" ErrMsgCheck = ErrEmail
Case "4" ErrMsgCheck = ErrHttp
Case "5" ErrMsgCheck = ErrPhone
Case "6" ErrMsgCheck = ErrNum
End Select
End if
ErrMsg=ErrMsg&CheckMsg&ErrMsgCheck
End Function
'*********************************
'从数组中提取值生成列表
'name:控件名
'classname:样式名
'value1:传入的值
'Array_x:数组
'iStart:从第几项开始取值
'iEnd:到第几项止
'****************
function makeArraySelect(name,classname,value1,Array_x,iStart,iEnd)
if classname<>"" then
classname=" class="&classname
end if
response.Write("<select name="""&name&""" "&classname&">"&vbCrLf)
for i=iStart to iEnd
if i=value1 then
selected=" selected "
else
selected=""
end if
response.Write("<option"&selected&" value="""&i&""">"&Array_x(i)&"</option>")
next
response.Write("</select>")
End function
'生成日期
Public Function MakeSelectDay (name,value)
start_value=1
End_value=31
code="<select name="&name&" class=select >"
for i=start_value to End_value
if (value=i) then
code=code&"<option value="&i&" SELECTED>"&i&"</option>"
else
code=code&"<option value="&i&">"&i&"</option>"
End if
next
code=code&"</select>"
Response.write code
End Function
'生成月份
Public Function MakeSelectMonth (name,value)
start_value=1
End_value=12
code="<select name="&name&" class=select >"
for i=start_value to End_value
if (value=i) then
code=code&"<option value="&i&" SELECTED>"&i&"</option>"
else
code=code&"<option value="&i&">"&i&"</option>"
End if
next
code=code&"</select>"
Response.write code
End Function
'生成年份的下拉菜单
'start_value，生成下拉中的开始年份
'End_value 生成下拉菜单中的结束年份
Public Function MakeSelectYear (name,value,start_value,End_value)
code="<select name="&name&" size=1>"
for i=start_value to End_value
if (value=i) then
code=code&"<option value="&i&" SELECTED>"&i&"</option>"
else
code=code&"<option value="&i&">"&i&"</option>"
End if
next
code=code&"</select>"
Response.write code
End Function
'*************************************************
'函数名：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
'**************************************************
'函数名：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+2
else
t=t+1
end if
next
strLength=t
else
strLength=len(str)
end if
if err.number<>0 then err.clear
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
'***********************************************
'函数名：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
Public Function AlertBack(Msg)
Response.Write "<script language=JavaScript>{alert('提示："&Msg&"！');location.href = 'javascript:history.go(-1)';}</script>"
Response.End
End Function
Public Function AlertBack2(Msg)
Response.Write "<script language=JavaScript>{alert('提示："&Msg&"！');location.href = 'javascript:history.go(-2)';}</script>"
Response.End
End Function
Public Function UrlMsg(sHtmlUrl,Msg)
if Msg<>"" then
Response.Write "<script language=JavaScript>{alert('提示："&Msg&"！');}</script><meta http-equiv='refresh' content='0; url="&sHtmlUrl&"'>"
else
Response.Write "<meta http-equiv='refresh' content='0; url="&sHtmlUrl&"'>"
end if
End Function
Public Function AlertClose(Msg)
Response.Write "<script language=JavaScript>{alert('提示："&Msg&"！！');window.close();}</script>"
Response.End
End Function
'*******************************************
'功能描述：判断字符串str2是否在str1中
'入口参数：
'str1，str2
'sign字符串分隔符
'出口参数：
'str2在str1中则返回true 否则返回false
'作者：梁忠光
'创建日期：2002-9-10
function str_in(str1,str2,sign)
dim m_str
if str1="" then
str_in=false
exit function
end if
m_str=split(str1,sign)
dim count
count=0
for count=0 to ubound(m_str)
if str2=m_str(count) then
exit for
end if
next
if count>ubound(m_str) then
str_in=false
else
str_in=true
end if
end function
Public Function CloseParentWin(Msg)
if Msg<>"" then
Response.Write "<script language=JavaScript>{alert('提示:"&Msg&"！！');parent.window.close();window.returnValue=1;}</script>"
Response.end
else
Response.Write "<script language=JavaScript>{parent.window.close();window.returnValue=1;}</script>"
Response.end
end if
End Function
Public Function MsgOut(Msg,href,mode)
if mode=0 then
Response.Write "<script language=JavaScript>{alert('提示:"&Msg&"！！');location.href = '"& href &"';}</script>"
Response.end
elseif mode=1 then
Response.Write "<html><LINK href='../css/admin.css' rel=stylesheet type=text/css><meta http-equiv=Content-Type content=text/html; charset=gb2312><SCRIPT LANGUAGE=javascript>alert('" & Msg & " ');window.open('" & href & "','_self'); </SCRIPT></html>"
elseif mode=2 then
Response.Write "<html><LINK href='../css/admin.css' rel=stylesheet type=text/css><meta http-equiv=Content-Type content=text/html; charset=gb2312><head><meta http-equiv=""Content-Type"" content=""text/html; charset=gb2312""></head>"
Response.Write "<body><BR><BR><p align=""center"">" & Msg & "</p>"
Response.Write "<p align=""center""><a href=""" & href & """>返回</a></p></body></html>"
elseif mode=3 then
Response.Write "<html><meta http-equiv=Content-Type content=text/html; charset=gb2312><head><meta http-equiv=""Content-Type"" content=""text/html; charset=gb2312""></head>"
Response.Write "<body><BR><BR><p align=""center""><font color=#FF0000>" & Msg & "</font></p>"
Response.Write "<p align=""center""><a href=""" & href & """>返回</a></p></body></html>"
End if
End Function
Sub ShowLastNext(PageCount,Page,Prop)
Dim query, a, x, temp
action = "http://" & Request.ServerVariables("HTTP_HOST") & Request.ServerVariables("SCRIPT_NAME")
if page>1 then
Response.Write("[<A HREF="&action&"?"&prop&"&"&"Page="&(Page-1)&" class='a1'>上一页</A>]" & vbCrLf)
End if
if page<pagecount then
Response.Write("[<A HREF="&action&"?" & prop & "&" & "Page=" & (Page+1) & " class='a1'>下一页</A>] " & vbCrLf)
End if
Response.Write(" 第 " &page& " 页 " & vbCrLf)
Response.Write(" 共 " & pageCount & " 页" & vbCrLf)
End Sub
Sub LastNextPage(pagecount,page,table_style,font_style,button_style)
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("<table width=98% cellspacing=0 cellpadding=0 border=0 class='"&table_style&"'>" & vbCrLf )
Response.Write("<form method=get onsubmit=""document.location = '" & action & "?" & temp & "Page='+ this.page.value;return false;""><TR>" & vbCrLf )
Response.Write("<TD align=right>" & vbCrLf )
Response.Write(vbCrLf )
if page<=1 then
'Response.Write ("[第一页] " & vbCrLf)
'Response.Write ("[上一页] " & vbCrLf)
else
Response.Write("[<A HREF=" & action & "?" & temp & "Page=1>第一页</A>] " & vbCrLf)
Response.Write("[<A HREF=" & action & "?" & temp & "Page=" & (Page-1) & ">上一页</A>] " & vbCrLf)
end if
if page>=pagecount then
'Response.Write ("[下一页] " & vbCrLf)
'Response.Write ("[最后一页]" & vbCrLf)
else
Response.Write("[<A HREF=" & action & "?" & temp & "Page=" & (Page+1) & ">下一页</A>] " & vbCrLf)
Response.Write("[<A HREF=" & action & "?" & temp & "Page=" & pagecount & ">最后一页</A>]" & vbCrLf)
end if
Response.Write(" 第" & "<INPUT Class='input' TYEP=TEXT NAME=page SIZE=3 Maxlength=3 VALUE=" & page & ">" & "页" & vbCrLf & "<INPUT type=submit Class='"&button_style&"' style=""font-size: 7pt"" value=GO>")
Response.Write(" 共 " & pageCount & " 页" & vbCrLf)
Response.Write("</TD>" & vbCrLf )
Response.Write("</TR></form>" & vbCrLf )
Response.Write("</table>" & vbCrLf )
End Sub
Function NoCache()
Response.Expires=0
Response.ExpiresAbsolute = Now() - 1
Response.AddHeader "Pragma","No-Cache"
Response.AddHeader "Cache-Control","Private"
Response.CacheControl = "No-Cache"
End Function
'插入日志文件
Function Insert_Log(Recorder,Operate,TableName,ModuleName)
Conn.execute("insert into Wzjt_Log(Recorder,Operate,TableName,ModuleName,IP) values ('"&Recorder&"','"&Operate&"','"&TableName&"','"&ModuleName&"','"&Request.ServerVariables("LOCAL_ADDR")&"')")
End Function
Public Function Num(table,conn,inname,outname,value)
sql3="select * from " & table &" where "&inname&"='"&value&"'"
set re=server.createobject("adodb.recordset")
re.open sql3,conn,1,1
if re.recordcount>0 then
response.Write(re(outname))
end if
re.close
set re=nothing
End function
Public Function ChangeSelect(sql,nodisplay,value,conn,name,display)
Response.Write ("<select enabled=true name='"&name&"' onchange=""change(this.value)"">")
set re=server.createobject("adodb.recordset")
re.open sql,conn,1,1
if not (re.bof and re.eof) then
response.write("<option value=""0"">--选择--</option>")
else
response.Write("<option value=""0"">目前没有分类</option>")
end if
while re.EOF<>true
if trim(re(nodisplay))=trim(value) then
selected=" selected "
else
selected=" "
end if
response.write("<option " & selected & " value=""" & trim(re(nodisplay)) & """>" & trim(re(display)) & "</option>")
re.MoveNext
wend
re.close
set re=nothing
Response.Write ("</select>")
End function
Public Function MakeSelect(sql,nodisplay,value,conn,name,display)
Response.Write ("<select enabled=true name='"&name&"' class='input'>")
set re=server.createobject("adodb.recordset")
re.open sql,conn,1,1
if not (re.bof and re.eof) then
response.write("<option value=""0"">--选择--</option>")
else
response.Write("<option value=""0"">目前没有分类</option>")
end if
while re.EOF<>true
if trim(re(nodisplay))=trim(value) then
selected=" selected "
else
selected=" "
end if
response.write("<option " & selected & " value=""" & trim(re(nodisplay)) & """>" & trim(re(display)) & "</option>")
re.MoveNext
wend
re.close
set re=nothing
Response.Write ("</select>")
End function
Public Function MsgCloseWin(Msg)
Response.Write "<script language=JavaScript>{alert('提示:"&Msg&"！！');window.returnValue=1;window.close();}</script>"
Response.end
End Function
%>