Find all our projects in development below.
All source code is GNU General Public License (GPL)
Browsing InfoForm.frm (10.33 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 = 4695
ClientLeft = 45
ClientTop = 330
ClientWidth = 7875
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 = 4695
ScaleWidth = 7875
StartUpPosition = 3 'Windows Default
Begin VB.TextBox txtCopy
Height = 285
Left = 0
MultiLine = -1 'True
TabIndex = 2
TabStop = 0 'False
Top = 0
Visible = 0 'False
Width = 735
End
Begin MSWinsockLib.Winsock WS_GameInfo
Left = 120
Top = 120
_ExtentX = 741
_ExtentY = 741
_Version = 393216
Protocol = 1
End
Begin ComctlLib.ListView LVGameInfo
Height = 4575
Left = 60
TabIndex = 0
Top = 60
Width = 3855
_ExtentX = 6800
_ExtentY = 8070
View = 3
LabelEdit = 1
Sorted = -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 = 2293
EndProperty
BeginProperty ColumnHeader(2) {0713E8C7-850A-101B-AFC0-4210102A8DA7}
SubItemIndex = 1
Key = ""
Object.Tag = ""
Text = "Value"
Object.Width = 2875
EndProperty
End
Begin ComctlLib.ListView LVPlayers
Height = 4575
Left = 3960
TabIndex = 1
Top = 60
Width = 3855
_ExtentX = 6800
_ExtentY = 8070
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 = 212
EndProperty
BeginProperty ColumnHeader(2) {0713E8C7-850A-101B-AFC0-4210102A8DA7}
SubItemIndex = 1
Key = ""
Object.Tag = ""
Text = "Player Name"
Object.Width = 2575
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 = "Ping"
Object.Width = 706
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 Object
Dim bItemClicked As Boolean
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 "����getstatus xxx"
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
End Sub
Private Sub Form_Load()
LV_FullRowSelect LVPlayers
SubClassListViewParentWnd hWnd, Me, LVPlayers, 1
End Sub
Private Sub Form_Unload(Cancel As Integer)
UnSubClassListViewParentWnd hWnd
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 RefreshMenu_Click
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
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_ItemClick(ByVal Item As ComctlLib.ListItem)
LVGotFocus hWnd
LVPlayers.Refresh
bItemClicked = True
End Sub
Private Sub LVPlayers_KeyDown(KeyCode As Integer, Shift As Integer)
If KeyCode = KEY_F5 Then RefreshMenu_Click
End Sub
Private Sub LVPlayers_LostFocus()
LVNoFocus hWnd
LVPlayers.Refresh
End Sub
Private Sub LVPlayers_MouseDown(Button As Integer, Shift As Integer, x As Single, y As Single)
If Button = vbLeftButton Then
If Not bItemClicked Then
LVNoFocus hWnd
LVPlayers.Refresh
Else
bItemClicked = False
End If
End If
End Sub
Private Sub LVPlayers_MouseUp(Button As Integer, Shift As Integer, x As Single, y As Single)
If Button = vbLeftButton Then
bItemClicked = False
If Not (LVPlayers.SelectedItem Is Nothing) Then
If Not LVPlayers.SelectedItem.Selected Then LVPlayers.Refresh
End If
ElseIf Button = vbRightButton Then
If Not (LVPlayers.SelectedItem Is Nothing) Then
Set CurrentLV = LVPlayers
PopupMenu LVPopupMenu, vbPopupMenuRightButton
End If
End If
End Sub
Private Sub RefreshMenu_Click()
On Error Resume Next
LVGameInfo.ListItems.Clear
LVPlayers.ListItems.Clear
WS_GameInfo.SendData "����getstatus xxx"
End Sub
Private Sub WS_GameInfo_DataArrival(ByVal bytesTotal As Long)
On Error Resume Next
Dim RecvData As String
Dim Settings() As String
Dim TmpStr As String
Dim PlayerArray() As String
Dim PlayerCount As Integer
Dim PlayerName As String
Dim PlayerFrags As Long
Dim PlayerPing As Long
Dim i As Integer
WS_GameInfo.GetData RecvData
WS_GameInfo.Close
RecvData = Mid(RecvData, InStr(RecvData, vbLf) + 2)
TmpStr = Mid(RecvData, InStr(RecvData, vbLf) + 1)
RecvData = Left(RecvData, InStr(RecvData, vbLf) - 1)
Settings = Split(RecvData, "\")
PlayerArray = Split(TmpStr, vbLf)
PlayerCount = UBound(PlayerArray)
If Err.Number Or PlayerCount < 0 Then PlayerCount = 0
For i = 0 To UBound(Settings) Step 2
With LVGameInfo.ListItems.Add
.Text = Settings(i)
.SubItems(1) = Settings(i + 1)
End With
Next i
If PlayerCount > 0 Then
For i = 0 To UBound(PlayerArray) - 1
PlayerName = Mid(PlayerArray(i), InStr(PlayerArray(i), """") + 1, InStrRev(PlayerArray(i), """") - InStr(PlayerArray(i), """") - 1)
PlayerFrags = Trim(Left(PlayerArray(i), InStr(PlayerArray(i), " ") - 1))
PlayerPing = CStr(Val(Mid(PlayerArray(i), InStr(PlayerArray(i), " ") + 1)))
With LVPlayers.ListItems.Add
.Text = .Index
.SubItems(1) = StripQ3Colors(PlayerName)
.SubItems(2) = PlayerFrags
.SubItems(3) = PlayerPing
.Tag = PlayerName
End With
Next i
End If
End Sub