<% '//////////////////////////////////////////////////////////////////////// '本页:数据库控制类 '说明:本类支持ASP下Access与SqlServer数据库的无缝访问,避免了数据库编程差异问题. '要求:在使用本类进行数据库访问时,所有的Sql脚本必须与Sql Server为准 '更新:了了 853403885 '//////////////////////////////////////////////////////////////////////// Class DBControl Public Conn, DBType '初始化类 Private Sub Class_Initialize DBType = DataBase_Type End Sub '函数:创建数据库链接 '返回:链接对象 Public Function Open() On Error Resume Next Set Conn = Server.CreateObject("ADODB.CONNECTION") Conn.Open ConnStr If Err Then Response.Write "数据库连接出错,请检查连接字串。
Error,Could not open database connection for ODBC,Please check up database config!" Response.End err.Clear Set Conn = Nothing End If End Function '函数:创建数据库链接 '参数:链接串 '返回:链接对象 Public Function Close() Conn.Close Set Conn = Nothing End Function '函数:创建数据库RecordSet对象 '参数:链接串 '返回:链接对象 Public Function CreateRS() Set CreateRS = Server.CreateObject("ADODB.RecordSet") End Function '函数:根据当前数据库类型转换Sql脚本 '参数:Sql串 '返回:转换结果Sql串 Public Function SqlTran(Sql) If DBType = "ACCESS" Then SqlTran = SqlServer_To_Access(Sql) Else SqlTran = Sql End If End Function '函数:数据库脚本执行(代Sql转换) '参数:Sql脚本 '返回:执行结果 '说明:本执行可自动根据数据库类型对部分Sql基础语法进行转换执行 Public Function ExeCute(Sql) On Error Resume Next Sql = SqlTran(Sql) Set ExeCute = Conn.ExeCute(Sql) If Err.Number <> 0 Then Response.Write "数据库脚本执行失败!(时间:" & Now() & "),返回
错误:
" & Err.Description & Err.Source & "
" If PrintDBSqlWithError Then Response.Write "错误脚本:
"&Sql&"
" End If Response.End End If End Function '函数:数据库脚本执行 '参数:Sql脚本 '返回:执行结果 Public Function ExeCute2(Sql) Set ExeCute2 = Conn.ExeCute(Sql) End Function '函数:SqlServer(97-2000) to Access(97-2000) '参数:Sql,数据库类型(ACCESS,SQLSERVER) '说明: Public Function SqlServer_To_Access(Sql) Dim regEx, Matches, Match '创建正则对象 Set regEx = New RegExp regEx.IgnoreCase = True regEx.Global = True regEx.MultiLine = True '转:GetDate() regEx.Pattern = "(?=[^']?)GETDATE\(\)(?=[^']?)" Sql = regEx.Replace(Sql,"NOW()") '转:UPPER() regEx.Pattern = "(?=[^']?)UPPER\([\s]?(.+?)[\s]?\)(?=[^']?)" Sql = regEx.Replace(Sql,"UCASE($1)") '转:日期表示方式 '说明:时间格式必须是2004/23/23 11:11:10 标准格式 regEx.Pattern = "'([\d]{4,4}\/[\d]{1,2}\/[\d]{1,2}(?:[\s][\d]{1,2}:[\d]{1,2}:[\d]{1,2})?)'" Sql = regEx.Replace(Sql,"#$1#") regEx.Pattern = "DATEDIFF\([\s]?(second|minute|hour|day|month|year)[\s]?\,[\s]?(.+?)[\s]?\,[\s]?(.+?)([\s]?\)[\s]?)" Set Matches = regEx.ExeCute(Sql) Dim temStr For Each Match In Matches temStr = "DATEDIFF(" Select Case lcase(Match.SubMatches(0)) Case "second" : temStr = temStr & "'s'" Case "minute" : temStr = temStr & "'n'" Case "hour" : temStr = temStr & "'h'" Case "day" : temStr = temStr & "'d'" Case "month" : temStr = temStr & "'m'" Case "year" : temStr = temStr & "'y'" End Select temStr = temStr & "," & Match.SubMatches(1) & "," & Match.SubMatches(2) & Match.SubMatches(3) Sql = Replace(Sql,Match.Value,temStr,1,1) Next '转:Insert函数 regEx.Pattern = "CHARINDEX\([\s]?'(.+?)'[\s]?,[\s]?'(.+?)'[\s]?\)[\s]?" Sql = regEx.Replace(Sql,"INSTR('$2','$1')") Set regEx = Nothing SqlServer_To_Access = Sql End Function '注消类 Private Sub Class_Terminate End Sub End Class %> <% '//////////////////////////////////////////////////////////////////////// '网站系统公用函数库类。 'By 了了 搏仕商务服务工作室(www.bossok.com) '配置文档最后更新日期:2007-3-29 15:41:13 '说明:为全面升级做准备,全部采用类模式。 '部分代码来自原程序,原作者:小男等 '//////////////////////////////////////////////////////////////////////// Class Function_Public '########################################### '字符串处理函数 Start '以下引用原Tsys字符函数 '########################################### '函数:Cookie写 '参数:Cookie名, Cookie值, 有效时间 Public Function SetCookie(Key, Val, ExpTime) Response.Cookies("sxjk_" & Key) = Val Response.Cookies("sxjk_" & Key).Expires = ExpTime End Function '函数:Cookie读 '参数:Cookie名 '返回:cookie值 Public Function GetCookie(Key) Response.Cookies("sxjk_" & Key).Domain = "sxjk.com" Response.Cookies("sxjk_" & Key).Secure =False GetCookie = Request.Cookies("sxjk_" & Key) End Function '函数:Cookie清除 Public Function ClearCookie(Key) Response.Cookies("sxjk_" & Key) = "" End Function '//从Html标签中取出文本内容 Public Function GetTextFromHtml(strHtml) Dim strPatrn strpatrn="<.*?>" Dim regEx Set regEx = New RegExp regEx.Pattern = strPatrn regEx.IgnoreCase = True regEx.Global = True GetTextFromHtml = regEx.Replace(strHtml,"") End Function '//检测Email '//返回:True/False Public Function CheckEmail(strng) CheckEmail = false Dim regEx, Match Set regEx = New RegExp regEx.Pattern = "^\w+((-\w+)|(\.\w+))*\@[A-Za-z0-9]+((\.|-)[A-Za-z0-9]+)*\.[A-Za-z0-9]+$" regEx.IgnoreCase = True Set Match = regEx.Execute(strng) if match.count then CheckEmail= true End Function '//字符串是否在[0-9]&[a-z]及下划线中(不区分大小写) '//返回:True/False Public Function IsChar26AndInt(str) IsChar26AndInt=True Dim regEx,Match Set regEx=New RegExp regEx.Pattern="[\W]{1,}?" regEx.IgnoreCase=True Set Match=regEx.Execute(str) If Match.Count>=1 Then IsChar26AndInt=False End If End Function '//字符串是否在[a-z]中(不区分大小写) '//返回:True/False Public Function IsChar26(str) IsChar26=True Dim regEx,Match Set regEx=New RegExp regEx.Pattern="[^a-zA-Z]{1,}?" regEx.IgnoreCase=True Set Match=regEx.Execute(str) If Match.Count>=1 Then IsChar26=False End If End Function '//字符串是否在[0-9]中(不区分大小写) Public Function IsIntChar(str) IsIntChar=True Dim regEx,Match Set regEx=New RegExp regEx.Pattern="\D{1,}?" regEx.IgnoreCase=True Set Match=regEx.Execute(str) If Match.Count>=1 Then IsIntChar=False End If End Function '//中文检测 Public Function CheckChineseWord(Word) Dim I Dim TempChar For I = 1 To Len(Word) TempChar = ASC(Mid(Word,I,1)) 'Response.write TempChar If TempChar < 0 Then TempChar = TempChar + 65535 If TempChar > 41214 and TempChar < 43584 Then CheckChineseWord = "不允许使用中文全角字符!
" Exit Function End If 'If (TempChar >= 33088 and TempChar < 41378) or TempChar > 43508 Then 'CheckChineseWord = "不允许使用中文汉字!
" 'Exit Function 'End If If TempChar > 65184 Then CheckChineseWord = "含有非法字符,请确认!
" Exit Function End If Next CheckChineseWord = True End Function '------------------------------------ '看字符串里是否全由英文及下划线组成 '------------------------------------ Function CheckNotEngLishWord(Word) Dim patrn patrn="\W" If RegExpTest(patrn,Word) Then CheckNotEngLishWord="必须由字母,数字和下划线组成" Exit Function End If CheckNotEngLishWord = True End Function '------------------------------------ '非法字符检测 '------------------------------------ Function CheckNonlicetWord(Word) Dim I IF Trim(""&Word)="" Then CheckNonlicetWord = Empty Exit Function End IF Dim TempChar For I = 1 To Len(Word) TempChar = ASC(Mid(Word,I,1)) If TempChar < 0 Then TempChar = TempChar + 65535 If (TempChar>45 and TempChar<48) or (TempChar>57 and TempChar<65) or (TempChar>90 and TempChar < 95) or TempChar = 96 or (TempChar > 122 and TempChar < 33088) Then CheckNonlicetWord = "含有非法字符1!
" Exit Function End If Next 'Dim FobWords '91-92 'FobWords = Array(63,304,305,430,431,437,438,12460,12461,12462,12463,12464,12465,12466,12467,12468,12469,12470,12471,12472,12473,12474,12475,12476,12477,12478,12479,12480,12481,12482,12483,12485,12486,12487,12488,12489,12490,12496,12497,12498,12499,12500,12501,12502,12503,12504,12505,12506,12507,12508,12509,12510,12532,12533,65339,65340) 'For I = 0 to Ubound(FobWords,1) 'If Instr(Word,FobWords(I)) <>0 Then 'CheckNonlicetWord = "含有非法字符"&I&"!
" 'Exit Function 'End if 'Next CheckNonlicetWord = true End Function '------------------------------------ '检测多个数字参数传递 '------------------------------------ Public Function CheckSplitNum(Num) If Trim(""&Num)="" Then CheckSplitNum=False :Exit Function Dim patrn patrn="(^[0-9\, ]+$)" CheckSplitNum = RegExpTest(patrn,Num) End Function '------------------------------------ '正则表达式检测字符串匹配 '------------------------------------ Public Function RegExpTest(patrn,strng) Dim regEx, retVal ' 建立变量。 Set regEx = New RegExp ' 建立正则表达式。 regEx.Pattern = patrn ' 设置模式。 regEx.IgnoreCase = False ' 设置是否区分大小写。 regEx.Global = True ' 设置全程性质。 retVal = regEx.Test(strng) ' 执行搜索测试。 If retVal Then RegExpTest = True Else RegExpTest = False End If Set regEx=Nothing End Function '------------------------------------ '检测多个参数是否是空值 '------------------------------------ Public Function CheckVariableEmpty(VariableName) IF Trim(""&VariableName)="" Then CheckVariableEmpty=False Exit Function End if Dim NameArray,Checked,I Checked=false NameArray = Split(VariableName,",") For I = 0 To Ubound(NameArray) Execute("If Trim(""""&" & NameArray(I) & ") ="""" Then Checked=true") If Checked=true then Exit For Next CheckVariableEmpty = Checked End Function '------------------------------------ 'Html字符串转Js字符串 '------------------------------------ Public Function HTMLToJS(strHtml) If Trim(strHtml)="" Then HTMLToJS="" Exit Function End If strHtml=Replace(strHtml,"\","\\") strHtml=Replace(strHtml,"""","\""") strHtml=Replace(strHtml,vbCrLf,"") HTMLToJS=strHtml End Function '------------------------------------ '//扫描元素mItem是否在元素列表strItemList中 '//参数:stritemList(被扫描元素列表,各元素以逗号隔开),mItem(欲匹配元素) '//返回:True/False '//例:myCharClass.ItemInList("1,2,3,34,23","2",",") 结果:True '------------------------------------ Public Function ItemInList(strItemList,mItem) ItemInList=False If IsNull(strItemList) Or IsNull(mItem="") Then Exit Function End If strItemList=Replace(strItemList," ","") If Instr(","&strItemList&",",","&mItem&",")>=1 Then ItemInList=True End If End Function '------------------------------------ '//转换Html关键标签为Html特殊字符串 '------------------------------------ Public Function HTMLEncode(str) If Not Isnull(str) Then str = Replace(str, CHR(13), "") str = Replace(str, CHR(10) & CHR(10), "

