[xanburzum]

Quem está online? sem usar Global.asa

abaixo os códigos :

activeusers.asp

CÓDIGO

<%
Response.Expires=0
Response.Buffer = True
Response.ExpiresAbsolute = Now() - 1
Response.CacheControl = "no-cache"
Response.AddHeader "cache-control", "private"
Response.AddHeader "pragma", "no-cache"
%>
<script language="VBScript" runat="server">
Sub Application_onstart
    Session.Timeout = 10
        Application.Lock()
    Application("id.online") = ""
        Application.UnLock()
End Sub
Sub Application_onend
        Application.Lock()
    Application("id.online") = ""
        Application.UnLock()
End Sub
Sub Session_onend
        Application.Lock()
    Application("id.online") = Replace(Application("id.online"),Request.Cookies("id")&",","")
        Application.UnLock()
End Sub
</script>
<%
Sub LogActiveUser
    Dim strActiveUserList
    Dim intUserStart, intUserEnd
    Dim strUser
    Dim strDate
    strActiveUserList = Application("ActiveUserList")

    If Instr(1, strActiveUserList, Session.SessionID) > 0 Then
        Application.Lock
        intUserStart = Instr(1, strActiveUserList, Session.SessionID)
        intUserEnd = Instr(intUserStart, strActiveUserList, "|")
        strUser = Mid(strActiveUserList, intUserStart, intUserEnd - intUserStart)
        strActiveUserList = Replace(strActiveUserList, strUser, Session.SessionID & ":" & Now())
        Application("ActiveUserList") = strActiveUserList
        Application.UnLock
          
    Else
        Application.Lock
        Application("ActiveUsers") = CInt(Application("ActiveUsers")) + 1
        Application("ActiveUserList") = Application("ActiveUserList") & Session.SessionID & ":" & Now() & "|"
        Application.UnLock

    End If
End Sub

Sub ActiveUserCleanup
    Dim ix
    Dim intUsers
    Dim strActiveUserList
    Dim aActiveUsers
    Dim intActiveUserCleanupTime
    Dim intActiveUserTimeout

    intActiveUserCleanupTime = 2 'Em minutos, para que a ActiveUserList seja limpa.
    intActiveUserTimeout = 10 'Em minutos, para verificar, após esse tempo, se um usuário está inativo e deletá-lo da ActiveUserList.

    If Application("ActiveUserList") = "" Then Exit Sub

    If DateDiff("n", Application("ActiveUsersLastCleanup"), Now()) > intActiveUserCleanupTime Then

        Application.Lock
        Application("ActiveUsersLastCleanup") = Now()
        Application.Unlock

        intUsers = 0
        strActiveUserList = Application("ActiveUserList")
        strActiveUserList = Left(strActiveUserList, Len(strActiveUserList) - 1)

        aActiveUsers = Split(strActiveUserList, "|")

    For ix = 0 To UBound(aActiveUsers)
    If DateDiff("n", Mid(aActiveUsers(ix), Instr(1, aActiveUsers(ix), ":") + 1, Len(aActiveUsers(ix))), Now()) > intActiveUserTimeout Then
        aActiveUsers(ix) = "XXXX"
        
        Application.Lock()
            Application("id.online") = Replace(Application("id.online"),Request.Cookies("id")&",","")
        Application.UnLock()
    Else
        intUsers = intUsers + 1
    End If
Next

strActiveUserList = Join(aActiveUsers, "|") & "|"
strActiveUserList = Replace(strActiveUserList, "XXXX|", "")

    Application.Lock
        Application("ActiveUserList") = strActiveUserList
        Application("ActiveUsers") = intUsers
    Application.UnLock
End If

End Sub
%>

online.asp

CÓDIGO

<!--#include file="activeusers.asp"-->
<!--#include file="conn.asp"-->
<%
Response.Expires=0
Response.Buffer = True
Response.ExpiresAbsolute = Now() - 1
Response.CacheControl = "no-cache"
Response.AddHeader "cache-control", "private"
Response.AddHeader "pragma", "no-cache"
%>
<%
username = Request.Cookies("username")
%>

<%
sql = "SELECT username, id FROM users WHERE username = '" & username & "'"
    Set rsUser = Server.CreateObject("ADODB.Recordset")
    rsUser.Open sql, conn, 3, 3
%>

<%
If (not rsUser.BOF) and (not rsUser.EOF) = True then
    Response.Cookies("id") = rsUser("id")
    Application("id.online") = Application("id.online") &  Request.Cookies("id") & ","
end if
%>

<%
If NOT Application("id.online") = "" Then  
    ids = Cstr(Application("id.online"))
    ids = Left(ids,(Len(ids)-1))
End If
    Dim rs_user
    rs_user = "1"
