Find all our projects in development below.
All source code is GNU General Public License (GPL)
Browsing InfoForm.frm (15.53 KB)
VERSION 5.00
Object = "{248DD890-BB45-11CF-9ABC-0080C7E7B78D}#1.0#0"; "MSWINSCK.OCX"
Object = "{6B7E6392-850A-101B-AFC0-4210102A8DA7}#1.3#0"; "comctl32.ocx"
Begin VB.Form InfoForm
BorderStyle = 1 'Fixed Single
Caption = "Server Info for 127.0.0.1:27015"
ClientHeight = 5535
ClientLeft = 45
ClientTop = 330
ClientWidth = 9135
ClipControls = 0 'False
BeginProperty Font
Name = "Tahoma"
Size = 8.25
Charset = 0
Weight = 400
Underline = 0 'False
Italic = 0 'False
Strikethrough = 0 'False
EndProperty
Icon = "InfoForm.frx":0000
MaxButton = 0 'False
ScaleHeight = 5535
ScaleWidth = 9135
StartUpPosition = 3 'Windows Default
Begin VB.TextBox txtCopy
Height = 285
Left = 0
MultiLine = -1 'True
TabIndex = 3
TabStop = 0 'False
Top = 0
Visible = 0 'False
Width = 735
End
Begin MSWinsockLib.Winsock WS_Players
Left = 1080
Top = 120
_ExtentX = 741
_ExtentY = 741
_Version = 393216
Protocol = 1
End
Begin MSWinsockLib.Winsock WS_GameRules
Left = 600
Top = 120
_ExtentX = 741
_ExtentY = 741
_Version = 393216
Protocol = 1
End
Begin MSWinsockLib.Winsock WS_GameInfo
Left = 120
Top = 120
_ExtentX = 741
_ExtentY = 741
_Version = 393216
Protocol = 1
End
Begin ComctlLib.ListView LVGameInfo
Height = 1695
Left = 120
TabIndex = 0
Top = 120
Width = 8895
_ExtentX = 15690
_ExtentY = 2990
View = 3
LabelEdit = 1
SortOrder = -1 'True
LabelWrap = -1 'True
HideSelection = -1 'True
_Version = 327682
ForeColor = -2147483640
BackColor = -2147483643
BorderStyle = 1
Appearance = 1
BeginProperty Font {0BE35203-8F91-11CE-9DE3-00AA004BB851}
Name = "Tahoma"
Size = 8.25
Charset = 0
Weight = 400
Underline = 0 'False
Italic = 0 'False
Strikethrough = 0 'False
EndProperty
NumItems = 2
BeginProperty ColumnHeader(1) {0713E8C7-850A-101B-AFC0-4210102A8DA7}
Key = ""
Object.Tag = ""
Text = "Setting"
Object.Width = 3528
EndProperty
BeginProperty ColumnHeader(2) {0713E8C7-850A-101B-AFC0-4210102A8DA7}
SubItemIndex = 1
Key = ""
Object.Tag = ""
Text = "Value"
Object.Width = 10583
EndProperty
End
Begin ComctlLib.ListView LVGameRules
Height = 1695
Left = 120
TabIndex = 1
Top = 1920
Width = 8895
_ExtentX = 15690
_ExtentY = 2990
View = 3
LabelEdit = 1
SortOrder = -1 'True
LabelWrap = -1 'True
HideSelection = -1 'True
_Version = 327682
ForeColor = -2147483640
BackColor = -2147483643
BorderStyle = 1
Appearance = 1
BeginProperty Font {0BE35203-8F91-11CE-9DE3-00AA004BB851}
Name = "Tahoma"
Size = 8.25
Charset = 0
Weight = 400
Underline = 0 'False
Italic = 0 'False
Strikethrough = 0 'False
EndProperty
NumItems = 2
BeginProperty ColumnHeader(1) {0713E8C7-850A-101B-AFC0-4210102A8DA7}
Key = ""
Object.Tag = ""
Text = "Rule"
Object.Width = 3528
EndProperty
BeginProperty ColumnHeader(2) {0713E8C7-850A-101B-AFC0-4210102A8DA7}
SubItemIndex = 1
Key = ""
Object.Tag = ""
Text = "Value"
Object.Width = 10583
EndProperty
End
Begin ComctlLib.ListView LVPlayers
Height = 1695
Left = 120
TabIndex = 2
Top = 3720
Width = 8895
_ExtentX = 15690
_ExtentY = 2990
View = 3
LabelEdit = 1
SortOrder = -1 'True
LabelWrap = -1 'True
HideSelection = -1 'True
_Version = 327682
ForeColor = -2147483640
BackColor = -2147483643
BorderStyle = 1
Appearance = 1
BeginProperty Font {0BE35203-8F91-11CE-9DE3-00AA004BB851}
Name = "Tahoma"
Size = 8.25
Charset = 0
Weight = 400
Underline = 0 'False
Italic = 0 'False
Strikethrough = 0 'False
EndProperty
NumItems = 4
BeginProperty ColumnHeader(1) {0713E8C7-850A-101B-AFC0-4210102A8DA7}
Key = ""
Object.Tag = ""
Text = "ID"
Object.Width = 265
EndProperty
BeginProperty ColumnHeader(2) {0713E8C7-850A-101B-AFC0-4210102A8DA7}
SubItemIndex = 1
Key = ""
Object.Tag = ""
Text = "Player Name"
Object.Width = 11024
EndProperty
BeginProperty ColumnHeader(3) {0713E8C7-850A-101B-AFC0-4210102A8DA7}
Alignment = 2
SubItemIndex = 2
Key = ""
Object.Tag = ""
Text = "Frags"
Object.Width = 706
EndProperty
BeginProperty ColumnHeader(4) {0713E8C7-850A-101B-AFC0-4210102A8DA7}
Alignment = 1
SubItemIndex = 3
Key = ""
Object.Tag = ""
Text = "Time"
Object.Width = 1058
EndProperty
End
Begin VB.Menu LVPopupMenu
Caption = "LVPopupMenu"
Visible = 0 'False
Begin VB.Menu RefreshMenu
Caption = "&Refresh"
End
Begin VB.Menu CopyMenu
Caption = "&Copy"
End
End
End
Attribute VB_Name = "InfoForm"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = True
Attribute VB_Exposed = False
Dim CurrentLV As ListView
Dim CurrentWS As Winsock
Dim WSDataToSend As String
Public Sub GetInfo(ServerIP As String, ServerPort As Long)
On Error Resume Next
Caption = "Server Info for " & ServerIP & ":" & ServerPort
WS_GameInfo.RemoteHost = ServerIP
WS_GameInfo.RemotePort = ServerPort
WS_GameInfo.SendData "����info"
WS_GameRules.RemoteHost = ServerIP
WS_GameRules.RemotePort = ServerPort
WS_GameRules.SendData "����rules"
WS_Players.RemoteHost = ServerIP
WS_Players.RemotePort = ServerPort
WS_Players.SendData "����players"
End Sub
Private Sub CopyMenu_Click()
Dim i As Integer
Dim i2 As Integer
For i = 1 To CurrentLV.ListItems.Count
txtCopy.Text = txtCopy.Text + CurrentLV.ListItems(i).Text
For i2 = 2 To CurrentLV.ColumnHeaders.Count
txtCopy.Text = txtCopy.Text + vbTab + CurrentLV.ListItems(i).SubItems(i2 - 1)
Next i2
txtCopy.Text = txtCopy.Text + vbCrLf
Next i
txtCopy.SelStart = 0
txtCopy.SelLength = Len(txtCopy.Text)
ClipboardCut txtCopy.hWnd
Set CurrentLV = Nothing
Set CurrentWS = Nothing
WSDataToSend = ""
End Sub
Private Sub Form_Load()
With LVGameInfo.ListItems
.Add(, , "Host Name").SubItems(1) = "n/a"
.Add(, , "Map Name").SubItems(1) = "n/a"
.Add(, , "Game Directory").SubItems(1) = "n/a"
.Add(, , "Game Description").SubItems(1) = "n/a"
.Add(, , "Players").SubItems(1) = "n/a"
.Add(, , "Protocol Version").SubItems(1) = "n/a"
End With
LV_FullRowSelect LVPlayers
End Sub
Private Sub LVGameInfo_ColumnClick(ByVal ColumnHeader As ComctlLib.ColumnHeader)
LVGameInfo.SortOrder = Abs(Not (LVGameInfo.SortOrder * -1))
LVGameInfo.SortKey = ColumnHeader.Index - 1
LVGameInfo.Sorted = True
End Sub
Private Sub LVGameInfo_KeyDown(KeyCode As Integer, Shift As Integer)
If KeyCode = KEY_F5 Then
Set CurrentLV = LVGameInfo
Set CurrentWS = WS_GameInfo
WSDataToSend = "����info"
RefreshMenu_Click
End If
End Sub
Private Sub LVGameInfo_MouseUp(Button As Integer, Shift As Integer, x As Single, y As Single)
If Button = vbRightButton Then
If Not (LVGameInfo.SelectedItem Is Nothing) Then
Set CurrentLV = LVGameInfo
Set CurrentWS = WS_GameInfo
WSDataToSend = "����info"
PopupMenu LVPopupMenu, vbPopupMenuRightButton
End If
End If
End Sub
Private Sub LVGameRules_ColumnClick(ByVal ColumnHeader As ComctlLib.ColumnHeader)
LVGameRules.SortOrder = Abs(Not (LVGameRules.SortOrder * -1))
LVGameRules.SortKey = ColumnHeader.Index - 1
LVGameRules.Sorted = True
End Sub
Private Sub LVGameRules_KeyDown(KeyCode As Integer, Shift As Integer)
If KeyCode = KEY_F5 Then
Set CurrentLV = LVGameRules
Set CurrentWS = WS_GameRules
WSDataToSend = "����rules"
RefreshMenu_Click
End If
End Sub
Private Sub LVGameRules_MouseUp(Button As Integer, Shift As Integer, x As Single, y As Single)
If Button = vbRightButton Then
If Not (LVGameRules.SelectedItem Is Nothing) Then
Set CurrentLV = LVGameRules
Set CurrentWS = WS_GameRules
WSDataToSend = "����rules"
PopupMenu LVPopupMenu, vbPopupMenuRightButton
End If
End If
End Sub
Private Sub LVPlayers_ColumnClick(ByVal ColumnHeader As ComctlLib.ColumnHeader)
LVPlayers.SortOrder = Abs(Not (LVPlayers.SortOrder * -1))
LVPlayers.SortKey = ColumnHeader.Index - 1
LVPlayers.Sorted = True
End Sub
Private Sub LVPlayers_KeyDown(KeyCode As Integer, Shift As Integer)
If KeyCode = KEY_F5 Then
Set CurrentLV = LVPlayers
Set CurrentWS = WS_Players
WSDataToSend = "����players"
RefreshMenu_Click
End If
End Sub
Private Sub LVPlayers_MouseUp(Button As Integer, Shift As Integer, x As Single, y As Single)
If Button = vbRightButton Then
If Not (LVPlayers.SelectedItem Is Nothing) Then
Set CurrentLV = LVPlayers
Set CurrentWS = WS_Players
WSDataToSend = "����players"
PopupMenu LVPopupMenu, vbPopupMenuRightButton
End If
End If
End Sub
Private Sub RefreshMenu_Click()
On Error Resume Next
CurrentLV.ListItems.Clear
If CurrentLV.Name = "LVGameInfo" Then
LVGameInfo.Sorted = False
LVGameInfo.SortOrder = lvwDescending
With LVGameInfo.ListItems
.Add(, , "Host Name").SubItems(1) = "n/a"
.Add(, , "Map Name").SubItems(1) = "n/a"
.Add(, , "Game Directory").SubItems(1) = "n/a"
.Add(, , "Game Description").SubItems(1) = "n/a"
.Add(, , "Players").SubItems(1) = "n/a"
.Add(, , "Protocol Version").SubItems(1) = "n/a"
End With
End If
CurrentWS.SendData WSDataToSend
Set CurrentLV = Nothing
Set CurrentWS = Nothing
WSDataToSend = ""
End Sub
Private Sub WS_GameInfo_DataArrival(ByVal bytesTotal As Long)
On Error GoTo ErrHandler
Dim RecvData As String
Dim i As Integer
WS_GameInfo.GetData RecvData
WS_GameInfo.Close
i = 6
i = InStr(i, RecvData, vbNullChar) + 1
LVGameInfo.ListItems(1).SubItems(1) = Mid(RecvData, i, InStr(i + 1, RecvData, vbNullChar) - i)
i = InStr(i, RecvData, vbNullChar) + 1
LVGameInfo.ListItems(2).SubItems(1) = Mid(RecvData, i, InStr(i + 1, RecvData, vbNullChar) - i)
i = InStr(i, RecvData, vbNullChar) + 1
LVGameInfo.ListItems(3).SubItems(1) = Mid(RecvData, i, InStr(i + 1, RecvData, vbNullChar) - i)
i = InStr(i, RecvData, vbNullChar) + 1
LVGameInfo.ListItems(4).SubItems(1) = Mid(RecvData, i, InStr(i + 1, RecvData, vbNullChar) - i)
i = InStr(i, RecvData, vbNullChar) + 1
LVGameInfo.ListItems(5).SubItems(1) = Asc(Mid(RecvData, i, 1)) & "/" & Asc(Mid(RecvData, i + 1, 1))
i = i + 2
LVGameInfo.ListItems(6).SubItems(1) = Asc(Mid(RecvData, i, 1))
ErrHandler:
End Sub
Private Sub WS_GameRules_DataArrival(ByVal bytesTotal As Long)
On Error GoTo ErrHandler
Dim RecvData As String
Dim TotalRules As Long
Dim i As Integer
Dim i2 As Long
WS_GameRules.GetData RecvData
WS_GameRules.Close
i2 = InStr(7, RecvData, vbNullChar) + 1
TotalRules = Asc(Mid(RecvData, 6, 1))
For i = 1 To TotalRules
With LVGameRules.ListItems.Add()
.Text = Mid(RecvData, i2, InStr(i2 + 1, RecvData, vbNullChar) - i2)
i2 = InStr(i2, RecvData, vbNullChar) + 1
.SubItems(1) = Mid(RecvData, i2, InStr(i2 + 1, RecvData, vbNullChar) - i2)
i2 = InStr(i2, RecvData, vbNullChar) + 1
End With
Next i
ErrHandler:
End Sub
Private Sub WS_Players_DataArrival(ByVal bytesTotal As Long)
On Error Resume Next
Dim RecvData As String
Dim PlayerTotal As Integer
Dim PlayerFrags As Long
Dim PlayerTime As Long
Dim lngSecs As Long
Dim lngSecs2 As Long
Dim lngHours As Long
Dim lngMins As Long
Dim i As Integer
Dim i2 As Long
WS_Players.GetData RecvData
WS_Players.Close
i2 = 7
PlayerTotal = Asc(Mid(RecvData, 6, 1))
For i = 1 To PlayerTotal
With LVPlayers.ListItems.Add()
.Text = Asc(Mid(RecvData, i2, 1))
i2 = i2 + 1
.SubItems(1) = Mid(RecvData, i2, InStr(i2 + 1, RecvData, vbNullChar) - i2)
i2 = InStr(i2, RecvData, vbNullChar) + 1
PlayerFrags = Asc(Mid(RecvData, i2, 1)) + Asc(Mid(RecvData, i2 + 1, 1)) + Asc(Mid(RecvData, i2 + 2, 1)) + Asc(Mid(RecvData, i2 + 3, 1))
If PlayerFrags > 512 Then PlayerFrags = -(1021 - PlayerFrags)
.SubItems(2) = PlayerFrags
i2 = i2 + 4
PlayerTime = Asc(Mid(RecvData, i2, 1)) + Asc(Mid(RecvData, i2 + 1, 1)) + Asc(Mid(RecvData, i2 + 2, 1)) + Asc(Mid(RecvData, i2 + 3, 1))
i2 = i2 + 4
lngHours = Fix(PlayerTime / 3600)
lngSecs = PlayerTime - (lngHours * 3600)
lngMins = Fix(lngSecs / 60)
lngSecs2 = lngSecs - (lngMins * 60)
.SubItems(3) = Format(lngHours, "00:") & Format(lngMins, "00:") & Format(lngSecs2, "00")
End With
Next i
End Sub