Find all our projects in development below.
All source code is GNU General Public License (GPL)
Browsing QuickQuery HL Edition/ServerQueryForm.frm (30.13 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 ServerQueryForm
BorderStyle = 3 'Fixed Dialog
Caption = "Server Query Tool"
ClientHeight = 6000
ClientLeft = 45
ClientTop = 330
ClientWidth = 6480
BeginProperty Font
Name = "Tahoma"
Size = 8.25
Charset = 0
Weight = 700
Underline = 0 'False
Italic = 0 'False
Strikethrough = 0 'False
EndProperty
Icon = "ServerQueryForm.frx":0000
MaxButton = 0 'False
MinButton = 0 'False
ScaleHeight = 6000
ScaleWidth = 6480
ShowInTaskbar = 0 'False
StartUpPosition = 1 'CenterOwner
Begin VB.TextBox txtCopy
BeginProperty Font
Name = "Tahoma"
Size = 8.25
Charset = 0
Weight = 400
Underline = 0 'False
Italic = 0 'False
Strikethrough = 0 'False
EndProperty
Height = 285
Left = 60
MultiLine = -1 'True
TabIndex = 6
TabStop = 0 'False
Top = 420
Visible = 0 'False
Width = 735
End
Begin MSWinsockLib.Winsock WS_Players
Left = 1020
Top = 420
_ExtentX = 741
_ExtentY = 741
_Version = 393216
Protocol = 1
End
Begin MSWinsockLib.Winsock WS_GameRules
Left = 540
Top = 420
_ExtentX = 741
_ExtentY = 741
_Version = 393216
Protocol = 1
End
Begin MSWinsockLib.Winsock WS_GameInfo
Left = 60
Top = 420
_ExtentX = 741
_ExtentY = 741
_Version = 393216
Protocol = 1
End
Begin VB.CommandButton Command1
Caption = "&Query Server"
Default = -1 'True
Enabled = 0 'False
BeginProperty Font
Name = "Tahoma"
Size = 8.25
Charset = 0
Weight = 400
Underline = 0 'False
Italic = 0 'False
Strikethrough = 0 'False
EndProperty
Height = 315
Left = 4980
TabIndex = 2
ToolTipText = "Right click to launch game"
Top = 60
Width = 1455
End
Begin VB.ComboBox cboAddress
BeginProperty Font
Name = "Tahoma"
Size = 8.25
Charset = 0
Weight = 400
Underline = 0 'False
Italic = 0 'False
Strikethrough = 0 'False
EndProperty
Height = 315
Left = 1320
TabIndex = 1
Top = 80
Width = 3555
End
Begin ComctlLib.ListView LVGameRules
Height = 1815
Left = 60
TabIndex = 4
Top = 2280
Width = 6375
_ExtentX = 11245
_ExtentY = 3201
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 = 6085
EndProperty
End
Begin ComctlLib.ListView LVPlayers
Height = 1815
Left = 60
TabIndex = 5
Top = 4140
Width = 6375
_ExtentX = 11245
_ExtentY = 3201
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 = 6526
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 ComctlLib.ListView LVGameInfo
Height = 1815
Left = 60
TabIndex = 3
Top = 420
Width = 6375
_ExtentX = 11245
_ExtentY = 3201
View = 3
LabelEdit = 1
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 = "Property"
Object.Width = 3528
EndProperty
BeginProperty ColumnHeader(2) {0713E8C7-850A-101B-AFC0-4210102A8DA7}
SubItemIndex = 1
Key = ""
Object.Tag = ""
Text = "Value"
Object.Width = 6085
EndProperty
End
Begin VB.Label Label1
BackStyle = 0 'Transparent
Caption = "&Server Address:"
BeginProperty Font
Name = "Tahoma"
Size = 8.25
Charset = 0
Weight = 400
Underline = 0 'False
Italic = 0 'False
Strikethrough = 0 'False
EndProperty
Height = 255
Left = 60
TabIndex = 0
Top = 120
Width = 1215
End
Begin VB.Menu BtnPopupMenu
Caption = "BtnPopupMenu"
Visible = 0 'False
Begin VB.Menu LaunchMenu
Caption = "&Launch Half-Life..."
End
Begin VB.Menu Blank1
Caption = "-"
End
Begin VB.Menu AutoRefreshMenu
Caption = "&AutoRefresh Server..."
End
Begin VB.Menu AddToFavsMenu
Caption = "Add &to Favorites..."
End
Begin VB.Menu RemoveFavoriteMenu
Caption = "R&emove From Favorites"
End
Begin VB.Menu RCONConsoleMenu
Caption = "&RCON Console..."
End
End
Begin VB.Menu CBPopupMenu
Caption = "CBPopupMenu"
Visible = 0 'False
Begin VB.Menu RemoveMenu
Caption = "&Remove from List"
End
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 = "ServerQueryForm"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = True
Attribute VB_Exposed = False
Dim PingTimer As Single
Dim CurrentLV As ListView
Dim CurrentWS As Winsock
Dim WSDataToSend As String
Dim bNoHistoryAdd As Boolean
Public Sub QueryServerClick()
bNoHistoryAdd = True
Command1_Click
bNoHistoryAdd = False
End Sub
Private Sub AddToFavsMenu_Click()
AddFavoriteForm.Caption = "Add New Favorite"
AddFavoriteForm.ListIndex = -1
AddFavoriteForm.txtAddress.Text = cboAddress.Text
AddFavoriteForm.txtAddress.SelStart = 0
AddFavoriteForm.txtAddress.SelLength = Len(AddFavoriteForm.txtAddress.Text)
AddFavoriteForm.Show 1
End Sub
Private Sub AutoRefreshMenu_Click()
Dim wsHost As String
Dim wsPort As Long
wsHost = cboAddress.Text
wsPort = 27015
If InStr(wsHost, ":") > 0 Then
wsPort = Val(Mid(wsHost, InStr(wsHost, ":") + 1))
wsHost = Left(wsHost, InStr(wsHost, ":") - 1)
If wsPort = 0 Then wsPort = 27015
End If
With AutoRefreshForm
.Caption = "AutoRefreshing " + cboAddress.Text
.Show 0, MainForm
.RefreshTimer.Enabled = False
.ServerRulesRecvd False
.LVGameInfo.ListItems.Clear
.LVGameInfo.ListItems.Add , , "Receiving game rules..."
.WS_GameRules.RemoteHost = wsHost
.WS_GameRules.RemotePort = wsPort
.WS_GameRules.SendData "����rules"
End With
End Sub
Private Sub cboAddress_Change()
If cboAddress.Text = "" Then
Command1.Enabled = False
Else
Command1.Enabled = True
End If
End Sub
Private Sub cboAddress_Click()
cboAddress_Change
End Sub
Private Sub cboAddress_GotFocus()
cboAddress_Change
End Sub
Private Sub Command1_Click()
On Error GoTo ErrHandler
Dim wsHost As String
Dim wsPort As Long
Dim i As Integer
Dim strAddress As String
strAddress = cboAddress.Text
wsHost = strAddress
wsPort = 27015
If InStr(wsHost, ":") > 0 Then
wsPort = Val(Mid(wsHost, InStr(wsHost, ":") + 1))
wsHost = Left(wsHost, InStr(wsHost, ":") - 1)
If wsPort = 0 Then wsPort = 27015
End If
If bNoHistoryAdd = False Then
For i = 0 To cboAddress.ListCount - 1
If LCase(cboAddress.Text) = LCase(cboAddress.List(i)) Then
cboAddress.RemoveItem i
Exit For
End If
Next i
cboAddress.AddItem strAddress, 0
cboAddress.Text = strAddress
End If
LVGameInfo.ListItems.Clear
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(, , "Ping").SubItems(1) = "n/a"
End With
LVGameRules.ListItems.Clear
LVGameRules.Sorted = False
LVGameRules.SortOrder = lvwDescending
LVPlayers.ListItems.Clear
LVPlayers.Sorted = False
LVPlayers.SortOrder = lvwDescending
WS_GameInfo.Close
WS_GameInfo.RemoteHost = wsHost
WS_GameInfo.RemotePort = wsPort
WS_GameInfo.SendData "����info"
DoEvents
WS_GameRules.Close
WS_GameRules.RemoteHost = wsHost
WS_GameRules.RemotePort = wsPort
WS_GameRules.SendData "����rules"
DoEvents
WS_Players.Close
WS_Players.RemoteHost = wsHost
WS_Players.RemotePort = wsPort
WS_Players.SendData "����players"
PingTimer = Timer
Exit Sub
ErrHandler:
MsgBox "Error: " + Err.Description + vbCrLf + vbCrLf + "Type the address and try again.", vbCritical
cboAddress.SetFocus
End Sub
Private Sub Command1_MouseUp(Button As Integer, Shift As Integer, x As Single, y As Single)
On Error Resume Next
Dim i As Long
If Button = vbRightButton Or (Button = vbLeftButton And IsMouseSwapped()) Then
LaunchMenu.Enabled = True
If LVGameInfo.ListItems(3).SubItems(1) = "n/a" Then LaunchMenu.Enabled = False
If Err.Number Then LaunchMenu.Enabled = False
AddToFavsMenu.Visible = True
RemoveFavoriteMenu.Visible = False
For i = 1 To UBound(FavoritesList)
If LCase(cboAddress.Text) = LCase(FavoritesList(i)) Then
RemoveFavoriteMenu.Visible = True
AddToFavsMenu.Visible = False
Exit For
End If
Next i
PopupMenu BtnPopupMenu, vbPopupMenuRightButton
End If
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 + IIf(i2 = 3, CStr(Val(CurrentLV.ListItems(i).SubItems(i2 - 1))), 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()
Dim i As Long
Dim i2 As Integer
Dim RegStr As String
Dim bFound As Boolean
LV_FlatColumnHeaders LVGameInfo
LV_FullRowSelect LVPlayers
For i = 1 To GetRegDWORD(HKEY_LOCAL_MACHINE, ServersReg, "QueryiedCount")
RegStr = GetRegString(HKEY_LOCAL_MACHINE, ServersReg, "Address[" & i & "]")
If RegStr <> "" Then
bFound = False
For i2 = 0 To cboAddress.ListCount - 1
If LCase(cboAddress.List(i2)) = LCase(RegStr) Then
bFound = True
Exit For
End If
Next i2
If Not bFound Then cboAddress.AddItem RegStr
End If
Next i
SetLVType LVGameInfo.hWnd, 3
SetLVType LVGameRules.hWnd, 1
SubClassListViewParentWnd hWnd
StartCBSubClass cboAddress.hWnd
End Sub
Private Sub Form_QueryUnload(Cancel As Integer, UnloadMode As Integer)
Dim i As Integer
SaveRegDWORD HKEY_LOCAL_MACHINE, ServersReg, "QueryiedCount", CLng(cboAddress.ListCount)
For i = 0 To cboAddress.ListCount - 1
SaveRegString HKEY_LOCAL_MACHINE, ServersReg, "Address[" & (i + 1) & "]", cboAddress.List(i)
Next i
End Sub
Private Sub Form_Unload(Cancel As Integer)
UnSubClassListViewParentWnd hWnd
RemoveLVType LVGameRules.hWnd
RemoveLVType LVGameInfo.hWnd
EndCBSubClass
MainForm.SetFocus
End Sub
Private Sub LaunchMenu_Click()
Dim i As Long
LaunchForm.txtAddress.Text = cboAddress.Text
Select Case LVGameInfo.ListItems(3).SubItems(1)
Case "action"
LaunchForm.IconImage.Visible = True
LaunchForm.IconImage.Picture = LoadResPicture(13, 1)
Case "cstrike"
LaunchForm.IconImage.Visible = True
LaunchForm.IconImage.Picture = LoadResPicture(5, 1)
Case "dmc"
LaunchForm.IconImage.Visible = True
LaunchForm.IconImage.Picture = LoadResPicture(7, 1)
Case "dod"
LaunchForm.IconImage.Visible = True
LaunchForm.IconImage.Picture = LoadResPicture(9, 1)
Case "firearms"
LaunchForm.IconImage.Visible = True
LaunchForm.IconImage.Picture = LoadResPicture(11, 1)
Case "frontline"
LaunchForm.IconImage.Visible = True
LaunchForm.IconImage.Picture = LoadResPicture(15, 1)
Case "tfc"
LaunchForm.IconImage.Visible = True
LaunchForm.IconImage.Picture = LoadResPicture(3, 1)
Case "valve"
LaunchForm.IconImage.Visible = True
LaunchForm.IconImage.Picture = LoadResPicture(2, 1)
Case Else
LaunchForm.IconImage.Visible = False
End Select
LaunchForm.IconImage.ToolTipText = LVGameInfo.ListItems(4).SubItems(1)
LaunchForm.Tag = LVGameInfo.ListItems(3).SubItems(1)
LaunchForm.bHasPassword = False
If Optn_AutoPB = 1 Then
LaunchForm.bNoSet = True
LaunchForm.lstOptions.Selected(0) = False
LaunchForm.bNoSet = False
End If
If Optn_AutoPaladin = 1 Then
LaunchForm.bNoSet = True
LaunchForm.lstOptions.Selected(1) = False
LaunchForm.bNoSet = False
End If
If Optn_AutoCD = 1 Then
LaunchForm.bNoSet = True
LaunchForm.lstOptions.Selected(2) = False
LaunchForm.bNoSet = False
End If
If LVGameRules.ListItems.Count > 0 Then
For i = 1 To LVGameRules.ListItems.Count
If (LCase(LVGameRules.ListItems(i).Text) = "sv_contact" And InStr(LVGameRules.ListItems(i).SubItems(1), "{PB REQ}")) And Optn_AutoPB = 1 Then
LaunchForm.bNoSet = True
LaunchForm.lstOptions.Selected(0) = True
LaunchForm.bNoSet = False
ElseIf (LCase(LVGameRules.ListItems(i).Text) = "sv_contact" And InStr(LVGameRules.ListItems(i).SubItems(1), "{PALADIN REQ}")) And Optn_AutoPaladin = 1 Then
LaunchForm.bNoSet = True
LaunchForm.lstOptions.Selected(1) = True
LaunchForm.bNoSet = False
ElseIf (LCase(LVGameRules.ListItems(i).Text) = "cdrequired" And Val(LVGameRules.ListItems(i).SubItems(1)) > 0) And Optn_AutoCD = 1 Then
LaunchForm.bNoSet = True
LaunchForm.lstOptions.Selected(2) = True
LaunchForm.bNoSet = False
ElseIf LCase(LVGameRules.ListItems(i).Text) = "sv_password" And Val(LVGameRules.ListItems(i).SubItems(1)) > 0 Then
LaunchForm.bHasPassword = True
End If
Next i
End If
LaunchForm.Show 0, MainForm
End Sub
Private Sub LVGameInfo_DblClick()
If Not (LVGameInfo.SelectedItem Is Nothing) Then
If LVGameInfo.SelectedItem.Selected And _
LVGameInfo.SelectedItem.Index = 7 Then
On Error Resume Next
DetailsForm.lblDetails.Caption = "&Details for " + WS_GameInfo.RemoteHostIP + ":" & WS_GameInfo.RemotePort & ":"
DetailsForm.Show 0, MainForm
If DetailsForm.Command2.Caption = "DNS &Address <<" Then
DetailsForm.Height = DetailsForm.txtDNS.Top + (DetailsForm.Height - DetailsForm.ScaleHeight) - 105
DetailsForm.Command2.Caption = "DNS &Address >>"
DetailsForm.txtDNS.TabStop = False
End If
DetailsForm.LVDetails.ListItems.Clear
DetailsForm.WS_Details.Close
DetailsForm.WS_Details.RemoteHost = WS_GameInfo.RemoteHostIP
DetailsForm.WS_Details.RemotePort = WS_GameInfo.RemotePort
DetailsForm.WS_Details.SendData "����infostring"
End If
End If
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 Or (Button = vbLeftButton And IsMouseSwapped()) 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 Or (Button = vbLeftButton And IsMouseSwapped()) 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 Or (Button = vbLeftButton And IsMouseSwapped()) 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 RCONConsoleMenu_Click()
Dim NewRCONForm As New RCONForm
Dim wsHost As String
Dim wsPort As Long
wsHost = cboAddress.Text
wsPort = 27015
If InStr(wsHost, ":") > 0 Then
wsPort = Val(Mid(wsHost, InStr(wsHost, ":") + 1))
wsHost = Left(wsHost, InStr(wsHost, ":") - 1)
If wsPort = 0 Then wsPort = 27015
End If
Load NewRCONForm
NewRCONForm.RCON_Address = wsHost
NewRCONForm.RCON_Port = wsPort
NewRCONForm.Show 0, MainForm
End Sub
Private Sub RefreshMenu_Click()
On Error Resume Next
CurrentLV.ListItems.Clear
If CurrentLV.Name = "LVGameInfo" Then
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(, , "Ping").SubItems(1) = "n/a"
End With
PingTimer = Timer
End If
CurrentWS.SendData WSDataToSend
Set CurrentLV = Nothing
Set CurrentWS = Nothing
WSDataToSend = ""
End Sub
Private Sub RemoveFavoriteMenu_Click()
Dim i As Long
Dim i2 As Long
For i = 1 To UBound(FavoritesList)
If LCase(cboAddress.Text) = LCase(FavoritesList(i)) Then
For i2 = i + 1 To UBound(FavoritesList)
FavoritesList(i2 - 1) = FavoritesList(i2)
Next i2
ReDim Preserve FavoritesList(UBound(FavoritesList) - 1)
Exit For
End If
Next i
End Sub
Private Sub RemoveMenu_Click()
Dim i As Integer
Dim strAddress As String
strAddress = cboAddress.Text
For i = 0 To cboAddress.ListCount - 1
If LCase(strAddress) = LCase(cboAddress.List(i)) Then
cboAddress.RemoveItem i
Exit For
End If
Next i
cboAddress.Text = strAddress
End Sub
Private Sub WS_GameInfo_DataArrival(ByVal bytesTotal As Long)
On Error GoTo ErrHandler
Dim RecvData As String
Dim ServerPing As Long
Dim i As Integer
WS_GameInfo.GetData RecvData
WS_GameInfo.Close
ServerPing = Abs(Round(Timer - PingTimer, 3) * 1000) + 20
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) = ServerPing & " ms"
LVGameInfo.ListItems.Add , , "Details..."
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
Dim LIndex As Long
Dim strText As String
Dim strSubItem As String
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
If (.Text = "sv_password" And Val(.SubItems(1)) > 0) Or _
(.Text = "mp_friendlyfire" And Val(.SubItems(1)) > 0) Or _
(.Text = "reserve_slots" And Val(.SubItems(1)) > 0) Or _
(.Text = "cdrequired" And Val(.SubItems(1)) > 0) Or _
(.Text = "sv_contact" And InStr(.SubItems(1), "{PB REQ}")) Or _
(.Text = "sv_contact" And InStr(.SubItems(1), "{PALADIN REQ}")) Then
LIndex = .Index
strText = .Text
strSubItem = .SubItems(1)
End If
End With
If LIndex > 0 Then
LVGameRules.ListItems.Remove LIndex
With LVGameRules.ListItems.Add(1)
.Text = strText
.SubItems(1) = strSubItem
End With
LIndex = 0
End If
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 String
Dim binPlayerTime As String
Dim lngSecs As Long
Dim lngSecs2 As Long
Dim lngHours As Long
Dim lngMins As Long
Dim i As Integer
Dim i2 As Long
Dim i3 As Integer
Dim NewIndex As Long
Dim strSubItem1 As String
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)
strSubItem1 = CStr(PlayerFrags)
.SubItems(2) = IIf(PlayerFrags < 0, "-", "") + String(3 - Len(strSubItem1), "0") & Abs(PlayerFrags)
i2 = i2 + 4
PlayerTime = ""
For i3 = 0 To 3
binPlayerTime = Dec2Bin(Asc(Mid(RecvData, i2 + i3, 1)))
If Len(binPlayerTime) < 8 Then binPlayerTime = String(8 - Len(binPlayerTime), "0") + binPlayerTime
PlayerTime = binPlayerTime + PlayerTime
Next i3
lngSecs = Float2Int(PlayerTime)
lngHours = Fix(lngSecs / 3600)
lngSecs = lngSecs - (lngHours * 3600)
lngMins = Fix(lngSecs / 60)
lngSecs2 = lngSecs - (lngMins * 60)
.SubItems(3) = Format(lngHours, "00:") & Format(lngMins, "00:") & Format(lngSecs2, "00")
i2 = i2 + 4
NewIndex = .Index
End With
SetSubItemText LVPlayers.hWnd, NewIndex - 1, 2, strSubItem1
Next i
End Sub
Download QuickQuery HL Edition/ServerQueryForm.frm