<%
On Error Resume Next
Response.charset="utf-8"
'设置输出缓冲区
Response.Buffer = True
Dim LS, Conn, dCmd, strSuc, strMsg, SM_RandomID
Dim G_IN, G_INITTIMER, G_FLAGHTMLTYPE, G_CACHENAME, G_ALLCACHE, G_CREATEHTMLTYPE, G_ROOTPATH
Dim G_UAID, G_UATYPE, G_UANAME, G_UIID, G_UINAME, G_UIPATH, G_UARIGHTS, G_SITEID
Dim G_CHKRIGHTS,G_EDITRIGHTS
'页面声明
G_IN = True
'初始化时间
G_INITTIMER = Timer()
'缓存名称
G_CACHENAME = "LONSUN"
'开启后会消耗大量内存、FALSE 为抓取URL地址生成，否则不建议开启
G_ALLCACHE = True
'生成静态方式,TRUE 为读取模板生成，除非独立服务器。 目前只支持 False 参数
G_CREATEHTMLTYPE = False
'函数返回字符类型
G_FLAGHTMLTYPE = False
'结构保存路径
G_CONFIG_PATH = "/UploadFile/config/"
G_SITESTRUCTUR_XML = "sitestructure.config"
'当前站点域名
G_CURSITE_PORT = Request.ServerVariables("SERVER_PORT")
If G_CURSITE_PORT="80" Then
G_CURSITE_PORT = ""
Else
G_CURSITE_PORT = "."& G_CURSITE_PORT
End If
G_CURSITE_URL = Request.ServerVariables("SERVER_NAME") & G_CURSITE_PORT
'修改权限类型
G_CHKRIGHTS = False
'编辑权限类型
G_EDITRIGHTS = False
Public Sub IsUser()
If G_UAID = "" Then
Response.Write ""
Response.End()
End If
End Sub
Public Function Validate(ByVal v)
If Not Permission(v) Then
Response.Write ""
Response.End()
End If
'此处强行注入全局变量，免得在页面上。虽然在某些情况下浪费资源，但是比页面每个地方都写这样的IF要好的多
SS_ID_ = LS.toClng(Request.QueryString("SS_ID"))
If SS_ID_<>0 Then
If Permission("|C"& SS_ID_ &"|") Then G_CHKRIGHTS = True
If Permission("|E"& SS_ID_ &"|") Then G_EDITRIGHTS = True
End If
End Function
Public Function Permission(ByVal s)
If InStr(G_UARIGHTS, "|0|") > 0 Then
Permission = True
Else
Permission = False
Dim x, scwords
scwords = Split(s, ",")
For x = 0 To UBound(scwords)
If InStr(G_UARIGHTS, scwords(x)) > 0 Then
Permission = True
Exit For
End If
Next
End If
End Function
Public Function Permissionm(ByVal s)
Permissionm = False
Dim x, scwords
scwords = Split(s, ",")
For x = 0 To UBound(scwords)
If InStr(G_UARIGHTS, scwords(x)) > 0 Then
Permissionm = True
Exit For
End If
Next
End Function
Public Sub DBConnEnd()
Set Rs = Nothing
Set conn = Nothing
End Sub
Public Sub OutScript(Str)
Response.Write ""
Response.End()
End Sub
Sub OutScriptNoBack(Str)
Response.Write ""
Response.End()
End Sub
Public Sub OutScriptTopClose(Str)
Response.Write ""
Response.End()
End Sub
Public Sub OutTips(ByVal s, ByVal icons)
If icons = "" Then icons = "info"
Response.Write ""
End Sub
Public Function GetSafeStr(Str)
Str = Trim(Str)
Str = Replace(Str, "'", "")
Str = Replace(Str, ";", "")
Str = Replace(Str, ",", "")
Str = Replace(Str, "!!", "")
Str = Replace(Str, Chr(34), "")
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, "CR", "")
Str = Replace(Str, "LF", "")
Str = Replace(Str, "script", "")
Str = Replace(Str, "document", "")
Str = Replace(Str, "eval", "")
Str = Replace(Str, "alert", "")
Str = Replace(Str, "+/v8", "")
Str = Replace(Str, "+/v9", "")
GetSafeStr = Str
End Function
Public Function IsSafeStr(Str)
Dim s_BadStr, n, i
s_BadStr = "' &<>?%,;:()`~!@#$^*{}[]|+-=" & Chr(34) & Chr(9) & Chr(32)
n = Len(s_BadStr)
IsSafeStr = True
For i = 1 To n
If InStr(Str, Mid(s_BadStr, i, 1)) > 0 Then
IsSafeStr = False
Exit Function
End If
Next
End Function
Public Function strLen(ByVal Str)
Dim k, i, c
Dim ForTotal
k = 0
ForTotal = Len(Str)
For i = 1 To ForTotal
c = Abs(AscW(Mid(Str, i, 1)))
If c>255 Then
k = k + 2
Else
k = k + 1
End If
Next
strLen = k
End Function
function cutStr(str,strlen)
If str = "" Then
exit function
End If
'------------来源长度检查
If strlen = "" Then
exit function
End If
If CInt(strlen) = 0 Then
exit function
End If
'----------检测来源字符长度
dim l,t,c,i
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
cutStr=left(str,strlen)&"..."
exit for
else
cutStr=str
end if
next
cutStr=replace(cutStr,chr(10),"")
end function
'Public Function CutStr(Str, LenNum)
' If Ls.IsN(Str) Then Exit Function
' Dim k, i, d, c
' Dim iStr
' Dim ForTotal
'
' If CDbl(LenNum) > 0 Then
' k = 0
' d = StrLen(Str)
' iStr = ""
' ForTotal = Len(Str)
' For i = 1 To ForTotal
' c = Abs(AscW(Mid(Str, i, 1)))
' If c>255 Then
' k = k + 2
' Else
' k = k + 1
' End If
' iStr = iStr & Mid(Str, i, 1)
' If CLng(k)>CLng(LenNum) Then
' iStr = iStr & "..."
' Exit For
' End If
' Next
' CutStr = iStr
' Else
' CutStr = ""
' End If
'End Function
Public Function FsoStr()
FsoStr = "Scripting."&FsoAddStr&"FileSystemObject"
End Function
Public Function FsoStat()
If IsObjInstalled(FsoStr()) = False Then
FsoStat = False
Else
FsoStat = True
End If
End Function
'读取站点ID
Public Function ReadSiteID(sid)
sql = "select SS_SiteID from SiteStructure where SS_ID=" & sid
Set trs = LS.CreateRs(sql, 1, 1)
If Not trs.EOF Then
ReadSiteID = trs("SS_SiteID")
End If
trs.Close
End Function
Public Function GetDateCode(ByVal sDate, ByVal sMode)
Dim sReturn
If Not IsDate(sDate) Or IsNull(sDate) Then sDate = Now()
sReturn = Year(sDate) & Right("0" & Month(sDate), 2) & Right("0" & Day(sDate), 2)
Select Case sMode
Case "1"
sReturn = sReturn & Right("0" & Hour(sDate), 2)
Case "2"
sReturn = sReturn & Right("0" & Hour(sDate), 2) & Right("0" & Minute(sDate), 2)
Case "3"
sReturn = sReturn & Right("0" & Hour(sDate), 2) & Right("0" & Minute(sDate), 2) & Right("0" & Second(sDate), 2)
Case "4"
sReturn = Year(sDate) &"-"& Right("0" &"-"& Month(sDate), 2) &"-"& Right("0" & Day(sDate), 2)
Case "5"
sReturn = Year(sDate) &"/"& Right("0" &"/"& Month(sDate), 2) &"/"& Right("0" & Day(sDate), 2)
Case "6"
sReturn = Year(sDate) & Right("0" & Month(sDate), 2) & Right("0" & Day(sDate), 2)
End Select
GetDateCode = sReturn
End Function
Public Sub EventsUser(EU_Description)
If EU_Description = "" Then Exit Sub
sql = "select * from EventsUser order by EU_ID desc"
Set Rs = LS.CreateRs(sql, 1, 3)
Rs.addnew
Rs("EU_Date") = Now()
'Rs("EU_Time") = Time()
Rs("UA_ID") = G_UAID
Rs("UA_Name") = G_UANAME
Rs("EU_RemoteIP") = Request.ServerVariables("REMOTE_ADDR")
Rs("EU_Description") = EU_Description
Rs.update
Rs.Close
End Sub
Public Function Rightscheck(ritem)
If InStr(G_UARIGHTS, "|0|")>0 Then
Rightscheck = True
Else
If InStr(G_UARIGHTS, "|"&ritem&"|") > 0 Then
Rightscheck = True
Else
Rightscheck = False
End If
End If
End Function
Public Function GetRandom()
Randomize
GetRandom = Round(Rnd * (99999999 - 10000000 + 1) - 0.5) + 10000000
End Function
Public Function GetPublicModule()
GetPublicModule = "1,2,8,10,15,95,100,101,105,106"
End Function
'通过构造出的数据库连接字符串，得到数据库中的数据表名的函数
Public Function GetTable(StrConn)
Dim dataconn
Set dataconn = Server.CreateObject("ADODB.CONNECTION")
dataconn.Open StrConn
Dim rstSchema
Set rstSchema = dataconn.OpenSchema(20)
Dim tableList
tableList = ""
Do While Not rstSchema.EOF
If rstSchema("TABLE_TYPE") = "TABLE" Then
If Left(rstSchema("TABLE_NAME"), 1) <> "~" Then
tableList = tableList&"|"&rstSchema("TABLE_NAME")
End If
End If
rstSchema.MoveNext
Loop
rstSchema.Close
dataconn.Close
GetTable = tableList
End Function
'通过构造出的数据库连接字符串和表名，得到表中所有字段的函数
Public Sub GetFields(StrConn, TableName)
Dim dataconn, rstSchema
Set dataconn = Server.CreateObject("ADODB.CONNECTION")
Set rstSchema = Server.CreateObject("ADODB.RECORDSET")
dataconn.Open StrConn
sql = "select * from "&TableName&""
rstSchema.Open sql, dataconn, 1, 1
j = rstSchema.Fields.Count
FieldLists = ""
FieldTypes = ""
For i = 0 To j -1
FieldLists = FieldLists&"|"&rstSchema.Fields(i).Name
FieldTypes = FieldTypes&"|"&rstSchema.Fields(i).Type
Next
rstSchema.Close
dataconn.Close
End Sub
Public Function GetStrConn(DB_Type, DB_FILE, DB_ADDR, DB_NAME, DB_USER, DB_PWD)
If DB_TYPE = "Excel" Then
GetStrConn = "Provider=Microsoft.Jet.OLEDB.4.0;Extended Properties=""Excel 8.0;HDR=Yes;IMEX=1"";Data Source=" & Server.MapPath(DB_FILE) & ";"
End If
If DB_TYPE = "ACCESS" Then
GetStrConn = "provider=microsoft.jet.oledb.4.0;data source="&Server.MapPath(DB_FILE)&";user id="&DB_USER&";password="&DB_PWD&";"
End If
If DB_TYPE = "SQL Server" Then
GetStrConn = "PROVIDER=SQLOLEDB;Data Source="&DB_ADDR&";Initial Catalog="&DB_NAME&";User ID="&DB_USER&";Password="&DB_PWD&";"
End If
End Function
'追加查询条件
Public Function Type_Name(DB_Type, FName, FValue, num)
If DB_Type = "ACCESS" Or DB_Type = "Excel" Then
Select Case num
Case 3, 6, 11
If IsNumeric(FValue) = False Then
Response.Write("查询类型不匹配!")
Response.End
End If
Type_Name = " and "&FName&"="&FValue
Case 7
Type_Name = " and "&FName&"=#"&FValue&"#"
Case 5, 202, 203, 205
Type_Name = " and "&FName&" like '%"&FValue&"%'"
End Select
End If
If DB_Type = "SQL Server" Then
Select Case num
Case 2, 3, 4, 5, 11, 12, 17, 20, 72, 131
If IsNumeric(FValue) = False Then
Response.Write("查询类型不匹配!")
Response.End
End If
Type_Name = " and "&FName&"="&FValue
Case 6, 128, 129, 130, 135, 200, 201, 202, 203, 204, 205
Type_Name = " and "&FName&" like '%"&FValue&"%'"
End Select
End If
End Function
' 读取路径
Public Function ReadSSPath(SSID)
ReadSSPathSql = "select SS_Path from SiteStructure where SS_ID=" & SSID
Set ReadSSPathRs = LS.CreateRs(ReadSSPathSql, 1, 1)
If Not ReadSSPathRs.EOF Then
ReadSSPath = ReadSSPathRs("SS_Path")
End If
ReadSSPathRs.Close
Set ReadSSPathRs = Nothing
End Function
'去除HTML标记与空格
Public Function MoveHTML(strHTML)
If Not Ls.IsN(strHTML) Then
Dim objRegExp, Match, Matches
Set objRegExp = New Regexp
objRegExp.IgnoreCase = True
objRegExp.Global = True
objRegExp.Pattern = "<.+?>"
strHTML = objRegExp.Replace(strHTML, " ")
strHTML = Replace(strHTML, " ", "")
strHTML = Replace(strHTML, " ", "")
strHTML = Replace(strHTML, " ", "")
strHTML = Replace(strHTML, " ", "")
Set Matches = objRegExp.Execute(strHTML)
For Each Match in Matches
strHtml = Replace(strHTML, Match.Value, "")
Next
MoveHTML = strHTML
Set objRegExp = Nothing
End If
End Function
'去除HTML格式
Public Function RemoveHTML(strHTML)
Dim objRegExp, Match, Matches
Set objRegExp = New Regexp
objRegExp.IgnoreCase = True
objRegExp.Global = True
objRegExp.Pattern = "<.+?>"
Set Matches = objRegExp.Execute(Trim(strHTML))
For Each Match in Matches
strHtml = Replace(strHTML, Match.Value, "")
Next
RemoveHTML = strHTML
Set objRegExp = Nothing
End Function
Public Function outHTML(Str)
Dim sTemp
sTemp = Str
outHTML = ""
If IsNull(sTemp) = True Then
Exit Function
End If
sTemp = Replace(sTemp, "&", "&")
sTemp = Replace(sTemp, "<", "<")
sTemp = Replace(sTemp, ">", ">")
sTemp = Replace(sTemp, Chr(34), """)
sTemp = Replace(sTemp, Chr(10), " ")
outHTML = sTemp
End Function
Public Sub CreatePutPath(PathStr)
Set MyFileObject = LS.InitFSO()
If MyFileObject.FolderExists(Server.Mappath(PathStr)) = False Then
Dim thispath, sthispath
ArPathStr = Split(PathStr, "/")
For x = 0 To UBound(ArPathStr)
If ArPathStr(x) <> "" Then
thispath = thispath & "/" & ArPathStr(x)
sthispath = Server.Mappath(thispath)
If MyFileObject.FolderExists(sthispath) = False Then MyFileObject.CreateFolder sthispath
End If
Next
End If
Set MyFileObject = Nothing
End Sub
Public Function CheckTable(TableName)
Set Conn = LS.CreateConn()
Set Rs = Conn.OpenSchema(4)
Do Until Rs.EOF
If Rs("Table_name") = TableName Then
CheckTable = True
Exit Do
Else
CheckTable = False
End If
Rs.movenext
Loop
Rs.Close
Conn.Close
Set Conn = Nothing
End Function
'设置消息已读
Public Sub SetMessageIsSign(ByVal SM_RandomID)
If SM_RandomID = "" Or Not IsNumeric(SM_RandomID) Then Exit Sub
sql = "update SysMessage set SM_IsSign=1 where SM_RandomID=" & SM_RandomID & " and SM_User=" & G_UAID
Set smConn = LS.CreateConn()
smConn.Execute(sql)
smConn.Close
End Sub
'写入消息
Public Function SysMsg(ByVal UAID, ByVal msgType, ByVal msgUrl, ByVal Msg, ByVal msgTitle, ByVal msgSenderUAID)
If msgSenderUAID = "" Or Not IsNumeric(msgSenderUAID) Then msgSenderUAID = 0
Dim msg_i
UAIDS = Split(UAID&"", ",")
For msg_i = 0 To UBound(UAIDS)
If UAIDS(msg_i) = "" Or IsNumeric(UAIDS(msg_i)) = False Then
Exit Function
End If
sql = "select top 1 * from SysMessage order by SM_ID desc"
Set Rs = Ls.CreateRs(sql, 1, 3)
If Rs.EOF Then
SM_ID = 1
Else
SM_ID = Rs("SM_ID") + 1
End If
Rs.addnew()
Rs("SM_ID") = SM_ID
Rs("SM_User") = UAIDS(msg_i)
Rs("SM_Title") = msgTitle
Rs("SM_Content") = Msg
Rs("SM_Link") = msgUrl
Rs("SM_Time") = Now()
Rs("SM_IsSign") = 0
Rs("SM_Target") = 0
Rs("SM_Sender") = msgSenderUAID
Rs("SM_Type") = msgType
If SM_RandomID <> "" Then Rs("SM_RandomID") = SM_RandomID
Rs.update
Rs.Close
Set Rs = Nothing
Next
End Function
Public Function pageExecTime()
pageTimerEnd = Timer()
pageExecTime = FormatNumber((pageTimerEnd - G_INITTIMER), 2, -1) & "秒"
End Function
'显示项目列表
Public Function Str_SS_Type(SS_Type)
strSelect = "select PM_Name,PM_Type,PM_Default from PublicModule where PM_State=0"
strSelect = strSelect & "and PM_Type="&SS_Type
strSelect = strSelect & " order by PM_Order"
Set Lhyrs = LS.CreateRs(strSelect, 1, 1)
if not Lhyrs.eof then
Str_SS_Type = Lhyrs("PM_Name")
else
if SS_Type = 1000 then
Str_SS_Type = "【主站点】"
end if
if SS_Type = 1001 then
Str_SS_Type = "【子站点】"
end if
end if
End Function
'检测栏目是否建在专题下
Public Function checkSpecial(ByVal PSS_ID)
checkSpecial = False
p_SSPath = CCfg(PSS_ID, 1)
p_SSPath_Len = Len(p_SSPath)
For i = 0 To (p_SSPath_Len -2) / 4
cur_path = Left(p_SSPath, p_SSPath_Len - (i * 4))
If CPathCfg(cur_path, 18)<>"0" Then
checkSpecial = True
Exit For
End If
Next
End Function
'取当前页
Public Function getCurPage()
pp = Request("pp")
getCurPage = "pp="&pp
End Function
'信息提示,此函数只有放在有core.js的页面,并且放在body里.
Public Function tipInfo()
Response.Write ""
Response.End()
End Function
'配合事务
Public Function CreateRs(ByVal Sql, ByVal CursorType, ByVal LockType)
Set Rs_ = Server.CreateObject("ADODB.Recordset")
Rs_.Open Sql, Conn, CursorType, LockType
Set CreateRs = Rs_
End Function
'调用查询存储过程
Public Function doSp(ByVal strSelect)
Set dCmd = Server.CreateObject("ADODB.Command")
With dCmd
.CommandType = 4
.ActiveConnection = LS.DB.Conn
.CommandText = "sp_Select"
.Prepared = True
.Parameters(1) = strSelect
Set doSp = .Execute()
End With
Set o_Cmd = Nothing
End Function
'返回模块配置
Public Function ModCfg(ByVal ID, ByVal FieldID)
If Not IsObject(Application(G_CACHENAME & "_PublicModule")) Then Call InitPublicModule()
ModCfg = LS.GetAppCfg("_PublicModule", "k[@w0="& ID &"]/@w" & FieldID)
End Function
'返回结构配置
Public Function CCfg(ByVal ID, ByVal FieldID)
If ID = "" Or Not IsNumeric(ID) Then Exit Function
If Not IsObject(Application(G_CACHENAME & "_PortalClass")) OR CheckSiteInfoConfig() Then Call InitSiteStructure()
CCfg = LS.GetAppCfg("_PortalClass", "k[@w0="& ID &"]/@w" & FieldID)
End Function
'返回结构配置,根据PATH返回路径相关值
Public Function CPathCfg(ByVal Path, ByVal FieldID)
If Path = "" Then Exit Function
If Not IsObject(Application(G_CACHENAME & "_PortalClass")) Then Call InitSiteStructure()
CPathCfg = LS.GetAppCfg("_PortalClass", "k[@w1='"& Path &"']/@w" & FieldID)
End Function
'返回SS_ID下的所有子孙节点ID，以逗号分割
Public Function CSCfg(ByVal ID)
If ID = "" Or Not IsNumeric(ID) Then Exit Function
If G_ALLCACHE Then
If Not IsObject(Application(G_CACHENAME & "_PortalSubClass")) Then Call InitClassSubIDs()
CSCfg = LS.GetAppCfg("_PortalSubClass", "k[@w0="& ID &"]/@w1")
If CSCfg="" Then CSCfg = 0
Else
Dim aRs_
strSelect = "select SS_Path from v_ClassSubIDs Where SS_ID=" & ID
Set aRs_ = LS.DB.Query(strSelect)
If Not aRs_.Eof Then
CSCfg = aRs_("SS_Path")
Else
CSCfg = 0
End If
aRs_.Close
Set aRs_ = Nothing
End If
End Function
'返回站点信息后台
Public Function SiteCfg(ByVal SiteID, ByVal FieldID)
If SiteID = "" Or Not IsNumeric(SiteID) Then Exit Function
If Not IsObject(Application(G_CACHENAME & "_SiteInfo")) Then Call InitSiteInfo()
SiteCfg = LS.GetAppCfg("_SiteInfo", "k[@w0="& SiteID &"]/@w" & FieldID)
End Function
'返回站点信息前台
Public Function SiteInfo(ByVal FieldID)
SiteInfo = SiteCfg(ThisSiteID, FieldID)
End Function
'返回广告信息
Public Function ADCfg(ByVal ID, ByVal FieldID)
If Not IsObject(Application(G_CACHENAME & "_ADInfo")) Then Call InitADInfo()
ADCfg = LS.GetAppCfg("_ADInfo", "k[@w0="& ID &"]/@w" & FieldID)
End Function
'创建当前要更新缓存的站点
Private Function CreateSiteInfoConfig()
strSelect = "select SI_Domain from SiteInfo"
Set cRs = LS.DB.Query(strSelect)
Do While Not cRs.Eof
SI_Domain = cRs("SI_Domain")
If LS.VD(SI_Domain,"url") Then
SI_Domain = Replace(SI_Domain & "","http://","")
SI_Domain = Replace(SI_Domain & "",":",".")
Call LS.FSO.CreateFile(G_CONFIG_PATH & SI_Domain,"")
End If
cRs.MoveNext
Loop
End Function
'检查要更新缓存站点
Private Function CheckSiteInfoConfig()
CheckSiteInfoConfig = False
If LS.FSO.IsFile(G_CONFIG_PATH & G_CURSITE_URL) Then
CheckSiteInfoConfig = True
LS.FSO.DeleteFile(G_CONFIG_PATH & G_CURSITE_URL)
End If
End Function
'保存站点缓存到文件，加快初次载入的速度
Public Function SaveXML(ByVal xmltype)
Select Case xmltype
Case "1"
Application(G_CACHENAME & "_PortalClass").Save(Server.MapPath(G_CONFIG_PATH & G_SITESTRUCTUR_XML))
Call CreateSiteInfoConfig()
End Select
End Function
'站点结构字段
Public Function SiteStructureFields()
Dim strField
strField = "SS_ID,SS_Path,PSS_ID,SS_SiteID,SS_No,SS_Type,SS_Name,SS_SubItem,SS_URL,SS_LinkURL,SS_HtmlUrl,SS_DocTpl,SI_Domain,"
strField = strField & "SS_LMID,ModelTable,ModelID,ArDST_ID,SS_CheckIn,TempleteID,BoardNum,pic_width,pic_height,SS_Article,SS_FIID,IsLeader,IsUnit,SS_IDFrom,ss_imgURL"
strField = strField & ",mess_type"
SiteStructureFields = strField
End Function
'站点结构缓存
Public Function refreshCache(ByVal SS_ID, ByVal Action)
If SS_ID = "" Then Exit Function
Dim strField
strField = SiteStructureFields()
Select Case Action
Case "add"
'向缓存追加节点
Set newNode = Application(G_CACHENAME & "_PortalClass").DocumentElement.appendChild(Application(G_CACHENAME & "_PortalClass").createNode(1, "k", ""))
strSelect = "select " & strField & " from SiteStructure Where SS_ID=" & SS_ID
Set cRs = LS.DB.Query(strSelect)
strField = Split(strField, ",")
Application.Lock
For m = 0 To UBound(strField)
newNode.setAttribute "w" & m, cRs(strField(m))&""
Next
Application.UnLock
cRs.Close
Set cRs = Nothing
Set newNode = Nothing
Case "edit"
'修改缓存记录
Set newNode = Application(G_CACHENAME & "_PortalClass").DocumentElement.SelectSingleNode("k[@w0=" & SS_ID & "]")
strSelect = "select " & strField & " from SiteStructure Where SS_ID=" & SS_ID
Set cRs = LS.DB.Query(strSelect)
If Not cRs.EOF Then
strField = Split(strField, ",")
Application.Lock
For m = 0 To UBound(strField)
newNode.SelectSingleNode("@w"&m).text = cRs(strField(m))&""
Next
Application.UnLock
Else
Call refreshCache(SS_ID, "del")
End If
cRs.Close
Set cRs = Nothing
Set newNode = Nothing
Case "del"
Application.Lock
Set Node = Application(G_CACHENAME & "_PortalClass").documentElement.selectSingleNode("k[@w0='" & SS_ID & "']")
If Not Node Is Nothing Then
Node.parentNode.removeChild(Node)
End If
Set Node = Nothing
Application.UnLock
End Select
End Function
'站点结构
Public Function InitSiteStructure()
strSelect = "select "& SiteStructureFields() &" from SiteStructure order by SS_Path"
If LS.FSO.IsFile(G_CONFIG_PATH & G_SITESTRUCTUR_XML) Then
Set SiteStructureXML = Server.CreateObject("msxml2.FreeThreadedDOMDocument.3.0")
SiteStructureXML.async = False
SiteStructureXML.setProperty "ServerHTTPRequest", True
SiteStructureXML.load(Server.MapPath(G_CONFIG_PATH & G_SITESTRUCTUR_XML))
Application.Lock
Set Application(G_CACHENAME & "_PortalClass") = SiteStructureXML
Application.UnLock
Else
Set aRs = LS.DB.Query(strSelect)
Application.Lock
Set Application(G_CACHENAME & "_PortalClass") = LS.ToXmlWT(aRs, "k", "c")
Application.UnLock
aRs.Close
Set aRs = Nothing
Call SaveXML(1)
End If
End Function
'站点结构PATH的子孙表
Public Function InitClassSubIDs()
strSelect = "select SS_ID,SS_Path from v_ClassSubIDs"
Set aRs = LS.DB.Query(strSelect)
Application.Lock
Set Application(G_CACHENAME & "_PortalSubClass") = LS.ToXmlWT(aRs, "k", "c")
Application.UnLock
aRs.Close
Set aRs = Nothing
End Function
'模块表
Public Function InitPublicModule()
strSelect = "select PM_Type,PM_Name,PM_Url,PM_Imgone,PM_Imgtwo,PM_LimitsID,PM_LimitsVal "
strSelect = strSelect & " from PublicModule order by PM_Type"
Set aRs = LS.DB.Query(strSelect)
Application.Lock
Set Application(G_CACHENAME & "_PublicModule") = LS.ToXmlWT(aRs, "k", "c")
Application.UnLock
aRs.Close
Set aRs = Nothing
End Function
'站点信息
Public Function InitSiteInfo()
strSelect = "select SS_SiteID,SI_Name,SI_Title,SI_Domain,SI_Logo,SI_Keywords,SI_Description,SI_Copyright,SI_BeiAnNo,"
strSelect = strSelect & "SI_Dir,SI_IndexUrl,YUANPAN_ENABLE,YUANPAN_DOMAIN,YUANPAN_videourl,SI_Isvideo,SI_Isfb,SI_Isxxgk,SI_IsHtml"
strSelect = strSelect & " from SiteInfo"
Set aRs = LS.DB.Query(strSelect)
If aRs.EOF Then
aRs.Close
Call OutScript("请设置当前站点ID！")
End If
Application.Lock
Set Application(G_CACHENAME & "_SiteInfo") = LS.ToXmlWT(aRs, "k", "c")
Application.UnLock
aRs.Close
Set aRs = Nothing
End Function
'广告信息
Public Function InitADInfo()
strSelect = "select AI_ID,AS_ID,AI_Name,AI_LogoURL,AI_URL,AS_LogoIS,AS_LogoWidth,AS_LogoHeight from v_ADInfo "
Set aRs = LS.DB.Query(strSelect)
Application.Lock
Set Application(G_CACHENAME & "_ADInfo") = LS.ToXmlWT(aRs, "k", "c")
Application.UnLock
aRs.Close
Set aRs = Nothing
End Function
'热字库表
Public Function InitHotWordsModule()
strSelect = "select HW_ID,HW_TITLE,HW_TYPE,HW_URL,HW_CONTENT "
strSelect = strSelect & " from HotWords order by HW_ID"
Set aRs = LS.DB.Query(strSelect)
Application.Lock
Set Application(G_CACHENAME & "_HotWords") = LS.ToXmlWT(aRs, "k", "c")
Application.UnLock
aRs.Close
Set aRs = Nothing
End Function
'敏感词库表
Public Function InitfilterwordsModule()
strSelect = "select FW_ID,FW_TITLE,FW_TITLE1 "
strSelect = strSelect & " from filterwords order by FW_ID"
Set aRs = LS.DB.Query(strSelect)
Application.Lock
Set Application(G_CACHENAME & "_filterwords") = LS.ToXmlWT(aRs, "k", "c")
Application.UnLock
aRs.Close
Set aRs = Nothing
End Function
'取得当前栏目下所有子栏目ID
Public Function ReadPid(id)
Set Conn = LS.CreateConn()
If id = "" Then Exit Function
Set cmd = server.CreateObject("Adodb.Command")
cmd.ActiveConnection = Conn
cmd.CommandType = 4
cmd.commandText = "GetxxgkCid1"
cmd("@id") = id
cmd.Execute()
rv = cmd("@return_value")
ReadPid = rv '显示返回值
End Function
Public Function CreateHtmlDateTime()
CreateHtmlDateTime = vbCrLf & ""
End Function
Public Sub OnlineUser(ByVal UA_ID) '添加当前用户在线
If Instr(Application("OnlineUser"),"|"&UA_ID&"^%^") = 0 Then
Application.Lock()
Application("OnlineUser") = Application("OnlineUser") & "|" & UA_ID & "^%^" & CStr(FormatDateTime(Now(),0)) & "|"
Application.UnLock()
End If
End Sub
Public Sub OutlineUser(ByVal UA_ID) '删除当前用户在线
On Error Resume Next
Application.Lock()
z = ""
tUser = Replace(Application("OnlineUser"),"||",",")
tUser = Replace(tUser,"|","")
Ar_tUser = Split(tUser,",")
For x = 0 to UBound(Ar_tUser)
y = Split(Ar_tUser(x),"^%^")
If CInt(y(0)) <> CInt(UA_ID) Then z = z & "|" &y(0)& "^%^" & y(1) & "|"
Next
Application("OnlineUser") = z
Application.UnLock()
End Sub
Public Sub UpdateOnlineUser(ByVal UA_ID) '更新当前用户在线时间
On Error Resume Next
Application.Lock()
z = ""
tUser = Replace(Application("OnlineUser"),"||",",")
tUser = Replace(tUser,"|","")
Ar_tUser = Split(tUser,",")
For x = 0 to UBound(Ar_tUser)
y = Split(Ar_tUser(x),"^%^")
If CInt(y(0)) = CInt(UA_ID) Then
z = z & "|" &y(0)& "^%^" & CStr(FormatDateTime(Now(),0)) & "|"
else
z = z & "|" &y(0)& "^%^" & y(1) & "|"
end if
Next
Application("OnlineUser") = z
Application.UnLock()
End Sub
'初始化
'=======================================================================================================================
Set LS = Server.CreateObject("Lonsun4_0.LonsunCode")
If Err <> 0 Then
Response.Write "
Lonsun4_0.dll Unregistered!
"
Response.End()
End If
'开启调试模式
LS.DDebug = False
'缓存名称
LS.CacheName = G_CACHENAME
'设置数据库类型
LS.DB.DBType = "SQL_SP"
'分页模板名称
LS.DB.PageClass = "pagenav"
'加载数据库
Call LS.DB.OpenConn()
If IsObject(Session(G_CACHENAME & "_UserInfo")) Then
'用户ID
G_UAID = LS.UserInfo(0)
'用户类型
G_UATYPE = LS.UserInfo(3)
'用户姓名
G_UANAME = LS.UserInfo(6)
'用户单位ID
G_UIID = LS.UserInfo(1)
'用户单位名称
G_UINAME = LS.UserInfo(5)
'用户单位PATH
G_UIPATH = LS.UserInfo(2)
'超管模块
G_MODULE = LS.UserInfo(15)
'用户权限
G_UARIGHTS = LS.UserInfo(100)
'站点ID
G_SITEID = LS.UserInfo(19)
End If
%>
<%
Const LicUserName = "系统配置"
Const FsoAddStr = ""
Const WebStyle = 2
Const RootPath = "/"
Const IndexHtmlDir = "/IndexHtml/"
Const DocHtmlDir = "/DocHtml/"
Const SortHtmlDir = "/SortHtml/"
Const UploadFileDir = "/UploadFile/"
Const STATICLIST = "list_"
Const STATICONTENT = "doc_"
Const STATICEXT = ".html"
%>
<%
Class JsonCore
Public Collection
Public Count
Public QuotedVars
Public Kind ' 0 = object, 1 = array
Private Sub Class_Initialize
Set Collection = Server.CreateObject("Scripting.Dictionary")
QuotedVars = True
Count = 0
End Sub
Private Sub Class_Terminate
Set Collection = Nothing
End Sub
' counter
Private Property Get Counter
Counter = Count
Count = Count + 1
End Property
' - data maluplation
' -- pair
Public Property Let Pair(p, v)
If IsNull(p) Then p = Counter
Collection(p) = v
End Property
Public Property Set Pair(p, v)
If IsNull(p) Then p = Counter
If TypeName(v) <> "JsonCore" Then
Err.Raise &hD, "class: class", "Incompatible types: '" & TypeName(v) & "'"
End If
Set Collection(p) = v
End Property
Public Default Property Get Pair(p)
If IsNull(p) Then p = Count - 1
If IsObject(Collection(p)) Then
Set Pair = Collection(p)
Else
Pair = Collection(p)
End If
End Property
' -- pair
Public Sub Clean
Collection.RemoveAll
End Sub
Public Sub Remove(vProp)
Collection.Remove vProp
End Sub
' data maluplation
' encoding
Function jsEncode(str)
Dim charmap(127), haystack()
charmap(8) = "\b"
charmap(9) = "\t"
charmap(10) = "\n"
charmap(12) = "\f"
charmap(13) = "\r"
charmap(34) = "\"""
charmap(47) = "\/"
charmap(92) = "\\"
Dim strlen : strlen = Len(str) - 1
ReDim haystack(strlen)
Dim i, charcode
For i = 0 To strlen
haystack(i) = Mid(str, i + 1, 1)
charcode = AscW(haystack(i)) And 65535
If charcode < 127 Then
If Not IsEmpty(charmap(charcode)) Then
haystack(i) = charmap(charcode)
ElseIf charcode < 32 Then
haystack(i) = "\u" & Right("000" & Hex(charcode), 4)
End If
Else
haystack(i) = "\u" & Right("000" & Hex(charcode), 4)
End If
Next
jsEncode = Join(haystack, "")
End Function
' converting
Public Function toJSON(vPair)
Select Case VarType(vPair)
Case 0 ' Empty
toJSON = "null"
Case 1 ' Null
toJSON = "null"
Case 7 ' Date
' toJSON = "new Date(" & (vPair - CDate(25569)) * 86400000 & ")" ' let in only utc time
toJSON = """" & CStr(vPair) & """"
Case 8 ' String
toJSON = """" & jsEncode(vPair) & """"
Case 9 ' Object
Dim bFI,i
bFI = True
If vPair.Kind Then toJSON = toJSON & "[" Else toJSON = toJSON & "{"
For Each i In vPair.Collection
If bFI Then bFI = False Else toJSON = toJSON & ","
If vPair.Kind Then
toJSON = toJSON & toJSON(vPair(i))
Else
If QuotedVars Then
toJSON = toJSON & """" & i & """:" & toJSON(vPair(i))
Else
toJSON = toJSON & i & ":" & toJSON(vPair(i))
End If
End If
Next
If vPair.Kind Then toJSON = toJSON & "]" Else toJSON = toJSON & "}"
Case 11
If vPair Then toJSON = "true" Else toJSON = "false"
Case 12, 8192, 8204
toJSON = RenderArray(vPair, 1, "")
Case Else
toJSON = Replace(vPair, ",", ".")
End select
End Function
Function RenderArray(arr, depth, parent)
Dim first : first = LBound(arr, depth)
Dim last : last = UBound(arr, depth)
Dim index, rendered
Dim limiter : limiter = ","
RenderArray = "["
For index = first To last
If index = last Then
limiter = ""
End If
On Error Resume Next
rendered = RenderArray(arr, depth + 1, parent & index & "," )
If Err = 9 Then
On Error GoTo 0
RenderArray = RenderArray & toJSON(Eval("arr(" & parent & index & ")")) & limiter
Else
RenderArray = RenderArray & rendered & "" & limiter
End If
Next
RenderArray = RenderArray & "]"
End Function
Public Property Get jsString
jsString = toJSON(Me)
End Property
Sub Flush
If TypeName(Response) <> "Empty" Then
Response.Write(jsString)
ElseIf WScript <> Empty Then
WScript.Echo(jsString)
End If
End Sub
Public Function Clone
Set Clone = ColClone(Me)
End Function
Private Function ColClone(core)
Dim jsc, i
Set jsc = new jsCore
jsc.Kind = core.Kind
For Each i In core.Collection
If IsObject(core(i)) Then
Set jsc(i) = ColClone(core(i))
Else
jsc(i) = core(i)
End If
Next
Set ColClone = jsc
End Function
End Class
Public Function JsObject()
Set JsObject = new JsonCore
JsObject.Kind = 0
End Function
Public Function JsArray()
Set JsArray = new JsonCore
JsArray.Kind = 1
End Function
Public Function toJSON(val)
toJSON = (new JsonCore).toJSON(val)
End Function
Public Function Callback(ByVal r_status,ByVal r_desc,ByRef r_data)
Dim JsonData_
Set pJson_ = JsObject()
pJson_("status") = r_status
pJson_("desc") = r_desc
If TypeName(r_data) = "JsonCore" then
Set pJson_("data") = r_data
Set r_data = Nothing
Else
pJson_("data") = r_data
End If
JsonData_ = toJSON(pJson_)
Set pJson_ = Nothing
Response.Write JsonData_
Response.End()
End Function
%>
<%
Public Function ClearApp(ByVal SSType,ByVal SSID)
Dim v_CacheName
v_CacheName = ""
If SSType="" Or Not IsNumeric(SSType) Then Exit Function
Select Case SSType
'普通页面
Case 1
v_CacheName = "" &_
"_SortMenuList_New_" & SSID & ","
'文字列表
Case 2
v_CacheName = "" &_
"_IndexDocList_" & SSID & "," &_
"_IndexTopDocList_" & SSID & "," &_
"_IndexDocList_Sub_" & SSID & "," &_
"_IndexImageList_" & SSID & "," &_
"_SortMenuList_New_" & SSID & ","
'广告管理
Case 4
v_CacheName = "" &_
"_AD_" & SSID & "," &_
"_ADMenu_" & SSID & ","
'视频点播
Case 8
v_CacheName = "" &_
"_IndexVodList_" & SSID & ","
'文件下载
Case 10
v_CacheName = "" &_
"_IndexDownList_" & SSID & ","
'领导之窗
Case 15
v_CacheName = "" &_
"_SortMenuList_New_" & SSID & ","
'场景式服务
Case 95
'自定义查询
Case 108
'会员管理
Case 101
v_CacheName = "" &_
"" & ","
'广告管理
Case 105
v_CacheName = "" &_
"" & ","
'评论管理
Case 66
v_CacheName = "" &_
"IndexbbsList" & SSID & ","
'在线办事
Case 80
v_CacheName = "" &_
"_BanshiSortList_" & SSID & ","
Case 81
v_CacheName = "" &_
"" & ","
Case 82
v_CacheName = "" &_
"" & ","
'民意征集
Case 62
v_CacheName = "" &_
"_IndexSolicitList_" & SSID & "," &_
"" & ","
'在线调查
Case 63
v_CacheName = "" &_
"_IndexVoteList_" & SSID & "," &_
"" & ","
'网上评议
Case 64
v_CacheName = "" &_
"" & ","
'在线留言
Case 60
v_CacheName = "" &_
"_IndexMessageInfolist_" & SSID & "," &_
"_IndexMessagelist_" & SSID & ","
'在线访谈
Case 61
v_CacheName = "" &_
"_InterViewimgs_" & SSID & ","
'信息公开
Case 109
v_CacheName = "" &_
"_IndexDocOpenLists_" & SSID & "," &_
"_IndexDocOpenList_" & SSID & ","
Case 110
v_CacheName = "" &_
"_filterwords,"
End Select
v_CacheName = Split(v_CacheName,",")
For y=0 to Ubound(v_CacheName)
If v_CacheName(y)<>"" Then
Application.Lock
Application.Contents.Remove(G_CACHENAME & v_CacheName(y))
Application.UnLock
End If
Next
End Function
Public Function ClearLMID(ByVal SS_ID,ByVal SS_Type)
strSSID = CCfg(SS_ID,13)
If Not LS.IsN(strSSID) Then
strSSID = Split(strSSID,",")
For i=0 to Ubound(strSSID)
Call ClearApp(SS_Type,strSSID(i))
Next
Else
Call ClearApp(SS_Type,SS_ID)
End If
End Function
%>
<%
Dim objXmlHttp, binFileData, objAdoStream
Dim lresolveTimeout, lconnectTimeout, lsendTimeout, lreceiveTimeout
lresolveTimeout = 30000 ' 解析DNS名字的超时时间,10秒
lconnectTimeout = 20000 ' 建立Winsock连接的超时时间,10秒
lsendTimeout = 12000 ' 发送数据的超时时间,12秒
lreceiveTimeout = 20000 ' 接收response的超时时间,20秒
Public Function GetResStr(URL)
objXmlHttp.Open "GET", URL, False '以上已设置后。就打开网址。参数1:提交方式,url地址,异步执行 一般选择异步执行
objXmlHttp.Send() '调用Send方法发送XML数据
If objXmlHttp.Readystate = 4 Then '文档已经解析完毕，客户端可以接受返回消息
If objXmlHttp.status = 200 Then '接收返回的错误
ResStr = objXmlHttp.responseText '接收返回的信息..(源代码一般)
GetResStr = ResStr '返回值
End If
End If
End Function
Public Sub HtmlComm(strUrl, FilePath)
If InStr(strUrl, ".asp") Then
strUrl = Replace(strUrl, "shtml", "asp")
End If
Dim p1
p1 = InStr(strUrl, "?")
If p1>0 Then
strUrl = strUrl & "&tm=" & Timer()
Else
strUrl = strUrl & "?tm=" & Timer()
End If
objXmlHttp.setTimeouts lresolveTimeout, lconnectTimeout, lsendTimeout, lreceiveTimeout
Call LS.FSO.CreateFile(FilePath, GetResStr(strUrl))
If Err <> 0 Then Response.Write Error.Description
End Sub
'返回动态包含文件字符串
Public Function tGetInclude(ByVal filePath)
'On Error Resume Next
If G_CREATEHTMLTYPE Then
If tmpReadPath<>filePath Then
tmpTemplate = LS.FSO.IncludeCode(LS.FSO.Include(filePath), 1)
End If
tmpReadPath = filePath
ExecuteGlobal tmpTemplate
tGetInclude = IHCHtml
If Err.Number<>0 Then
GetInclude = "包含文件内部运行错误，请检查包含文件代码！ ( " & LS.FileName(filePath) & ".shtml )"
End If
Else
p1 = InStr(filePath, "?")
If p1>0 Then
filePath = filePath & "&s=" & Timer()
Else
filePath = filePath & "?s=" & Timer()
End If
tGetInclude = tGetResStr(filePath) & CreateHtmlDateTime()
End If
'Err.Clear
End Function
Private Function tGetResStr(ByVal URL)
tGetResStr = ""
If TypeName(objXmlHttp)<>"IServerXMLHTTPRequest2" Then
Set objXmlHttp = Server.CreateObject("Msxml2.ServerXMLHTTP")
Set objAdoStream = Server.CreateObject("ADODB.Stream")
objAdoStream.Type = 1
objXmlHttp.setTimeouts lresolveTimeout, lconnectTimeout, lsendTimeout, lreceiveTimeout
End If
objXmlHttp.Open "GET", URL, False '以上已设置后。就打开网址。参数1:提交方式,url地址,异步执行 一般选择异步执行
objXmlHttp.Send() '调用Send方法发送XML数据
If objXmlHttp.Readystate = 4 Then '文档已经解析完毕，客户端可以接受返回消息
If objXmlHttp.status = 200 Then '接收返回的错误
ResStr = objXmlHttp.responseText '接收返回的信息..(源代码一般)
tGetResStr = ResStr '返回值
End If
End If
End Function
'生成首页
Private Sub tRefreshIndex(ByVal SITE_ID)
Dim SiteDir
Dim IndexTemplate, SaveFilePath, IndexFileContent
If SITE_ID = "" Or Not IsNumeric(SITE_ID) Then Exit Sub
' SiteDir = SiteCfg(SITE_ID, 9)
' If LS.IsN(SiteDir) Then
' Exit Sub
' End If
If G_ROOTPATH = "" Then G_ROOTPATH = Server.MapPath("../")
If Not G_CREATEHTMLTYPE Then
IndexTemplate = SiteCfg(SITE_ID, 3) & "/Tmp/" & SiteCfg(SITE_ID, 10) & "?x=1"
Else
IndexTemplate = G_ROOTPATH & "\" & SiteCfg(SITE_ID, 9) &"\template\" & SiteCfg(SITE_ID, 10)
If Not LS.FSO.IsFile(IndexTemplate) Then
Exit Sub
End If
End If
'保存路径
SaveFilePath = G_ROOTPATH & "\" & SiteCfg(SITE_ID, 9) &"\" & "index" & STATICEXT
IndexFileContent = tGetInclude(IndexTemplate)
Call LS.CreateFile(SaveFilePath, IndexFileContent)
Set objXmlHttp = Nothing
Set objAdoStream = Nothing
End Sub
'生成栏目页
Private Sub tRefreshClass(ByVal Path)
If Path = "" Then Exit Sub
Dim SS_ID, SS_LMID
Dim WebRootPath, TemplatePath, SaveFilePath, d_SaveFilePath, d_DocFileContent
SS_SiteID = CPathCfg(Path, 3)&""
if SS_SiteID=0 then SS_SiteID=CPathCfg(Path, 0)
'是否开启页面触发器
If SiteCfg(SS_SiteID, 17) Then
SS_LMID = CPathCfg(Path, 13)&","&CPathCfg(Path, 0)
Else
SSLen = Len(Path)
SortCount = (SSLen -1) / 4
For k = 0 To SortCount - 2
SS_LMID = SS_LMID & CPathCfg(Left(Path, SSLen - (k * 4)), 0) & ","
Next
SS_LMID = Left(SS_LMID, Len(SS_LMID) -1)&","&SS_SiteID
End If
SS_LMID = LS.Repeat(SS_LMID, ",")&""
SaveFilePath = Replace(G_ROOTPATH & SortHtmlDir & SS_SiteID & "\", "/", "\")
SS_LMID = LS.toIDS(SS_LMID)
SS_LMID = Split(SS_LMID&"", ",")
For i = 0 To UBound(SS_LMID)
tSS_ID = SS_LMID(i)
'如果ID中有站点，调用生成首函数
If CCfg(tSS_ID, 5) = "1000" Or CCfg(tSS_ID, 5) = "1001" Then
Call tRefreshIndex(tSS_ID)
Else
'模板路径
If Not G_CREATEHTMLTYPE Then
TemplatePath = CCfg(tSS_ID, 12) & Replace("/tmp/" & CCfg(tSS_ID, 8) & "?SS_ID=" & tSS_ID, "//", "/")
Else
TemplatePath = G_ROOTPATH & "\" & SiteCfg(CCfg(tSS_ID, 3), 9) & "\template\" & Replace(CCfg(tSS_ID, 8), "/", "\")
End If
'保存路径
d_SaveFilePath = SaveFilePath & STATICLIST & tSS_ID & STATICEXT
'获取模板内容
d_DocFileContent = tGetInclude(TemplatePath)
'保存内容到磁盘
Call LS.CreateFile(d_SaveFilePath, d_DocFileContent)
End If
Next
Set objXmlHttp = Nothing
Set objAdoStream = Nothing
End Sub
'生成专题首页
Public Sub RefreshSpecialClass(ByVal SS_ID, ByVal styleID)
Call tRefreshSpecialClass(SS_ID, styleID)
End Sub
Private Sub tRefreshSpecialClass(ByVal SS_ID, ByVal styleID)
SS_SiteID = CCfg(SS_ID, 3)
Select Case styleID
Case "1"
indexHTML = "index.shtml"
Case "2"
indexHTML = "nav.shtml"
End Select
'模板路径
If Not G_CREATEHTMLTYPE Then
TemplatePath = CCfg(SS_ID, 12) & Replace("/tmp/special/" & SS_ID & "/"& indexHTML &"?SS_ID=" & SS_ID & "&styleID="& StyleID, "//", "/")
Else
TemplatePath = G_ROOTPATH & "\" & SiteCfg(CCfg(SS_ID, 3), 9) & "\template\special\" & Replace(CCfg(SS_ID, 8), "/", "\")
End If
'保存路径
SaveFilePath = Replace(G_ROOTPATH & SortHtmlDir & SS_SiteID & "\", "/", "\")
d_SaveFilePath = SaveFilePath & STATICLIST & SS_ID & STATICEXT
'获取模板内容
d_DocFileContent = tGetInclude(TemplatePath)
'保存内容到磁盘
Call LS.CreateFile(d_SaveFilePath, d_DocFileContent)
Set objXmlHttp = Nothing
Set objAdoStream = Nothing
End Sub
'生成专题文章页
Public Sub RefreshSpecialContent(ByVal d_ID, ByVal styleID)
Call tRefreshSpecialContent(d_ID, styleID)
End Sub
Private Sub tRefreshSpecialContent(ByVal d_ID, ByVal styleID)
End Sub
Private Sub tRefreshContent(ByVal d_ID)
If d_ID = "" Or Not IsNumeric(d_ID) Then Exit Sub
Dim HtmlDomain, SaveFilePath, TemplatePath
strSelect = "Select SS_ID,SS_SiteID,d_HtmlPath,d_HtmlUrl from DocContents where d_CheckIn=1 and d_ID="& d_ID
Set Rs = LS.CreateRs(strSelect, 1, 1)
If Rs.EOF Then
Rs.Close
Set Rs = Nothing
Exit Sub
End If
SS_ID = Rs("SS_ID")
SS_SiteID = Rs("SS_SiteID")
d_HtmlPath = Rs("d_HtmlPath")
d_HtmlUrl = Rs("d_HtmlUrl")
Rs.Close
Set Rs = Nothing
'访问地址
HtmlDomain = CCfg(SS_SiteID, 12) & DocHtmlDir & SS_SiteID & "/" & d_HtmlPath
'保存路径
SaveFilePath = Replace(G_ROOTPATH & DocHtmlDir & SS_SiteID & "\" & d_HtmlPath, "/", "\")
If Not G_CREATEHTMLTYPE Then
TemplatePath = CCfg(SS_ID, 12) & "/tmp/" & CCfg(SS_ID, 11) & "?d_ID=" & d_ID & "&SS_ID=" & SS_ID
Else
'模板路径
TemplatePath = G_ROOTPATH & "\" & SiteCfg(SS_SiteID, 9) & "\template\" & Replace(CCfg(SS_ID, 11), "/", "\")
End If
'生成文件名
d_SaveFilePath = SaveFilePath & d_HtmlUrl & STATICEXT
'获取模板内容
d_DocFileContent = tGetInclude(TemplatePath)
'保存内容到磁盘
Call LS.CreateFile(d_SaveFilePath, d_DocFileContent)
Set objXmlHttp = Nothing
Set objAdoStream = Nothing
End Sub
'生成主页html
Public Sub CreateIndexHtml(ByVal SSSiteID)
Call tRefreshIndex(SSSiteID)
End Sub
'生成指定ID的文章html
Sub CreateDocHtml(d_ID)
Call tRefreshContent(d_ID)
End Sub
'生成与指定路径相关的栏目html
Sub CreatePathSortHtml(ByVal SS_Path)
Call tRefreshClass(SS_Path)
End Sub
Public Sub CreateIDSortHtml(theid) '生成指定ID下一级的栏目html
If theid = "" Then Exit Sub
Set objXmlHttp = Server.CreateObject("Msxml2.ServerXMLHTTP")
Set objAdoStream = Server.CreateObject("ADODB.Stream")
objAdoStream.Type = 1
sql = "select SS_ID,SS_URL,SI_Domain,SS_HtmlUrl from SiteStructure where PSS_ID="&theid&" and (SS_Type<4 or SS_Type=95) and SS_CheckIn<>0 order by SS_Path desc"
Set Rs = LS.CreateRs(sql, 1, 1)
rscount = Rs.recordcount
For k = 1 To rscount
SS_HtmlUrl = Rs("SS_HtmlUrl")
SS_URL = Rs("SS_URL")
tSS_ID = Rs("SS_ID")
SI_Domain = Rs("SI_Domain")
strUrl = SI_Domain & "/tmp/" & SS_URL & "?SS_ID=" & tSS_ID
FileName = SS_HtmlUrl
FilePath = Server.MapPath(FileName)
Call HtmlComm(strUrl, FilePath)
Rs.movenext
Next
Rs.Close
Set objXmlHttp = Nothing
Set objAdoStream = Nothing
End Sub
'生成指定ID下一级的栏目html
Public Sub CreateIDSortHtml_zt(theid)
If theid = "" Then Exit Sub
Set objXmlHttp = Server.CreateObject("Msxml2.ServerXMLHTTP")
Set objAdoStream = Server.CreateObject("ADODB.Stream")
objAdoStream.Type = 1
sql = "select SS_ID,SS_URL,SI_Domain,SS_HtmlUrl from SiteStructure where SS_path like '%"&ReadSSPath(theid)&"%' and (SS_Type<4 or SS_Type=95) and SS_CheckIn<>0 order by SS_Path desc"
Set Rs = LS.CreateRs(sql, 1, 1)
rscount = Rs.recordcount
For k = 1 To rscount
SS_HtmlUrl = Rs("SS_HtmlUrl")
SS_URL = Rs("SS_URL")
tSS_ID = Rs("SS_ID")
SI_Domain = Rs("SI_Domain")
strUrl = SI_Domain & "/tmp/" & SS_URL &"?SS_ID=" & tSS_ID
FileName = SS_HtmlUrl
FilePath = Server.MapPath(FileName)
Call HtmlComm(strUrl, FilePath)
Rs.movenext
Next
Rs.Close
Set objXmlHttp = Nothing
Set objAdoStream = Nothing
End Sub
'生成指定ID的栏目html
Public Sub CreateFirstSortHtml(StrSS_ID)
If StrSS_ID = "" Then Exit Sub
Set objXmlHttp = Server.CreateObject("Msxml2.ServerXMLHTTP")
'Set objXmlHttp = Server.CreateObject("Microsoft.XMLHTTP")
Set objAdoStream = Server.CreateObject("ADODB.Stream")
objAdoStream.Type = 1
sql = "select SS_ID,PSS_ID,SS_URL,SI_Domain,SS_HtmlUrl from SiteStructure where SS_ID=" & StrSS_ID & " and SS_CheckIn<>0"
Set Rs = LS.CreateRs(sql, 1, 1)
rscount = Rs.recordcount
For k = 1 To rscount
tPSS_ID = Rs("PSS_ID")
If tPSS_ID > 0 Then
SS_HtmlUrl = Rs("SS_HtmlUrl")
SS_URL = Rs("SS_URL")
tSS_ID = Rs("SS_ID")
SI_Domain = Rs("SI_Domain")
strUrl = SI_Domain & "/tmp/" & SS_URL & "?SS_ID=" & tSS_ID
FileName = SS_HtmlUrl
FilePath = Server.MapPath(FileName)
Call HtmlComm(strUrl, FilePath)
End If
Rs.movenext
Next
Rs.Close
Set objXmlHttp = Nothing
Set objAdoStream = Nothing
End Sub
'生成指定领导ID的文章html
Public Sub CreateLwHtml(d_ID)
If d_ID = "" Then Exit Sub
sql = "Select SS_ID,lw_date from LeaderWindow where LW_CheckIn<>0 and LW_ID="& d_ID
Set Rs = Ls.CreateRs(sql, 1, 1)
If Rs.EOF Then
Rs.Close
Exit Sub
End If
SS_ID = Rs("SS_ID")
lw_date = rs("lw_date")
Rs.Close
'读取模板ID
ArDST_ID = CCfg(SS_ID, 16)
SS_SiteID = CCfg(SS_ID, 3)
SI_Domain = CCfg(SS_ID, 12)
'读取文章页模板
sqlt = "select DST_URL from DocShowType where DST_ID="&Replace(ArDST_ID, "|", "")
Set rst = Ls.CreateRs(sqlt, 1, 1)
If Not rst.EOF Then
DST_URL = rst("DST_URL")
End If
rst.Close
'站点根路径
If G_ROOTPATH = "" Then G_ROOTPATH = Server.MapPath("../")
'访问地址
HtmlDomain = CCfg(SS_SiteID, 12) & DocHtmlDir & SS_SiteID & "/"
'保存路径
SaveFilePath = Replace(G_ROOTPATH & DocHtmlDir & SS_SiteID&"/"&Year(lw_date)&"/"&Month(lw_date), "/", "\")
If Not G_CREATEHTMLTYPE Then
TemplatePath = CCfg(SS_SiteID, 12) & "/tmp/" & DST_URL & "?SS_ID="&SS_ID&"&d_ID=" & d_ID
Else
'模板路径
TemplatePath = G_ROOTPATH & "\" & SiteCfg(SS_SiteID, 9) & "\template\" & DST_URL
End If
'生成文件名
d_SaveFilePath = SaveFilePath & "\Ld_" & d_ID & ".html"
'获取模板内容
d_DocFileContent = tGetInclude(TemplatePath)
'保存内容到磁盘
Call LS.CreateFile(d_SaveFilePath, d_DocFileContent)
Set objXmlHttp = Nothing
Set objAdoStream = Nothing
End Sub
'生成指定政民互动ID的文章html
Public Sub CreateDocInterHtml(m_ID)
If m_ID = "" Then Exit Sub
sql = "Select m_date,SS_ID from messagelist where m_ID="& m_ID
Set Rs = Ls.CreateRs(sql, 1, 1)
If Rs.EOF Then
Rs.Close
Exit Sub
End If
m_date = rs("m_date")
SS_ID = rs("SS_ID")
Rs.Close
Set Rs = Nothing
SS_SiteID = CCfg(SS_ID, 3)
SI_Domain = CCfg(SS_ID, 12)
DST_URL = CCfg(SS_ID, 11)
'站点根路径
If G_ROOTPATH = "" Then G_ROOTPATH = Server.MapPath("../")
'访问地址
HtmlDomain = SI_Domain & DocHtmlDir & SS_SiteID & "/"
'保存路径
SaveFilePath = Replace(G_ROOTPATH & DocHtmlDir & SS_SiteID&"/"&Year(m_date)&"/"&Month(m_date), "/", "\")
If Not G_CREATEHTMLTYPE Then
TemplatePath = SI_Domain & "/tmp/" & DST_URL & "?SS_ID="&SS_ID&"&m_ID=" & m_ID
Else
'模板路径
TemplatePath = G_ROOTPATH & "\" & SiteCfg(SS_SiteID, 9) & "\template\" & DST_URL
End If
'生成文件名
d_SaveFilePath = SaveFilePath & "\Mess_" & m_ID & ".html"
'获取模板内容
d_DocFileContent = tGetInclude(TemplatePath)
'保存内容到磁盘
Call LS.CreateFile(d_SaveFilePath, d_DocFileContent)
Set objXmlHttp = Nothing
Set objAdoStream = Nothing
End Sub
'生成指定在线调查主题ID的html
Sub CreateIDVoteNameHtml(d_ID)
If d_ID = "" Then Exit Sub
sql = "Select top 1 SS_ID,Vote_HtmlUrl from VoteName where (VoteUrl = '' or VoteUrl is null) and VoteID="& d_ID
Set Rs = Ls.CreateRs(sql, 1, 1)
If Rs.EOF Then
Rs.Close
Exit Sub
End If
SS_ID = Rs("SS_ID")
Vote_HtmlUrl = Rs("Vote_HtmlUrl")
Rs.Close
SS_SiteID = CCfg(SS_ID, 3)
SI_Domain = CCfg(SS_ID, 12)
DST_URL = CCfg(SS_ID, 11)
'站点根路径
If G_ROOTPATH = "" Then G_ROOTPATH = Server.MapPath("../")
HtmlDomain = CCfg(SS_SiteID, 12) & Vote_HtmlUrl
'保存路径
SaveFilePath = Replace(G_ROOTPATH & Vote_HtmlUrl, "/", "\")
'创建文件夹
If Not LS.FSO.IsFolder(SaveFilePath) Then LS.FSO.CreateFolder(SaveFilePath)
If Not G_CREATEHTMLTYPE Then
TemplatePath = CCfg(SS_SiteID, 12) & "/tmp/" & DST_URL & "?SS_ID="&SS_ID&"&VoteID=" & d_ID
Else
'模板路径
TemplatePath = G_ROOTPATH & "\" & SiteCfg(SS_SiteID, 9) & "\template\" & DST_URL
End If
'获取模板内容
d_DocFileContent = tGetInclude(TemplatePath)
'保存内容到磁盘
Call LS.CreateFile(SaveFilePath, d_DocFileContent)
Set objXmlHttp = Nothing
Set objAdoStream = Nothing
End Sub
'生成指定ID的办事文章html
Sub CreateBsHtml(BS_ID)
sql = "Select top 1 SS_ID,SS_SiteID from BsContents where BS_CheckIn<>0 and BS_Isdel=0 and (BS_RedirectLink is null or BS_RedirectLink='') and BS_ID="& BS_ID
Set Rs = LS.CreateRs(sql, 1, 1)
If Rs.EOF Then
Rs.Close
Exit Sub
End If
SS_ID = Rs("SS_ID")
SS_SiteID = Rs("SS_SiteID")
Rs.Close
Set Rs = Nothing
DST_URL = CCfg(SS_ID, 11)
'站点根路径
If G_ROOTPATH = "" Then G_ROOTPATH = Server.MapPath("../")
'访问地址
HtmlDomain = CCfg(SS_SiteID, 12) & DocHtmlDir & SS_SiteID & "/"
'保存路径
SaveFilePath = Replace(G_ROOTPATH & DocHtmlDir & SS_SiteID, "/", "\")
If Not G_CREATEHTMLTYPE Then
TemplatePath = CCfg(SS_SiteID, 12) & "/tmp/" & DST_URL & "?BS_ID=" & BS_ID
Else
'模板路径
TemplatePath = G_ROOTPATH & "\" & SiteCfg(SS_SiteID, 9) & "\template\" & DST_URL
End If
'生成文件名
d_SaveFilePath = SaveFilePath & "\Banshi_" & BS_ID & ".html"
'获取模板内容
d_DocFileContent = tGetInclude(TemplatePath)
'保存内容到磁盘
Call LS.CreateFile(d_SaveFilePath, d_DocFileContent)
Set objXmlHttp = Nothing
Set objAdoStream = Nothing
End Sub
'生成指定ID的论坛帖子html
Sub CreateBbsHtml(F_ID)
sql = "Select top 1 SS_ID,f_date from Forum where F_CheckIn<>0 and F_Isdel=0 and F_ID="& F_ID
Set Rs = LS.CreateRs(sql, 1, 1)
If Rs.EOF Then
Rs.Close
Exit Sub
End If
bSS_ID = Rs("SS_ID")
f_date = Rs("f_date")
Rs.Close
SS_SiteID = CCfg(bSS_ID, 3)
SI_Domain = CCfg(bSS_ID, 12)
DST_URL = CCfg(bSS_ID, 11)
'站点根路径
If G_ROOTPATH = "" Then G_ROOTPATH = Server.MapPath("../")
'访问地址
HtmlDomain = CCfg(SS_SiteID, 12) & DocHtmlDir & SS_SiteID & "/"
'保存路径
SaveFilePath = Replace(G_ROOTPATH & DocHtmlDir & SS_SiteID&"/"&Year(f_date)&"/"&Month(f_date), "/", "\")
If Not G_CREATEHTMLTYPE Then
TemplatePath = CCfg(SS_SiteID, 12) & "/tmp/" & DST_URL & "?F_ID=" & F_ID
Else
'模板路径
TemplatePath = G_ROOTPATH & "\" & SiteCfg(SS_SiteID, 9) & "\template\" & DST_URL
End If
'生成文件名
d_SaveFilePath = SaveFilePath & "\bbs_" & F_ID & ".html"
'获取模板内容
d_DocFileContent = tGetInclude(TemplatePath)
'保存内容到磁盘
Call LS.CreateFile(d_SaveFilePath, d_DocFileContent)
Set objXmlHttp = Nothing
Set objAdoStream = Nothing
End Sub
'生成指定在线访谈主题ID的html
Sub CreateIVSHtml(IVS_ID)
If IVS_ID = "" Then Exit Sub
sql = "Select IVS_SS_ID,IVS_HtmlUrl from InterViewSort where IVS_ID="& IVS_ID
Set Rs = Ls.CreateRs(sql, 1, 1)
If Rs.EOF Then
Rs.Close
Exit Sub
End If
SS_ID = Rs("IVS_SS_ID")
IVS_HtmlUrl = Rs("IVS_HtmlUrl")
Rs.Close
SS_SiteID = CCfg(SS_ID, 3)
SI_Domain = CCfg(SS_ID, 12)
DST_URL = CCfg(SS_ID, 11)
'站点根路径
If G_ROOTPATH = "" Then G_ROOTPATH = Server.MapPath("../")
'访问地址
HtmlDomain = CCfg(SS_SiteID, 12) & DocHtmlDir & SS_SiteID & "/"
'保存路径
SaveFilePath = Replace(G_ROOTPATH & IVS_HtmlUrl, "/", "\")
If Not G_CREATEHTMLTYPE Then
TemplatePath = CCfg(SS_SiteID, 12) & "/tmp/" & DST_URL & "?SS_ID="&SS_ID&"&IVS_ID=" & IVS_ID & "&action=docshow"
Else
'模板路径
TemplatePath = G_ROOTPATH & "\" & SiteCfg(SS_SiteID, 9) & "\template\" & DST_URL
End If
'生成文件名
d_SaveFilePath = SaveFilePath
'获取模板内容
d_DocFileContent = tGetInclude(TemplatePath)
'保存内容到磁盘
Call LS.CreateFile(d_SaveFilePath, d_DocFileContent)
Set objXmlHttp = Nothing
Set objAdoStream = Nothing
End Sub
'生成指定网上评议主题ID的html
Sub CreatePYHtml(d_ID)
sql = "Select top 1 SS_ID from Satisfaction where Nid="& d_ID
Set Rs = Ls.CreateRs(sql, 1, 1)
If Rs.EOF Then
Rs.Close
Exit Sub
End If
SS_ID = Rs("SS_ID")
Rs.Close
SS_SiteID = CCfg(SS_ID, 3)
SI_Domain = CCfg(SS_ID, 12)
DST_URL = CCfg(SS_ID, 11)
'站点根路径
If G_ROOTPATH = "" Then G_ROOTPATH = Server.MapPath("../")
'访问地址
HtmlDomain = CCfg(SS_SiteID, 12) & DocHtmlDir & SS_SiteID & "/"
'保存路径
SaveFilePath = Replace(G_ROOTPATH & DocHtmlDir & SS_SiteID, "/", "\")
If Not G_CREATEHTMLTYPE Then
TemplatePath = CCfg(SS_SiteID, 12) & "/tmp/" & DST_URL & "?SS_ID="&SS_ID&"&NID=" & d_ID
Else
'模板路径
TemplatePath = G_ROOTPATH & "\" & SiteCfg(SS_SiteID, 9) & "\template\" & DST_URL
End If
'生成文件名
d_SaveFilePath = SaveFilePath & "\Py_" & d_ID & ".html"
'获取模板内容
d_DocFileContent = tGetInclude(TemplatePath)
'保存内容到磁盘
Call LS.CreateFile(d_SaveFilePath, d_DocFileContent)
Set objXmlHttp = Nothing
Set objAdoStream = Nothing
End Sub
'生成指定民意征集主题ID的html
Sub CreateMYHtml(d_ID)
sql = "Select top 1 SS_ID,CC_HtmlUrl from CollectContents where CC_ID="& d_ID
Set Rs = Ls.CreateRs(sql, 1, 1)
If Rs.EOF Then
Rs.Close
Exit Sub
End If
SS_ID = Rs("SS_ID")
CC_HtmlUrl = Rs("CC_HtmlUrl")
Rs.Close
SS_SiteID = CCfg(SS_ID, 3)
SI_Domain = CCfg(SS_ID, 12)
DST_URL = CCfg(SS_ID, 11)
'站点根路径
If G_ROOTPATH = "" Then G_ROOTPATH = Server.MapPath("../")
HtmlDomain = CCfg(SS_SiteID, 12) & CC_HtmlUrl
'保存路径
SaveFilePath = Replace(G_ROOTPATH & CC_HtmlUrl, "/", "\")
'创建文件夹
If Not LS.FSO.IsFolder(SaveFilePath) Then LS.FSO.CreateFolder(SaveFilePath)
If Not G_CREATEHTMLTYPE Then
TemplatePath = CCfg(SS_SiteID, 12) & "/tmp/" & DST_URL & "?SS_ID="&SS_ID&"&CC_ID=" & d_ID
Else
'模板路径
TemplatePath = G_ROOTPATH & "\" & SiteCfg(SS_SiteID, 9) & "\template\" & DST_URL
End If
'获取模板内容
d_DocFileContent = tGetInclude(TemplatePath)
'保存内容到磁盘
Call LS.CreateFile(SaveFilePath, d_DocFileContent)
Set objXmlHttp = Nothing
Set objAdoStream = Nothing
End Sub
'=======信息公开 生成静态==========
'生成指定ID的单位栏目html
Sub CreateDOSortHtml(ByVal ID)
If ID = "" Or Not IsNumeric(ID) Then Exit Sub
sql = "select a.navTemplet,a.unitHtml,b.DST_URL,b.SS_SiteID,a.relevanceID from tb_common_units as a "
sql = sql & " inner join DocShowType as b on a.navTemplet=b.DST_ID where a.unitsId=" & ID & ""
Set Rs = LS.CreateRs(sql, 1, 1)
rscount = Rs.recordcount
If rscount > 0 Then
navTemplet = Rs("navTemplet")
SS_HtmlUrl = Rs("unitHtml")
SS_URL = Rs("DST_URL")
SS_SiteID = Rs("SS_SiteID")
unitHtml = Rs("unitHtml")
relevanceID = Rs("relevanceID")
End If
Rs.Close
Set Rs = Nothing
'站点根路径
If G_ROOTPATH = "" Then G_ROOTPATH = Server.MapPath("../")
'访问地址
HtmlDomain = CCfg(SS_SiteID, 12) & SortHtmlDir & SS_SiteID & "/"
'保存路径
SaveFilePath = Replace(G_ROOTPATH & unitHtml, "/", "\")
'关联栏目生成目录
SortSaveFilePath = Replace(G_ROOTPATH & SortHtmlDir & SS_SiteID & "\", "/", "\")
If Not Ls.IsN(relevanceID) Then
SS_LMID = LS.toIDS(LS.Repeat(relevanceID, ","))&""
SS_LMID = Split(SS_LMID&"", ",")
For i = 0 To UBound(SS_LMID)
tSS_ID = SS_LMID(i)
'如果ID中有站点，调用生成首函数
If CCfg(tSS_ID, 5) = "1000" Or CCfg(tSS_ID, 5) = "1001" Then
Call tRefreshIndex(tSS_ID)
Else
'模板路径
If Not G_CREATEHTMLTYPE Then
TemplatePath = CCfg(tSS_ID, 12) & Replace("/tmp/" & CCfg(tSS_ID, 8) & "?SS_ID=" & tSS_ID, "//", "/")
Else
TemplatePath = G_ROOTPATH & "\" & SiteCfg(CCfg(tSS_ID, 3), 9) & "\template\" & Replace(CCfg(tSS_ID, 8), "/", "\")
End If
'保存路径
d_SaveFilePath = SortSaveFilePath & STATICLIST & tSS_ID & STATICEXT
'获取模板内容
d_DocFileContent = tGetInclude(TemplatePath)
'保存内容到磁盘
Call LS.CreateFile(d_SaveFilePath, d_DocFileContent)
End If
Next
End If
If Not G_CREATEHTMLTYPE Then
TemplatePath = CCfg(SS_SiteID, 12) & "/tmp/" & SS_URL & "?unitsId=" & ID
Else
'模板路径
TemplatePath = G_ROOTPATH & "\" & SiteCfg(SS_SiteID, 9) & "\template\" & SS_URL
End If
'获取模板内容
d_DocFileContent = tGetInclude(TemplatePath)
'保存内容到磁盘
Call LS.CreateFile(SaveFilePath, d_DocFileContent)
Set objXmlHttp = Nothing
Set objAdoStream = Nothing
End Sub
'生成指定ID的文章html
Public Sub CreateDocOpenHtml(ByVal d_ID)
sql = "Select a.docId,a.docHtmlUrl,a.docTempletID,a.docContent,a.docSiteId,b.DST_URL,b.SS_SiteID from tb_xxgk_contents as a inner join DocShowType as b on a.docTempletID=b.DST_ID where a.docCheckIn<>0 and a.docId='"& LS.FormatSQL(d_ID) & "'"
Set Rs = LS.CreateRs(sql, 1, 1)
If Rs.EOF Then
Rs.Close
Exit Sub
End If
docId = Rs("docId")
d_HtmlUrl = Rs("docHtmlUrl")
docTempletID = Rs("docTempletID")
d_Contents = Rs("docContent")
docSiteId = Rs("docSiteId")
DST_URL = Rs("DST_URL")
SS_SiteID = Rs("SS_SiteID")
Rs.Close
Set Rs = Nothing
'站点根路径
If G_ROOTPATH = "" Then G_ROOTPATH = Server.MapPath("../")
'访问地址
HtmlDomain = CCfg(SS_SiteID, 12) & d_HtmlUrl
'保存路径
SaveFilePath = Replace(G_ROOTPATH & d_HtmlUrl, "/", "\")
'创建文件夹
If Not LS.FSO.IsFolder(SaveFilePath) Then LS.FSO.CreateFolder(SaveFilePath)
If Not G_CREATEHTMLTYPE Then
TemplatePath = CCfg(SS_SiteID, 12) & "/tmp/" & DST_URL & "?d_ID=" & docId
Else
'模板路径
TemplatePath = G_ROOTPATH & "\" & SiteCfg(SS_SiteID, 9) & "\template\" & DST_URL
End If
'获取模板内容
d_DocFileContent = tGetInclude(TemplatePath)
'保存内容到磁盘
Call LS.CreateFile(SaveFilePath, d_DocFileContent)
Set objXmlHttp = Nothing
Set objAdoStream = Nothing
End Sub
%>
<%
'/*------------------------------------------------ Jorkin 自定义类 翻页优化代码
' ********************************************************************* 说 明
' * 来源: KinJAVA日志 (http://jorkin.reallydo.com/article.asp?id=534)
' * 最后更新:2022-07-26
' * 当前版本: Ver: 1.09
' ********************************************************************* 特色功能
' * 有方便的 Eg() 实例,不需要记住每个变量的名称,为开发者提供方便.
' * ISAPI_REWRITE 功能可以轻松实现静态(伪静态)翻页以及ajax翻页.
' ********************************************************************* 更新历史
' * 2009-03-22
' * 修正qsliuliu反馈自定义PageParam后分页错误BUG。
' * 2009-03-19
' * 重要更新、提高速度，优化。
' * 2009-02-14
' * 优化ReWrite()函数，大大提高了效率。
' * 加入新函数GetCondition()，不过需要Jorkin_Function.asp库，用来做多条件搜索。
' * 方法为：GetCondition("表单字段名", "表单比较运算符", "表单关键字")。
' * 比较运算符可选(<, =, >, <=, >=, <>, !=, !<, !>)、关键字可用?表示单字符，用*表示零个或更多字符。
' * 警告！！！前台页面慎用，会显露数据库字段名称，可参考GetCondition()自行修改。
' * 2009-02-11
' * 小修小改，更新一些说明，加强了几个判断，本类完全兼容，想用存储过程的请下载叶子分页类的sp_Util_Page.sql。
' * 2008-11-26
' * 根据数据库连接自动判断数据库类型。
' * 2008-09-09
' * 修正 Eg() 实例BUG。
' * 继续完善一直烂尾的Select Where In排序功能，还是未全部完成。(方法想命名为Kin_Db_Pager.OrderIn(字段名,排序))
' * 修正了几个马虎导致的拼写错误。 (-_-#)
' * 加入了自定义翻页样式时设定空值的判断。
' * 2008-08-28
' * 增加 Connect() 方法进行数据库连接，比 ActiveConnection 和 ConnectionString 更安全有效。
' * 修正Bug: 如果数字跳转INPUT框在一个FORM里，回车时将会进行提交表单操作。
' * 修正Bug: 数字跳转INPUT框不支持自定义ISAPI_REWRITE路径。
' * 修正Bug: 使用自定义SQL语句时分页出错。
' * 重写 Eg() 样例,使其更容易被理解。
' * 删除大量无用代码.
' * Ver: 1.03之前
' * 一行代码即可实现帮助,不需要记住所有的属性设定。
' * 请先使用 Eg() 查看生成的代码,将其全选复制放入ASP代码块内即为本分页类的操作模板。
' ********************************************************************* 鸣 谢
' * 感谢以下大大的分页类思想及代码:
' * Sunrise_Chen (http://www.ccopus.com)
' * 才子 (http://www.54caizi.org)
' * 风声 (http://www.fonshen.com)
' * 叶子 (http://www.yeeh.org)
'*/-----------------------------------------------------------------------------
Class Kin_Db_Pager
'//-------------------------------------------------------------------------
'// 定义变量 开始
'Private Conn '//连接对象
Private sDbType '//数据库类型
Private sTableName '//表名
Private sPKey '//主键
Private sFields '//输出的字段名
Private sOrderBy '//排序字符串
Private sSql '//当前的查询语句
Private sSqlString '//自定义Sql语句
Private aCondition() '//查询条件(数组)
Private sCondition '//查询条件(字符串)
Private iPage '//当前页码
Private iPageSize '//每页记录数
Private iPageCount '//总页数
Private iRecordCount '//当前查询条件下的记录数
Private sPage '//当前页 替换字符串
Private sPageCount '//总页数 替换字符串
Private sRecordCount '//当前查询条件下的记录数 替换字符串
Private sProjectName '//项目名
Private sVersion '//版本号
Private bShowError '//是否显示错误信息
Private bDistinct '//是否显示唯一记录
Private sPageInfo '//记录数、页码等信息
Private sPageParam '//page参数名称
Private iStyle '//翻页的样式
Private iPagerSize '//翻页按钮的数值
Private iCurrentPageSize '//当前页面记录数量
Private sReWrite '//用ISAP REWRITE做的路径,可用Javascript函数实现AJAX翻页
Private iTableKind '//表的类型, 是否需要强制加 [ ]
Private sFirstPage '//首页链接 样式
Private sPreviewPage '//上一页链接 样式
Private sCurrentPage '//当前页链接 样式
Private sListPage '//分页列表链接 样式
Private sNextPage '//下一页链接 样式
Private sLastPage '//末页链接 样式
Private iPagerTop '//分页列表头尾数量
Private sJumpPage '//分页跳转功能
Private sJumpPageType '//分页跳转类型(可选SELECT或INPUT)
Private sJumpPageAttr '//分页跳转其他HTML属性
Private ii, iStart, iEnd
Private sUrl, sQueryString, x, y
Private sSpaceMark '//链接之前间隔符
'//定义变量 结束
'//-------------------------------------------------------------------------
'//-------------------------------------------------------------------------
'//事件、方法: 类初始化事件 开始
Private Sub Class_Initialize()
ReDim aCondition( -1)
sPKey = "ID"
sFields = "*"
sCondition = ""
sOrderBy = ""
sSqlString = ""
' iPageSize = 2
iPage = 1
iRecordCount = Null
iPageCount = Null
bShowError = True
bDistinct = False
iPagerTop = 0
sPage = "{$Kin_Page}"
sPageCount = "{$Kin_PageCount}"
sRecordCount = "{$Kin_RecordCount}"
sPageInfo = "共有 {$Kin_RecordCount} 条记录 页次 : {$Kin_Page}/{$Kin_PageCount}"
sPageParam = "page"
iStyle = 29252888
iTableKind = 0
iPagerSize = 7
sFirstPage = "[首页]"
sPreviewPage = "[上一页]"
sCurrentPage = "[{$CurrentPage}]"
sListPage = "[{$ListPage}]"
sNextPage = "[下一页]"
sLastPage = "[末页]"
sJumpPage = ""
sJumpPageType = "SELECT"
sSpaceMark = " "
setPageParam(sPageParam)
End Sub
'//类结束事件
'//事件、方法: 类初始化事件 结束
'//-------------------------------------------------------------------------
'//-------------------------------------------------------------------------
'//函数、方法 开始
'功能:ASP里的IIF
'来源:http://jorkin.reallydo.com/article.asp?id=26
Private Function IIf(bExp1, sVal1, sVal2)
If (bExp1) Then
IIf = sVal1
Else
IIf = sVal2
End If
End Function
'功能:只取数字
'来源:http://jorkin.reallydo.com/article.asp?id=395
Private Function Bint(sValue)
On Error Resume Next
Bint = 0
Bint = Fix(CDbl(sValue))
End Function
'功能:判断是否是空值
'来源:http://jorkin.reallydo.com/article.asp?id=386
Private Function IsBlank(byref TempVar)
IsBlank = False
Select Case VarType(TempVar)
Case 0, 1 '--- Empty & Null
IsBlank = True
Case 8 '--- String
If Len(TempVar) = 0 Then
IsBlank = True
End If
Case 9 '--- Object
tmpType = TypeName(TempVar)
If (tmpType = "Nothing") Or (tmpType = "Empty") Then
IsBlank = True
End If
Case 8192, 8204, 8209 '--- Array
If UBound(TempVar) = -1 Then
IsBlank = True
End If
End Select
End Function
'//检查数据库连接是否可用
'//处理错误信息
Public Sub doError(s)
On Error Resume Next
Dim nRnd
Randomize()
nRnd = CLng(Rnd() * 29252888)
With Response
.Clear
.Expires = 0
.Write " "
.Write "
"
.Write " "
.End()
End With
End Sub
'//产生分页的SQL语句
Public Function getSql()
If Not IsBlank(sSqlString) Then
getSql = sSqlString
Exit Function
End If
Dim iStart, iEnd
Call makeCondition()
iStart = ( iPage - 1 ) * iPageSize
iEnd = iStart + iPageSize
getSql = "SELECT " & sFields & " FROM " & TableFormat(sTableName) & " " & sCondition & " " & sOrderBy
End Function
'//产生条件字符串
Private Sub makeCondition()
If Not IsBlank(sCondition) Then Exit Sub
If UBound(aCondition)>= 0 Then
sCondition = " WHERE " & Join(aCondition, " AND ")
End If
End Sub
'//计算记录数
Private Sub CaculateRecordCount()
On Error Resume Next
Dim oRs
If Not IsBlank(sSqlString) Then
sSql = "SELECT COUNT(0) FROM (" & sSqlString & ")"
Else
Call makeCondition()
sSql = "SELECT COUNT(0) FROM " & TableFormat(sTableName) & " " & IIf(IsBlank(sCondition), "", sCondition)
End If
Set oRs = Ls.CreateRs(sSql,1,1)
If Err Then
If bShowError Then doError Err.Description
End If
iRecordCount = oRs.Fields.Item(0).Value
Set oRs = Nothing
End Sub
'//计算页数
Private Sub CaculatePageCount()
If IsNull(iRecordCount) Then CaculateRecordCount()
If iRecordCount = 0 Then
iPageCount = 0
Exit Sub
End If
iPageCount = Abs( Int( 0 - (iRecordCount / iPageSize) ) )
End Sub
'//设置页码
Private Function setPage(n)
iPage = Bint(n)
If iPage < 1 Then iPage = 1
End Function
'//增加条件
Public Sub AddCondition(s)
If IsBlank(s) Then Exit Sub
ReDim Preserve aCondition(UBound(aCondition) + 1)
aCondition(UBound(aCondition)) = s
End Sub
'//判断页面连接
Private Function ReWrite(n)
n = Bint(n)
If Not IsBlank(sRewrite) Then
ReWrite = Replace(sReWrite, "*", n)
Else
ReWrite = sUrl & IIf(n>0, n, "")
End If
End Function
'//数据库表加 []
Private Function TableFormat(s)
Select Case iTableKind
Case 0
TableFormat = "[" & s & "]"
Case 1
TableFormat = " " & s & " "
End Select
End Function
'//按Where In顺序进行排序
Public Function OrderIn(s, sOrderIn)
OrderIn = " "
If Not IsBlank(s) And Not IsBlank(sOrderIn) Then
sOrderIn = Replace(sOrderIn, " ", "")
sOrderIn = Replace(sOrderIn, "'", "")
sOrderIn = "'" & sOrderIn & "'"
Select Case sDbType
Case "MYSQL"
OrderIn = "FIND_IN_SET(" & s & ", " & sOrderIn & ")"
Case "ACCESS"
OrderIn = "INSTR(','+CStr(" & sOrderIn & ")+',',','+CStr(" & s & ")+',')"
Case Else
OrderIn = "PATINDEX('% ' + CONVERT(nvarchar(820222), " & s & ") + ' %',' ' + CONVERT(nvarchar(820222), Replace(" & sOrderIn & ", ',', ' , ')) + ' ')"
End Select
End If
OrderIn = OrderIn & " "
End Function
'//设定分页变量的名称
Private Function setPageParam(s)
sQueryString = ""
For Each x In Request.QueryString
If x <> sPageParam Then
For Each y In Request.QueryString(x)
sQueryString = "&" & x & "=" & Server.URLEncode(y) & sQueryString
Next
End If
Next
sUrl = Request.ServerVariables("URL") & "?" & IIf(IsBlank(sQueryString), "", Mid(sQueryString, 2) & "&") & sPageParam & "="
End Function
'//定义 首页 样式
Public Property Let FirstPage(s)
sFirstPage = s
End Property
'//定义 上一页 样式
Public Property Let PreviewPage(s)
sPreviewPage = s
End Property
'//定义 当前页 样式
Public Property Let CurrentPage(s)
sCurrentPage = s
End Property
'//定义 分页列表页 样式
Public Property Let ListPage(s)
sListPage = s
End Property
'//定义 下一页 样式
Public Property Let NextPage(s)
sNextPage = s
End Property
'//定义 末页 样式
Public Property Let LastPage(s)
sLastPage = s
End Property
'//定义间隔符，默认半角空格
Public Property Let SpaceMark(s)
sSpaceMark = s
End Property
'//定义 列表前后多加几页
Public Property Let PagerTop(n)
iPagerTop = Bint(n)
End Property
'//定义查询表名
Public Property Let TableName(s)
sTableName = s
'//如果发现表名包含 ([. ，那么就不要用 []
If InStr(s, "(")>0 Then iTableKind = 1
If InStr(s, "[")>0 Then iTableKind = 1
If InStr(s, ".")>0 Then iTableKind = 1
End Property
'//定义需要输出的字段名
Public Property Let Fields(s)
sFields = s
End Property
'//定义主键
Public Property Let PKey(s)
If Not IsBlank(s) Then sPKey = s
End Property
'//定义排序规则
Public Property Let OrderBy(s)
If Not IsBlank(s) Then sOrderBy = " ORDER BY " & s & " "
End Property
'//定义每页的记录条数
Public Property Let PageSize(s)
iPageSize = Bint(s)
iPageSize = IIf(iPageSize<1, 1, iPageSize)
End Property
'//定义当前页码
Public Property Let Page(n)
setPage Bint(n)
End Property
'//定义当前页码(同Property Page)
Public Property Let AbsolutePage(n)
setPage Bint(n)
End Property
'//自定义查询语句
Public Property Let Sql(s)
sSqlString = s
End Property
'//是否DISTINCT
Public Property Let Distinct(b)
bDistinct = b
End Property
'//设定分页变量的名称
Public Property Let PageParam(s)
sPageParam = LCase(s)
If IsBlank(sPageParam) Then sPageParam = "page"
setPageParam(sPageParam)
End Property
'//选择分页的样式,可以后面自己添加新的
Public Property Let Style(s)
iStyle = Bint(s)
End Property
'//分页列表显示数量
Public Property Let PagerSize(n)
iPagerSize = 2
End Property
'//自定义ISAPI_REWRITE路径 * 将被替换为当前页数
'//使用Javascript时请注意本分页类用双引号引用字符串,请先处理.
Public Property Let ReWritePath(s)
sReWrite = s
End Property
'//强制TABLE类型
Public Property Let TableKind(n)
iTableKind = n
End Property
'//自定义分页信息
Public Property Let PageInfo(s)
sPageInfo = s
End Property
'//定义页面跳转类型
Public Property Let JumpPageType(s)
sJumpPageType = UCase(s)
Select Case sJumpPageType
Case "INPUT", "SELECT"
Case Else
sJumpPageType = "SELECT"
End Select
End Property
'//定义页面跳转链接其他HTML属性
Public Property Let JumpPageAttr(s)
sJumpPageAttr = s
End Property
'//输入属性 结束
'//-------------------------------------------------------------------------
'//-------------------------------------------------------------------------
'//输出属性 开始
'//输出连接语句
'//输出查询表名
Public Property Get TableName()
TableName = sTableName
End Property
'//输出需要输出的字段名
Public Property Get Fields()
Fields = sFields
End Property
'//输出主键
Public Property Get PKey()
PKey = sPKey
End Property
'//输出排序规则
Public Property Get OrderBy()
OrderBy = sOrderBy
End Property
'//取得当前条件下的记录数
Public Property Get RecordCount()
If IsNull(iRecordCount) Then CaculateRecordCount()
RecordCount = iRecordCount
End Property
'//取得每页记录数
Public Property Get PageSize()
PageSize = iPageSize
End Property
'//取得当前查询的条件
Public Property Get Condition()
If IsBlank(sCondition) Then makeCondition()
Condition = sCondition
End Property
'//取得当前页码
Public Property Get Page()
Page = iPage
End Property
'//取得当前页码
Public Property Get AbsolutePage()
AbsolutePage = iPage
End Property
'//取得总页数
Public Property Get PageCount()
If IsNull(iPageCount) Then CaculatePageCount()
PageCount = iPageCount
End Property
'//取得当前页记录数
Public Property Get CurrentPageSize()
If IsNull(iRecordCount) Then CaculateRecordCount()
If IsNull(iPageCount) Then CaculatePageCount()
CurrentPageSize = IIf(iPage = iPageCount, iRecordCount - (iPage -1) * iPageSize, iPageSize)
End Property
'//得到分页后的记录集
Public Property Get RecordSet()
On Error Resume Next
sSql = getSql()
Set RecordSet = Ls.CreateRs(sSql,1,1)
RecordSet.PageSize = iPageSize
If RecordSet.AbsolutePage <> -1 Then
iPage = IIf(iPage>RecordSet.PageCount, RecordSet.PageCount, iPage)
RecordSet.AbsolutePage = iPage
End If
If Err Then
If bShowError Then doError Err.Description
If Not IsBlank(sSql) Then
Set RecordSet = Ls.CreateRs(sSql,1,1)
If Err Then
If bShowError Then doError Err.Description
End If
Else
If bShowError Then doError Err.Description
End If
End If
Err.Clear()
End Property
'//版本信息
Public Property Get Version()
Version = sVersion
End Property
'//输出页码及记录数等信息
Public Property Get PageInfo()
CaculatePageCount()
PageInfo = Replace(sPageInfo, sRecordCount, iRecordCount)
PageInfo = Replace(PageInfo, sPageCount, iPageCount)
PageInfo = Replace(PageInfo, sPage, iPage)
End Property
'//输出分页样式
Public Property Get Style()
Style = iStyle
End Property
'//输出分页变量
Public Property Get PageParam()
PageParam = sPageParam
End Property
'//输出翻页按钮
Public Property Get Pager()
Pager = ""
ii = (iPagerSize \ 2)
iEnd = iPage + ii
iStart = iPage - (ii + (iPagerSize Mod 2)) + 1
If iEnd > iPageCount Then
iEnd = iPageCount
iStart = iPageCount - iPagerSize + 1
End If
If iStart < 1 Then
iStart = 1
iEnd = iStart + iPagerSize -1
End If
If iEnd > iPageCount Then
iEnd = iPageCount
End If
'Select Case iStyle
' Case 0
' If iPageCount>0 Then
' If iPage>1 Then
' 'Pager = Pager & IIf(IsBlank(sFirstPage), "", "" & sFirstPage & "" & sSpaceMark)
' Pager = Pager & IIf(IsBlank(sPreviewPage), "", "" & sPreviewPage & "" & sSpaceMark)
' Else
' ' Pager = Pager & IIf(IsBlank(sFirstPage), "", "" & sFirstPage & "" & sSpaceMark)
' Pager = Pager & IIf(IsBlank(sPreviewPage), "", "" & sPreviewPage & "" & sSpaceMark)
' End If
' If iPagerTop > 0 Then
' If iPagerTop < iStart Then
' ii = iPagerTop
' Else
' ii = iStart - 1
' End If
' For i = 1 To ii
' Pager = Pager & "" & Replace(sListPage, "{$Listpage}", i, 1, -1, 1) & "" & sSpaceMark
' Next
' If iPagerTop < iStart -1 Then Pager = Pager & "..." & sSpaceMark
' End If
' If iPagerSize >0 Then
' For i = iStart To iEnd
' If i = iPage Then
' Pager = Pager & "" & Replace(sCurrentPage, "{$Currentpage}", i, 1, -1, 1) & "" & sSpaceMark
' Else
' Pager = Pager & "" & Replace(sListPage, "{$Listpage}", i, 1, -1, 1) & "" & sSpaceMark
' End If
' Next
' End If
' If iPagerTop > 0 Then
' If iPageCount - iPagerTop > iEnd Then Pager = Pager & "..." & sSpaceMark
' If iPageCount - iPagerTop > iEnd Then
' ii = iPageCount - iPagerTop + 1
' Else
' ii = iEnd + 1
' End If
' For i = ii To iPageCount
' Pager = Pager & "" & Replace(sListPage, "{$Listpage}", i, 1, -1, 1) & "" & sSpaceMark
' Next
' End If
' If iPageCount>iPage Then
' Pager = Pager & IIf(IsBlank(sNextPage), "", "" & sNextPage & "" & sSpaceMark)
' ' Pager = Pager & IIf(IsBlank(sLastPage), "", "" & sLastPage & "" & sSpaceMark)
' Else
' Pager = Pager & IIf(IsBlank(sNextPage), "", "" & sNextPage & "" & sSpaceMark)
' 'Pager = Pager & IIf(IsBlank(sLastPage), "", "" & sLastPage & "")
' End If
' End If
' Case 1
' If iPageCount>0 Then
' If iPage>1 Then
' Pager = Pager & "" & sFirstPage & "" & sSpaceMark
' Pager = Pager & "" & sPreviewPage & "" & sSpaceMark
' Else
' Pager = Pager & sFirstPage & sSpaceMark
' Pager = Pager & sPreviewPage & sSpaceMark
' End If
' If iPagerTop > 0 Then
' If iPagerTop < iStart Then
' ii = iPagerTop
' Else
' ii = iStart - 1
' End If
' For i = 1 To ii
' Pager = Pager & "" & Replace(sListPage, "{$Listpage}", i, 1, -1, 1) & "" & sSpaceMark
' Next
' If iPagerTop < iStart -1 Then Pager = Pager & "..." & sSpaceMark
' End If
' If iPagerSize >0 Then
' For i = iStart To iEnd
' If i = iPage Then
' Pager = Pager & Replace(sCurrentPage, "{$Currentpage}", i, 1, -1, 1) & sSpaceMark
' Else
' Pager = Pager & "" & Replace(sListPage, "{$Listpage}", i, 1, -1, 1) & "" & sSpaceMark
' End If
' Next
' End If
' If iPagerTop > 0 Then
' If iPageCount - iPagerTop > iEnd Then Pager = Pager & "..." & sSpaceMark
' If iPageCount - iPagerTop > iEnd Then
' ii = iPageCount - iPagerTop + 1
' Else
' ii = iEnd + 1
' End If
' For i = ii To iPageCount
' Pager = Pager & "" & Replace(sListPage, "{$Listpage}", i, 1, -1, 1) & "" & sSpaceMark
' Next
' End If
' If iPageCount>iPage Then
' Pager = Pager & "" & sNextPage & "" & sSpaceMark
' Pager = Pager & "" & sLastPage & "" & sSpaceMark
' Else
' Pager = Pager & sNextPage & sSpaceMark
' Pager = Pager & sLastPage
' End If
' End If
' Case Else
' If iPageCount>0 Then
' If iPage>1 Then
' Pager = Pager & "[首页]" & sSpaceMark
' Pager = Pager & "[上一页]" & sSpaceMark
' Else
' Pager = Pager & "[首页]" & sSpaceMark
' Pager = Pager & "[上一页]" & sSpaceMark
' End If
' If iPagerTop > 0 Then
' If iPagerTop < iStart Then
' ii = iPagerTop
' Else
' ii = iStart - 1
' End If
' For i = 1 To ii
' Pager = Pager & "" & Replace("[{$Listpage}]", "{$Listpage}", i, 1, -1, 1) & "" & sSpaceMark
' Next
' If iPagerTop < iStart -1 Then Pager = Pager & "..." & sSpaceMark
' End If
' If iPagerSize >0 Then
' For i = iStart To iEnd
' If i = iPage Then
' Pager = Pager & "" & Replace("[{$Currentpage}]", "{$Currentpage}", i, 1, -1, 1) & "" & sSpaceMark
' Else
' Pager = Pager & "" & Replace("[{$Listpage}]", "{$Listpage}", i, 1, -1, 1) & "" & sSpaceMark
' End If
' Next
' End If
' If iPagerTop > 0 Then
' If iPageCount - iPagerTop > iEnd Then Pager = Pager & "..." & sSpaceMark
' If iPageCount - iPagerTop > iEnd Then
' ii = iPageCount - iPagerTop + 1
' Else
' ii = iEnd + 1
' End If
' For i = ii To iPageCount
' Pager = Pager & "" & Replace("[{$Listpage}]", "{$Listpage}", i, 1, -1, 1) & "" & sSpaceMark
' Next
' End If
' If iPageCount>iPage Then
' Pager = Pager & "[下一页]" & sSpaceMark
' Pager = Pager & "[尾页]" & sSpaceMark
' Else
' Pager = Pager & "[下一页]" & sSpaceMark
' Pager = Pager & "[尾页]"
' End If
' End If
' End Select
' End Property
Select Case iStyle
Case 0
If iPageCount>0 Then
If iPage>1 Then
Pager = Pager & IIf(IsBlank(sFirstPage), "", "" & sFirstPage & "" & sSpaceMark)
Pager = Pager & IIf(IsBlank(sPreviewPage), "", "" & sPreviewPage & "" & sSpaceMark)
Else
Pager = Pager & IIf(IsBlank(sFirstPage), "", "" & sFirstPage & "" & sSpaceMark)
Pager = Pager & IIf(IsBlank(sPreviewPage), "", "" & sPreviewPage & "" & sSpaceMark)
End If
If iPagerTop > 0 Then
If iPagerTop < iStart Then
ii = iPagerTop
Else
ii = iStart - 1
End If
For i = 1 To ii
Pager = Pager & "" & Replace(sListPage, "{$Listpage}", i, 1, -1, 1) & "" & sSpaceMark
Next
If iPagerTop < iStart -1 Then Pager = Pager & "..." & sSpaceMark
End If
If iPagerSize >0 Then
For i = iStart To iEnd
If i = iPage Then
Pager = Pager & "" & Replace(sCurrentPage, "{$Currentpage}", i, 1, -1, 1) & "" & sSpaceMark
Else
Pager = Pager & "" & Replace(sListPage, "{$Listpage}", i, 1, -1, 1) & "" & sSpaceMark
End If
Next
End If
If iPagerTop > 0 Then
If iPageCount - iPagerTop > iEnd Then Pager = Pager & "..." & sSpaceMark
If iPageCount - iPagerTop > iEnd Then
ii = iPageCount - iPagerTop + 1
Else
ii = iEnd + 1
End If
For i = ii To iPageCount
Pager = Pager & "" & Replace(sListPage, "{$Listpage}", i, 1, -1, 1) & "" & sSpaceMark
Next
End If
If iPageCount>iPage Then
Pager = Pager & IIf(IsBlank(sNextPage), "", "" & sNextPage & "" & sSpaceMark)
Pager = Pager & IIf(IsBlank(sLastPage), "", "" & sLastPage & "" & sSpaceMark)
Else
Pager = Pager & IIf(IsBlank(sNextPage), "", "" & sNextPage & "" & sSpaceMark)
Pager = Pager & IIf(IsBlank(sLastPage), "", "" & sLastPage & "")
End If
End If
Case 1
If iPageCount>0 Then
If iPage>1 Then
Pager = Pager & "" & sFirstPage & "" & sSpaceMark
Pager = Pager & "" & sPreviewPage & "" & sSpaceMark
Else
Pager = Pager & sFirstPage & sSpaceMark
Pager = Pager & sPreviewPage & sSpaceMark
End If
If iPagerTop > 0 Then
If iPagerTop < iStart Then
ii = iPagerTop
Else
ii = iStart - 1
End If
For i = 1 To ii
Pager = Pager & "" & Replace(sListPage, "{$Listpage}", i, 1, -1, 1) & "" & sSpaceMark
Next
If iPagerTop < iStart -1 Then Pager = Pager & "..." & sSpaceMark
End If
If iPagerSize >0 Then
For i = iStart To iEnd
If i = iPage Then
Pager = Pager & Replace(sCurrentPage, "{$Currentpage}", i, 1, -1, 1) & sSpaceMark
Else
Pager = Pager & "" & Replace(sListPage, "{$Listpage}", i, 1, -1, 1) & "" & sSpaceMark
End If
Next
End If
If iPagerTop > 0 Then
If iPageCount - iPagerTop > iEnd Then Pager = Pager & "..." & sSpaceMark
If iPageCount - iPagerTop > iEnd Then
ii = iPageCount - iPagerTop + 1
Else
ii = iEnd + 1
End If
For i = ii To iPageCount
Pager = Pager & "" & Replace(sListPage, "{$Listpage}", i, 1, -1, 1) & "" & sSpaceMark
Next
End If
If iPageCount>iPage Then
Pager = Pager & "" & sNextPage & "" & sSpaceMark
Pager = Pager & "" & sLastPage & "" & sSpaceMark
Else
Pager = Pager & sNextPage & sSpaceMark
Pager = Pager & sLastPage
End If
End If
Case Else
If iPageCount>0 Then
If iPage>1 Then
Pager = Pager & "[首页]" & sSpaceMark
Pager = Pager & "[上一页]" & sSpaceMark
Else
Pager = Pager & "[首页]" & sSpaceMark
Pager = Pager & "[上一页]" & sSpaceMark
End If
If iPagerTop > 0 Then
If iPagerTop < iStart Then
ii = iPagerTop
Else
ii = iStart - 1
End If
For i = 1 To ii
Pager = Pager & "" & Replace("[{$Listpage}]", "{$Listpage}", i, 1, -1, 1) & "" & sSpaceMark
Next
If iPagerTop < iStart -1 Then Pager = Pager & "..." & sSpaceMark
End If
If iPagerSize >0 Then
For i = iStart To iEnd
If i = iPage Then
Pager = Pager & "" & Replace("[{$Currentpage}]", "{$Currentpage}", i, 1, -1, 1) & "" & sSpaceMark
Else
Pager = Pager & "" & Replace("[{$Listpage}]", "{$Listpage}", i, 1, -1, 1) & "" & sSpaceMark
End If
Next
End If
If iPagerTop > 0 Then
If iPageCount - iPagerTop > iEnd Then Pager = Pager & "..." & sSpaceMark
If iPageCount - iPagerTop > iEnd Then
ii = iPageCount - iPagerTop + 1
Else
ii = iEnd + 1
End If
For i = ii To iPageCount
Pager = Pager & "" & Replace("[{$Listpage}]", "{$Listpage}", i, 1, -1, 1) & "" & sSpaceMark
Next
End If
If iPageCount>iPage Then
Pager = Pager & "[下一页]" & sSpaceMark
Pager = Pager & "[尾页]" & sSpaceMark
Else
Pager = Pager & "[下一页]" & sSpaceMark
Pager = Pager & "[尾页]"
End If
End If
End Select
End Property
'//生成页面跳转
Public Property Get JumpPage()
Dim x, sQueryString, aQueryString
sJumpPage = vbCrLf
Select Case sJumpPageType
Case "INPUT"
sJumpPage = "跳转"
Case "SELECT"
sJumpPage = sJumpPage & ""
Case Else
sJumpPage = ""
End Select
JumpPage = sJumpPage
End Property
'//输出属性 结束
'//-------------------------------------------------------------------------
End Class
%>
<%ThisSiteID = 1%>
<%
Dim NowSSIS,NowSSID,NowPSID,NowPSIS,NowPSSubItem,NowSSSiteID,NowSIDomain,NowModelTable,NowModelID,NowSSURL,NowIMG
Dim SubID(),SubName(),SubNameq(),SubType(),SubURL(),SubPath(),SubItem0(),SubNum
Dim td_ID,td_Title,td_PageTitle,td_SubTitle,td_KeyWords,td_Date,td_Time,td_Contents,td_Resource,td_Author,td_Hit,DocNowPlace,RelativeLink,CommentList,wbstr,ttd_Title
Dim doctype,catalogTitle,td_unitsName,td_catalogTitle,td_docnum,Tclassdx,td_SSID
Dim lid,Ljob,Lname,Lphoto,LJobContents,LJobFengong,LeaderClass,KSS_ID,Lhtmlurl,ltel
Dim tm_ID,tm_numbers,tm_ly,tm_type,tm_Subject,tm_Date,tm_Contents,tm_OpenIs,tm_Name,tm_Tel,tm_RevertIS,tIsUnit,tIsLeader,tLW_Name,tReceiveUnits,tm_RevertDate,tm_Revert,tm_xz,tm_lb,tm_zy,tm_address,tm_HtmlUrl,tm_Appraise,td_docUnitsID,td_replace
Dim tivs_Contents,tivs_title,tivs_ftrq,tivs_ftjb
Dim rscount,linkpar,mypagesize,mypage,maxcount,scriptname,counter,i,j
Dim IsPicJS
NowSSIS = False
NowPSSubItem = True
NowSSID = GetSafeStr(Request.QueryString("SS_ID"))
Dim SQL_injdata
SQL_injdata = "CR|LF|document|eval|alert|script|prompt|onmouseover|iframe|confirm|or|and|exec|cast|insert|select|delete|update|count|@|$|;|&|+|*|%|chr|mid|master|truncate|char|declare|drop|from|MsgBox|onmouseover|windows.location|onmouseout|onclick|onkeydown|"""
SQL_inj = Split(SQL_injdata, "|")
If Request.QueryString <> "" Then
For Each SQL_Get In Request.QueryString
For SQL_Data = 0 To UBound(SQL_inj)
If InStr(LCase(Request.QueryString(SQL_Get)), LCase(SQL_inj(SQL_Data))) > 0 Or Len(Request.QueryString(SQL_Get))>40 Then
Response.Write ""
Response.End
End If
Next
Next
End If
Dim Reg1, Reg2, Reg3
Reg1 = "'|(and|or)\b.+?(>|<|=|in|like)|/\*.+?\*/|<\s*script\b|\bEXEC\b|UNION.+?SELECT|UPDATE.+?SET|"
Reg1 = Reg1 & "INSERT\s+INTO.+?VALUES|(SELECT|DELETE).+?FROM|(CREATE|"
Reg1 = Reg1 & "ALTER|DROP|TRUNCATE)\s+(TABLE|DATABASE)"
Reg2 = "\b(and|or)\b.{1,6}?(=|>|<|\bin\b|\blike\b)|/\*.+?\*/|<\s*script\b|"
Reg2 = Reg2 & "\bEXEC\b|UNION.+?SELECT|UPDATE.+?SET|INSERT\s+INTO.+?VALUES|(SELECT|DELETE)"
Reg2 = Reg2 & ".+?FROM|(CREATE|ALTER|DROP|TRUNCATE)\s+(TABLE|DATABASE)"
Reg3 = "\b(and|or)\b.{1,6}?(=|>|<|\bin\b|\blike\b)|/\*.+?\*/|"
Reg3 = Reg3 & "<\s*script\b|\bEXEC\b|UNION.+?SELECT|UPDATE.+?SET|INSERT\s+INTO.+?VALUES|("
Reg3 = Reg3 & "SELECT|DELETE).+?FROM|(CREATE|ALTER|DROP|TRUNCATE)\s+(TABLE|DATABASE)"
If Request.QueryString<>"" Then Call StopHacker(Request.QueryString, Reg1)
If Request.Form<>"" Then Call StopHacker(Request.Form, Reg2)
If Request.Cookies<>"" Then Call StopHacker(Request.Cookies, Reg3)
Public Function StopHacker(ByVal values, ByVal re)
Dim l_get, l_get2, n_get, regex, IP
For Each n_get in values
For Each l_get in values
l_get2 = values(l_get)
Set regex = New regexp
regex.IgnoreCase = True
regex.Global = True
regex.Pattern = re
If regex.Test(l_get2) Then
IP = Request.ServerVariables("HTTP_X_FORWARDED_FOR")
If IP = "" Then
IP = Request.ServerVariables("REMOTE_ADDR")
End If
Response.Write ""
Response.End
End If
Set regex = Nothing
Next
Next
End Function
' ======================================================================================================================
' 导航初始化
' ======================================================================================================================
If NowSSID <> "" Then
if IsNumeric(NowSSID) = false then
response.End()
else
If LS.IsN(CCfg(NowSSID,0)) Then
NowSSIS = False
Else
NowSSPath = CCfg(NowSSID,1)
NowSSType = CCfg(NowSSID,5)
NowSSName = CCfg(NowSSID,6)
NowSSSubItem = LS.toBool(CCfg(NowSSID,7))
NowSSURL = CCfg(NowSSID,8)
NowSSHtmlUrl = CCfg(NowSSID,10)
NowSSPathNum = UBound(Split(NowSSPath,"-"))
NowPSSID = CCfg(NowSSID,2)
NowIMG = CCfg(NowSSID,27)
NowSSIS = True
End If
end if
Else
NowSSID = 0
End If
'办事
Dim NowBSIS,NowBSID,NowBSName,NowBSPath,NowBSSubItem,NowPBSID,NowPBSName,NowPBSPath,NowPClassId,BSNowCurrentNav,BSActiveID,NowIsParent,NowParentID
NowBSID = Ls.toClng(Request.QueryString("BS_ID"))
NowBSClassId = Ls.toClng(Request.QueryString("BS_ClassId"))
If NowBSID<>0 Then
'菜单选种的ID
NowIsParent = False
NowParentID = NowBSID
strSelect = "SELECT *,(SELECT count(bb.BS_ID) countChild FROM BsSort as bb WHERE bb.PBS_ID=aa.BS_ID) as countChild FROM BsSort as aa WHERE aa.BS_ID=" & NowBSID
Set Rs = Ls.CreateRs(strSelect, 1, 1)
If Not Rs.Eof Then
NowPBSID = Rs("PBS_ID")
NowBSName = Rs("BS_Name")
NowBSPath = Rs("BS_Path")
NowBSClassId = Rs("BS_classId")
NowBSSubItem = Rs("BS_SubItem")
countChild = Rs("countChild")
BSNowCurrentNav = " > " & NowBSName
Else
NowBSSubItem = False
NowBSIS = False
NowPBSID = 0
End If
Rs.Close
NowPBSIS = False
If NowPBSID>0 Then
'有父级用父及菜单的ID
strSelect = "SELECT * FROM BsSort WHERE BS_ID=" & NowPBSID
Set Rs = Ls.CreateRs(strSelect, 1, 1)
If Not Rs.Eof Then
NowParentID = NowPBSID
NowPBSName = Rs("BS_Name")
NowPBSPath = Rs("BS_Path")
NowPClassId = Rs("BS_classId")
NowPBSIS = True
BSNowCurrentNav = " > " & NowPBSName & BSNowCurrentNav
Else
NowPBSIS = False
End If
Rs.Close
Else
End If
Set Rs = Nothing
If countChild>0 Or NowPBSID>0 Then
NowIsParent = True
End If
Else
NowBSIS = False
End If
If NowBSClassId<>0 Then
strSelect = "SELECT * FROM BSClass WHERE classid=" & NowBSClassId
Set Rs = Ls.CreateRs(strSelect, 1, 1)
If Not Rs.Eof Then
BSClassName = Rs("classname")
BSNowCurrentNav = " > " & BSClassName
End If
Rs.Close
Set Rs = Nothing
End If
'在线办事“分类”当前位置
Public Function GetBSClassNav(ByVal parentID)
strSelect = "SELECT classid,classname FROM BSClass WHERE SS_SiteID="& ThisSiteID &" AND classid=" & NowBSClassId
Set Rs2 = Ls.CreateRs(strSelect, 1, 1)
If Not Rs2.Eof Then
classname = Rs2("classname")
classname = classname & GetBsSortNav(parentID,"")
Else
classname = GetBsSortNav(parentID,"")
End If
Rs2.Close
Set Rs2 = Nothing
GetBSClassNav = classname
End Function
'在线办事当前位置
Public Function GetBsSortNav(ByVal parentID,ByVal navStr)
strSelect = "SELECT PBS_ID,BS_Name FROM BsSort WHERE SS_SiteID="& ThisSiteID &" AND BS_ID=" & parentID
Set Rs = Ls.CreateRs(strSelect, 1, 1)
If Not Rs.Eof Then
PBS_ID = Rs("PBS_ID")
BS_Name = Rs("BS_Name")
navStr = " > " & BS_Name & navStr
Rs.Close
navStr = GetBsSortNav(PBS_ID,navStr)
Else
Rs.Close
End If
Set Rs = Nothing
GetBsSortNav = navStr
End Function
Public Function GetBsSortPath(ByVal classID, ByVal splitFlag)
Dim strWhere
strWhere = ""
If splitFlag="" Then splitFlag = " OR "
strSelect = "SELECT BS_Path FROM BsSort as aa WHERE aa.PBS_ID=0 AND aa.BS_classId=" & classID
Set Rs2 = Ls.CreateRs(strSelect, 1, 1)
Do While Not Rs2.Eof
BS_Path = Rs2("BS_Path")
If strWhere<>"" Then strWhere = strWhere & splitFlag
strWhere = strWhere & " BS_classid"& classID & " LIKE '"& BS_Path &"%'"
Rs2.MoveNext
Loop
Rs2.Close
Set Rs2 = Nothing
GetBsSortPath = strWhere
End Function
' ======================================================================================================================
' 当前栏目上一级名称
' ======================================================================================================================
Public Function NowPSSName()
Dim tStr:tStr = ""
If NowPSSID > 0 and NowSSSubItem = False Then
tStr = CCfg(NowPSSID,6)
Else
tStr = NowSSName
End If
If G_FLAGHTMLTYPE = 1 Then
response.Write(tStr)
Else
NowPSSName = tStr
End If
End Function
' ======================================================================================================================
' 水平主导航
' ======================================================================================================================
Sub HorzMainNav(NowCor,IndexURL)
If IndexURL = "" Then Exit Sub
Str = ""
sql = "select * from SiteStructure where SS_CheckIn=1 and SS_Type<101 and PSS_ID="&NowSSSiteID&" order by SS_Path"
Set Rs = LS.CreateRs(sql,1,1)
rscount = Rs.recordcount
If rscount = 0 Then
Rs.close
Exit Sub
End If
If Not NowSSIS Then
tStr = "首页 "
Else
tStr = "首页 "
End If
For i = 1 to rscount
SS_ID = Rs("SS_ID")
SS_Name = Rs("SS_Name")
SS_URL = Rs("SS_URL")
tSS_Path = Rs("SS_Path")
SS_Type = Rs("SS_Type")
SS_LinkURL = Rs("SS_LinkURL")
SS_HtmlUrl = Rs("SS_HtmlUrl")
If SS_LinkURL <> "" Then
SS_URL = SS_LinkURL
Else
If SS_Type < 100 and SS_Type <>8 and SS_Type <> 10 Then
SS_URL = SS_HtmlUrl '静态 .html
Else
SS_URL = SS_URL & "?SS_ID=" &SS_ID '动态 .shtml
End If
End If
If CStr(SS_ID) = NowSSID or Instr(NowSSPath,tSS_Path) > 0 Then
tStr = tStr & " | "&SS_Name&""
Else
tStr = tStr & " | "&SS_Name&""
End If
Rs.MoveNext
Next
Rs.close
Set Rs = Nothing
If G_FLAGHTMLTYPE = 1 Then
Response.Write(tStr)
Else
NowPSSName = tStr
End If
End Sub
' ======================================================================================================================
' 垂直主导航
' ======================================================================================================================
Sub VertMainNav(NowCor,IndexURL)
If IndexURL = "" Then Exit Sub
sql = "select * from SiteStructure where SS_CheckIn=1 and SS_Type<101 and PSS_ID="&NowSSSiteID&" order by SS_Path"
Set Rs = LS.CreateRs(sql,1,1)
rscount = Rs.recordcount
If rscount = 0 Then
Rs.close
Exit Sub
End If
Response.write "
"
End If
For i = 1 to rscount
SS_ID = Rs("SS_ID")
SS_Name = Rs("SS_Name")
SS_URL = Rs("SS_URL")
tSS_Path = Rs("SS_Path")
SS_Type = Rs("SS_Type")
SS_LinkURL = Rs("SS_LinkURL")
SS_HtmlUrl = Rs("SS_HtmlUrl")
If SS_LinkURL <> "" Then
SS_URL = SS_LinkURL
Else
If SS_Type < 100 and SS_Type <>8 and SS_Type <> 10 Then
SS_URL = SS_HtmlUrl '静态 .html
Else
SS_URL = SS_URL & "?SS_ID=" &SS_ID '动态 .shtml
End If
End If
If CStr(SS_ID) = NowSSID or Instr(NowSSPath,tSS_Path) > 0 Then
Response.write "
"
End If
Rs.movenext
Next
Rs.close
Response.write "
"
End Sub
' ======================================================================================================================
' 水平子导航
' ======================================================================================================================
Public Sub HorzSubNav(NowCor,NavVis)
If NowSSIS = False Then Exit Sub
If NowSSType < 101 Then
If NowSSSubItem Then
sql = "select * from SiteStructure where SS_CheckIn=1 and SS_Type<101 and PSS_ID="&NowSSID&" order by SS_Path"
Else
If NowPSSID = 0 Then Exit Sub
sql = "select * from SiteStructure where SS_CheckIn=1 and SS_Type<101 and PSS_ID="&NowPSSID&" order by SS_Path"
End If
Set Rs = LS.CreateRs(sql,1,1)
rscount = Rs.recordcount
SubNum = rscount
Redim Preserve SubID(rscount),SubName(rscount),SubType(rscount),SubURL(rscount),SubItem0(rscount),SubPath(rscount)
str = ""
For i = 1 to rscount
SubID(i) = Rs("SS_ID")
SubName(i) = Rs("SS_Name")
SubType(i) = Rs("SS_Type")
SubURL(i) = Rs("SS_URL")
SubItem0(i) = Rs("SS_SubItem")
SubPath(i) = Rs("SS_Path")
SS_LinkURL = Rs("SS_LinkURL")
SS_HtmlUrl = Rs("SS_HtmlUrl")
If SubType(i) < 4 and WebStyle = 2 Then
SubURL(i) = SS_HtmlUrl '静态 .html
Else
SubURL(i) = SubURL(i) & "?SS_ID=" &SubID(i) '动态 .shtml
End If
If SS_LinkURL <> "" Then
SubURL(i) = SS_LinkURL
str = str & ""&SubName(i)&""
Else
If SS_SubItem = False and CStr(SubID(i)) = NowSSID Then
str = str & ""&SubName(i)&""
Else
str = str & ""&SubName(i)&""
End If
End If
If i < rscount Then str = str & " | "
Rs.movenext
Next
Rs.close
If NavVis = 1 Then Response.write str
End If
End Sub
' ======================================================================================================================
' 垂直子导航
' 新增左边距Padd_left参数
' ======================================================================================================================
Public Function VertSubNav(NumsTr,NumWords)
If NowSSIS = False Then Exit Function
If NowSSType < 105 Then
If NowSSSubItem Then
sql = "select * from SiteStructure where SS_CheckIn<>0 and (SS_Type<101 or SS_Type=104 ) and SS_Type<>15 and PSS_ID="&NowSSID&" order by SS_Path"
Else
If NowPSSID = 0 Then Exit Function
sql = "select * from SiteStructure where SS_CheckIn<>0 and (SS_Type<101 or SS_Type=104) and SS_Type<>15 and PSS_ID="&NowPSSID&" order by SS_Path"
End If
Set rs = LS.CreateRs(sql,1,1)
rscount = rs.recordcount
SubNum = rscount
If NumsTr <>0 and rscount>NumsTr then
rscount = NumsTr
End if
If rscount = 0 Then
Redim Preserve SubID(rscount),SubName(rscount),SubNameq(rscount),SubType(rscount),SubURL(rscount),SubItem0(rscount),SubPath(rscount)
rs.close
Exit Function
End If
Redim Preserve SubID(rscount),SubName(rscount),SubNameq(rscount),SubType(rscount),SubURL(rscount),SubItem0(rscount),SubPath(rscount)
str = "
"
For i = 1 to rscount
SubID(i) = rs("SS_ID")
SubName(i) = rs("SS_Name")
SubNameq(i) = rs("SS_Name")
SubType(i) = rs("SS_Type")
SubURL(i) = rs("SS_URL")
SubItem0(i) = rs("SS_SubItem")
SubPath(i) = rs("SS_Path")
SS_LinkURL = rs("SS_LinkURL")
SS_HtmlUrl = rs("SS_HtmlUrl")
If SubType(i) < 100 and SubType(i)<>8 and SubType(i)<>10 and WebStyle = 2 Then
SubURL(i) = SS_HtmlUrl '静态 .html
Else
SubURL(i) = "/tmp/"&SubURL(i) & "?SS_ID=" &SubID(i) '动态 .shtml
End If
if NumWords<>0 then
SubName(i) = cutstr(SubName(i),NumWords)
end if
If SS_LinkURL <> "" Then
SubURL(i) = SS_LinkURL
str = str & "
"
End If
End If
rs.movenext
Next
rs.close
str = str & "
"
Response.write str
End If
End Function
' ======================================================================================================================
' 垂直子导航（指定ID）
' ======================================================================================================================
Public Sub VertMenuSubNav(SS_ID,NavVis)
If SS_ID = "" or IsNumeric(SS_ID) = False Then Exit Sub
sql = "select * from SiteStructure where SS_CheckIn<>0 and SS_Type<101 and PSS_ID="&SS_ID&" order by SS_Path"
Set Rs = LS.CreateRs(sql,1,1)
rscount = Rs.recordcount
SubNum = rscount
If rscount = 0 Then
Rs.close
Exit Sub
End If
str = "
"
For i = 1 to rscount
tSS_ID = Rs("SS_ID")
SS_Name = Rs("SS_Name")
SS_Type = Rs("SS_Type")
SS_URL = Rs("SS_URL")
SS_SubItem = Rs("SS_SubItem")
SS_Path = Rs("SS_Path")
SS_LinkURL = Rs("SS_LinkURL")
SS_HtmlUrl = Rs("SS_HtmlUrl")
If SS_Type < 100 and SS_Type <>8 and SS_Type <> 10 Then
SS_URL = SS_HtmlUrl '静态 .html
Else
SS_URL = SS_URL & "?SS_ID=" &tSS_ID '动态 .shtml
End If
If SS_LinkURL <> "" Then
str = str & "
"
End If
End If
Rs.movenext
Next
Rs.close
str = str & "
"
If NavVis = 1 Then Response.write str
End Sub
'======================================================================================================================
' 当前位置
'======================================================================================================================
Public Function NowPlace(IndexURL)
If NowSSIS = False Then Exit Function
If IndexURL = "" Then Exit Function
str = ""
NowSSSiteID = CCfg(NowSSID,3)
If NowSSSiteID > 0 Then
RootSSPath = CCfg(NowSSSiteID,1)
RootSSPathNum = UBound(Split(RootSSPath,"-"))
Else
RootSSPathNum = 0
End If
If RootSSPathNum >= NowSSPathNum Then Exit Function
PSS_ID = NowPSSID
str = str & "首页 > "
OutStr = ""
For i = 2 to NowSSPathNum - RootSSPathNum
SS_ID = CCfg(PSS_ID,0)
PSS_ID_ = CCfg(PSS_ID,2)
SS_Type = CCfg(PSS_ID,5)
SS_Name = CCfg(PSS_ID,6)
SS_URL = CCfg(PSS_ID,8)
SS_LinkURL = CCfg(PSS_ID,9)
SS_HtmlUrl = CCfg(PSS_ID,10)
If SS_Type < 100 and SS_Type <>8 and SS_Type <> 10 Then
SS_URL = SS_HtmlUrl '静态 .html
Else
SS_URL = SS_URL & "?SS_ID=" &SS_ID '动态 .shtml
End If
If SS_LinkURL <> "" Then
If OutStr = "" Then
OutStr = ""&SS_Name&" > "
Else
OutStr = ""&SS_Name&" > " & OutStr
End If
Else
If OutStr = "" Then
OutStr = ""&SS_Name&" > "
Else
OutStr = ""&SS_Name&" > " & OutStr
End If
End If
PSS_ID = PSS_ID_
Next
If NowSSType < 100 and NowSSType <>8 and NowSSType <> 10 Then
str = str & OutStr & ""&NowSSName&""
else
str = str & OutStr & ""&NowSSName&""
end if
If G_FLAGHTMLTYPE = 1 Then
response.Write(str)
Else
NowPlace = str
End If
End Function
%>
<%
' ======================================================================================================================
' 新导航主菜单子栏目列表：增加子栏目显示总数，栏目名称字数限制（SS_ID：栏目ID,NumTr:显示栏目数，WordNums:标题字数）【有缓存】
' ======================================================================================================================
Public Function SortMenuList_New(SS_ID, NumTr, WordNums)
If SS_ID = "" Or IsNumeric(SS_ID) = False Then Exit Function
Dim v_CacheName
v_CacheName = G_CACHENAME & "_SortMenuList_New_" & SS_ID
Str = ""
If Not IsEmpty(Application(v_CacheName)) And G_ALLCACHE Then
Str = Application(v_CacheName)
Else
sql = "select top "&NumTr&" SS_Name,SS_Type,SS_URL,SS_ID,SS_HtmlUrl,SS_LinkURL from SiteStructure where PSS_ID="&SS_ID&" AND SS_CheckIn<>0 AND SS_Type<105 and ss_type<>15 order by SS_No"
Set Rs = LS.CreateRs(sql, 1, 1)
rscount = Rs.recordcount
If rscount > NumTr Then
rscount = NumTr
End If
Str = Str & "
"
For i = 1 To rscount
SS_Name = Rs("SS_Name")
SS_Type = Rs("SS_Type")
SS_URL = Rs("SS_URL")
SS_ID = Rs("SS_ID")
SS_HtmlUrl = Rs("SS_HtmlUrl")
SS_LinkURL = Rs("SS_LinkURL")
If (SS_Type < 4 Or SS_Type = 95) And WebStyle = 2 Then
SS_URL = SS_HtmlUrl
Else
SS_URL = "/tmp/"&SS_URL & "?SS_ID=" & SS_ID
End If
If SS_LinkURL <> "" Then
Str = Str & "
"
Rs.Close
Set Rs = Nothing
If G_ALLCACHE Then
Application.Lock
Application(v_CacheName) = Str
Application.UnLock
End If
End If
If G_FLAGHTMLTYPE = 1 Then
response.Write(Str)
Else
SortMenuList_New = Str
End If
End Function
' ===============================================================================================
'首页普通新闻文字列表(SS_ID:栏目ID,SubIS:是否显示分类,SSIDS:多个栏目ID,NumTr:条数,OrderType:排序,NumWords:标题字数,DateVis:是否显示日期,YearVis:是否显示年份)【有缓存】
'================================================================================================
'存储过程分页
Public Function IndexDocList(SS_ID, SubIS, SSIDS, NumTr, OrderType, NumWords, DateVis, YearVis)
If (SS_ID <> "" And IsNumeric(SS_ID) = False) Or (SubIS <> 0 And SubIS <> 1) Or IsNumeric(NumTr) = False Then Exit Function
Dim v_CacheName
v_CacheName = G_CACHENAME & "_IndexDocList_" & SS_ID
Str = ""
If Not IsEmpty(Application(v_CacheName)) And G_ALLCACHE Then
Str = Application(v_CacheName)
Else
sql = "select top "&NumTr&" d_ID,d_Title,d_TitleColor,d_RedirectLink"
sql = sql & ",d_Date,d_HtmlUrl,d_Htmlpath,d_Author,d_Hit,d_IsHot,d_IsTitle,SS_SiteID,SS_ID"
sql = sql & " from DocContents where d_IsDel=0 AND d_CheckIn=1 AND d_Type=2"
If SSIDS <> "" Then
sql = sql & " AND SS_ID in ("&SSIDS&")"
ElseIf SubIS = 1 And SS_ID > 0 Then
sql = sql & " AND SS_ID in ("&CSCfg(SS_ID)&")"
Else
sql = sql & " AND SS_ID="&SS_ID
End If
Select Case OrderType
Case 0
sql = sql & " order by d_TopLock DESC,d_No DESC,d_Date DESC"
Case 1
sql = sql & " order by d_TopLock desc,d_Date DESC,d_No DESC"
Case 2
sql = sql & " order by d_Date DESC,d_No DESC"
Case 3
sql = sql & " order by d_Hit DESC,d_Date DESC"
End Select
Set oRs = doSp(sql)
If Not oRs.EOF Then
Set XMLDom_ = LS.RsToXml(oRs, "k", "c")
oRs.Close
Set oRs = Nothing
Dim SN_, SSN_
Set SN_ = XMLDom_.DocumentElement.SelectNodes("k")
Str = Str & "
"
n = 1
For Each SSN_ In SN_
If NumWords<>"" And IsNumeric(NumWords) Then
tNumWords = NumWords
End If
d_id = SSN_.SelectSingleNode("@d_id").text
d_title = SSN_.SelectSingleNode("@d_title").text
d_titlecolor = SSN_.SelectSingleNode("@d_titlecolor").text
d_redirectlink = SSN_.SelectSingleNode("@d_redirectlink").text
d_date = SSN_.SelectSingleNode("@d_date").text
d_htmlurl = SSN_.SelectSingleNode("@d_htmlurl").text
d_Htmlpath = SSN_.SelectSingleNode("@d_htmlpath").text
d_author = SSN_.SelectSingleNode("@d_author").text
d_hit = SSN_.SelectSingleNode("@d_hit").text
d_ishot = SSN_.SelectSingleNode("@d_ishot").text
d_istitle = SSN_.SelectSingleNode("@d_istitle").text
p_SiteID = SSN_.SelectSingleNode("@ss_siteid").text
ss_id = SSN_.SelectSingleNode("@ss_id").text
SI_Domain = CCfg(ss_id, 13)
If IsNull(d_RedirectLink) = False And d_RedirectLink<>"" Then
DocURL = d_RedirectLink
Else
DocURL = DocHtmlDir &p_SiteID&"/"& d_Htmlpath&d_HtmlUrl&STATICEXT
End If
li_even = ""
If n mod 2=0 Then li_even = "even"
Str = Str & "
"
Set SN_ = Nothing
Set XMLDom_ = Nothing
Else
oRs.Close
Set oRs = Nothing
Str = "正在更新中..."
End If
If G_ALLCACHE Then
Application.Lock
Application(v_CacheName) = Str
Application.UnLock
End If
End If
If G_FLAGHTMLTYPE = 1 Then
Response.Write(Str)
Else
IndexDocList = Str
End If
End Function
' ===============================================================================================
'首页普通新闻文字列表加置顶(SS_ID:栏目ID,SubIS:是否显示分类,SSIDS:多个栏目ID,NumTr:条数,OrderType:排序,NumWords:标题字数,DateVis:是否显示日期)【有缓存】
'================================================================================================
Public Function IndexTopDocList(SS_ID, SubIS, SSIDS, NumTr, OrderType, NumWords)
If (SS_ID <> "" And IsNumeric(SS_ID) = False) Or (SubIS <> 0 And SubIS <> 1) Or IsNumeric(NumTr) = False Then Exit Function
Dim v_CacheName
v_CacheName = G_CACHENAME & "_IndexTopDocList_" & SS_ID
Str = ""
If Not IsEmpty(Application(v_CacheName)) And G_ALLCACHE Then
Str = Application(v_CacheName)
Else
sql = "select top "&NumTr&" d_ID,d_Title,d_TitleColor,d_RedirectLink,d_Htmlpath"
sql = sql & ",d_Date,d_HtmlUrl,d_Author,d_Hit,d_IsHot,d_IsTitle,SS_SiteID,SS_ID"
sql = sql & " from DocContents where d_IsDel=0 AND d_CheckIn=1 AND d_Type in(2,3) and d_TopLock=1"
If SSIDS <> "" Then
sql = sql & " AND SS_ID in ("&SSIDS&")"
ElseIf SubIS = 1 And SS_ID > 0 Then
sql = sql & " AND SS_ID in ("&CSCfg(SS_ID)&")"
Else
sql = sql & " AND SS_ID="&SS_ID
End If
Select Case OrderType
Case 0
sql = sql & " order by d_TopLock DESC,d_No DESC,d_Date DESC"
Case 1
sql = sql & " order by d_TopLock desc,d_Date DESC,d_No DESC"
Case 2
sql = sql & " order by d_Date DESC,d_No DESC"
Case 3
sql = sql & " order by d_Hit DESC,d_Date DESC"
End Select
Set oRs = doSp(sql)
If Not oRs.EOF Then
Set XMLDom_ = LS.RsToXml(oRs, "k", "c")
oRs.Close
Set oRs = Nothing
Dim SN_, SSN_
Set SN_ = XMLDom_.DocumentElement.SelectNodes("k")
Str = Str & "
"
For Each SSN_ In SN_
tNumWords = NumWords
d_id = SSN_.SelectSingleNode("@d_id").text
d_title = SSN_.SelectSingleNode("@d_title").text
d_titlecolor = SSN_.SelectSingleNode("@d_titlecolor").text
d_redirectlink = SSN_.SelectSingleNode("@d_redirectlink").text
d_date = SSN_.SelectSingleNode("@d_date").text
d_htmlurl = SSN_.SelectSingleNode("@d_htmlurl").text
d_Htmlpath = SSN_.SelectSingleNode("@d_htmlpath").text
d_author = SSN_.SelectSingleNode("@d_author").text
d_hit = SSN_.SelectSingleNode("@d_hit").text
d_ishot = SSN_.SelectSingleNode("@d_ishot").text
d_istitle = SSN_.SelectSingleNode("@d_istitle").text
p_SiteID = SSN_.SelectSingleNode("@ss_siteid").text
ss_id = SSN_.SelectSingleNode("@ss_id").text
If IsNull(d_RedirectLink) = False And d_RedirectLink<>"" Then
DocURL = d_RedirectLink
Else
DocURL = DocHtmlDir & p_SiteID &"/"& d_Htmlpath & d_HtmlUrl & STATICEXT
End If
Str = Str & "
"
Set SN_ = Nothing
Set XMLDom_ = Nothing
Else
oRs.Close
Set oRs = Nothing
Str = "正在更新中..."
End If
If G_ALLCACHE Then
Application.Lock
Application(v_CacheName) = Str
Application.UnLock
End If
End If
If G_FLAGHTMLTYPE = 1 Then
Response.Write(Str)
Else
IndexTopDocList = Str
End If
End Function
' ===============================================================================================
'首页普通新闻文字列表加栏目名称(SS_ID:栏目ID,SubIS:是否显示分类,SSIDS:多个栏目ID,NumTr:条数,OrderType:排序,NumWords:标题字数,DateVis:是否显示日期)【有缓存】
'================================================================================================
Public Function IndexDocList_Sub(SS_ID, SubIS, SSIDS, NumTr, OrderType, NumWords, DateVis)
If (SS_ID <> "" And IsNumeric(SS_ID) = False) Or (SubIS <> 0 And SubIS <> 1) Or IsNumeric(NumTr) = False Then Exit Function
Dim v_CacheName
v_CacheName = G_CACHENAME & "_IndexDocList_Sub_" & SS_ID
Str = ""
If Not IsEmpty(Application(v_CacheName)) And G_ALLCACHE Then
Str = Application(v_CacheName)
Else
sql = "select top "&NumTr&" d_ID,d_Title,d_TitleColor,d_RedirectLink,d_Date,d_HtmlUrl,d_Htmlpath,SS_SiteID,"
sql = sql & "d_Author,d_Hit,d_IsHot,d_IsTitle,SS_ID "
sql = sql & "from DocContents where d_IsDel=0 AND d_CheckIn=1 AND d_Type=2"
If SSIDS <> "" Then
sql = sql & " AND SS_ID in ("&SSIDS&")"
ElseIf SubIS = 1 And SS_ID > 0 Then
sql = sql & " AND SS_ID in ("&CSCfg(SS_ID)&")"
Else
sql = sql & " AND SS_ID="&SS_ID
End If
Select Case OrderType
Case 0
sql = sql & " order by d_TopLock DESC,d_No DESC,d_Date DESC"
Case 1
sql = sql & " order by d_TopLock desc,d_Date DESC,d_No DESC"
Case 2
sql = sql & " order by d_Date DESC,d_No DESC"
Case 3
sql = sql & " order by d_Hit DESC,d_Date DESC"
End Select
Set Rs = LS.CreateRs(sql, 1, 1)
rscount = Rs.recordcount
If rscount > NumTr Then rscount = NumTr
If rscount > 0 Then
Str = Str & "
"
Else
Rs.Close
Str = "正在更新中..."
End If
Set Rs = Nothing
If G_ALLCACHE Then
Application.Lock
Application(v_CacheName) = Str
Application.UnLock
End If
End If
If G_FLAGHTMLTYPE = 1 Then
response.Write(Str)
Else
IndexDocList_Sub = Str
End If
End Function
' ======================================================================================================================
' 首页图片列表(SS_ID:栏目ID,SubIS:是否显示子栏目内容,SSIDS:多栏目ID,NumTr:条数,ImgWid:图片宽度,ImgHig:图片高度,TitleVis:是否显示标题,NumWords:标题限定字数)
' ======================================================================================================================
Public Function IndexImageList(SS_ID, SubIS, SSIDS, NumTr, OrderType, ImgWid, ImgHig, TitleVis, NumWords)
If SS_ID = "" Or IsNumeric(SS_ID) = False Or (SubIS <> 0 And SubIS <> 1) Or IsNumeric(NumTr) = False Then Exit Function
Dim v_CacheName
v_CacheName = G_CACHENAME & "_IndexImageList_" & SS_ID
Str = ""
If Not IsEmpty(Application(v_CacheName)) And G_ALLCACHE Then
Str = Application(v_CacheName)
Else
sql = "select top "&NumTr&" d_ID,d_Title,d_TitleColor,d_RedirectLink,d_Htmlpath,ss_siteid,d_LinkImage,d_HtmlUrl"
sql = sql&" from DocContents where d_LinkImage<>'' AND d_IsDel=0 AND d_CheckIn=1"
If SSIDS <> "" Then
sql = sql & " AND SS_ID in ("&SSIDS&")"
ElseIf SubIS = 1 And SS_ID > 0 Then
sql = sql & " AND SS_Path like '"&ReadSSPath(SS_ID)&"%'"
Else
sql = sql & " AND SS_ID="&SS_ID
End If
Select Case OrderType
Case 0
sql = sql & " order by d_TopLock DESC,d_No DESC,d_Date DESC"
Case 1
sql = sql & " order by d_TopLock desc,d_Date DESC,d_No DESC"
Case 2
sql = sql & " order by d_Date DESC,d_No DESC"
Case 3
sql = sql & " order by d_Hit DESC,d_Date DESC"
End Select
Set Rs = LS.CreateRs(sql, 1, 1)
rscount = Rs.recordcount
If rscount > NumTr Then rscount = NumTr
If rscount > 0 Then
Str = Str & "
"
For i = 1 To rscount
d_ID = Rs("d_ID")
d_Title = Rs("d_Title")
d_LinkImage = Rs("d_LinkImage")
d_TitleColor = Rs("d_TitleColor")
d_HtmlUrl = Rs("d_HtmlUrl")
d_RedirectLink = Rs("d_RedirectLink")
p_SiteID = Rs("ss_siteid")
d_Htmlpath = Rs("d_Htmlpath")
If IsNull(d_RedirectLink) = False And d_RedirectLink<>"" Then
DocURL = d_RedirectLink
Else
DocURL = DocHtmlDir &p_SiteID&"/"& d_Htmlpath&d_HtmlUrl&STATICEXT
End If
Str = Str & "
"
Rs.movenext
Next
Rs.Close
Set Rs = Nothing
Str = Str & "
"
Else
Rs.Close
Set Rs = Nothing
response.Write "正在更新中..."
End If
If G_ALLCACHE Then
Application.Lock
Application(v_CacheName) = Str
Application.UnLock
End If
End If
If G_FLAGHTMLTYPE = 1 Then
response.Write(Str)
Else
IndexImageList = Str
End If
End Function
' ======================================================================================================================
' 调用单篇加标新闻加概要(SS_ID:栏目ID,TitleNumWords:标题显示字数,ContentNumWords:摘要显示字数,MoreIs:是否显示详细)
' ======================================================================================================================
Public Function IndexDocTitAndWords(SS_ID, TitleNumWords, ContentNumWords, MoreIs)
If SS_ID = "" Or IsNumeric(SS_ID) = False Then Exit Function
Str = ""
sql = "select top 1 d_ID,d_Title,d_Hit,d_TitleColor,d_LinkImage,d_Date,d_HtmlUrl,d_Contents,d_RedirectLink,d_Htmlpath,ss_siteid"
sql = sql & " from vDocContents where d_Type in(2,3) AND d_IsDel=0 AND d_IsTitle=1 AND d_CheckIn=1 AND SS_ID="&SS_ID
sql = sql & " order by d_TopLock desc,d_No desc,d_Date desc"
Set Rs = LS.CreateRs(sql, 1, 1)
If Not Rs.EOF Then
xd_ID = Rs("d_ID")
xd_Title = Rs("d_Title")
xd_TitleColor = Rs("d_TitleColor")
xd_LinkImage = Rs("d_LinkImage")
xd_Date = Rs("d_Date")
xd_Hit = Rs("d_Hit")
xd_HtmlUrl = Rs("d_HtmlUrl")
d_RedirectLink = Rs("d_RedirectLink")
p_SiteID = Rs("ss_siteid")
d_Htmlpath = Rs("d_Htmlpath")
xd_Contents = MoveHTML(Rs("d_Contents"))
If IsNull(d_RedirectLink) = False And d_RedirectLink<>"" Then
DocURL = d_RedirectLink
Else
DocURL = DocHtmlDir &p_SiteID&"/"& d_Htmlpath&xd_HtmlUrl&STATICEXT
End If
xd_Title = CutStr(xd_Title, TitleNumWords)
xd_Contents = CutStr(xd_Contents, ContentNumWords)
If xd_TitleColor <> "" Then xd_Title = ""&xd_Title&""
Str = Str & "
"&xd_Contents& ""
If MoreIs<>0 Then
Str = Str & "<详情>"
End If
Str = Str & "
"&Chr(13)&Chr(10)
Str = Str & "
"&Chr(13)&Chr(10)
else
Str = "正在更新中……"
End If
Rs.Close
Set Rs = Nothing
If G_FLAGHTMLTYPE = 1 Then
response.Write(Str)
Else
IndexDocTitAndWords = Str
End If
End Function
' ===============================================================================================
'加标单篇图片加概要及下面文字列表显示(SS_ID:栏目ID;SubIS:是否显示子栏目内容;SSIDS:多栏目ID;NumRow:行数;OrderType:排列顺序;NumWords:文字标题限定显示字数;DateVis:PicWid:图片宽度;PicHig:图片高度;NumPicTitle:图片新闻标题字数;NumPicCont:图片新闻摘要字数)【有缓存】
'================================================================================================
Public Function IndexPicDocList(SS_ID, SubIS, SSIDS, NumRow, OrderType, NumWords, DateVis, PicWid, PicHig, NumPicTitle, NumPicCont)
If SS_ID = "" Or IsNumeric(SS_ID) = False Or (SubIS <> 0 And SubIS <> 1) Or IsNumeric(NumRow) = False Then Exit Function
Str = ""
'显示加标新闻
sql = "select top 1 d_ID,d_Title,d_linkimage,d_HtmlUrl,d_TitleColor,d_HtmlPath,SS_SiteID,d_Contents from vDocContents where d_Type in(2,3) AND d_IsDel=0 AND d_CheckIn=1 AND d_linkimage<>'' AND d_IsTitle<>0"
If SSIDS <> "" Then
sql = sql & " AND SS_ID in ("&SSIDS&")"
ElseIf SubIS = 1 And SS_ID > 0 Then
sql = sql & " AND SS_Path like '"&ReadSSPath(SS_ID)&"%'"
Else
sql = sql & " AND SS_ID="&SS_ID
End If
Select Case OrderType
Case 0
sql = sql & " order by d_TopLock DESC,d_No DESC,d_Date DESC"
Case 1
sql = sql & " order by d_TopLock desc,d_Date DESC,d_No DESC"
Case 2
sql = sql & " order by d_Date DESC,d_No DESC"
Case 3
sql = sql & " order by d_Hit DESC,d_Date DESC"
End Select
Set Rs = doSp(sql)
If Not Rs.EOF Then
Str = Str & "
"
NumPicTitle = NumPicTitle
NumPicCont = NumPicCont
top_ID = Rs("d_ID")
d_ID = Rs("d_ID")
d_Title = Rs("d_Title")
d_TitleColor = Rs("d_TitleColor")
d_Linkimage = Rs("d_Linkimage")
d_HtmlPath = Rs("d_HtmlPath")
d_HtmlUrl = Rs("d_HtmlUrl")
p_SiteID = Rs("SS_SiteID")
xd_Contents = Rs("d_Contents")
If IsNull(d_RedirectLink) = False And d_RedirectLink<>"" Then
DocURL = d_RedirectLink
Else
DocURL = DocHtmlDir & p_SiteID &"/"& d_HtmlPath & d_HtmlUrl&STATICEXT
End If
If NumPicTitle<>"" And IsNumeric(NumPicTitle) Then
d_Title = CutStr(Rs("d_Title"), NumPicTitle)
End If
Str = Str & "
"
Else
top_ID = 0
End If
Rs.Close
'显示加标新闻
sql = "select top "&NumRow&" a.d_ID,a.d_Title,a.d_IsHot,a.d_IsTitle,a.d_TitleColor,a.d_HtmlPath,a.SS_SiteID"
sql = sql & ",a.d_RedirectLink,a.d_Date,a.d_HtmlUrl,a.d_Author,a.d_Hit "
sql = sql & " from DocContents as a left join SiteStructure as b "
sql = sql & "on a.SS_ID=b.SS_ID where a.d_IsDel=0 AND a.d_Type in(2,3) AND a.d_CheckIn=1"
If top_id<>"" And IsNumeric(top_id) Then
sql = sql & " AND a.d_ID not in ("&top_ID&")"
End If
If SSIDS <> "" Then
sql = sql & " AND a.SS_ID in ("&SSIDS&")"
ElseIf SubIS = 1 And SS_ID > 0 Then
sql = sql & " AND a.SS_Path like '"&ReadSSPath(SS_ID)&"%'"
Else
sql = sql & " AND a.SS_ID="&SS_ID
End If
Select Case OrderType
Case 0
sql = sql & " order by d_TopLock DESC,d_No DESC,d_Date DESC"
Case 1
sql = sql & " order by d_TopLock desc,d_Date DESC,d_No DESC"
Case 2
sql = sql & " order by d_Date DESC,d_No DESC"
Case 3
sql = sql & " order by d_Hit DESC,d_Date DESC"
End Select
Set Rs = Ls.CreateRs(sql, 1, 1)
rscount = Rs.recordcount
If rscount > NumRow Then rscount = NumRow
If rscount > 0 Then
Str = Str & "
"
tNumWords = NumWords
For i = 1 To rscount
d_ID = Rs("d_ID")
d_Title = Rs("d_Title")
d_TitleColor = Rs("d_TitleColor")
d_Date = Rs("d_Date")
d_Author = Rs("d_Author")
d_IsHot = Rs("d_IsHot")
d_Hit = Rs("d_Hit")
d_HtmlUrl = Rs("d_HtmlUrl")
d_HtmlPath = Rs("d_HtmlPath")
p_SiteID = Rs("SS_SiteID")
d_RedirectLink = Rs("d_RedirectLink")
If IsNull(d_RedirectLink) = False And d_RedirectLink<>"" Then
DocURL = d_RedirectLink
Else
DocURL = DocHtmlDir & p_SiteID &"/"& d_HtmlPath & d_HtmlUrl&STATICEXT
End If
If d_IsHot<>"" And IsNull(d_IsHot) = False Then
If d_IsHot<>0 Then '显示加新，加热图标标题长度再缩短四个字符
d_Title = CutStr(d_Title, tNumWords -2)
Else
d_Title = CutStr(d_Title, tNumWords)
End If
End If
Str = Str & "
"
If d_TitleColor <> "" Then d_Title = ""&d_Title&""
Str = Str & d_Title&""
If d_IsHot<>"" And IsNull(d_IsHot) = False Then
If d_IsHot<>0 Then '是否加热
Str = Str & ""
End If
End If
Str = Str & ""
If DateVis = 1 Then
Str = Str & ""
Str = Str & ""&Ls.datetime(d_date, "mm-dd")
Str = Str & ""
End If
Str = Str & "
"
Rs.movenext
Next
Rs.Close
Set Rs = Nothing
Str = Str & "
"
Else
Rs.Close
Set Rs = Nothing
response.Write "正在更新中..."
End If
If G_FLAGHTMLTYPE = 1 Then
response.Write(Str)
Else
IndexPicDocList = Str
End If
End Function
' ======================================================================================================================
' 首页调用大标加标新闻(SS_ID:栏目ID,TitleNumWords:标题显示字数,ContentNumWords:摘要显示字数,MoreIs:是否显示详细)
' ======================================================================================================================
Public Function IndexDocBigTitle(SS_ID, TitleNumWords)
If SS_ID = "" Or IsNumeric(SS_ID) = False Then Exit Function
Str = ""
sql = "select top 1 d_ID,d_Title,d_TitleColor,d_Date,d_HtmlUrl,SS_SiteID,d_HtmlPath,d_RedirectLink"
sql = sql & " from DocContents where d_Type in(2,3) AND d_IsDel=0 AND d_IsTitle=1 AND d_CheckIn=1 AND SS_ID="&SS_ID
sql = sql & " order by d_TopLock desc,d_No desc,d_Date desc"
Set Rs = doSp(sql)
If Not Rs.EOF Then
xd_ID = Rs("d_ID")
xd_Title = Rs("d_Title")
xd_TitleColor = Rs("d_TitleColor")
xd_Date = Rs("d_Date")
d_HtmlUrl = Rs("d_HtmlUrl")
p_SiteID = Rs("SS_SiteID")
d_HtmlPath = Rs("d_HtmlPath")
d_RedirectLink = Rs("d_RedirectLink")
xd_HtmlUrl = DocHtmlDir &p_SiteID&"/"& d_Htmlpath&d_HtmlUrl&STATICEXT
if d_RedirectLink<>"" then xd_HtmlUrl = d_RedirectLink
If TitleNumWords > 0 Then xd_Title = CutStr(xd_Title, TitleNumWords )
If xd_TitleColor <> "" Then xd_Title = ""&xd_Title&""
Str = Str & ""
Str = Str & ""&xd_Title&""
Else
Str = "正在更新中..."
End If
Rs.Close
Set Rs = Nothing
If G_FLAGHTMLTYPE = 1 Then
response.Write(Str)
Else
IndexDocBigTitle = Str
End If
End Function
'================================================================================================
'首页切换图片(SS_ID:栏目ID,SubIS:是否显示分类,SSIDS:多个栏目ID,NumRow:条数,ImgWid：图片宽度,ImgHig:图片高度,divwid:DIV宽度,divhig:Div高度,TxtHig:标题行高,NumWords:标题字数)【有缓存】
'================================================================================================
Public Function MyFocus(SS_ID, SubIS, NumRow, ImgWid, ImgHig, divwid, divhig, TxtHig, NumWords, ScriptName)
If SS_ID = "" Or IsNumeric(SS_ID) = False Or (SubIS <> 0 And SubIS <> 1) Or IsNumeric(NumRow) = False Then Exit Function
If ScriptName = "" Then ScriptName = "mF_classicHC"
Str = ""
sql = "select top "&NumRow&" d_ID,d_Title,d_TitleColor,d_RedirectLink,d_LinkImage,d_Date,d_HtmlUrl,"
sql = sql & "d_Author,d_Hit,d_IsHot,d_IsTitle,SS_ID,d_HtmlPath,SS_SiteID "
sql = sql & " from DocContents where d_IsDel=0 AND d_CheckIn=1 AND d_LinkImage<>''"
If SubIS = 1 And SS_ID > 0 Then
sql = sql & " AND SS_ID in ("&CSCfg(SS_ID)&")"
Else
sql = sql & " AND SS_ID="&SS_ID
End If
sql = sql&" order by d_TopLock DESC,d_Date DESC"
Set oRs = doSp(sql)
If Not oRs.EOF Then
Set XMLDom_ = LS.RsToXml(oRs, "k", "c")
oRs.Close
Set oRs = Nothing
Dim SN_, SSN_
Set SN_ = XMLDom_.DocumentElement.SelectNodes("k")
Str = Str & "
"
Str = Str & "
"
For Each SSN_ In SN_
d_id = SSN_.SelectSingleNode("@d_id").text
d_title = SSN_.SelectSingleNode("@d_title").text
d_title1 = d_title
d_redirectlink = SSN_.SelectSingleNode("@d_redirectlink").text
d_linkimage = SSN_.SelectSingleNode("@d_linkimage").text
d_HtmlUrl = SSN_.SelectSingleNode("@d_htmlurl").text
d_ssid = SSN_.SelectSingleNode("@ss_id").text
d_HtmlPath = SSN_.SelectSingleNode("@d_htmlpath").text
SS_SiteID = SSN_.SelectSingleNode("@ss_siteid").text
SI_Domain = CCfg(d_ssid, 13)
If IsNull(d_RedirectLink) = False And d_RedirectLink<>"" Then
DocURL = d_RedirectLink
Else
DocURL = DocHtmlDir & SS_SiteID &"/"& d_HtmlPath & d_HtmlUrl&STATICEXT
End If
If NumWords > 0 Then d_Title = CutStr(d_Title, NumWords )
Str = Str & "
"
Next
Str = Str & "
"
Str = Str & "
"
Str = Str & ""&Chr(13)&Chr(10)
Else
oRs.Close
Set oRs = Nothing
Str = "正在更新中..."
End If
If G_FLAGHTMLTYPE = 1 Then
response.Write(Str)
Else
MyFocus = Str
End If
End Function
'调用办事用户单位列表
Public Function BS_units(NumTr, NumWords)
If NumTr = "" Or IsNumeric(NumTr) = False Then Exit Function
Str = ""
sql = "select top "&NumTr&" UI_Name,UI_id from UnitsInfo where UI_SubItem=0 AND UI_ID<>0 and UI_Lock=0 and UI_hidden=1 order by UI_Path"
Set Rs = doSp(sql)
rscount = Rs.recordcount
If rscount > NumTr Then
rscount = NumTr
End If
Str = Str & "
"
For i = 1 To rscount
UI_Name = Rs("UI_Name")
UI_ID = Rs("UI_ID")
If NumWords<>"" Then
UI_Name = CutStr(UI_Name, NumWords )
End If
Str = Str & "
"
Rs.Close
Set Rs = Nothing
If G_FLAGHTMLTYPE = 1 Then
response.Write(Str)
Else
BS_units = Str
End If
End Function
'===========================
'首页政民互动调用部门单位
'===========================
Function IndexUnits(NumTr, Numwords)
If NumTr = "" Or IsNumeric(NumTr) = False Then Exit Function
Str = ""
sql = "select top "&NumTr&" UI_Name,UI_id from UnitsInfo where UI_SubItem=0 AND UI_ID<>0 and UI_Lock=0 and UI_hdhidde=1 order by UI_Path"
Set Rs = Ls.CreateRs(sql, 1, 1)
rscount = Rs.recordcount
If rscount > 0 Then
Str = Str &"
"
For i = 1 To rscount
UI_Name = Rs("UI_Name")
UI_id = Rs("UI_id")
If Numwords<>"" Then
UI_Name = CutStr(UI_Name, Numwords )
End If
Str = Str &"
"
Else
Str = Str & "正在更新中..."
End If
Rs.Close
Set Rs = Nothing
If G_FLAGHTMLTYPE = 1 Then
response.Write(Str)
Else
IndexUnits = Str
End If
End Function
%>
<%
Public Function AD(ByVal AS_ID, ByVal NumTr, ByVal RandomIS, ByVal ByRandomNum, ByVal IsVouch)
Str = ""
If G_FLAGHTMLTYPE = 1 Then
Response.Write(Str)
Else
AD = Str
End If
End Function
Public Function AD_Head(ByVal AS_ID, ByVal NumTr, ByVal RandomIS, ByVal ByRandomNum, ByVal IsVouch)
If AS_ID = "" or IsNumeric(AS_ID) = False or RandomIS = "" Then Exit Function
Str = ""
If RandomIS = 0 Then '不随机取
If NumTr = 0 Then Call OutScript("行数或列数不规范！")
sql = "select top " & NumTr & " ADInfo.*,ADSort.AS_LogoIS as AS_LogoIS,ADSort.AS_LogoWidth as AS_LogoWidth,"
sql = sql&"ADSort.AS_LogoHeight as AS_LogoHeight from ADInfo inner join ADSort on ADInfo.AS_ID=ADSort.AS_ID where "
sql = sql&"ADInfo.AS_ID="&AS_ID&" and ADInfo.AI_IsShow=1"
If IsVouch = 1 Then sql = sql & " and ADInfo.AI_Vouch <> 0"
sql = sql & " order by ADInfo.AI_Vouch"&OType&",ADInfo.AI_NO desc,ADInfo.AI_Date desc"
Set rs = LS.CreateRs(sql, 1, 1)
rscount = rs.recordcount
If rscount = 0 Then
rs.close
Exit Function
End If
If rscount > NumTr Then rscount = NumTr
AS_LogoIS = rs("AS_LogoIS")
AS_LogoWidth = rs("AS_LogoWidth")
AS_LogoHeight = rs("AS_LogoHeight")
Str = Str & "
"
If AS_LogoIS = True Then
For i = 1 to rscount
AI_ID = rs("AI_ID")
AI_Name = rs("AI_Name")
AI_LogoURL = rs("AI_LogoURL")
AI_URL = rs("AI_URL")
Str = Str & "
"
rs.movenext
Next
Else
For i = 1 to rscount
AI_ID = rs("AI_ID")
AI_Name = rs("AI_Name")
AI_LogoURL = rs("AI_LogoURL")
AI_URL = rs("AI_URL")
If AI_URL<>"#" Then
Str = Str & "
"
end if
rs.movenext
Next
End If
rs.close
Str = Str & "
"
Else '随机取值
Dim tAI_ID(),tAI_Name(),tAI_LogoURL(),tAI_URL()
sql = "select top " & RandomNum & " ADInfo.*,ADSort.AS_LogoIS as AS_LogoIS,ADSort.AS_LogoWidth as AS_LogoWidth,"
sql = sql & "ADSort.AS_LogoHeight as AS_LogoHeight from ADInfo inner join ADSort on ADInfo.AS_ID=ADSort.AS_ID where "
sql = sql & "ADInfo.AS_ID="&AS_ID&" and ADInfo.AI_IsShow=1"
If IsVouch = 1 Then sql = sql & " and ADInfo.AI_Vouch <> 0"
sql = sql & " order by ADInfo.AI_Vouch"&OType&",ADInfo.AI_NO desc,ADInfo.AI_Date desc,ADInfo.AI_Time desc"
Set rs = LS.CreateRs(sql, 1, 1)
rscount = rs.recordcount
If rscount = 0 Then
rs.close
Exit Function
End If
If rscount > RandomNum Then rscount = RandomNum
Redim Preserve tAI_ID(rscount),tAI_Name(rscount),tAI_LogoURL(rscount),tAI_URL(rscount)
AS_LogoIS = rs("AS_LogoIS")
AS_LogoWidth = rs("AS_LogoWidth")
AS_LogoHeight = rs("AS_LogoHeight")
For i = 1 to rscount
tAI_ID(i) = rs("AI_ID")
tAI_Name(i) = rs("AI_Name")
tAI_LogoURL(i) = rs("AI_LogoURL")
tAI_URL(i) = rs("AI_URL")
rs.movenext
Next
rs.close
Randomize
Max = rscount
Min = 1
ri = Round(Rnd * (Max - Min + 1) - 0.5) + Min
Str = Str & "
"
End If
If G_FLAGHTMLTYPE = 1 Then
Response.Write(Str)
Else
AD_Head = Str
End If
End Function
' ======================================================================================================================
' 广告位样式递增(AS_ID:广告分类,NumRow:显示个
' ======================================================================================================================
Public Function AD_LI(AS_ID, NumRow)
If AS_ID = "" Or IsNumeric(AS_ID) = False Or NumRow = "" Or IsNumeric(NumRow) = False Then Exit Function
Str = ""
If NumRow = 0 Then Call OutScript("行数不规范！")
sql = "select top "&NumRow&" AI_ID,AI_Name,AI_URL from ADInfo where AS_ID="&AS_ID&" and AI_IsShow=1"
sql = sql & " order by AI_Vouch desc,AI_NO desc,AI_Date desc"
Set rs = LS.CreateRs(sql, 1, 1)
rscount = rs.recordcount
If rscount = 0 Then
rs.Close
Exit Function
End If
If rscount > NumRow Then rscount = NumRow
Str = Str & "
"
For i = 1 To rscount
AI_ID = rs("AI_ID")
AI_Name = rs("AI_Name")
AI_URL = rs("AI_URL")
Str = Str & "
"
rs.Close
Set rs = Nothing
AD_LI = Str
End Function
'======================================================================================================================
'支持多个浏览器漂浮（AS_ID：广告分类号）
' ======================================================================================================================
Function FloatingAds(AS_ID)
Str = ""
If AS_ID = "" Then Exit Function
sql = "select a.AI_ID as AI_ID,a.AI_Name as AI_Name,a.AI_LogoURL as AI_LogoURL,a.AI_URL as AI_URL,b.AS_LogoIS as AS_LogoIS,b.AS_LogoWidth as AS_LogoWidth,"
sql = sql&"b.AS_LogoHeight as AS_LogoHeight from ADInfo as a inner join ADSort as b on a.AS_ID=b.AS_ID where "
sql = sql&"a.AS_ID ="&AS_ID&" and a.AI_IsShow=1 order by a.AI_NO desc,a.AI_Date desc"
Set rs = LS.CreateRs(sql, 1, 1)
rscount = rs.recordcount
If rs.EOF Then
rs.Close
Exit Function
End If
Str = Str & "" & Chr(13)
Str = Str & "" & Chr(13)
For mi = 1 To rscount
AS_LogoIS = rs("AS_LogoIS")
AS_LogoWidth = rs("AS_LogoWidth")
AS_LogoHeight = rs("AS_LogoHeight")
AI_ID = rs("AI_ID")
AI_Name = rs("AI_Name")
AI_LogoURL = rs("AI_LogoURL")
AI_URL = rs("AI_URL")
If AS_LogoIS = True Then
Str = Str & "
" & Chr(13)
Str = Str & "" & Chr(13)
End If
rs.movenext
Next
rs.Close
Set rs = Nothing
If G_FLAGHTMLTYPE = 1 Then
response.Write(Str)
Else
FloatingAds = Str
End If
End Function
' ======================================================================================================================
' 下拉列表式友情链接(AS_ID:广告分类,NumRow:显示个数,BgCor:背景颜色,FontCor:字体颜色,MenuName:菜单名称,selectWid:下拉框宽度)
' ======================================================================================================================
Public Function ADMenu(AS_ID, NumRow, BgCor, FontCor, MenuName, selectWid)
If AS_ID = "" Or IsNumeric(AS_ID) = False Or NumRow = "" Or IsNumeric(NumRow) = False Or MenuName = "" Then Exit Function
Str = ""
If NumRow = 0 Then Call OutScript("行数不规范！")
sql = "select top "&NumRow&" AI_ID,AI_Name,AI_URL from ADInfo where AS_ID="&AS_ID&" and AI_IsShow=1"
sql = sql & " order by AI_Vouch desc,AI_NO desc,AI_Date desc"
Set rs = LS.CreateRs(sql, 1, 1)
rscount = rs.recordcount
If rscount = 0 Then
rs.Close
Exit Function
End If
If rscount > NumRow Then rscount = NumRow
Randomize
Random = Round(Rnd * (100 - 1 + 1) - 0.5) + 1
Str = Str & ""&Chr(13)&Chr(10)
rs.Close
Set rs = Nothing
If G_FLAGHTMLTYPE = 1 Then
response.Write(Str)
Else
ADMenu = Str
End If
End Function
'======================================================================================================================
'头部大广告图片渐隐（AS_ID:广告分类,AD_Height:显示高度,StopTime:停顿时间,ObjectName:对象名称）
' ======================================================================================================================
Function ADChangeHidden(AS_ID, AD_Height, StopTime, ObjectName)
Str = ""
If AS_ID = "" Then Exit Function
sql = "select a.AI_ID as AI_ID,a.AI_Name as AI_Name,a.AI_LogoURL as AI_LogoURL,a.AI_URL as AI_URL,b.AS_LogoIS as AS_LogoIS,b.AS_LogoWidth as AS_LogoWidth,"
sql = sql&"b.AS_LogoHeight as AS_LogoHeight from ADInfo as a left join ADSort as b on a.AS_ID=b.AS_ID where "
sql = sql&"a.AS_ID ="&AS_ID&" and a.AI_IsShow=1 order by a.AI_NO desc,a.AI_Date desc"
Set rs = LS.CreateRs(sql, 1, 1)
If Not rs.EOF Then
AS_LogoIS = rs("AS_LogoIS")
AS_LogoWidth = rs("AS_LogoWidth")
AS_LogoHeight = rs("AS_LogoHeight")
AI_ID = rs("AI_ID")
AI_Name = rs("AI_Name")
AI_LogoURL = rs("AI_LogoURL")
AI_URL = rs("AI_URL")
If AS_LogoIS = True Then
With Response
Str = Str & "" & Chr(13)
Str = Str & "
"
End With
End If
End If
rs.Close
Set rs = Nothing
If G_FLAGHTMLTYPE = 1 Then
response.Write(Str)
Else
ADChangeHidden = Str
End If
End Function
%>
<%
' ===============================================================================================
'首页普通新闻文字列表(SS_ID:栏目ID,FunctionIS:是否显示分类,SSIDS:多个栏目ID,NumTr:条数,NumWords:标题字数,DateVis:是否显示日期 )
'================================================================================================
Function SearchDocList_index(SS_SiteID, PerNumRow, NumWords, DateVis)
Str = ""
SearchWords = GetSafeStr(Trim(Request.QueryString("SearchWords")))
SearchFrom = GetSafeStr(Trim(Request("SearchFrom")))
If SearchWords = "" Then
response.Write "请输入搜索关键词！"
Exit Function
End If
If SS_SiteID = "" Or IsNumeric(SS_SiteID) = False Or PerNumRow = "" Or IsNumeric(PerNumRow) = False Then Exit Function
sql = " d_IsDel=0 and d_CheckIn=1"
If SS_SiteID<>"" Then
sql = sql&" and SS_SiteID="&SS_SiteID
End If
If SearchWords <> "" Then
sql = sql&" and d_TITLE like '%"&SearchWords&"%'"
End If
'默认分页样式名称 pagination
With LS.DB
.PageSize = CInt(PerNumRow)'定义页数
.ListLong = 3'页数前后显示个数
.Pkey = "d_ID"'主键
.Field = "d_ID,d_Title,d_Date,d_Author,d_Hit,d_IsHot,d_HtmlUrl,d_RedirectLink,SS_SiteID,d_HtmlPath,d_type"'字段，尽量不要用*号
.Table = "doccontents"'表名
.Condition = sql '条件语句，不带用where
.OrderBy = "d_TopLock desc,d_Date desc,d_No desc"'排序,不用带order by
.RecordCount = 0'默认0即可。
Set oRs = .ResultSet
strPage = .PageNav()'分页列表
End With
If oRs.EOF Then
oRs.Close
response.Write "抱歉！未找到符合条件的内容。"
Exit Function
End If
Str = Str & "
"
tNumWords = NumWords
Do While Not oRs.EOF
d_ID = oRs("d_ID")
d_Title = oRs("d_Title")
d_Title1 = d_Title
d_Date = Ls.datetime(oRs("d_Date"), "yyyy-mm-dd")
d_Author = oRs("d_Author")
d_IsHot = oRs("d_IsHot")
d_Hit = oRs("d_Hit")
d_type = oRs("d_type")
d_HtmlUrl = oRs("d_HtmlUrl")
d_HtmlPath = oRs("d_HtmlPath")
SS_SiteID = oRs("SS_SiteID")
d_RedirectLink = oRs("d_RedirectLink")
If IsNull(d_RedirectLink) = False And d_RedirectLink<>"" Then
DocURL = d_RedirectLink
Else
if d_type =1 then
DocURL = SiteCfg(SS_SiteID, 3)&SortHtmlDir & SS_SiteID &"/"& d_HtmlPath & d_HtmlUrl
else
DocURL = SiteCfg(SS_SiteID, 3)&DocHtmlDir & SS_SiteID &"/"& d_HtmlPath & d_HtmlUrl&STATICEXT
end if
End If
if tNumWords<>"" and isnumeric(tNumWords) then d_Title = CutStr(d_Title,tNumWords)
d_Title = Replace(d_Title, SearchWords, ""&SearchWords&"", 1, -1, 1)
Str = Str & "
"
If LS.DB.Recordcount>CInt(PerNumRow) Then
Str = Str & "
"
Str = Str & strPage
Str = Str & "
"
End If
oRs.Close
Set oRs = Nothing
If G_FLAGHTMLTYPE = 1 Then
response.Write(Str)
Else
SearchDocList_index = Str
End If
End Function
'======================================================================================================================
' 普通文章栏目页面IndexSortDoc(SS_ID：栏目ID，NumWords：内容字数)
'======================================================================================================================
Function IndexSortDoc(SS_ID, NumWords)
Str = ""
If SS_ID = "" Or IsNumeric(SS_ID) = False Then Exit Function
sql = "select d_id,d_Hit,d_Contents from vDocContents where d_IsDel=0 and d_Type=1 and SS_ID=" & SS_ID
Set rs = LS.CreateRs(sql, 1, 1)
If Not rs.EOF Then
d_id = rs("d_id")
d_Hit = rs("d_Hit")
d_Contents = rs("d_Contents")
If d_Contents = "" Or IsNull(d_Contents) = True Then
response.Write "正在更新中..."
exit function
end if
If NumWords <> "" And IsNumeric(NumWords) = True Then
Str = Str & Cutstr(MoveHTML(d_Contents), NumWords )
Else
Str = Str & d_Contents
End If
Else
response.Write "正在更新中..."
End If
rs.Close
Set rs = Nothing
If G_FLAGHTMLTYPE = 1 Then
response.Write(Str)
Else
IndexSortDoc = Str
End If
End Function
Function IndexSortDocs(SS_ID, NumWords)
Str = ""
If SS_ID = "" Or IsNumeric(SS_ID) = False Then Exit Function
sql = "select d_id,d_Hit,d_Contents from vDocContents where d_IsDel=0 and d_Type=1 and SS_ID=" & SS_ID
Set rs = LS.CreateRs(sql, 1, 1)
If Not rs.EOF Then
d_id = rs("d_id")
d_Hit = rs("d_Hit")
d_Contents = rs("d_Contents")
If d_Contents = "" Or IsNull(d_Contents) = True Then
response.Write "正在更新中..."
exit function
end if
If NumWords <> "" And IsNumeric(NumWords) = True Then
Str = Str & Cutstr(d_Contents, NumWords )
Else
Str = Str & d_Contents
End If
Else
response.Write "正在更新中..."
End If
rs.Close
Set rs = Nothing
If G_FLAGHTMLTYPE = 1 Then
response.Write(Str)
Else
IndexSortDocs = Str
End If
End Function
'======================================================================================================================
' 栏目页普通文章栏目页面
'======================================================================================================================
Function SortDoc()
Str = ""
sql = "select d_Hit,d_Contents from vDocContents where d_IsDel=0 and d_Type=1 and SS_ID=" & NowSSID
Set rs = LS.CreateRs(sql, 1, 1)
If Not rs.EOF Then
d_Contents = rs("d_Contents")
If d_Contents = "" Or IsNull(d_Contents) = True Then
response.Write "正在更新中..."
Else
Str = Str & d_Contents
End If
Else
response.Write "正在更新中..."
End If
rs.Close
Set rs = Nothing
If G_FLAGHTMLTYPE = 1 Then
response.Write(Str)
Else
SortDoc = Str
End If
End Function
'======================================================================================================================
' 栏目页文字文章列表 (PerNumRow:每页显示条数,NumRow:当有子栏目时,调用子栏目条数,NumWords：新闻标题显示字数,DateVis：是否在文章标题后显示日期,取值:0;1,SubDocVis:是否显示子项目名称)
'======================================================================================================================
Function DocList(PerNumRow, NumRow, NumWords, DateVis, SubDocVis,imgWidth,imgHight,imgNums,imgNumWords,OrderType)
Str = ""
If NowSSIS = False Then Exit Function
If NowSSType = 1 Then '当前项目为页面
response.Write SortDoc()
Exit Function
End If
If NowSSSubItem = True Then
If UBound(SubType) = 0 Then Exit Function
If SubType(1) = 1 Then
Response.Redirect "?SS_ID=" & SubID(1) '第一个子项目为页面，转向第一个项目
Exit Function
End If
End If
If NowSSSubItem And (NowSSType = 2 Or NowSSType = 3) Then '当前项目有子项目，且为文字或图片分类，显示分类名称
For i = 1 To SubNum
If SubType(i) = 2 Or SubType(i) = 3 Then '列出项目名称
Str = Str & "
"
If SubItem0(i) = True And SubDocVis = 0 Then '分类包含子项目，列出子项目名称
Set pclass = Application(G_CACHENAME & "_PortalClass").DocumentElement.SelectNodes("k[@w2="& SubID(i) &"]")
If pclass.Length>0 Then
Str = Str & "
"
For Each subclass In pclass
SS_ID = subclass.SelectSingleNode("@w0").text
SS_HtmlUrl = subclass.SelectSingleNode("@w10").text
SS_URL = subclass.SelectSingleNode("@w8").text
SS_LinkURL = subclass.SelectSingleNode("@w9").text
SS_Type = subclass.SelectSingleNode("@w5").text
SS_Name = subclass.SelectSingleNode("@w6").text
SS_SubItem = subclass.SelectSingleNode("@w7").text
If WebStyle = 1 Then SS_HtmlUrl = SS_URL & "?SS_ID=" & SS_ID
'If k Mod 8 = 1 Then Str = Str & "
"
if SS_LinkURL<>"" then
Str = Str & ""&SS_Name&""
else
If (SS_Type < 4 Or SS_Type = 95) Then
Str = Str & ""&SS_Name&""
Else
Str = Str & ""&SS_Name&""
End If
end if
Str = Str & ""
Next
Str = Str & "
"
End If
Else '子项目中不再包含子项目，则列出指定篇数的最近更新文章列表
If SubType(i) = 2 Then '列出项目名称
sql = "select top "&NumRow&" d_ID,d_Title,d_IsHot,d_TitleColor,d_Date,d_HtmlUrl,d_RedirectLink,d_Htmlpath,SS_SiteID from doccontents"
If SubDocVis = 1 Then
sql = sql & " where SS_ID in ("&CSCfg(SubID(i))&")"
Else
sql = sql & " where SS_ID="&SubID(i)&""
End If
sql = sql&" and d_Type=2 and d_IsDel=0 and d_CheckIn=1"
Select Case OrderType
Case 0
sql = sql & " order by d_TopLock DESC,d_No DESC,d_Date DESC"
Case 1
sql = sql & " order by d_TopLock desc,d_Date DESC,d_No DESC"
Case 2
sql = sql & " order by d_Date DESC,d_No DESC"
Case 3
sql = sql & " order by d_Hit DESC,d_Date DESC"
End Select
Set rs = LS.CreateRs(sql, 1, 1)
rscount = rs.recordcount
Str = Str & "
"
For k = 1 To rscount
tNumWords = NumWords
d_ID = rs("d_ID")
d_Title = rs("d_Title")
d_Date = rs("d_Date")
d_IsHot = rs("d_IsHot")
d_HtmlUrl = rs("d_HtmlUrl")
d_RedirectLink = rs("d_RedirectLink")
d_HtmlPath = rs("d_HtmlPath")
p_SiteID = RS("SS_SiteID")
d_TitleColor = rs("d_TitleColor")
If IsNull(d_RedirectLink) = False And d_RedirectLink<>"" Then
DocURL = d_RedirectLink
Else
DocURL = DocHtmlDir & p_SiteID &"/" & d_HtmlPath & d_HtmlUrl & STATICEXT
End If
Str = Str & "
"
rs.Close
Set rs = Nothing
End If
end if
If SubType(i) = 3 Then '列出项目名称
sql = "select top "&imgNums&" d_ID,d_Title,d_IsHot,d_TitleColor,d_Date,d_HtmlUrl,d_RedirectLink,d_Htmlpath,SS_SiteID,d_LinkImage from doccontents"
If SubDocVis = 1 Then
sql = sql & " where SS_ID in ("&CSCfg(SubID(i))&")"
Else
sql = sql & " where SS_ID="&SubID(i)&""
End If
sql = sql&" and d_Type=3 and d_IsDel=0 and d_CheckIn=1"
Select Case OrderType
Case 0
sql = sql & " order by d_TopLock DESC,d_No DESC,d_Date DESC"
Case 1
sql = sql & " order by d_TopLock desc,d_Date DESC,d_No DESC"
Case 2
sql = sql & " order by d_Date DESC,d_No DESC"
Case 3
sql = sql & " order by d_Hit DESC,d_Date DESC"
End Select
Set rs = LS.CreateRs(sql, 1, 1)
rscount = rs.recordcount
If rscount > 0 Then
Str = Str & "
"
For k = 1 To rscount
d_ID = rs("d_ID")
d_Title = rs("d_Title")
d_Title1 = rs("d_Title")
d_LinkImage = rs("d_LinkImage")
d_TitleColor = rs("d_TitleColor")
d_HtmlUrl = rs("d_HtmlUrl")
d_HtmlPath = rs("d_HtmlPath")
d_RedirectLink = rs("d_RedirectLink")
p_SiteID = rs("SS_Siteid")
If IsNull(d_RedirectLink) = False And d_RedirectLink<>"" Then
DocURL = d_RedirectLink
Else
DocURL = DocHtmlDir & p_SiteID &"/" & d_HtmlPath & d_HtmlUrl & STATICEXT
End If
If imgNumWords > 0 Then d_Title = CutStr(d_Title, imgNumWords )
If d_TitleColor <> "" Then d_Title = ""&d_Title&""
Str = Str & "
"
rs.movenext
Next
rs.Close
Set rs = Nothing
Str = Str & "
"
Else
rs.Close
Set rs = Nothing
Str = Str & "正在更新中..."
End If
End If
End If
Next
If G_FLAGHTMLTYPE = 1 Then
response.Write(Str)
Else
DocList = Str
End If
End If
If Not NowSSSubItem And (CInt(NowSSType) = 2 Or CInt(NowSSType) = 3) Then '当前项目下无子项目，尽量不要用*号
.Table = "doccontents"'表名
.Condition = sql '条件语句，显示文字列表
Select Case OrderType
Case 0
sqlorder = " d_TopLock DESC,d_No DESC,d_Date DESC"
Case 1
sqlorder = " d_TopLock desc,d_Date DESC,d_No DESC"
Case 2
sqlorder = " d_Date DESC,d_No DESC"
Case 3
sqlorder = " d_Hit DESC,d_Date DESC"
End Select
sql = " SS_ID="&NowSSID&" and d_Type=2 and d_IsDel=0 and d_CheckIn=1"
'默认分页样式名称 pagination
With LS.DB
.PageSize = CInt(PerNumRow)'定义页数
.ListLong = 3'页数前后显示个数
.Pkey = "d_ID"'主键
.Field = "d_ID,d_Title,d_Date,d_Hit,d_TitleColor,d_IsHot,d_HtmlUrl,d_RedirectLink,d_Htmlpath,SS_SiteID"'字段，且当前项目为图片或文字分类，不带用where
.OrderBy = sqlorder'排序,不用带order by
.RecordCount = 0'默认0即可。
Set oRs = .ResultSet
.Template = "
"
strPage = .PageNav()'分页列表
End With
If oRs.EOF Then
oRs.Close
response.Write "正在更新中..."
Exit Function
End If
gourl="/tmp/"&NowSSURL&"?SS_ID="&nowSSID&"&pp="
If Not oRs.EOF Then
Str = Str & ""&Chr(13)&Chr(10)
End If
If Not IsNull(oRs) Then
Str = Str & "
"
Do While Not oRs.EOF
tNumWords = NumWords
d_ID = oRs("d_ID")
d_Title = oRs("d_Title")
d_Date = oRs("d_Date")
d_Hit = oRs("d_Hit")
d_IsHot = oRs("d_IsHot")
d_HtmlUrl = oRs("d_HtmlUrl")
d_HtmlPath = oRs("d_HtmlPath")
d_RedirectLink = oRs("d_RedirectLink")
p_SiteID = oRs("SS_SiteID")
d_TitleColor = oRs("d_TitleColor")
If IsNull(d_RedirectLink) = False And d_RedirectLink<>"" Then
DocURL = d_RedirectLink
Else
DocURL = DocHtmlDir & p_SiteID &"/"& d_HtmlPath & d_HtmlUrl&STATICEXT
End If
Str = Str & "
"
if LS.DB.recordcount > PerNumRow then
Str = Str & strPage&""
end if
Str = Str & "
"
End If
oRs.Close
Set oRs = Nothing
End If
If G_FLAGHTMLTYPE = 1 Then
response.Write(Str)
Else
DocList = Str
End If
End Function
Function DocList_tpl(PerNumRow, NumRow, NumWords, DateVis, SubDocVis,imgWidth,imgHight,imgNums,imgNumWords,action)
Str = ""
If NowSSIS = False Then Exit Function
If NowSSType = 1 Then '当前项目为页面
response.Write SortDoc()
Exit Function
End If
If NowSSSubItem = True and action="" Then
If UBound(SubType) = 0 Then Exit Function
If SubType(1) = 1 Then
Response.Redirect "?SS_ID=" & SubID(1) '第一个子项目为页面，转向第一个项目
Exit Function
End If
End If
If NowSSSubItem And (NowSSType = 2 Or NowSSType = 3) Then '当前项目有子项目，且为文字或图片分类，显示分类名称
For i = 1 To SubNum
If SubType(i) = 2 Or SubType(i) = 3 Then '列出项目名称
Str = Str & "
"
If SubItem0(i) = True And SubDocVis = 0 and ThisSiteID =0 Then '分类包含子项目，列出子项目名称
Set pclass = Application(G_CACHENAME & "_PortalClass").DocumentElement.SelectNodes("k[@w2="& SubID(i) &"]")
If pclass.Length>0 Then
For Each subclass In pclass
SS_ID = subclass.SelectSingleNode("@w0").text
SS_HtmlUrl = subclass.SelectSingleNode("@w10").text
SS_URL = subclass.SelectSingleNode("@w8").text
SS_LinkURL = subclass.SelectSingleNode("@w9").text
SS_Type = subclass.SelectSingleNode("@w5").text
SS_Name = subclass.SelectSingleNode("@w6").text
SS_SubItem = subclass.SelectSingleNode("@w7").text
If WebStyle = 1 Then SS_HtmlUrl = SS_URL & "?SS_ID=" & SS_ID
'If k Mod 8 = 1 Then Str = Str & "
"
if SS_LinkURL<>"" then
Str = Str & ""&SS_Name&""
else
If (SS_Type < 4 Or SS_Type = 95) And WebStyle = 2 Then
Str = Str & ""&SS_Name&""
Else
Str = Str & ""&SS_Name&""
End If
end if
Next
End If
Else '子项目中不再包含子项目，则列出指定篇数的最近更新文章列表
If SubType(i) = 2 Then '列出项目名称
sql = "select top "&NumRow&" d_ID,d_Title,d_IsHot,d_TitleColor,d_Date,d_HtmlUrl,d_RedirectLink,d_Htmlpath,SS_SiteID from doccontents"
If SubDocVis = 1 Then
sql = sql & " where SS_ID in ("&CSCfg(SubID(i))&")"
Else
sql = sql & " where SS_ID="&SubID(i)&""
End If
sql = sql&" and d_Type=2 and d_IsDel=0 and d_CheckIn=1"
sql = sql&" order by d_TopLock desc,d_No desc,d_Date desc"
Set rs = LS.CreateRs(sql, 1, 1)
rscount = rs.recordcount
Str = Str & "
"
For k = 1 To rscount
tNumWords = NumWords
d_ID = rs("d_ID")
d_Title = rs("d_Title")
d_Date = rs("d_Date")
d_IsHot = rs("d_IsHot")
d_HtmlUrl = rs("d_HtmlUrl")
d_RedirectLink = rs("d_RedirectLink")
d_HtmlPath = rs("d_HtmlPath")
p_SiteID = RS("SS_SiteID")
d_TitleColor = rs("d_TitleColor")
If IsNull(d_RedirectLink) = False And d_RedirectLink<>"" Then
DocURL = d_RedirectLink
Else
DocURL = DocHtmlDir & p_SiteID &"/" & d_HtmlPath & d_HtmlUrl & STATICEXT
End If
Str = Str & "
"
rs.Close
Set rs = Nothing
End If
end if
If SubType(i) = 3 Then '列出项目名称
sql = "select top "&imgNums&" d_ID,d_Title,d_IsHot,d_TitleColor,d_Date,d_HtmlUrl,d_RedirectLink,d_Htmlpath,SS_SiteID,d_LinkImage from doccontents"
If SubDocVis = 1 Then
sql = sql & " where SS_ID in ("&CSCfg(SubID(i))&")"
Else
sql = sql & " where SS_ID="&SubID(i)&""
End If
sql = sql&" and d_Type=3 and d_IsDel=0 and d_CheckIn=1"
sql = sql&" order by d_TopLock desc,d_No desc,d_Date desc"
Set rs = LS.CreateRs(sql, 1, 1)
rscount = rs.recordcount
If rscount > 0 Then
Str = Str & "
"
For k = 1 To rscount
d_ID = rs("d_ID")
d_Title = rs("d_Title")
d_Title1 = rs("d_Title")
d_LinkImage = rs("d_LinkImage")
d_TitleColor = rs("d_TitleColor")
d_HtmlUrl = rs("d_HtmlUrl")
d_HtmlPath = rs("d_HtmlPath")
d_RedirectLink = rs("d_RedirectLink")
p_SiteID = rs("SS_Siteid")
If IsNull(d_RedirectLink) = False And d_RedirectLink<>"" Then
DocURL = d_RedirectLink
Else
DocURL = DocHtmlDir & p_SiteID &"/" & d_HtmlPath & d_HtmlUrl & STATICEXT
End If
If imgNumWords > 0 Then d_Title = CutStr(d_Title, imgNumWords )
If d_TitleColor <> "" Then d_Title = ""&d_Title&""
Str = Str & "
"
rs.movenext
Next
rs.Close
Set rs = Nothing
Str = Str & "
"
Else
rs.Close
Set rs = Nothing
Str = Str & "正在更新中..."
End If
End If
End If
Next
If G_FLAGHTMLTYPE = 1 Then
response.Write(Str)
Else
DocList_tpl = Str
End If
End If
If Not NowSSSubItem And (CInt(NowSSType) = 2 Or CInt(NowSSType) = 3) Then '当前项目下无子项目。显示文字列表
sql = " SS_ID="&NowSSID&" and d_Type=2 and d_IsDel=0 and d_CheckIn=1"
'默认分页样式名称 pagination
With LS.DB
.PageSize = CInt(PerNumRow)'定义页数
.ListLong = 3'页数前后显示个数
.Pkey = "d_ID"'主键
.Field = "d_ID,d_Title,d_Date,d_Hit,d_TitleColor,d_IsHot,d_HtmlUrl,d_RedirectLink,d_Htmlpath,SS_SiteID"'字段，不带用where
.OrderBy = "d_TopLock desc,d_No desc,d_Date desc"'排序,不用带order by
.RecordCount = 0'默认0即可，且当前项目为图片或文字分类，尽量不要用*号
.Table = "doccontents"'表名
.Condition = sql '条件语句。
Set oRs = .ResultSet
.Template = "
"
strPage = .PageNav()'分页列表
End With
If oRs.EOF Then
oRs.Close
response.Write "正在更新中..."
Exit Function
End If
gourl="/tmp/"&NowSSURL&"?SS_ID="&nowSSID&"&pp="
If Not oRs.EOF Then
Str = Str & ""&Chr(13)&Chr(10)
End If
If Not IsNull(oRs) Then
Str = Str & "
"
Do While Not oRs.EOF
tNumWords = NumWords
d_ID = oRs("d_ID")
d_Title = oRs("d_Title")
d_Date = oRs("d_Date")
d_Hit = oRs("d_Hit")
d_IsHot = oRs("d_IsHot")
d_HtmlUrl = oRs("d_HtmlUrl")
d_HtmlPath = oRs("d_HtmlPath")
d_RedirectLink = oRs("d_RedirectLink")
p_SiteID = oRs("SS_SiteID")
d_TitleColor = oRs("d_TitleColor")
If IsNull(d_RedirectLink) = False And d_RedirectLink<>"" Then
DocURL = d_RedirectLink
Else
DocURL = DocHtmlDir & p_SiteID &"/"& d_HtmlPath & d_HtmlUrl&STATICEXT
End If
Str = Str & "
"
if LS.DB.recordcount > PerNumRow then
Str = Str & strPage&""
end if
Str = Str & "
"
End If
oRs.Close
Set oRs = Nothing
End If
If G_FLAGHTMLTYPE = 1 Then
response.Write(Str)
Else
DocList_tpl = Str
End If
End Function
'======================================================================================================================
'栏目页图片文章列表 (NumTr：列数,NumCol：行数,ImgWid：图片宽度,ImgHig：图片高度,TitleVis：是否显示标题,NumWords：标题字数)
'======================================================================================================================
Function ImageList(NumTr, NumCol, ImgWid, ImgHig, TitleVis, NumWords,OrderType)
Str = ""
If NowSSIS = False Then Exit Function
If NowSSType = 1 Then '当前项目为页面
response.Write SortDoc()
Exit Function
End If
If NowSSSubItem = True Then '第一个子项目为页面，转向第一个项目
If UBound(SubType) = 0 Then Exit Function
If SubType(1) = 1 Then
Response.Redirect "?SS_ID=" & SubID(1)
Exit Function
End If
End If
If IsNumeric(NumTr) = False Then Exit Function
If NowSSSubItem And NowSSType = 3 Then '当前项目有子项目，且为文字或图片分类，逐行显示子项图片列表
For i = 1 To SubNum
If SubType(i) = 3 Then '列出项目名称
Str = Str & "
"
sql = "select top "&NumCol&" d_ID,d_Title,d_LinkImage,d_TitleColor,d_HtmlUrl,d_HtmlPath,SS_Siteid,d_RedirectLink from doccontents where d_IsDel=0 and d_LinkImage<>'' and d_CheckIn<>0"
' sql = sql& " and SS_Path like '"&SubPath(i)&"%'"
sql = sql & " and SS_ID in ("&CSCfg(SubID(i))&")"
Select Case OrderType
Case 0
sql = sql & " order by d_TopLock DESC,d_No DESC,d_Date DESC"
Case 1
sql = sql & " order by d_TopLock desc,d_Date DESC,d_No DESC"
Case 2
sql = sql & " order by d_Date DESC,d_No DESC"
Case 3
sql = sql & " order by d_Hit DESC,d_Date DESC"
End Select
Set rs = LS.CreateRs(sql, 1, 1)
rscount = rs.recordcount
If rscount > NumCol Then rscount = NumCol
If rscount > 0 Then
Str = Str & "
"
For k = 1 To rscount
d_ID = rs("d_ID")
d_Title = rs("d_Title")
d_Title1 = rs("d_Title")
d_LinkImage = rs("d_LinkImage")
d_TitleColor = rs("d_TitleColor")
d_HtmlUrl = rs("d_HtmlUrl")
d_HtmlPath = rs("d_HtmlPath")
d_RedirectLink = rs("d_RedirectLink")
p_SiteID = rs("SS_Siteid")
If IsNull(d_RedirectLink) = False And d_RedirectLink<>"" Then
DocURL = d_RedirectLink
Else
DocURL = DocHtmlDir & p_SiteID &"/" & d_HtmlPath & d_HtmlUrl & STATICEXT
End If
If NumWords > 0 Then d_Title = CutStr(d_Title, NumWords )
If d_TitleColor <> "" Then d_Title = ""&d_Title&""
Str = Str & "
"
rs.movenext
Next
rs.Close
Set rs = Nothing
Str = Str & "
"
Else
rs.Close
Set rs = Nothing
Str = Str & "正在更新中..."
End If
End If
Next
If G_FLAGHTMLTYPE = 1 Then
response.Write(Str)
Else
ImageList = Str
End If
End If
If Not NowSSSubItem And NowSSType = 3 Then '当前项目有子项目，不带用where
.OrderBy = sqlorder
.RecordCount = 0'默认0即可，显示分类名称
Select Case OrderType
Case 0
sqlorder = " d_TopLock DESC,d_No DESC,d_Date DESC"
Case 1
sqlorder = " d_TopLock desc,d_Date DESC,d_No DESC"
Case 2
sqlorder = " d_Date DESC,d_No DESC"
Case 3
sqlorder = " d_Hit DESC,d_Date DESC"
End Select
sql = " d_IsDel=0 and d_LinkImage<>'' and d_CheckIn=1 and SS_ID="&NowSSID
'默认分页样式名称 pagination
With LS.DB
.PageSize = CInt(NumTr * NumCol)'定义页数
.ListLong = 3'页数前后显示个数
.Pkey = "d_ID"'主键
.Field = "d_ID,d_Title,d_Date,d_Hit,d_HtmlUrl,d_HtmlPath,SS_Siteid,d_RedirectLink,d_LinkImage,d_Titlecolor"'字段，尽量不要用*号
.Table = "doccontents"'表名
.Condition = sql '条件语句，且为文字或图片分类。
Set oRs = .ResultSet
.Template = "
"
strPage = .PageNav()'分页列表
End With
If oRs.EOF Then
oRs.Close
response.Write "正在更新中..."
Exit Function
End If
gourl="/tmp/"&NowSSURL&"?SS_ID="&nowSSID&"&pp="
If Not oRs.EOF Then
Str = Str & ""&Chr(13)&Chr(10)
End If
Str = Str & "
"
If Not IsNull(oRs) Then
Do While Not oRs.EOF
d_ID = oRs("d_ID")
d_Title = oRs("d_Title")
d_Title1 = oRs("d_Title")
d_Titlecolor = oRs("d_Titlecolor")
d_LinkImage = oRs("d_LinkImage")
d_HtmlUrl = oRs("d_HtmlUrl")
d_RedirectLink = oRs("d_RedirectLink")
d_HtmlPath = oRs("d_HtmlPath")
p_SiteID = oRs("SS_Siteid")
If IsNull(d_RedirectLink) = False And d_RedirectLink<>"" Then
DocURL = d_RedirectLink
Else
DocURL = DocHtmlDir & p_SiteID &"/" & d_HtmlPath & d_HtmlUrl & STATICEXT
End If
If NumWords > 0 Then d_Title = CutStr(d_Title, NumWords )
If d_TitleColor <> "" Then d_Title = ""&d_Title&""
Str = Str & "
"
pagect = oRs.pagecount
if LS.DB.recordcount > cint(NumTr * NumCol) then
Str = Str & "
"
Str = Str & strPage&""
Str = Str & "
"
end if
oRs.Close
Set oRs = Nothing
End If
If G_FLAGHTMLTYPE = 1 Then
response.Write(Str)
Else
ImageList = Str
End If
End Function
%>
<%
'===============================================================================================================================================
'首页留言列表（SS_ID:栏目ID,MType:留言类型,ISrevert:是否显示未回复和已回复,TopNum:显示条数,titleNum:显示字数,RevertVis:是否显示回复状态,DateVis:是否显示时间）
'===============================================================================================================================================
Public Function IndexMessagelist(SS_ID, MType, ISrevert, TopNum, titleNum, RevertVis, DateVis)
If SS_ID = "" Or IsNumeric(SS_ID) = False Or TopNum = "" Or IsNumeric(TopNum) = False Then Exit Function
Dim v_CacheName : v_CacheName = G_CACHENAME & "_IndexMessagelist_" & SS_ID
Str = ""
If Not IsEmpty(Application(v_CacheName)) And G_ALLCACHE Then
Str = Application(v_CacheName)
Else
sql = "SELECT top "&TopNum&" b.UI_Name as ReceiveUnits, a.m_ID,a.ss_id,a.m_QueryPasswd,a.m_UnitID,a.m_LeaderID,a.m_Name,a.m_Subject,a.m_Tel,a.m_Contents,a.m_Date,a.m_HtmlUrl,a.m_numbers"
sql = sql & ",a.m_Revert,a.m_RevertIS,a.m_RevertDate,a.m_type,a.m_OpenIs,a.m_RevertDate,a.m_Revert"
sql = sql & " FROM (messagelist as a LEFT JOIN UnitsInfo as b ON a.m_UnitID=b.UI_ID) "
sql = sql & " Where m_ShowIs<>0 and m_isdel=0"
If ss_id<>"" Then
sql = sql &" and a.ss_id="&ss_id
End If
If MType<>"" Then
sql = sql & " and a.m_type="&MType
End If
if ISrevert<>"" then
If ISrevert = 1 Then
sql = sql & " and a.m_RevertIS=1"
Else
sql = sql & " and a.m_RevertIS=0"
End If
end if
sql = sql & " order by a.m_ID desc"
Set rs = Ls.CreateRs(sql, 1, 1)
rscount = rs.RecordCount
For i = 1 To rscount
m_ID = rs("m_ID")
Nowssid = rs("ss_id")
m_numbers = rs("m_numbers")
m_QueryPasswd = rs("m_QueryPasswd")
m_UI_ID = rs("m_UnitID")
m_LeaderID = rs("m_LeaderID")
m_Name = rs("m_Name")
m_Subject = rs("m_Subject")
m_Tel = rs("m_Tel")
m_Contents = rs("m_Contents")
m_Date = Ls.datetime(rs("m_Date"),"yyyy-mm-dd")
m_HtmlUrl = rs("m_HtmlUrl")
m_Revert = rs("m_Revert")
m_RevertIS = rs("m_RevertIS")
m_RevertDate = rs("m_RevertDate")
m_type = rs("m_type")
m_OpenIs = rs("m_OpenIs")
ReceiveUnits = rs("ReceiveUnits")
m_RevertDate = rs("m_RevertDate")
m_Revert = rs("m_Revert")
If m_RevertIS = 0 Then
RevertIStr = "未回复"
ElseIf m_RevertIS = 1 Then
RevertIStr = "已回复"
End If
'读取领导姓名
sqla = "select LW_Name from LeaderWindow where LW_ID=" & m_LeaderID
Set rsa = LS.CreateRs(sqla, 1, 1)
If Not rsa.EOF Then
LW_Name = rsa("LW_Name")
End If
rsa.Close
Set rsa = Nothing
ul_even = ""
If i mod 2=0 Then ul_even = "even"
Str = Str & "
"
Str = Str & "
"&m_numbers&"
"
if titleNum>0 then m_Subject = CutStr(m_Subject, titleNum*2)
Str = Str & "
"
rs.movenext
Next
rs.Close
Set rs = Nothing
If G_ALLCACHE Then
Application.Lock
Application(v_CacheName) = Str
Application.UnLock
End If
end if
If G_FLAGHTMLTYPE = 1 Then
response.Write(Str)
Else
IndexMessagelist = Str
End If
End Function
' ======================================================================================================================
' 首页政民互动表格列表(SS_ID:栏目ID,MType:分类ID,TopNum:显示条数,ISrevert:调用已回复或未回复,titleNum:标题字数,TypeVis:是否显示类型,RevertVis:是否显示回复状态,BuVis:是否显示部门)
' ======================================================================================================================
Public Function IndexMessageInfolist(SS_ID, MType, ISrevert, TopNum, titleNum, TypeVis, RevertVis, BuVis,DateVis)
If TopNum = "" Or IsNumeric(TopNum) = False Then Exit Function
Dim v_CacheName : v_CacheName = G_CACHENAME & "_IndexMessageInfolist_" & SS_ID
Str = ""
If Not IsEmpty(Application(v_CacheName)) And G_ALLCACHE Then
Str = Application(v_CacheName)
Else
sql = "SELECT top "&TopNum&" b.UI_Name as ReceiveUnits, a.m_ID,a.ss_id,a.m_QueryPasswd,a.m_UnitID,a.m_LeaderID,a.m_Name,a.m_Subject,a.m_Tel,a.m_Contents,a.m_Date,a.m_HtmlUrl"
sql = sql & ",a.m_Revert,a.m_RevertIS,a.m_RevertDate,a.m_type,a.m_OpenIs,a.m_RevertDate,a.m_Revert"
sql = sql & " FROM (messagelist as a LEFT JOIN UnitsInfo as b ON a.m_UnitID=b.UI_ID) "
sql = sql & " Where m_ShowIs<>0 and m_isdel=0"
If ss_id<>"" Then
sql = sql &" and a.ss_id="&ss_id
End If
If MType<>"" Then
sql = sql & " and a.m_type="&MType
End If
if ISrevert<>"" then
If ISrevert = 1 Then
sql = sql & " and a.m_RevertIS=1"
Else
sql = sql & " and a.m_RevertIS=0"
End If
end if
sql = sql & " order by a.m_ID desc"
Set rs = Ls.CreateRs(sql, 1, 1)
rscount = rs.RecordCount
For i = 1 To rscount
m_ID = rs("m_ID")
Nowssid = rs("ss_id")
m_QueryPasswd = rs("m_QueryPasswd")
m_UI_ID = rs("m_UnitID")
m_LeaderID = rs("m_LeaderID")
m_Name = rs("m_Name")
m_Subject = rs("m_Subject")
m_Tel = rs("m_Tel")
m_Contents = rs("m_Contents")
m_Date = Ls.datetime(rs("m_Date"),"yyyy-mm-dd")
m_HtmlUrl = rs("m_HtmlUrl")
m_Revert = rs("m_Revert")
m_RevertIS = rs("m_RevertIS")
m_RevertDate = rs("m_RevertDate")
m_type = rs("m_type")
m_OpenIs = rs("m_OpenIs")
ReceiveUnits = rs("ReceiveUnits")
m_RevertDate = rs("m_RevertDate")
m_Revert = rs("m_Revert")
If m_RevertIS = 0 Then
RevertIStr = "未回复"
ElseIf m_RevertIS = 1 Then
RevertIStr = "已回复"
End If
If m_type = 1 Then
mtypestr = "咨询"
ElseIf m_type = 2 Then
mtypestr = "投拆"
ElseIf m_type = 3 Then
mtypestr = "建议"
ElseIf m_type = 4 Then
mtypestr = "举报"
Else
mtypestr = "其它"
End If
'读取领导姓名
sqla = "select LW_Name from LeaderWindow where LW_ID=" & m_LeaderID
Set rsa = LS.CreateRs(sqla, 1, 1)
If Not rsa.EOF Then
LW_Name = rsa("LW_Name")
End If
rsa.Close
Set rsa = Nothing
Str = Str & "
"
if titleNum>0 then m_Subject = CutStr(m_Subject, titleNum*2)
if TypeVis=1 then
Str = Str & "
"
rs.movenext
Next
rs.Close
Set rs = Nothing
If G_ALLCACHE Then
Application.Lock
Application(v_CacheName) = Str
Application.UnLock
End If
end if
If G_FLAGHTMLTYPE = 1 Then
response.Write(Str)
Else
IndexMessageInfolist = Str
End If
End Function
' ======================================================================================================================
' 首页领导留言列表(SS_ID:栏目ID,Ldid:领导ID,TopNum:显示条数,ISrevert:调用已回复或未回复,titleNum:标题字数)
' ======================================================================================================================
Public Function IndexLdMessage(SS_ID, Ldid, ISrevert, TopNum, titleNum,DateVis)
If SS_ID = "" Or IsNumeric(SS_ID) = False Or TopNum = "" Or IsNumeric(TopNum) = False Then Exit Function
sql = "SELECT top "&TopNum&" m_Subject,m_Date,m_HtmlUrl FROM messagelist Where m_ShowIs<>0 and m_isdel=0 and ss_id="&ss_id
If Ldid<>"" and isnumeric(Ldid) Then
sql = sql & " and m_leaderid="&Ldid
End If
If ISrevert = 1 Then
sql = sql & " and m_RevertIS<>0"
Else
sql = sql & " and m_RevertIS=0"
End If
sql = sql & " order by m_date desc"
Set rs = Ls.CreateRs(sql, 1, 1)
rscount = rs.RecordCount
For i = 1 To rscount
m_Subject = rs("m_Subject")
m_Date = Ls.datetime(rs("m_Date"),"yyyy-mm-dd")
m_HtmlUrl = rs("m_HtmlUrl")
Str = Str & "
"
if titleNum>0 then m_Subject = CutStr(m_Subject, titleNum*2)
Str = Str & ""&m_Subject&""
if DateVis=1 then
Str = Str & ""&m_Date&""
end if
Str = Str & "
"
rs.movenext
Next
rs.Close
Set rs = Nothing
If G_FLAGHTMLTYPE = 1 Then
response.Write(Str)
Else
IndexLdMessage = Str
End If
End Function
'======================================================================================================================
' 栏目页留言列表(PerNumRow:显示条数,ShowIS:显示提示信息)
'======================================================================================================================
Function GuestBook(PerNumRow, Numwords, ShowIS, CommentSSID)
Str = ""
If NowSSIS = False Then Exit Function
Set rs = LS.CreateConn().Execute("SELECT IsUnit,IsLeader FROM SiteStructure WHERE SS_ID = "&NowSSID&"")
If Not rs.EOF Then
IsUnit = rs("IsUnit")
IsLeader = rs("IsLeader")
End If
rs.Close
Set rs = Nothing
action = GetSafeStr(Request("action"))
actionx = GetSafeStr(Request("actionx"))
'通过ID和密码查询留言
If actionx = "find" Then
m_ID = GetSafeStr(Request.Form("m_ID"))
m_QueryPasswd = GetSafeStr(Request.Form("m_QueryPasswd"))
if m_ID="" or isnumeric(m_ID)=false then response.End()
sql = "select b.UI_Name as ReceiveUnits,a.m_Name,a.m_Subject,a.m_Contents,a.m_Date,a.m_Revert,a.m_RevertDate,a.m_RemoteIp,a.m_RevertIS from (messagelist as a LEFT JOIN UnitsInfo as b ON a.m_UnitID=b.UI_ID) where a.m_isdel=0 and a.m_ID=" & m_ID & " and a.m_QueryPasswd='"&m_QueryPasswd&"'"
Set rs = LS.CreateRs(sql, 1, 1)
If rs.EOF Then
rs.Close
Call OutScript("查询编号或密码不正确！")
Exit Function
End If
m_RevertIS = rs("m_RevertIS")
If m_RevertIS = False Then
rs.Close
Call OutScript("您的留言正在处理中，请稍候查询！")
Exit Function
End If
m_Name = rs("m_Name")
m_Subject = rs("m_Subject")
m_Contents = rs("m_Contents")
m_Date = rs("m_Date")
m_Revert = rs("m_Revert")
m_RevertDate = rs("m_RevertDate")
m_RevertBranch = rs("ReceiveUnits")
m_RemoteIp = rs("m_RemoteIp")
rs.Close
Set rs = Nothing
%>
发件人：
<%= m_Name%>
发送时间：
<%= m_Date & " " & m_Time%>
主题：
<%= m_Subject%>
留言内容：
<%= m_Contents%>
回复部门：
<%= m_RevertBranch%>
回复时间：
<%= m_RevertDate & " " & m_RevertTime%>
回复内容：
<%= m_Revert%>
<%
Exit Function
End If
'显示查询表单
If action = "query" Then
%>
<%
Exit Function
End If
' If action = "show" or action = "search" Then
SearchStr = GetSafeStr(Request.QueryString("SearchStr"))
BS_ID = GetSafeStr(Request.QueryString("BS"))
UI_ID = GetSafeStr(Request.QueryString("UI_ID"))
stype = getsafestr(request("type"))
if stype <> "" and isnumeric(stype) = false then response.End()
sql = " m_ShowIs<>0 and m_isdel=0 and SS_ID=" & NowSSID
if stype <> "" then sql = sql & " and m_type = "& stype
if BS_ID<>"" then sql = sql & " and m_bsid="&BS_ID
if UI_ID<>"" and isnumeric(UI_ID) and isnull(UI_ID)=false then sql = sql & " and m_UnitID="&UI_ID
If SearchStr <> "" Then sql = sql & " and (m_Contents like '%" & SearchStr & "%' or m_Subject like '%" & SearchStr & "%')"
With LS.DB
.PageSize = cint(PerNumRow)'定义页数
.ListLong = 3'页数前后显示个数
.Pkey = "m_ID"'主键
.Field = "m_ID,m_UnitID,m_type,m_Name,m_Subject,m_Tel,m_Contents,m_Date,m_HtmlUrl,m_RevertIS,m_RevertDate"'字段、尽量不要用*号
.Table = "messagelist"'表名
.Condition = sql '条件语句，不带用where
.OrderBy = "m_ID desc"'排序,不用带order by
.RecordCount = 0'默认0即可。
Set oRs = .ResultSet
strPage = .PageNav()'分页列表
End With
%>
主题
留言人
留言时间
回复状态
<%
UI_Name = ""
If Not oRs.bof Then
Do While Not oRs.EOF
m_ID = oRs("m_ID")
m_UI_ID = oRs("m_UnitID")
m_type = oRs("m_type")
m_Name = oRs("m_Name")
m_Name1 = oRs("m_Name")
m_Subject = oRs("m_Subject")
m_Subject1 = oRs("m_Subject")
m_Tel = oRs("m_Tel")
m_Contents = oRs("m_Contents")
m_Dates = oRs("m_Date")
m_HtmlUrl = oRs("m_HtmlUrl")
m_RevertIS = oRs("m_RevertIS")
m_Date = Year(m_Dates)&"-"&Month(m_Dates)&"-"&day(m_Dates)
If m_RevertIS <>0 Then
m_RevertIS = "【已回复】"
Else
m_RevertIS = "【未回复】"
End If
If Len(m_Name)>10 Then
m_Name = Left(m_Name, 10)&"..."
Else
m_Name = m_Name
End If
Select Case m_type
Case 1
m_type = "我要咨询"
Case 2
m_type = "我要投诉"
Case 3
m_type = "我要建议"
Case 4
m_type = "我要举报"
Case 5
m_type = "其他"
End Select
if Numwords<>"" and isnumeric(Numwords) then
m_Subject = cutstr(m_Subject,Numwords)
end if
%>
<%
End Function
'=====================================
'首页部门回复排行
'=====================================
Function Indexinfoph(NumTr,SS_Siteid,SS_ID)
If NumTr = "" Or IsNumeric(NumTr) = False or SS_Siteid="" or isnumeric(SS_Siteid)=false Then Exit Function
strWhere = strWhere & " AND m_IsDel=0 and m_RevertIS=1 AND SS_SiteID="& SS_Siteid & ""
If SS_ID<>"" and isnumeric(SS_ID) Then strWhere = strWhere & " AND SS_ID = " & SS_ID
strSelect = "SELECT top "&NumTr&" ISNULL(TotalCount,0) as TotalCount,a.UI_ID,a.UI_Name,a.PUI_ID FROM UnitsInfo a "
strSelect = strSelect &" LEFT JOIN "
strSelect = strSelect &"(select count(m_ID) as TotalCount,m_UnitID from MessageList where 1=1 "& strWhere &" group by m_UnitID) d on a.UI_ID = d.m_unitid "
strSelect = strSelect &" LEFT JOIN "
strSelect = strSelect &" (SELECT TOP 1 UI_ID,UI_Name FROM UnitsInfo) AS e ON e.UI_ID = a.UI_ID"
strSelect = strSelect &" where a.UI_ID>0 order by TotalCount desc,a.UI_ID"
Set Rs = Ls.CreateRs(strSelect,1,1)
rscount = Rs.recordcount
For i = 1 to rscount
pathstr = ""
UI_ID = Rs("UI_ID")
UI_Name = Rs("UI_Name")
TotalCount = Rs("TotalCount")
ArUI_Path = Split(UI_Path,"-")
For x = 1 to UBound(ArUI_Path)-1
pathstr = pathstr & "├"
Next
If UBound(ArUI_Path) = 1 Then
UI_Name = UI_Name
Else
UI_Name = pathstr & UI_Name
End If
str = str &"
"
str = str &"
"
str = str &"
"&UI_NAME&"
"
str = str &"
"&TotalCount&"
"
str = str &"
"
Rs.movenext
Next
Rs.close
Set Rs = nothing
If G_FLAGHTMLTYPE = 1 Then
response.Write(Str)
Else
Indexinfoph = Str
End If
End Function
'=====================================
'首页满意度排行
'=====================================
Function Indexinfomy(NumTr,SS_Siteid,SS_ID)
If NumTr = "" Or IsNumeric(NumTr) = False or SS_Siteid="" or isnumeric(SS_Siteid)=false Then Exit Function
sql = "select top "&NumTr&" m_Subject,m_HtmlUrl,m_Appraise from MessageList where m_Appraise<>''"
if ss_id<>"" then
sql = sql&" and ss_id="&ss_id
end if
sql = sql & " order by m_Appraise asc"
Set Rs = Ls.CreateRs(sql,1,1)
rscount = Rs.recordcount
For i = 1 to rscount
m_Subject = Rs("m_Subject")
m_HtmlUrl = Rs("m_HtmlUrl")
m_Appraise = Rs("m_Appraise")
select case m_Appraise
case 1
mstr="满意"
case 2
mstr="比较满意"
case 3
mstr="一般"
case 4
mstr="不满意"
case 5
mstr="很不满意"
end select
str = str &"
"
Rs.movenext
Next
Rs.close
Set Rs = nothing
If G_FLAGHTMLTYPE = 1 Then
response.Write(Str)
Else
Indexinfomy = Str
End If
End Function
%>
<%
' ======================================================================================================================
' 首页视频点播文字列表(SS_ID：栏目ID,SS_Path：栏目路径,NumRow：显示条数,NumWords：标题字数,DateVis：是否显示日期,HitVis：是否显示点击数)
' ======================================================================================================================
Public Function IndexVodList(SS_ID, SS_Path, NumRow, NumWords, DateVis,YearVis, HitVis)
If IsNumeric(NumRow) = False Then Exit Function
If SS_ID = "" And SS_Path = "" Then Exit Function
If ss_id = "" Or IsNumeric(SS_ID) = False Then Exit Function
Dim v_CacheName : v_CacheName = G_CACHENAME & "_IndexVodList_" & SS_ID
Str = ""
If Not IsEmpty(Application(v_CacheName)) And G_ALLCACHE Then
Str = Application(v_CacheName)
Else
sql = "select top "&NumRow&" SS_ID,VI_ID,VI_Name,VI_Date,VI_Hit,VI_Type,VI_Linkurl from VodInfo"
If SS_Path <> "" Then
sql = sql&" where VI_checkin=1 and SS_Path like '"&SS_Path&"%'"
Else
sql = sql& " where VI_checkin=1 and SS_ID="&SS_ID
End If
sql = sql&" order by VI_Vouch desc,VI_Date desc"
Set rs = LS.CreateRs(sql, 1, 1)
rscount = rs.recordcount
If rscount > NumRow Then rscount = NumRow
If rscount > 0 Then
Str = Str & "
"
VideoUrl = SI_Domain&"/tmp/"&SS_URL
if VI_Linkurl<>"" then
Str = Str & ""
else
Str = Str & ""
end if
If NumWords > 0 Then VI_Name = CutStr(VI_Name, NumWords )
Str = Str & VI_Name&""
If DateVis = 1 Or TimeVis = 1 Or HitVis = 1 Then
Str = Str & ""
If DateVis = 1 Then
If YearVis = 1 Then
Str = Str & ""&Ls.datetime(VI_Date, "yyyy-mm-dd")
Else
Str = Str & ""&Ls.datetime(VI_Date, "mm-dd")
End If
end if
'If DateVis = 1 Then Str = Str & " "&VI_Date
If HitVis = 1 Then Str = Str & " "&VI_Hit
Str = Str & ""
End If
Str = Str & "
"
rs.movenext
Next
rs.Close
Set rs = Nothing
Str = Str & "
"
Else
rs.Close
Set rs = Nothing
Str = "正在更新中..."
End If
If G_ALLCACHE Then
Application.Lock
Application(v_CacheName) = Str
Application.UnLock
End If
end if
If G_FLAGHTMLTYPE = 1 Then
Response.Write(Str)
Else
IndexVodList = Str
End If
End Function
' ======================================================================================================================
' 首页视频单个调用(SS_ID：栏目ID,SS_Path：栏目路径,VodID：视频ID,TitleNum：标题字数,DescNum：简介字数,V_Width：视频宽度,V_Height：视频高度,IsTitle：是否显示标题 (0--不显示视频标题；1--显示视频标题),IsDesc：是否显示视频简介 (0--不显示简介信息；1--显示简介信息),Pic_Vod：是显示图片还是播放视频(0--显示图片；1--播放视频))
' ======================================================================================================================
Function IndexVodShow(SS_ID, SS_Path, VodID, IsTitle, TitleNum, IsDesc, DescNum, V_Width, V_Height, Pic_Vod)
Str = ""
If SS_ID = "" And SS_Path = "" Then Exit Function
If V_Width = "" Or Not IsNumeric(V_Width) Then V_Width = 100
If V_Height = "" Or Not IsNumeric(V_Height) Then V_Height = 100
sql = "select top 1 VI_ID,VI_URL,VI_Name,VI_Intro,VI_Type,VI_SmallImage,SS_ID from VodInfo"
If SS_ID <> "" Then
sql = sql& " where VI_checkin=1 and SS_ID="&SS_ID
Else
sql = sql&" where VI_checkin=1 and SS_Path like '"&SS_Path&"%'"
End If
sql = sql&" order by VI_Vouch desc,VI_Date desc"
Set rs = LS.CreateRs(sql, 1, 1)
If Not rs.EOF Then
Vss_id = rs("SS_ID")
VI_ID = rs("VI_ID")
VI_URL = rs("VI_URL")
VI_Name = rs("VI_Name")
VI_Intro = rs("VI_Intro")
VI_Type = rs("VI_Type")
SS_URL = CCfg(Vss_id,8)
SI_Domain = CCfg(Vss_id,12)
VI_SmallImage = rs("VI_SmallImage")
If VI_SmallImage = "" Or IsNull(VI_SmallImage) Then
VI_SmallImage = "/tmp/jslib/images/video_logo.png"
End If
Str = Str & "
"
Str = Str & "
"
Select Case Pic_Vod
Case 0'显示图片
VideoUrl = SI_Domain&SS_URL
Str = Str & ""
Str = Str & ""
Str = Str & ""
Case 1'播放视频
if instr(VI_URL,".wmv") <> 0 then
Str = Str & "
"
Str = Str & ""
Str = Str & "
"
Else
Str = Str & ""
str = str & "
"
Str = Str & ""
End If
End Select
If IsTitle = 1 Then'显示标题
VI_Name = CutStr(VI_Name, TitleNum)
Str = Str & ""&VI_Name&""
End If
If IsDesc = 1 Then'显示简介
VI_Intro = CutStr(VI_Intro, DescNum)
Str = Str & ""&VI_Intro&""
End If
Str = Str & "
"
Str = Str & ""
End If
If G_FLAGHTMLTYPE = 1 Then
response.Write(Str)
Else
IndexVodShow = Str
End If
End Function
' ======================================================================================================================
' 首页视频点播图片列表(SS_ID：栏目ID,SS_Path：栏目路径,NumRow：显示条数,ImgWid：图片宽度,ImgHig：图片高度,IsTitle：是否显示标题,TitleNum：标题字数)
' ======================================================================================================================
Function IndexVodImgList(SS_ID, SS_Path, NumRow, ImgWid, ImgHig, IsTitle, TitleNum)
Str = ""
If IsNumeric(NumRow) = False Then Exit Function
If SS_ID = "" And SS_Path = "" Then Exit Function
sql = "select top "&NumRow&" VI_ID,VI_URL,VI_Name"
sql = sql&",VI_Intro,VI_Type,VI_SmallImage,SS_ID from VodInfo where VI_SmallImage<>''"
If SS_ID <> "" Then
sql = sql& " and VI_checkin=1 and SS_ID="&SS_ID
Else
sql = sql&" and VI_checkin=1 and SS_Path like '"&SS_Path&"%'"
End If
sql = sql&" order by VI_Vouch desc,VI_Date desc"
Set rs = LS.CreateRs(sql, 1, 1)
rscount = rs.recordcount
If rscount > NumRow Then rscount = NumRow
If rscount > 0 Then
Str = Str & "
"
For i = 1 To rscount
SS_ID = rs("SS_ID")
VI_ID = rs("VI_ID")
VI_Name = rs("VI_Name")
VI_Type = rs("VI_Type")
VI_SmallImage = rs("VI_SmallImage")
If VI_SmallImage = "" Or IsNull(VI_SmallImage) = True Then VI_SmallImage = "/tmp/jslib/images/video_logo.png"
Vss_id = rs("ss_id")
SS_URL = CCfg(Vss_id,8)
SI_Domain = CCfg(Vss_id,12)
Str = Str & "
"
VideoUrl = SI_Domain&"/tmp/"&SS_URL
Str = Str & ""
Str = Str & ""
If IsTitle Then
If TitleNum > 0 Then VI_Name = CutStr(VI_Name, TitleNum * 2)
Str = Str & "
"&VI_Name&"
"
End If
Str = Str & "
"
rs.movenext
Next
rs.Close
Set rs = Nothing
Str = Str & "
"
Else
rs.Close
Set rs = Nothing
Response.Write "正在更新中..."
End If
If G_FLAGHTMLTYPE = 1 Then
response.Write(Str)
Else
IndexVodImgList = Str
End If
End Function
' ======================================================================================================================
' 首页视频在线点播(SS_ID:栏目ID,SS_Path:栏目路径,IsPic:是否显示图片0显示视频 1显示图片，VideoUrl:显示视频的链接地址,VodWidth:宽度,VodHeight:高度,IsTitle:是否显示标题,TitleNum:标题字数)
' ======================================================================================================================
Function OnlinePlay()
Str = ""
SS_ID = GetSafeStr(request("SS_ID"))
VI_ID = GetSafeStr(request("VI_ID"))
If IsNumeric(SS_ID) = False Then Exit Function
If IsNumeric(VI_ID) = False Then Exit Function
sql = "select VI_ID,VI_Name,VI_SmallImage,VI_Type,VI_URL,VI_Intro,VI_Hit from VodInfo where VI_ID="&VI_ID
Set rs = LS.CreateRs(sql, 1, 3)
If Not rs.EOF Then
VI_ID = rs("VI_ID")
VI_Name = rs("VI_Name")
VI_SmallImage = rs("VI_SmallImage")
VI_Type = rs("VI_Type")
VI_URL = rs("VI_URL")
VI_Intro = rs("VI_Intro")
VI_Hit = rs("VI_Hit")
rs("VI_Hit") = VI_Hit + 1
If VI_SmallImage="" Then VI_SmallImage="/tmp/jslib/images/video_logo.png"
rs.update
Str = Str & "
"&VI_Name&"
"
If Application("VodMemIS") = 1 Then
If Session("m_ID") = "" Then
Str = Str & "登录无效！请先登录。
如果您不是本站会员，请先注册。"
Response.End()
End If
End If
if instr(VI_URL,".wmv") <> 0 then
Str = Str & "
"
Str = Str & ""
Str = Str & "
"
Else
Str = Str & ""
str = str & "
"
Str = Str & ""
End If
Str = Str & "
"&VI_Intro&"
"
Else
response.Write "正在更新中"
End If
rs.Close
Set rs = Nothing
If G_FLAGHTMLTYPE = 1 Then
response.Write(Str)
Else
OnlinePlay = Str
End If
End Function
' ======================================================================================================================
' 视频窗口点播排行
' ======================================================================================================================
Function VodHitList(SS_ID, SS_Path, NumRow, NumWords, DateVis, HitVis)
Str = ""
NumTr = NumRow
If IsNumeric(NumTr) = False Then Exit Function
If SS_ID = "" And SS_Path = "" Then Exit Function
sql = "select top "&NumTr&" VI_ID,VI_Name,VI_Date,VI_Hit from VodInfo where VI_checkin=1 AND VI_IsDel=0"
If SS_ID <> "" Then
sql = sql & " and SS_ID="&SS_ID
Else
sql = sql & " and SS_Path like '"&SS_Path&"%'"
End If
sql = sql&" order by VI_Hit desc"
Set rs = LS.CreateRs(sql, 1, 1)
rscount = rs.recordcount
If rscount > NumRow Then rscount = NumRow
If rscount > 0 Then
Str = Str & "
>"
For i = 1 To rscount
SS_ID = rs("SS_ID")
VI_ID = rs("VI_ID")
VI_Name = rs("VI_Name")
VI_Date = ls.datetime(rs("VI_Date"),"yyyy-mm-dd")
VI_Hit = rs("VI_Hit")
Str = Str & "
"
Else
rs.Close
Response.Write "正在更新中..."
End If
If G_FLAGHTMLTYPE = 1 Then
response.Write(Str)
Else
VodHitList = Str
End If
End Function
'======================================================================================================================
' 栏目页视频点播列表(PerNumRow:显示条数,ImgWid:图片宽度,ImgHig:图片高度,MemberIS:是否绑定会员,MemberSSID:绑定会员栏目ID,TitleNumWords:标题数字,DesNumWords:描述数字)
'======================================================================================================================
Function VodLists(PerNumRow, ImgWid, ImgHig, MemberIS, MemberSSID, TitleNumWords, DesNumWords)
Str = ""
Application("VodMemIS") = MemberIS
' ------------------系统启用会员-------------------------
If MemberIS = 1 Then
Str = Str & "
"
End If
' ------------------验证Post-------------------------
action = GetSafeStr(Request.Form("action"))
If action = "logincheck" Then '验证会员登录
Call MemberLoginCheck(MemberSSID)
Exit Function
End If
If action = "registercheck" Then '验证会员注册
Call MemberRegisterCheck(MemberSSID)
Exit Function
End If
If action = "editcheck" Then '验证会员修改资料
Call MemberEditCheck(MemberSSID)
Exit Function
End If
If action = "findpasscheckuser" Then '验证密码查询
Call MemberFindPassCheckUser()
Exit Function
End If
If action = "findpasscheckanswer" Then '验证密码查询
Call MemberFindPassCheckAnswer()
Exit Function
End If
' ------------------验证Get-------------------------
action = GetSafeStr(Request.QueryString("action"))
If action = "login" Then '用户登录表单
%>
<%
Exit Function
End If
If action = "register" Then '用户注册表单
%>
<%If GetSafeStr(Request.QueryString("read")) <> "1" Then%>
<%Else%>
<%If Session("NoForm") = "" Then Session("NoForm") = 1%>
<%End If%>
<%
Exit Function
End If
If action = "View" Then '查看
response.Write OnlinePlay()
Exit Function
End If
If action = "edit" Then '用户修改资料表单
Call MemberEdit()
Exit Function
End If
If action = "findpass" Then '用户查询密码表单
Call MemberFindPass()
Exit Function
End If
If action = "logout" Then '用户安全退出
Session("m_ID") = ""
Session("m_Name") = ""
Session("m_ForumRights") = ""
Session("m_Level") = ""
Session("m_LoginNow") = ""
Response.Redirect NowSSURL&"?SS_ID="&NowSSID
End If
If NowSSSubItem = True Then
sql = " VI_checkin=1 and SS_Path like '"&NowSSPath&"%'"
Else
sql = " VI_checkin=1 and SS_ID="&NowSSID&""
End If
'默认分页样式名称 pagination
With LS.DB
.PageSize = cint(PerNumRow)'定义页数
.ListLong = 3'页数前后显示个数
.Pkey = "VI_ID"'主键
.Field = "VI_ID,VI_Name,VI_SmallImage,VI_Intro,VI_Hit,VI_Date,VI_URL,VI_Linkurl"'字段，不带用where
.OrderBy = "VI_Vouch desc,VI_checkin desc,VI_ID desc"'排序,不用带order by
.RecordCount = 0'默认0即可，尽量不要用*号
.Table = "VodInfo"'表名
.Condition = sql '条件语句。
pages= .RecordCount
Set oRs = .ResultSet
.Template = "
"
strPage = .PageNav()'分页列表
End With
If oRs.EOF Then
oRs.Close
response.Write "正在更新中..."
Exit Function
End If
gourl="/tmp/"&NowSSURL&"?SS_ID="&nowSSID&"&pp="
If Not oRs.EOF Then
Str = Str & ""&Chr(13)&Chr(10)
End If
Str = Str & "
"
If Not IsNull(oRs) Then
Do While Not oRs.EOF
VI_ID = oRs("VI_ID")
VI_Name = oRs("VI_Name")
NameFull = replace(VI_Name," ","")
VI_Name = CutStr(VI_Name, TitleNumWords )
VI_SmallImage = oRs("VI_SmallImage")
VI_Intro = oRs("VI_Intro")
VI_Linkurl = ors("VI_Linkurl")
if VI_Intro<>"" then
VI_Intro = Replace((Replace(VI_Intro, vbCrLf, " ")), Chr(32)&Chr(32), " ")
VI_Intro = CutStr(VI_Intro, DesNumWords )
end if
VI_Des = VI_Intro
VI_Hit = oRs("VI_Hit")
VI_Date = oRs("VI_Date")
VI_Date = Ls.datetime(VI_Date,"yyyy-mm-dd")
VI_URL = oRs("VI_URL")
If VI_SmallImage = "" Or IsNull(VI_SmallImage) = True Then VI_SmallImage = "/tmp/jslib/images/video_logo.png"
ItemIcon = "/System/static/skins/image/mediaicon.gif"
if instr(VI_URL,".wmv") <> 0 then ItemIcon = "/System/static/skins/image/mediaicon.gif"
if instr(VI_URL,".flv") <> 0 or instr(VI_URL,".mp3") <> 0 or VI_URL = "" Then ItemIcon = "/System/static/skins/image/flv.gif"
Str = Str & "
"
'视频图片显示
Str = Str & "
"
If MemberIS = 1 And Session("m_ID") = "" Then
Str = Str & ""
Else
if VI_Linkurl<>"" then
Str = Str & ""
else
Str = Str & ""
end if
Str = Str & ""
End If
Str = Str & "
"
If LS.DB.Recordcount>CInt(PerNumRow) Then '文章列表多于1页
Str = Str & "
"
Str = Str & strPage
Str = Str & "
"
End If
oRs.Close:Set oRs = Nothing
If G_FLAGHTMLTYPE = 1 Then
response.Write(Str)
Else
VodLists = Str
End If
End Function
%>
<%
Sub IndexSiteList(SS_ID,NumCol,TbWid,TdHig,IsCSS,CssName,CWid,CHig,CLineHig,CPadLeft,CMarTop,CMarRight,CTextAlign,NumWords,LinkUrl)
If IsCSS Then
%>
<%
End If
sql = "select * from SiteLink where SS_ID="&SS_ID&" order by SL_Date desc,SL_Time desc"
Set rs = LS.CreateRs(sql,1,1)
rscount = rs.recordcount
With Response
If rscount > 0 Then
.Write "
"
.Write "
"
.Write "
"
.Write "
"
For i = 1 to rscount
SL_ID = rs("SL_ID")
SL_Name = rs("SL_Name")
If NumWords <> "" Then SL_Name = CutStr(SL_Name,NumWords*2)
.write ""&SL_Name&""
If i mod NumCol > 0 and i < rscount Then .write " "
If i mod NumCol = 0 Then .write " "
rs.movenext
Next
.Write "
"
.Write "
"
.Write "
"
.Write "
"
End If
End With
rs.close
End Sub
'======================================================================================================================
' 站点链接列表
'======================================================================================================================
Sub SiteList(NumRow,NumCol,TbBgCor,TdBgCor,TbPad,LeftWidth,IntroVis,LinkManVis,TelVis,FaxVis,EmailVis,AddressVis,PostCodeVis)
If NowSSIS = False Then Exit Sub
NumTr = NumRow * NumCol
If IsNumeric(NumTr) = False Then Exit Sub
SL_ID = GetSafeStr(Request.QueryString("SL_ID"))
If SL_ID <> "" Then
sql = "select * from SiteLink where SL_ID=" & SL_ID
Set rs = LS.CreateRs(sql,1,1)
If not rs.eof Then
SL_Name = rs("SL_Name")
SL_Intro = rs("SL_Intro")
End If
rs.close
Response.write "
"&SL_Name&"
"
Response.write "
"&SL_Intro&"
"
Exit Sub
End If
If NowSSSubItem = True Then
sql = "select * from SiteLink where SS_Path like '%"&NowSSPath&"%' order by SL_Vouch desc,SL_Date desc,SL_Time desc"
Else
sql = "select * from SiteLink where SS_ID="&NowSSID&" order by SL_Vouch desc,SL_Date desc,SL_Time desc"
End If
Set rs = LS.CreateRs(sql,1,1)
rscount = rs.recordcount
If rscount = 0 Then
rs.close
Response.write "正在更新中..."
Exit Sub
End If
linkpar = "&SS_ID="&NowSSID
mypage = Request("whichpage")
If mypage = "" or IsNumeric(mypage) = False Then mypage = 1
mypage = CInt(mypage)
If mypage < 1 Then mypage = 1
mypagesize = NumTr
rs.PageSize = mypagesize
maxcount = rs.pageCount
If mypage > maxcount Then mypage = maxcount
rs.Absolutepage = mypage
Response.write "
"
Response.write "
"
Response.write "
"
Call Pagination()
Response.write "
"
Response.write "
"
Response.write "
"
j = rscount - (mypage-1) * mypagesize
If j > mypagesize Then j = mypagesize
For i = 1 to j
SL_ID = rs("SL_ID")
SL_Name = rs("SL_Name")
SL_URL = rs("SL_URL")
SL_SmallImage = rs("SL_SmallImage")
SL_LinkMan = rs("SL_LinkMan")
SL_Tel = rs("SL_Tel")
SL_Fax = rs("SL_Fax")
SL_Email = rs("SL_Email")
SL_Address = rs("SL_Address")
SL_PostCode = rs("SL_PostCode")
SL_Vouch = rs("SL_Vouch")
SL_Hit = rs("SL_Hit")
If SL_SmallImage = "" or IsNull(SL_SmallImage) = True Then SL_SmallImage = "/System/static/skins/image/nophoto.gif"
If i mod NumCol = 1 or NumCol = 1 Then Response.write "
"
Response.write " "&SL_Name&""
Response.write " [机构职能]"
Response.write " 网 址："&SL_URL&""
If LinkManVis = 1 Then Response.write " 联系人："&SL_LinkMan&""
If TelVis = 1 Then Response.write " 电 话："&SL_Tel&""
If FaxVis = 1 Then Response.write " 传 真："&SL_Fax&""
If EmailVis = 1 Then Response.write " E-mail："&SL_Email&""
If AddressVis = 1 Then Response.write " 地 址："&SL_Address&""
If PostCodeVis = 1 Then Response.write " 邮 编："&SL_PostCode&""
Response.write "
"
End If
If i = j and j > NumCol and i mod NumCol <> 0 Then
y = NumCol - (i mod NumCol)
For x = 1 to y
Response.write "
"
Next
End If
If i mod NumCol = 0 Then Response.write "
"
rs.movenext
Next
rs.close
Response.write "
"
If maxcount > 1 Then '站点列表多于1页
Response.write "
"
Response.write "
"
Call Pagination()
Response.write "
"
End If
Response.write "
"
End Sub
%>
<%
'======================================================================================================================
' 首页下载列表(SS_ID:栏目ID,SS_Path:栏目路径,NumRow：显示条数,NumWords：标题显示字数,ViewUrl：链接地址,DateVis：是否显示时间,DownVis：是否显示下载文字)
'======================================================================================================================
Function IndexDownList(SS_ID, SS_Path, NumRow, NumWords, ViewUrl, DateVis, DownVis)
If ss_id = "" Or IsNumeric(SS_ID) = False Or NumRow = "" Or IsNumeric(NumRow) = False Then Exit Function
Dim v_CacheName
v_CacheName = G_CACHENAME & "_IndexDownList_" & SS_ID
Str = ""
If Not IsEmpty(Application(v_CacheName)) And G_ALLCACHE Then
Str = Application(v_CacheName)
Else
sql = "select top "&NumRow&" SS_ID,DL_ID,DL_Name,DL_Date,DL_Url from DownLoad where DL_CheckIn=1"
If SS_Path <> "" Then
sql = sql &" and SS_Path like '"&SS_Path&"%'"
Else
sql = sql & " and SS_ID="&SS_ID
End If
sql = sql & " order by DL_Vouch desc,DL_Date desc,DL_ID desc"
Set rs = LS.CreateRs(sql, 1, 1)
rscount = rs.recordcount
If rscount > NumRow Then rscount = NumRow
If rscount = 0 Then
rs.Close
Response.Write "暂无相关信息"
Exit Function
End If
Str = Str & "
"
For i = 1 To rscount
SS_ID = rs("SS_ID")
DL_ID = rs("DL_ID")
DL_Name = rs("DL_Name")
DL_Name1 = DL_Name
DL_Date = LS.Datetime(rs("DL_Date"), "yyyy-mm-dd")
DL_Url = rs("DL_Url")
If NumWords > 0 Then DL_Name = CutStr(DL_Name, NumWords)
If DownVis = 1 Then DL_Name = CutStr(DL_Name, NumWords)
Str = Str & "
"&DL_Name&""
If DateVis = 1 Then
Str = Str & ""&DL_Date&""
End If
If DownVis = 1 Then
If DL_Url<>"" And DL_Url<>"#" Then
Str = Str & "文件下载"
Else
Str = Str & "文件下载"
End If
End If
Str = Str & "
"
rs.movenext
Next
rs.Close
Set rs = Nothing
Str = Str & "
"
If G_ALLCACHE Then
Application.Lock
Application(v_CacheName) = Str
Application.UnLock
End If
End If
If G_FLAGHTMLTYPE = 1 Then
response.Write(Str)
Else
IndexDownList = Str
End If
End Function
'======================================================================================================================
' 栏目页下载列表(PerNumRow：每页显示条数,MemberIS：是否启动会员,MemberSSID：绑定会员栏目ID,NumWords：标题显示字数)
'======================================================================================================================
Function DownList(PerNumRow, MemberIS, MemberSSID, NumWords)
Str = ""
If NowSSIS = False Then Exit Function
Application("DownMemIS") = MemberIS
' ------------------系统启用会员-------------------------
If MemberIS = 1 Then
Str = Str & "
"
End If
'显示下载详细资料
DL_ID = GetSafeStr(Request.QueryString("DL_ID"))
If DL_ID <> "" Then
If IsNumeric(DL_ID) = True Then
sql = "select DL_Name,DL_Image,DL_Date,DL_URL,DL_Hit,DL_Intro from DownLoad where DL_CheckIn=1 and DL_ID=" & DL_ID
Set rs = LS.CreateRs(sql, 1, 1)
If rs.EOF Then
rs.Close
Exit Function
End If
DL_Name = rs("DL_Name")
DL_Image = rs("DL_Image")
DL_Date = rs("DL_Date")
DL_URL = rs("DL_URL")
DL_Hit = rs("DL_Hit")
DL_Intro = rs("DL_Intro")
If DL_Image = "" Or IsNull(DL_Image) = True Then DL_Image = "/tmp/jslib/images/nophoto.jpg"
If DL_Intro <> "" Then DL_Intro = Replace((Replace(DL_Intro, vbCrLf, " ")), Chr(32)&Chr(32), " ")
rs.Close
Set rs = Nothing
%><%
Response.write "" & chr(13)&chr(10)
If Title2Pic_Width > 0 Then
Response.write "" & chr(13) &chr(10)
replstr = "
<%
Exit Function
End If
End If
' ------------------验证Post-------------------------
action = GetSafeStr(Request.Form("action"))
If action = "logincheck" Then '验证会员登录
Call MemberLoginCheck(MemberSSID)
Exit Function
End If
If action = "registercheck" Then '验证会员注册
Call MemberRegisterCheck(MemberSSID)
Exit Function
End If
If action = "editcheck" Then '验证会员修改资料
Call MemberEditCheck(MemberSSID)
Exit Function
End If
If action = "findpasscheckuser" Then '验证密码查询
Call MemberFindPassCheckUser()
Exit Function
End If
If action = "findpasscheckanswer" Then '验证密码查询
Call MemberFindPassCheckAnswer()
Exit Function
End If
' ------------------验证Get-------------------------
action = GetSafeStr(Request.QueryString("action"))
If action = "login" Then '用户登录表单
%>
<%
Exit Function
End If
If action = "register" Then '用户注册表单
%>
<%If GetSafeStr(Request.QueryString("read")) <> "1" Then%>
<%Else%>
<%If Session("NoForm") = "" Then Session("NoForm") = 1%>
<%End If%>
<%
Exit Function
End If
If action = "edit" Then '用户修改资料表单
Call MemberEdit()
Exit Function
End If
If action = "findpass" Then '用户查询密码表单
Call MemberFindPass()
Exit Function
End If
If action = "logout" Then '用户安全退出
Session("m_ID") = ""
Session("m_Name") = ""
Session("m_ForumRights") = ""
Session("m_Level") = ""
Session("m_LoginNow") = ""
Response.Redirect NowSSURL&"?SS_ID="&NowSSID
End If
If NowSSSubItem = True Then
sql = " DL_CheckIn=1 and SS_Path like '"&NowSSPath&"%'"
Else
sql = " DL_CheckIn=1 and SS_ID="&NowSSID&""
End If
'默认分页样式名称 pagination
With LS.DB
.PageSize = CInt(PerNumRow)'定义页数
.ListLong = 3'页数前后显示个数
.Pkey = "DL_ID"'主键
.Field = "DL_ID,DL_Name,DL_Url,DL_Date"'字段、不带用where
.OrderBy = "DL_Vouch desc,DL_Date desc,DL_ID desc"'排序,不用带order by
.RecordCount = 0'默认0即可，尽量不要用*号
.Table = "DownLoad"'表名
.Condition = sql '条件语句。
Set oRs = .ResultSet
.Template = "
"
strPage = .PageNav()'分页列表
End With
If oRs.EOF Then
oRs.Close
response.Write "正在更新中..."
Exit Function
End If
gourl="/tmp/"&NowSSURL&"?SS_ID="&nowSSID&"&pp="
If Not oRs.EOF Then
Str = Str & ""&Chr(13)&Chr(10)
End If
Str = Str & "
"
If Not IsNull(oRs) Then
Do While Not oRs.EOF
Str = Str & "
"
DL_ID = oRs("DL_ID")
DL_Name = oRs("DL_Name")
DL_Name1 = DL_Name
DL_Url = oRs("DL_Url")
DL_Date = oRs("DL_Date")
if DL_Date <>"" then
DL_Date = LS.Datetime(DL_Date, "yyyy-mm-dd")
end if
If NumWords<>"" And IsNumeric(NumWords) Then
DL_Name = Cutstr(DL_Name, NumWords)
End If
Str = Str & " "&DL_Name&""
Str = Str & " "&DL_Date&""
' If DL_Url<>"" And DL_Url<>"#" Then
' Str = Str & "点击下载"
' Else
' Str = Str & "点击下载"
' End If
oRs.movenext
Str = Str & "
"
Loop
End If
Str = Str & "
"
If LS.DB.Recordcount>CInt(PerNumRow) Then '文章列表多于1页
Str = Str & "
"
Str = Str & strPage
Str = Str & "
"
End If
oRs.Close
Set oRs = Nothing
If G_FLAGHTMLTYPE = 1 Then
response.Write(Str)
Else
DownList = Str
End If
End Function
%>
<%
Private Const BITS_TO_A_BYTE = 8
Private Const BYTES_TO_A_WORD = 4
Private Const BITS_TO_A_WORD = 32
Private m_lOnBits(30)
Private m_l2Power(30)
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)
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
MD5 = LCase(WordToHex(a) & WordToHex(b) & WordToHex(c) & WordToHex(d)) '32byte
'MD5=LCase(WordToHex(b) & WordToHex(c)) '16byte
End Function
%>
<%
'======================================================================================================================
' 会员积分榜
'======================================================================================================================
Sub MemberTopScore(NumRow)
sql = "select top "&NumRow&" m_Name,m_Score from Member order by m_Score desc"
Set rs = LS.CreateRs(sql,1,1)
rscount = rs.recordcount
If rscount > NumRow Then rscount = NumRow
If rscount > 0 Then
Response.write "
"
Response.write "
"
For i = 1 to rscount
Response.write "
"&rs("m_Name") & " ("&rs("m_Score")&")
"
rs.movenext
Next
Response.write "
"
End If
rs.close:set rs=nothing
End Sub
'======================================================================================================================
' 当前论坛分类版主
'======================================================================================================================
Sub MemberForumAdmin()
If NowSSID = "" Then Exit Sub
sql = "select m_Name from Member where m_ForumRights like '%|"&NowSSID&"|%' order by m_ID"
Set rs = LS.CreateRs(sql,1,1)
rscount = rs.recordcount
If rscount > 0 Then
Response.write "当前版主："
For i = 1 to rscount
Response.write " " & rs("m_Name")
rs.movenext
Next
Response.write ""
End If
rs.close:set rs=nothing
End Sub
'======================================================================================================================
' 验证会员登录
'======================================================================================================================
Sub MemberLoginCheck(MemberSSID,BBSid)
m_Login = GetSafeStr(Trim(Request.Form("m_Login")))
m_Password = GetSafeStr(Trim(Request.Form("m_Password")))
If m_Login = "" or m_Password = "" Then Response.End()
sql = "select FC_Score2 from forumconfig where SS_ID ="&BBSid&" order by FC_ID desc"
Set rs = LS.CreateRs(sql,1,1)
if not rs.eof then
memberloginscore = rs("FC_Score2")
end if
rs.close
sql = "select * from Member Where m_Login='" & m_Login & "' and m_Password='" & md5(m_Password) & "'"
Set rs = LS.CreateRs(sql,1,3)
If rs.eof Then
rs.close
Call OutScript("出错提示：\n\n用户验证失败！")
Response.End()
End If
m_Lock = rs("m_Lock")
If m_Lock = True Then
rs.close
Call OutScript("用户正在审核中，请耐心等待！")
Response.End()
End If
If CInt(MemberSSID) <> rs("SS_ID") Then
rs.close
Call OutScript("出错提示：\n\n登录失败，非本栏目会员！")
Response.End()
End If
m_LoginTime = rs("m_LoginTime")
m_score = rs("m_score")+memberloginscore
rs("m_LoginTime") = m_LoginTime + 1
rs("m_LastAccessDate") = Date()
rs("m_LastAccessTime") = Time()
rs("m_LastAccessIP") = Request.ServerVariables("REMOTE_ADDR")
'更新会员组等级
sqla = "select FM_ID from forummebers where FM_score>="&m_score&" order by FM_score asc"
Set rsa = LS.CreateRs(sqla,1,1)
If not rsa.eof Then
m_Level = rsa("FM_ID")
End If
rsa.close:set rsa=nothing
rs("m_Score") = m_score
rs("m_Level") = m_Level
Session("m_Name") = rs("m_Name")
Session("m_ID") = rs("m_ID")
Session("m_Level") = m_Level
Session("m_LoginNow") = Time()
rs.update
rs.close:set rs=nothing
rUrl = "?SS_ID="&NowSSID
If NowPSID > 0 Then rUrl = rUrl & "&PS_ID=" & NowPSID
Response.Redirect rUrl
End Sub
'======================================================================================================================
' 验证会员注册
'======================================================================================================================
Sub MemberRegisterCheck(MemberSSID,BBSid)
If MemberSSID = "" Then Exit Sub
If IsNumeric(Request.Form("NoForm")) = False Then Exit Sub
m_Login = GetSafeStr(Trim(Request.Form("m_Login")))
m_Password = GetSafeStr(Trim(Request.Form("m_Password")))
m_Name = GetSafeStr(Trim(Request.Form("m_Name")))
m_Address = GetSafeStr(Trim(Request.Form("m_Address")))
m_Tel = GetSafeStr(Trim(Request.Form("m_Tel")))
m_Email = GetSafeStr(Trim(Request.Form("m_Email")))
m_Question = GetSafeStr(Trim(Request.Form("m_Question")))
m_Answer = GetSafeStr(Trim(Request.Form("m_Answer")))
m_Photo = GetSafeStr(Trim(Request.Form("m_Photo")))
If m_Login = "" or m_PassWord = "" or m_Name = "" Then Call OutScript("出错提示：\n\n内容填写不规范！")
If m_Tel = "" or m_Question = "" or m_Answer = "" Then Call OutScript("出错提示：\n\n内容填写不规范！")
'验证码是否输入正确
checkCode = Trim(Request.form("checkimg"))
If checkCode <> Session("psn") Then
Response.Write("")
End If
'验证用户名是否重复
sql = "select * from Member where SS_ID="&MemberSSID&" and m_Login='" & m_Login & "'"
Set rs = LS.CreateRs(sql,1,1)
If not rs.eof Then
rs.close
Call OutScript("出错提示：\n\n此用户名已被他人注册，请更换！")
End If
rs.close
If CInt(Request.Form("NoForm")) <> Session("NoForm") Then
Call OutScript("出错提示：\n\n当前表单不可重复提交！")
Exit Sub
End If
Session("NoForm") = Session("NoForm") + 1
sql = "select FC_member,FC_Score1 from forumconfig where SS_ID ="&BBSid&" order by FC_ID desc"
Set rs = LS.CreateRs(sql,1,1)
if not rs.eof then
Indexmemberreg = rs("FC_member")
memberregscore = rs("FC_Score1")
end if
rs.close:set rs=nothing
'添加用户信息
sql = "select top 1 * from Member order by m_ID desc"
Set rs = LS.CreateRs(sql,1,3)
rs.addnew
rs("SS_ID") = MemberSSID
rs("m_Login") = m_Login
rs("m_Password") = md5(m_Password)
rs("m_Name") = m_Name
rs("m_Address") = m_Address
rs("m_Tel") = m_Tel
rs("m_Email") = m_Email
rs("m_Question") = m_Question
rs("m_Answer") = m_Answer
rs("m_LoginTime") = 1
rs("m_LastAccessDate") = Date()
rs("m_LastAccessTime") = Time()
rs("m_CreateDate") = Date()
rs("m_CreateTime") = Time()
rs("m_CreateIP") = Request.ServerVariables("REMOTE_ADDR")
rs("m_Level") = 1
if Indexmemberreg=0 then
rs("m_Lock") = 1
else
rs("m_Lock") = 0
end if
rs("m_Score") = memberregscore
rs("m_Photo") = m_Photo
rs.update
rs.close:set rs=nothing
Response.write ""
End Sub
'======================================================================================================================
' 会员修改资料
'======================================================================================================================
Sub MemberEdit()
sql = "select m_Login,m_Password,m_Name,m_Address,m_Tel,m_Email,m_Question,m_Answer,m_Photo from Member where m_ID=" & Session("m_ID")
Set rs = LS.CreateRs(sql,1,1)
If not rs.eof Then
m_Login = rs("m_Login")
m_Password = rs("m_Password")
m_Name = rs("m_Name")
m_Address = rs("m_Address")
m_Tel = rs("m_Tel")
m_Email = rs("m_Email")
m_Question = rs("m_Question")
m_Answer = rs("m_Answer")
m_Photo = rs("m_Photo")
End If
rs.close
%>
<%If Session("NoForm") = "" Then Session("NoForm") = 1%>
<%If WebLanguage = 2 Then%>
<%If Session("NoForm") = "" Then Session("NoForm") = 1%>
<%End If%>
<%
End Sub
'======================================================================================================================
' 验证会员修改资料
'======================================================================================================================
Sub MemberEditCheck(MemberSSID)
m_Login = GetSafeStr(Trim(Request.Form("m_Login")))
m_Password = GetSafeStr(Trim(Request.Form("m_Password")))
m_Name = GetSafeStr(Trim(Request.Form("m_Name")))
m_Address = GetSafeStr(Trim(Request.Form("m_Address")))
m_Tel = GetSafeStr(Trim(Request.Form("m_Tel")))
m_Email = GetSafeStr(Trim(Request.Form("m_Email")))
m_Question = GetSafeStr(Trim(Request.Form("m_Question")))
m_Answer = GetSafeStr(Trim(Request.Form("m_Answer")))
m_Photo = GetSafeStr(Trim(Request.Form("m_Photo")))
If m_Login = "" or m_PassWord = "" or m_Name = "" Then Call OutScript("出错提示：\n\n内容填写不规范！")
If m_Tel = "" or m_Question = "" or m_Answer = "" Then Call OutScript("出错提示：\n\n内容填写不规范！")
'验证用户名是否重复
sql = "select * from Member where SS_ID="&MemberSSID&" and m_Login='" & m_Login & "' and m_ID<>" & Session("m_ID")
Set rs = LS.CreateRs(sql,1,1)
If not rs.eof Then
rs.close
Call OutScript("出错提示：\n\n此用户名已被他人注册，请更换！")
End If
rs.close:set rs=nothing
'修改用户信息
sql = "select * from Member where m_ID=" & Session("m_ID")
Set rs = LS.CreateRs(sql,1,3)
If not rs.eof Then
rs("m_Login") = m_Login
rs("m_Password") = md5(m_Password)
rs("m_Name") = m_Name
rs("m_Address") = m_Address
rs("m_Tel") = m_Tel
rs("m_Email") = m_Email
rs("m_Question") = m_Question
rs("m_Answer") = m_Answer
rs("m_Photo") = m_Photo
rs.update
End If
rs.close
Session("m_ID") = ""
Session("m_Name") = ""
Response.write ""&chr(13)&chr(10)
Response.End()
End Sub
Sub MemberFindPass()
Response.write "
"
Response.write "
"
Response.write ""
Response.write "
"&chr(13)&chr(10)
Response.write ""&chr(13)&chr(10)
End Sub
Sub MemberFindPassCheckUser()
m_Login = GetSafeStr(Trim(Request.Form("m_Login")))
If m_Login = "" Then Exit Sub
sql = "select m_Question from Member where m_Login='"&m_Login&"'"
Set rs = LS.CreateRs(sql,1,1)
If rs.eof Then
rs.close
Response.write " 系统无此用户！"
Exit Sub
End If
m_Question = rs("m_Question")
rs.close:set rs=nothing
Response.write "
"
Response.write "
"
Response.write ""
Response.write "
"&chr(13)&chr(10)
Response.write ""&chr(13)&chr(10)
End Sub
Sub MemberFindPassCheckAnswer()
m_Login = GetSafeStr(Trim(Request.Form("m_Login")))
m_Answer = GetSafeStr(Trim(Request.Form("m_Answer")))
If m_Answer = "" or m_Login = "" Then Exit Sub
sql = "select * from Member where m_Login='"&m_Login&"'"
Set rs = LS.CreateRs(sql,1,1)
If rs.eof Then
rs.close
Exit Sub
End If
Response.write "
"
If m_Answer = rs("m_Answer") Then
Response.write "
"
End If
rs.close:set rs=nothing
End Sub
%>
<%
Sub OnlineRegister()
If NowSSID = "" Then Exit Sub
action = Request.Form("action")
If action = "add" Then
OR_Name = GetSafeStr(Request.Form("OR_Name"))
OR_Sex = Request.Form("OR_Sex")
OR_Birth = Request.Form("OR_Birth")
OR_Degree = Request.Form("OR_Degree")
OR_School = GetSafeStr(Request.Form("OR_School"))
OR_Address = GetSafeStr(Request.Form("OR_Address"))
OR_Postcode = GetSafeStr(Request.Form("OR_Postcode"))
OR_Tel = GetSafeStr(Request.Form("OR_Tel"))
OR_Class = GetSafeStr(Request.Form("OR_Class"))
OR_Email = GetSafeStr(Request.Form("OR_Email"))
OR_QQ = GetSafeStr(Request.Form("OR_QQ"))
OR_Detail = GetSafeStr(Request.Form("OR_Detail"))
If OR_Name = "" or OR_School = "" or OR_Postcode = "" or OR_Class = "" Then Response.End()
sql = "select top 1 * from OnlineRegister order by OR_ID desc"
Set rs = LS.CreateRs(sql,1,3)
If Err <> 0 Then Response.write Err.Description
If not rs.eof Then
OR_ID = rs("OR_ID") + 1
Else
OR_ID = 1
End If
rs.addnew
rs("SS_ID") = NowSSID
rs("OR_ID") = OR_ID
rs("OR_Name") = OR_Name
rs("OR_Sex") = OR_Sex
rs("OR_Birth") = OR_Birth
rs("OR_Degree") = OR_Degree
rs("OR_School") = OR_School
rs("OR_Address") = OR_Address
rs("OR_Postcode") = OR_Postcode
rs("OR_Tel") = OR_Tel
rs("OR_Class") = OR_Class
If OR_Email <> "" Then rs("OR_Email") = OR_Email
If OR_QQ <> "" Then rs("OR_QQ") = OR_QQ
If OR_Detail <> "" Then rs("OR_Detail") = OR_Detail
rs("OR_IP") = Request.ServerVariables("REMOTE_ADDR")
rs("OR_Time") = Date() & " " & Time()
rs.update
rs.close
If Err = 0 Then Response.write " 报名成功！"
Else
%>
<%
End If
End Sub
%>
<%
'======================================================================================================================
' 文章内容页
'======================================================================================================================
Dim xd_ID,PageNav
PageNav = ""
'============================================================================================================
'内容页相关调用字段DocContentInfo(DocPlaceIS：当前位置,WeiboIS：是不显示新浪微博等共享,d_ShowComment：是否评论,CommentSSID：评论管理栏目ID,MaxImgWid：内容图片最大宽度)
'============================================================================================================
Public Function DocContentInfo(DocPlaceIS,WeiboIS,d_ShowComment,CommentSSID,MaxImgWid)
If td_ID<>"" And IsNumeric(td_ID) Then
xd_ID = td_ID
Else
xd_ID = GetSafeStr(Request.QueryString("d_ID"))
End If
SS_ID = GetSafeStr(Request.QueryString("SS_ID"))
page = GetSafeStr(Request.QueryString("page"))
If page = "" Then
page = 1
Else
If IsNumeric(page) = False Then
page = 1
Else
page = CInt(page)
If page < 1 Then page = 1
End If
End If
If xd_ID = "" or IsNumeric(xd_ID) = False Then Exit Function
'当前位置
If DocPlaceIS = 1 Then
SS_SiteID = CCfg(SS_ID,3)
If SS_SiteID = "" or IsNumeric(SS_SiteID) = False Then Exit Function
DocNowPlace = ""
If SS_SiteID > 0 Then
RootSSPath = CCfg(SS_SiteID,1)
RootSSPathNum = UBound(Split(RootSSPath,"-"))
Else
RootSSPathNum = 0
End If
If RootSSPathNum >= NowSSPathNum Then Exit Function
If SS_Type < 4 Then
SS_URL = NowSSHtmlUrl '静态 .html
Else
SS_URL = "/tmp/"&NowSSURL & "?SS_ID=" &NowSSID '动态 .shtml
End If
DocNowPlace = ""&NowSSName&""
PSS_ID = NowPSSID
For i = 2 to NowSSPathNum - RootSSPathNum
SS_ID = CCfg(PSS_ID,0)
PSS_ID_ = CCfg(PSS_ID,2)
SS_Type = CCfg(PSS_ID,5)
SS_Name = CCfg(PSS_ID,6)
SS_URL = CCfg(PSS_ID,8)
SS_LinkURL = CCfg(PSS_ID,9)
SS_HtmlUrl = CCfg(PSS_ID,10)
If SS_Type < 100 and SS_Type <>8 and SS_Type <> 10 Then
SS_URL = SS_HtmlUrl '静态 .html
Else
SS_URL = SS_URL & "?SS_ID=" &SS_ID '动态 .shtml
End If
If SS_LinkURL <> "" Then
If DocNowPlace = "" Then
DocNowPlace = ""&SS_Name&" > "
Else
DocNowPlace = ""&SS_Name&" > " & DocNowPlace
End If
Else
If DocNowPlace = "" Then
DocNowPlace = ""&SS_Name&" > "
Else
DocNowPlace = ""&SS_Name&" > " & DocNowPlace
End If
End If
PSS_ID = PSS_ID_
Next
DocNowPlace = " > "&DocNowPlace
End If
If WeiboIS = 1 then
wbstr="分享到： 腾讯微博 新浪微博"
End if
strSelect = "select SS_ID,SS_Path,d_CheckIn,d_Title,d_TitleColor,d_SubTitle,d_KeyWords,d_Resource,d_LinkImage,d_isdel,d_Date,d_Author,d_Hit,d_HtmlUrl,d_Contents from vDocContents where d_ID=" & xd_ID
If G_UAID="" And Not IsNumeric(G_UAID) Then
strSelect = strSelect & " AND d_CheckIn=1"
End If
Set Rs = doSp(strSelect)
If not Rs.eof Then
NowSSID = Rs("SS_ID")
NowSSPath = Rs("SS_Path")
d_CheckIn = Rs("d_CheckIn")
d_isdel = Rs("d_isdel")
td_Title = Rs("d_Title")
ttd_Title = Rs("d_Title")
td_TitleColor = Rs("d_TitleColor")
td_SubTitle = Rs("d_SubTitle")
td_KeyWords = Rs("d_KeyWords")
td_Resource = Rs("d_Resource")
d_LinkImage = Rs("d_LinkImage")
td_Date = Rs("d_Date")
td_Author = Rs("d_Author")
td_Hit = Rs("d_Hit")
td_HtmlUrl = Rs("d_HtmlUrl")
td_Contents = Rs("d_Contents")
Rs.close
End If
Set Rs=nothing
if td_TitleColor<>"" then
td_Title = ""&td_Title&""
end if
if (d_CheckIn = 0 or d_isdel<>0) and G_UAID="" then response.End()
If MaxImgWid > 0 and td_Contents<>"" Then
Response.write "" & chr(13) &chr(10)
replstr = "0]")
If pclass.length>0 Then
rscount = pclass.length
For Each subclass In pclass
HW_ID = subclass.SelectSingleNode("@w0").text
HW_TITLE = subclass.SelectSingleNode("@w1").text
HW_TYPE = subclass.SelectSingleNode("@w2").text
HW_URL = subclass.SelectSingleNode("@w3").text
HW_CONTENT = subclass.SelectSingleNode("@w4").text
Str_num=instr(td_Contents,HW_TITLE)
if Str_num>0 then
Str_nums=split(td_Contents,HW_TITLE)
for j=0 to ubound(Str_nums)
next
end if
Str_nums=j-1
if HW_TYPE=0 THEN
HotWords=""&HW_TITLE&""
Else
HotWords=""&HW_TITLE&"
"&HW_CONTENT&"
"
End if
if Str_num>=1 then
td_Contents=Replace(td_Contents,HW_TITLE,HotWords,1,1)
end if
Next
End If
td_Contents=td_Contents&HotWordsDiv
' '开启敏感词库
' If Not IsObject(Application(G_CACHENAME & "_filterwords")) Then Call InitfilterwordsModule()
' Set pclass = Application(G_CACHENAME & "_filterwords").DocumentElement.SelectNodes("k[@w0>0]")
' If pclass.length>0 Then
' rscount = pclass.length
' For Each subclass In pclass
' FW_ID = subclass.SelectSingleNode("@w0").text
' FW_TITLE = subclass.SelectSingleNode("@w1").text
' FW_TITLE1 = subclass.SelectSingleNode("@w2").text
'
' if instr(td_Contents,FW_TITLE)<>0 then
' td_Contents=Replace(td_Contents,FW_TITLE,FW_TITLE1)
' end if
' Next
' End If
'是否开启评论功能。
If d_ShowComment=1 Then
nowpage = LS.toClng(request("pp"))
if nowpage = 0 then nowpage = 1
CommentList = ""
CommentList = CommentList & "" & chr(13) &chr(10)
sql = " c_CheckIn<>0 and d_ID=" & xd_ID
With LS.DB
.PageSize = 6'定义页数
.ListLong = 3'页数前后显示个数
.Pkey = "c_ID"'主键
.Field = "*"'字段、尽量不要用*号
.Table = "DocComments"'表名
.Condition = sql '条件语句，不带用where
.OrderBy = "c_date asc,c_Time asc"'排序,不用带order by
.RecordCount = 0'默认0即可。
Set Rs = .ResultSet
strPage = .PageNav()'分页列表
End With
If Not Rs.eof Then
CommentList = CommentList & "
"
if LS.DB.recordcount > 6 then
CommentList = CommentList & "
"&strPage&"
"
end if
CommentList = CommentList & "
"
End If
rs.close
CommentList = CommentList & "" & chr(13) &chr(10)
CommentList = CommentList & ""
End If
End Function
%>
<%
Sub LsFunction(StyleID)
sql="select * from fun_style where ID="&StyleID
Set rs = LS.CreateRs(sql,1,1)
if not rs.eof then
ExecFun=rs("ExecFun")
if rs("ParaValue")<>"" then
ParaValue=left(rs("ParaValue"),len(rs("ParaValue"))-1)
end if
rs.close
set rs = nothing
if ParaValue<>"" then Para=Split(ParaValue,",")
Select Case ExecFun
case "HorzMainNav"
call HorzMainNav(Para(0),Para(1))
case "VertMainNav"
call VertMainNav(Para(0),Para(1),Para(2),Para(3),Para(4),Para(5),Para(6),Para(7),Para(8),Para(9))
case "HorzSubNav"
call HorzSubNav(Para(0),Para(1))
case "VertSubNav"
call VertSubNav(Para(0),Para(1),Para(2),Para(3),Para(4),Para(5),Para(6),Para(7),Para(8),Para(9))
case "VertMenuSubNav"
call VertMenuSubNav(Para(0),Para(1),Para(2),Para(3),Para(4),Para(5),Para(6),Para(7),Para(8),Para(9),Para(10))
case "NowPSSName"
call NowPSSName()
case "NowPlace"
call NowPlace(Para(0))
case "IndexDocList"
call IndexDocList(Para(0),Para(1),Para(2),Para(3),Para(4),Para(5),Para(6),Para(7),Para(8),Para(9),Para(10),Para(11),Para(12),Para(13))
case "IndexSortDocList"
call IndexSortDocList(Para(0),Para(1),Para(2),Para(3),Para(4),Para(5),Para(6),Para(7),Para(8),Para(9),Para(10),Para(11),Para(12),Para(13))
case "IndexImageList"
call IndexImageList(Para(0),Para(1),Para(2),Para(3),Para(4),Para(5),Para(6),Para(7),Para(8),Para(9),Para(10),Para(11),Para(12))
case "ImageShow"
call ImageShow(Para(0),Para(1),Para(2),Para(3),Para(4),Para(5),Para(6),Para(7),Para(8),Para(9),Para(10),Para(11),Para(12),Para(13),Para(14),Para(15))
case "ImageSlide"
call ImageSlide(Para(0),Para(1),Para(2),Para(3),Para(4),Para(5),Para(6),Para(7),Para(8),Para(9),Para(10))
case "ImageFlash"
call ImageFlash(Para(0),Para(1),Para(2),Para(3),Para(4),Para(5),Para(6))
case "IndexProductList"
call IndexProductList(Para(0),Para(1),Para(2),Para(3),Para(4),Para(5),Para(6),Para(7),Para(8),Para(9))
case "IndexDownList"
call IndexDownList(Para(0),Para(1),Para(2),Para(3),Para(4))
case "IndexSortDoc"
call IndexSortDoc(Para(0),Para(1))
case "IndexForumList"
call IndexForumList(Para(0),Para(1),Para(2),Para(3),Para(4),Para(5),Para(6),Para(7),Para(8),Para(9),Para(10),Para(11),Para(12))
case "IndexVodList"
call IndexVodList(Para(0),Para(1),Para(2),Para(3),Para(4),Para(5),Para(6),Para(7),Para(8),Para(9),Para(10),Para(11))
case "IndexVodImgList"
call IndexVodImgList(Para(0),Para(1),Para(2),Para(3),Para(4),Para(5),Para(6),Para(7),Para(8))
case "IndexCorpProductList"
call IndexCorpProductList(Para(0),Para(1),Para(2),Para(3),Para(4),Para(5),Para(6))
case "IndexTravelList"
call IndexTravelList(Para(0),Para(1),Para(2),Para(3),Para(4),Para(5),Para(6))
case "Notice"
call Notice(Para(0))
case "CallBoard"
call CallBoard(Para(0))
case "Vote"
call Vote(Para(0),Para(1),Para(2),Para(3))
case "AD"
call AD(Para(0),Para(1),Para(2),Para(3),Para(4),Para(5),Para(6),Para(7),Para(8))
case "ADMenu"
call ADMenu(Para(0),Para(1),Para(2),Para(3),Para(4))
case "FloatAD"
call FloatAD(Para(0),Para(1),Para(2),Para(3),Para(4),Para(5),Para(6),Para(7),Para(8))
case "DocList"
call DocList(Para(0),Para(1),Para(2),Para(3),Para(4),Para(5),Para(6),Para(7),Para(8),Para(9),Para(10),Para(11),Para(12),Para(13))
case "ImageList"
call ImageList(Para(0),Para(1),Para(2),Para(3),Para(4),Para(5),Para(6),Para(7),Para(8),Para(9),Para(10),Para(11))
case "SearchDocList"
call SearchDocList(Para(0),Para(1),Para(2),Para(3),Para(4),Para(5),Para(6),Para(7),Para(8))
case "VodList"
call VodList(Para(0),Para(1),Para(2),Para(3),Para(4),Para(5),Para(6))
case "ForumList"
call ForumList(Para(0),Para(1),Para(2),Para(3),Para(4),Para(5),Para(6),Para(7))
case "GuestBook"
call GuestBook(Para(0),Para(1),Para(2),Para(3))
case "Job"
call Job()
case "ProductList"
call ProductList(Para(0),Para(1),Para(2),Para(3),Para(4),Para(5),Para(6))
case "DownList"
call DownList(Para(0),Para(1),Para(2))
case "SiteList"
call SiteList(Para(0),Para(1),Para(2),Para(3),Para(4),Para(5),Para(6),Para(7),Para(8),Para(9),Para(10),Para(11),Para(12))
case "OnlineRegister"
Call OnlineRegister()
case "ECard"
call ECard()
case "CorpInfoSort"
call CorpInfoSort(Para(0),Para(1),Para(2),Para(3),Para(4),Para(5),Para(6),Para(7),Para(8),Para(9))
case "TravelList"
call TravelList(Para(0),Para(1),Para(2),Para(3),Para(4))
case "DocContent"
call DocContentInfo(Para(0),Para(1),Para(2),Para(3),Para(4),Para(5),Para(6))
case "CorpCardForm"
Call CorpCardForm()
case "HotelList"
call HotelList(Para(0),Para(1),Para(2),Para(3),Para(4))
case "HotelOrder"
Call HotelOrder()
case "HotelView"
Call HotelView(Para(0))
case "TravelView"
Call TravelView(Para(0))
case "OrderTravel"
Call OrderTravel()
End Select
else
rs.close
set rs = nothing
end if
End Sub
%>
<%
'======================================================================================================================
' 栏目页在线访谈页面(PerNumRow:显示访谈条数,PerdocNumRow:显示回复条数,IsInPut:是否显示回复登录框,IsIframe:是否内嵌页面,iName:内嵌页面名称,iWid:宽度,iHei:高度)
'======================================================================================================================
Function InterViewSortList(PerNumRow, PerdocNumRow, IsInPut, IsIframe, iName, iWid, iHei, IVS_ZT)
Str = ""
action = GetSafeStr(Request.QueryString("action"))
If action = "imgshow" Then
IVS_ID = GetSafeStr(Trim(Request.QueryString("IVS_ID")))
If IVS_ID = "" Or IsNumeric(IVS_ID) = False Then Response.End()
sql = "select IVS_SceneImages,IVS_Close"
sql = sql&" from InterViewSort where IVS_ID="&CInt(IVS_ID)&" and IVS_Open=1"
If IVS_ZT<>"" Then
sql = sql & " and IVS_ZT="&IVS_ZT
End If
Set rs = LS.CreateRs(sql, 1, 1)
If Not rs.EOF Then
IVS_SceneImages = rs("IVS_SceneImages")
IVS_Close = rs("IVS_Close")
Str = Str & IVS_SceneImages
End If
Exit Function
End If
If Action = "docshow" Then
QsIsiFrame = GetSafeStr(Trim(Request.QueryString("IsiFrame")))
If QsIsiFrame = "" Then IsiFrame_ = IsIframe Else IsiFrame_ = QsIsiFrame End If
If IsiFrame_ = 1 Then
IVS_ID = GetSafeStr(Trim(Request.QueryString("IVS_ID")))
sql = "select IVS_SceneImages,IVS_Close,IVS_ZT"
sql = sql&" from InterViewSort where IVS_ID="&CInt(IVS_ID)&" and IVS_Open=1"
If IVS_ZT<>"" Then
sql = sql & " and IVS_ZT="&IVS_ZT
End If
Set rs = LS.CreateRs(sql, 1, 1)
If Not rs.EOF Then
IVS_Close = rs("IVS_Close")
IVS_zts = rs("IVS_ZT")
End If
rs.Close
Set rs = Nothing
If IVS_ID = "" Or IsNumeric(IVS_ID) = False Then Response.End()
Call InterViewSort(IVS_ID, 30, iName)
Call InterViewDocList(PerdocNumRow, IsInPut, IVS_Close, IVS_zts)
End If
Exit Function
End If
Str = ""
sql = " IVS_SS_ID="&NowSSID&" and IVS_Open=1"
If IVS_ZT<>"" Then
sql = sql & " and IVS_ZT="&IVS_ZT
End If
With LS.DB
.PageSize = PerNumRow'定义页数
.ListLong = 3'页数前后显示个数
.Pkey="IVS_ID"'主键
.Field="IVS_ID,IVS_SS_ID,IVS_Title,IVS_CheckIn,IVS_LinkImage,IVS_Synopsis,IVS_GuestSynopsis,IVS_SceneImages,IVS_Moderator,IVS_Abstract,IVS_Date,IVS_Type,IVS_OrderID,IVS_Open,IVS_HtmlUrl,IVS_Isdel,IVS_linkurl,IVS_zy,IVS_savepathfilename"'字段、尽量不要用*号
.Table="InterViewSort"'表名
.Condition = sql '条件语句，不带用where
.OrderBy="IVS_OrderID desc,IVS_ID desc"'排序,不用带order by
.PageParm = "page" '分页参数名称
.RecordCount = 0'默认0即可。
Set oRs = .ResultSet
.Template = "
"
strPage = .PageNav()'分页列表
End With
If IsNull(oRs) Or oRs.Eof Then
oRs.Close
response.Write "正在更新中..."
Exit Function
End If
gourl="/tmp/"&NowSSURL&"?SS_ID="&nowSSID&"&pp="
If Not oRs.EOF Then
Str = Str & ""&Chr(13)&Chr(10)
End If
Str = Str & "
<%
oRs.Close
Set oRs = Nothing
%>
<%
End If
If IsInPut = 1 And IVS_Close = 0 And IVS_zts = 1 Then
%>
<%
End If
End Sub
'======================================================================================================================
' InterViewimg (ss_id:栏目ID)
'======================================================================================================================
Function InterViewimg(ss_id, NumWords)
Str = ""
If ss_id = "" Or IsNumeric(ss_id) = False Or NumWords = "" Or IsNumeric(NumWords) = False Then Exit Function
sql = "select top 1 IVS_LinkImage,IVS_Title,IVS_GuestSynopsis,IVS_linkurl,IVS_Date,IVS_ID,IVS_SS_ID,IVS_HtmlUrl from InterViewSort Where IVS_SS_ID="&SS_ID&" and IVS_Open=1 and IVS_zt=1 order by IVS_OrderID desc,IVS_ID desc"
Set rs = Ls.CreateRs(sql, 1, 1)
If rs.EOF And rs.bof Then
Response.Write("正在更新中...")
Else
IVS_LinkImage = rs("IVS_LinkImage")
IVS_Title = rs("IVS_Title")
IVS_GuestSynopsis = rs("IVS_GuestSynopsis")
IVS_linkurl = rs("IVS_linkurl")
IVS_Date = rs("IVS_Date")
IVS_ID = rs("IVS_ID")
SS_IDD = rs("IVS_SS_ID")
IVS_HtmlUrl = rs("IVS_HtmlUrl")
If IVS_linkurl<>"" Then
IVS_HtmlUrl = IVS_linkurl
End If
Str = Str & "
"
Str = Str & "
"
Str = Str & "
"&IVS_GuestSynopsis&"
"
Str = Str & "
"&CutStr(IVS_Title, NumWords * 2)&"
"
Str = Str & "
"&IVS_Date&"
"
Str = Str & "
"
End If
rs.Close
Set rs = Nothing
If G_FLAGHTMLTYPE = 1 Then
response.Write(Str)
Else
InterViewimg = Str
End If
End Function
Function InterViewimg1(ss_id, NumWords, Imgwid, Imghig)
Str = ""
If ss_id = "" Or IsNumeric(ss_id) = False Or NumWords = "" Or IsNumeric(NumWords) = False Then Exit Function
sql = "select top 1 IVS_LinkImage,IVS_Title,IVS_GuestSynopsis,IVS_linkurl,IVS_Date,IVS_ID,IVS_SS_ID,IVS_HtmlUrl,IVS_Zy from InterViewSort Where IVS_SS_ID="&SS_ID&" and IVS_Open=1 and IVS_zt=1 order by IVS_OrderID desc,IVS_ID desc"
Set rs = Ls.CreateRs(sql, 1, 1)
If rs.EOF And rs.bof Then
Response.Write("正在更新中...")
Else
IVS_LinkImage = rs("IVS_LinkImage")
IVS_Title = rs("IVS_Title")
IVS_GuestSynopsis = rs("IVS_GuestSynopsis")
IVS_linkurl = rs("IVS_linkurl")
IVS_Date = rs("IVS_Date")
IVS_ID = rs("IVS_ID")
SS_IDD = rs("IVS_SS_ID")
IVS_HtmlUrl = rs("IVS_HtmlUrl")
If IVS_linkurl<>"" Then
IVS_HtmlUrl = IVS_linkurl
End If
IVS_Zy = rs("IVS_Zy")
If IVS_url = "" Then
IVS_url = "正在更新中..."
Else
IVS_url = IVS_url
End If
Str = Str & "
"
Str = Str & "
"
Str = Str & "
"
Str = Str & "
主题："&CutStr(IVS_Title, NumWords * 2)&"
"
Str = Str & "
时间："&IVS_Date&"
"
Str = Str & "
嘉宾："&IVS_GuestSynopsis&"
"
Str = Str & "
内容："&IVS_Zy&"
"
Str = Str & "
"
Str = Str & ""
End If
rs.Close
Set rs = Nothing
If G_FLAGHTMLTYPE = 1 Then
response.Write(Str)
Else
InterViewimg1 = Str
End If
End Function
Function InterViewimg2(ss_id, NumWords, Imgwid, Imghig)
Str = ""
If ss_id = "" Or IsNumeric(ss_id) = False Or NumWords = "" Or IsNumeric(NumWords) = False Then Exit Function
sql = "select top 1 IVS_LinkImage,IVS_Title,IVS_GuestSynopsis,IVS_linkurl,IVS_Date,IVS_ID,IVS_SS_ID,IVS_HtmlUrl,IVS_Zy,IVS_url from InterViewSort Where IVS_SS_ID="&SS_ID&" and IVS_Open=1 and IVS_ZT=1 order by IVS_OrderID desc,IVS_ID desc"
Set rs = Ls.CreateRs(sql, 1, 1)
If rs.EOF And rs.bof Then
Response.Write("正在更新中...")
Else
IVS_LinkImage = rs("IVS_LinkImage")
IVS_Title = rs("IVS_Title")
IVS_GuestSynopsis = rs("IVS_GuestSynopsis")
IVS_linkurl = rs("IVS_linkurl")
IVS_Date = rs("IVS_Date")
IVS_ID = rs("IVS_ID")
SS_IDD = rs("IVS_SS_ID")
IVS_HtmlUrl = rs("IVS_HtmlUrl")
IVS_url = rs("IVS_url")
If IVS_linkurl<>"" Then
IVS_HtmlUrl = IVS_linkurl
End If
IVS_Zy = rs("IVS_Zy")
If IVS_url = "" Then
IVS_url = "正在更新中..."
Else
IVS_url = IVS_url
End If
Str = Str & "
"
Str = Str & "
"
Str = Str & "
"&CutStr(IVS_Title, NumWords * 2)&"
"
Str = Str & "
"
Str = Str & "
访谈嘉宾
"&IVS_GuestSynopsis&"
"
Str = Str & "
访谈时间
"&IVS_Date&"
"
Str = Str & "
直播地址
"&IVS_url&"
"
Str = Str & "
"
Str = Str & "
"&IVS_Zy&"
"
End If
rs.Close
Set rs = Nothing
If G_FLAGHTMLTYPE = 1 Then
response.Write(Str)
Else
InterViewimg2 = Str
End If
End Function
'======================================================================================================================
' InterViewimg (ss_id:栏目ID,NumTr:显示条数)
'======================================================================================================================
Function InterViewlist(SS_ID, NumTr, NumWords)
If ss_id = "" Or IsNumeric(ss_id) = False Or NumTr = "" Or IsNumeric(NumTr) = False Or NumWords = "" Or IsNumeric(NumWords) = False Then Exit Function
Str = ""
Str = Str & "
"
'提取最新主题ID
sql = "select top 1 IVS_ID from InterViewSort Where IVS_SS_ID="&SS_ID&" and IVS_Open=1 and IVS_zt=1 order by IVS_OrderID desc,IVS_ID desc"
Set rs = Ls.CreateRs(sql, 1, 1)
If Not rs.bof Then
IVS_ID = rs("IVS_ID")
End If
rs.Close
Set rs = Nothing
sql = "select top "&NumTr&" IVS_LinkImage,IVS_Title,IVS_GuestSynopsis,IVS_Synopsis,IVS_Date,IVS_ID,IVS_SS_ID,IVS_HtmlUrl from InterViewSort Where IVS_SS_ID="&SS_ID&" and IVS_Open=1 and IVS_zt=1 "
If IVS_ID<>"" And IsNumeric(IVS_ID) Then sql = sql & " and IVS_ID<>"&IVS_ID&""
sql = sql & " order by IVS_OrderID desc,IVS_ID desc"
Set rs = Ls.CreateRs(sql, 1, 1)
If rs.EOF And rs.bof Then
Response.Write("正在更新中...")
Else
For i = 1 To rs.recordcount
If rs.EOF Then
Exit For
Else
IVS_LinkImage = rs("IVS_LinkImage")
IVS_Title = rs("IVS_Title")
IVS_GuestSynopsis = rs("IVS_GuestSynopsis")
IVS_Synopsis = rs("IVS_Synopsis")
IVS_Date = rs("IVS_Date")
IVS_ID = rs("IVS_ID")
SS_IDD = rs("IVS_SS_ID")
IVS_HtmlUrl = rs("IVS_HtmlUrl")
Str = Str & "
"
End If
rs.movenext
Next
End If
rs.Close
Set rs = Nothing
response.Write "
"
If G_FLAGHTMLTYPE = 1 Then
response.Write(Str)
Else
InterViewlist = Str
End If
End Function
' =============================================================================================================================
' 类别列表InterViewSort
' =============================================================================================================================
Function InterViewSort(IVS_ID, TitleNum, UrlPath)
If IVS_ID = "" Or IsNumeric(IVS_ID) = False Then IVS_ID = GetSafeStr(Trim(Request.QueryString("IVS_ID")))
sql = "select IVS_ID,IVS_SS_ID,IVS_Title,IVS_CheckIn,IVS_HtmlUrl,IVS_zy,IVS_LinkImage,IVS_Synopsis,IVS_GuestSynopsis,IVS_SceneImages,IVS_Moderator,IVS_Abstract"
sql = sql &",IVS_Date,IVS_Type,IVS_OrderID,IVS_Open,IVS_originalfilename,IVS_savefilename,IVS_savepathfilename,IVS_Synopsis"
sql = sql&" from InterViewSort where "
If IVS_ID<>"" Then sql = sql&" IVS_ID="&CInt(IVS_ID)&" and "
sql = sql&" IVS_Isdel=0 and IVS_Open=1 order by IVS_OrderID desc,IVS_ID desc"
Set rs = LS.CreateRs(sql, 1, 1)
If rs.EOF Then Exit Function
IVS_ID = rs("IVS_ID")
SS_ID = rs("IVS_SS_ID")
IVS_LinkImage = rs("IVS_LinkImage")
IVS_Title = rs("IVS_Title")
IVS_Date = rs("IVS_Date")
IVS_Moderator = rs("IVS_Moderator")
IVS_GuestSynopsis = rs("IVS_GuestSynopsis")
IVS_Synopsis = rs("IVS_Synopsis")
IVS_zy = rs("IVS_zy")
IVS_HtmlUrl = rs("IVS_HtmlUrl")
IVI_Content = rs("IVS_Synopsis")
%>
<%=IVS_Title%>
时 间<%=IVS_Date%>
嘉 宾<%=IVS_GuestSynopsis%>
主持人<%=IVS_Moderator%>
摘 要<%=IVS_zy%>
访谈实录
<%=IVI_Content%>
<%
rs.Close
Set rs = Nothing
If G_FLAGHTMLTYPE = 1 Then
response.Write(InterViewSort)
Else
InterViewSort = InterViewSort
End If
End Function
Function IVSContents()
If td_ID<>"" And IsNumeric(td_ID) Then
IVS_ID = td_ID
Else
IVS_ID = GetSafeStr(Request.QueryString("IVS_ID"))
End If
If IVS_ID = "" Or IsNumeric(IVS_ID) = False Then Response.End()
sql = "select IVS_Title,IVS_Synopsis,IVS_GuestSynopsis,IVS_Date"
sql = sql&" from InterViewSort where IVS_ID="&CInt(IVS_ID)&" and IVS_Open=1"
Set rs = LS.CreateRs(sql, 1, 1)
If Not rs.EOF Then
tivs_Title = rs("IVS_Title")
tivs_Contents = rs("IVS_Synopsis")
tivs_ftjb = rs("IVS_GuestSynopsis")
tivs_ftrq = rs("IVS_Date")
End If
rs.Close
End Function
'======================================================================================================================
' InterViewimg (首页调用访谈列表;ss_id:栏目ID,NumTr:显示条数)
'======================================================================================================================
Function IndexViewlist(SS_ID, NumTr, Numwords, stype, Datevis)
If stype = "" Or IsNumeric(stype) = False Or ss_id = "" Or IsNumeric(ss_id) = False Or NumTr = "" Or IsNumeric(NumTr) = False Then Exit Function
Str = ""
Str = Str & "
"
sql = "select top "&NumTr&" IVS_LinkImage,IVS_Title,IVS_GuestSynopsis,IVS_Synopsis,IVS_Date,IVS_ID,IVS_SS_ID,IVS_HtmlUrl from InterViewSort Where IVS_Isdel=0 and IVS_Open=1 and IVS_SS_ID="&SS_ID
If stype<>"" Then
sql = sql &" and IVS_zt="&stype
If stype<>"" Then
sql = sql & " and IVS_zt="&stype
End If
End If
sql = sql & " order by IVS_OrderID desc,IVS_ID desc"
Set rs = Ls.CreateRs(sql, 1, 1)
If rs.EOF And rs.bof Then
Response.Write("正在更新中...")
Else
For i = 1 To rs.recordcount
If rs.EOF Then
Exit For
Else
IVS_LinkImage = rs("IVS_LinkImage")
IVS_Title = rs("IVS_Title")
IVS_GuestSynopsis = rs("IVS_GuestSynopsis")
IVS_Synopsis = rs("IVS_Synopsis")
IVS_Date = rs("IVS_Date")
IVS_ID = rs("IVS_ID")
SS_IDD = rs("IVS_SS_ID")
IVS_HtmlUrl = rs("IVS_HtmlUrl")
If Numwords<>"" Then
IVS_Title = CutStr(IVS_Title, Numwords)
End If
Str = Str & "
"&IVS_Title&""
If Datevis = 1 Then
Str = Str &IVS_Date
End If
Str = Str &"
"
End If
rs.movenext
Next
End If
rs.Close
Set rs = Nothing
response.Write "
"
If G_FLAGHTMLTYPE = 1 Then
response.Write(Str)
Else
IndexViewlist = Str
End If
End Function
%>
<%
'站点文章排序
Sub SiteSort(IsMainSite,SortNum,TbBorder,TbSpc,TbPad,TbBgC,TrHig,SiteTitWid,IsShowHeader,SiteHeader,NewCountHeader,TdAlign,TdNavBgC,TdBgC)
If SortNum = "" Then
sql = "SELECT SI_Name,COUNT(d_ID) as DocCount from DocContents,SiteInfo where d_Type=2 and d_CheckIn = 1 and DocContents.SS_SiteID=SiteInfo.SS_SiteID"
Else
sql = "SELECT Top "&SortNum&" SI_Name,COUNT(d_ID) as DocCount from DocContents,SiteInfo where d_Type=2 and d_CheckIn=1 and DocContents.SS_SiteID=SiteInfo.SS_SiteID"
End If
If IsMainSite = False Then
sql = sql & " and SiteInfo.SS_SiteID<>1"
End If
sql = sql & " GROUP BY SI_Name ORDER BY COUNT(d_ID) DESC"
Set rs = LS.CreateRs(sql,1,1)
rscount = rs.recordcount
With Response
If rscount > 0 Then
.write "
"
If IsShowHeader THen
.Write "
"
.Write "
"&SiteHeader&"
"
.Write "
"&NewCountHeader&"
"
.Write "
"
End If
For k = 1 to rscount
SI_Name = rs("SI_Name")
DocCount = rs("DocCount")
.write "
"
.write "
"
.write SI_Name
.write "
"
.write "
"
.Write DocCount
.write "
"
.write "
"
rs.movenext
Next
.write "
"
Else
.Write "暂无站点信息"
End If
End With
rs.close
End Sub
'Call SiteSort(True,"",0,1,0,"#F1F0EF",25,200,True,"站点名称","新闻数","center","#F1F0EF","#FFFFFF")
'单位文章排序
Sub UnitSort(UI_Path,Excl_UI_ID,Excl_UI_Path,TbBorder,TbSpc,TbPad,TbBgC,TrHig,UnitTitWid,IsShowHeader,TdAlign,TdNavBgC,TdBgC,UnitHeader,NewCountHeader)
Dim UnitID(),UnitName(),UnitTotalCount(),ArticleArr()
sql = "select * from UnitsInfo where UI_ID > 0"
If UI_Path <> "" Then sql = sql & " and UI_ID in (select UI_ID from UnitsInfo where UI_Path = '%"&UI_Path&"%')"
If Excl_UI_ID <> "" Then sql = sql & " and UI_ID not in (Excl_UI_ID)"
If Excl_UI_Path <> "" Then sql = sql & " and UI_ID not in (select UI_ID from UnitsInfo where UI_Path = '%"&Excl_UI_Path&"%')"
sql = sql & " order by UI_ID"
Set rs = LS.CreateRs(sql,1,1)
rscount = rs.recordcount
k = rscount-1
With Response
If rscount >0 Then
Redim Preserve UnitID(k),UnitName(k)
for i = 0 to rscount-1
UnitID(i) = rs("UI_ID")
UnitName(i) = rs("UI_Name")
rs.movenext
Next
Else
.Write("暂无注册单位")
.End()
End If
rs.close
Redim Preserve UnitTotalCount(k)
For i = 0 to Ubound(UnitName)
'各单位发布的新闻总数
sql = "select count(d_ID) as totalCount from DocContents where d_CheckIn =1 and UI_Name like '%"&UnitName(i)&"'"
Set rs = LS.CreateRs(sql,1,1)
totalCount = rs("totalCount")
rs.close
If totalCount = "" or IsNull(totalCount) Then
totalCount = 0
End If
UnitTotalCount(i) = totalCount
Next
Redim ArticleArr(k+1,3)
For i = 0 to Ubound(UnitID)
ArticleArr(i,0) = UnitID(i)
ArticleArr(i,1) = UnitName(i)
ArticleArr(i,2) = UnitTotalCount(i)
Next
For i = 0 to k
For m = 0 to k-i
If ArticleArr(m,2) < ArticleArr(m+1,2) Then
For j = 0 to 2
temp = ArticleArr(m+1,j)
ArticleArr(m+1,j) = ArticleArr(m,j)
ArticleArr(m,j) = temp
Next
End If
Next
Next
.write "
"
If IsShowHeader THen
.Write "
"
.Write "
"&UnitHeader&"
"
.Write "
"&NewCountHeader&"
"
.Write "
"
End If
If SortNum <> "" Then k = SortNum
For i = 0 to k
.Write("
")
For j = 1 to 2
If j=1 Then
.write "
"
.write ArticleArr(i,j)
.write "
"
Else
.write "
"
.write ArticleArr(i,j)
.write "
"
End If
Next
.Write("
")
Next
.write "
"
End With
End Sub
'Call UnitSort("","","",0,1,0,"#F1F0EF",25,200,True,"center","#F1F0EF","#FFFFFF","单位","新闻数")
%>
<%
'======================================================================================================================
'左侧领导分类调用(LeaderClass:领导分类ID)
'======================================================================================================================
Function leader(LeaderClass)
if LeaderClass="" or isnumeric(LeaderClass)=false then exit function
Str = ""
sql = "select top 20 LW_ID as id,LW_title as title,LW_name as name,LW_Htmlurl as LW_Htmlurl from LeaderWindow where LW_LeaderClass="&LeaderClass&" and LW_Checkin=1 order by LW_ORDER asc"
Set rs = LS.CreateRs(sql, 1, 1)
rscount = rs.recordcount
If Not rs.EOF Then
Str = Str & "
"
For i = 1 To rscount
id1 = rs("id")
txt1 = rs("title")
xm1 = rs("name")
LW_Htmlurl = rs("LW_Htmlurl")
if id1=1 or id1=2 then
LW_Htmlurl="/tmp/News_shizhangzhichuang.shtml?ss_id="&Nowssid&"&d_id="&id1
else
LW_Htmlurl = LW_Htmlurl
end if
Str = Str & ""&xm1&" "&txt1&""
rs.movenext
Next
Str = Str & "
"
End If
rs.Close:Set rs = Nothing
If G_FLAGHTMLTYPE = 1 Then
response.Write(Str)
Else
leader = Str
End If
End Function
'======================================================================================================================
'左侧领导分类调用(SS_ID:栏目ID,NumWords:字数,LinkUrl:链接地址,ClassName:分类样式,ClassName1:姓名样式)
'======================================================================================================================
Function LeaderLeft(SS_ID, NumWords, LinkUrl, ClassName, ClassName1)
Str = ""
sql = "select LC_ID,LC_TITLE from LeaderClass where LC_SSID="&SS_ID&" order by LC_ID"
Set rs = LS.CreateRs(sql, 1, 1)
rscount = rs.recordcount
If rscount > 0 Then
Str = Str & "
"
For i = 1 To rscount
If rs.EOF Then
Exit For
Else
LC_ID = rs("LC_ID")
LC_TITLE = rs("LC_TITLE")
Str = Str & "
"
sqla = "select LW_ID,LW_Title,LW_name,LW_leaderclass from LeaderWindow where SS_ID="&SS_ID&" and LW_LeaderClass="&LC_ID&" and LW_CheckIn<>0 order by LW_LeaderClass asc,LW_ORDER ASC,LW_ID desc"
Set rsa = LS.CreateRs(sqla, 1, 1)
rscounta = rsa.recordcount
If rscounta > 0 Then
Str = Str & "
"t"&LC_ID Then
Str = Str & " style=""display:none;"""
End If
Str = Str & ">"
For j = 1 To rscounta
If rsa.EOF Then
Exit For
Else
d_ID = rsa("LW_ID")
d_Title = rsa("LW_Title")
d_name = rsa("LW_name")
d_class = rsa("LW_leaderclass")
Str = Str & "
"
End If
rsa.Close
Set rsa = Nothing
End If
rs.movenext
Next
Str = Str & "
"
End If
rs.Close:Set rs = Nothing
If G_FLAGHTMLTYPE = 1 Then
response.Write(Str)
Else
LeaderLeft = Str
End If
End Function
'======================================================================================================================
'首页领导相关信息文字列表(LeaderName:领导名称,SSIDS:多个栏目,NumTr:条数,OrderType:排序,NumWords:字数,DateVis:是否显示日期,ClassVis:是否显示分类)
'======================================================================================================================
Function LeaderindexDocList(LeaderName, SSIDS, NumTr, OrderType, NumWords, DateVis, ClassVis)
If NumTr="" or IsNumeric(NumTr) = False or OrderType="" or isnumeric(OrderType)=false or LeaderName="" Then Exit Function
Str = ""
sql = "select top "&NumTr&" d_ID,d_Title,d_TitleColor,d_RedirectLink,d_Date,d_HtmlUrl,d_Htmlpath,SS_Siteid,"
sql = sql & "d_Author,d_Hit,d_IsHot,ss_id from DocContents where d_IsDel=0 and d_Type in(2,3) and d_CheckIn=1"
If SSIDS<>"" Then
sql = sql & " and SS_ID in ("&SSIDS&")"
End If
sql = sql & " and (d_title like '%"&Replace(LeaderName, " ", "")&"%' or d_keywords like '%"&Replace(LeaderName, " ", "")&"%')"
Select Case OrderType
Case 0
sql = sql & " order by d_TopLock desc,d_No desc,d_Date desc"
Case 1
sql = sql & " order by d_No desc,d_Date desc"
Case 2
sql = sql & " order by d_Date desc,d_No desc"
Case 3
sql = sql & " order by d_Hit desc,d_Date desc"
End Select
Set rs = LS.CreateRs(sql, 1, 1)
rscount = rs.recordcount
If rscount > NumTr Then rscount = NumTr
If rscount > 0 Then
Str = Str & "
"
tNumWords = NumWords*2
For i = 1 To rscount
d_ID = rs("d_ID")
d_Title = rs("d_Title")
d_TitleColor = rs("d_TitleColor")
d_Date = rs("d_Date")
d_IsHot = rs("d_IsHot")
d_Author = rs("d_Author")
d_Hit = rs("d_Hit")
d_HtmlUrl = rs("d_HtmlUrl")
d_Htmlpath = rs("d_Htmlpath")
d_RedirectLink = rs("d_RedirectLink")
d_SSID = rs("SS_ID")
p_SiteID = rs("SS_Siteid")
SS_Name = CCfg(d_SSID,6)
If IsNull(d_RedirectLink) = False And d_RedirectLink<>"" Then
DocURL = d_RedirectLink
Else
DocURL = DocHtmlDir &p_SiteID&"/"& d_Htmlpath&d_HtmlUrl&STATICEXT
End If
Str = Str & "
"
rs.movenext
Next
rs.Close:set rs=nothing
Str = Str & "
"
Else
rs.Close:set rs=nothing
Response.Write "正在更新中..."
End If
If G_FLAGHTMLTYPE = 1 Then
response.Write(Str)
Else
LeaderindexDocList = Str
End If
End Function
'======================================================================================================================
'首页领导相关信息图片列表(LeaderName:领导名称,SSIDS:多个栏目,NumTr:条数,OrderType:排序,NumWords:字数)
'======================================================================================================================
Function Leaderindexpic(LeaderName, SSIDS, NumTr, OrderType, NumWords)
If IsNumeric(NumTr) = False and OrderType="" or isnumeric(OrderType)=false or LeaderName="" Then Exit Function
Str = ""
sql = "select top "&NumTr&" d_ID,d_Title,d_TitleColor,d_RedirectLink,d_Date,d_HtmlUrl,d_Htmlpath,SS_SiteID,"
sql = sql & "d_Author,d_Hit,d_IsHot,ss_id,d_LinkImage from DocContents where d_IsDel=0 and d_Type in(2,3) and d_CheckIn=1 and d_LinkImage<>''"
If SSIDS<>"" Then
sql = sql & " and SS_ID in ("&SSIDS&")"
End If
sql = sql & " and (d_title like '%"&Replace(LeaderName, " ", "")&"%' or d_keywords like '%"&Replace(LeaderName, " ", "")&"%')"
Select Case OrderType
Case 0
sql = sql & " order by d_TopLock desc,d_No desc,d_Date desc"
Case 1
sql = sql & " order by d_No desc,d_Date desc"
Case 2
sql = sql & " order by d_Date desc,d_No desc"
Case 3
sql = sql & " order by d_Hit desc,d_Date desc"
End Select
Set rs = LS.CreateRs(sql, 1, 1)
rscount = rs.recordcount
If rscount > NumTr Then rscount = NumTr
If rscount > 0 Then
Str = Str & "
"
tNumWords = NumWords*2
For i = 1 To rscount
d_ID = rs("d_ID")
d_Title = rs("d_Title")
d_TitleColor = rs("d_TitleColor")
d_Date = rs("d_Date")
d_IsHot = rs("d_IsHot")
d_Author = rs("d_Author")
d_Hit = rs("d_Hit")
d_HtmlUrl = rs("d_HtmlUrl")
d_Htmlpath = rs("d_Htmlpath")
d_RedirectLink = rs("d_RedirectLink")
d_SSID = rs("SS_ID")
d_LinkImage = rs("d_LinkImage")
SS_Name = CCfg(d_SSID,6)
p_SiteID = rs("SS_SiteID")
If IsNull(d_RedirectLink) = False And d_RedirectLink<>"" Then
DocURL = d_RedirectLink
Else
DocURL = DocHtmlDir &p_SiteID&"/"& d_Htmlpath&d_HtmlUrl&STATICEXT
End If
if i=rscount then
Str = Str & "
"
rs.movenext
Next
rs.Close:set rs=nothing
Str = Str & "
"
Else
rs.Close:set rs=nothing
Response.Write "正在更新中..."
End If
If G_FLAGHTMLTYPE = 1 Then
response.Write(Str)
Else
Leaderindexpic = Str
End If
End Function
'======================================================================================================================
'内容页领导相关信息检索
'======================================================================================================================
Function LeaderContents()
id =GetSafeStr(request.QueryString("d_id"))
class1 = GetSafeStr(request.QueryString("class"))
if id<>"" and isnumeric(id) then
sql = "select LW_ID as id,LW_title as title,LW_name as name,LW_LinkImage as images,LW_Contents1 as contents,LW_Contents as contents1,isnull(LW_LeaderClass,0) as LeaderClass,SS_ID as ss_id,LW_Htmlurl from LeaderWindow where LW_ID="&id
else
if class1<>"" and isnumeric(class1) then
sql = "select LW_ID as id,LW_title as title,LW_name as name,LW_LinkImage as images,LW_Contents1 as contents,LW_Contents as contents1,isnull(LW_LeaderClass,0) as LeaderClass,SS_ID as ss_id,LW_Htmlurl from LeaderWindow where LW_LeaderClass="&class1&" and lw_checkin=1 order by LW_ORDER asc,LW_ID asc"
else
sql = "select LW_ID as id,LW_title as title,LW_name as name,LW_LinkImage as images,LW_Contents1 as contents,LW_Contents as contents1,isnull(LW_LeaderClass,0) as LeaderClass,SS_ID as ss_id,LW_Htmlurl from LeaderWindow where lw_checkin=1 order by LW_ORDER asc,LW_ID asc"
end if
end if
set rs = LS.CreateRs(sql,1,1)
if not rs.eof then
lid = rs("id")
Ljob = rs("title")
NowSSID = rs("SS_ID")
Lname = rs("name")
Lphoto = rs("images")
LJobContents = rs("contents1")
LJobFengong = rs("contents")
Lhtmlurl = rs("LW_Htmlurl")
LeaderClass = rs("LeaderClass"):if LeaderClass="" or isnull(LeaderClass) then LeaderClass=0
if len(Lphoto)=0 or Lphoto="#" then Lphoto="/tmp/images/ld_pic.jpg"
end if
rs.close:set rs=nothing
set ems=LS.CreateRs("select SS_ID from SiteStructure where PSS_ID=3 and SS_Name like'%"&replace(replace(xm," ","")," ","")&"%'",1,1)
if not ems.eof then
KSS_ID=ems("SS_ID")
else
KSS_ID= 0
end if
If G_FLAGHTMLTYPE = 1 Then
response.Write(Str)
Else
LeaderContents = Str
End If
End Function
%>
<%
'存储过程读取当前位置
Public Function XxgkReplace(cid, uid)
Set Conn = LS.CreateConn()
If cid = "" Or uid = "" Or IsNumeric(cid) = False Or IsNumeric(uid) = False Then Exit Function
Set cmd = server.CreateObject("Adodb.Command")
cmd.ActiveConnection = Conn
cmd.CommandType = 4
cmd.commandText = "GetxxgkNames"
cmd("@id") = cid
cmd("@uid") = uid
cmd.Execute()
rv = cmd("@return_value")
XxgkReplace = rv '显示返回值
End Function
'存储过程读取分配信息
Public Function ReadId(d_id)
Set Conn = LS.CreateConn()
If d_id = "" Then Exit Function
Set cmd = server.CreateObject("Adodb.Command")
cmd.ActiveConnection = Conn
cmd.CommandType = 4
cmd.commandText = "GetXXGK_Class"
cmd("@id") = d_id
cmd.Execute()
rv = cmd("@return_value")
ReadId = rv '显示返回值
End Function
'存储过程读取信息公开栏目下的所有子栏目
Public Function readclassid(id)
Set conn = LS.CreateConn()
If id = "" Then Exit Function
Set rs = server.CreateObject("adodb.recordset")
sql = "exec GetXxgkCid1 "&id&""
rs.Open sql, conn, 1, 1
rv = rs("return_value")
rv = Left(rv, Len(rv) -1)
readclassid = rv '显示返回值
rs.Close
Set rs = Nothing
End Function
'读取组配分类名称
Function ReadClassName(d_id, Path)
If d_id = "" Or IsNumeric(d_id) = False Or Path = "" Then Exit Function
Zclassdx = ""
classId_ = ReadId(d_id)
If classId_="" Then Exit Function
LXMsql = "select className from tb_xxgk_class where path like '"&Path&"%' and classId in("& classId_ &")"
Set LXMrs = LS.CreateRs(LXMsql, 1, 1)
If Not LXMrs.bof Then
For i = 1 To LXMrs.recordcount
If i = LXMrs.recordcount Then
Zclassdx = Zclassdx & LXMrs("className")
Else
Zclassdx = Zclassdx & LXMrs("className") & ","
End If
LXMrs.movenext
Next
ReadClassName = Zclassdx
End If
LXMrs.Close
Set LXMrs = Nothing
End Function
'======================================================================================================================
'读取栏目路径
'======================================================================================================================
Function CReadSSPath(CatalogID)
If CatalogID = "" Or IsNumeric(CatalogID) = False Then Exit Function
sql = "select Path from tb_xxgk_catalog where catalogId="&CatalogID
Set rs = LS.CreateRs(sql, 1, 1)
If Not rs.bof Then
CReadSSPath = rs("Path")
End If
rs.Close
Set rs = Nothing
End Function
'======================================================================================================================
' 各部门下单位分类(UnitsID:单位ID,NumTr:条数)
'======================================================================================================================
Public Function IndexUnitslist(Cid, NumTr, Numwords)
If Cid = "" Or IsNumeric(Cid) = False Or NumTr = "" Or IsNumeric(NumTr) = False Then Exit Function
Str = ""
Str = Str &"
"
sql = "select top "&NumTr&" unitsId,unitsName,unitHtml from tb_common_units where catalogId="&Cid&" order by orderId asc"
Set rs = Ls.CreateRs(sql, 1, 1)
If Not rs.bof Then
For i = 1 To rs.recordcount
unitsId = rs("unitsId")
unitsName = rs("unitsName")
unitHtml = rs("unitHtml")
If Numwords<>"" And IsNumeric(Numwords) Then unitsName = cutstr(unitsName, Numwords * 2)
Str = Str &"
"
rs.movenext
Next
End If
rs.Close
Set rs = Nothing
Str = Str &"
"
If G_FLAGHTMLTYPE Then
response.Write(Str)
Else
IndexUnitslist = Str
End If
End Function
'======================================================================================================================
' 友情链接显示各栏目下单位名称(CID:分类ID,MenuName:下拉名称)
'======================================================================================================================
Public Function IndexDocClassList(CID, MenuName)
If CID = "" Or IsNumeric(CID) = False Then Exit Function
Str = ""
Str = Str &""
If G_FLAGHTMLTYPE Then
response.Write(Str)
Else
IndexDocClassList = Str
End If
End Function
'======================================================================================================================
' 首页调用某单位下所有信息公文章(docSiteId:站点ID,UnitID:单位ID,CatalogID:分类ID,NumTr:条数,NumWords:字数,DateVis:是否显示日期,OrderNum:排序 0按时排排序 1按序号排序)【加有缓存】
'======================================================================================================================
Public Function IndexDocOpenLists(docSiteId, UnitID, CatalogID, SubIs, OrderNum, NumTr, NumWords, DateVis)
If NumTr = "" Or IsNumeric(NumTr) = False Then Exit Function
Dim v_CacheName
v_CacheName = G_CACHENAME & "_IndexDocOpenLists_" & CatalogID
Str = ""
If Not IsEmpty(Application(v_CacheName)) And G_ALLCACHE Then
Str = Application(v_CacheName)
Else
sql = "select top "&NumTr&" a.docID,a.docTitle,a.docDateline,a.docHtmlUrl,a.docOorderId,a.docHits,a.docNum,b.unitsName from tb_xxgk_contents as a left join tb_common_units as b on a.docUnitsID=b.unitsId where a.docCheckIn=1 and a.docIsDel=0 and docType=2"
If docSiteId<>"" And IsNumeric(docSiteId) Then
sql = sql & " and a.docSiteId="&docSiteId
End If
If UnitID<>"" And IsNumeric(UnitID) Then
sql = sql & " and a.docUnitsID="&UnitID
End If
If SubIs<>"" And CatalogID<>"" And IsNumeric(CatalogID) Then
sql = sql & " and a.docCatalogID IN("&readclassid(CatalogID)&")"
End If
If OrderNum<>"" And IsNumeric(OrderNum) Then
If OrderNum = 0 Then
sql = sql & " order by a.docDateline desc,a.docID desc"
ElseIf OrderNum = 1 Then
sql = sql & " order by a.docOorderId desc,a.docDateline desc,a.docID desc"
End If
End If
Set rs = LS.CreateRs(sql, 1, 1)
rscount = rs.recordcount
If rscount > NumTr Then rscount = NumTr
If rscount > 0 Then
For i = 1 To rscount
ul_even = ""
If i mod 2=0 Then ul_even = "even"
Str = Str & "
"
If DateVis = 1 Or HitVis = 1 Then
If DateVis = 1 Then Str = Str &" "&d_Date
End If
Str = Str & "
"
Str = Str & "
"
rs.movenext
Next
rs.Close
Set rs = Nothing
Else
rs.Close
Set rs = Nothing
response.Write "正在更新中..."
End If
If G_ALLCACHE Then
Application.Lock
Application(v_CacheName) = Str
Application.UnLock
End If
End If
If G_FLAGHTMLTYPE Then
response.Write(Str)
Else
IndexDocOpenLists = Str
End If
End Function
'======================================================================================================================
' 首页调用某单位下所有信息公开文章(SS_Siteid:站点ID，UnitID:单位ID,CatalogID:分类ID,NumTr:条数,NumWords:字数,DateVis:是否显示日期)【不加缓存】
'======================================================================================================================
Public Function IndexUnitsDocOpenList(SS_Siteid , UnitID, CatalogID, SubIs, NumTr, NumWords, DateVis)
If NumTr = "" Or IsNumeric(NumTr) = False Or SS_Siteid = "" Or IsNumeric(SS_Siteid) = False Then Exit Function
Str = ""
sql = "select top "&NumTr&" docID,docTitle,docDateline,docHtmlUrl,docHits from tb_xxgk_contents where docSiteId="&SS_Siteid&" and docCheckIn=1 and docType=2 and docIsDel=0"
If UnitID<>"" Then
sql = sql & " and docUnitsID="&UnitID
End If
If SubIs<>"" Then
If SubIs = 1 And CatalogID<>"" And IsNumeric(CatalogID) Then
sql = sql & " and docCatalogID IN("& readclassid(CatalogID) &")"
Else
sql = sql & " and docCatalogID="&CatalogID
End If
End If
sql = sql & " order by docDateline desc"
Set rs = LS.CreateRs(sql, 1, 1)
rscount = rs.recordcount
If rscount > NumTr Then rscount = NumTr
If rscount > 0 Then
Str = Str & "
"
For i = 1 To rscount
d_ID = rs("docID")
d_Title = rs("docTitle")
d_Date = Ls.datetime(rs("docDateline"), "yyyy-mm-dd")
d_HtmlUrl = rs("docHtmlUrl")
d_Hit = rs("docHits")
Str = Str & "
"
rs.movenext
Next
rs.Close
Set rs = Nothing
Str = Str & "
"
Else
rs.Close
Set rs = Nothing
response.Write "正在更新中..."
End If
If G_FLAGHTMLTYPE Then
response.Write(Str)
Else
IndexUnitsDocOpenList = Str
End If
End Function
'======================================================================================================================
'信息公开内容页调取相关字段
'======================================================================================================================
Public Function xxgk_doccontent()
If td_ID<>"" Then
xd_ID = td_ID
Else
xd_ID = GetSafeStr(Request.QueryString("d_ID"))
End If
If xd_ID = "" Then response.End()
sql = "select docCheckIn,doctype,docTitle,docKeyWords,docDateline,docIndex,docNum,docContent,docCatalogID,docCatalogPath,docClassID,docHits,docUnitsID "
sql = sql & " ,className,catalogTitle,unitsName"
sql = sql & " from v_tb_xxgk_contents where docID='" & xd_ID & "'"
Set rs = LS.CreateRs(sql, 1, 1)
If Not rs.EOF Then
d_CheckIn = rs("docCheckIn")
doctype = rs("doctype")
td_Title = rs("docTitle")
td_KeyWords = rs("docKeyWords")
td_Date = rs("docDateline")
td_Resource = rs("docIndex")
td_docnum = rs("docNum")
td_Contents = rs("docContent")
td_SSID = rs("docCatalogID")
td_docCatalogPath = rs("docCatalogPath")
td_sx = rs("docClassID")
td_Hit = rs("docHits")
td_docUnitsID = rs("docUnitsID")
catalogTitle = rs("catalogTitle")
td_unitsName = rs("unitsName")
td_catalogTitle = rs("catalogTitle")
End If
rs.Close
Set rs = Nothing
Select Case doctype
Case 4
catalogTitle = "公开年报"
Case 6
catalogTitle = "公开指南"
Case 8
catalogTitle = "公开规定"
End Select
td_replace = XxgkReplace(td_SSID, td_docUnitsID)
If G_FLAGHTMLTYPE Then
response.Write(Str)
Else
xxgk_doccontent = Str
End If
End Function
'======================================================================================================================
' 当月单位信息排行调用(SS_Siteid:站点ID,Nums:行数,Icons:小图片地址)
'======================================================================================================================
Public Function IndexMonthdoclist(SS_Siteid, Nums, Icons1)
If Nums = "" Or IsNumeric(Nums) = False Or SS_Siteid = "" Or IsNumeric(SS_Siteid) = False Then response.End()
Str = ""
sql = "select top "&Nums&" ISNULL(MonthTotalCount,0) as MonthTotalCount,a.unitsId,a.unitsName,a.Path FROM tb_common_units as a left join (select count(docId) as MonthTotalCount,docUnitsID from tb_xxgk_contents where docCheckIn=1 and docIsDel=0 and docSiteId="&SS_Siteid&" and month(docDateline)="&Month(Date())&" and year(docDateline)="&Year(Date())&" group by docUnitsID) as b on a.unitsId=b.docUnitsID order by MonthTotalCount desc"
Set Rs = Ls.CreateRs(sql, 1, 1)
rscount = Rs.recordcount
If rscount>0 Then
Str = Str &"
"
For i = 1 To rscount
TotalCount = Rs("MonthTotalCount")
unitsName = Rs("unitsName")
unitsId = Rs("unitsId")
Str = Str & "
"
Str = Str & "
"&unitsName&"
"
Str = Str & "
"&TotalCount&"
"
Str = Str & "
"
rs.movenext
Next
Str = Str &"
"
End If
rs.Close
Set rs = Nothing
If G_FLAGHTMLTYPE Then
response.Write(Str)
Else
IndexMonthdoclist = Str
End If
End Function
'======================================================================================================================
' 当季度单位信息排行调用(SS_Siteid:站点ID,Nums:行数,Icons:小图片地址)
'======================================================================================================================
Public Function IndexQuarterdoclist(SS_Siteid, Nums, Icons)
If Nums = "" Or IsNumeric(Nums) = False Or SS_Siteid = "" Or IsNumeric(SS_Siteid) = False Then response.End()
Str = ""
getmonth = "|"&Month(Date())&"|"
If InStr("|1|2|3|", getmonth)>0 Then
jidustr = " and (month(docDateline)=1 or month(docDateline)=2 or month(docDateline)=3) and year(docDateline)="&Year(Date())
ElseIf InStr("|4|5|6|", getmonth)>0 Then
jidustr = " and (month(docDateline)=4 or month(docDateline)=5 or month(docDateline)=6) and year(docDateline)="&Year(Date())
ElseIf InStr("|7|8|9|", getmonth)>0 Then
jidustr = " and (month(docDateline)=7 or month(docDateline)=8 or month(docDateline)=9) and year(docDateline)="&Year(Date())
ElseIf InStr("|10|11|12|", getmonth)>0 Then
jidustr = " and (month(docDateline)=10 or month(docDateline)=11 or month(docDateline)=12) and year(docDateline)="&Year(Date())
End If
Str = Str &"
"
sql = "select top "&Nums&" ISNULL(TotalCount,0) as TotalCount,a.unitsId,a.unitsName,a.Path FROM tb_common_units as a left join (select count(docId) as TotalCount,docUnitsID from tb_xxgk_contents where docCheckIn=1 and docIsDel=0 and docSiteId="&SS_Siteid&""&jidustr&" group by docUnitsID) as b on a.unitsId=b.docUnitsID order by TotalCount desc"
Set Rs = Ls.CreateRs(sql, 1, 1)
rscount = Rs.recordcount
If rscount>0 Then
For i = 1 To rscount
TotalCount = Rs("TotalCount")
unitsName = Rs("unitsName")
unitsId = Rs("unitsId")
Str = Str & "
"
Str = Str & "
"&unitsName&"
"
Str = Str & "
"&TotalCount&"
"
Str = Str & "
"
rs.movenext
Next
Str = Str &"
"
rs.Close
Set rs = Nothing
End If
If G_FLAGHTMLTYPE Then
response.Write(Str)
Else
IndexMonthdoclist = Str
End If
End Function
'======================================================================================================================
' 本年度单位信息排行调用(Nums:行数,Icons:小图片地址)
'======================================================================================================================
Public Function IndexYeardoclist(SS_Siteid, Nums, Icons)
If Nums = "" Or IsNumeric(Nums) = False Or SS_Siteid = "" Or IsNumeric(SS_Siteid) = False Then response.End()
Str = ""
jidustr = " and year(docDateline)="&Year(Date())
sql = "select top "&Nums&" ISNULL(TotalCount,0) as TotalCount,a.unitsId,a.unitsName,a.Path FROM tb_common_units as a left join (select count(docId) as TotalCount,docUnitsID from tb_xxgk_contents where docCheckIn=1 and docisdel=0 and docSiteId="&SS_Siteid&""&jidustr&" group by docUnitsID) as b on a.unitsId=b.docUnitsID order by TotalCount desc"
Set Rs = Ls.CreateRs(sql, 1, 1)
rscount = Rs.recordcount
If rscount>0 Then
For i = 1 To rscount
Str = Str &"
"
TotalCount = Rs("TotalCount")
unitsName = Rs("unitsName")
unitsId = Rs("unitsId")
If i = 1 Or i = 2 Then
Str = Str & "
"
rs.movenext
Next
rs.Close
Set rs = Nothing
End If
If G_FLAGHTMLTYPE Then
response.Write(Str)
Else
IndexYeardoclist = Str
End If
End Function
'======================================================================================================================
' 信息公开搜索列表(UnitsID:单位ID,CatalogID:栏目ID,NumTr:条数,MenuName:下拉名称)
'======================================================================================================================
Public Function XxgkSearchList(SS_Siteid, PerNumRow, NumWords, ContentWords, DateVis, SqhVis, HitVis)
Str = ""
s_type = LS.toClng(Trim(Request("s_type")))
unitid = LS.toClng(Trim(Request("unitid")))
d_BeginTime = LS.FormatSQL(Trim(Request("d_BeginTime")))
d_EndTime = LS.FormatSQL(Trim(Request("d_EndTime")))
SearchWords = LS.FormatSQL(Trim(Request("SearchWords")))
If SearchWords = "" Then
OutScript("请输入关键字！")
Exit Function
End If
If (SS_SiteID <> "" And IsNumeric(SS_SiteID) = False) Or (PerNumRow <> "" And IsNumeric(PerNumRow) = False) Then Exit Function
sql = " docIsDel=0 and docType=2 and docCheckIn=1"
If unitid<>0 Then
sql = sql &" and docUnitsID="&unitid
End If
'If SearchWords <> "" Then
' sql = sql&" and (docTitle like '%"&SearchWords&"%' or docNum like '%"&SearchWords&"%' or docIndex like '%"&SearchWords&"%')"
'End If
If SearchWords <> "" Then
If s_type<>0 Then
If s_type = 1 Then
sql = sql&" and docTitle like '%"&SearchWords&"%'"
ElseIf s_type = 2 Then
sql = sql&" and docNum like '%"&SearchWords&"%'"
ElseIf s_type = 3 Then
sql = sql&" and docIndex like '%"&SearchWords&"%'"
ElseIf s_type = 4 Then
sql = sql&" and docContent like '%"&SearchWords&"%'"
End If
Else
sql = sql&" and (docTitle like '%"&SearchWords&"%' or docNum like '%"&SearchWords&"%' or docIndex like '%"&SearchWords&"%')"
End If
End If
If d_BeginTime<>"" Or d_EndTime<>"" Then
If d_BeginTime<>"" And IsDate(d_BeginTime) Then
sql = sql&" and docDateline>='"&d_BeginTime&"'"
End If
If d_EndTime<>"" And IsDate(d_EndTime) Then
sql = sql&" and docDateline<='"&d_EndTime&"'"
End If
End If
'默认分页样式名称 pagination
With LS.DB
.PageSize = CInt(PerNumRow)'定义页数
.ListLong = 3'页数前后显示个数
.Pkey = "docId"'主键
.Field = "docId,docTitle,docDateline,docHits,docHtmlUrl,docIndex,docShortContent,docContent"'字段，尽量不要用*号
.Table = "tb_xxgk_contents"'表名
.Condition = sql '条件语句，不带用where
.OrderBy = "docDateline desc,docOorderId desc"'排序,不用带order by
.RecordCount = 0'默认0即可。
Set oRs = .ResultSet
strPage = .PageNav()'分页列表
End With
If oRs.EOF Then
oRs.Close
response.Write "抱歉！未找到符合条件的内容。"
Exit Function
End If
Str = Str & "
"
Do While Not oRs.EOF
tNumWords = NumWords * 2
docId = oRs("docId")
docTitle = oRs("docTitle")
docDateline = oRs("docDateline")
docHits = oRs("docHits")
docHtmlUrl = oRs("docHtmlUrl")
docShortContent = oRs("docShortContent")
docIndex = oRs("docIndex")
docContent = oRs("docContent")
If ContentWords<>"" And IsNumeric(ContentWords) Then
docContent = CutStr(MoveHTML(docContent), ContentWords * 2)
End If
docDateline = LS.DateTime(docDateline, "yyyy-mm-dd")
d_Title = Replace(docTitle, SearchWords, ""&SearchWords&"", 1, -1, 1)
Str = Str & "
"&CCfg(SS_Siteid, 12)&docHtmlUrl&""
If SqhVis = 1 Then Str = Str & "索引号："&docIndex&""
If HitVis = 1 Then Str = Str & " [点击率："&docHits&"]"
Str = Str & "
"
Str = Str & "
"
oRs.movenext
Loop
Str = Str & "
"
If LS.DB.Recordcount>CInt(PerNumRow) Then
Str = Str & strPage
end if
Str = Str & ""
oRs.Close
Set oRs = Nothing
If G_FLAGHTMLTYPE Then
response.Write(Str)
Else
XxgkSearchList = Str
End If
End Function
'=====================================================================
'目录管理列表 (SSIDS:一级栏目ID)
'=====================================================================
Public Function MuluList(SSIDS)
If SSIDS = "" Then response.End()
LXMsql = "select catalogId,catalogTitle from tb_xxgk_catalog where catalogPid=0 and catalogId in("&SSIDS&") order by Path asc"
Set LXMrs = Ls.CreateRs(LXMsql, 1, 1)
LXMrscount = LXMrs.recordcount
If LXMrscount>0 Then
For i = 1 To LXMrscount
catalogId = LXMrs("catalogId")
catalogTitle = LXMrs("catalogTitle")
%>
<%=catalogTitle%>信息公开目录
<%
DWsql = "select unitsName,unitHtml,unitsId from tb_common_units where catalogId="&catalogId
Set DWrs = Ls.CreateRs(DWsql, 1, 1)
DWrscount = DWrs.recordcount
If DWrscount>0 Then
For j = 1 To DWrscount
unitsName = DWrs("unitsName")
unitHtml = DWrs("unitHtml")
unitsId = DWrs("unitsId")
%>
<%
If j = DWrscount And j / 2<>Int(j / 2) Then
response.Write "
"
End If
If j / 2 = Int(j / 2) And j<>DWrscount Then
response.Write "
"
End If
DWrs.movenext
Next
End If
DWrs.Close
Set DWrs = Nothing
%>
<%
LXMrs.movenext
Next
End If
LXMrs.Close
Set LXMrs = Nothing
End Function
'=====================================================================
'信息统计分析
'=====================================================================
Public Function InfolistCount(SS_Siteid)
If SS_Siteid = "" Or IsNumeric(SS_Siteid) = False Then response.End()
Str = ""
Str = Str & "
"
Str = Str & "
"
Str = Str & "
单位名称
"
Str = Str & "
主动公开信息
"
Str = Str & "
收到申请公开数
"
Str = Str & "
已回复数
"
Str = Str & "
合计
"
Str = Str & "
"
HTotalCount = 0
HTotalYcount = 0
HTotalRcount = 0
strWhere = ""
strWhereply = ""
beginTime = GetSafeStr(Request("d_BeginTime"))
endTime = GetSafeStr(Request("d_EndTime"))
unitid = Request("unitid")
If beginTime<>"" And IsDate(beginTime) Then
'信息公开文章统计
strWhere = " AND DATEDIFF(DAY,docDateline,'"& beginTime &"')=0"
If endTime<>"" And IsDate(endTime) Then
strWhere = " AND docDateline BETWEEN '"& beginTime &" 00:00:00' AND '"& endTime &" 23:59:59'"
End If
'依申请公开公开文章统计
strWhereply = " AND DATEDIFF(DAY,dateLine,'"& beginTime &"')=0"
If endTime<>"" Then
strWhereply = " AND dateLine BETWEEN '"& beginTime &" 00:00:00' AND '"& endTime &" 23:59:59'"
End If
End If
If unitid<>"" And IsNumeric(unitid) Then
strWhere = strWhere & " and docUnitsID="&unitid
strWhereply = strWhereply & " and unitsId="&unitid
End If
sqlt = "select ISNULL(TotalCount,0) as TotalCount,ISNULL(TotalYcount,0) as TotalYcount,ISNULL(TotalRcount,0) as TotalRcount,a.unitsId,a.unitsName,a.unitHtml from tb_common_units as a left join (select count(docID) as TotalCount,docUnitsID from tb_xxgk_contents where docIsDel=0 and docCheckIn=1 and docType=2 "&strWhere&" group by docUnitsID) as b on a.unitsId=b.docUnitsID left join (select count(applyId) as TotalYcount,unitsId from tb_xxgk_apply where 1=1 "&strWhereply&" group by unitsId) as c on a.unitsId=c.unitsId left join (select count(applyId) as TotalRcount,unitsId from tb_xxgk_apply where 1=1 and isRevert=1 "&strWhereply&" group by unitsId) as d on a.unitsId=d.unitsId where 1=1"
If unitid<>"" And IsNumeric(unitid) Then
sqlt = sqlt &" and a.unitsId="&unitid
End If
sqlt = sqlt &" order by a.unitsId asc"
Set rst = Ls.CreateRs(sqlt, 1, 1)
rscount = rst.recordcount
If rscount>0 Then
For i = 1 To rscount
TotalCount = rst("TotalCount")
unitsId = rst("unitsId")
unitHtml = rst("unitHtml")
unitsName = rst("unitsName")
TotalYcount = rst("TotalYcount")
TotalRcount = rst("TotalRcount")
HTotalCount = HTotalCount + TotalCount
HTotalYcount = HTotalYcount + TotalYcount
HTotalRcount = HTotalRcount + TotalRcount
DtotalRcount = TotalCount + TotalYcount
Str = Str & "
"
rst.movenext
Next
End If
rst.Close
Set rst = Nothing
Counttotal = HTotalCount + HTotalYcount
Str = Str & "
"
Str = Str & "
合计： "&rscount&"
"
Str = Str & "
"&HTotalCount&"
"
Str = Str & "
"&HTotalYcount&"
"
Str = Str & "
"&HTotalRcount&"
"
Str = Str & "
"&Counttotal&"
"
Str = Str & "
"
Str = Str & "
"
If G_FLAGHTMLTYPE Then
response.Write(Str)
Else
InfolistCount = Str
End If
End Function
'=====================================================================
'依申请公开统计
'=====================================================================
Public Function ApplylistCount(SS_Siteid)
If SS_Siteid = "" Or IsNumeric(SS_Siteid) = False Then response.End()
Str = ""
Str = Str & "
"
Str = Str & "
"
Str = Str & "
单位名称
"
Str = Str & "
收到申请公开数
"
Str = Str & "
已回复数
"
Str = Str & "
"
HTotalYcount = 0
HTotalRcount = 0
strWhereply = ""
beginTime = GetSafeStr(Request("firstDate"))
endTime = GetSafeStr(Request("lastDate"))
unitid = Request("unitid")
If beginTime<>"" And IsDate(beginTime) Then
'依申请公开公开文章统计
strWhereply = " AND DATEDIFF(DAY,dateLine,'"& beginTime &"')=0"
If endTime<>"" And IsDate(endTime) Then
strWhereply = " AND dataLine BETWEEN '"& beginTime &"' AND '"& endTime &"'"
End If
End If
If unitid<>"" And IsNumeric(unitid) Then
strWhereply = strWhereply & " and unitsId="&unitid
End If
sqlt = "select ISNULL(TotalYcount,0) as TotalYcount,ISNULL(TotalRcount,0) as TotalRcount,a.unitsId,a.unitsName,a.unitHtml from tb_common_units as a left join (select count(applyId) as TotalYcount,unitsId from tb_xxgk_apply where 1=1 "&strWhereply&" group by unitsId) as c on a.unitsId=c.unitsId left join (select count(applyId) as TotalRcount,unitsId from tb_xxgk_apply where 1=1 and isRevert=1 "&strWhereply&" group by unitsId) as d on a.unitsId=d.unitsId where 1=1"
If unitid<>"" And IsNumeric(unitid) Then
sqlt = sqlt &" and a.unitsId="&unitid
End If
sqlt = sqlt &" order by a.unitsId asc"
Set rst = Ls.CreateRs(sqlt, 1, 1)
rscount = rst.recordcount
If rscount>0 Then
For i = 1 To rscount
unitsId = rst("unitsId")
unitHtml = rst("unitHtml")
unitsName = rst("unitsName")
TotalYcount = rst("TotalYcount")
TotalRcount = rst("TotalRcount")
HTotalYcount = HTotalYcount + TotalYcount
HTotalRcount = HTotalRcount + TotalRcount
Str = Str & "
"
rst.movenext
Next
End If
rst.Close
Set rst = Nothing
Str = Str & "
"
Str = Str & "
单位合计："&rscount&"
"
Str = Str & "
收到申请公开数总数："&HTotalYcount&"
"
Str = Str & "
已回复数总数："&HTotalRcount&"
"
Str = Str & "
"
Str = Str & "
"
If G_FLAGHTMLTYPE Then
response.Write(Str)
Else
ApplylistCount = Str
End If
End Function
'==================================================
'依申请公开目录
'==================================================
Public Function Ysqgklist(PerNumRow, SS_Siteid)
If PerNumRow = "" Or IsNumeric(PerNumRow) = False Or SS_Siteid = "" Or IsNumeric(SS_Siteid) = False Then response.End()
%>
序号
索引号
信息名称
生成日期
<%
s_type = LS.toClng(Trim(Request("s_type")))
d_BeginTime = LS.FormatSQL(Trim(Request("firstDate")))
d_EndTime = LS.FormatSQL(Trim(Request("lastDate")))
SearchWords = LS.FormatSQL(Trim(Request.Form("SearchWords")))
sql = " docCheckIn<>0 and docSiteId="&SS_Siteid&" and docisdel=0"
sql = sql &" and docCatalogID in(select catalogId from tb_xxgk_catalog where catalogTitle='依申请公开目录')"
If SearchWords <> "" And s_type<>0 Then
If s_type = 1 Then
sql = sql&" and docTitle like '%"&SearchWords&"%'"
ElseIf s_type = 2 Then
sql = sql&" and docNum like '%"&SearchWords&"%'"
Else
sql = sql&" and docIndex like '%"&SearchWords&"%'"
End If
End If
If d_BeginTime<>"" Or d_EndTime<>"" Then
If d_BeginTime<>"" And IsDate(d_BeginTime) Then
sql = sql&" and docDateline>='"&d_BeginTime&"'"
End If
If d_EndTime<>"" And IsDate(d_EndTime) Then
sql = sql&" and docDateline<='"&d_EndTime&"'"
End If
End If
If docCatalogPath<>"" Then
sql = sql&" and docCatalogPath like '"&docCatalogPath&"%'"
End If
If Types<>"" Then
sql = sql&" and docType ="&Types&""
Else
sql = sql&" and docType =2"
End If
'默认分页样式名称 pagination
With LS.DB
.PageSize = CInt(PerNumRow)'定义页数
.ListLong = 3'页数前后显示个数
.Pkey = "docID"'主键
.Field = "docID,docTitle,docIndex,docDateline,docKeyWords,docNum,docHtmlUrl,docShortContent"'字段，尽量不要用*号
.Table = "tb_xxgk_contents"'表名
.Condition = sql '条件语句，不带用where
.OrderBy = "docDateline desc"'排序,不用带order by
.RecordCount = 0'默认0即可。
Set oRs = .ResultSet
strPage = .PageNav()'分页列表
End With
If oRs.EOF Then
Response.Write "
抱歉，未找到记录！
"
End If
i = 1
If Not IsNull(oRs) Then
Do While Not oRs.EOF
d_ID = oRs("docID")
d_Title = oRs("docTitle")
d_sqh = oRs("docIndex")
d_date = oRs("docDateline")
d_keywords = oRs("docKeyWords")
d_fwh = oRs("docNum")
docShortContent = oRs("docShortContent")
d_HtmlUrl = oRs("docHtmlUrl")
d_date = LS.DateTime(d_date, "yyyy-mm-dd")
%>
<%
oRs.Close
Set oRs = Nothing
End Function
'==================================================
'依申请公开列表
'==================================================
Public Function Gongkailist(PerNumRow, SS_Siteid, NumWords)
If PerNumRow = "" Or IsNumeric(PerNumRow) = False Or SS_Siteid = "" Or IsNumeric(SS_Siteid) = False Or NumWords = "" Or IsNumeric(NumWords) = False Then response.End()
unitsid = GetSafeStr(Trim(Request("unitsid")))
%>
序号
申请内容
申请人
受理单位
申请时间
当前状态
<%
sqlt = "siteId="&SS_Siteid&" and checkIn=1"
If unitsid<>"" And IsNumeric(unitsid) Then
sqlt = sqlt&" and unitsId="&unitsid
End If
'默认分页样式名称 pagination
With LS.DB
.PageSize = CInt(PerNumRow)'定义页数
.ListLong = 3'页数前后显示个数
.Pkey = "applyId"'主键
.Field = "applyId,description,userName,unitsId,dataLine,revertType,unitsName"'字段，尽量不要用*号
.Table = "v_applyname"'表名
.Condition = sqlt '条件语句，不带用where
.OrderBy = "applyId desc"'排序,不用带order by
.RecordCount = 0'默认0即可。
Set oRs = .ResultSet
strPage = .PageNav()'分页列表
End With
Do While Not oRs.EOF
applyId = oRs("applyId")
description1 = oRs("description")
userName = oRs("userName")
unitsId = oRs("unitsId")
dataLine = Ls.datetime(oRs("dataLine"), "yyyy-mm-dd")
revertType = oRs("revertType")
unitsName = oRs("unitsName")
If revertType<>"" Then
Select Case revertType
Case 1
reverts = "尚未办理"
Case 2
reverts = "同意公开"
Case 3
reverts = "同意部分公开"
Case 4
reverts = "信息不存在"
Case 5
reverts = "非本部门掌握"
Case 6
reverts = "申请内容不明确"
Case 7
reverts = "已主动公开"
Case 8
reverts = "不予公开"
End Select
Else
reverts = "尚未办理"
End If
%>
<%
End Function
%>
<%
Function MessContent()
str = ""
If td_ID<>"" And IsNumeric(td_ID) Then
m_ID = td_ID
Else
m_ID = GetSafeStr(Request.QueryString("m_ID"))
End If
ss_id = GetSafeStr(Trim(Request.QueryString("ss_id")))
sql = "select IsUnit,IsLeader from SiteStructure where SS_ID=" & Ls.toClng(SS_ID)
Set rs = LS.CreateRs(sql,1,1)
if not rs.eof then
tIsUnit = rs("IsUnit")
tIsLeader = rs("IsLeader")
end if
rs.close:set rs=nothing
sql = "SELECT b.UI_Name as ReceiveUnits,a.*"
sql = sql & " FROM (messagelist as a LEFT JOIN UnitsInfo as b ON a.m_UnitID=b.UI_ID) "
sql = sql & " Where a.m_ShowIs<>0 and a.m_isdel=0 and m_id=" & Ls.toClng(m_ID)
Set rs = LS.CreateRs(sql,1,1)
rscount = rs.recordcount
If rscount > 0 Then
tm_ID = rs("m_ID")
tm_numbers = rs("m_numbers")
Nowssid = rs("ss_id")
tm_UI_ID = rs("m_UnitID")
m_LeaderID = rs("m_LeaderID")
tm_Name = rs("m_Name")
tm_Subject = rs("m_Subject")
tm_Tel = rs("m_Tel")
tm_Contents = rs("m_Contents")
tm_Date = rs("m_Date")
tm_HtmlUrl = rs("m_HtmlUrl")
tm_Revert = rs("m_Revert")
tm_RevertIS = rs("m_RevertIS")
tm_RevertDate = rs("m_RevertDate")
m_type = rs("m_type")
tm_OpenIs = rs("m_OpenIs")
tm_Appraise = rs("m_Appraise")
m_RevertUserid = rs("m_RevertUserid")
tm_xz = rs("m_xz")
tm_lb = rs("m_lb")
tm_zy= rs("m_zy")
tm_address = rs("m_address")
if tm_xz=1 then
tm_xz = "涉法"
else
tm_xz="非涉法"
end if
if tm_Appraise<>"" then
select case tm_Appraise
case 1
tm_Appraise = "满意"
case 2
tm_Appraise="比较满意"
case 3
tm_Appraise="一般"
case 4
tm_Appraise="不满意"
case 5
tm_Appraise="很不满意"
end select
end if
select case tm_lb
case 1
tm_lb="政治综合"
case 2
tm_lb="经济综合"
case 3
tm_lb="宣传舆论"
case 4
tm_lb="纪检监察"
case 5
tm_lb="政法"
case 6
tm_lb="劳动社保"
case 7
tm_lb="教育"
case 8
tm_lb="卫生计生"
case 9
tm_lb="科技文体"
case 10
tm_lb="组织人事"
case 11
tm_lb="交通资源环保"
case 12
tm_lb="民政"
case 13
tm_lb="城乡建设"
case 14
tm_lb="信息产业"
case 15
tm_lb="国土资源水利林业"
case 16
tm_lb="农村农业"
case 17
tm_lb="商贸旅游"
case 18
tm_lb="其他"
end select
select case m_type
case 1
tm_type="我要咨询"
case 2
tm_type="我要投诉"
case 3
tm_type="我要建议"
case 4
tm_type="我要举报"
case 5
tm_type="其他"
end select
'读取领导姓名
'sqla="select LW_Name from LeaderWindow where LW_ID=" & m_LeaderID
' set rsa = LS.CreateRs(sqla,1,1)
' if not rsa.eof then
' tLW_Name = rsa("LW_Name")
' end if
' rsa.close:set rsa=nothing
'
'读取回复单位名称
if tm_UI_ID<>0 then
sqlt = "SELECT UI_Name as ReceiveUnits"
sqlt = sqlt & " FROM UnitsInfo Where UI_id="&tm_UI_ID
set rsa = LS.CreateRs(sqlt,1,1)
if not rsa.eof then
tReceiveUnits = rsa("ReceiveUnits")
end if
rsa.close:set rsa=nothing
else
tReceiveUnits = ""
end if
end if
rs.close:set rs=nothing
End Function
%>
<%
'======================================================================================================================
'首页投票调查列表（SS_ID：栏目ID,NumWords：显示字数,PageName：链接页面,DateVis:是否显示时间,ResultVis:是否显示结果）
'======================================================================================================================
Public Function IndexVoteList(SS_ID, NumTr, NumWords, DateVis, ResultVis)
If SS_ID = "" Or IsNumeric(SS_ID) = False Or NumTr = "" Or IsNumeric(NumTr) = False Then Exit Function
Str = ""
sql = "select top "&NumTr&" VoteID,VoteName,VoteTaxis,VoteType,adddate,VoteUrl,ss_id,Vote_HtmlUrl from VoteName "
sql = sql & " where SS_ID="&SS_ID&" and Vote_CheckIn=1 AND Vote_isdel=0 order by VoteTaxis desc,VoteID desc"
Set rs = Ls.CreateRs(sql, 1, 1)
rscount = rs.recordcount
If rscount > 0 Then
Str = Str & "
"
For i = 1 To rscount
VoteID = rs("VoteID")
VoteName = rs("VoteName")
VoteTaxis = rs("VoteTaxis")
VoteType = rs("VoteType")
adddate = rs("adddate")
VoteUrl = rs("VoteUrl")
Vote_HtmlUrl = rs("Vote_HtmlUrl")
If VoteUrl <> "" Then
linkurl = VoteUrl
Else
linkurl = Vote_HtmlUrl
End If
ss_id = rs("ss_id")
If IsDate(adddate) Then adddate = Ls.DateTime(adddate,"yyyy-mm-dd")
li_even = ""
If i mod 2=0 Then li_even = "even"
Str = Str & "
"
If NumWords<>"" And IsNumeric(NumWords) And Len(VoteName)>NumWords Then
VoteName = CutStr(VoteName, NumWords)
Else
VoteName = VoteName
End If
Str = Str & ""&VoteName&""
If DateVis<>0 Then
Str = Str & ""
Str = Str &adddate
Str = Str & ""
End If
If ResultVis<>0 Then
Str = Str & "查看结果"
End If
Str = Str & "
"
rs.movenext
Next
Str = Str & "
"
Else
Str = Str & "暂无相关信息"
End If
If G_FLAGHTMLTYPE = 1 Then
response.Write (Str)
Else
IndexVoteList = Str
End If
End Function
'======================================================================================================================
'栏目页投票调查列表（NumWords:显示字数,PerNumRow:一页显示条数）
'======================================================================================================================
Function VoteList(PerNumRow, NumWords)
Str = ""
sql = " Vote_CheckIn=1 and Vote_isdel=0 and SS_ID = "&NowSSID
'默认分页样式名称 pagination
With LS.DB
.PageSize = PerNumRow'定义页数
.ListLong = 3'页数前后显示个数
.Pkey="VoteID"'主键
.Field="VoteID,VoteName,Vote_HtmlUrl,VoteDate,VotebeginDate,adddate,VoteUrl"'字段。不带用where
.OrderBy="VoteTaxis desc,adddate desc,VoteID desc"'排序,不用带order by
.PageParm = "page" '分页参数名称
.RecordCount = 0'默认0即可，尽量不要用*号
.Table="VoteName"'表名
.Condition = sql '条件语句。
Set oRs = .ResultSet
strPage = .PageNav()'分页列表
End With
If IsNull(oRs) Or oRs.Eof Then
ors.Close
response.Write "暂无相关信息"
Exit Function
End If
Str = Str & "
"
Do While Not oRs.Eof
VoteID = oRs("VoteID")
VoteName = oRs("VoteName")
Vote_HtmlUrl = oRs("Vote_HtmlUrl")
VotebeginDate = oRs("VotebeginDate")
VoteDate = oRs("VoteDate")
adddate = oRs("adddate")
VoteUrl = oRs("VoteUrl")
If CInt(Len(VoteName)) > CInt(NumWords) Then VoteName = Cutstr(VoteName, NumWords)
If VoteUrl <> "" Then
linkurl = VoteUrl
Else
linkurl = Vote_HtmlUrl
End If
Str = Str & "
"
if LS.DB.recordcount > cint(PerNumRow) then
Str = Str & "
"&strPage&"
"
end if
If G_FLAGHTMLTYPE = 1 Then
response.Write (Str)
Else
VoteList = Str
End If
End Function
'======================================================================================================================
' 投票调查内容(SS_ID：栏目ID，VoteNameID：投票主题ID ，TxtVis：文本型问题是否显示结果)
'======================================================================================================================
Function Vote(SS_ID, VoteNameID, WinWidth, WinHeight, TxtVis)
Str = ""
sql = "select VoteID from VoteName where SS_ID="&SS_ID&" and VoteID="&VoteNameID&" Order by VoteTaxis desc,VoteID desc"
Set rs = LS.CreateRs(sql, 1, 3)
If Not rs.EOF Then
dVoteNameID = rs("VoteID")
Else
sqla = "select VoteID from VoteName where SS_ID="&SS_ID&" and (IsNULL(VoteDate,'1900-1-1')='1900-1-1' or (IsNULL(VoteDate,'1900-1-1')=VoteDate and datediff(day,VoteDate,getdate())<0)) Order by VoteTaxis desc,VoteID desc"
Set rsa = Ls.CreateRs(sqla, 1, 3)
If Not rsa.EOF Then
dVoteNameID = rsa("VoteID")
End If
rsa.Close
Set rsa = Nothing
End If
rs.Close
Set rs = Nothing
sql = "select Votename,VoteCol,VoteView,votecontents,VoteDate,VotebeginDate from VoteName where SS_ID="&SS_ID&" and VoteID="&dVoteNameID&" Order by VoteTaxis desc,VoteID desc"
Set rs = Ls.CreateRs(sql, 1, 1)
If Not rs.EOF Then
Votename = rs("Votename")
VoteCol = rs("VoteCol")
VoteView = rs("VoteView")
votecontents = rs("votecontents")
VoteDate = rs("VoteDate")
VotebeginDate = rs("VotebeginDate")
rs.Close
Dim VoteID(), VoteType(), VoteTitle(), vote_id
sql = "select * from VoteTitle where SS_ID="&SS_ID&" and VoteID="&dVoteNameID&" order by ID"
Set rs = Ls.CreateRs(sql, 1, 1)
rscount = rs.recordcount
ReDim Preserve VoteID(rscount), VoteType(rscount), VoteTitle(rscount)
If rscount = 0 Then
rs.Close
Set rs = Nothing
Exit Function
End If
If rscount > 1 Then Str = Str & "
"&Votename&"
"
Str = Str & "
"&votecontents&"
"
vote_id = ""
For i = 1 To rscount
VoteID(i) = rs("ID") '投票题目ID
VoteTitle(i) = rs("VoteTitle")
Select Case rs("VoteType")
Case 0
VoteType(i) = "radio"
Case 1
VoteType(i) = "checkbox"
Case 2
VoteType(i) = "txt"
Case 3
VoteType(i) = "radio"
Case 4
VoteType(i) = "checkbox"
End Select
vote_id = vote_id & VoteID(i) & "," '投票题目ID组
rs.movenext
Next
rs.Close
Set rs = Nothing
Str = Str & ""&Chr(13)&Chr(10)
Str = Str & ""
' str = str & str
End If
If G_FLAGHTMLTYPE = 1 Then
response.Write (Str)
Else
Vote = Str
End If
End Function
%>
<%
'======================================================
'首页网上评议文字列表IndexReviewlist(SS_ID:栏目ID,NumTr:显示条数,NumWords：标题字数,DateVis:是否显示时间)
'======================================================
Function IndexReviewlist(SS_ID, NumTr, NumWords, DateVis)
If SS_ID = "" Or IsNumeric(SS_ID) = False Or NumTr = "" Or IsNumeric(NumTr) = False Then Exit Function
Str = ""
sql = "select top "&NumTr&" Nid,SS_ID,Title,SDate,Edate,content,addtime,ischeckIP,message,s_checkin,s_htmlurl FROM Satisfaction "
sql = sql & " where ss_id="&ss_id&" and s_checkin=1 AND s_isdel=0 order by Nid desc"
Set rs = LS.CreateRs(sql, 1, 1)
rscount = rs.recordcount
If rscount>0 Then
For i = 1 To rscount
Title = rs("Title")
Title1 = rs("Title")
s_htmlurl = rs("s_htmlurl")
addtime = rs("addtime")
SDate = rs("SDate")
Edate = rs("Edate")
If IsDate(addtime) Then addtime = Ls.DateTime(addtime,"yyyy-mm-dd")
Str = Str & "
"
Str = Str & "
"
If NumWords<>"" And IsNumeric(NumWords) Then
Title = Cutstr(Title, NumWords * 2)
End If
Str = Str & ""&Title&""
If DateVis = 1 Then
Str = Str &""&addtime&""
End If
Str = Str & "
"
Str = Str & "
"
rs.movenext
Next
End If
rs.Close
Set rs = Nothing
If G_FLAGHTMLTYPE = 1 Then
response.Write(Str)
Else
IndexReviewlist = Str
End If
End Function
'======================================================
'栏目页网上评议Reviewlist(PerNumRow:每页显示条数,NumWords：标题字数)
'======================================================
Function Reviewlist(PerNumRow, NumWords)
Str = ""
sql = " s_checkin=1 and AND s_isdel=0 and SS_ID="&NowSSID
'默认分页样式名称 pagination
With LS.DB
.PageSize = CInt(PerNumRow)'定义页数
.ListLong = 3'页数前后显示个数
.Pkey = "Nid"'主键
.Field = "Nid,SS_ID,Title,SDate,Edate,content,addtime,ischeckIP,message,s_checkin,s_htmlurl"'字段、尽量不要用*号
.Table = "Satisfaction"'表名
.Condition = sql '条件语句，不带用where
.OrderBy = "Nid desc"'排序,不用带order by
.RecordCount = 0'默认0即可。
Set oRs = .ResultSet
strPage = .PageNav()'分页列表
End With
If oRs.EOF Then
oRs.Close
response.Write "正在更新中..."
Exit Function
End If
Do While Not oRs.EOF
Title = oRs("Title")
Title1 = oRs("Title")
s_htmlurl = oRs("s_htmlurl")
addtime = oRs("addtime")
SDate = oRs("SDate")
Edate = oRs("Edate")
Str = Str & "
"
Str = Str & "
"
If NumWords<>"" And IsNumeric(NumWords) Then
Title = Cutstr(Title, NumWords * 2)
End If
Str = Str & ""&Title&"[开始时间："&SDate&" 结束时间："&Edate&"]"
Str = Str & "
"
Str = Str & "
"
oRs.movenext
Loop
if LS.DB.recordcount > cint(PerNumRow) then
Str = Str & "
"
Str = Str & strPage
Str = Str & "
"
End If
oRs.Close
Set oRs = Nothing
If G_FLAGHTMLTYPE = 1 Then
response.Write(Str)
Else
Reviewlist = Str
End If
End Function
%>
<%
Dim tBS_Title, tBS_Contents, tBS_ID
'分类名称
Public Function BanshiTitle(ID)
Str = ""
sql = "select BS_Name from BsSort where BS_ID="&ID&" order by BS_No"
Set rs = Ls.CreateRs(sql, 1, 1)
If Not rs.EOF Then
Str = rs("BS_Name")
End If
rs.Close
Set rs = Nothing
If G_FLAGHTMLTYPE = 1 Then
response.Write(Str)
Else
BanshiTitle = Str
End If
End Function
'单位名称
Public Function BanshiUnitsName(ID)
Str = ""
sql = "select UI_Name from UnitsInfo where UI_ID="&ID
Set rs = Ls.CreateRs(sql, 1, 1)
If Not rs.EOF Then
Str = rs("UI_Name")
End If
rs.Close
Set rs = Nothing
If G_FLAGHTMLTYPE = 1 Then
response.Write(Str)
Else
BanshiUnitsName = Str
End If
End Function
'不带样式的办事分类
Public Function BanshiSortList(SS_SiteID, PBS_ID, BS_Classid, NumTr, NumWords, BS_url)
Str = ""
sql = "select BS_Name,BS_ID,BS_Linkurl from BsSort where SS_SiteID=" & SS_SiteID & " and BS_Classid="&BS_Classid&" and PBS_ID="&PBS_ID&" order by BS_No"
Set rs = Ls.CreateRs(sql, 1, 1)
rscount = rs.recordcount
If rscount>NumTr Then
rscount = NumTr
End If
Str = Str & "
"
For i = 1 To rscount
BS_Name = rs("BS_Name")
BS_ID = rs("BS_ID")
BS_Linkurl = rs("BS_Linkurl")
If BS_Linkurl<>"" Then
Str = Str & "
"
End If
rs.movenext
Next
rs.Close
Set rs = Nothing
Str = Str & "
"
If G_FLAGHTMLTYPE = 1 Then
response.Write(Str)
Else
BanshiSortList = Str
End If
End Function
'带样式的办事分类
Public Function BanshiSortList_Class(SS_SiteID, PBS_ID, BS_Classid, NumTr, NumWords, BS_url)
Str = ""
sql = "select BS_Name,BS_ID,BS_Linkurl from BsSort where SS_SiteID=" & SS_SiteID & " and BS_Classid="&BS_Classid&" and PBS_ID="&PBS_ID&" order by BS_No"
Set rs = Ls.CreateRs(sql, 1, 1)
rscount = rs.recordcount
If rscount>NumTr Then
rscount = NumTr
End If
Str = Str & "
"
For i = 1 To rscount
BS_Name = rs("BS_Name")
BS_ID = rs("BS_ID")
BS_Linkurl = rs("BS_Linkurl")
If BS_Linkurl<>"" Then
Str = Str & "
"
End If
rs.movenext
Next
rs.Close
Set rs = Nothing
Str = Str & "
"
If G_FLAGHTMLTYPE = 1 Then
response.Write(Str)
Else
BanshiSortList_Class = Str
End If
End Function
'办事单位调用
Public Function BanshiUnits(NumTr, NumWords, BS_url)
Str = ""
sql = "select UI_Name,UI_ID from UnitsInfo where UI_SubItem=0 and UI_ID<>0 and UI_Hidden<>0 order by UI_Path"
Set rs = Ls.CreateRs(sql, 1, 1)
rscount = rs.recordcount
If rscount>NumTr Then
rscount = NumTr
End If
Str = Str & "
"
For i = 1 To rscount
UI_Name = rs("UI_Name")
UI_ID = rs("UI_ID")
Str = Str & "
"
rs.movenext
Next
rs.Close
Set rs = Nothing
Str = Str & "
"
If G_FLAGHTMLTYPE = 1 Then
response.Write(Str)
Else
BanshiUnits = Str
End If
End Function
'首页办事文字列表
Function IndexBSlist(SS_ID, Numrow, NumWords, DateVis, OrderType)
If Numrow = "" Or IsNumeric(Numrow) = False Then Exit Function
Str = ""
sql = " select top "&Numrow&" BS_ID,BS_Title,BS_Date,BS_Hit,BS_HtmlUrl,BS_RedirectLink from BsContents where BS_IsDel=0 and BS_CheckIn=1 and ss_id="&ss_id
Select Case OrderType
Case 0
sql = sql & " order by BS_Date Desc"
Case 1
sql = sql & " order by BS_ID Desc"
Case 2
sql = sql & " order by BS_Hit Desc, BS_Date Desc"
End Select
Set rs = LS.CreateRs(sql, 1, 1)
If Not rs.EOF Then
Str = Str&"
"
tNumWords = NumWords * 2
Do While Not rs.EOF
BS_ID = rs("BS_ID")
BS_Title = rs("BS_Title")
BS_Date = rs("BS_Date")
BS_HtmlUrl = rs("BS_HtmlUrl")
BS_RedirectLink = rs("BS_RedirectLink")
If BS_RedirectLink<>"" Then
DocURL = BS_RedirectLink
Else
DocURL = BS_HtmlUrl
End If
Str = Str&"
"
Else
Str = "正在更新中..."
End If
rs.Close
Set rs = Nothing
If G_FLAGHTMLTYPE = 1 Then
response.Write(Str)
Else
IndexBSlist = Str
End If
End Function
'/*****办事内容页***/
Function BsContents()
tBS_ID = GetSafeStr(Request.QueryString("BS_ID"))
If tBS_ID = "" Or IsNumeric(tBS_ID) = False Then Exit Function
sql = "select * from BsContents where BS_ID=" & tBS_ID
Set rs = LS.CreateRs(sql, 1, 1)
If Not rs.EOF Then
NowSSID = rs("SS_ID")
NowSSPath = rs("SS_Path")
tBS_Title = rs("BS_Title")
tBS_Fj = rs("BS_Fj")
tBS_Contents = "
"
sqla = "select AttributeName,DisplayName from TableMetadata where ModelID=3 and IsVisible<>0 and AttributeName<>'BS_Title' and AttributeName<>'BS_RedirectLink' order by ModelNo"
Set rsa = LS.CreateRs(sqla, 1, 1)
rscounta = rsa.recordcount
If rscounta > 0 Then
For i = 1 To rscounta
AttributeName = rsa("AttributeName")
DisplayName = rsa("DisplayName")
If Int(i / 2) = i / 2 Then
trcolor = "#F4F4F4"
Else
trcolor = "#ffffff"
End If
If rs(AttributeName)<>"" Then
tBS_Contents = tBS_Contents&"
"
End If
rsa.movenext
Next
End If
rsa.Close
Set rsa = Nothing
If rs("BS_Contents") <> "" Then
tBS_Contents = tBS_Contents&"
其他说明：
"&rs("BS_Contents")&"
"
End If
tBS_Contents = tBS_Contents&"
"
End If
rs.Close
Set rs = Nothing
End Function
'/*****办事文章列表页***/
Function BsList(SS_ID, classid, classname, unitid, PerNumRow, NumWords, DateVis)
Str = ""
sql = " BS_IsDel=0 and BS_CheckIn=1 and SS_ID="&SS_ID
If classname <> "" And classid<>"" Then
sqla = "select BS_Path from BsSort where BS_ID="&classid
Set rsa = Ls.CreateRs(sqla, 1, 1)
If Not rsa.EOF Then
classPath = rsa("BS_Path")
End If
rsa.Close
Set rsa = Nothing
sql = sql &" and "& classname &" like '"&classPath&"%'"
End If
If unitid<>"" Then
sql = sql &" and BS_Unitid = "&unitid
End If
SearchWords = getsafestr(request("SearchWords"))
If SearchWords <> "" Then
sql = sql &" and BS_Title like '%"&SearchWords&"%'"
End If
With LS.DB
.PageSize = PerNumRow'定义页数
.ListLong = 3'页数前后显示个数
.Pkey="BS_ID"'主键
.Field="BS_ID,BS_Title,BS_Date,BS_Hit,BS_HtmlUrl,BS_RedirectLink"'字段、不带用where
.OrderBy="BS_Date desc"'排序,不用带order by
.PageParm = "page" '分页参数名称
.RecordCount = 0'默认0即可，尽量不要用*号
.Table="BsContents"'表名
.Condition = sql '条件语句。
Set rs = .ResultSet
strPage = .PageNav()'分页列表
End With
If IsNull(rs) Or rs.Eof Then
rs.Close
response.Write "正在更新中..."
Exit Function
End If
Str = Str & "
"
Do While Not rs.Eof
BS_ID = rs("BS_ID")
BS_Title = rs("BS_Title")
BS_Date = rs("BS_Date")
BS_Hit = rs("BS_Hit")
BS_HtmlUrl = rs("BS_HtmlUrl")
BS_RedirectLink = rs("BS_RedirectLink")
If BS_RedirectLink<>"" Then
DocURL = BS_RedirectLink
Else
DocURL = BS_HtmlUrl
End If
Str = Str & "
"
If G_FLAGHTMLTYPE = 1 Then
response.Write(Str)
Else
BsList = Str
End If
End Function
'/*****表格列表***/
Function BanshidownList(SS_ID, classPath, classname, NumRow, NumWords, DateVis, PicVis)
If NumRow = "" Or IsNumeric(NumRow) = False Or SS_ID = "" Or IsNumeric(SS_ID) = False Then Exit Function
Str = ""
sql = " SS_ID="&SS_ID&""
If classname <> "" Then
sql = sql &" and "& classname &" like '"&classPath&"%'"
End If
With LS.DB
.PageSize = NumRow'定义页数
.ListLong = 3'页数前后显示个数
.Pkey="BS_ID"'主键
.Field="BS_ID,BS_Title,BS_URL,BS_Date"'字段，不带用where
.OrderBy="BS_Date desc"'排序,不用带order by
.PageParm = "page" '分页参数名称
.RecordCount = 0'默认0即可，尽量不要用*号
.Table="BsTable"'表名
.Condition = sql '条件语句。
Set rs = .ResultSet
strPage = .PageNav()'分页列表
End With
If IsNull(rs) Or rs.Eof Then
rs.Close
response.Write "正在更新中..."
Exit Function
End If
Str = Str & "
"
Do While Not rs.Eof
BS_ID = rs("BS_ID")
BS_Title = rs("BS_Title")
BS_URL = rs("BS_URL")
BS_Date = rs("BS_Date")
If NumWords<>"" Then
BS_Title = CutStr(BS_Title, NumWords * 2)
End If
Str = Str & "
"&BS_Title&""
If DateVis = 1 Then
Str = Str &""&FormatDateTime(BS_Date, 2)&""
End If
If PicVis = 1 Then
Str = Str &"下载"
End If
Str = Str & "
"
Rs.movenext
Loop
Str = Str & "
"
rs.Close
Set rs = Nothing
Str = Str & "
"& strPage &"
"
If G_FLAGHTMLTYPE = 1 Then
response.Write(Str)
Else
BanshidownList = Str
End If
End Function
' 办事指南搜索
'PageSize 分页条数
'NumWords 标题截取字数
Public Function BS_Search(ByVal PageSize,ByVal NumWords)
searchStr = LS.FormatSQL(Trim(Request.QueryString("searchStr")))
searchUnitID = LS.toClng(Trim(Request.QueryString("searchUnitID")))
If Ls.IsN(searchStr) Then
ConditionStr = "1=2"
Else
ConditionStr = "BS_Title LIKE'%"& searchStr &"%'"
End If
If searchUnitID<>0 Then
ConditionStr = ConditionStr & " AND BS_unitid=" & searchUnitID
End If
With LS.DB
.PageSize = PageSize'定义页数
.ListLong = 3'页数前后显示个数
.Pkey="BS_ID"'主键
.Field="BS_ID,BS_No,BS_Title,BS_Hit,BS_RedirectLink,BS_Date,BS_CheckIn,BS_HtmlUrl,UA_ID"'字段、尽量不要用*号
.Table="BSContents"'表名
.Condition = ConditionStr '条件语句，不带用where
.OrderBy="BS_No desc,BS_Date desc"'排序,不用带order by
.RecordCount = 0'默认0即可。
Set oRs = .ResultSet
strPage = .PageNav()'分页列表
End With
ulStr = "
"
If Not oRs.Eof Then
i=1
Do While Not oRs.Eof
BS_ID = oRs("BS_ID")
BS_No = oRs("BS_No")
BS_Title = oRs("BS_Title")
BS_hit = oRs("BS_Hit")
BS_RedirectLink = oRs("BS_RedirectLink")
BS_Date = oRs("BS_Date")
BS_CheckIn = oRs("BS_CheckIn")
BS_HtmlUrl = oRs("BS_HtmlUrl")
UA_ID = oRs("UA_ID")
rBS_Title = BS_Title
BS_Title = CutStr(BS_Title,NumWords)
If BS_RedirectLink <>"" Then BS_Title = "" & BS_Title & ""
ulStr = ulStr & "
"
BS_Search = ulStr & strPage
End Function
' 办事指南-表格资源库搜索
'PageSize 分页条数
'NumWords 标题截取字数
Public Function BS_Search_Table(ByVal PageSize,ByVal NumWords)
searchStr = LS.FormatSQL(Trim(Request.QueryString("searchStr")))
searchUnitID = LS.toClng(Trim(Request.QueryString("searchUnitID")))
If Ls.IsN(searchStr) Then
ConditionStr = "1=2"
Else
ConditionStr = "BS_Title LIKE'%"& searchStr &"%'"
End If
If searchUnitID<>0 Then
ConditionStr = ConditionStr & " AND BS_unitid=" & searchUnitID
End If
With LS.DB
.PageSize = PageSize'定义页数
.ListLong = 3'页数前后显示个数
.Pkey="BS_ID"'主键
.Field="BS_ID,BS_Title,BS_URL,BS_Date"'字段，不带用where
.OrderBy="BS_ID desc"'排序,不用带order by
.RecordCount = 0'默认0即可，尽量不要用*号
.Table="BsTable"'表名
.Condition = ConditionStr '条件语句。
Set oRs = .ResultSet
strPage = .PageNav()'分页列表
End With
ulStr = "
"
If Not oRs.Eof Then
i=1
Do While Not oRs.Eof
BS_ID = oRs("BS_ID")
BS_Title = oRs("BS_Title")
BS_URL = oRs("BS_URL")
BS_Date = oRs("BS_Date")
rBS_Title = BS_Title
BS_Title = CutStr(BS_Title,NumWords)
If BS_RedirectLink <>"" Then BS_Title = "" & BS_Title & ""
ulStr = ulStr & "
"
BS_Search_Table = ulStr & strPage
End Function
'create by ex7
'author doocal
'description 办事分类调用
' SiteID 站点ID
' SSID 栏目ID可为空，为空取地址栏的SS_ID参数
' PID 父ID
' classId 分类ID
' newUrl 新的URL，参数支持标签替换({BS_ID},{BS_ClassID},{PBS_ID}),用在在特定情况下自由组合参数
' activeID 当前选种的菜单的ID
Public Function BsSortSubNav(ByVal SiteID,ByVal SSID,ByVal PID,ByVal classId,ByVal newUrl,ByVal activeID,ByVal target)
Dim ulStr,urlLink
If Ls.IsN(SSID) Then SSID = NowSSID
If InStr(newUrl,"?")=0 Then
newUrl = newUrl & "?SS_ID="& SSID &"&BS_ID={BS_ID}&BS_ClassId={BS_ClassID}"
End If
If Ls.IsN(activeID) Then activeID = Ls.toClng(Request.QueryString("NowBSID"))
If target="" Then target = "_blank"
strSelect = "SELECT BS_ID,BS_Name,SS_SiteID,BS_ClassID,PBS_ID FROM BsSort WHERE 1=1 "
If LS.toClng(SiteID)<>0 Then strSelect = strSelect & "AND SS_SiteID="& LS.toClng(SiteID)
If LS.toClng(PID)<>0 Then strSelect = strSelect & " AND PBS_ID=" & LS.toClng(PID)
If LS.toClng(classId)<>0 Then strSelect = strSelect & "AND BS_Classid=" & LS.toClng(classId)
strSelect = strSelect & " ORDER BY BS_Path"
Set Rs = LS.CreateRs(strSelect,1,1)
ulStr = ""
Do While Not Rs.eof
BS_ID = Rs("BS_ID")
BS_Name = Rs("BS_Name")
BS_ClassID = Rs("BS_ClassID")
PBS_ID = Rs("PBS_ID")
ulStr = ulStr & "
"
urlLink = Replace(newUrl,"{SS_ID}",SSID)
urlLink = Replace(urlLink,"{BS_ID}",BS_ID)
urlLink = Replace(urlLink,"{BS_ClassID}",BS_ClassID)
urlLink = Replace(urlLink,"{PBS_ID}",PBS_ID)
className = ""
If BS_ID=Ls.toClng(activeID) Or BS_ID=NowBSID Then
className = " class="cc-febbef9 "active"""
End If
ulStr = ulStr & ""& BS_Name &""
ulStr = ulStr & "
"
Rs.movenext
Loop
If Not Ls.IsN(ulStr) Then ulStr = "
"& ulStr &"
"
Rs.Close
Set Rs= Nothing
BsSortSubNav = ulStr
End Function
Public Function BsSortVertical(ByVal siteID,ByVal SSID,ByVal classID,ByVal newUrl)
Dim divStr,urlLink
If InStr(newUrl,"?")=0 Then
newUrl = newUrl & "?SS_ID="& SSID &"&BS_ID={BS_ID}&BS_ClassId={BS_ClassID}"
End If
If Not Ls.IsN(classID) Then classID = Ls.toIDS(classID)
strSelect = "SELECT * FROM dbo.BsSort AS aa Left JOIN dbo.BSClass AS bb ON bb.classid=aa.BS_classid WHERE "
strSelect = strSelect & "bb.SS_SiteID="& Ls.toClng(siteID) &" AND aa.PBS_ID=0 "
If Not Ls.IsN(classID) Then strSelect = strSelect & " AND bb.classId IN("& classID &")"
strSelect = strSelect & " ORDER BY bb.classid,aa.BS_Path"
Set Rs = LS.CreateRs(strSelect,1,1)
divStr = ""
i = 1
Rscount = Rs.Recordcount
Do While Not Rs.Eof
'读取字段
BS_ID = Rs("BS_ID")
PBS_ID = Rs("PBS_ID")
BS_No = Rs("BS_No")
BS_Name = Rs("BS_Name")
BS_Path = Rs("BS_Path")
BS_SubItem = Rs("BS_SubItem")
classId = Rs("classId")
className = Rs("className")
urlLink = Replace(newUrl,"{BS_ID}",BS_ID)
urlLink = Replace(urlLink,"{SS_ID}",SSID)
urlLink = Replace(urlLink,"{BS_ClassID}",classId)
urlLink = Replace(urlLink,"{PBS_ID}",PBS_ID)
If classId<>classId_ And i>1 Then
divStr = divStr & " "
divStr = divStr & "
"
divStr = divStr & "
"
End If
cssName = ""
cssHide = "none"
If NowBSClassId=classId Or (NowBSClassId="" And i=1) Then
cssName = "active"
cssHide = ""
End If
If classId<>classId_ Then
divStr = divStr & "
"
End If
classId_ = classId
i = i + 1
Rs.MoveNext
Loop
Rs.Close
Set Rs = Nothing
divStr = divStr & "
"
BsSortVertical = divStr
End Function
'网上办事垂直子导航
Public Function BsSortSubVertical(ByVal siteID,ByVal SSID,ByVal classID,ByVal newUrl)
Dim divStr,urlLink
If InStr(newUrl,"?")=0 Then
newUrl = newUrl & "?SS_ID="& SSID &"&BS_ID={BS_ID}&BS_ClassId={BS_ClassID}"
End If
strSelect = "SELECT * FROM BsSort WHERE SS_SiteID=" & Ls.toClng(siteID) & " AND BS_classID="& Ls.toClng(classID) &" ORDER BY BS_Path"
Set Rs = LS.CreateRs(strSelect,1,1)
divStr = ""
i = 1
Rscount = Rs.Recordcount
Do While Not Rs.Eof
'读取字段
BS_ID = Rs("BS_ID")
PBS_ID = Rs("PBS_ID")
BS_No = Rs("BS_No")
BS_Name = Rs("BS_Name")
BS_Path = Rs("BS_Path")
BS_SubItem = Rs("BS_SubItem")
urlLink = Replace(newUrl,"{BS_ID}",BS_ID)
urlLink = Replace(urlLink,"{SS_ID}",SSID)
urlLink = Replace(urlLink,"{BS_ClassID}",classID)
urlLink = Replace(urlLink,"{PBS_ID}",PBS_ID)
If BS_SubItem And i>1 Then
divStr = divStr & "
"
divStr = divStr & "
"
divStr = divStr & ""
End If
If BS_SubItem Then
divStr = divStr & "
办事指南"
If BS_Fg<>"" Then
divStr = divStr &" 相关法规"
End If
If BS_Fj<>"" Then
divStr = divStr &" 表格下载 "
End If
divStr = divStr &" 在线咨询"
divStr = divStr &" 在线申报"
divStr = divStr &"
"
divStr = divStr &"
"
Rs.movenext
Loop
if LS.DB.RecordCount>15 then
divStr = divStr & "
"
divStr = divStr & strPage
divStr = divStr & "
"
end if
End If
Rs.close
set Rs = Nothing
BanshiList = divStr
End Function
'SS_ID 用于显示当前位置，NumTr 调用条数，NumWords 显示字数，Condition SQL条件，newUrl 支持参数替换
Public Function BSUnitsNav(SSID, NumTr, NumWords, Condition, newUrl)
Str = ""
unitID = Ls.toClng(Request.QueryString("unitID"))
If InStr(newUrl,"?")=0 Then
newUrl = newUrl & "?SS_ID="& SSID &"&unitID={unitID}&unitName={unitName}"
End If
strSelect = "select top "& Ls.toClng(NumTr) &" UI_Name,UI_ID FROM UnitsInfo WHERE 1=1 "
If Not Ls.IsN(Condition) Then
strSelect = strSelect & Condition
Else
strSelect = strSelect & " AND UI_SubItem=0 AND UI_ID<>0 AND UI_Hidden=1"
End If
strSelect = strSelect & " ORDER BY UI_Path"
Set rs = Ls.CreateRs(strSelect, 1, 1)
Str = Str & "
"
Do While Not Rs.Eof
UI_Name = Rs("UI_Name")
UI_ID = Rs("UI_ID")
urlLink = Replace(newUrl,"{unitID}",UI_ID)
urlLink = Replace(urlLink,"{unitName}",UI_Name)
urlLink = Replace(urlLink,"{SS_ID}",SSID)
Str = Str & "
"
If G_FLAGHTMLTYPE = 1 Then
Response.Write(Str)
Else
BSUnitsNav = Str
End If
End Function
'此涵数用在根据 BS_ClassId 调用下级所有内容时，因无法直接关联，暂时用这个土办事实现
Public Function GetBsSortPath(ByVal classID, ByVal splitFlag)
Dim strWhere
strWhere = ""
If splitFlag="" Then splitFlag = " OR "
strSelect = "SELECT BS_Path FROM BsSort as aa WHERE aa.PBS_ID=0 AND aa.BS_classId=" & classID
Set Rs2 = Ls.CreateRs(strSelect, 1, 1)
Do While Not Rs2.Eof
BS_Path = Rs2("BS_Path")
If strWhere<>"" Then strWhere = strWhere & splitFlag
strWhere = strWhere & " BS_classid"& classID & " LIKE '"& BS_Path &"%'"
Rs2.MoveNext
Loop
Rs2.Close
Set Rs2 = Nothing
GetBsSortPath = strWhere
End Function
%>
<%
Dim bbsNowPlace
'/*****栏目页当前位置***/
Function NowbbsPlace(ttSS_ID)
bbsNowPlace = ""
if ttSS_ID<>0 then
sql = "select SS_Name,PSS_ID,SS_HtmlUrl,SS_Path from SiteStructure where SS_ID="&ttSS_ID
else
sql = "select SS_Name,PSS_ID,SS_HtmlUrl,SS_Path from SiteStructure where SS_ID="&NowSSID
end if
Set rs = LS.CreateRs(sql,1,1)
If not rs.eof Then
NowhdSSName = rs("SS_Name")
PSS_ID = rs("PSS_ID")
SS_HtmlUrl = rs("SS_HtmlUrl")
RootSSPath = rs("SS_Path")
RootSSPathNum = UBound(Split(RootSSPath,"-"))
End if
rs.close
bbsNowPlace = NowhdSSName
For i = 1 to RootSSPathNum
sql = "select SS_Name,PSS_ID,SS_HtmlUrl from SiteStructure where SS_ID="&PSS_ID
Set rs = LS.CreateRs(sql,1,1)
If not rs.eof Then
SS_Name = rs("SS_Name")
PSS_ID = rs("PSS_ID")
SS_HtmlUrl = rs("SS_HtmlUrl")
SS_URL = SS_HtmlUrl
If bbsNowPlace = "" Then
bbsNowPlace = ""&SS_Name&""
Else
bbsNowPlace = ""&SS_Name&" > "&bbsNowPlace
End If
End If
rs.close
Next
bbsNowPlace = " > "&bbsNowPlace
' response.write bbsNowPlace
If G_FLAGHTMLTYPE = 1 Then
Response.write bbsNowPlace
Else
NowbbsPlace = bbsNowPlace
End If
End Function
'/*****帖子列表***/
Function bbsList(PerNumRow,BBSid,MemberIS,MemberSSID)
If NowSSIS = False Then Exit Function
' --------------表单提交 Post-------------------------------
action = Request.Form("action")
If action = "add" Then '主题帖子
response.Write ForumAdd()
Exit Function
End If
If action = "edit" Then '修改贴子
response.Write ForumEdit()
Exit Function
End If
If action = "revert" Then '回复帖子
response.Write ForumRevert(CheckIn)
Exit Function
End If
If action = "logincheck" Then '验证会员登录
Call MemberLoginCheck(MemberSSID,BBSid)
Exit Function
End If
If action = "registercheck" Then '验证会员注册
Call MemberRegisterCheck(MemberSSID,BBSid)
Exit Function
End If
If action = "editcheck" Then '验证会员修改资料
Call MemberEditCheck(MemberSSID)
Exit Function
End If
If action = "findpasscheckuser" Then '验证密码查询
Call MemberFindPassCheckUser()
Exit Function
End If
If action = "findpasscheckanswer" Then '验证密码查询
Call MemberFindPassCheckAnswer()
Exit Function
End If
%>
<%
' --------------显示表单 Get------------------------------
action = Request.QueryString("action")
If action = "add" Then '主题帖子表单
response.Write ForumAddForm(action)
Exit Function
End If
If action = "edit" Then '修改帖子表单
response.Write ForumEditForm()
Exit Function
End If
If action = "del" Then
response.Write ForumDel()
Exit Function
End If
If action = "login" Then '用户登录表单
%>
<%
Exit Function
End If
If action = "register" Then '用户注册表单
%>
<%If GetSafeStr(Request.QueryString("read")) <> "1" Then%>
<%Else%>
<%If Session("NoForm") = "" Then Session("NoForm") = 1%>
<%End If%>
<%
Exit Function
End If
If action = "editmem" Then '用户修改资料表单
Call MemberEdit()
Exit Function
End If
If action = "findpass" Then '用户查询密码表单
Call MemberFindPass()
Exit Function
End If
If action = "logout" Then '用户安全退出
Session("m_ID") = ""
Session("m_Name") = ""
Session("m_ForumRights") = ""
Session("m_Level") = ""
Session("m_LoginNow") = ""
Response.Redirect "/tmp/"&NowSSURL&"?SS_ID="&NowSSID
End If
' ================================================
' 显示当前项目帖子列表
' ================================================
If tF_ID <> "" Then
response.Write ForumArticleList(PerNumRow,tF_ID,TbBdCor,ThBgCor,TrBgCor,CheckIn,MemberIS)
Exit Function
End If
If action = "notice" Then
Response.write ""
End If
%>
标题<%if NowhdIsUnit=1 then response.write "状态"%> 浏览回复
<%
If NowSSSubItem = True Then
sql = " SS_Path like '%"&NowSSPath&"%'"
If tF_Title <> "" Then sql = sql & " and F_Title like '"&tF_Title&"%'"
sql = sql & " and PF_ID=0 and F_CheckIn=1 and F_Isdel=0"
Else
sql = " SS_ID="&NowSSID
If tF_Title <> "" Then sql = sql & " and F_Title like '"&tF_Title&"%'"
sql = sql &" and PF_ID=0 and F_CheckIn=1 and F_Isdel=0"
End If
With LS.DB
.PageSize = CInt(PerNumRow)'定义页数
.ListLong = 3'页数前后显示个数
.Pkey = "F_ID"'主键
.Field = "F_ID,F_Title,F_Name,F_Htmlurl,F_Date,F_Hit,F_Revert,F_TopLock,F_Vouch,F_LastName,F_LastDate,F_isrevert,F_unitid"'字段。尽量不要用*号
.Table = "Forum"'表名
.Condition = sql '条件语句，不带用where
.OrderBy = "F_TopLock desc,F_Date desc"'排序,不用带order by
.RecordCount = 0'默认0即可。
Set oRs = .ResultSet
strPage = .PageNav()'分页列表
End With
If oRs.eof Then
oRs.close
%>
暂无内容！
<%
Response.Write ""
%>
<%
Exit Function
End If
If Not IsNull(oRs) Then
Do While Not oRs.EOF
F_ID = oRs("F_ID")
F_Title = oRs("F_Title")
F_Name = oRs("F_Name")
F_Htmlurl = oRs("F_Htmlurl")
F_Date = oRs("F_Date")
F_Hit = oRs("F_Hit")
F_Revert = oRs("F_Revert")
F_TopLock = oRs("F_TopLock")
F_Vouch = oRs("F_Vouch")
F_LastName = oRs("F_LastName")
F_LastDate = oRs("F_LastDate")
F_isrevert = oRs("F_isrevert")
F_unitid = oRs("F_unitid")
if F_isrevert<>0 then
revertname="已回复"
else
revertname="未回复"
end if
sqla = "select UI_Name from UnitsInfo where UI_ID = "&F_unitid
Set rsa = LS.CreateRs(sqla,1,1)
If not rsa.eof Then
UI_Name = rsa("UI_Name")
else
UI_Name = ""
end if
rsa.close:set rsa=nothing
%>
<%=cutstr(F_Title,40)%>
<%if F_TopLock<>0 then response.write ""
if F_Vouch<>0 then response.write ""
%>
<%
If Not oRs.bOF Then
response.Write strPage
End If
%>
<%
oRs.close:set oRs=nothing
%><%
End Function
'/*****论坛子栏目***/
Function bbsSortMenu(PSS_ID,NumTr,WordNums)
str = ""
PSSID = PSS_ID
'判断是否有二级栏目
sql = "select PSS_ID from SiteStructure where SS_SubItem=0 and SS_ID="&PSSID
Set rs = LS.CreateRs(sql,1,1)
If not rs.eof Then
PSSID = rs("PSS_ID")
End If
rs.close:set rs=nothing
sql = "select SS_Name,SS_URL,SS_HtmlUrl,SS_LinkURL,SS_URL from SiteStructure where SS_CheckIn=1 and PSS_ID="&PSSID&" order by SS_No"
Set rs = Ls.CreateRs(sql,1,1)
rscount = rs.recordcount
if rscount > NumTr then
rscount = NumTr
end if
str = str & "
"
For i = 1 to rscount
SS_Name = rs("SS_Name")
SS_URL = rs("SS_URL")
SS_HtmlUrl = rs("SS_HtmlUrl")
SS_LinkURL = rs("SS_LinkURL")
SS_URL = SS_HtmlUrl
If SS_LinkURL <> "" Then
str = str & ""&CutStr(SS_Name,WordNums)&""
Else
str = str & ""&CutStr(SS_Name,WordNums)&""
End If
rs.movenext
Next
str = str & "
"
rs.close:set rs=nothing
If G_FLAGHTMLTYPE = 1 Then
response.Write(Str)
Else
bbsSortMenu = Str
End If
End Function
'/*****发贴表单***/
Function ForumAddForm(action)
'取出论坛根路径
sql = "select * from SiteStructure where SS_ID=" & NowSSID & " and SS_Type=66"
Set rs = LS.CreateRs(sql,1,1)
If rs.eof Then
rs.close
Exit Function
End If
SS_Path = rs("SS_Path")
rs.close
'生成论坛目录列表表单
sql = "select SS_ID,SS_Path,SS_Name,SS_SubItem from SiteStructure where SS_Path like '"&SS_Path&"%' order by SS_Path"
Set rs = LS.CreateRs(sql,1,1)
rscount = rs.recordcount
OptionStr = ""
%><%
If Session("m_ID")="" Then
Response.Write ""
response.end
End if
'验证会员组权限
sql = "select FM_Isfb from forummebers where FM_ID="&Session("m_Level")
Set rs = LS.CreateRs(sql,1,1)
If not rs.eof Then
FM_Isfb = rs("FM_Isfb")
End If
rs.close:set rs=nothing
if FM_Isfb=0 then
response.write ""
response.end
end if
%>
<%
sql = "select m_Address,m_Tel,m_Email from Member where m_ID=" & Session("m_ID")
Set rs = LS.CreateRs(sql,1,1)
If not rs.eof Then
m_Address = rs("m_Address")
m_Tel = rs("m_Tel")
m_Email = rs("m_Email")
End If
rs.close
%>
<%
End Function
'/*****提交发帖内容***/
Function ForumAdd()
F_Title = GetSafeStr(Request.Form("F_Title"))
F_Name = GetSafeStr(Request.Form("F_Name"))
F_Email = GetSafeStr(Request.Form("F_Email"))
F_Tel = GetSafeStr(Request.Form("F_Tel"))
F_address = GetSafeStr(Request.Form("F_address"))
F_Contents = ""
For i = 1 To Request.Form("F_Contents").Count
F_Contents = F_Contents & Trim(Request.Form("F_Contents")(i))
Next
SS_Name = Request.Form("SS_Name")
If F_Title = "" Then Call OutScript("您的标题填写不规范!")
If F_Name = "" Then Call OutScript("您的网名填写不规范!")
If F_Contents = "" Then Call OutScript("您的留言填写不规范!")
Ar_SS_Name = Split(SS_Name,"|")
SS_Path = Ar_SS_Name(0)
SS_ID = Ar_SS_Name(1)
f_type = GetSafeStr(Request.Form("f_type"))
f_unitid = GetSafeStr(Request.Form("f_unitid"))
'验证码是否输入正确
checkCode = Trim(Request.form("checkimg"))
If checkCode <> Session("psn") Then
Call OutScript("验证码输入错误！")
End If
sql = "select SS_SiteID,mess_type from SiteStructure where SS_ID="&SS_ID
Set rs = LS.CreateRs(sql,1,1)
If not rs.eof Then
SS_SiteID = rs("SS_SiteID")
mess_type = rs("mess_type")
End If
rs.close:set rs=nothing
'验证会员组权限
' sql = "select FM_Issh from forummebers where FM_ID="&Session("m_Level")
' Set rs = LS.CreateRs(sql,1,1)
' If not rs.eof Then
' FM_Issh = rs("FM_Issh")
' End If
' rs.close
Randomize
Random = Round(Rnd * (99999999 - 10000000 + 1) - 0.5) + 10000000
CreateDir = DocHtmlDir & SS_SiteID & "/" &year(date())&"/"&month(date())&"/"
sql = "select top 1 * from Forum order by F_ID desc"
Set rs = LS.CreateRs(sql,1,3)
rs.addnew
rs("PF_ID") = 0
rs("SS_SiteID") = SS_SiteID
rs("SS_Type") = 106
rs("SS_ID") = SS_ID
rs("SS_Path") = SS_Path
rs("F_Title") = F_Title
rs("F_address") = F_address
rs("F_Name") = F_Name
rs("F_Email") = F_Email
rs("F_Tel") = F_Tel
rs("F_Contents") = F_Contents
rs("F_Date") = now()
rs("F_RemoteIp") = Request.ServerVariables("REMOTE_ADDR")
rs("F_Hit") = 0
rs("F_Revert") = 0
rs("F_TopLock") = 0
rs("F_vouch") = 0
rs("F_IsDel") = 0
if F_unitid<>"" then
rs("F_unitid") = F_unitid
end if
if F_type<>"" then
rs("F_type") = F_type
end if
rs("F_CheckIn") = 0
' rs("F_Htmlurl") = CreateDir & "bbs_"&d_ID & ".html"
rs("d_OriginalFileName") = d_originalfilename
rs("d_SaveFileName") = d_savefilename
rs("d_SavePathFileName") = d_savepathfilename
If Session("m_ID") <> "" Then rs("m_ID") = Session("m_ID")
rs.update
F_ID = rs("F_ID")
LXMsql = "select * from Forum where F_ID="&F_ID
Set LXMrs = LS.CreateRs(LXMsql,1,3)
if not LXMrs.bof then
LXMrs("F_Htmlurl") = CreateDir & "bbs_"&F_ID & ".html"
LXMrs.update
end if
LXMrs.close:set LXMrs=nothing
rs.close:set rs=nothing
if F_unitid<>"" then
'判断接受消息的用户ID
sqla="select UA_ID,UA_Mail from UserAccount where charindex('|H"&SS_ID&"|',UA_Rights)<>0 and UI_ID=" & F_unitid
set rsa = LS.CreateRs(sqla,1,1)
if not rsa.eof then
for i=1 to rsa.recordcount
if i=1 then
UA_ID = rsa("UA_ID")
UA_Mail = rsa("UA_Mail")
else
UA_ID = UA_ID&","&rsa("UA_ID")
UA_Mail = UA_Mail&","&rsa("UA_Mail")
end if
rsa.movenext
next
end if
rsa.close
'用消息盒子发送消息
if instr(mess_type,"1")<>0 then
'发送消息记录给相关人员
If UA_ID<>"" then
call SysMsg(UA_ID,2,"/system/sys_bbs_view.shtml?SS_ID="&SS_ID&"&F_ID="&F_ID&"&winopen=1",cutstr(F_Title,27),"主题","")
end if
end if
'用手机短信提醒发送消息
if instr(mess_type,"2")<>0 then
'参数：发送者ID、接收者ID（用,分割）、内容、尾部
If UA_ID<>"" then
CALL SendSMS(m_Name,UA_ID,"有一条新的论坛主帖："&F_Title&"发布","【" & f_Name & "】")
end if
end if
'发送邮件提醒
if instr(mess_type,"3")<>0 then
serv_url = Request.servervariables("http_host")
if IsObjInstalled("JMail.Message") =True then
Contentstr=Contentstr&""
Contentstr=Contentstr&""&SiteInfo(2)&"
"
Contentstr=Contentstr&"您有一条新的留言：【"&f_title&"】请及时回复，发送时间:"&now()&" "
Contentstr=Contentstr&""
Contentstr=Contentstr&"点击查看(http://"&serv_url&"/system/sys_bbs_view.shtml?SS_ID="&SS_ID&"&F_ID="&F_ID&"&winopen=1) "
Contentstr=Contentstr&"本邮件由系统自动发送,无须回复，如链接打不开，请自行登录后台查看。
"
if UA_Mail<>"" then
checks=Split(UA_Mail,",")
For i=0 To UBound(checks)
email=replace(checks(i)," ","")
if email<>"" then
SendStat = Jmail(email,"主题:"&f_title&"",""&Contentstr&"","GB2312","text/html")
end if
Next
end if
end if
end if
end if
Response.write ""
End Function
'/*****帖子详细内容***/
Function ForumArticleList(PerNumRow)
str = ""
str = str & ""&chr(13)&chr(10)
action = getsafestr(Request.QueryString("action"))
If td_ID<>"" And IsNumeric(td_ID) Then
F_ID = td_ID
Else
F_ID = GetSafeStr(Request.QueryString("F_ID"))
End If
If action = "notice" Then
str = str & ""
End If
sql = "select F_Title,F_Name,F_Email,F_Contents,F_Date,F_Hit,F_Revert,m_ID,SS_ID,F_IsClose,F_Htmlurl from Forum where f_isdel=0 and f_checkin=1 and F_ID=" & F_ID
Set rs = LS.CreateRs(sql,1,1)
If rs.eof Then
rs.close
Exit Function
End If
NowF_Title = rs("F_Title")
F_Name = rs("F_Name")
F_Email = rs("F_Email")
F_Contents = rs("F_Contents")
F_Htmlurl = rs("F_Htmlurl")
F_Date = rs("F_Date")
F_Hit = rs("F_Hit")
F_Revert = rs("F_Revert")
m_ID = rs("m_ID")
ttSS_ID = rs("SS_ID")
F_IsClose = rs("F_IsClose")
rs.close:set rs=nothing
if m_id<>"" then
sqla = "select m_Score,m_Level,m_photo from Member where m_ID=" & m_ID
Set rsa = LS.CreateRs(sqla,1,1)
If not rsa.eof Then
m_Score = rsa("m_Score")
m_Level = rsa("m_Level")
m_photo = rsa("m_photo")
End If
rsa.close:set rsa=nothing
end if
if m_Level<>"" then
sqla = "select fm_name from forummebers where fm_ID=" & m_Level
Set rsa = LS.CreateRs(sqla,1,1)
If not rsa.eof Then
fm_name = rsa("fm_name")
End If
rsa.close:set rsa=nothing
end if
sql = "select SS_Path from SiteStructure where SS_ID="&ttSS_ID
Set rs = LS.CreateRs(sql,1,1)
If not rs.eof Then
ttSS_Path = rs("SS_Path")
End if
rs.close:set rs=nothing
%>
<%
'显示回复帖子
If Not IsNull(oRs) Then
Do While Not oRs.EOF
ttF_ID = oRs("F_ID")
ttSS_ID = oRs("SS_ID")
F_Title = oRs("F_Title")
F_Name = oRs("F_Name")
F_Email = oRs("F_Email")
F_FaceImage = oRs("F_FaceImage")
F_Contents = oRs("F_Contents")
F_Date = oRs("F_Date")
m_ID = oRs("m_ID")
if m_id<>"" then
sqla = "select m_Score,m_Level,m_photo from Member where m_ID=" & m_ID
Set rsa = LS.CreateRs(sqla,1,1)
If not rsa.eof Then
m_Score = rsa("m_Score")
m_Level = rsa("m_Level")
m_photo1 = rsa("m_photo")
End If
rsa.close:set rsa=nothing
end if
if m_Level<>"" then
sqla = "select fm_name from forummebers where fm_ID=" & m_Level
Set rsa = LS.CreateRs(sqla,1,1)
If not rsa.eof Then
fm_name = rsa("fm_name")
End If
rsa.close:set rsa=nothing
end if
%>
<%
If Not oRs.BOF Then
response.Write strPage
End If
oRs.close:set oRs=nothing
%>
<%
If F_IsClose Then
Response.write "
"
Response.write "
此贴已经结贴！！！
"
Response.write "
"
Exit Function
Else
Response.write "
"
Response.write "
"
Response.write "
"
End If
%>
<%
End Function
'统计用户发帖数
Function totalBBS(SS_SiteID,m_ID,m_type)
str = ""
bbsCount=0
if m_type=0 then
strSelect = "SELECT count(f_ID) FROM forum WHERE SS_SiteID="&SS_SiteID&" and f_IsDel=0"
if m_id<>"" then
strSelect = strSelect & " and m_ID="&m_ID&""
end if
strSelect = strSelect & " and pf_id=0"
bbsCount = LS.CreateConn.Execute(strSelect)(0)
else
strSelect = "SELECT count(f_ID) FROM forum WHERE SS_SiteID="&SS_SiteID&" and f_IsDel=0"
if m_id<>"" then
strSelect = strSelect & " and m_ID="&m_ID&""
end if
strSelect = strSelect & " and pf_id<>0"
bbsCount = LS.CreateConn.Execute(strSelect)(0)
end if
str = str & bbsCount
If G_FLAGHTMLTYPE = 1 Then
response.Write(Str)
Else
totalBBS = Str
End If
End Function
' ======================================================================================================================
' 首页调用论坛贴子
' ======================================================================================================================
Function IndexbbsList(SS_ID,SS_Path,TopNum,Wnumbers,Is_date)
If SS_ID = "" Or IsNumeric(SS_ID) = False Or TopNum = "" Or IsNumeric(TopNum) = False Then Exit Function
Str = ""
Dim v_CacheName : v_CacheName = G_CACHENAME & "IndexbbsList" & SS_ID
If Not IsEmpty(Application(v_CacheName)) And G_ALLCACHE Then
Str = Application(v_CacheName)
Else
sql = "SELECT top "&TopNum&" f_title,f_Date,f_HtmlUrl FROM forum Where pf_id=0 and f_checkin<>0 and f_isdel=0"
if SS_Path<>"" then
sql = sql & " and ss_Path like '"&ss_path&"%'"
else
sql = sql & " and ss_id="&ss_id
end if
sql = sql & " order by f_date desc"
Set rs = Ls.CreateRs(sql, 1, 1)
rscount = rs.RecordCount
Str = Str & "
"
For i = 1 To rscount
f_title = rs("f_title")
f_Date = rs("f_Date")
f_HtmlUrl = rs("f_HtmlUrl")
f_Date = Year(f_Date)&"-"&Month(f_Date)&"-"&Day(f_Date)
if Is_date=1 then
Str = Str & "
"
rs.Close
Set rs = Nothing
If G_ALLCACHE Then
Application.Lock
Application(v_CacheName) = Str
Application.UnLock
End If
end if
If G_FLAGHTMLTYPE = 1 Then
response.Write(Str)
Else
IndexbbsList = Str
End If
End Function
' ======================================================================================================================
' 首页调用论坛贴子
' ======================================================================================================================
Function IndexbbsLists(SS_ID,SS_Path,TopNum,NumWords,DateVis)
If SS_ID = "" Or IsNumeric(SS_ID) = False Or TopNum = "" Or IsNumeric(TopNum) = False Then Exit Function
Str = ""
sql = "SELECT top "&TopNum&" f_title,f_Date,f_HtmlUrl FROM forum Where pf_id=0 and f_checkin<>0 and f_isdel=0"
if SS_Path<>"" then
sql = sql & " and ss_Path like '"&ss_path&"%'"
else
sql = sql & " and ss_id="&ss_id
end if
sql = sql & " order by f_date desc"
Set rs = Ls.CreateRs(sql, 1, 1)
rscount = rs.RecordCount
Str = Str & "
"
For i = 1 To rscount
f_title = rs("f_title")
f_Date = Ls.datetime(rs("f_Date"),"yyyy-mm-dd")
f_HtmlUrl = rs("f_HtmlUrl")
if NumWords<>"" and isnumeric(NumWords) then
f_title=CutStr(f_title, NumWords* 2)
end if
if DateVis=1 then
Str = Str & "
"
rs.Close
Set rs = Nothing
If G_FLAGHTMLTYPE = 1 Then
response.Write(Str)
Else
IndexbbsLists = Str
End If
End Function
' ======================================================================================================================
' 黄牌警示论坛贴子列表
' ======================================================================================================================
Function YellowForumList(SS_ID,SS_Path,Numtr,ItemIcon,NumWords,DateVis,NameVis,HitVis)
If Numtr = "" or isnumeric(Numtr)=false Then Exit Function
Str = ""
sql = "select top "&Numtr&" F_ID,SS_ID,F_Title,F_Date,F_Name"
sql = sql & ",(select SS_URL from SiteStructure where Forum.SS_ID=SiteStructure.SS_ID) As SS_URL"
sql = sql & " from Forum"
sql = sql & " where Forum.PF_ID=0 and Forum.F_CheckIn<>0 and Forum.F_IsDel=0"
If DBType = 1 Then
sql = sql & " and (datediff('d',Forum.F_Date,'"&Date()&"')>5 and datediff('d',Forum.F_Date,'"&Date()&"')<10)"
else
sql = sql & " and (datediff(day,Forum.F_Date,'"&Date()&"')>5 and datediff(day,Forum.F_Date,'"&Date()&"')<10)"
end if
If SS_ID <> "" or isnumeric(SS_ID)=false Then sql = sql& " and Forum.SS_ID="&SS_ID
If SS_Path <> "" Then sql = sql&" and Forum.SS_Path like '"&SS_Path&"%'"
sql = sql&" order by Forum.F_Date desc"
Set rs = Ls.CreateRs(sql,1,1)
rscount = rs.recordcount
Str = Str &"
"
LsObject.CreateConn().Execute("Update Forum2 Set YellowForumNum=1,YellowDate='"&Date()&"' where F_ID="&F_ID&"")
rs.movenext
Next
rs.close
Str = Str &"
"
Else
rs.close
Str = Str &"暂无内容"
End If
Set rs = Nothing
If G_FLAGHTMLTYPE = 1 Then
response.Write(Str)
Else
YellowForumList = Str
End If
End Function
' ======================================================================================================================
' 红牌督办论坛贴子列表
' ======================================================================================================================
Function DCForumList(Topnums,SS_ID,SS_Path,NumWords,DateVis,NameVis,HitVis)
If SS_Path = "" or Topnums="" or isnumeric(Topnums)=false Then Exit Function
Str = ""
'查询督办催办时间
Rsql = "SELECT FC_yellowqx,redqx FROM forumconfig where ss_id=5"
Set Ors = Ls.CreateRs(Rsql,1,1)
Orscount = Ors.recordcount
if Orscount>0 then
FC_yellowqx = Ors("FC_yellowqx")
redqx = Ors("FC_yellowqx")
end if
Ors.close:set Ors=nothing
sql = "select top "&Topnums&" F_ID,SS_ID,F_Title,F_Date,F_Name,F_Htmlurl"
sql = sql & " from Forum"
sql = sql & " where PF_ID=0 and F_CheckIn<>0 and F_Revert=0 and F_IsDel=0"
If DBType = 1 and FC_yellowqx<>"" and isnumeric(FC_yellowqx)=True Then
sql = sql & " and (datediff('d',Forum.F_Date,'"&Date()&"')>"&FC_yellowqx&")"
else
sql = sql & " and (datediff(day,Forum.F_Date,'"&Date()&"')>"&FC_yellowqx&")"
end if
If SS_ID <> "" Then sql = sql& " and SS_ID="&SS_ID
If SS_Path <> "" Then sql = sql&" and SS_Path like '"&SS_Path&"%'"
sql = sql & " order by F_Date desc"
Set rs = Ls.CreateRs(sql,1,1)
rscount = rs.recordcount
If rscount > 0 Then
Str = Str & "
"
For i = 1 to rscount
F_ID = rs("F_ID")
SS_ID = rs("SS_ID")
F_Title = rs("F_Title")
F_Date = Ls.datetime(rs("F_Date"),"yyyy-mm-dd")
F_Name = rs("F_Name")
F_Htmlurl = rs("F_Htmlurl")
Str = Str & "
"
Else
rs.close
Str = Str & "暂无内容"
End If
Set rs = Nothing
If G_FLAGHTMLTYPE = 1 Then
response.Write(Str)
Else
DCForumList = Str
End If
End Function
%>
<%
'======================================================
'首页民意征集文字列表IndexReviewlist(NID:对象ID,NumTr:显示条数,NumWords：标题字数,DateVis:是否显示时间)【有缓存】
'======================================================
Public Function IndexSolicitList(SS_ID, NumTr, NumWords, DateVis)
If SS_ID = "" Or IsNumeric(SS_ID) = False Or NumTr = "" Or IsNumeric(NumTr) = False Then Exit Function
Dim v_CacheName
v_CacheName = G_CACHENAME & "_IndexSolicitList_" & SS_ID
Str = ""
If Not IsEmpty(Application(v_CacheName)) And G_ALLCACHE Then
Str = Application(v_CacheName)
Else
sql = "select top "&NumTr&" CC_ID,SS_ID,CC_Title,CC_linkimages,CC_Begindate,CC_Enddate,CC_date,CC_HtmlUrl,CC_CheckIN,CC_Isdel from CollectContents where SS_ID="&SS_ID&" and CC_CheckIN<>0 order by CC_date desc"
Set rs = LS.CreateRs(sql, 1, 1)
rscount = rs.recordcount
If rscount>0 Then
tNumWords = NumWords
Str = Str & "
"
CC_Title = Cutstr(CC_Title, tNumWords)
Str = Str & ""&CC_Title&""
If DateVis = 1 Then
Str = Str &"期限："&CC_Begindate&" 至 "&CC_Enddate&""
End If
Str = Str & "
"
rs.movenext
Next
Str = Str & "
"
Else
response.Write "正在更新中..."
End If
rs.Close
Set rs = Nothing
If G_ALLCACHE Then
Application.Lock
Application(v_CacheName) = Str
Application.UnLock
End If
End If
If G_FLAGHTMLTYPE = 1 Then
response.Write(Str)
Else
IndexSolicitList = Str
End If
End Function
'======================================================
'栏目页民意征集SolicitList(PerNumRow:每页显示条数,NumWords：标题字数)
'======================================================
Function SolicitList(PerNumRow, NumWords)
Str = ""
sql = " SS_ID="&NowSSID&" and CC_CheckIN<>0"
With LS.DB
.PageSize = PerNumRow'定义页数
.ListLong = 3'页数前后显示个数
.Pkey="CC_ID"'主键
.Field="CC_ID,SS_ID,CC_Title,CC_linkimages,CC_Begindate,CC_Enddate,CC_date,CC_HtmlUrl,CC_CheckIN"'字段。尽量不要用*号
.Table="CollectContents"'表名
.Condition = sql '条件语句，不带用where
.OrderBy="CC_date desc"'排序,不用带order by
.PageParm = "page" '分页参数名称
.RecordCount = 0'默认0即可。
Set oRs = .ResultSet
strPage = .PageNav()'分页列表
End With
If IsNull(oRs) Or oRs.Eof Then
oRs.Close
response.Write "正在更新中..."
Exit Function
End If
Str = Str & "
"
Do While Not oRs.Eof
CC_Title = oRs("CC_Title")
CC_Title1 = oRs("CC_Title")
CC_ID = oRs("CC_ID")
SS_ID = oRs("SS_ID")
CC_date = oRs("CC_date")
if oRs("CC_Begindate")<>"" then
CC_Begindate = Ls.datetime(oRs("CC_Begindate"), "yyyy-mm-dd")
else
CC_Begindate = "现在"
end if
if oRs("CC_Enddate")<>"" then
CC_Enddate = Ls.datetime(oRs("CC_Enddate"), "yyyy-mm-dd")
else
CC_Enddate = "无期限"
end if
CC_HtmlUrl = oRs("CC_HtmlUrl")
Str = Str & "
"
If NumWords<>"" And IsNumeric(NumWords) Then
CC_Title = Cutstr(CC_Title, NumWords)
End If
Str = Str & ""&CC_Title&"[征集时间："&CC_Begindate&"/"&CC_Enddate&"]"
Str = Str & "
"
if LS.DB.recordcount > cint(PerNumRow) then
Str = Str & "
"& strPage &"
"
end if
If G_FLAGHTMLTYPE = 1 Then
response.Write(Str)
Else
SolicitList = Str
End If
End Function
%>
<%
'======================================================================================================================
' 自定义查询模块--查询左侧分类显示部分
'======================================================================================================================
Sub CommonDBinfo(TabWid,TdHig,TdBg,LinkStyle)
Response.Write "
"
sql = "select DB_ID,DB_Title from DBInfo order by DB_ID desc"
Set rs = LS.CreateRs(sql,1,1)
rscount = rs.recordcount
If rscount>0 Then
For i =1 to rscount
Response.Write "
"
End Sub
'======================================================================================================================
' 自定义查询模块--查询显示部分
'======================================================================================================================
Sub CommonQuery(DB_ID,Qtbbgcolor,Qtrbgcolor,Qtdbgcolor,Rtbbgcolor,Rbkgroud,Rtrbgcolor,Rtdbgcolor)
Dim queryTitle,str,action,dataconn,StrConn,sqlstr
'查询操作
action = request("action")
If action = "query" Then
'从主表里取出数据库相关信息
sql = "select DB_TYPE,DB_FILE,DB_ADDR,DB_NAME,DB_USER,DB_PWD,TABLE_NAME,DB_SFNAME,DB_SFMEAN from DBInfo where DB_ID = "&DB_ID
Set rs = LS.CreateRs(sql,1,1)
If not rs.eof Then
DB_TYPE = rs("DB_TYPE")
DB_FILE = rs("DB_FILE")
DB_ADDR = rs("DB_ADDR")
DB_NAME = rs("DB_NAME")
DB_USER = rs("DB_USER")
DB_PWD = rs("DB_PWD")
TABLE_NAME = rs("TABLE_NAME")
DB_SFNAME = rs("DB_SFNAME")
DB_SFMEAN = rs("DB_SFMEAN")
End If
rs.close
Call DBConnEnd()
'获取外部数据库数据库连接字符串
Strconn = GetStrConn(DB_TYPE,DB_FILE,DB_ADDR,DB_NAME,DB_USER,DB_PWD)
'根据外部数据库信息创建数据库连接
Set dataconn = Server.CreateObject("Adodb.Connection")
dataconn.Open StrConn
'查询初始SQL
sqlstr = "select * from "&TABLE_NAME&" where 1=1"
'根据以上所得外部数据库ID从子表查询出用于查询条件的各字段与类型,放入数组,用于下一步追加查询条件
sql = "select Q_FNAME,Q_FOTYPE from QerFields where DB_ID = "&DB_ID
Set rs = LS.CreateRs(sql,1,1)
rscount = rs.recordcount
Dim QField(),QType()
If rscount>0 Then
Redim QField(rscount)
Redim QType(rscount)
For i = 1 to rscount
QField(i) = rs("Q_FNAME")
QType(i) = rs("Q_FOTYPE")
rs.movenext
Next
End If
rs.close
Call DBConnEnd()
'显示字段的提示性文本
DB_SFMEAN = split(DB_SFMEAN,"|")
'显示字段名
DB_SFNAME = split(DB_SFNAME,"|")
'追加SQL查询条件,TypeName()函数在/System/Include/EasyBuildSiteConn.shtml里,通过数据库类型追加
dim k
k = 0
For j = 1 to rscount
If Request.Form(QField(j))<>"" Then
k = k+1
sqlstr = sqlstr&TypeName(DB_TYPE,QField(j),Request.Form(QField(j)),QType(j))
End If
Next
id = Request.QueryString("id")
queryfieldnum = Request.Form("queryfieldnum")
If CInt(k) < CInt(queryfieldnum) Then Call OutScript("查询条件不足，请认真填写!")
If k = 0 and id="" Then Call OutScript("非法查询!")
If id <> "" Then
sqlstr = sqlstr & " and "& DB_SFMEAN(1)&"='"&id&"'"
End If
'用以上组成的SQL语句进行外部数据库查询并将结果以表格形式输出
Set qrs = Server.CreateObject("ADODB.Recordset")
qrs.open sqlstr,dataconn,1,3
'response.Write(sqlstr)
Response.Write "
"
If id <> "" Then
Response.Write "
"
Response.Write "
"
Response.Write "详细信息"
Response.Write "
"
If not qrs.eof Then
'循环输出显示字段单元格并将相应查询结果输入其中
For k = 1 to Ubound(DB_SFMEAN)
If k mod 2 = 0 Then
trcolor = "#F4F4F4"
Else
trcolor = "#FFFFFF"
End If
Response.Write "
"
If qrs.recordcount>0 Then
'循环输出查询出的结果
For j = 1 to qrs.recordcount
If j mod 2 = 0 Then
trcolor = "#F4F4F4"
Else
trcolor = "#FFFFFF"
End If
Response.Write "
"
'循环输出显示字段单元格并将相应查询结果输入其中
For k = 1 to Ubound(DB_SFNAME)
FeildVal = qrs(trim(DB_SFNAME(k)))
FeildVal = CutStr(FeildVal,30)
Response.Write "
"
Response.Write FeildVal
Response.Write "
"
Next
Response.Write "
"
Response.Write ""
Response.Write "
"
Response.Write "
"
qrs.movenext
Next
else
'无查询结果输出提示说明
Response.Write "
"
End If
End If
qrs.close
dataconn.close
Set qrs = nothing
Set dataconn = nothing
Response.Write "
"
Response.End()
End If
'查询结果
'查询页输出开始
'接收外部数据库ID,根据此ID设置查询功能
'从主表中查询出查询标题
sql = "select DB_TITLE,DB_INTRO from DBInfo where DB_ID = "& DB_ID
Set rs = LS.CreateRs(sql,1,1)
If not rs.eof then
queryTitle = rs("DB_TITLE")
DB_INTRO = rs("DB_INTRO")
End If
rs.close
'Call DBConnEnd()
'查询页面字符串初始化
str=""
'从字段属性表中查询出各个字段名用于表单元素名,各个字段提示性文本
sql = "select Q_FSHOW,Q_FNAME,Q_FALERT from QerFields where DB_ID = "&DB_ID
Set rs = LS.CreateRs(sql,1,1)
rscount = rs.recordcount
str = str&""
response.Write(str)
End Sub
%>
<%
version = "4505"
mailname = ""
mailpassword = ""
smsname = ""
smspassword = ""
%>
<%
'======================================================================================================================
' 邮件发送
'======================================================================================================================
on error goto 0
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
Function Jmail(mailTo,mailTopic,mailBody,mailCharset,mailContentType)
Dim ConstFromNameCn,ConstFromNameEn,ConstFrom,ConstMailDomain,ConstMailServerUserName,ConstMailServerPassword
ConstFromNameCn = SiteInfo(2)'发信人中文姓名(发中文邮件的时候使用)，例如smtp.163.com
ConstMailServerUserName = LS.Decodeuser(mailname)'smtp服务器的信箱登陆名，例如'张三'
ConstFromNameEn = SiteInfo(2)'发信人英文姓名(发英文邮件的时候使用)，例如'zhangsan@163.com'
ConstMailDomain = "smtp.163.com"'smtp服务器地址，例如'zhangsan'
ConstFrom = LS.Decodeuser(mailname)&"@163.com"'发信人邮件地址，例如'zhangsan'。注意要与发信人邮件地址一致！
ConstMailServerPassword = LS.Decodeuser(mailpassword)'smtp服务器的信箱登陆密码
'***************根据需要设置常量结束*****************
'-----------------------------以下内容无需改动------------------------------
On Error Resume Next
Dim myJmail
Set myJmail = Server.CreateObject("JMail.Message")
myJmail.Logging = False'记录日志
myJmail.ISOEncodeHeaders = False'邮件头不使用ISO-8859-1编码
myJmail.ContentTransferEncoding = "base64"'邮件编码设为base64
myJmail.AddHeader "Priority","3"'添加邮件头,不要改动！
myJmail.AddHeader "MSMail-Priority","Normal"'添加邮件头,不要改动！
myJmail.AddHeader "Mailer","Microsoft Outlook Express 6.00.2800.1437"'添加邮件头,不要改动！
myJmail.AddHeader "MimeOLE","Produced By Microsoft MimeOLE V6.00.2800.1441"'添加邮件头,不要改动！
myJmail.charset="utf-8"GB2312" Then
myJmail.FromName = ConstFromNameCn
Else
myJmail.FromName = ConstFromNameEn
End If
myJmail.From = ConstFrom
myJmail.Subject = mailTopic
myJmail.Body = mailBody
myJmail.AddRecipient mailTo
myJmail.MailDomain = ConstMailDomain
myJmail.MailServerUserName = ConstMailServerUserName
myJmail.MailServerPassword = ConstMailServerPassword
myJmail.Send ConstMailDomain
myJmail.Close
Set myJmail=nothing
If Err Then
Jmail=Err.Description
Err.Clear
Else
Jmail="OK"
End If
On Error Goto 0
End Function
Function isNul(str)
If isnull(str) or str="" Then isNul=true Else isNul=false
End Function
Function getHttpTxtFile(xUrl,Charset)
On Error Resume Next
Dim Http
Set Http = Server.CreateObject("Msxml2.ServerXMLHTTP")
Http.Open "GET",xUrl,False
Http.Send()
If Http.ReadyState <> 4 Then
getHttpTxtFile = False
Exit Function
End If
getHttpTxtFile = BIN2STRTxT(Http.responseBody,Charset)
Set Http = Nothing
If Err Then
getHttpTxtFile = Err.description
Err.Clear
End If
End function
'=============
'POST发送短信
'建议一次最大提交5000个号码之内
'页面编码类型为：GB2312
'=============作用把中文转为urlcode
Function URLEncoding(vstrIn)
strReturn = ""
For i = 1 To Len(vstrIn)
ThisChr = Mid(vStrIn,i,1) '循环取字相应字符
'取当前字符的ASNI字符代码的绝对值不是小于255
If Abs(Asc(ThisChr)) < &HFF Then
'Abs() 是VBScript中的求绝对值的函数，返回数字的绝对值。
'Asc() 是VBScript中的一个函数，返回与字符串的第一个字母对应的ANSI字符代码
'Hex() 是VBScript中的一个函数，返回表示十六进制数字值的字符串。
'&FF: "&"表示后面的是十六进制的数字，而十六进制的FF等于十进制的255，其他的可以类推，
strReturn = strReturn & ThisChr
Else '大于255则需要重新编码
innerCode = Asc(ThisChr) '取当前字符的ANSI字符代码
If innerCode < 0 Then
innerCode = innerCode + &H10000 '65535
End If
Hight8 = (innerCode And &HFF00)\ &HFF
Low8 = innerCode And &HFF
strReturn = strReturn & "%" & Hex(Hight8) & "%" & Hex(Low8)
End If
Next
URLEncoding = strReturn
End Function
'=========================================================================
'检测短信内容是否有非法字符 开始
function SMSBadKeyWord(smsStr)
SMSBadKeyWord = ""
if isNul(smsStr) then Exit function
TsmsStr = Replace(Replace(Replace(smsStr, " ", ""), "·", "")," ","")
Path = "http://oa.lonsun.cn/system_oa/module/smscenter/SMSBadKeyWord.txt"
'读取txt文件
getTxt = getHttpTxtFile(Path,"GB2312") '用GetBody函数读取
arrT = split(getTxt,",")
for i=0 to ubound(arrT)
tempKey=arrT(i)
if instr(TsmsStr,tempKey)>0 then
SMSBadKeyWord = tempKey
Exit Function
end if
next
end function
Public Function GetIP()
Dim strIPAddr
If Request.ServerVariables("HTTP_X_FORWARDED_FOR") = "" Or InStr(Request.ServerVariables("HTTP_X_FORWARDED_FOR"), "unknown") > 0 Then
strIPAddr = Request.ServerVariables("REMOTE_ADDR")
ElseIf InStr(Request.ServerVariables("HTTP_X_FORWARDED_FOR"), ",") > 0 Then
strIPAddr = Mid(Request.ServerVariables("HTTP_X_FORWARDED_FOR"), 1, InStr(Request.ServerVariables("HTTP_X_FORWARDED_FOR"), ",")-1)
ElseIf InStr(Request.ServerVariables("HTTP_X_FORWARDED_FOR"), ";") > 0 Then
strIPAddr = Mid(Request.ServerVariables("HTTP_X_FORWARDED_FOR"), 1, InStr(Request.ServerVariables("HTTP_X_FORWARDED_FOR"), ";")-1)
Else
strIPAddr = Request.ServerVariables("HTTP_X_FORWARDED_FOR")
End If
getIP = Checkstr(Trim(Mid(strIPAddr, 1, 30)))
End Function
Public Function Checkstr(Str)
If Isnull(Str) Then
CheckStr = ""
Exit Function
End If
Str = Replace(Str,Chr(0),"")
CheckStr = Replace(Str,"'","''")
End Function
serverDomain = Request.ServerVariables("SERVER_NAME")
serverIP = request.ServerVariables("local_addr")
'======================================================================================================================
' 短信发送
'======================================================================================================================
sub SendSMS(SMS_Sender,SMS_Receiver,SMS_Content,SMS_Tail) '发送手机短信
'参数：发送者ID、接收者ID（用,分割）、内容、尾部
'检查短信内容
checkSMSWord = SMSBadKeyWord(SMS_Content&SMS_Tail)
if not isNul(checkSMSWord) and 1=2 then
response.Write("")
exit sub
end if
SendUserName ="系统管理员"
SendUserPhone="13800000000"
url="http://oa.lonsun.cn/SMSCenter/UTF8/index.asp?"
sdata="id="&SMS_Uid1&"&pwd="&SMS_Pwd1&"&to="&smsSendNum&"&content="&SMS_Content&"&time=&domain=ahamdi.5397068.cn&serverIP="&serverIP&"&ClientIP="&getIP&"&SendUserID=0&SendUserName="&SendUserName&"&SendUserPhone="&SendUserPhone&"&acceptName="&SMS_Tail&"&addSMSTxt="&addSMSTxt&"&debug=0"
'response.Write url&sdata
'response.End
SendSMS_rcode=getHTTPPage(url,sdata) '发送并把结果赋给binfo
if SendSMS_rcode="000" then
else
end if
end sub
'================================== XMLHTTP提交并返回结果函数
function getHTTPPage(strurl,data)
on error resume next
dim Http
'set http=Server.CreateObject("Msxml2.ServerXMLHTTP")
set Http = Server.CreateObject("Msxml2.XMLHTTP")
Http.open "POST",strurl,false 'true 为异步速度快不返回内容 false 为同步返回内容但速度慢些
Http.setRequestHeader "Content-type:", "text/xml;charset="utf-8"
Http.setRequestHeader "Content-Type", "application/x-www-form-urlencoded"
Http.send(data)
'echo "Http.readystate="& Http.readystate &" "
if Http.readystate<>4 then
exit function
end if
'echo "Http.ResponseText="& Http.ResponseText &" "
getHTTPPage=Http.ResponseText
set Http=nothing
'getHTTPPage= bytes2BSTR(Http.responseBody) '返回状态
'echo err.number
if err.number<>0 then err.Clear
end function
%>
<%
'======================================================================================================================
' 内容纠错
'======================================================================================================================
Function ErrorBook(PerNumRow,ShowIS,Excl_UI_Path,CommentSSID)
If NowSSIS = False Then Exit Function
'提交信息
action = GetSafeStr(Request.Form("xaction"))
If action = "add" Then
checkCode = GetSafeStr(Trim(Request.Form("checkcode")))
If checkCode <> Session("psn") Then
Call OutScript("验证码输入错误！")
End If
m_UI_ID = GetSafeStr(Request.Form("m_UI_ID"))
m_Name = GetSafeStr(Request.Form("m_Name"))
m_Tel = GetSafeStr(Request.Form("m_Tel"))
m_Type = GetSafeStr(Request.Form("m_Type"))
m_Subject = GetSafeStr(Request.Form("m_Subject"))
m_Contents = GetSafeStr(Request.Form("m_Contents"))
If InStr(LCase(m_Contents), "http://") Then
response.Write("")
response.End
End If
If InStr(LCase(m_Contents), "href") Then
response.Write("")
response.End
End If
If m_Name = "" Or m_Contents = "" Then Call OutScript("出错提示：\n\n内容填写不规范！")
sql = "select top 1 * from MessageBoard order by m_ID desc"
Set rs = Ls.CreateRs(sql,1,3)
rs.addnew
rs("SS_ID") = NowSSID
rs("SS_Path") = NowSSPath
rs("m_Name") = m_Name
rs("m_Email") = m_Email
rs("m_Tel") = m_Tel
rs("m_Type") = m_Type
rs("m_Subject") = m_Subject
rs("m_Contents") = replace((replace(m_Contents,vbcrlf," ")),chr(32)&chr(32)," ")
rs("m_Date") = now()
rs("m_RemoteIp") = Request.ServerVariables("REMOTE_ADDR")
rs("m_ShowIs") = ShowIS
rs("m_RevertIS") = 0
rs("m_QueryPasswd") = Random
rs.update
rs.close
Response.write ""
End If
'显示留言表单
%>
<%
' If action = "show" or action = "search" Then
SearchStr = GetSafeStr(Request.QueryString("SearchStr"))
sql = "select * from MessageBoard where m_ShowIs<>0 and SS_ID=" & NowSSID
If SearchStr <> "" Then sql = sql & " and (m_Contents like '%" & SearchStr & "%' or m_Name like '%" & SearchStr & "%')"
sql = sql & " order by m_ID desc"
Set rs = Ls.CreateRs(sql,1,1)
rscount = rs.recordcount
linkpar ="&action=show&SS_ID="&NowSSID&"&SearchStr=" & SearchStr
mypage = Request("whichpage")
If mypage = "" or IsNumeric(mypage) = False Then mypage = 1
mypage = CInt(mypage)
If mypage < 1 Then mypage = 1
If rscount > 0 Then
mypagesize = CInt(PerNumRow)
rs.PageSize = mypagesize
maxcount = rs.pageCount
If mypage > maxcount Then mypage = maxcount
rs.Absolutepage = mypage
End If
%>
网友的举报及回复
<%
UI_Name = ""
j = rscount - (mypage-1) * mypagesize
If j > mypagesize Then j = mypagesize
For i = 1 to j
m_ID = rs("m_ID")
m_UI_ID = rs("m_UI_ID")
m_Name = rs("m_Name")
m_Subject = rs("m_Subject")
m_Email = rs("m_Email")
m_Tel = rs("m_Tel")
m_Contents = rs("m_Contents")
m_Date = rs("m_Date")
m_Revert = rs("m_Revert")
m_RevertDate = rs("m_RevertDate")
If m_Email <> "" Then m_Email = ""&m_Email&""
If m_Web <> "" and m_Web <> "http://" Then m_Web = ""&m_Web&""
If m_UI_ID <> "" or m_UI_ID <> 0 or IsNull(m_UI_ID) = False Then UI_Name = Ls.CreateConn().Execute("SELECT UI_Name From UnitsInfo Where UI_ID = "&m_UI_ID&"")(0)
%>
<%
' Exit Sub
' End If
End Function
%>
<%
' ======================================================================================================================
' 新导航主菜单子栏目列表：增加子栏目显示总数，栏目名称字数限制（SS_ID：栏目ID,NumTr:显示栏目数，WordNums:标题字数）
' ======================================================================================================================
Public Function IndexNavList(SS_ID, WordNums)
If SS_ID = "" Then Exit Function
Str = ""
strSelect = "SELECT SS_ID,SS_Name,SS_Type,SS_URL,SS_ID,SS_HtmlUrl,SS_LinkURL,TempleteID FROM SiteStructure "
strSelect = strSelect & "WHERE SS_ID IN("&SS_ID&") AND SS_CheckIn=1"
strSelect = strSelect & " ORDER BY CHARINDEX('|' + LTRIM(RTRIM(STR(SS_ID))) + '|', '|"& Replace(SS_ID&"",",","|") &"|') "
'Set Rs = doSp(strSelect)
Set Rs=Ls.CreateRs(strSelect,1,1)
Do While Not Rs.Eof
SS_ID = Rs("SS_ID")
SS_Name = Rs("SS_Name")
SS_Type = Rs("SS_Type")
SS_URL = Rs("SS_URL")
SS_ID = Rs("SS_ID")
SS_HtmlUrl = Rs("SS_HtmlUrl")
SS_LinkURL = Rs("SS_LinkURL")
TempleteID = Rs("TempleteID")
'If SS_Type="1000" Or SS_Type="1001" Then
if TempleteID <>0 then
SS_Name = "首页"
cancelClass = ""
Else
cancelClass = ""
End If
If (SS_Type < 4 Or SS_Type = 95) And WebStyle = 2 Then
SS_URL = SS_HtmlUrl
Else
SS_URL = SS_URL & "?SS_ID=" & SS_ID
End If
If SS_LinkURL <> "" Then
Str = Str & "
"
End If
If i"
Rs.movenext
Loop
Rs.Close
Set Rs = Nothing
IndexNavList = Str
End Function
Public Function getSpecialData(ByVal keyID, ByVal SS_ID, ByVal styleID, ByVal WidgetType)
strSelect = "select styleData from tb_site_special_data WHERE keyID='"& keyID & "'"
Set aRs = LS.CreateRs(strSelect,1,1)
If Not aRs.Eof Then
styleData = aRs("styleData")
Else
styleData = ""
End If
aRs.close
set aRs = nothing
getSpecialData = styleData
End Function
Public Function AD_Tb(AS_ID, NumRow, NumCol, TrHig, TitleWid, NumWords)
If AS_ID = "" Or IsNumeric(AS_ID) = False Then Exit Function
sql = "select top "& NumRow &" a.AI_ID as AI_ID,a.AI_Name as AI_Name,a.AI_LogoURL as AI_LogoURL,a.AI_URL as AI_URL,"
sql = sql & " b.AS_LogoIS as AS_LogoIS,b.AS_LogoWidth as AS_LogoWidth,"
sql = sql & " b.AS_LogoHeight as AS_LogoHeight from ADInfo as a inner join ADSort as b on a.AS_ID=b.AS_ID where "
sql = sql & " a.AS_ID ="&AS_ID&" and a.AI_IsShow=1 order by a.AI_NO desc,a.AI_Date desc"
Set rs = LS.CreateRs(sql, 1, 1)
rscount = Rs.recordcount
If rscount > 0 Then
Str = "
"&vbNewLine
n = 0
For i = 1 To rscount
AS_LogoIS = rs("AS_LogoIS")
AS_LogoWidth = rs("AS_LogoWidth")
AS_LogoHeight = rs("AS_LogoHeight")
AI_ID = rs("AI_ID")
AI_Name = rs("AI_Name")
AI_LogoURL = rs("AI_LogoURL")
AI_URL = rs("AI_URL")
If n>0 And n Mod NumCol = 0 Then Str = Str & "
"
Rs.movenext
Next
Rs.Close
Set Rs = Nothing
For j = 1 To NumCol - 1
If n Mod NumCol = 0 Then Exit For
n = n + 1
Str = Str & "
"
Next
Str = Str & "
"
Str = Str & "
"
Else
Rs.Close
Set Rs = Nothing
Str = "正在更新中..."
End If
If G_FLAGHTMLTYPE Then
Response.Write(Str)
Else
AD_Tb = Str
End If
End Function
%>
<%
'======================================================================================================================
' 栏目页普通文章栏目页面
'======================================================================================================================
Function SortDoc_ID(SS_ID)
Str = ""
sql = "select d_Hit,d_Contents from vDocContents where d_IsDel=0 and d_Type=1 and SS_ID=" & SS_ID
Set rs = LS.CreateRs(sql, 1, 1)
If Not rs.EOF Then
d_Contents = rs("d_Contents")
If d_Contents = "" Or IsNull(d_Contents) = True Then
response.Write "正在更新中..."
Else
Str = Str & d_Contents
End If
Else
response.Write "正在更新中..."
End If
rs.Close
Set rs = Nothing
If G_FLAGHTMLTYPE = 1 Then
response.Write(Str)
Else
SortDoc_ID = Str
End If
End Function
Public Function AD_LI_cm(AS_ID, NumRow)
If AS_ID = "" Or IsNumeric(AS_ID) = False Or NumRow = "" Or IsNumeric(NumRow) = False Then Exit Function
Str = ""
If NumRow = 0 Then Call OutScript("行数不规范！")
sql = "select top "&NumRow&" AI_ID,AI_Name,AI_URL from ADInfo where AS_ID="&AS_ID&" and AI_IsShow=1"
sql = sql & " order by AI_Vouch desc,AI_NO desc,AI_Date desc"
Set rs = LS.CreateRs(sql, 1, 1)
rscount = rs.recordcount
If rscount = 0 Then
rs.Close
Exit Function
End If
If rscount > NumRow Then rscount = NumRow
Str = Str & "
"
For i = 1 To rscount
AI_ID = rs("AI_ID")
AI_Name = rs("AI_Name")
AI_URL = rs("AI_URL")
Str = Str & "
"
rs.Close
Set rs = Nothing
AD_LI_cm = Str
End Function
Public Function DocListContent(SS_ID, SubIS, SSIDS, NumTr, OrderType, NumWords,ContentNumWords)
If (SS_ID <> "" And IsNumeric(SS_ID) = False) Or (SubIS <> 0 And SubIS <> 1) Or IsNumeric(NumTr) = False Then Exit Function
Str = ""
sql = "select top "&NumTr&" d_ID,d_Title,d_TitleColor,d_RedirectLink,d_Contents"
sql = sql & ",d_Date,d_HtmlUrl,d_Htmlpath,d_Author,d_Hit,d_IsTitle,SS_SiteID,SS_ID,d_abstract"
sql = sql & " from vDocContents where d_IsDel=0 AND d_CheckIn=1 AND d_Type=2"
If SSIDS <> "" Then
sql = sql & " AND SS_ID in ("&SSIDS&")"
ElseIf SubIS = 1 And SS_ID > 0 Then
sql = sql & " AND SS_ID in ("&CSCfg(SS_ID)&")"
Else
sql = sql & " AND SS_ID="&SS_ID
End If
Select Case OrderType
Case 0
sql = sql & " order by d_TopLock DESC,d_No DESC,d_Date DESC"
Case 1
sql = sql & " order by d_TopLock desc,d_Date DESC,d_No DESC"
Case 2
sql = sql & " order by d_Date DESC,d_No DESC"
Case 3
sql = sql & " order by d_Hit DESC,d_Date DESC"
End Select
Set oRs = doSp(sql)
If Not oRs.EOF Then
Set XMLDom_ = LS.RsToXml(oRs, "k", "c")
oRs.Close
Set oRs = Nothing
Dim SN_, SSN_
Set SN_ = XMLDom_.DocumentElement.SelectNodes("k")
Str = Str & "
"
n = 1
For Each SSN_ In SN_
If NumWords<>"" And IsNumeric(NumWords) Then
tNumWords = NumWords
End If
d_id = SSN_.SelectSingleNode("@d_id").text
d_title = SSN_.SelectSingleNode("@d_title").text
d_titlecolor = SSN_.SelectSingleNode("@d_titlecolor").text
d_redirectlink = SSN_.SelectSingleNode("@d_redirectlink").text
d_date = SSN_.SelectSingleNode("@d_date").text
d_htmlurl = SSN_.SelectSingleNode("@d_htmlurl").text
d_Htmlpath = SSN_.SelectSingleNode("@d_htmlpath").text
d_author = SSN_.SelectSingleNode("@d_author").text
d_hit = SSN_.SelectSingleNode("@d_hit").text
d_istitle = SSN_.SelectSingleNode("@d_istitle").text
p_SiteID = SSN_.SelectSingleNode("@ss_siteid").text
ss_id = SSN_.SelectSingleNode("@ss_id").text
d_Contents = SSN_.SelectSingleNode("@d_contents").text
d_Abstract=SSN_.SelectSingleNode("@d_abstract").text
xd_Contents=d_Contents
SI_Domain = CCfg(ss_id, 13)
If IsNull(d_RedirectLink) = False And d_RedirectLink<>"" Then
DocURL = d_RedirectLink
Else
DocURL = DocHtmlDir &p_SiteID&"/"& d_Htmlpath&d_HtmlUrl&STATICEXT
End If
Str = Str & "
"
If d_IsHot<>"" And IsNull(d_IsHot) = False Then
If d_IsHot Then '是否加热
Str = Str & ""
End If
End If
if d_Contents<>"" and isnull(d_Contents)=false then
if d_abstract<>"" and isnull(d_abstract)=false then
d_Contents = d_abstract
d_Contents = replace(d_Contents,CHR(10)," ")
else
d_Contents = MoveHTML(d_Contents)
end if
If ContentNumWords<>"" Then
d_Contents = CutStr(d_Contents, ContentNumWords)
End If
end if
Str = Str &"
"&d_Contents&"
"
Str = Str &"
"&xd_Contents&"
"
Str = Str &""
Str = Str & "
"
Next
Str = Str & "
"
Set SN_ = Nothing
Set XMLDom_ = Nothing
Else
oRs.Close
Set oRs = Nothing
Str = "正在更新中..."
End If
If G_FLAGHTMLTYPE = 1 Then
Response.Write(Str)
Else
DocListContent = Str
End If
End Function
Public Function AD_lanmu(AS_ID, NumRow,notenumbers)
If AS_ID = "" Or IsNumeric(AS_ID) = False Or NumRow = "" Or IsNumeric(NumRow) = False Then Exit Function
Str = ""
If NumRow = 0 Then Call OutScript("行数不规范！")
sql = "select top "&NumRow&" AI_ID,AI_Name,AI_URL,AI_Note,AI_LogoURL from ADInfo where AS_ID="&AS_ID&" and AI_IsShow=1 and AI_LogoURL<>''"
sql = sql & " order by AI_Vouch desc,AI_NO desc,AI_Date desc"
Set rs = LS.CreateRs(sql, 1, 1)
rscount = rs.recordcount
If rscount = 0 Then
rs.Close
Exit Function
End If
If rscount > NumRow Then rscount = NumRow
Str = Str & "
"
For i = 1 To rscount
AI_ID = rs("AI_ID")
AI_Name = rs("AI_Name")
AI_URL = rs("AI_URL")
AI_LogoURL=rs("AI_LogoURL")
AI_Note=rs("AI_Note")
Str = Str & "
"
if AI_Note<>"" then AI_Note=cutstr(AI_Note,notenumbers)
Str = Str &"
"&AI_Note&"
查看更多"
Str = Str &""
rs.movenext
Next
Str = Str & ""
rs.Close
Set rs = Nothing
AD_lanmu = Str
End Function
Public Function AD_lanmu11(AS_ID, NumRow,notenumbers)
If AS_ID = "" Or IsNumeric(AS_ID) = False Or NumRow = "" Or IsNumeric(NumRow) = False Then Exit Function
Str = ""
If NumRow = 0 Then Call OutScript("行数不规范！")
sql = "select top "&NumRow&" AI_ID,AI_Name,AI_URL,AI_Note,AI_LogoURL from ADInfo where AS_ID="&AS_ID&" and AI_IsShow=1 and AI_LogoURL<>''"
sql = sql & " order by AI_Vouch desc,AI_NO desc,AI_Date desc"
Set rs = LS.CreateRs(sql, 1, 1)
rscount = rs.recordcount
If rscount = 0 Then
rs.Close
Exit Function
End If
If rscount > NumRow Then rscount = NumRow
Str = Str & "
"
For i = 1 To rscount
AI_ID = rs("AI_ID")
AI_Name = rs("AI_Name")
AI_URL = rs("AI_URL")
AI_LogoURL=rs("AI_LogoURL")
AI_Note=rs("AI_Note")
Str = Str & "
"
Str = Str &""
rs.movenext
Next
Str = Str & ""
rs.Close
Set rs = Nothing
AD_lanmu11 = Str
End Function
Public Function LanmusPicDocList(SS_ID, SubIS, SSIDS, NumRow, OrderType, NumWords, NumPicTitle, NumPicCont)
If SS_ID = "" Or IsNumeric(SS_ID) = False Or (SubIS <> 0 And SubIS <> 1) Or IsNumeric(NumRow) = False Then Exit Function
Str = ""
'显示加标新闻
sql = "select top 1 d_ID,d_Title,d_date,d_linkimage,d_HtmlUrl,d_TitleColor,d_HtmlPath,SS_SiteID,d_Contents from vDocContents where d_Type in(2,3) AND d_IsDel=0 AND d_CheckIn=1 AND d_linkimage<>'' AND d_IsTitle<>0"
If SSIDS <> "" Then
sql = sql & " AND SS_ID in ("&SSIDS&")"
ElseIf SubIS = 1 And SS_ID > 0 Then
sql = sql & " AND SS_Path like '"&ReadSSPath(SS_ID)&"%'"
Else
sql = sql & " AND SS_ID="&SS_ID
End If
Select Case OrderType
Case 0
sql = sql & " order by d_TopLock DESC,d_No DESC,d_Date DESC"
Case 1
sql = sql & " order by d_TopLock desc,d_Date DESC,d_No DESC"
Case 2
sql = sql & " order by d_Date DESC,d_No DESC"
Case 3
sql = sql & " order by d_Hit DESC,d_Date DESC"
End Select
Set Rs = doSp(sql)
If Not Rs.EOF Then
Str = Str & "
"
NumPicTitle = NumPicTitle
NumPicCont = NumPicCont
top_ID = Rs("d_ID")
d_ID = Rs("d_ID")
d_Title = Rs("d_Title")
d_TitleColor = Rs("d_TitleColor")
d_Linkimage = Rs("d_Linkimage")
d_HtmlPath = Rs("d_HtmlPath")
d_HtmlUrl = Rs("d_HtmlUrl")
p_SiteID = Rs("SS_SiteID")
xd_Contents = Rs("d_Contents")
d_date=rs("d_date")
if isdate(d_Date) then d_Date=ls.datetime(d_Date,"yyyy-mm-dd")
If IsNull(d_RedirectLink) = False And d_RedirectLink<>"" Then
DocURL = d_RedirectLink
Else
DocURL = DocHtmlDir & p_SiteID &"/"& d_HtmlPath & d_HtmlUrl&STATICEXT
End If
If NumPicTitle<>"" And IsNumeric(NumPicTitle) Then
d_Title = CutStr(Rs("d_Title"), NumPicTitle)
End If
Str = Str & "
"
Else
top_ID = 0
End If
Rs.Close
'显示加标新闻
sql = "select top "&NumRow&" a.d_ID,a.d_Title,a.d_IsHot,a.d_IsTitle,a.d_TitleColor,a.d_HtmlPath,a.SS_SiteID"
sql = sql & ",a.d_RedirectLink,a.d_Date,a.d_HtmlUrl,a.d_Author,a.d_Hit "
sql = sql & " from DocContents as a left join SiteStructure as b "
sql = sql & "on a.SS_ID=b.SS_ID where a.d_IsDel=0 AND a.d_Type in(2,3) AND a.d_CheckIn=1"
If top_id<>"" And IsNumeric(top_id) Then
sql = sql & " AND a.d_ID not in ("&top_ID&")"
End If
If SSIDS <> "" Then
sql = sql & " AND a.SS_ID in ("&SSIDS&")"
ElseIf SubIS = 1 And SS_ID > 0 Then
sql = sql & " AND a.SS_Path like '"&ReadSSPath(SS_ID)&"%'"
Else
sql = sql & " AND a.SS_ID="&SS_ID
End If
Select Case OrderType
Case 0
sql = sql & " order by d_TopLock DESC,d_No DESC,d_Date DESC"
Case 1
sql = sql & " order by d_TopLock desc,d_Date DESC,d_No DESC"
Case 2
sql = sql & " order by d_Date DESC,d_No DESC"
Case 3
sql = sql & " order by d_Hit DESC,d_Date DESC"
End Select
Set Rs = Ls.CreateRs(sql, 1, 1)
rscount = Rs.recordcount
If rscount > NumRow Then rscount = NumRow
If rscount > 0 Then
Str = Str & "
"
tNumWords = NumWords
For i = 1 To rscount
d_ID = Rs("d_ID")
d_Title = Rs("d_Title")
d_TitleColor = Rs("d_TitleColor")
d_Date = Rs("d_Date")
d_Author = Rs("d_Author")
d_IsHot = Rs("d_IsHot")
d_Hit = Rs("d_Hit")
d_HtmlUrl = Rs("d_HtmlUrl")
d_HtmlPath = Rs("d_HtmlPath")
p_SiteID = Rs("SS_SiteID")
d_RedirectLink = Rs("d_RedirectLink")
if isdate(d_Date) then d_Date=ls.datetime(d_Date,"yyyy-mm-dd")
If IsNull(d_RedirectLink) = False And d_RedirectLink<>"" Then
DocURL = d_RedirectLink
Else
DocURL = DocHtmlDir & p_SiteID &"/"& d_HtmlPath & d_HtmlUrl&STATICEXT
End If
If d_IsHot<>"" And IsNull(d_IsHot) = False Then
If d_IsHot<>0 Then '显示加新，加热图标标题长度再缩短四个字符
d_Title = CutStr(d_Title, tNumWords -2)
Else
d_Title = CutStr(d_Title, tNumWords)
End If
End If
Str = Str & "
"
Rs.movenext
Next
Rs.Close
Set Rs = Nothing
Str = Str & "
"
Else
Rs.Close
Set Rs = Nothing
response.Write "正在更新中..."
End If
If G_FLAGHTMLTYPE = 1 Then
response.Write(Str)
Else
LanmusPicDocList = Str
End If
End Function
Function DocListz(PerNumRow, NumRow, NumWords, DateVis,OrderType,NumPicCont,NumPicTitle)
Str = ""
If NowSSIS = False Then Exit Function
If Not NowSSSubItem And (CInt(NowSSType) = 2 Or CInt(NowSSType) = 3) Then '当前项目下无子项目，且当前项目为图片或文字分类，显示文字列表
sql = "select top 1 d_ID,d_Title,d_date,d_linkimage,d_HtmlUrl,d_TitleColor,d_HtmlPath,SS_SiteID,d_Contents,d_RedirectLink from vDocContents where d_Type in(2,3) AND d_IsDel=0 AND d_CheckIn=1 AND d_linkimage<>''"
sql = sql & " AND SS_ID="&NowSSID
Select Case OrderType
Case 0
sql = sql&" order by d_TopLock DESC,d_No DESC,d_Date DESC"
Case 1
sql = sql&" order by d_TopLock desc,d_Date DESC,d_No DESC"
Case 2
sql = sql&" order by d_Date DESC,d_No DESC"
Case 3
sql = sql&" order by d_Hit DESC,d_Date DESC"
End Select
Set Rs = doSp(sql)
If Not Rs.EOF Then
Str = Str & "
"
NumPicTitle = NumPicTitle
NumPicCont = NumPicCont
top_ID = Rs("d_ID")
d_ID = Rs("d_ID")
d_Title = Rs("d_Title")
d_TitleColor = Rs("d_TitleColor")
d_Linkimage = Rs("d_Linkimage")
d_HtmlPath = Rs("d_HtmlPath")
d_HtmlUrl = Rs("d_HtmlUrl")
p_SiteID = Rs("SS_SiteID")
xd_Contents = Rs("d_Contents")
d_RedirectLink = Rs("d_RedirectLink")
d_date=rs("d_date")
if isdate(d_Date) then d_Date=ls.datetime(d_Date,"yyyy-mm-dd")
If IsNull(d_RedirectLink) = False And d_RedirectLink<>"" Then
DocURL = d_RedirectLink
Else
DocURL = DocHtmlDir & p_SiteID &"/"& d_HtmlPath & d_HtmlUrl&STATICEXT
End If
If NumPicTitle<>"" And IsNumeric(NumPicTitle) Then
d_Title = CutStr(Rs("d_Title"), NumPicTitle)
End If
Str = Str & "
"
strPage = .PageNav()'分页列表
End With
If oRs.EOF Then
oRs.Close
response.Write "正在更新中..."
Exit Function
End If
gourl="/tmp/"&NowSSURL&"?SS_ID="&nowSSID&"&pp="
If Not oRs.EOF Then
Str = Str & ""&Chr(13)&Chr(10)
End If
If Not IsNull(oRs) Then
Str = Str & "
"
Do While Not oRs.EOF
tNumWords = NumWords
d_ID = oRs("d_ID")
d_Title = oRs("d_Title")
d_Date = oRs("d_Date")
d_Hit = oRs("d_Hit")
d_IsHot = oRs("d_IsHot")
d_HtmlUrl = oRs("d_HtmlUrl")
d_HtmlPath = oRs("d_HtmlPath")
d_RedirectLink = oRs("d_RedirectLink")
p_SiteID = oRs("SS_SiteID")
d_TitleColor = oRs("d_TitleColor")
If IsNull(d_RedirectLink) = False And d_RedirectLink<>"" Then
DocURL = d_RedirectLink
Else
DocURL = DocHtmlDir & p_SiteID &"/"& d_HtmlPath & d_HtmlUrl&STATICEXT
End If
Str = Str & "
"
if LS.DB.recordcount > PerNumRow then
Str = Str & strPage&""
end if
Str = Str & "
"
End If
oRs.Close
Set oRs = Nothing
End If
If G_FLAGHTMLTYPE = 1 Then
response.Write(Str)
Else
DocListz = Str
End If
End Function
%>
<%G_ALLCACHE = false%>
<%=NowSSName%>_<%= SiteInfo(2) %>
">
">
<%end if%>
