related.inc

精品OA,已经本人测试成功,完全可用,使我花钱从别人那买的.商业源码仅供学习交流,请勿用于商业用途. 在建立数据库时

<SCRIPT LANGUAGE="VBScript" RUNAT="Server">
Dim arrTop,arrRest, gLastMsgLvl
'定义8个常数，数值代表其位于GetRows()函数中的栏顺序
Const cMaxMsgLvl = 10
Const cID = 0
Const cName = 1
Const cMsgLevel = 2
Const cPrevRef = 3
Const cThreadPos = 4

Sub Main()
  xprevref=request("id")
  do 
    SQLstr = "SELECT DISTINCT ChannelID,ChannelName,"
    SQLstr = SQLstr & "MsgLevel,PrevRef,"
    SQLstr = SQLstr & "ThreadPos FROM sq_selfchannel "
    SQLstr = SQLstr & "where channelid=" & xprevref & " and display=1"
	set rstop=conn.execute(sqlstr)
	xmsglevel=rstop("msglevel")
	xprevref=rstop("prevref")
	xid=rstop("channelid")
  loop	while xmsglevel>1
  
  If Not RSTop.EOF Then
    Response.Write "<br><hr>" 
    Response.Write "<P><a name=related><font color='#00008b'><strong>相关栏目：</strong></font></a></P>"

    '以GetRows()函数取出30笔最新的标题至arrTop数组
    arrTop = RSTop.GetRows
    '抓出MsgLevel > 1的文章标题
    SQLstr = "SELECT DISTINCT ChannelID,ChannelName,"
    SQLstr = SQLstr & "MsgLevel,PrevRef,"
    SQLstr = SQLstr & "ThreadPos FROM sq_selfchannel "
    SQLstr = SQLstr & "WHERE MsgLevel > 1 and display=1"
    'SQLstr = "select * from Forum where MsgLevel>1"

    '建立Recordset
    Set RSRest=Conn.Execute(SQLstr)
    If Not RSRest.EOF Then
    '同样以GetRows()函数取出所有的文章至arrRest数组
       arrRest = RSRest.GetRows()
    Else
       arrRest = Empty
    End If
      
    Sqlstr="select channelid from sq_selfchannel where prevref=" & xid & " and display=1"  
    Set rrs=conn.execute(sqlstr)
      
    '记录目前的Message Level
    gLastMsgLvl = 0
    '以<ul type=disc>标签组降序排列文章
    If Not rrs.EOF Then
       Show_UL arrTop(cMsgLevel, i), arrTop, i
       '扩展该Thread的所有回覆文章
       ExpandAll arrTop(cID, i), 1
       Show_UL 0, 0, 0
       rrs.close
       set rrs=nothing
       RSRest.Close
       set rsrest=nothing
    Else
       Response.Write "<p>&nbsp;&nbsp;无相关栏目！<br>"
    End If
  
  Else
   Response.Write "<br>" 
   Response.Write "<p>查询出错，请与<a href='mailto:[e-mail]'>易读网联系！</a><br>"
  End If

  RSTop.Close
  set rstop=nothing
End Sub

Function Show_UL(NewMsgLvl, TopArray, intRow)
  Dim Ind
  '输出<UL>标签;
  For Ind = gLastMsgLvl To NewMsgLvl - 1
    'Response.Write "<UL TYPE=DISC>" & vbCrlf
    Response.Write "<UL>" & vbCrlf
  Next
  '输出</UL>标签
  For Ind = NewMsgLvl To gLastMsgLvl -1
    Response.Write "</UL>"
  Next
  If NewMsgLvl > 0 Then
    '摘要显示某笔文章
    Response.Write ListTr(TopArray, intRow)
  End If
  gLastMsgLvl = NewMsgLvl
End Function

Function ListTr(SrcArray, intRow)

  ListTr = "<LI>" & vbCrlf 
  If cint(request("id"))<>SrcArray(cID, intRow) Then
	ListTr = ListTr & "<A HREF='" & "showinfo.asp?id=" & SrcArray(cID, intRow) & "&class=" & treeid & "'> "& SrcArray(cName, intRow) & "</A>"
  Else 
    Listtr = ListTr & SrcArray(cName, intRow)	
  End if
  ListTr = ListTr & vbCrLf

End Function

Sub ExpandAll(lngID, iThPos)
  'Message Level需小于等于10层
  If iThPos <= cMaxMsgLvl Then
     For lngRow = 0 To UBound(arrRest, 2)
       '如果找到回覆文章
       If (arrRest(cPrevRef, lngRow) = lngID) And _
          (arrRest(cThreadPos, lngRow) = iThPos) Then
         '显示该Thread，然后再一层一层展开
         Show_UL arrRest(cMsgLevel, lngRow), arrRest, lngRow
         '递回呼叫自己(为了展开回覆文章)
         ExpandAll arrRest(cID, lngRow), 1
         Exit For
       End If
     Next
     
     ExpandAll lngID, iThPos + 1
  End If
End Sub
</script>