"
End Function
'**************************************************
'函数名：ReturnPictureStyle
'作 用：返回图片显示方式的标签(标签中心调用)
'参 数：PicStyle--默认选择的样式
'**************************************************
Public Function ReturnPictureStyle(PicStyle)
If PicStyle = "1" Then ReturnPictureStyle = ("") Else ReturnPictureStyle = ReturnPictureStyle & ("")
If PicStyle = "2" Then ReturnPictureStyle = ReturnPictureStyle & ("") Else ReturnPictureStyle = ReturnPictureStyle & ("")
If PicStyle = "3" Then ReturnPictureStyle = ReturnPictureStyle & ("") Else ReturnPictureStyle = ReturnPictureStyle & ("")
If PicStyle = "4" Then ReturnPictureStyle = ReturnPictureStyle & ("") Else ReturnPictureStyle = ReturnPictureStyle & ("")
If PicStyle = "5" Then ReturnPictureStyle = ReturnPictureStyle & ("") Else ReturnPictureStyle = ReturnPictureStyle & ("")
End Function
'**************************************************
'函数名：ReturnFlashStyle
'作 用：返回Flash显示方式的标签(标签中心调用)
'参 数：PicStyle--默认选择的样式
'**************************************************
Public Function ReturnFlashStyle(PicStyle)
If PicStyle = "1" Then
ReturnFlashStyle = ("")
Else
ReturnFlashStyle = ReturnFlashStyle & ("")
End If
If PicStyle = "2" Then
ReturnFlashStyle = ReturnFlashStyle & ("")
Else
ReturnFlashStyle = ReturnFlashStyle & ("")
End If
If PicStyle = "3" Then
ReturnFlashStyle = ReturnFlashStyle & ("")
Else
ReturnFlashStyle = ReturnFlashStyle & ("")
End If
If PicStyle = "4" Then
ReturnFlashStyle = ReturnFlashStyle & ("")
Else
ReturnFlashStyle = ReturnFlashStyle & ("")
End If
If PicStyle = "5" Then
ReturnFlashStyle = ReturnFlashStyle & ("")
Else
ReturnFlashStyle = ReturnFlashStyle & ("")
End If
If PicStyle = "6" Then
ReturnFlashStyle = ReturnFlashStyle & ("")
Else
ReturnFlashStyle = ReturnFlashStyle & ("")
End If
If PicStyle = "7" Then
ReturnFlashStyle = ReturnFlashStyle & ("")
Else
ReturnFlashStyle = ReturnFlashStyle & ("")
End If
End Function
'****************************************************************************
'函数名：GetFsoTypeStr
'作 用：返回系统支持的生成类型(.htm,.html,.shtml.shtm等)
'参 数：ExtType 预定选中的类型
'*****************************************************************************
Public Function GetFsoTypeStr(ExtType)
GetFsoTypeStr = ""
End Function
'**************************************************
'函数名：SaveBeyondFile
'作 用：保存远程文件到本地
'参 数：LocalFile 本地文件,BeyondFileUrl远程文件
'返回值：无
'**************************************************
Public Function ReplaceBeyondUrl(ReplaceContent, SaveFilePath)
Dim re, BeyondFile, BeyondFileUrl, SaveFileName, InstallDir, SaveImagePath
Dim LocalFile, LocalUrl, SysDomain
InstallDir = GetConfig("InstallDir")
SysDomain = GetDomain()
SysDomain = Left(SysDomain, Len(SysDomain) - 1)
If Right(InstallDir, 1) = "/" Or Right(InstallDir, 1) = "\" Then
InstallDir = Left(InstallDir, Len(InstallDir) - 1)
End If
If Left(SaveFilePath, 1) <> "/" And Left(SaveFilePath, 1) <> "\" Then
SaveFilePath = "/" & SaveFilePath
End If
Set re = New RegExp
re.IgnoreCase = True
re.Global = True
re.Pattern = "((http|https|ftp|rtsp|mms):(\/\/|\\\\){1}((\w)+[.]){1,}(net|com|cn|org|cc|tv|[0-9]{1,3})(\S*\/)((\S)+[.]{1}(gif|jpg|png|bmp)))"
Set BeyondFile = re.Execute(ReplaceContent)
Set re = Nothing
For Each BeyondFileUrl In BeyondFile
SaveFileName = Year(Now()) & Month(Now()) & Day(Now()) & MakeRandom(10) & Mid(BeyondFileUrl, InStrRev(BeyondFileUrl, "."))
LocalFile = InstallDir & SaveFilePath & SaveFileName
If InstallDir = "/" Or InstallDir = "\" Then
LocalUrl = SysDomain & SaveFilePath & SaveFileName
Else
LocalUrl = SysDomain & InstallDir & SaveFilePath & SaveFileName
End If
Call SaveBeyondFile(LocalFile, BeyondFileUrl)
ReplaceContent = Replace(ReplaceContent, BeyondFileUrl, LocalUrl)
Next
ReplaceBeyondUrl = ReplaceContent
End Function
'==================================================
'过程名：SaveBeyondFile
'作 用：保存远程的文件到本地
'参 数：LocalFileName ------ 本地文件名
'参 数：RemoteFileUrl ------ 远程文件URL
'==================================================
Function SaveBeyondFile(LocalFileName,RemoteFileUrl)
Dim SaveRemoteFile:SaveRemoteFile=True
dim Ads,Retrieval,GetRemoteData
Set Retrieval = Server.CreateObject("Microsoft.XMLHTTP")
With Retrieval
.Open "Get", RemoteFileUrl, False, "", ""
.Send
If .Readystate<>4 then
SaveRemoteFile=False
Exit Function
End If
GetRemoteData = .ResponseBody
End With
Set Retrieval = Nothing
Set Ads = Server.CreateObject("Adodb.Stream")
With Ads
.Type = 1
.Open
.Write GetRemoteData
.SaveToFile server.MapPath(LocalFileName),2
.Cancel()
.Close()
End With
Set Ads=nothing
end Function
'****************************************************
'参数说明
'Subject : 邮件标题
'MailAddress : 发件服务器的地址,如smtp.163.com
'LoginName ----登录用户名(不需要请填写"")
'LoginPass ----用户密码(不需要请填写"")
'Email : 收件人邮件地址
'Sender : 发件人姓名
'Content : 邮件内容
'Fromer : 发件人的邮件地址
'****************************************************
Public Function SendMail(MailAddress, LoginName, LoginPass, Subject, Email, Sender, Content, Fromer)
On Error Resume Next
Dim JMail
Set JMail = Server.CreateObject("JMAIL.SMTPMail") '创建一个JMAIL对象
JMail.silent = True 'JMAIL不会抛出例外错误，返回的值为FALSE跟TRUE
JMail.logging = True '启用使用日志
JMail.Charset = "GB2312" '邮件文字的代码为简体中文
JMail.ContentType = "text/html" '邮件的格式为HTML的
JMail.ServerAddress = MailAddress '发送邮件的服务器
If Not (LoginName = "" Or LoginPass = "") Then
JMail.MailServerUserName = LoginName '您的邮件服务器登录名
JMail.MailServerPassword = LoginPass '登录密码
End If
JMail.AddRecipient Email '邮件的收件人
JMail.SenderName = Sender '邮件发送者的姓名
JMail.Sender = Fromer '邮件发送者的邮件地址
JMail.Priority = 1 '邮件的紧急程序，1 为最快，5 为最慢， 3 为默认值
JMail.Subject = Subject '邮件的标题
JMail.Body = Content '邮件的内容
'由于没有用到密抄跟抄送，这里屏蔽掉这两句，如果您有需要的话，可以在这里恢复
'jmail.AddRecipientBCC Email '密件收件人的地址
'jmail.AddRecipientCC Email '邮件抄送者的地址
JMail.Execute '执行邮件发送
JMail.Close '关闭邮件对象
Set JMail = Nothing
If Err Then
SendMail = Err.Description
Err.Clear
Else
SendMail = "OK"
End If
End Function
'**************************************************
'函数名：CreateListFolder
'作 用：不限分级创建目录 形如 1\2\3\ 则在网站根目录下创建分级目录
'参 数：Folder要创建的目录
'返回值：成功返回true 否则返回Flase
'**************************************************
Public Function CreateListFolder(Folder)
Dim FSO, WaitCreateFolder, SplitFolder, CF, k
On Error Resume Next
If Folder = "" Then
CreateListFolder = False:Exit Function
End If
Folder = Replace(Folder, "\", "/")
If Right(Folder, 1) <> "/" Then
Folder = Folder & "/"
End If
If Left(Folder, 1) <> "/" Then
Folder = "/" & Folder
End If
Set FSO = CreateObject(GetConfig("FsoObjName"))
If Not FSO.FolderExists(Server.MapPath(Folder)) Then
SplitFolder = Split(Folder, "/")
For k = 0 To UBound(SplitFolder) - 1
If k = 0 Then
CF = SplitFolder(k) & "/"
Else
CF = CF & SplitFolder(k) & "/"
End If
If (Not FSO.FolderExists(Server.MapPath(CF))) Then
FSO.CreateFolder (Server.MapPath(CF))
CreateListFolder = True
End If
Next
End If
Set FSO = Nothing
If Err.Number <> 0 Then
Err.Clear
CreateListFolder = False
Else
CreateListFolder = True
End If
End Function
'**************************************************
'函数名：DeleteFolder
'作 用：删除指定目录
'参 数：FolderStr要删除的目录
'返回值：成功返回true 否则返回Flase
'**************************************************
Public Function DeleteFolder(FolderStr)
Dim FSO
On Error Resume Next
FolderStr = Replace(FolderStr, "\", "/")
Set FSO = CreateObject(GetConfig("FsoObjName"))
If FSO.FolderExists(Server.MapPath(FolderStr)) Then
FSO.DeleteFolder (Server.MapPath(FolderStr))
Else
DeleteFolder = True
End If
Set FSO = Nothing
If Err.Number <> 0 Then
Err.Clear:DeleteFolder = False
Else
DeleteFolder = True
End If
End Function
'**************************************************
'函数名：DeleteFile
'作 用：删除指定文件
'参 数：FileStr要删除的文件
'返回值：成功返回true 否则返回Flase
'**************************************************
Public Function DeleteFile(FileStr)
Dim FSO
On Error Resume Next
Set FSO = CreateObject(GetConfig("FsoObjName"))
If FSO.FileExists(Server.MapPath(FileStr)) Then
FSO.DeleteFile Server.MapPath(FileStr), True
Else
DeleteFile = True
End If
Set FSO = Nothing
If Err.Number <> 0 Then
Err.Clear:DeleteFile = False
Else
DeleteFile = True
End If
End Function
'**********************************************************************
'函数名：CheckFileShowOrNot
'参数：AllowShowExtNameStr允许的文件扩展名，ExtName实际文件扩展名
'**********************************************************************
Public Function CheckFileShowOrNot(AllowShowExtNameStr, ExtName)
If ExtName = "" Then
CheckFileShowOrNot = False
Else
If InStr(1, AllowShowExtNameStr, ExtName) = 0 Then
CheckFileShowOrNot = False
Else
CheckFileShowOrNot = True
End If
End If
End Function
'**********************************************************************
'函数名：GetFieSize
'作用：取得指定文件的大小
'参数：FilePath--文件位置
'**********************************************************************
Public Function GetFieSize(FilePath)
GetFieSize = 0
Dim FSO, F
On Error Resume Next
Set FSO = Server.CreateObject(GetConfig("FsoObjName"))
Set F = FSO.GetFile(FilePath)
GetFieSize = F.size
Set F = Nothing:Set FSO = Nothing
End Function
'*************************************************************************************
'文件备份过程
'过程名：backupdata
'参数：CurrPath原文件完整物理地址，BackPath目标备份文件完整物理地址
'*************************************************************************************
Public Function BackUpData(CurrPath, BackPath)
On Error Resume Next
Dim FSO:Set FSO = Server.CreateObject(GetConfig("FsoObjName"))
FSO.copyfile CurrPath, BackPath
If Err Then
BackUpData = False
Else
BackUpData = True
End If
FSO.Close:Set FSO = Nothing
End Function
'------------------检查某一目录是否存在-------------------
Public Function CheckDir(FolderPath)
Dim fso1
FolderPath = Server.MapPath(".") & "\" & FolderPath
Set fso1 = CreateObject(GetConfig("FsoObjName"))
If fso1.FolderExists(FolderPath) Then
'存在
CheckDir = True
Else
'不存在
CheckDir = False
End If
Set fso1 = Nothing
End Function
'------------------检查某一文件是否存在-------------------
Public Function CheckFile(FileName)
On Error Resume Next
Dim FsoObj
Set FsoObj = Server.CreateObject(GetConfig("FsoObjName"))
If Not FsoObj.FileExists(Server.MapPath(FileName)) Then
CheckFile = False
Exit Function
End If
CheckFile = True:Set FsoObj = Nothing
End Function
'-------------根据指定名称生成目录---------
Public Function MakeNewsDir(FolderName)
Dim fso1, F
Set fso1 = CreateObject(GetConfig("FsoObjName"))
Set F = fso1.CreateFolder(FolderName)
MakeNewsDir = True
Set fso1 = Nothing
End Function
'**************************************************
'函数名：WriteTOFile
'作 用：写内容到指定的html文件
'参 数：Filename ----目标文件件 如 mb\index.htm
' Content ------要写入目标文件的内容
'返回值：成功返回true ,失败返回false
'**************************************************
Public Function WriteTOFile(FileName, Content)
On Error Resume Next
Dim FSO, FileObj
Set FSO = Server.CreateObject(GetConfig("FsoObjName"))
Set FileObj = FSO.CreateTextFile(Server.MapPath(FileName), True) '创建文件
FileObj.Write Content
FileObj.Close '释放对象
Set FileObj = Nothing:Set FSO = Nothing
If Err.Number <> 0 Then
WriteTOFile = False
Else
WriteTOFile = True
End If
End Function
'**************************************************
'函数名：ReadFromFile
'作 用：写内容到指定的html文件
'参 数：Filename ----目标文件件 如 mb\index.htm
'返回值：成功返回文件内容 ,失败返回""
'**************************************************
Public Function ReadFromFile(FileName)
On Error Resume Next
Dim FsoObj, FileStreamObj, FileObj
Set FsoObj = Server.CreateObject(GetConfig("FsoObjName"))
If CheckFile(FileName) = False Then
Call Alert("错误提示:\n\n[" & Server.MapPath(FileName) & "]文件不存在", """"):Exit Function
End If
Set FileObj = FsoObj.GetFile(Server.MapPath(FileName))
Set FileStreamObj = FileObj.OpenAsTextStream(1)
If Not FileStreamObj.AtEndOfStream Then
ReadFromFile = FileStreamObj.ReadAll
Else
ReadFromFile = ""
End If
End Function
'**************************************************
'函数名：MakeRandom
'作 用：生成指定位数的随机数
'参 数： maxLen ----生成位数
'返回值：成功:返回随机数
'**************************************************
Public Function MakeRandom(ByVal maxLen)
Dim strNewPass,whatsNext, upper, lower, intCounter
Randomize
For intCounter = 1 To maxLen
upper = 57:lower = 48:strNewPass = strNewPass & Chr(Int((upper - lower + 1) * Rnd + lower))
Next
MakeRandom = strNewPass
End Function
'**************************************************
'函数名：MakeRandomChar
'作 用：生成指定位数的随机数字符串 如 "sJKD_!@KK"
'参 数： Length ----生成位数
'返回值：成功返回随机字符串
'**************************************************
Public Function MakeRandomChar(Length)
Dim I, tempS, v
Dim c(65)
tempS = ""
c(1) = "a": c(2) = "b": c(3) = "c": c(4) = "d": c(5) = "e": c(6) = "f": c(7) = "g"
c(8) = "h": c(9) = "i": c(10) = "j": c(11) = "k": c(12) = "l": c(13) = "m": c(14) = "n"
c(15) = "o": c(16) = "p": c(17) = "q": c(18) = "r": c(19) = "s": c(20) = "t": c(21) = "u"
c(22) = "v": c(23) = "w": c(24) = "x": c(25) = "y": c(26) = "z": c(27) = "1": c(28) = "2"
c(29) = "3": c(30) = "4": c(31) = "5": c(32) = "6": c(33) = "7": c(34) = "8": c(35) = "9"
c(36) = "-": c(37) = "_": c(38) = "@": c(39) = "!": c(40) = "A": c(41) = "B": c(42) = "C"
c(43) = "D": c(44) = "E": c(45) = "F": c(46) = "G": c(47) = "H": c(48) = "I": c(49) = "J": c(50) = "K"
c(51) = "L": c(52) = "M": c(53) = "N": c(54) = "O": c(55) = "P": c(56) = "Q": c(57) = "R": c(58) = "S"
c(59) = "J": c(60) = "U": c(61) = "V": c(62) = "W": c(63) = "X": c(64) = "Y": c(65) = "Z"
If IsNumeric(Length) = False Then
MakeRandomChar = "":Exit Function
End If
For I = 1 To Length
Randomize
v = Int((65 * Rnd) + 1):tempS = tempS & c(v)
Next
MakeRandomChar = tempS
End Function
'**************************************************
'函数名：GetFileName
'作 用：构造文件名。
'参 数：ArticleFsoType ----生成类型
' addDate -----添加时间,GetFileNameType--扩展名
'**************************************************
Public Function GetFileName(ArticleFsoType, AddDate, GetFileNameType)
Dim N
Randomize
N = Rnd * 10 + 5
Select Case ArticleFsoType
Case 1
GetFileName = Year(AddDate) & "/" & Month(AddDate) & "-" & Day(AddDate) & "/" & MakeRandom(N) & GetFileNameType '年/月-日/随机数+扩展名
Case 2
GetFileName = Year(AddDate) & "/" & Month(AddDate) & "/" & Day(AddDate) & "/" & MakeRandom(N) & GetFileNameType '年/月/日/随机数+扩展名
Case 3
GetFileName = Year(AddDate) & "-" & Month(AddDate) & "-" & Day(AddDate) & "/" & MakeRandom(N) & GetFileNameType '年-月-日/随机数+扩展名
Case 4
GetFileName = Year(AddDate) & "/" & Month(AddDate) & "/" & MakeRandom(N) & GetFileNameType '年/月/随机数+扩展名
Case 5
GetFileName = Year(AddDate) & "-" & Month(AddDate) & "/" & MakeRandom(N) & GetFileNameType '年-月/随机数+扩展名
Case 6
GetFileName = Year(AddDate) & Month(AddDate) & Day(AddDate) & "/" & MakeRandom(N) & GetFileNameType '年月日/随机数+扩展名
Case 7
GetFileName = Year(AddDate) & "/" & MakeRandom(N) & GetFileNameType '年/随机数+扩展名
Case 8
GetFileName = Year(AddDate) & Month(AddDate) & Day(AddDate) & MakeRandom(N) & GetFileNameType '年+月+日+随机数+扩展名
Case 9
GetFileName = MakeRandom(N) & GetFileNameType
Case 10
GetFileName = MakeRandomChar(N) & GetFileNameType '随机字符
Case Else
GetFileName = Year(AddDate) & Month(AddDate) & Day(AddDate) & GetFileNameType '12位随机数+扩展名
End Select
End Function
'**************************************************
'函数名：Alert
'作 用：弹出成功提示。
'参 数：SuccessStr ----成功提示信息
' Url ------成功提示按下"确定"转向链接
'返回值：无
'**************************************************
Public Function Alert(SuccessStr, Url)
If Url <> "" Then
Response.Write ("")
Else
Response.Write ("")
End If
End Function
'**************************************************
'函数名：AlertHistory
'作 用：弹出警告消息后,停止所在页面的执行,返回n级。
'参 数：SuccessStr ----成功提示信息
' n ------返回级数
'返回值：无
'**************************************************
Public Function AlertHistory(SuccessStr, N)
Response.Write ("")
Response.End
End Function
'**************************************************
'函数名：Confirm
'作 用：弹出成功提示。
'参 数：SuccessStr ----成功提示信息
' Url ------成功提示按下"确定"转向链接
' Url1 ------confirm按下"取消"转向链接
'返回值：无
'**************************************************
Public Function Confirm(SuccessStr, Url, Url1)
Response.Write ("")
End Function
'**************************************************
'函数名：ShowError
'作 用：显示错误信息。
'参 数：Errmsg ----出错信息
'返回值：无
'**************************************************
Public Sub ShowError(Errmsg)
With Response
.Write ("
")
.End
End With
end sub
'*****************************************************************************************
'函数名：ReturnPowerResult
'作 用：检查操作权限。
'参 数：ChannelID---所在系统(频道) 1文章系统2图片系统等 PowerOpName ---当前操作的权限名称
'返回值：允许返回true,否则返回false
'******************************************************************************************
Public Function ReturnPowerResult(ChannelID, PowerOpName)
If Request.Cookies(SiteSn)("AdminName") = "" Then
'ReturnPowerResult = True
ReturnPowerResult = False
Exit Function
ElseIf Request.Cookies(SiteSn)("SuperTF") = "1" Then '超级管理组拥有所有权限
ReturnPowerResult = True
Exit Function
Else
Select Case CInt(ChannelID)
Case 1 '文章管理中心
If Request.Cookies(SiteSn)("ArticlePower") = "0" Then '没有任何管理权
ReturnPowerResult = False
ElseIf Request.Cookies(SiteSn)("ArticlePower") = "1" Then '拥有在文章管理系统的所有权限
ReturnPowerResult = True
ElseIf Request.Cookies(SiteSn)("ArticlePower") = "2" Then '限制栏目,拥有部分权限
ReturnPowerResult = CheckPower(PowerOpName)
Else
ReturnPowerResult = False '其它情况强制退出
End If
Case 2 '图片管理中心
If Request.Cookies(SiteSn)("PicturePower") = "0" Then '没有任何管理权
ReturnPowerResult = False
ElseIf Request.Cookies(SiteSn)("PicturePower") = "1" Then '拥有图片管理系统的所有权限
ReturnPowerResult = True
ElseIf Request.Cookies(SiteSn)("PicturePower") = "2" Then '限制栏目,拥有部分权限
ReturnPowerResult = CheckPower(PowerOpName)
Else
ReturnPowerResult = False '其它情况强制退出
End If
Case 3 '下载管理中心
If Request.Cookies(SiteSn)("DownLoadPower") = "0" Then '没有任何管理权
ReturnPowerResult = False
ElseIf Request.Cookies(SiteSn)("DownLoadPower") = "1" Then '拥有下载管理系统的所有权限
ReturnPowerResult = True
ElseIf Request.Cookies(SiteSn)("DownLoadPower") = "2" Then '限制栏目,拥有部分权限
ReturnPowerResult = CheckPower(PowerOpName)
Else
ReturnPowerResult = False '其它情况强制退出
End If
Case 4 'Flash管理中心
If Request.Cookies(SiteSn)("FlashPower") = "0" Then '没有任何管理权
ReturnPowerResult = False
ElseIf Request.Cookies(SiteSn)("FlashPower") = "1" Then '拥有下载管理系统的所有权限
ReturnPowerResult = True
ElseIf Request.Cookies(SiteSn)("FlashPower") = "2" Then '限制栏目,拥有部分权限
ReturnPowerResult = CheckPower(PowerOpName)
Else
ReturnPowerResult = False '其它情况强制退出
End If
Case Else '其它非频道的检查,如发布管理,会员管理,专题管理等
ReturnPowerResult = CheckPower(PowerOpName)
End Select
End If
End Function
'结合上面ReturnPowerResult过程序使用
Public Function CheckPower(PowerOpName)
Dim PowerList, ModelPower
PowerList = Trim(Request.Cookies(SiteSn)("PowerList"))
If (PowerList <> "") And (PowerOpName <> "") Then
Select Case Left(PowerOpName, 4) '检查是否有模块的总权限
Case "KMSP"
ModelPower = "KMSPPower"
Case "KMST"
ModelPower = "KMSystemPower"
Case "KMRF"
ModelPower = "KMRefreshPower"
Case "KMUA"
ModelPower = "KMUserAdminPower"
Case "KMCT"
ModelPower = "KMConventionPower"
Case "KMTL"
ModelPower = "KMTemplatePower"
Case Else
ModelPower = ""
End Select
If ModelPower <> "" Then
If InStr(PowerList, PowerOpName) <> 0 And InStr(1, PowerList, ModelPower, 1) <> 0 Then
CheckPower = True:Exit Function
Else
CheckPower = False:Exit Function
End If
Else
If InStr(PowerList, PowerOpName) <> 0 Then
CheckPower = True:Exit Function
Else
CheckPower = False:Exit Function
End If
End If
Else
CheckPower = False:Exit Function
End If
End Function
'结合上面ReturnPowerResult过程使用, ReturnFlag ----类型 0关闭,1返回前一页2,转向URL, Url -错误后转向的Url
Sub ReturnErr(ReturnFlag, Url)
If ReturnFlag = 0 Then
Response.Write ("")
ElseIf ReturnFlag = 1 Then
Response.Write ("")
ElseIf ReturnFlag = 2 Then
Response.Write ("")
End If
End Sub
'插入网站后台日志 , UserName --- 管理员账号 , ResultTF ---0登录失败 1---登录成功 ,ScriptName---登录路径 ,Descript---描述信息
Sub InsertLog(UserName, ResultTF, ScriptName, Descript)
Dim sqlLog, rsLog, SystemStr
SystemStr = Request.ServerVariables("HTTP_USER_AGENT")
If InStr(SystemStr, "Windows NT 5.2") Then
SystemStr = "Win2003"
ElseIf InStr(SystemStr, "Windows NT 5.0") Then
SystemStr = "Win2000"
ElseIf InStr(SystemStr, "Windows NT 5.1") Then
SystemStr = "WinXP"
ElseIf InStr(SystemStr, "Windows NT") Then
SystemStr = "WinNT"
ElseIf InStr(SystemStr, "Windows 9") Then
SystemStr = "Win9x"
ElseIf InStr(SystemStr, "unix") Or InStr(SystemStr, "linux") Or InStr(SystemStr, "SunOS") Or InStr(SystemStr, "BSD") Then
SystemStr = "类似Unix"
ElseIf InStr(SystemStr, "Mac") Then
SystemStr = "Mac"
Else
SystemStr = "Other"
End If
sqlLog = "Select top 1 * from KS_Log"
Set rsLog = Server.CreateObject("Adodb.RecordSet")
rsLog.Open sqlLog, Conn, 1, 3
rsLog.AddNew
rsLog("UserName") = UserName
rsLog("ResultTF") = ResultTF
rsLog("LoginTime") = Now()
rsLog("LoginOS") = SystemStr
rsLog("LoginIP") = Request.ServerVariables("Remote_Addr")
rsLog("ScriptName") = ScriptName
rsLog("Description") = Descript
rsLog.Update
rsLog.Close:Set rsLog = Nothing
End Sub
'删除刷新用的缓存数据
Public Function DelApplication()
Application.Contents.Remove (SiteSN & "FolderNameAndLinkStr")
Application.Contents.Remove (SiteSN & "CurrTid")
Application.Contents.Remove (SiteSN & "CurrPath")
Application.Contents.Remove (SiteSN & "RefreshSingerType")
Application.Contents.Remove (SiteSN & "RefreshMusicTempStr")
'此对象不能删除
'Application.Contents.Remove (SiteSN & "RefreshType")
Application.Contents.Remove (SiteSN & "RefreshMusicSingerTempStr")
End Function
'*************************************************************************************
'函数名:GetClassID
'作 用:生成新目录或频道的ID号
'参 数:无
'*************************************************************************************
Public Function GetClassID()
Dim RSC
Set RSC=Server.CreateObject("ADODB.RECORDSET")
'生成目录ID 年+10位随机
Do While True
GetClassID = Year(Now()) & MakeRandom(10)
RSC.Open "Select ID from KS_Class Where ID='" & GetClassID & "'", Conn, 1, 1
If RSC.EOF And RSC.BOF Then Exit Do
Loop
RSC.Close:Set RSC = Nothing
End Function
'*************************************************************************************
'函数名:GetInfoID
'作 用:生成文章,图片或下载等的唯一ID
'参 数:ChannelID--频道ID
'*************************************************************************************
Public Function GetInfoID(ChannelID)
On Error Resume Next
Dim RSC, TableNameStr
Set RSC=Server.CreateObject("ADODB.RECORDSET")
Select Case ChannelID
Case 1
TableNameStr = "Select NewsID From KS_Article Where NewsID='"
Case 2
TableNameStr = "Select PicID From KS_Photo Where PicID='"
Case 3
TableNameStr = "Select DownID From KS_DownLoad Where DownID='"
Case 4
TableNameStr = "Select FlashID From KS_Flash Where FlashID='"
End Select
Do While True
GetInfoID = Replace(Replace(Replace(Replace(Replace(Replace(Replace(Now(), "-", ""), " ", ""), ":", ""), "PM", ""), "AM", ""), "上午", ""), "下午", "") & MakeRandom(3)
RSC.Open TableNameStr & GetInfoID & "'", Conn, 1, 1
If RSC.EOF And RSC.BOF Then Exit Do
Loop
RSC.Close:Set RSC = Nothing
End Function
'*************************************************************************************
'函数名:ReplaceInnerLink
'作 用:替换站内链接
'参 数:Content-待替换内容
'*************************************************************************************
Public Function ReplaceInnerLink(Content)
Dim InnerRS:Set InnerRS=Server.CreateObject("ADODB.RECORDSET")
Dim Title, OpenTypeStr
Dim Refresh:Set Refresh = New RefreshFunction
InnerRS.Open "Select Title,Url,OpenType From KS_InnerLink Where OpenTF=1", Conn, 1, 1
Do While Not InnerRS.EOF
Title = InnerRS(0)
OpenTypeStr = Refresh.GetOpenTypeStr(InnerRS(2))
Content = Replace(Content, Title, "" & Title & "")
InnerRS.MoveNext
Loop
InnerRS.Close:Set InnerRS = Nothing:Set Refresh = Nothing
ReplaceInnerLink = Content
End Function
'=============================================================
'函数作用：判断来源URL是否来自外部
'=============================================================
Public Function CheckOuterUrl()
On Error Resume Next
Dim server_v1, server_v2
server_v1 = Replace(LCase(Trim(Request.ServerVariables("HTTP_REFERER"))), "http://", "")
server_v2 = LCase(Trim(Request.ServerVariables("SERVER_NAME")))
If server_v1 <> "" And Left(server_v1, Len(server_v2)) <> server_v2 Then
CheckOuterUrl = False
Else
CheckOuterUrl = True
End If
End Function
'===================================================MD5加密实现部分开始==========================================================
Private Function LShift(lValue, iShiftBits)
If iShiftBits = 0 Then
LShift = lValue
Exit Function
ElseIf iShiftBits = 31 Then
If lValue And 1 Then
LShift = &H80000000
Else
LShift = 0
End If
Exit Function
ElseIf iShiftBits < 0 Or iShiftBits > 31 Then
Err.Raise 6
End If
If (lValue And m_l2Power(31 - iShiftBits)) Then
LShift = ((lValue And m_lOnBits(31 - (iShiftBits + 1))) * m_l2Power(iShiftBits)) Or &H80000000
Else
LShift = ((lValue And m_lOnBits(31 - iShiftBits)) * m_l2Power(iShiftBits))
End If
End Function
Private Function RShift(lValue, iShiftBits)
If iShiftBits = 0 Then
RShift = lValue
Exit Function
ElseIf iShiftBits = 31 Then
If lValue And &H80000000 Then
RShift = 1
Else
RShift = 0
End If
Exit Function
ElseIf iShiftBits < 0 Or iShiftBits > 31 Then
Err.Raise 6
End If
RShift = (lValue And &H7FFFFFFE) \ m_l2Power(iShiftBits)
If (lValue And &H80000000) Then
RShift = (RShift Or (&H40000000 \ m_l2Power(iShiftBits - 1)))
End If
End Function
Private Function RotateLeft(lValue, iShiftBits)
RotateLeft = LShift(lValue, iShiftBits) Or RShift(lValue, (32 - iShiftBits))
End Function
Private Function AddUnsigned(lX, lY)
Dim lX4
Dim lY4
Dim lX8
Dim lY8
Dim lResult
lX8 = lX And &H80000000
lY8 = lY And &H80000000
lX4 = lX And &H40000000
lY4 = lY And &H40000000
lResult = (lX And &H3FFFFFFF) + (lY And &H3FFFFFFF)
If lX4 And lY4 Then
lResult = lResult Xor &H80000000 Xor lX8 Xor lY8
ElseIf lX4 Or lY4 Then
If lResult And &H40000000 Then
lResult = lResult Xor &HC0000000 Xor lX8 Xor lY8
Else
lResult = lResult Xor &H40000000 Xor lX8 Xor lY8
End If
Else
lResult = lResult Xor lX8 Xor lY8
End If
AddUnsigned = lResult
End Function
Private Function md5_F(x, y, z)
md5_F = (x And y) Or ((Not x) And z)
End Function
Private Function md5_G(x, y, z)
md5_G = (x And z) Or (y And (Not z))
End Function
Private Function md5_H(x, y, z)
md5_H = (x Xor y Xor z)
End Function
Private Function md5_I(x, y, z)
md5_I = (y Xor (x Or (Not z)))
End Function
Private Sub md5_FF(a, b, c, d, x, s, ac)
a = AddUnsigned(a, AddUnsigned(AddUnsigned(md5_F(b, c, d), x), ac))
a = RotateLeft(a, s)
a = AddUnsigned(a, b)
End Sub
Private Sub md5_GG(a, b, c, d, x, s, ac)
a = AddUnsigned(a, AddUnsigned(AddUnsigned(md5_G(b, c, d), x), ac))
a = RotateLeft(a, s)
a = AddUnsigned(a, b)
End Sub
Private Sub md5_HH(a, b, c, d, x, s, ac)
a = AddUnsigned(a, AddUnsigned(AddUnsigned(md5_H(b, c, d), x), ac))
a = RotateLeft(a, s)
a = AddUnsigned(a, b)
End Sub
Private Sub md5_II(a, b, c, d, x, s, ac)
a = AddUnsigned(a, AddUnsigned(AddUnsigned(md5_I(b, c, d), x), ac))
a = RotateLeft(a, s)
a = AddUnsigned(a, b)
End Sub
Private Function ConvertToWordArray(sMessage)
Dim lMessageLength
Dim lNumberOfWords
Dim lWordArray()
Dim lBytePosition
Dim lByteCount
Dim lWordCount
Const MODULUS_BITS = 512
Const CONGRUENT_BITS = 448
lMessageLength = Len(sMessage)
lNumberOfWords = (((lMessageLength + ((MODULUS_BITS - CONGRUENT_BITS) \ BITS_TO_A_BYTE)) \ (MODULUS_BITS \ BITS_TO_A_BYTE)) + 1) * (MODULUS_BITS \ BITS_TO_A_WORD)
ReDim lWordArray(lNumberOfWords - 1)
lBytePosition = 0
lByteCount = 0
Do Until lByteCount >= lMessageLength
lWordCount = lByteCount \ BYTES_TO_A_WORD
lBytePosition = (lByteCount Mod BYTES_TO_A_WORD) * BITS_TO_A_BYTE
lWordArray(lWordCount) = lWordArray(lWordCount) Or LShift(Asc(Mid(sMessage, lByteCount + 1, 1)), lBytePosition)
lByteCount = lByteCount + 1
Loop
lWordCount = lByteCount \ BYTES_TO_A_WORD
lBytePosition = (lByteCount Mod BYTES_TO_A_WORD) * BITS_TO_A_BYTE
lWordArray(lWordCount) = lWordArray(lWordCount) Or LShift(&H80, lBytePosition)
lWordArray(lNumberOfWords - 2) = LShift(lMessageLength, 3)
lWordArray(lNumberOfWords - 1) = RShift(lMessageLength, 29)
ConvertToWordArray = lWordArray
End Function
Private Function WordToHex(lValue)
Dim lByte
Dim lCount
For lCount = 0 To 3
lByte = RShift(lValue, lCount * BITS_TO_A_BYTE) And m_lOnBits(BITS_TO_A_BYTE - 1)
WordToHex = WordToHex & Right("0" & Hex(lByte), 2)
Next
End Function
Public Function MD5(sMessage, stype)
m_lOnBits(0) = CLng(1)
m_lOnBits(1) = CLng(3)
m_lOnBits(2) = CLng(7)
m_lOnBits(3) = CLng(15)
m_lOnBits(4) = CLng(31)
m_lOnBits(5) = CLng(63)
m_lOnBits(6) = CLng(127)
m_lOnBits(7) = CLng(255)
m_lOnBits(8) = CLng(511)
m_lOnBits(9) = CLng(1023)
m_lOnBits(10) = CLng(2047)
m_lOnBits(11) = CLng(4095)
m_lOnBits(12) = CLng(8191)
m_lOnBits(13) = CLng(16383)
m_lOnBits(14) = CLng(32767)
m_lOnBits(15) = CLng(65535)
m_lOnBits(16) = CLng(131071)
m_lOnBits(17) = CLng(262143)
m_lOnBits(18) = CLng(524287)
m_lOnBits(19) = CLng(1048575)
m_lOnBits(20) = CLng(2097151)
m_lOnBits(21) = CLng(4194303)
m_lOnBits(22) = CLng(8388607)
m_lOnBits(23) = CLng(16777215)
m_lOnBits(24) = CLng(33554431)
m_lOnBits(25) = CLng(67108863)
m_lOnBits(26) = CLng(134217727)
m_lOnBits(27) = CLng(268435455)
m_lOnBits(28) = CLng(536870911)
m_lOnBits(29) = CLng(1073741823)
m_lOnBits(30) = CLng(2147483647)
m_l2Power(0) = CLng(1)
m_l2Power(1) = CLng(2)
m_l2Power(2) = CLng(4)
m_l2Power(3) = CLng(8)
m_l2Power(4) = CLng(16)
m_l2Power(5) = CLng(32)
m_l2Power(6) = CLng(64)
m_l2Power(7) = CLng(128)
m_l2Power(8) = CLng(256)
m_l2Power(9) = CLng(512)
m_l2Power(10) = CLng(1024)
m_l2Power(11) = CLng(2048)
m_l2Power(12) = CLng(4096)
m_l2Power(13) = CLng(8192)
m_l2Power(14) = CLng(16384)
m_l2Power(15) = CLng(32768)
m_l2Power(16) = CLng(65536)
m_l2Power(17) = CLng(131072)
m_l2Power(18) = CLng(262144)
m_l2Power(19) = CLng(524288)
m_l2Power(20) = CLng(1048576)
m_l2Power(21) = CLng(2097152)
m_l2Power(22) = CLng(4194304)
m_l2Power(23) = CLng(8388608)
m_l2Power(24) = CLng(16777216)
m_l2Power(25) = CLng(33554432)
m_l2Power(26) = CLng(67108864)
m_l2Power(27) = CLng(134217728)
m_l2Power(28) = CLng(268435456)
m_l2Power(29) = CLng(536870912)
m_l2Power(30) = CLng(1073741824)
Dim x
Dim k
Dim AA
Dim BB
Dim CC
Dim DD
Dim a
Dim b
Dim c
Dim d
Const S11 = 7
Const S12 = 12
Const S13 = 17
Const S14 = 22
Const S21 = 5
Const S22 = 9
Const S23 = 14
Const S24 = 20
Const S31 = 4
Const S32 = 11
Const S33 = 16
Const S34 = 23
Const S41 = 6
Const S42 = 10
Const S43 = 15
Const S44 = 21
x = ConvertToWordArray(sMessage)
a = &H67452301
b = &HEFCDAB89
c = &H98BADCFE
d = &H10325476
For k = 0 To UBound(x) Step 16
AA = a
BB = b
CC = c
DD = d
md5_FF a, b, c, d, x(k + 0), S11, &HD76AA478
md5_FF d, a, b, c, x(k + 1), S12, &HE8C7B756
md5_FF c, d, a, b, x(k + 2), S13, &H242070DB
md5_FF b, c, d, a, x(k + 3), S14, &HC1BDCEEE
md5_FF a, b, c, d, x(k + 4), S11, &HF57C0FAF
md5_FF d, a, b, c, x(k + 5), S12, &H4787C62A
md5_FF c, d, a, b, x(k + 6), S13, &HA8304613
md5_FF b, c, d, a, x(k + 7), S14, &HFD469501
md5_FF a, b, c, d, x(k + 8), S11, &H698098D8
md5_FF d, a, b, c, x(k + 9), S12, &H8B44F7AF
md5_FF c, d, a, b, x(k + 10), S13, &HFFFF5BB1
md5_FF b, c, d, a, x(k + 11), S14, &H895CD7BE
md5_FF a, b, c, d, x(k + 12), S11, &H6B901122
md5_FF d, a, b, c, x(k + 13), S12, &HFD987193
md5_FF c, d, a, b, x(k + 14), S13, &HA679438E
md5_FF b, c, d, a, x(k + 15), S14, &H49B40821
md5_GG a, b, c, d, x(k + 1), S21, &HF61E2562
md5_GG d, a, b, c, x(k + 6), S22, &HC040B340
md5_GG c, d, a, b, x(k + 11), S23, &H265E5A51
md5_GG b, c, d, a, x(k + 0), S24, &HE9B6C7AA
md5_GG a, b, c, d, x(k + 5), S21, &HD62F105D
md5_GG d, a, b, c, x(k + 10), S22, &H2441453
md5_GG c, d, a, b, x(k + 15), S23, &HD8A1E681
md5_GG b, c, d, a, x(k + 4), S24, &HE7D3FBC8
md5_GG a, b, c, d, x(k + 9), S21, &H21E1CDE6
md5_GG d, a, b, c, x(k + 14), S22, &HC33707D6
md5_GG c, d, a, b, x(k + 3), S23, &HF4D50D87
md5_GG b, c, d, a, x(k + 8), S24, &H455A14ED
md5_GG a, b, c, d, x(k + 13), S21, &HA9E3E905
md5_GG d, a, b, c, x(k + 2), S22, &HFCEFA3F8
md5_GG c, d, a, b, x(k + 7), S23, &H676F02D9
md5_GG b, c, d, a, x(k + 12), S24, &H8D2A4C8A
md5_HH a, b, c, d, x(k + 5), S31, &HFFFA3942
md5_HH d, a, b, c, x(k + 8), S32, &H8771F681
md5_HH c, d, a, b, x(k + 11), S33, &H6D9D6122
md5_HH b, c, d, a, x(k + 14), S34, &HFDE5380C
md5_HH a, b, c, d, x(k + 1), S31, &HA4BEEA44
md5_HH d, a, b, c, x(k + 4), S32, &H4BDECFA9
md5_HH c, d, a, b, x(k + 7), S33, &HF6BB4B60
md5_HH b, c, d, a, x(k + 10), S34, &HBEBFBC70
md5_HH a, b, c, d, x(k + 13), S31, &H289B7EC6
md5_HH d, a, b, c, x(k + 0), S32, &HEAA127FA
md5_HH c, d, a, b, x(k + 3), S33, &HD4EF3085
md5_HH b, c, d, a, x(k + 6), S34, &H4881D05
md5_HH a, b, c, d, x(k + 9), S31, &HD9D4D039
md5_HH d, a, b, c, x(k + 12), S32, &HE6DB99E5
md5_HH c, d, a, b, x(k + 15), S33, &H1FA27CF8
md5_HH b, c, d, a, x(k + 2), S34, &HC4AC5665
md5_II a, b, c, d, x(k + 0), S41, &HF4292244
md5_II d, a, b, c, x(k + 7), S42, &H432AFF97
md5_II c, d, a, b, x(k + 14), S43, &HAB9423A7
md5_II b, c, d, a, x(k + 5), S44, &HFC93A039
md5_II a, b, c, d, x(k + 12), S41, &H655B59C3
md5_II d, a, b, c, x(k + 3), S42, &H8F0CCC92
md5_II c, d, a, b, x(k + 10), S43, &HFFEFF47D
md5_II b, c, d, a, x(k + 1), S44, &H85845DD1
md5_II a, b, c, d, x(k + 8), S41, &H6FA87E4F
md5_II d, a, b, c, x(k + 15), S42, &HFE2CE6E0
md5_II c, d, a, b, x(k + 6), S43, &HA3014314
md5_II b, c, d, a, x(k + 13), S44, &H4E0811A1
md5_II a, b, c, d, x(k + 4), S41, &HF7537E82
md5_II d, a, b, c, x(k + 11), S42, &HBD3AF235
md5_II c, d, a, b, x(k + 2), S43, &H2AD7D2BB
md5_II b, c, d, a, x(k + 9), S44, &HEB86D391
a = AddUnsigned(a, AA)
b = AddUnsigned(b, BB)
c = AddUnsigned(c, CC)
d = AddUnsigned(d, DD)
Next
If stype = 32 Then
MD5 = LCase(WordToHex(a) & WordToHex(b) & WordToHex(c) & WordToHex(d))
Else
MD5 = LCase(WordToHex(b) & WordToHex(c))
End If
End Function
'===================================================MD5加密部分结束=============================================
'取得Request.Querystring 或 Request.Form 的值
Public Function G(Str)
G = Replace(Replace(Request(Str), "'", ""), """", "")
End Function
'关闭主数据库对象
Public Sub CloseConn()
On Error Resume Next
If IsObject(Conn) Then
Conn.Close:Set Conn = Nothing
End If
End Sub
'关闭采集数据库对象
Public Sub CloseConnItem()
On Error Resume Next
If IsObject(ConnItem) Then
ConnItem.Close:Set ConnItem = Nothing
End If
End Sub
Public Function HTMLEncode(fString)
If Not IsNull(fString) then
fString = replace(fString, ">", ">")
fString = replace(fString, "<", "<")
fString = replace(fString, "&", "&")
fString = Replace(fString, CHR(32), " ")
fString = Replace(fString, CHR(9), " ")
fString = Replace(fString, CHR(34), """)
fString = Replace(fString, CHR(39), "'")
fString = Replace(fString, CHR(13), "")
fString = Replace(fString, CHR(10) & CHR(10), "
")
fString = Replace(fString, CHR(10), " ")
HTMLEncode = fString
End If
End Function
Public Function HTMLCode(fString)
If Not IsNull(fString) then
fString = replace(fString, ">", ">")
fString = replace(fString, "<", "<")
fString = Replace(fString, " "," ")
fString = Replace(fString, """, CHR(34))
fString = Replace(fString, "'", CHR(39))
fString = Replace(fString, "
",CHR(10) & CHR(10))
fString = Replace(fString, " ", CHR(10))
HTMLCode = fString
End If
End Function
Public 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
Public Function IsExpired(strClassString)
On Error Resume Next
IsExpired = True
Err = 0
Dim xTestObj:Set xTestObj = Server.CreateObject(strClassString)
If 0 = Err Then
Select Case strClassString
Case "Persits.Jpeg"
If xTestObjResponse.Expires > Now Then
IsExpired = False
End If
Case "wsImage.Resize"
If InStr(xTestObj.errorinfo, "已经过期") = 0 Then
IsExpired = False
End If
Case "SoftArtisans.ImageGen"
xTestObj.CreateImage 500, 500, RGB(255, 255, 255)
If Err = 0 Then
IsExpired = False
End If
End Select
End If
Set xTestObj = Nothing
Err = 0
End Function
Public Function ExpiredStr(I)
Dim ComponentName(3)
ComponentName(0) = "Persits.Jpeg"
ComponentName(1) = "wsImage.Resize"
ComponentName(2) = "SoftArtisans.ImageGen"
ComponentName(3) = "CreatePreviewImage.cGvbox"
If IsObjInstalled(ComponentName(I)) Then
If IsExpired(ComponentName(I)) Then
ExpiredStr = "，但已过期"
Else
ExpiredStr = ""
End If
ExpiredStr = " √支持" & ExpiredStr
Else
ExpiredStr = "×不支持"
End If
End Function
'=================================================缓存相关函数=======================
'不提示,批量清除缓存,参数 PreCacheName-前段匹配
Public Sub DelCaches(PreCacheName)
Dim i
Dim CacheList:CacheList=split(GetCacheList(PreCacheName),",")
If UBound(CacheList)>1 Then
For i=0 to UBound(CacheList)-1
DelCahe CacheList(i)
Next
End IF
End Sub
'取得缓存列表 参数 PreCacheName-前段匹配
Public Function GetCacheList(PreCacheName)
Dim Cacheobj
For Each Cacheobj in Application.Contents
If CStr(Left(Cacheobj,Len(PreCacheName)))=CStr(PreCacheName) Then
GetCacheList=GetCacheList&Cacheobj&","
End If
Next
End Function
'清除缓存,参数 MyCaheName-缓存名称
Public Sub DelCahe(MyCaheName)
Application.Lock
Application.Contents.Remove(MyCaheName)
Application.unLock
End Sub
'======================================================================================
'======================================会员相关函数====================================
'取得会员组选项--下拉列表 参数：Selected--默认选项
Public Function GetUserGroup_Option(Selected)
Dim RSObj:Set RSObj=Server.CreateObject("Adodb.Recordset")
RSObj.Open "Select ID,GroupName From KS_UserGroup",Conn,1,1
Do While Not RSObj.Eof
IF Selected=RSObj(0) Then
GetUserGroup_Option=GetUserGroup_Option & ""
Else
GetUserGroup_Option=GetUserGroup_Option & ""
End If
RSObj.MoveNext
Loop
RSObj.Close:Set RSObj=Nothing
End Function
'取得会员组选项--多选列表 参数：SelectArr--默认选择项以","隔开,RowNum--每行显示选项数
Public Function GetUserGroup_CheckBox(SelectArr,RowNum)
Dim n:n=0
Dim RSObj:Set RSObj=Server.CreateObject("Adodb.Recordset")
IF RowNum<=0 Then RowNum=3
RSObj.Open "Select ID,GroupName From KS_UserGroup",Conn,1,1
GetUserGroup_CheckBox="
"
Do While Not RSObj.Eof
GetUserGroup_CheckBox=GetUserGroup_CheckBox & "
"
For N=1 To RowNum
GetUserGroup_CheckBox=GetUserGroup_CheckBox & "
"
If Instr(SelectArr,RSObj(0))<>0 Then
GetUserGroup_CheckBox=GetUserGroup_CheckBox & "" & RSObj(1) & " "
Else
GetUserGroup_CheckBox=GetUserGroup_CheckBox & "" & RSObj(1) & " "
End IF
GetUserGroup_CheckBox=GetUserGroup_CheckBox & "
"
RSObj.MoveNext
If RSObj.Eof Then Exit For
Next
GetUserGroup_CheckBox=GetUserGroup_CheckBox & "
"
If RSObj.Eof Then Exit Do
Loop
GetUserGroup_CheckBox=GetUserGroup_CheckBox & "
"
RSObj.Close:Set RSObj=Nothing
End Function
'取得用户组名称
Public Function GetUserGroupName(GroupID)
On Error Resume Next
GetUserGroupName=Conn.Execute("Select GroupName From KS_UserGroup Where ID=" & GroupID)(0)
if err then GetUserGroupName=""
End Function
'会员投稿文章，图片，下载等增加积分,发送站内短信操作
'参数ChannelID-频道ID,UserName---用户名称,InfoTitle---投稿的主题
Public Sub SignUserInfoOK(ChannelID,UserName,InfoTitle)
IF Not IsNumeric(ChannelID) Then Exit Sub
Dim RSObj:Set RSObj=Server.CreateObject("ADODB.RECORDSET")
RSObj.Open "Select Money,Point,Score From KS_User Where UserName='" & UserName & "'",Conn,1,3
IF RSObj.Eof And RSObj.Bof Then
'错误处理
Else
RSObj(0)=RSObj(0)+GetChannelConfig(ChannelID,"UserAddMoney")
RSObj(1)=RSObj(1)+GetChannelConfig(ChannelID,"UserAddPoint")
RSObj(2)=RSObj(2)+GetChannelConfig(ChannelID,"UserAddScore")
RSObj.Update
'成功则发送站内通知信件
Dim Sender:Sender=GetConfig("WebName")
Dim Title:Title="恭喜，您发表的稿件[" & InfoTitle & "]已被签收！！！"
Dim Message:Message="稿件标题：" & InfoTitle &" "_
& "获得金钱：" & GetChannelConfig(ChannelID,"UserAddMoney") & " 元人民币 "_
& "获得点券：" & GetChannelConfig(ChannelID,"UserAddPoint") & " " & PointStr & " "_
& "获得积分：" & GetChannelConfig(ChannelID,"UserAddScore") & " 分积分 "_
& " 备注：此信息由系统自动发布，请不要回复！！！"
Call PointInOrOut(ChannelID,0,UserName,1,GetChannelConfig(ChannelID,"UserAddPoint"),"系统","发表搞件[" & InfoTitle & "]所得")
Call SendInfo(UserName,Sender,Title,Message)
End IF
RSObj.Close:Set RSObj=Nothing
End Sub
'功能:会员点券明细出入函数 '参数:Channelid-模块ID,InfoID-信息ID，UserName-用户名,InOrOutFlag-操作类型1收入2支同,Point-交易点数,User-操作员,Descript-操作备注
Public Function PointInOrOut(ChannelID,InfoID,UserName,InOrOutFlag,Point,User,Descript)
If Not IsNumeric(InOrOutFlag) Or Not IsNumeric(Point) Then PointInOrOut=false:Exit Function
Dim PointParam
If InOrOutFlag=1 Then
PointParam="Set Point=Point+" & Point
ElseIF InOrOutFlag=2 Then
PointParam="Set Point=Point-" & Point
Else
PointInOrOut=false:Exit Function
End If
Conn.Execute("Update KS_User " & PointParam & " Where UserName='" & UserName & "'")
Dim RSObj:Set RSObj=Server.CreateObject("Adodb.Recordset")
RSObj.Open "Select * From KS_LogPoint Where ID is null",Conn,1,3
RSObj.AddNew
RSObj("ChannelID")=ChannelID
RSObj("InfoID")=InfoID
RSObj("UserName")=UserName
RSObj("InOrOutFlag")=InOrOutFlag
RSObj("Point")=Point
RSObj("Times")=1
RSObj("User")=User
RSObj("Descript")=Descript
RSObj("AddDate")=now
RSObj("IP")=Request.ServerVariables("Remote_Addr")
RSObj.Update
RSObj.Close:Set RSObj=Nothing
IF Err Then PointInOrOut=false Else PointInOrOut=true
End Function
'会员有效期明细出入函数
'参数:UserName,InOrOutFlag,Edays,User,Descript
Function EdaysInOrOut(UserName,InOrOutFlag,Edays,User,Descript)
If Not IsNumeric(InOrOutFlag) Or Not IsNumeric(Edays) Then EdaysInOrOut=false:Exit Function
Dim RSObj:Set RSObj=Server.CreateObject("Adodb.Recordset")
RSObj.Open "Select * From KS_LogEdays Where ID is null",Conn,1,3
RSObj.AddNew
RSObj("UserName")=UserName
RSObj("InOrOutFlag")=InOrOutFlag
RSObj("Edays")=Edays
RSObj("User")=User
RSObj("Descript")=Descript
RSObj("AddDate")=now
RSObj("IP")=Request.ServerVariables("Remote_Addr")
RSObj.Update
RSObj.Close:Set RSObj=Nothing
IF Err Then EdaysInOrOut=false Else EdaysInOrOut=true
End Function
'发送站内信息
'参数Incept--接收者,Sender-发送者,title--主题,Content--信件内容
Public Sub SendInfo(Incept,Sender,title,Content)
Conn.Execute("insert into KS_Message (Incept,sEnder,title,content,SendTime,flag,IsSend) values ('"&Incept&"','"&Sender&"','"&title&"','"&Content&"','"&Now()&"',0,1)")
End Sub
'======================================================================================
End Class
%>
<%
Dim KSCls
Set KSCls = New User_GuestBook
KSCls.Execute()
Set KSCls = Nothing
Class User_GuestBook
Private KSCMS
Private GuestNum,GuestCheckTF
Private Sub Class_Initialize()
Set KSCMS=New CommonCls
End Sub
Private Sub Class_Terminate()
Call KSCMS.CloseConn()
Set KSCMS=Nothing
End Sub
Public Sub Execute()
GuestNum=KSCMS.GetConfig("GuestNum")
GuestCheckTF=KSCMS.GetConfig("GuestCheckTF")
%>
