Programación VB. Latinchat. Contador de usuarios
Posted by
ax3L
CATEGORIAS:
Códigos fuente,
LatinChat,
Personal Releases,
Programación
Y eso por lo visto es un contador de usuarios alternativo. Antes esa función se generaba mediante javascript searchuser.js
groups=new
Array('41','26','212','21','26','18','13','15','23','20','83','91',
'18','26','3','23','15','88','11','6','1','19','47','11','13','10','8','5','11','5',17',
'16','3','20','7','4','12','5','14','3','1','2','16','0','10','24','14','7','37','13','19',
'5','5','10','1','93','9','67','36','34','90','28','18','21','10','16','22','70','42','1'
'4','2','9','3','5','31','26','9','10','16','0','3','1','0','7','11','17','11','35','10','15',
51','6','107','18','15','12','10','12','11','3','0','4','5','0','5','14','
12','1','2','5','2',
'3','0','0','5','0','2','1','1','6','2','0','4','2','1','1','1','0','2','0','131'); numusers=2413;
Array('41','26','212','21','26','18','13','15','23','20','83','91',
'18','26','3','23','15','88','11','6','1','19','47','11','13','10','8','5','11','5',17',
'16','3','20','7','4','12','5','14','3','1','2','16','0','10','24','14','7','37','13','19',
'5','5','10','1','93','9','67','36','34','90','28','18','21','10','16','22','70','42','1'
'4','2','9','3','5','31','26','9','10','16','0','3','1','0','7','11','17','11','35','10','15',
51','6','107','18','15','12','10','12','11','3','0','4','5','0','5','14','
12','1','2','5','2',
'3','0','0','5','0','2','1','1','6','2','0','4','2','1','1','1','0','2','0','131'); numusers=2413;
script pueden descargar de Aquí . Ahora existe otra forma alternativa para tener esa función.
Código:
VERSION 5.00
Object = "{3B7C8863-D78F-101B-B9B5-04021C009402}#1.2#0"; "RICHTX32.OCX"
Object = "{248DD890-BB45-11CF-9ABC-0080C7E7B78D}#1.0#0"; "MSWINSCK.OCX"
Begin VB.Form Form1
BackColor = &H00000000&
BorderStyle = 4 'Fixed ToolWindow
Caption = "User count © d4rksoft 2008!"
ClientHeight = 3090
ClientLeft = 45
ClientTop = 315
ClientWidth = 4455
LinkTopic = "Form1"
MaxButton = 0 'False
MinButton = 0 'False
ScaleHeight = 3090
ScaleWidth = 4455
ShowInTaskbar = 0 'False
StartUpPosition = 3 'Windows Default
Begin MSWinsockLib.Winsock Winsock1
Left = 1200
Top = 2880
_ExtentX = 741
_ExtentY = 741
_Version = 393216
End
Begin VB.Timer Timer1
Enabled = 0 'False
Interval = 1000
Left = 4200
Top = 2880
End
Begin VB.Frame Frame1
BackColor = &H00000000&
Caption = "Data Arrival"
ForeColor = &H000000FF&
Height = 2175
Left = 120
TabIndex = 3
Top = 720
Width = 4215
Begin RichTextLib.RichTextBox dataR
Height = 1815
Left = 120
TabIndex = 4
Top = 240
Width = 3975
_ExtentX = 7011
_ExtentY = 3201
_Version = 393217
Enabled = -1 'True
TextRTF = $"NewuserCount.frx":0000
End
End
Begin VB.Label Label3
BackStyle = 0 'Transparent
Caption = "Data Arrival :"
ForeColor = &H000000FF&
Height = 255
Left = 720
TabIndex = 2
Top = 360
Width = 975
End
Begin VB.Label Label2
Alignment = 2 'Center
BackColor = &H00000000&
BackStyle = 0 'Transparent
ForeColor = &H000000FF&
Height = 375
Left = 2760
TabIndex = 1
Top = 120
Width = 1455
End
Begin VB.Label Label1
BackStyle = 0 'Transparent
Caption = "Usuarios conectados a Latinchat:"
ForeColor = &H000000FF&
Height = 255
Left = 120
TabIndex = 0
Top = 120
Width = 2415
End
End
Attribute VB_Name = "Form1"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = True
Attribute VB_Exposed = False
'new user counter creado por d4rk
'modifica codigo a tu gusto pero devuelve creditos al creador
'codigo bajado de http://ax3l.blogspot.com
Private Sub dataR_Change()
Dim Mystr As String
Dim StrInic As Long
Dim StrFin As Long
Mystr = dataR.Text
If InStr(Mystr, "<body>") <> 0 Then
StrInic = InStr(Mystr, "<body>") + 6
StrFin = InStr(StrInic, Mystr, "</body>") - StrInic
If InStr(dataR, Chr(11)) <> 0 Then dataR = Replace(dataR, Chr(11), "")
Label2.Caption = Mid(Mystr, StrInic, StrFin)
End If
End Sub
Private Sub Form_Load()
Timer1 = True
End Sub
Private Sub Timer1_Timer()
Winsock1.Close
Winsock1.Connect "login01.latinchat.com", 80
End Sub
Private Sub winsock1_Connect()
Winsock1.SendData ("GET /usercount/usercount.php" & " HTTP/1.1" & vbCrLf _
& "Accept: */*" & vbCrLf & "Accept: text/html" & vbCrLf & "Host:
login01.latinchat.com" & vbCrLf & vbCrLf)
End Sub
Private Sub winsock1_DataArrival(ByVal bytesTotal As Long)
Dim DATA As String
Winsock1.GetData DATA
dataR = DATA
End Sub
Object = "{3B7C8863-D78F-101B-B9B5-04021C009402}#1.2#0"; "RICHTX32.OCX"
Object = "{248DD890-BB45-11CF-9ABC-0080C7E7B78D}#1.0#0"; "MSWINSCK.OCX"
Begin VB.Form Form1
BackColor = &H00000000&
BorderStyle = 4 'Fixed ToolWindow
Caption = "User count © d4rksoft 2008!"
ClientHeight = 3090
ClientLeft = 45
ClientTop = 315
ClientWidth = 4455
LinkTopic = "Form1"
MaxButton = 0 'False
MinButton = 0 'False
ScaleHeight = 3090
ScaleWidth = 4455
ShowInTaskbar = 0 'False
StartUpPosition = 3 'Windows Default
Begin MSWinsockLib.Winsock Winsock1
Left = 1200
Top = 2880
_ExtentX = 741
_ExtentY = 741
_Version = 393216
End
Begin VB.Timer Timer1
Enabled = 0 'False
Interval = 1000
Left = 4200
Top = 2880
End
Begin VB.Frame Frame1
BackColor = &H00000000&
Caption = "Data Arrival"
ForeColor = &H000000FF&
Height = 2175
Left = 120
TabIndex = 3
Top = 720
Width = 4215
Begin RichTextLib.RichTextBox dataR
Height = 1815
Left = 120
TabIndex = 4
Top = 240
Width = 3975
_ExtentX = 7011
_ExtentY = 3201
_Version = 393217
Enabled = -1 'True
TextRTF = $"NewuserCount.frx":0000
End
End
Begin VB.Label Label3
BackStyle = 0 'Transparent
Caption = "Data Arrival :"
ForeColor = &H000000FF&
Height = 255
Left = 720
TabIndex = 2
Top = 360
Width = 975
End
Begin VB.Label Label2
Alignment = 2 'Center
BackColor = &H00000000&
BackStyle = 0 'Transparent
ForeColor = &H000000FF&
Height = 375
Left = 2760
TabIndex = 1
Top = 120
Width = 1455
End
Begin VB.Label Label1
BackStyle = 0 'Transparent
Caption = "Usuarios conectados a Latinchat:"
ForeColor = &H000000FF&
Height = 255
Left = 120
TabIndex = 0
Top = 120
Width = 2415
End
End
Attribute VB_Name = "Form1"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = True
Attribute VB_Exposed = False
'new user counter creado por d4rk
'modifica codigo a tu gusto pero devuelve creditos al creador
'codigo bajado de http://ax3l.blogspot.com
Private Sub dataR_Change()
Dim Mystr As String
Dim StrInic As Long
Dim StrFin As Long
Mystr = dataR.Text
If InStr(Mystr, "<body>") <> 0 Then
StrInic = InStr(Mystr, "<body>") + 6
StrFin = InStr(StrInic, Mystr, "</body>") - StrInic
If InStr(dataR, Chr(11)) <> 0 Then dataR = Replace(dataR, Chr(11), "")
Label2.Caption = Mid(Mystr, StrInic, StrFin)
End If
End Sub
Private Sub Form_Load()
Timer1 = True
End Sub
Private Sub Timer1_Timer()
Winsock1.Close
Winsock1.Connect "login01.latinchat.com", 80
End Sub
Private Sub winsock1_Connect()
Winsock1.SendData ("GET /usercount/usercount.php" & " HTTP/1.1" & vbCrLf _
& "Accept: */*" & vbCrLf & "Accept: text/html" & vbCrLf & "Host:
login01.latinchat.com" & vbCrLf & vbCrLf)
End Sub
Private Sub winsock1_DataArrival(ByVal bytesTotal As Long)
Dim DATA As String
Winsock1.GetData DATA
dataR = DATA
End Sub
O simplemente bajar código fuente de Aquí.
Saludos!
Buscas un programa y no lo encuentras? Pidelo , posteando en blog o en tag y te lo conseguimos!
Subscribe to:
Post Comments (Atom)
Tuesday, April 02, 2013
Hello there! I could have sworn I've visited this web site before but after going through some of the articles I realized it's new to me.
Anyways, I'm certainly pleased I found it and I'll be bookmarking it
and checking back frequently!
Here is my web-site ... kitchen in northern virginia
Post a Comment