") str = Replace(str, CHR(10), "
") str = replace(str, ">", ">") str = replace(str, "<", "<") str = replace(str, "&", "&") str = replace(str, " ", " ") str = replace(str, """", """) HTMLEncode = str End If End Function '------------------------------------ '//转换Html关键标签为Html特殊字符串(不转换硬回车及软回车符) '------------------------------------ Public Function HTMLEncode2(str) If Not Isnull(str) Then str = replace(str, ">", ">") str = replace(str, "<", "<") ' str = replace(str, "&", "&") ' str = replace(str, " ", " ") ' str = replace(str, """", """) HTMLEncode2 = str End If End Function '------------------------------------ '//函数:字符串替换 '//参数:正则表达式,被替换字符串,替换字符串 Public Function ReplaceTest(patrn,mStr,replStr) '------------------------------------ Dim regEx Set regEx = New RegExp regEx.Pattern = patrn regEx.IgnoreCase = True regEx.Global = True ReplaceTest = regEx.Replace(mStr,replStr) End Function '------------------------------------ '//函数:字符串查找 '//参数:正则表达式,被替换字符串,替换字符串 '//返回:Bool(True:找到) '------------------------------------ Public Function FindText(patrn,mStr) Dim regEx Set regEx = New RegExp regEx.Pattern = patrn regEx.IgnoreCase = True regEx.Global = True FindText = regEx.Test(mStr) End Function '------------------------------------ '过滤HTML代码 '------------------------------------ Public Function TextHtml(byval Str1) If isNULL(Str1) Then TextHtml="" Exit Function End If Str1=Replace(Str1,"&","&") Str1=Replace(Str1,"<","<") Str1=Replace(Str1,">",">") Str1=Replace(Str1,VBcrlf,"
") Str1=Replace(Str1,chr(34),""") Str1=Replace(Str1,chr(9),"   ") Str1=Replace(Str1," "," ") TextHtml=Str1 End Function '------------------------------------ '恢复HTML代码 '------------------------------------ Public Function RestoreHtml(byval Str1) If isNULL(Str1) Then TextHtml="" Exit Function End If Str1=Replace(Str1,"&","&") Str1=Replace(Str1,"<","<") Str1=Replace(Str1,">",">") Str1=Replace(Str1,"
",vbcrlf) Str1=Replace(Str1,""",chr(34)) Str1=Replace(Str1,"   ",chr(9)) Str1=Replace(Str1," "," ") RestoreHtml=Str1 End Function '------------------------------------ '过滤HTML不良代码 '作者:小樱桃 '------------------------------------ Public Function FilterHTML(v) dim str,re str = ""&v set re = New RegExp re.Global = True re.IgnoreCase = True 'str = replace(str,vbCrlf,"") str = replace(str,"\","\") str = replace(str,"'","""") str = Replace(str,"", ">") DelHtml1 = str1 End Function '------------------------------------ '过滤禁止字符串 '参数:被检测字符串,禁止字符列表(以,号隔开Const.asp) '------------------------------------ Public Function BadWord(byVal str) Dim arrBadWord arrBadWord=Split(BadWords,",",-1,1) Dim I For I=0 To UBound(arrBadWord) If arrBadWord(I)<>"" Then Str=Replace(Str,arrBadWord(I),String(Len(arrBadWord(I)),"*")) End If Next BadWord=Str End Function '------------------------------------ '检测是否含有禁止字符串 '参数:被检测字符串,禁止字符列表(以,号隔开Const.asp) '------------------------------------ Public Function CheckBadWord(ByVal str) CheckBadWord = False Str=""&Str 'Str = ReplaceTest(Str,"[,.,。  \b\s\|\(\)\:\t\r\n\\\[\]\*\+\=\-<>!@#\$%\^&\/\`~]","") Str2 = ReplaceTest(Str,"[^\u4E00-\u9FA5]","") '取中文 Str3 = ReplaceTest(Str,"[^\w]|_","") '取英文 Str = Str3 & Str2 CheckBadWord = RegExpTest(Replace(Replace(""&BadWords,"|","\|"),",","|"),Str) End Function '------------------------------------ ''转义正则表达式 '------------------------------------ Public Function TransferRegPatrn(Byref Str) Str = "" & Str Str = Replace(Str,"\","\\") Str = Replace(Str,"|","\|") Str = Replace(Str,".","\.") Str = Replace(Str,"^","\^") Str = Replace(Str,"$","\$") Str = Replace(Str,"[","\[") Str = Replace(Str,"]","\]") Str = Replace(Str,"(","\(") Str = Replace(Str,")","\)") Str = Replace(Str,"{","\{") Str = Replace(Str,"}","\}") Str = Replace(Str,"+","\+") Str = Replace(Str,"?","\?") Str = Replace(Str,",","\,") Str = Replace(Str,"=","\=") Str = Replace(Str,"!","\!") Str = Replace(Str,"-","\-") TransferRegPatrn = Str End Function '------------------------------------ '过滤电话 '------------------------------------ Public Function ReplaceTel(strng) ReplaceTel = ReplaceTest(strng,"\d{7,}","*******") End Function '------------------------------------ '输出经转意的JS '------------------------------------ Public Function JScript(Str) Str=Replace(Str,"\","\\") Str=Replace(Str,"""","\""") Str=Replace(Str,Chr(13)," ") Str=Replace(Str,Chr(10)," ") JScript=Str End Function '------------------------------------ '过滤SQL中的' '------------------------------------ Public Function SafeSql(str) SafeSql = Replace(""&Str,"'","''") End Function '------------------------------------ '过滤SQL中的通配符 '------------------------------------ Public Function FilterSqlStr(Str) Dim TempStr,Temp_I 'SQL关键字 TempStr = "[]%^" Str = ""&Str For Temp_I = 1 To Len(TempStr) Str = Replace(Str,Mid(TempStr,Temp_I,1)," "&Mid(TempStr,Temp_I,1)) Next FilterSqlStr = Str End Function '------------------------------------ '格式化定单,流水号为 00000021 '------------------------------------ Function FormatMyNumber(Num,Length) FormatMyNumber=Right(String(Length,"0")&Num,Length) End Function '------------------------------------ '截取字符,方便排版 '------------------------------------ Public Function CutStr(str,length) dim length2,i,y,TmpStr str=Trim(""&str) if str="" Then CutStr="" :Exit Function if Trim(""&length)="" Then CutStr=str :Exit Function length2=length*2 y=0 TmpStr="" if len(str)255 then y=y+2 Else y=y+1 End If If Y>length2 Then CutStr=left(TmpStr,i-1)&".." exit Function End If TmpStr=TmpStr & mid(str,i,1) Next CutStr=TmpStr End Function '------------------------------------ '得到字符串长度,中文两个字符 '------------------------------------ Public Function StrLength(str) If isNull(str) or Str = "" Then StrLength = 0 Exit function End If If len("例子") = 2 then Dim l,t,c,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 End Function '------------------------------------ '函数:格式化空格 '参数:目录串,替换字符 '------------------------------------ Public Function FormatEmpty(str, fstr) If IsNull(fstr) Or fstr = "" Then FormatEmpty = str Else FormatEmpty = Replace(str,fstr,"") End If End Function '///////////////////////////////////////////////////////////////////////// '日期转化函数开始 '--------------------------------------------------------------------------- '//参数:时间,格式模板 '//返回:格式化后的字符串 '//备注:格式化关键词详解: ' "{Y}" : 4位年 ' "{y}" : 2位年 ' "{M}" : 不补位的月 ' "{m}" : 补位的月,如03,01 ' "{D}" : 不补位的日 ' "{d}" : 补位的日 ' "{H}" : 不补位的小时 ' "{h}" : 补位的小时 ' "{MI}": 不补位的分钟 ' "{mi}": 补位的分钟 ' "{S}" : 不补位的秒 ' "{s}" : 补位的秒 Public Function FormatMyDate(myDate,Template) If Not IsDate(myDate) Or Template = "" Then FormatMyDate = Template Exit Function End If Dim mYear,mMonth,mDay,mHour,mMin,mSec mYear = Year(myDate) mMonth = Month(myDate) mDay = Day(myDate) mHour = Hour(myDate) mMin = Minute(myDate) mSec = Second(myDate) Template = Replace(Template,"{Y}",Year(myDate)) Template = Replace(Template,"{y}",Right(Year(myDate),2)) Template = Replace(Template,"{M}",Month(myDate)) Template = Replace(Template,"{m}",Right("00" & Month(myDate),2)) Template = Replace(Template,"{D}",Day(myDate)) Template = Replace(Template,"{d}",Right("00" & Day(myDate),2)) Template = Replace(Template,"{H}",Hour(myDate)) Template = Replace(Template,"{h}",Right("00" & Day(myDate),2)) Template = Replace(Template,"{MI}",Minute(myDate)) Template = Replace(Template,"{mi}",Right("00" & Minute(myDate),2)) Template = Replace(Template,"{S}",Second(myDate)) Template = Replace(Template,"{s}",Right("00" & Second(myDate),2)) FormatMyDate = Template End Function '------------------------------ ' 功能说明:检测是否日期,如不是.退出 ' 参数说明:d 要检测的参数 '------------------------------ Function CheckIsDate(Fun_Date) On Error Resume Next If IsNumeric(Fun_Date) Then Fun_Date = Cint(Fun_Date) If len(Fun_Date)< 3 Then Fun_Date = "20" & right("0"&Fun_Date,2) Fun_Date = Fun_Date & "-1" End If CheckIsDate = cDate(Fun_Date) End Function '------------------------------ ' 功能说明:算第几周的星期几是几号 ' 参数说明:y 年,ww周,week 星期 (星期一1 星期天7) FirstDayofWeek 每周的第一天(详细设置请参照VBS手册) ' 例 2005年40周星期天 GetWeekDate(2005,40,7) '------------------------------ Function GetWeekDate(y,ww,week) Dim Date1,FirstDayofWeek FirstDayofWeek=2 Date1 = Cdate(y&"-1-1") '元旦 GetWeekDate = ((Date1-Weekday(Date1,FirstDayofWeek))+(ww-1)*7+week+7) End Function '------------------------------ ' 功能说明:获得某年某月的天数 ' 参数说明:date1 年-月-日 ' 小男 http://www.sman.cn ' 例 2005年10月 GetMonthDayCount("2005-10-11")(日可要可不要) '------------------------------ Function GetMonthDayCount(date1) date1=CheckIsDate(date1) GetMonthDayCount=datediff("d",date1,dateadd("m",1,date1)) End Function '------------------------------ ' 功能说明:得到某年某月的最后一天 ' 参数说明:date1 年-月-日 ' 关联函数:GetMonthDayCount ' 例 本月 GetMonthLastDay(date)(日可要可不要) 上月 GetMonthLastDay(dateadd("m",-1,date)) 以此类推 '------------------------------ Function GetMonthLastDay(date1) date1=CheckIsDate(date1) GetMonthLastDay = Cdate( year(Date1)&"-"&month(date1) & "-" & GetMonthDayCount(date1)) End Function '------------------------------ ' 功能说明:得到某年某月的最后一天 ' 参数说明:date1 年-月-日 ' 例 本月 GetMonthFirstDay(date)(日可要可不要) 上月 GetMonthFirstDay(dateadd("m",-1,date)) 以此类推 '------------------------------ Function GetMonthFirstDay(date1) date1=CheckIsDate(date1) GetMonthFirstDay = Cdate( year(Date1)&"-"&month(date1) & "-1") End Function '------------------------------ ' 功能说明:某日所在的周的第一天的日期 ' 参数说明:date1 ' 相关函数:GetWeekDate ' 小男 http://www.sman.cn ' 例 本周 WeekFirstDay(date) 上周 WeekFirstDay(dateadd("ww",-1,date)) 以此类推 '------------------------------ Function WeekFirstDay(date1) date1=CheckIsDate(date1) WeekFirstDay = GetWeekDate(year(date1),datepart("ww",date1),1) End Function '------------------------------ ' 功能说明:某日所在的周的第最后一天的日期 ' 参数说明:date1 ' 相关函数:GetWeekDate ' 例 本周 WeekLastDay(date) 上周 WeekLastDay(dateadd("ww",-1,date)) 以此类推 '------------------------------ Function WeekLastDay(date1) date1=CheckIsDate(date1) WeekLastDay = GetWeekDate(year(date1),datepart("ww",date1),7) End Function '------------------------------------------------------------------------------------------------------- '//输入:0,1 '//返回类型:字符串 0男 1女 Public Function toSex(intNum) If Not isNumeric(intNum) Then If isNull(intNum) Then toSex="两者" End If Exit Function End If If intNum=0 Then toSex="男" Else toSex="女" End IF End Function '*************************************************** '函数名:Getfilename '功能:以时间日期为文件名 '参数:日期 '返回:20060312300530 '*************************************************** Public Function Getfilename(d) IF len(Month(d))=1 then Getfilename=year(d)&"0"&month(d)&day(d)&hour(d)&minute(d)&second(d)&cstr(int(rnd(1000))) Else Getfilename=year(d)&month(d)&day(d)&hour(d)&minute(d)&second(d)&cstr(int(rnd(1000))) End if End Function '------------------------------------------------- '函数名称:ReadTextFile '作用:利用AdoDb.Stream对象来读取gb2312格式的文本文件 '---------------------------------------------------- Function ReadFromTextFile (FileUrl,CharSet) If FileUrl = "" OR IsNull(FileUrl) Then ReadFromTextFile = "" Exit Function End If If Not FLib.IsReallyPath(FileUrl) Then FileUrl = Server.MapPath(FileUrl) End If dim str, stm set stm=server.CreateObject(Adodb_Stream_Name) stm.Type=2 '以本模式读取 stm.mode=3 stm.charset=CharSet stm.open stm.loadfromfile FileUrl str=stm.readtext stm.Close set stm=nothing ReadFromTextFile=str End Function '------------------------------------------------- '函数名称:WriteToTextFile '作用:利用AdoDb.Stream对象来写入gb2312格式的文本文件 '---------------------------------------------------- Function WriteToTextFile (FileUrl,byval Str,CharSet) If FileUrl = "" OR IsNull(FileUrl) Then WriteToTextFile = "" Exit Function End If If Not FLib.IsReallyPath(FileUrl) Then FileUrl = Server.MapPath(FileUrl) End If Dim stm set stm=server.CreateObject(Adodb_Stream_Name) stm.Type=2 '以本模式读取 stm.mode=3 stm.charset=CharSet stm.open stm.WriteText str stm.SaveToFile FileUrl,2 stm.flush stm.Close set stm=nothing End Function '//////////////////////////////////////// '作 用:读取远程的文件数据 '参 数: ' RemoteDataUrl 远程文件URL '返回:读取到的数据 Public Function readRemoteFile(RemoteDataUrl) Dim XMLHttp ' On Error Resume Next Set XMLHttp = Server.CreateObject("Microsoft.XMLHTTP") With XMLHttp .Open "Get", RemoteDataUrl, False .Send readRemoteFile = BytesToBstr(.responseBody, "GB2312") End With Set XMLHttp = Nothing End Function ' ' Function BytesToBstr(body, Cset) dim objstream set objstream = Server.CreateObject("adodb.stream") objstream.Type = 1 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 '函数:isSelfRefer() '功能:检验是否外部提交 '参数:无 '返回:True|Flase Public Function isSelfRefer() Dim sHttp_Referer, sServer_Name sHttp_Referer = CStr(Request.ServerVariables("HTTP_REFERER")) sServer_Name = CStr(Request.ServerVariables("SERVER_NAME")) If Mid(sHttp_Referer, 8, Len(sServer_Name)) = sServer_Name Then IsSelfRefer = True Else IsSelfRefer = False End If End Function '函数:GetIPr() '功能:获取用户IP '参数:无 '返回:真是IP Public Function GetIP() dim userip userip = Request.ServerVariables("HTTP_X_FORWARDED_FOR") If userip = "" Then userip = Request.ServerVariables("REMOTE_ADDR") GetIP=userip end function '函数:IsObjInstalled() '功能:检验安装组件 '参数:组建名称 '返回:True|Flase Public Function IsObjInstalled(strClassString) On Error Resume Next IsObjInstalled = False Err = 0 Dim xTestObj Set xTestObj = Server.CreateObject(strClassString) If Err = 0 Then IsObjInstalled = True If Err = -2147352567 Then IsObjInstalled = True Set xTestObj = Nothing Err = 0 End Function '函数名:SendMail '作 用:用Jmail组件发送邮件 '参 数:MailtoAddress ----收信人地址 ' MailtoName -----收信人姓名 ' Subject -----主题 ' MailBody -----信件内容 ' FromName -----发信人姓名 ' MailFrom -----发信人地址 ' Priority -----信件优先级 '************************************************** Public function SendMail(MailtoAddress,MailtoName,Subject,MailBody,FromName,MailFrom,Priority) on error resume next Dim JMail Set JMail=Server.CreateObject("JMail.Message") if err then SendMail= "
  • 没有安装JMail组件
  • " err.clear exit function end if JMail.Charset="gb2312" '邮件编码 JMail.silent=true JMail.ContentType = "text/html" '邮件正文格式 'JMail.ServerAddress=MailServer '用来发送邮件的SMTP服务器 '如果服务器需要SMTP身份验证则还需指定以下参数 JMail.MailServerUserName = MailServerUserName '登录用户名 JMail.MailServerPassWord = MailServerPassword '登录密码 JMail.MailDomain = MailDomain '域名(如果用“name@domain.com”这样的用户名登录时,请指明domain.com JMail.AddRecipient MailtoAddress,MailtoName '收信人 JMail.Subject=Subject '主题 JMail.HMTLBody=MailBody '邮件正文(HTML格式) JMail.Body=MailBody '邮件正文(纯文本格式) JMail.FromName=FromName '发信人姓名 JMail.From = MailFrom '发信人Email JMail.Priority=Priority '邮件等级,1为加急,3为普通,5为低级 JMail.Send(MailServer) SendMail =JMail.ErrorMessage JMail.Close Set JMail=nothing end function '/////////////////////////////////////////////////////////////// '文件处理函数及上传相关 'by 了了(www.bossok.com 853403885) 'last update time:2007-6-5 '------------------------------------------------ '函数:是否为服务实际路径 Public Function IsReallyPath(str) Dim regEx '创建正则对象 Set regEx = New RegExp regEx.IgnoreCase = True regEx.Global = True regEx.MultiLine = True regEx.Pattern = "^[c-z]\:.+$" IsReallyPath = regEx.Test(str) Set regEx = Nothing End Function '函数:判断路径类型 '返回: ' 1 物理路径 ' 2 站点虚路径 ' 3 网络路径 Public Function ChkPathType(strPath) Dim regEx '创建正则对象 Set regEx = New RegExp regEx.IgnoreCase = True regEx.Global = True regEx.MultiLine = False regEx.Pattern = "^[c-z]{1,1}\:.+$" If regEx.Test(strPath) Then ChkPathType = 1 Exit Function End If regEx.Pattern = "^(?:http|https){1,1}\:.+$" If regEx.Test(strPath) Then ChkPathType = 3 Exit Function End If ChkPathType = 2 Set regEx = Nothing End Function '函数检查某一目录是否存在 '参数:目录串 Public Function CheckDir(FolderPath) dim fso folderpath=Server.MapPath(".")&"\"&folderpath Set fso = Server.CreateObject(FileSystemObject_Name) If fso.FolderExists(FolderPath) then '存在 CheckDir = True Else '不存在 CheckDir = False End if Set fso = nothing End Function '函数:创建完整目录 '参数:目录串 Public Function CreateFolder(strPath) strPath = Replace(strPath,"/", "\") arrPath = Split(strPath, "\") Dim Fso, I, tmpPath, arrPath Set Fso = Server.CreateObject(FileSystemObject_Name) tmpPath = arrPath(0) For I=1 To UBound(arrPath) tmpPath = tmpPath & "\" & arrPath(I) If Not Fso.FolderExists(tmpPath) Then Fso.CreateFolder tmpPath End If Next End Function '函数:根据指定名称生成目录 '参数:目录串 Public Function MakeNewsDir(foldername) dim fso,f Set fso = Server.CreateObject(FileSystemObject_Name) Set f = fso.CreateFolder(foldername) MakeNewsDir = True Set fso = nothing End Function '************************************** '保存上传文件 '小男 2005-8 '************************************** Public Function Save_UpFile(FormName,SavePath,FileName,IsImg) Dim File_Ext,File,Msg Set file=New UpLoadClass CreateFolder Server.mappath(SavePath) File.FileType = File_Up_Type File.MaxSize = File_Up_MaxSize File.SavePath = SavePath File.AutoSave = 2 File.open() File_Ext = File.Form(FormName & "_Ext") If IsImg = True and (Trim(File_Ext)="" or Instr("/jpg/jpeg/gif/png/bmp/",Lcase(File_Ext))) = 0 Then Set File = Nothing msg = "[上传失败]\n\n请上传图片文件." Alert msg,"CLOSE",0 End if If Clng("0"& File.Form(FormName & "_Size")) <10 Then Set File = Nothing Msg = "[上传失败]\n\n文件太小." Alert msg,"CLOSE",0 End if Dim tWidth,tHeight tWidth = File.Form(FormName & "_Width") tHeight= File.Form(FormName & "_Height") If IsImg = True And Clng("0"& tWidth) > ImgWidth Then Set File = Nothing Msg = "[上传失败]\n\n图片文件太宽 . 不能超过 "&ImgWidth&" 像素 \n\n 当前图片宽度为 "&tWidth&" 像素" Alert msg,"CLOSE",0 End If If IsImg = True And Clng("0"& tHeight) > ImgHeight Then Set File = Nothing Msg = "[上传失败]\n\n图片文件太高 . 不能超过 "&ImgHeight&" 像素 \n\n 当前图片高度为 "&tHeight&" 像素" Alert msg,"CLOSE",0 End If 'Response.write SavePath 'Response.end File.save FormName,FileName & "." & File_Ext Up_Error(File.Error) Set File = Nothing Save_UpFile=SavePath & FileName & "." & File_Ext End Function '删除目录 Public Function DelFolder(FolderName) Dim My_Fso SET My_FSO=Server.CreateObject(FileSystemObject_Name) On Error Resume Next My_Fso.deletefolder(FolderName) If Err Then DelFolde = Err.Description Else DelFolde = True End If Set My_FSO=Nothing End Function '删除文件 Public Function DelFile(FileName) Dim My_Fso SET My_FSO=Server.CreateObject(FileSystemObject_Name) On Error Resume Next My_Fso.DeleteFile(Server.MapPath(FileName)) If Err Then DelFile = Err.Description Else DelFile = True End If Set My_FSO=Nothing End Function '移动文文件夹 Public Function MoveFolder(FolderName,FolderName1) Dim My_Fso SET My_FSO=Server.CreateObject(FileSystemObject_Name) On Error Resume Next FolderName=Server.MapPath(FolderName) FolderName1=Server.MapPath(FolderName1) My_Fso.MoveFolder FolderName,FolderName1 If Err Then MoveFolder = Err.Description Else MoveFolder = True End if End Function '移动文件 Public Function MoveFile(FileName,FileName1) Dim My_Fso SET My_FSO=Server.CreateObject(FileSystemObject_Name) On Error Resume Next FileName=Server.MapPath(FileName) FileName1=Server.MapPath(FileName1) My_Fso.MoveFile FileName,FileName1 If Err Then MoveFile = Err.Description Else MoveFile = True End if End Function '---------------------- '保存文件 'options True 覆盖原文件,False否 '---------------------- Public Function SaveStrToFile(Ds_TempStr,Ds_FilePath,Ds_Options) Dim My_Fso SET My_FSO=Server.CreateObject(FileSystemObject_Name) Dim Ds_Files Set Ds_Files = My_Fso.CreateTextFile (Server.MapPath(Ds_FilePath),Ds_Options) Ds_Files.write (Ds_TempStr) Ds_Files.Close() Set Ds_Files=Nothing End Function '函数:日制记录 '参数:日制内容 Public Function AddLog(msg) Dim Sql Sql = "INSERT INTO Tbl_Sys_log(remark, creator, ip, addtime)VALUES('" & Server.HtmlEncode(msg) & "', '" & Admin.UserName & "', '" & Request.ServerVariables("REMOTE_ADDR") & "', GETDATE())" Db.ExeCute(Sql) End Function '/////////////////////////////自定义函数开始////////////////////////// '------------------------------------ '记录下本页地址 '------------------------------------ Public Function MarkThisLocation() Response.Cookies("Ekchina.com")("MarkedUrl")=GetLocationURL() End Function '记下某页地址. Public Function MarkUrl(Url) Response.Cookies("Ekchina.com")("MarkedUrl")=Url End Function '------------------------------------ '读取记录下的本页地址 '------------------------------------ Public Function GetMarkedUrl() GetMarkedUrl=Trim(""&Request.Cookies("Ekchina.com")("MarkedUrl")) End Function '得到上页地址 Public Function GetReUrl() GetReUrl = Request.ServerVariables("HTTP_REFERER") End Function '得到本页地址 Public Function GetLocationURL() Dim Url Dim ServerPort,ServerName,ScriptName,QueryString ServerName = Request.ServerVariables("SERVER_NAME") ServerPort = Request.ServerVariables("SERVER_PORT") ScriptName = Request.ServerVariables("SCRIPT_NAME") QueryString = Request.ServerVariables("QUERY_STRING") Url="http://"&ServerName If ServerPort <> "80" Then Url = Url & ":" & ServerPort Url=Url&ScriptName If QueryString <>"" Then Url=Url&"?"& QueryString GetLocationURL=Url End Function '******************************** '用户相关 '******************************** '得到来自的城市 Public Function GetUser_From(P,C) On Error Resume Next GetUser_From = db.Execute("Select provinceName From tblProvince Where provinceID="&P)(0) & db.Execute("Select cityName From TblCity where cityID="&C)(0) End Function '显示省选择列表,参数为默认选择的省ID Public Function GetProvince(province) If Not IsNumeric(Province) Then Exit Function Dim TempArray,C,TempStr,Rs Set Rs=db.CreateRs() Rs.open "select provinceID,provinceName from tblProvince order by provinceID asc",db.conn,1,1,1 If Not Rs.Eof THen TempArray=Rs.GetRows() Rs.close TempStr = "" If ISArray(TempArray) Then For C= 0 To Ubound(TempArray,2) TempStr = TempStr & "" Next End if GetProvince = TempStr End Function Public Function Get_Province(province) If Not IsNumeric(Province) Then Exit Function Dim Rs Set Rs=db.CreateRs() Rs.open "select provinceID,provinceName from tblProvince where provinceID=" & cint("0" & province),db.conn,1,1,1 If Not Rs.Eof THen Get_Province =rs(1) Rs.close End Function Public Function GetCity(Province,City) Dim TempArray,C,TempStr,Rs If Not IsNumeric(Province) Or Not IsNumeric(City) Then Exit Function Set Rs=db.CreateRs() Rs.Open "select cityID,cityName from tblCity where provinceID="& CInt("0"&Province) &" order by cityID asc",db.Conn,1,1,1 If Not Rs.Eof Then TempArray=Rs.GetRows() Rs.close TempStr = ("") IF ISArray(TempArray) Then For C=0 To Ubound(TempArray,2) TempStr = TempStr & "" Next End If GetCity = TempStr End Function Function Get_City(Province,City) Dim TempArray,C,TempStr,Rs If Not IsNumeric(Province) Or Not IsNumeric(City) Then Exit Function Set Rs=db.CreateRs() Rs.Open "select cityID,cityName from tblCity where provinceID="& CInt("0"&Province) & " and cityID=" & cint("0"&City),db.Conn,1,1 If Not Rs.Eof Then Get_City = rs(1) Rs.close End Function Function GetRegion(Province,City,region) Dim TempArray,C,TempStr,Rs If Not IsNumeric(Province) Or Not IsNumeric(City) or not isnumeric(region) Then Exit Function Set Rs=db.CreateRs() Rs.Open "select regionID,regionName from tblregion where provinceID="& CInt("0"&Province) &" and cityID=" & cint("0"&city) & " order by regionID asc",Db.Conn,1,1,1 If Not Rs.Eof Then TempArray=Rs.GetRows() Rs.close TempStr = ("") IF ISArray(TempArray) Then For C=0 To Ubound(TempArray,2) TempStr = TempStr & "" Next End If Getregion = TempStr End Function Function Get_Region(Province,City,region) If Not IsNumeric(Province) Or Not IsNumeric(City) or not isnumeric(region) Then Exit Function Dim Rs Set Rs=db.CreateRs() Rs.Open "select regionID,regionName from tblregion where provinceID="& CInt("0"&Province) &" and cityID=" & cint("0"&city) & " and Regionid=" & cint("0"&Region),Db.Conn,1,1,1 If Not Rs.Eof Then Get_region =rs(1) Rs.close End Function '医院列表 Public Function GethospitalList(HospitalID) Dim TempArray,C,rs,Tempcontent Set Rs=db.CreateRs() Rs.Open "select id,[name] from viewhospital where sh=1",db.Conn,1,1,1 If Not Rs.Eof THen TempArray=Rs.GetRows() Rs.Close If ISArray(TempArray) Then Tempcontent=Tempcontent& "" For C= 0 To Ubound(TempArray,2) Tempcontent=Tempcontent&"" Next End If GethospitalList=Tempcontent End Function '根据医院选择科室 Public Function GetOffice(HospitalID,OfficeID) Dim TempArray,C,Rs Set Rs=db.CreateRs() Rs.Open"select officeID,officeName from tblOffice Where hospitalID="&Clng("0"&HospitalID),db.Conn,1,1,1 If Not Rs.Eof Then TempArray=Rs.GetRows() Rs.close IF ISArray(TempArray) Then Response.Write("") For C=0 To Ubound(TempArray,2) Response.Write("") Next End If End Function '********************************************* '判断,获取一些有用信息 '********************************************* '判断一组以逗号分隔的字符(Str1)是否在另一个同样以逗号分隔的字符(Str2)里 '返回TURE|FALSE '如 "1,3" 在 "1,2,3,4,5" 里InTheStr("1,3","1,2,3,4,5") 则返回TRUE (注:必须都在str2里才返回TRUE) Public Function InTheStr(Str1,Str2) Dim TempArray,TempI TempArray=Split(Str1,",") InTheStr=True For TempI=0 To Ubound(TempArray) If Instr(","&Lcase(Str2)&",",","&LCase(TempArray(TempI))&",") =0 Then InTheStr=False:Exit Function Next End Function '输入的日期是否年 Public Function DateHaveYear(d) IF Cstr(d)<>Cstr(cdate(d)) Then '没有年 DateHaveYear = false ELSE '有年 DateHaveYear = true End IF End Function Function FormatMyTime(myDate,x) IF Not ISDate(myDate) Then FormatMyTime="":Exit Function FormatMyTime = FormatdateTime(myDate,x) End Function '把时间转成DBL Function GetTimeValue(DateString) Dim Temp,TempStr If isNull(DateString) or isTrueDate(DateString) = 0 Then Exit Function Temp = csTr(Year(DateString)) If len(temp)<3 Then Temp = left(year(date),2) & temp End If TempStr = Temp Temp = csTr(month(DateString)) If len(temp)<2 Then Temp = "0" & temp TempStr = TempStr & Temp Temp = csTr(day(DateString)) If len(temp)<2 Then Temp = "0" & temp TempStr = TempStr & Temp Temp = csTr(Hour(DateString)) If len(temp)<2 Then Temp = "0" & temp TempStr = TempStr & Temp Temp = csTr(Minute(DateString)) If len(temp)<2 Then Temp = "0" & temp TempStr = TempStr & Temp Temp = csTr(Second(DateString)) If len(temp)<2 Then Temp = "0" & temp TempStr = TempStr & Temp GetTimeValue = cCur(TempStr) End Function '把DBL类型的时间转成时间 Function RestoreTime(DateString) If isNull(DateString) Then Exit Function DateString = cstr(DateString) If len(DateString)<8 then RestoreTime=DateString Else If len(DateString)<14 then RestoreTime = Mid(DateString,1,4) & "-" & Mid(DateString,5,2) & "-" & Mid(DateString,7,2) Else RestoreTime = Mid(DateString,1,4) & "-" & Mid(DateString,5,2) & "-" & Mid(DateString,7,2) & " " & Mid(DateString,9,2) & ":" & Mid(DateString,11,2) & ":" & Mid(DateString,13,2) End If End If End Function ' 为VBScript的isDate缺陷而编写的函数,用on error resume next也拦不住 Function isTrueDate(TStr) Dim T T = TStr T = Replace(Replace(Replace(Replace(Replace(Replace(Replace(T,"年","-"),"月","-"),"日"," "),"上午"," "),"下午"," ")," "," ")," "," ") Dim N1,N2 N1 = inStr(T,"-") If N1>0 Then N2 = inStrRev(T,"-") If N1 = N2 and N1 >0 Then isTrueDate = 0 Exit Function End If N1 = inStr(T,":") If N1>0 Then N2 = inStrRev(T,"-") If N1 = N2 and N1 >0 Then isTrueDate = 0 Exit Function End If If isDate(TStr) Then isTrueDate = 1 Else isTrueDate = 0 End If End Function '得到药品名 Public Function GetDurg_Type(Ds_Durg_TypeID) On Error Resume Next GetDurg_Type = DrugType(Ds_Durg_TypeID) End Function '************************ '得到医生值班时间代号代表的时间 Public Function GetDoctorWorkTime(x) on Error Resume Next GetDoctorWorkTime=DoctorWorkTime(x) if err then GetDoctorWorkTime="*错误*" End Function '************************ '得到付款时间 Public Function GetPayType(x) on Error Resume Next GetPayType=Ds_PayType(x) if err then GetPayType="*错误*" End Function '得到用户购卡状态 Public Function Color_Order_State(Index) Dim Color_Order Select Case Trim(""&Index) Case "0" Color_Order="Red" Case "1" Color_Order="Blue" Case "2" Color_Order="#999999" End Select Color_Order_State=""&Order_State(Index)&"" End Function '*********************** '格式化数字字符 Public Function FormatNum(Num) FormatNum=FormatNumber("0"&Num,2,-1) End Function '########################################### '动作函数 Start '########################################### '函数:通用信息提示框 '参数: ' 提示内容 ' 返回地址,详细值类型如下: ' "#" 只提示,其它不做任何操作 ' "BACK" 提示后返回前一页 ' "CLOSE" 提示后关闭窗口 ' "网址" 提示后返回指定页面 ' 是否父窗口 Public Function Alert(str,backUrl,TopWindow) If str <> "" Then Response.Write "" End Function Public Function AutoRefresh(Times,Url) Response.Clear() Dim tempcontent Response.write "" Response.write "" Response.Write "








    " & msg &"   正在返回...." End Function Public Function ResponseScript(Script,lang) If Trim(""&Lang)="" THen Lang="Javascript" Response.write "" End Function '页面跳转到错误页面,提示错误信息 'msg :错误提示 Public Function ResponseGotoUrl(msg,gotourl,times) if Times="" and not isnumeric(Times) then Times=10 end if if GotoUrl="" then GotoUrl="/" end if if msg="" then msg="
  • 没有找到该页面或出现访问限制!
  • " else msg=SafeSql(msg) end if response.Redirect "/File/Error.asp?msg="&msg&"&time="×&"&GotoUrl="&gotourl&"" end function '站外提交检测 'Referer参数,要检测的本网站来源地址 '用逗号分开可多个,可为空 '小男 2005-8 '************************************** Public Function CheckPost(Referer) Dim Url , HostName,Msg Url = Request.ServerVariables("HTTP_REFERER") HostName=Request.ServerVariables("SERVER_NAME") Msg = " 非 法 链 接 ! \n\n"&GetIP() If Mid(url,8,Len(HostName))<>HostName Then Alert msg,"BACK",0 Exit Function End if Referer = lcase(Referer) If Trim(""&Referer)<>"" Then Dim TmpArray,i,Checked Checked = false TmpArray=Split(Referer,",") For i =0 To Ubound(TmpArray) If instr(Lcase(Url),Lcase("http://"&HostName & TmpArray(i)))>0 Then 'Response.Write(Lcase("http://"&HostName & TmpArray(i))&"
    "&Url) 'Response.End() Checked = true Exit For End if Next If Not Checked Then Alert msg,"BACK",0 Exit Function End If End If End Function '************************************** '是否是POST动作 '小男 2005-8 '************************************** Public Function ISPost() If Request.ServerVariables("REQUEST_METHOD")="POST" Then ISPost=True Else ISPost=False End If End Function '************************* '把返回记录集数组 'const.asp 定义全局变量,Ds_Page(页码),Ds_PageSize(每页数量),Ds_PageCount(总页数),Ds_RecordCount(总数) Public Function GetDataRows(Sql,PageSize,Page) Dim Rs IF Not IsNumeric(Trim(""&PageSize)) Then PageSize=500 'NetFetch m 'IF PageSize > 500 Then PageSize=500 Set Rs=db.CreateRs() Rs.PageSize=PageSize Rs.Open Sql,db.Conn,1,1,1 IF Not Rs.Eof Then Page=Clng("0"&Page) IF Page>Rs.PageCount Then Page=Rs.PageCount IF Page<1 Then Page=1 Rs.AbsolutePage=Page GetDataRows=Rs.GetRows(PageSize) Ds_PageCount=Rs.PageCount Ds_Page=Page Ds_PageSize=PageSize Ds_RecordCount=Rs.RecordCount End If Rs.Close End Function ''*************************挂号通用过程'************************* Function ResponseGuaHaoSelect(SelectName,SelectIndex) Dim TempI,TempStr TempStr= "" ResponseGuaHaoSelect=TempStr End Function Function GetGuaHaoType(TypeNum) On Error Resume Next GetGuaHaoType = Ds_Register_TypeArray(TypeNum) If Err Then GetGuaHaoType = "*错误*" End Function Function GetMaxGuaHaoCount(Count,Fun_Week) Dim Fun_TempArray On Error Resume Next Err.Clear Fun_TempArray=Split(Count,",") GetMaxGuaHaoCount=Clng(Fun_TempArray(Fun_Week-1)) If Err Or GetMaxGuaHaoCount <= 0 Then GetMaxGuaHaoCount = 10 End Function '///////////////////////////自定义函数结束/////////////////////////// End Class %> <% '------------china-sms接口内容----------------------------------------------------- '名称:SendSms(UserName, UserPass, DstMobile, SmsMsg) '参数: ' UserName: 短信王用户名 ' UserPass: 短信王密码 ' DstMobile:目标手机号码 ' SmsMsg:发送内容 '功能:发送短信 '返回值: ' true,已经成功发送 ' false,未成功发送 'SmsType 1:激活短信 2:生日短信 3:节日短信 4:服务提示短信 5:特定短信 6:其它 7:定制服务 Function SendSms(intMobile,SmsMsg,SmsType) On Error Resume Next Dim intMobile1, SmsMsg1, SmsType1 intMobile1 = intMobile SmsMsg1 = SmsMsg SmsType1 = SmsType if SmsMsg1="" then SmsMsg1 = "欢迎成为三湘健康会员,您的卡已激活,登陆三湘健康网www.sxjk.com请输入用户名:"&session("sms_username")&"或卡号,密码为卡密码。祝您健康快乐!" if SmsType1=0 then SmsType1 = 1 db.execute("insert msgsend(sendnum,sendtxt,sendType) values('"&intMobile1&"', '"&SmsMsg1&"', "&SmsType1&")") If Not Err Then SendSms = True Else SendSms = False End If End Function Function SendSms_Old(DstMobile,SmsMsg) Dim objHttpRequest 'XML文档对象 Dim URL if SmsMsg="" then SmsMsg="欢迎成为三湘健康会员,您的卡已激活,登陆三湘健康网www.sxjk.com请输入用户名:"&session("sms_username")&"或卡号,密码为卡密码。祝您健康快乐!" URL ="http://web.mobset.com/SDK/Sms_Send.asp?CorpID=102797&LoginName=admin&send_no="&DstMobile&"&Timer="&now()&"&msg="&Server.URLEncode(SmsMsg) '调用MSXML,发送请求 set objHttpRequest = CreateObject("MSXML2.ServerXMLHTTP" ) if objHttpRequest is Nothing Then '返回错误 response.write "create Msxl2.ServerXMLHTTP error" exit function end if '发出请求 objHttpRequest.open "GET",URL,False objHttpRequest.send() if objHttpRequest.status <> 200 then '返回错误 response.write "Open Request Error" exit function end if '取返回信息,并且分析 dim retMsg,Ret,iRed,SendID,iRet retMsg = objHttpRequest.responseText Ret = left(retMsg,InStr(retMsg,",")-1) iRet = Cint(Ret) if iRet>0 then '判断是否发送成功 SendID = right(retMsg,len(retMsg)-InStr(retMsg,",")) response.write "发送短信成功,SmsID:"&SendID db.execute("insert into temp_sms(nums,addtime) values('"&trim(DstMobile)&"','"&now()&"')") SendSms=True exit function else response.write "发送短信失败,错误代码:"&iRet end if '释放资源 Set objHttpRequest = Nothing session("smsnum") = "" session("sms_username") = "" End Function %>
     当前位置:首页 > 健康导读 > 中国健康导读 > 正文

    2009年第七届全国广州性文化节举办时间安排

    来源:http://www.sxjk.com 发表日期:07/08 浏览次数: 作者:三湘健康网

      由中国性学会、广东省人口和计划生育委员会、广东省性学会、广州市人口和计划生育局、广东省社会科学院、广东优生优育协会、广东共创经济发展有限公司等单位联合主办的“2009第七届全国(广州)性文化节暨第十一届全国(广州)计生、性与生殖健康用品展销订货会”定于2009年10月31日至11月2日在广州锦汉展览中心隆重举办。

    第六届广州性文化节时间安排      2008广州性文化节情趣内衣走秀   广州性文化节上卖清洁剂 性文化节“不够纯粹”

      “弘扬性科学、倡导性文明、普及性教育、树立性道德、促进性健康”是历届性文化节的一贯宗旨。为全面促进和谐社会的发展,大大提高我国性健康文化产业的社会声誉和公信力,倡导和推进性健康、性和谐的性文化理念,打造一个良好的全民普及性健康知识的发展环境,本届全国(广州)性文化节将全面提升文化含量,提高参会档次,加强组织与管理,努力为国内外生殖健康行业企业搭建一个优质的合作与交流平台,将本届展会办成一次更加成功的盛会!

      组委会电话:020-86671188、86671108、86671208  广州将举行第4届性文化节 门票10元限制人数

      联系人:王小姐陈小姐白小姐                                 专家希望性文化节成广东品牌

      组委会地址:广州市流花路111号109-11广东成人用品市场(二楼办公室) 广州性文化节将首度开进校园

      邮编:510010                                                 第六届广州性文化节

      文化节网址:www.cxwhj.com成人市场网址:www.gdcrypsc.com

    >>到论坛去说两句>> 【打印文本】 】【关闭【专家在线】
    【发表评论】

    更多...

    发表评论: *
    您的笔名: * [共有评论] 查看评论 进入论坛讨论

    ·尊重网上道德,遵守《全国人大常委会关于维护互联网安全的决定》及其他各项有关法律法规

    ·承担一切因您的行为而直接或间接导致的民事或刑事法律责任

    ·新闻评论管理人员有权保留或删除其管辖评论中的任意内容

    ·您在评论系统发表的作品,本网站有权在网站内转载或引用

    ·参与评论即表明您已经阅读并接受上述条款

    【推荐阅读】
    【精彩图片】

    九种避孕方式优缺点比较

    九种避孕方式优缺点比较

    男人性爱中的六大忌

    男人性爱中的六大忌

    职场女性最害怕什么?

    职场女性最害怕什么?

    聪明女人别碰男人禁区

    聪明女人别碰男人禁区

    本站版权与免责声明

      ① 凡本站注明“来源:三湘健康网”的所有文字、图片和音视频稿件,版权均属本站所有,任何媒体、网站或个人在转载、链接、转贴或以其他方式复制发表时,必须注明“来源:三湘健康网”字样,违者本站将依法追究责任。

      ② 本站未注明“来源:三湘健康网”的文/图等稿件均为转载稿,本站转载出于传递更多信息之目的,并不意味着赞同其观点或证实其内容的真实性。如其他媒体、网站或个人从本站下载使用,必须保留本站注明的来源信息,并自负版权等法律责任。

      ③ 如本站转载稿涉及版权等问题,请作者或版权所有人在两周内速来电或来函与本站联系。

    ·1y
    ·省妇幼保健院四维B超预约 ·省妇幼专家号预约
    ·中医附一张涤教授在线预约 ·私密保养.妇科疾病.不孕不育
    ·湘雅附一、附二医院预约挂号 ·健康专家在线咨询
    ·三湘健康卡购买 ·联盟医院预约挂号协议
    症状自诊
    ·全身|便秘 咯血 发热 咳嗽 ·头颈|牙痛 声嘶 红眼 鼻塞
    ·腹部|心悸 胸痛 腹胀 腹泻 ·皮肤|瘙痒 丘疹 紫癜 红斑
    ·四肢|四肢疼痛 肌肉萎缩 ·其他|性病 便血 血尿 黄疸
    最新图片

    如何呵护您的乳房

    月经为啥叫大姨妈

    男人别碰十种女人

    热点报道
  • 性姿势性技巧真人演示 [2008-10-30] (点击:272632)
  • 史上最大男性生殖器(图) [2007-7-19] (点击:167575)
  • 阴道图 [2007-7-19] (点击:161270)
  • 女性外生殖器结构图 [2007-2-1] (点击:47684)
  • 女性成人用品的一次亲密接触(图) [2009-6-16] (点击:43364)
  • 告诉你真实的处女膜(图) [2006-3-15] (点击:39908)
  • 阴蒂(图) [2007-7-19] (点击:31240)
  • 流行于年轻人的另类性爱图 [2006-9-1] (点击:27836)
  • 聪明女人别碰男人禁区 [2007-8-30] (点击:26236)
  • 处女膜修复:处女膜是怎样修复的 [2008-12-27] (点击:26149)
  • 健康指南
    <% conn.close set conn=nothing %>