If (ids <> "") Then  
    rs_user = ids
End If
    Dim rs_useron
Dim rs_useron_numRows

    Set rs_useron = Server.CreateObject("ADODB.Recordset")
    rs_useron.ActiveConnection = conn
    rs_useron.Source = "SELECT username, dob FROM users WHERE id IN(" + Replace(rs_user, "'", "''") + ") ORDER BY username"
    rs_useron.CursorType = 0
    rs_useron.CursorLocation = 2
    rs_useron.LockType = 1
    rs_useron.Open()
    
    rs_useron_numRows = 0
    
    Dim rs_usercount__idApp
    rs_usercount__idApp = "1"
If (ids <> "") Then  
  rs_usercount__idApp = ids
End If

    Dim rs_usercount
    Dim rs_usercount_numRows

    Set rs_usercount = Server.CreateObject("ADODB.Recordset")
    rs_usercount.ActiveConnection = conn
    rs_usercount.Source = "SELECT COUNT(*) as total FROM users WHERE id IN(" + Replace(rs_usercount__idApp, "'", "''") + ")"
    rs_usercount.CursorType = 0
    rs_usercount.CursorLocation = 2
    rs_usercount.LockType = 1
    rs_usercount.Open()

    rs_usercount_numRows = 0

    Dim Repeat2__numRows
    Dim Repeat2__index

    Repeat2__numRows = -1
    Repeat2__index = 0
    rs_useron_numRows = rs_useron_numRows + Repeat2__numRows
%>
<body topmargin="0" leftmargin="0" rightmargin="0" bottommargin="0" marginwidth="0" marginheight="0">
<table width="100%" border="0" cellspacing="0" cellpadding="0"><tr><td><font color="#769AB1"><%=(rs_usercount.Fields.Item("total").Value)%> usuário(s) cadastrado(s) online:</font>&nbsp;

<%  
    While NOT rs_useron.EOF
%>

<%

'Mostra determinados usuários em cores diferentes. Bom para determinar usuários com níveis diferentes no site.

If (rs_useron.Fields.Item("username").Value) = "Cajau" Then
    Response.Write("<b><font color=#3399FF>"&(rs_useron.Fields.Item("username").Value)&"</font></b>")
ElseIf (rs_useron.Fields.Item("username").Value) = "di_giorgio" Then
    Response.Write("<b><font color=#3399FF>"&(rs_useron.Fields.Item("username").Value)&"</font></b>")
ElseIf (rs_useron.Fields.Item("username").Value) = "Miss" Then
    Response.Write("<b><font color=#FF00FF>"&(rs_useron.Fields.Item("username").Value)&"</font></b>")
ElseIf (rs_useron.Fields.Item("username").Value) = "Brunella" Then
    Response.Write("<b><font color=#FF00FF>"&(rs_useron.Fields.Item("username").Value)&"</font></b>")    
ElseIf (rs_useron.Fields.Item("dob").Value) = 1 Then
    Response.Write("<b>"&(rs_useron.Fields.Item("username").Value)&"</b>")
Else

'Usuários comuns cadastrados no site

    Response.Write((rs_useron.Fields.Item("username").Value))
End If
%>

'Acrescenta uma vírgula após os nomes de usuários, caso tenha mais de 1 para ser mostrado
<% If NOT (Repeat2__index+1 = (rs_usercount.Fields.Item("total").Value)) Then Response.Write(", ")%>

<%  
    Repeat2__index=Repeat2__index+1
    Repeat2__numRows=Repeat2__numRows-1
    rs_useron.MoveNext()
Wend
%>
</td></tr></table>

<%
    rs_useron.Close()
    Set rs_useron = Nothing
%>

<%
    rs_usercount.Close()
    Set rs_usercount = Nothing
%>

mostra.asp - página que exibe a quantidade total de users online + nomes dos users cadastrados online

CÓDIGO

<!--#INCLUDE file="activeusers.asp"-->
Existem
<%
Call LogActiveUser()
Call ActiveUserCleanup()

Response.Write Application("ActiveUsers") & " Usuários Online nesse momento."
%>
<br>
<!--#include file="online.asp"-->

login
Na rotina da sua página de login acrescente o seguinte código:

CÓDIGO

  Response.Cookies("id") = rsUser("id")
  Application("id.online") = Application("id.online") &  Request.Cookies("id") & ","

logout
Na rotina da sua página de logout acrescente o seguinte código:

CÓDIGO

If Request.Cookies("id") <> "" Then
    Application("id.online") = Replace(Application("id.online"),Request.Cookies("id")&",","")
    For Each objCookie In Request.Cookies
    Response.Cookies(objCookie) = ""
    Next
    Session.Abandon()
End If