Find all our projects in development below.
All source code is GNU General Public License (GPL)
Browsing QuickQuery HL Edition/PlayerSearchForm.frm (58.81 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"
Object = "{532444B8-10BE-4A24-9805-31C4599561A0}#1.0#0"; "vbODCTL.ocx"
Begin VB.Form PlayerSearchForm
BorderStyle = 3 'Fixed Dialog
Caption = "Player Search Tool"
ClientHeight = 6375
ClientLeft = 45
ClientTop = 330
ClientWidth = 9735
BeginProperty Font
Name = "Tahoma"
Size = 8.25
Charset = 0
Weight = 400
Underline = 0 'False
Italic = 0 'False
Strikethrough = 0 'False
EndProperty
Icon = "PlayerSearchForm.frx":0000
MaxButton = 0 'False
MinButton = 0 'False
ScaleHeight = 6375
ScaleWidth = 9735
ShowInTaskbar = 0 'False
StartUpPosition = 1 'CenterOwner
Begin VB.PictureBox PictureContainer
BorderStyle = 0 'None
Height = 4695
Index = 0
Left = 120
ScaleHeight = 4695
ScaleWidth = 9375
TabIndex = 31
TabStop = 0 'False
Top = 960
Width = 9375
Begin VB.Frame Frame1
Caption = "&Search For..."
Height = 1215
Left = 240
TabIndex = 3
Top = 600
Width = 9015
Begin VB.TextBox txtPlayerName
Height = 315
Index = 0
Left = 600
TabIndex = 5
ToolTipText = "Player name"
Top = 360
Width = 5895
End
Begin VB.CheckBox chkUseWildcards
Caption = "Use Wildcards"
Height = 255
Index = 0
Left = 6720
TabIndex = 6
Top = 360
Width = 2055
End
Begin VB.TextBox txtPlayerName
Enabled = 0 'False
Height = 315
Index = 1
Left = 600
TabIndex = 8
ToolTipText = "Player name"
Top = 720
Width = 5895
End
Begin VB.CheckBox chkUseWildcards
Caption = "Use Wildcards"
Enabled = 0 'False
Height = 255
Index = 1
Left = 6720
TabIndex = 9
Top = 750
Width = 1935
End
Begin VB.CheckBox chkEnable
Caption = "Check1"
Enabled = 0 'False
Height = 255
Index = 0
Left = 240
TabIndex = 4
Top = 390
Value = 1 'Checked
Width = 230
End
Begin VB.CheckBox chkEnable
Caption = "Check1"
Height = 255
Index = 1
Left = 240
TabIndex = 7
Top = 750
Width = 230
End
End
Begin VB.Frame Frame4
Caption = "Filter"
Height = 735
Left = 240
TabIndex = 43
Top = 3840
Width = 9015
Begin VB.TextBox txtMap
Height = 315
Left = 6600
MaxLength = 50
TabIndex = 22
Top = 240
Width = 2175
End
Begin CboLstOD.ODComboList cboGameType
Height = 315
Left = 1680
TabIndex = 20
Top = 240
Width = 2055
_ExtentX = 3625
_ExtentY = 556
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
ForeColor = -2147483630
ClientDraw = 1
Style = 0
DefaultItemHeight= 18
AutoComplete = -1 'True
FullRowSelect = -1 'True
MaxLength = 100
End
Begin ComctlLib.ImageList GameImgList
Left = 3840
Top = 120
_ExtentX = 1005
_ExtentY = 1005
BackColor = -2147483643
MaskColor = 12632256
_Version = 327682
End
Begin VB.Label Label3
Caption = "Are running m&ap:"
Height = 255
Left = 5160
TabIndex = 21
Top = 300
Width = 1335
End
Begin VB.Label Label2
Caption = "Are running &game:"
Height = 255
Left = 240
TabIndex = 19
Top = 300
Width = 1455
End
End
Begin VB.Frame Frame3
Caption = "Half-Life Master Server Settings"
Height = 855
Left = 240
TabIndex = 41
Top = 2880
Width = 9015
Begin VB.CheckBox chkUseFavorites
Caption = "Use servers in &favorites list"
Height = 255
Left = 6600
TabIndex = 14
Top = -5
Width = 2325
End
Begin VB.CheckBox chkMax
Caption = "&Max amount of servers to download:"
Height = 255
Left = 4680
TabIndex = 17
Top = 400
Width = 3015
End
Begin VB.TextBox txtMax
Enabled = 0 'False
Height = 315
Left = 7800
MaxLength = 5
TabIndex = 18
Text = "5000"
Top = 360
Width = 975
End
Begin VB.ComboBox cboMaster
Height = 315
ItemData = "PlayerSearchForm.frx":030A
Left = 720
List = "PlayerSearchForm.frx":0317
TabIndex = 16
Text = "half-life.east.won.net:27010"
Top = 360
Width = 3015
End
Begin VB.Label Label18
Caption = "Us&e:"
Height = 255
Left = 240
TabIndex = 15
Top = 420
Width = 375
End
End
Begin VB.Frame Frame2
Caption = "Server Query Settings"
Height = 855
Left = 240
TabIndex = 33
Top = 1920
Width = 9015
Begin VB.TextBox txtTimeout
Height = 315
Left = 6960
MaxLength = 5
TabIndex = 13
Text = "1000"
Top = 360
Width = 615
End
Begin VB.TextBox txtMaxConn
Alignment = 2 'Center
Height = 315
Left = 600
MaxLength = 2
TabIndex = 11
Text = "60"
Top = 360
Width = 495
End
Begin VB.Label Label12
Caption = "(in milliseconds)"
Height = 255
Left = 7680
TabIndex = 35
Top = 420
Width = 1215
End
Begin VB.Label Label10
Caption = "&Query request timeout:"
Height = 255
Left = 5160
TabIndex = 12
Top = 420
Width = 1695
End
Begin VB.Label Label9
Caption = "simultaneous udp connections"
Height = 255
Left = 1200
TabIndex = 34
Top = 420
Width = 2295
End
Begin VB.Label Label7
Caption = "&Use"
Height = 255
Left = 240
TabIndex = 10
Top = 420
Width = 375
End
End
Begin VB.Label Label20
Caption = "Player Search Options"
BeginProperty Font
Name = "Tahoma"
Size = 9.75
Charset = 0
Weight = 700
Underline = 0 'False
Italic = 0 'False
Strikethrough = 0 'False
EndProperty
Height = 255
Left = 120
TabIndex = 32
Top = 120
Width = 7455
End
End
Begin VB.PictureBox PictureContainer
BorderStyle = 0 'None
Height = 4695
Index = 1
Left = 120
ScaleHeight = 4695
ScaleWidth = 9375
TabIndex = 36
TabStop = 0 'False
Top = 960
Width = 9375
Begin VB.CommandButton Command8
Caption = "P&ing Server"
Enabled = 0 'False
Height = 375
Left = 8160
TabIndex = 27
ToolTipText = "Ping the selected server"
Top = 1800
Width = 1095
End
Begin VB.Timer GameInfoTimer
Enabled = 0 'False
Interval = 1500
Left = 8280
Top = 0
End
Begin MSWinsockLib.Winsock WS_GameInfo
Left = 7800
Top = 0
_ExtentX = 741
_ExtentY = 741
_Version = 393216
Protocol = 1
End
Begin VB.CommandButton Command5
Caption = "&Stop"
Enabled = 0 'False
Height = 375
Left = 8160
TabIndex = 29
ToolTipText = "Stop refreshing servers"
Top = 2760
Width = 1095
End
Begin VB.TextBox txtCopy
Height = 285
Left = 8160
TabIndex = 42
TabStop = 0 'False
Top = 3240
Visible = 0 'False
Width = 1095
End
Begin MSWinsockLib.Winsock WS_RefreshServer
Left = 7320
Top = 0
_ExtentX = 741
_ExtentY = 741
_Version = 393216
Protocol = 1
End
Begin VB.CommandButton Command4
Caption = "&Refresh"
Enabled = 0 'False
Height = 375
Left = 8160
TabIndex = 26
ToolTipText = "Refresh selected server"
Top = 1320
Width = 1095
End
Begin VB.CommandButton Command1
Caption = "&Launch"
Enabled = 0 'False
BeginProperty Font
Name = "Tahoma"
Size = 8.25
Charset = 0
Weight = 700
Underline = 0 'False
Italic = 0 'False
Strikethrough = 0 'False
EndProperty
Height = 855
Left = 8160
Style = 1 'Graphical
TabIndex = 30
ToolTipText = "Launch Half-Life and connect to selected ip address"
Top = 3480
Width = 1095
End
Begin VB.Timer MSTimeoutTimer
Enabled = 0 'False
Interval = 30000
Left = 5880
Top = 0
End
Begin VB.Timer TimeoutTimer
Enabled = 0 'False
Index = 0
Interval = 500
Left = 6840
Top = 0
End
Begin VB.CommandButton Command7
Caption = "&Copy"
Enabled = 0 'False
Height = 375
Left = 8160
TabIndex = 28
ToolTipText = "Copy ip address to clipboard"
Top = 2280
Width = 1095
End
Begin VB.CommandButton Command6
Caption = "&View Info..."
Enabled = 0 'False
Height = 375
Left = 8160
TabIndex = 25
ToolTipText = "View info about the server"
Top = 840
Width = 1095
End
Begin ComctlLib.ListView LVPlayersFound
Height = 3495
Left = 240
TabIndex = 24
ToolTipText = "Double-click to refresh selected server"
Top = 840
Width = 7815
_ExtentX = 13785
_ExtentY = 6165
View = 3
LabelEdit = 1
SortOrder = -1 'True
LabelWrap = -1 'True
HideSelection = 0 'False
_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 = 5
BeginProperty ColumnHeader(1) {0713E8C7-850A-101B-AFC0-4210102A8DA7}
Key = ""
Object.Tag = ""
Text = "Server Address"
Object.Width = 2999
EndProperty
BeginProperty ColumnHeader(2) {0713E8C7-850A-101B-AFC0-4210102A8DA7}
Alignment = 2
SubItemIndex = 1
Key = ""
Object.Tag = ""
Text = "Ping"
Object.Width = 706
EndProperty
BeginProperty ColumnHeader(3) {0713E8C7-850A-101B-AFC0-4210102A8DA7}
SubItemIndex = 2
Key = ""
Object.Tag = ""
Text = "Player Name"
Object.Width = 5116
EndProperty
BeginProperty ColumnHeader(4) {0713E8C7-850A-101B-AFC0-4210102A8DA7}
Alignment = 2
SubItemIndex = 3
Key = ""
Object.Tag = ""
Text = "Frags"
Object.Width = 706
EndProperty
BeginProperty ColumnHeader(5) {0713E8C7-850A-101B-AFC0-4210102A8DA7}
Alignment = 1
SubItemIndex = 4
Key = ""
Object.Tag = ""
Text = "Time"
Object.Width = 1058
EndProperty
End
Begin MSWinsockLib.Winsock WS_QueryServer
Index = 0
Left = 6360
Top = 0
_ExtentX = 741
_ExtentY = 741
_Version = 393216
Protocol = 1
End
Begin MSWinsockLib.Winsock WS_GetServerList
Left = 5400
Top = 0
_ExtentX = 741
_ExtentY = 741
_Version = 393216
Protocol = 1
End
Begin MSWinsockLib.Winsock WS_GameRules
Left = 8760
Top = 0
_ExtentX = 741
_ExtentY = 741
_Version = 393216
Protocol = 1
End
Begin VB.Label Label17
Caption = "&Players Found:"
Height = 255
Left = 240
TabIndex = 23
Top = 600
Width = 1215
End
Begin VB.Label lblLeft
AutoSize = -1 'True
Caption = "Servers Left:"
Height = 195
Left = 6000
TabIndex = 40
Top = 4440
Visible = 0 'False
Width = 945
End
Begin VB.Label lblTotal
AutoSize = -1 'True
Caption = "Total Servers:"
Height = 195
Left = 3960
TabIndex = 39
Top = 4440
Visible = 0 'False
Width = 1020
End
Begin VB.Label lblStatus
AutoSize = -1 'True
Caption = "Status: Downloading Server List..."
Height = 195
Left = 240
TabIndex = 38
Top = 4440
Width = 2475
End
Begin VB.Label Label13
Caption = "Searching For Players..."
BeginProperty Font
Name = "Tahoma"
Size = 9.75
Charset = 0
Weight = 700
Underline = 0 'False
Italic = 0 'False
Strikethrough = 0 'False
EndProperty
Height = 255
Left = 120
TabIndex = 37
Top = 120
Width = 5175
End
End
Begin VB.PictureBox pbTitleBox
BackColor = &H80000005&
BorderStyle = 0 'None
Height = 855
Left = 0
ScaleHeight = 855
ScaleWidth = 9735
TabIndex = 44
Top = 0
Width = 9735
Begin VB.PictureBox pbIcon
BackColor = &H80000005&
Height = 615
Left = 9000
Picture = "PlayerSearchForm.frx":0378
ScaleHeight = 555
ScaleWidth = 555
TabIndex = 46
TabStop = 0 'False
Top = 120
Width = 615
End
Begin VB.Label lblTitle
AutoSize = -1 'True
BackStyle = 0 'Transparent
Caption = "Half-Life Player Search"
BeginProperty Font
Name = "Verdana"
Size = 14.25
Charset = 0
Weight = 700
Underline = 0 'False
Italic = 0 'False
Strikethrough = 0 'False
EndProperty
Height = 345
Left = 240
TabIndex = 45
Top = 240
Width = 3735
End
End
Begin VB.CommandButton Command3
Cancel = -1 'True
Caption = "Close"
Height = 375
Left = 120
TabIndex = 2
Top = 5895
Width = 1215
End
Begin VB.CommandButton Command2
Caption = "&Next >"
Default = -1 'True
Height = 375
Index = 1
Left = 8400
TabIndex = 0
Top = 5895
Width = 1215
End
Begin VB.CommandButton Command2
Caption = "< &Back"
Enabled = 0 'False
Height = 375
Index = 0
Left = 7080
TabIndex = 1
Top = 5895
Width = 1215
End
Begin VB.Line lnLightShadow
BorderColor = &H80000014&
X1 = 9600
X2 = 120
Y1 = 5775
Y2 = 5775
End
Begin VB.Line lnDarkShadow
BorderColor = &H80000015&
X1 = 9600
X2 = 120
Y1 = 5760
Y2 = 5760
End
Begin VB.Line lnTitleBox
BorderColor = &H80000015&
X1 = 0
X2 = 9720
Y1 = 855
Y2 = 855
End
Begin VB.Line lnTitleBox2
BorderColor = &H80000014&
X1 = 9720
X2 = 0
Y1 = 870
Y2 = 870
End
End
Attribute VB_Name = "PlayerSearchForm"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = True
Attribute VB_Exposed = False
Private Type HL_SERVER
IP As String
Port As Long
End Type
Dim ServerList() As HL_SERVER
Dim ServerIndex As Long
Dim LastTimer() As Single
Dim CurrentPic As Integer
Dim SCount As Long
Dim bServersDone As Boolean
Dim RefreshIndex As Long
Dim RefreshTimer As Single
Dim RefreshName As String
Dim bPunkBuster As Boolean
Dim bPaladin As Boolean
Dim bCD As Boolean
Dim bPassword As Boolean
Dim FindCompAnimateWnd As Long
Sub SetPictureContainerIndex(Index As Integer)
Dim i As Integer
For i = PictureContainer.LBound To PictureContainer.UBound
PictureContainer(i).Enabled = IIf(Index = i, True, False)
Next i
PictureContainer(Index).ZOrder 0
End Sub
Private Sub StartRefresh()
Dim i As Integer
lblTotal.Caption = "Total Servers: " & SCount
lblTotal.Visible = True
lblLeft.Caption = "Servers Left: " & SCount & " (100%)"
lblLeft.Visible = True
Command5.Enabled = True
For i = WS_QueryServer.LBound + 1 To WS_QueryServer.UBound
ServerIndex = ServerIndex + 1
If chkUseFavorites.Value = 0 Then
If chkMax.Value = 1 And ServerIndex > Val(txtMax.Text) Then Exit For
End If
lblStatus.Caption = "Status: Refreshing " & ServerList(ServerIndex).IP & ":" & ServerList(ServerIndex).Port & "..."
TimeoutTimer(i).Enabled = True
LastTimer(i) = Timer
WS_QueryServer(i).RemoteHost = ServerList(ServerIndex).IP
WS_QueryServer(i).RemotePort = ServerList(ServerIndex).Port
WS_QueryServer(i).SendData "����players"
Next i
End Sub
Private Sub chkEnable_Click(Index As Integer)
On Error Resume Next
txtPlayerName(Index).Enabled = CBool(chkEnable(Index).Value)
chkUseWildcards(Index).Enabled = CBool(chkEnable(Index).Value)
If txtPlayerName(Index).Enabled Then
txtPlayerName(Index).SetFocus
txtPlayerName(Index).SelStart = 0
txtPlayerName(Index).SelLength = Len(txtPlayerName(Index).Text)
End If
End Sub
Private Sub chkMax_Click()
On Error Resume Next
txtMax.Enabled = CBool(chkMax.Value)
If txtMax.Enabled Then
txtMax.SetFocus
txtMax.SelStart = 0
txtMax.SelLength = Len(txtMax.Text)
End If
End Sub
Private Sub chkUseFavorites_Click()
If chkUseFavorites.Value = 0 Then
Label18.Enabled = True
cboMaster.Enabled = True
chkMax.Enabled = True
If chkMax.Value = 1 Then txtMax.Enabled = True
Label2.Enabled = True
cboGameType.Enabled = True
Label3.Enabled = True
txtMap.Enabled = True
Else
Label18.Enabled = False
cboMaster.Enabled = False
chkMax.Enabled = False
txtMax.Enabled = False
Label2.Enabled = False
cboGameType.Enabled = False
Label3.Enabled = False
txtMap.Enabled = False
End If
End Sub
Private Sub Command1_Click()
LaunchForm.txtAddress.Text = LVPlayersFound.SelectedItem.Text
Select Case Command1.Tag
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 = Command1.Tag
LaunchForm.Tag = Command1.Tag
LaunchForm.bHasPassword = False
If Optn_AutoPB = 1 Then
If bPunkBuster = True Then
LaunchForm.bNoSet = True
LaunchForm.lstOptions.Selected(0) = True
LaunchForm.bNoSet = False
Else
LaunchForm.bNoSet = True
LaunchForm.lstOptions.Selected(0) = False
LaunchForm.bNoSet = False
End If
End If
If Optn_AutoPaladin = 1 Then
If bPaladin = True Then
LaunchForm.bNoSet = True
LaunchForm.lstOptions.Selected(1) = True
LaunchForm.bNoSet = False
Else
LaunchForm.bNoSet = True
LaunchForm.lstOptions.Selected(1) = False
LaunchForm.bNoSet = False
End If
End If
If Optn_AutoCD = 1 Then
If bCD = True Then
LaunchForm.bNoSet = True
LaunchForm.lstOptions.Selected(2) = True
LaunchForm.bNoSet = False
Else
LaunchForm.bNoSet = True
LaunchForm.lstOptions.Selected(2) = False
LaunchForm.bNoSet = False
End If
End If
If bPassword = True Then LaunchForm.bHasPassword = True
LaunchForm.Show 0, MainForm
End Sub
Private Sub Command2_Click(Index As Integer)
On Error Resume Next
Dim i As Long
Dim wsHost As String
Dim wsPort As Long
Dim WSDataToSend As String
If CurrentPic = 0 Then
For i = chkEnable.LBound To chkEnable.UBound
If chkEnable(i).Value = 1 Then
If txtPlayerName(i).Text = "" Then
MsgBox "Please enter a player name.", vbExclamation
txtPlayerName(i).SetFocus
Exit Sub
End If
End If
Next i
If Val(txtMaxConn.Text) < 1 Then
MsgBox "Please enter a number greater than zero.", vbExclamation
txtMaxConn.SetFocus
txtMaxConn.Text = "20"
txtMaxConn.SelStart = 0
txtMaxConn.SelLength = Len(txtMaxConn.Text)
Exit Sub
End If
If Val(txtTimeout.Text) < 1 Then
MsgBox "Please enter a number greater than zero.", vbExclamation
txtTimeout.SetFocus
txtTimeout.Text = "1000"
txtTimeout.SelStart = 0
txtTimeout.SelLength = Len(txtTimeout.Text)
Exit Sub
End If
If Val(txtMax.Text) < 1 And chkMax.Value = 1 Then
MsgBox "Please enter a number greater than zero.", vbExclamation
txtMax.SetFocus
txtMax.Text = "5000"
txtMax.SelStart = 0
txtMax.SelLength = Len(txtMax.Text)
Exit Sub
End If
If cboMaster.Text = "" Then
MsgBox "Please enter a master server address or choose one.", vbExclamation
cboMaster.SetFocus
Exit Sub
End If
If InStr(cboGameType.Text, "\") Then
MsgBox "Invalid character in game type.", vbExclamation
cboGameType.SetFocus
Exit Sub
End If
If InStr(txtMap.Text, "\") Then
MsgBox "Invalid character in map name.", vbExclamation
txtMap.SetFocus
txtMap.SelStart = 0
txtMap.SelLength = Len(txtMap.Text)
Exit Sub
End If
End If
If Index = 0 Then
CurrentPic = CurrentPic - 1
Command2(1).Enabled = True
If CurrentPic = PictureContainer.LBound Then
Command2(0).Enabled = False
Command2(1).SetFocus
End If
Else
CurrentPic = CurrentPic + 1
Command2(0).Enabled = True
End If
If CurrentPic = 1 Then
Command2(1).Enabled = False
Else
Command2(1).Enabled = True
End If
SetPictureContainerIndex CurrentPic
Select Case CurrentPic
Case 0
Command2(1).Default = True
If WS_QueryServer.UBound > 0 Then
MousePointer = vbHourglass
WS_GetServerList.Close
WS_RefreshServer.Close
WS_GameInfo.Close
MSTimeoutTimer.Enabled = False
GameInfoTimer.Enabled = False
For i = WS_QueryServer.UBound To 1 Step -1
Unload WS_QueryServer(i)
Unload TimeoutTimer(i)
Next i
MousePointer = vbDefault
End If
Case 1
ReDim LastTimer(Val(txtMaxConn.Text))
ReDim ServerList(0)
MousePointer = vbHourglass
Command1.Default = True
ServerIndex = 0
For i = 1 To Val(txtMaxConn.Text)
If chkUseFavorites.Value = 1 Then
If i > UBound(FavoritesList) Then Exit For
End If
Load WS_QueryServer(i)
Load TimeoutTimer(i)
TimeoutTimer(i).Interval = Val(txtTimeout.Text)
Next i
LVPlayersFound.ListItems.Clear
LVPlayersFound.Sorted = False
LVPlayersFound.SortOrder = lvwDescending
Label13.Caption = "Searching For Players..."
lblStatus.Caption = "Status: Downloading Server List..."
lblTotal.Visible = False
lblLeft.Visible = False
SCount = 0
bServersDone = False
Command6.Enabled = False
Command4.Enabled = False
Command8.Enabled = False
Command7.Enabled = False
Command5.Enabled = False
Command1.Enabled = False
Command1.Picture = LoadResPicture(2, 1)
Command1.DisabledPicture = LoadResPicture(2, 1)
If chkUseFavorites.Value = 0 Then
MSTimeoutTimer.Enabled = True
WS_GetServerList.Close
wsHost = cboMaster.Text
wsPort = 27010
If InStr(wsHost, ":") > 0 Then
wsPort = Val(Mid(wsHost, InStr(wsHost, ":") + 1))
wsHost = Left(wsHost, InStr(wsHost, ":") - 1)
If wsPort = 0 Then wsPort = 27010
End If
WS_GetServerList.RemoteHost = wsHost
WS_GetServerList.RemotePort = wsPort
WSDataToSend = "1" & String(4, 0) & IIf(cboGameType.Text <> "", "\gamedir\" + cboGameType.Text, "") & IIf(txtMap.Text <> "", "\map\" + txtMap.Text, "") & "\empty\1" & vbNullChar
WS_GetServerList.SendData WSDataToSend
If Err.Number <> 0 Then WS_GetServerList.SendData WSDataToSend
Else
SCount = UBound(FavoritesList)
ReDim ServerList(SCount)
For i = 1 To SCount
wsHost = FavoritesList(i)
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
ServerList(i).IP = wsHost
ServerList(i).Port = wsPort
Next i
StartRefresh
End If
MousePointer = vbDefault
PlayVideo FindCompAnimateWnd
End Select
End Sub
Private Sub Command3_Click()
Unload Me
End Sub
Private Sub Command4_Click()
RefreshTimer = Timer
RefreshIndex = LVPlayersFound.SelectedItem.Index
RefreshName = LVPlayersFound.SelectedItem.SubItems(2)
WS_RefreshServer.Close
WS_RefreshServer.RemoteHost = Left(LVPlayersFound.SelectedItem.Text, InStr(LVPlayersFound.SelectedItem.Text, ":") - 1)
WS_RefreshServer.RemotePort = Val(Mid(LVPlayersFound.SelectedItem.Text, InStr(LVPlayersFound.SelectedItem.Text, ":") + 1))
WS_RefreshServer.SendData "����players"
Command1.Enabled = False
Command1.Picture = LoadResPicture(99, 1)
Command1.DisabledPicture = LoadResPicture(99, 1)
Command1.Tag = "valve"
GameInfoTimer.Enabled = False
GameInfoTimer.Enabled = True
WS_GameInfo.Close
WS_GameInfo.RemoteHost = Left(LVPlayersFound.SelectedItem.Text, InStr(LVPlayersFound.SelectedItem.Text, ":") - 1)
WS_GameInfo.RemotePort = Val(Mid(LVPlayersFound.SelectedItem.Text, InStr(LVPlayersFound.SelectedItem.Text, ":") + 1))
WS_GameInfo.SendData "����info"
WS_GameRules.Close
WS_GameRules.RemoteHost = Left(LVPlayersFound.SelectedItem.Text, InStr(LVPlayersFound.SelectedItem.Text, ":") - 1)
WS_GameRules.RemotePort = Val(Mid(LVPlayersFound.SelectedItem.Text, InStr(LVPlayersFound.SelectedItem.Text, ":") + 1))
WS_GameRules.SendData "����rules"
End Sub
Private Sub Command5_Click()
MousePointer = vbHourglass
Command5.Enabled = False
lblTotal.Visible = False
lblLeft.Visible = False
StopVideo FindCompAnimateWnd
For i = WS_QueryServer.UBound To 1 Step -1
Unload WS_QueryServer(i)
Unload TimeoutTimer(i)
Next i
lblStatus.Caption = "Status: Done."
Label13.Caption = LVPlayersFound.ListItems.Count & " Player" + IIf(LVPlayersFound.ListItems.Count <> 1, "s", "") + " Found"
MousePointer = vbDefault
End Sub
Private Sub Command6_Click()
ServerQueryForm.cboAddress.Text = LVPlayersFound.SelectedItem.Text
ServerQueryForm.Show 0, MainForm
ServerQueryForm.QueryServerClick
End Sub
Private Sub Command7_Click()
txtCopy.Text = LVPlayersFound.SelectedItem.Text
txtCopy.SelStart = 0
txtCopy.SelLength = Len(txtCopy.Text)
ClipboardCut txtCopy.hWnd
End Sub
Private Sub Command8_Click()
Dim iStatCode As Integer
Dim sStatMsg As String
Dim RetVal As Long
RetVal = PingIP(Left(LVPlayersFound.SelectedItem.Text, InStr(LVPlayersFound.SelectedItem.Text, ":") - 1), iStatCode, sStatMsg)
If iStatCode = 0 Then
LVPlayersFound.SelectedItem.SubItems(1) = RetVal
ElseIf iStatCode = 11010 Then
LVPlayersFound.SelectedItem.SubItems(1) = "9999"
ElseIf iStatCode <> -1 Then
MsgBox "Ping error: " + sStatMsg, vbExclamation
End If
End Sub
Private Sub Form_Initialize()
InitCommonCtrls
End Sub
Private Sub Form_Load()
On Error Resume Next
Dim i As Integer
Dim lRegData As Long
Dim bRegErr As Boolean
CurrentPic = 0
SetPictureContainerIndex CurrentPic
LV_FullRowSelect LVPlayersFound
lRegData = GetRegDWORD(HKEY_LOCAL_MACHINE, PlayerSearchReg, "EnableSearch[2]", bRegErr)
If (lRegData <> 0 And lRegData <> 1) Or bRegErr Then lRegData = 0
chkEnable(1).Value = lRegData
lRegData = GetRegDWORD(HKEY_LOCAL_MACHINE, PlayerSearchReg, "UseWildcards[1]", bRegErr)
If (lRegData <> 0 And lRegData <> 1) Or bRegErr Then lRegData = 0
chkUseWildcards(0).Value = lRegData
lRegData = GetRegDWORD(HKEY_LOCAL_MACHINE, PlayerSearchReg, "UseWildcards[2]", bRegErr)
If (lRegData <> 0 And lRegData <> 1) Or bRegErr Then lRegData = 0
chkUseWildcards(1).Value = lRegData
txtPlayerName(0).Text = GetRegString(HKEY_LOCAL_MACHINE, PlayerSearchReg, "PlayerName[1]")
txtPlayerName(1).Text = GetRegString(HKEY_LOCAL_MACHINE, PlayerSearchReg, "PlayerName[2]")
lRegData = GetRegDWORD(HKEY_LOCAL_MACHINE, PlayerSearchReg, "MaxConnections", bRegErr)
If (lRegData < 1 Or lRegData > 99) Or bRegErr Then lRegData = 60
txtMaxConn.Text = lRegData
lRegData = GetRegDWORD(HKEY_LOCAL_MACHINE, PlayerSearchReg, "QueryTimeout", bRegErr)
If (lRegData < 1 Or lRegData > 99999) Or bRegErr Then lRegData = 1000
txtTimeout.Text = lRegData
cboMaster.Text = GetRegString(HKEY_LOCAL_MACHINE, PlayerSearchReg, "MasterServer")
If cboMaster.Text = "" Then cboMaster.Text = Optn_MasterServer
lRegData = GetRegDWORD(HKEY_LOCAL_MACHINE, PlayerSearchReg, "EnableMaxServers", bRegErr)
If (lRegData <> 0 And lRegData <> 1) Or bRegErr Then lRegData = 0
chkMax.Value = lRegData
lRegData = GetRegDWORD(HKEY_LOCAL_MACHINE, PlayerSearchReg, "MaxServerAmount", bRegErr)
If (lRegData < 1 Or lRegData > 99999) Or bRegErr Then lRegData = 5000
txtMax.Text = lRegData
lRegData = GetRegDWORD(HKEY_LOCAL_MACHINE, PlayerSearchReg, "UseFavorites", bRegErr)
If (lRegData <> 0 And lRegData <> 1) Or bRegErr Then lRegData = 0
chkUseFavorites.Value = lRegData
cboGameType.Text = GetRegString(HKEY_LOCAL_MACHINE, PlayerSearchReg, "GameFilter")
txtMap.Text = GetRegString(HKEY_LOCAL_MACHINE, PlayerSearchReg, "MapFilter")
With GameImgList
.ImageWidth = 16
.ImageHeight = 16
.ListImages.Add , , LoadResPicture(2, 1)
.ListImages.Add , , LoadResPicture(3, 1)
.ListImages.Add , , LoadResPicture(4, 1)
.ListImages.Add , , LoadResPicture(6, 1)
.ListImages.Add , , LoadResPicture(8, 1)
.ListImages.Add , , LoadResPicture(10, 1)
.ListImages.Add , , LoadResPicture(12, 1)
.ListImages.Add , , LoadResPicture(14, 1)
End With
With cboGameType
.ImageList = GameImgList
.AddItemAndData "action", 6
.AddItemAndData "cstrike", 2
.AddItemAndData "dmc", 3
.AddItemAndData "dod", 4
.AddItemAndData "firearms", 5
.AddItemAndData "frontline", 7
.AddItemAndData "tfc", 1
.AddItemAndData "valve", 0
End With
bPunkBuster = False
bPaladin = False
bCD = False
bPassword = False
If Optn_LVHotTrack = 1 Then LV_HotTracking LVPlayersFound, True
FindCompAnimateWnd = CreateAnimateWindow(556, 8, 48, 48, PictureContainer(1).hWnd)
If FindCompAnimateWnd Then OpenVideoFile FindCompAnimateWnd, , 300
End Sub
Private Sub Form_QueryUnload(Cancel As Integer, UnloadMode As Integer)
StopVideo FindCompAnimateWnd
DestroyAnimateWindow FindCompAnimateWnd
SaveRegDWORD HKEY_LOCAL_MACHINE, PlayerSearchReg, "EnableSearch[2]", CLng(chkEnable(1).Value)
SaveRegDWORD HKEY_LOCAL_MACHINE, PlayerSearchReg, "UseWildcards[1]", CLng(chkUseWildcards(0).Value)
SaveRegDWORD HKEY_LOCAL_MACHINE, PlayerSearchReg, "UseWildcards[2]", CLng(chkUseWildcards(1).Value)
SaveRegString HKEY_LOCAL_MACHINE, PlayerSearchReg, "PlayerName[1]", txtPlayerName(0).Text
SaveRegString HKEY_LOCAL_MACHINE, PlayerSearchReg, "PlayerName[2]", txtPlayerName(1).Text
SaveRegDWORD HKEY_LOCAL_MACHINE, PlayerSearchReg, "MaxConnections", CLng(Val(txtMaxConn.Text))
SaveRegDWORD HKEY_LOCAL_MACHINE, PlayerSearchReg, "QueryTimeout", CLng(Val(txtTimeout.Text))
SaveRegString HKEY_LOCAL_MACHINE, PlayerSearchReg, "MasterServer", cboMaster.Text
SaveRegDWORD HKEY_LOCAL_MACHINE, PlayerSearchReg, "EnableMaxServers", CStr(chkMax.Value)
SaveRegDWORD HKEY_LOCAL_MACHINE, PlayerSearchReg, "MaxServerAmount", CLng(Val(txtMax.Text))
SaveRegDWORD HKEY_LOCAL_MACHINE, PlayerSearchReg, "UseFavorites", CLng(chkUseFavorites.Value)
SaveRegString HKEY_LOCAL_MACHINE, PlayerSearchReg, "GameFilter", cboGameType.Text
SaveRegString HKEY_LOCAL_MACHINE, PlayerSearchReg, "MapFilter", txtMap.Text
End Sub
Private Sub Form_Unload(Cancel As Integer)
MainForm.SetFocus
End Sub
Private Sub GameInfoTimer_Timer()
GameInfoTimer.Enabled = False
WS_GameInfo.Close
WS_GameRules.Close
Command1.Picture = LoadResPicture(2, 1)
Command1.DisabledPicture = LoadResPicture(2, 1)
End Sub
Private Sub LVPlayersFound_ColumnClick(ByVal ColumnHeader As ComctlLib.ColumnHeader)
If Command6.Enabled Then
LVPlayersFound.SortOrder = Abs(Not (LVPlayersFound.SortOrder * -1))
LVPlayersFound.SortKey = ColumnHeader.Index - 1
LVPlayersFound.Sorted = True
End If
End Sub
Private Sub LVPlayersFound_DblClick()
If Not (LVPlayersFound.SelectedItem Is Nothing) Then
If LVPlayersFound.SelectedItem.Selected Then
If Command6.Enabled Then Command4_Click
End If
End If
End Sub
Private Sub LVPlayersFound_ItemClick(ByVal Item As ComctlLib.ListItem)
Command6.Enabled = True
Command4.Enabled = True
Command8.Enabled = True
Command7.Enabled = True
If WS_GameInfo.RemoteHostIP <> Left(LVPlayersFound.SelectedItem.Text, InStr(LVPlayersFound.SelectedItem.Text, ":") - 1) Or _
WS_GameInfo.RemotePort <> Val(Mid(LVPlayersFound.SelectedItem.Text, InStr(LVPlayersFound.SelectedItem.Text, ":") + 1)) Then
Command1.Enabled = False
Command1.Picture = LoadResPicture(99, 1)
Command1.DisabledPicture = LoadResPicture(99, 1)
Command1.Tag = "valve"
GameInfoTimer.Enabled = False
GameInfoTimer.Enabled = True
WS_GameInfo.Close
WS_GameInfo.RemoteHost = Left(LVPlayersFound.SelectedItem.Text, InStr(LVPlayersFound.SelectedItem.Text, ":") - 1)
WS_GameInfo.RemotePort = Val(Mid(LVPlayersFound.SelectedItem.Text, InStr(LVPlayersFound.SelectedItem.Text, ":") + 1))
WS_GameInfo.SendData "����info"
WS_GameRules.Close
WS_GameRules.RemoteHost = Left(LVPlayersFound.SelectedItem.Text, InStr(LVPlayersFound.SelectedItem.Text, ":") - 1)
WS_GameRules.RemotePort = Val(Mid(LVPlayersFound.SelectedItem.Text, InStr(LVPlayersFound.SelectedItem.Text, ":") + 1))
WS_GameRules.SendData "����rules"
End If
End Sub
Private Sub MSTimeoutTimer_Timer()
On Error Resume Next
MSTimeoutTimer.Enabled = False
bServersDone = True
If SCount = 0 Then
MsgBox "No servers received from master." & vbCrLf & vbCrLf & "Please try again later.", vbExclamation
lblStatus.Caption = "Status: Done."
Label13.Caption = "0 Players Found"
StopVideo FindCompAnimateWnd
Exit Sub
End If
lblTotal.Caption = "Total Servers: " & SCount
lblTotal.Visible = True
lblLeft.Caption = "Servers Left: " & SCount & " (100%)"
lblLeft.Visible = True
For i = WS_QueryServer.LBound + 1 To WS_QueryServer.UBound
ServerIndex = ServerIndex + 1
lblStatus.Caption = "Status: Refreshing " & ServerList(ServerIndex).IP & ":" & ServerList(ServerIndex).Port & "..."
TimeoutTimer(i).Enabled = True
LastTimer(i) = Timer
WS_QueryServer(i).RemoteHost = ServerList(ServerIndex).IP
WS_QueryServer(i).RemotePort = ServerList(ServerIndex).Port
WS_QueryServer(i).SendData "����players"
Next i
End Sub
Private Sub TimeoutTimer_Timer(Index As Integer)
On Error Resume Next
TimeoutTimer(Index).Enabled = False
ServerIndex = ServerIndex + 1
If ServerIndex > UBound(ServerList) Then
lblStatus.Caption = "Status: Done."
Label13.Caption = LVPlayersFound.ListItems.Count & " Player" + IIf(LVPlayersFound.ListItems.Count <> 1, "s", "") + " Found"
lblTotal.Visible = False
lblLeft.Visible = False
Command5.Enabled = False
StopVideo FindCompAnimateWnd
If Optn_UnloadWSControls = 1 Then
Unload WS_QueryServer(Index)
Unload TimeoutTimer(Index)
End If
Exit Sub
End If
lblStatus.Caption = "Status: Refreshing " & ServerList(ServerIndex).IP & ":" & ServerList(ServerIndex).Port & "..."
TimeoutTimer(Index).Enabled = True
WS_QueryServer(Index).Close
LastTimer(Index) = Timer
WS_QueryServer(Index).RemoteHost = ServerList(ServerIndex).IP
WS_QueryServer(Index).RemotePort = ServerList(ServerIndex).Port
lblLeft.Caption = "Servers Left: " & (UBound(ServerList) - ServerIndex) & " (" & (100 - Int((ServerIndex / UBound(ServerList)) * 100)) & "%)"
WS_QueryServer(Index).SendData "����players"
End Sub
Private Sub txtMax_KeyPress(KeyAscii As Integer)
If KeyAscii >= 48 And KeyAscii <= 57 Or KeyAscii = 8 Then Exit Sub
KeyAscii = 0
End Sub
Private Sub txtMax_LostFocus()
txtMax.Text = Val(txtMax.Text)
End Sub
Private Sub txtMaxConn_KeyPress(KeyAscii As Integer)
If KeyAscii >= 48 And KeyAscii <= 57 Or KeyAscii = 8 Then Exit Sub
KeyAscii = 0
End Sub
Private Sub txtMaxConn_LostFocus()
txtMaxConn.Text = Val(txtMaxConn.Text)
End Sub
Private Sub txtTimeout_KeyPress(KeyAscii As Integer)
If KeyAscii >= 48 And KeyAscii <= 57 Or KeyAscii = 8 Then Exit Sub
KeyAscii = 0
End Sub
Private Sub txtTimeout_LostFocus()
txtTimeout.Text = Val(txtTimeout.Text)
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
GameInfoTimer.Enabled = False
i = 6
i = InStr(i, RecvData, vbNullChar) + 1
i = InStr(i, RecvData, vbNullChar) + 1
i = InStr(i, RecvData, vbNullChar) + 1
Select Case LCase(Mid(RecvData, i, InStr(i + 1, RecvData, vbNullChar) - i))
Case "action"
Command1.Picture = LoadResPicture(13, 1)
Command1.DisabledPicture = LoadResPicture(13, 1)
Case "cstrike"
Command1.Picture = LoadResPicture(5, 1)
Command1.DisabledPicture = LoadResPicture(5, 1)
Case "dmc"
Command1.Picture = LoadResPicture(7, 1)
Command1.DisabledPicture = LoadResPicture(7, 1)
Case "dod"
Command1.Picture = LoadResPicture(9, 1)
Command1.DisabledPicture = LoadResPicture(9, 1)
Case "firearms"
Command1.Picture = LoadResPicture(11, 1)
Command1.DisabledPicture = LoadResPicture(11, 1)
Case "frontline"
Command1.Picture = LoadResPicture(15, 1)
Command1.DisabledPicture = LoadResPicture(15, 1)
Case "tfc"
Command1.Picture = LoadResPicture(3, 1)
Command1.DisabledPicture = LoadResPicture(3, 1)
Case Else
Command1.Picture = LoadResPicture(2, 1)
Command1.DisabledPicture = LoadResPicture(2, 1)
End Select
Command1.Tag = Mid(RecvData, i, InStr(i + 1, RecvData, vbNullChar) - i)
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
bPunkBuster = False
bPaladin = False
bCD = False
bPassword = False
i2 = InStr(7, RecvData, vbNullChar) + 1
TotalRules = Asc(Mid(RecvData, 6, 1))
For i = 1 To TotalRules
strText = Mid(RecvData, i2, InStr(i2 + 1, RecvData, vbNullChar) - i2)
i2 = InStr(i2, RecvData, vbNullChar) + 1
strSubItem = Mid(RecvData, i2, InStr(i2 + 1, RecvData, vbNullChar) - i2)
i2 = InStr(i2, RecvData, vbNullChar) + 1
If strText = "sv_contact" And InStr(strSubItem, "{PB REQ}") Then bPunkBuster = True
If strText = "sv_contact" And InStr(strSubItem, "{PALADIN REQ}") Then bPaladin = True
If strText = "cdrequired" Then bCD = CBool(Val(strSubItem))
If strText = "sv_password" Then bPassword = CBool(Val(strSubItem))
Next i
Command1.Enabled = True
ErrHandler:
End Sub
Private Sub WS_GetServerList_DataArrival(ByVal bytesTotal As Long)
On Error GoTo ErrHandler
Dim RecvData As String
Dim i As Long
Dim UniqueKey As String
If bServersDone Then Exit Sub
WS_GetServerList.GetData RecvData
WS_GetServerList.Close
If LCase(Left(RecvData, 5)) = "����f" Then
UniqueKey = Mid(RecvData, 7, 4)
For i = 11 To Len(RecvData) Step 6
ReDim Preserve ServerList(UBound(ServerList) + 1)
ServerList(UBound(ServerList)).IP = CStr(Asc(Mid(RecvData, i, 1))) + "." + CStr(Asc(Mid(RecvData, i + 1, 1))) + "." + CStr(Asc(Mid(RecvData, i + 2, 1))) + "." + CStr(Asc(Mid(RecvData, i + 3, 1)))
ServerList(UBound(ServerList)).Port = Val(Hex2Dec(Hex(Asc(Mid(RecvData, i + 4, 1))) + Hex(Asc(Mid(RecvData, i + 5, 1)))))
If chkMax.Value = 1 And SCount >= Val(txtMax.Text) Then
UniqueKey = String(4, vbNullChar)
Exit For
End If
Next i
SCount = UBound(ServerList)
lblStatus.Caption = "Status: Downloading Server List (" & SCount & ")..."
Else
MsgBox "Bad master server response." & vbCrLf & vbCrLf & "Please try again later.", vbExclamation
lblStatus.Caption = "Status: Done."
End If
If Asc(Mid(UniqueKey, 1, 1)) + Asc(Mid(UniqueKey, 2, 1)) + Asc(Mid(UniqueKey, 3, 1)) + Asc(Mid(UniqueKey, 4, 1)) <> 0 Then
WS_GetServerList.SendData "1" & UniqueKey & IIf(cboGameType.Text <> "", "\gamedir\" + cboGameType.Text, "") & IIf(txtMap.Text <> "", "\map\" + txtMap.Text, "") & "\empty\1" & vbNullChar
Else
On Error Resume Next
bServersDone = True
MSTimeoutTimer.Enabled = False
If SCount = 0 Then
MsgBox "No servers received from master." & vbCrLf & vbCrLf & "Please change your filter settings and try again later.", vbExclamation
lblStatus.Caption = "Status: Done."
Label13.Caption = "0 Players Found"
StopVideo FindCompAnimateWnd
Exit Sub
End If
StartRefresh
End If
Exit Sub
ErrHandler:
MsgBox "An unknown error occurred while obtaining the server list." & vbCrLf & vbCrLf & "Please try again later.", vbExclamation
lblStatus.Caption = "Status: Done."
Label13.Caption = "0 Players Found"
End Sub
Private Sub WS_QueryServer_DataArrival(Index As Integer, ByVal bytesTotal As Long)
On Error Resume Next
Dim RecvData As String
Dim ServerPing As Long
Dim PlayerTotal As Integer
Dim PlayerID As Integer
Dim PlayerName As String
Dim PlayerFound As String
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
WS_QueryServer(Index).GetData RecvData
WS_QueryServer(Index).Close
TimeoutTimer(Index).Enabled = False
ServerPing = Abs(Round(Timer - LastTimer(Index), 3) * 1000)
i2 = 7
PlayerTotal = Asc(Mid(RecvData, 6, 1))
For i = 1 To PlayerTotal
PlayerID = Asc(Mid(RecvData, i2, 1))
i2 = i2 + 1
PlayerName = Mid(RecvData, i2, InStr(i2 + 1, RecvData, vbNullChar) - i2)
For i3 = chkEnable.LBound To chkEnable.UBound
If chkEnable(i3).Value = 1 Then
If chkUseWildcards(i3).Value = 1 Then
If LCase(PlayerName) Like LCase(txtPlayerName(i3).Text) Then
PlayerFound = PlayerName
Exit For
End If
Else
If InStr(LCase(PlayerName), LCase(txtPlayerName(i3).Text)) Then
PlayerFound = PlayerName
Exit For
End If
End If
End If
Next i3
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))
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)
PlayerTime = Format(lngHours, "00:") & Format(lngMins, "00:") & Format(lngSecs2, "00")
i2 = i2 + 4
If PlayerFound <> "" Then
If PlayerFrags > 512 Then PlayerFrags = -(1021 - PlayerFrags)
With LVPlayersFound.ListItems.Add()
.Text = WS_QueryServer(Index).RemoteHostIP & ":" & WS_QueryServer(Index).RemotePort
.SubItems(1) = ServerPing
.SubItems(2) = PlayerFound
.SubItems(3) = PlayerFrags
.SubItems(4) = PlayerTime
End With
PlayerFound = ""
End If
Next i
ServerIndex = ServerIndex + 1
If ServerIndex > UBound(ServerList) Then
lblStatus.Caption = "Status: Done."
Label13.Caption = LVPlayersFound.ListItems.Count & " Player" + IIf(LVPlayersFound.ListItems.Count <> 1, "s", "") + " Found"
lblTotal.Visible = False
lblLeft.Visible = False
Command5.Enabled = False
StopVideo FindCompAnimateWnd
If Optn_UnloadWSControls = 1 Then
Unload WS_QueryServer(Index)
Unload TimeoutTimer(Index)
End If
Exit Sub
End If
lblStatus.Caption = "Status: Refreshing " & ServerList(ServerIndex).IP & ":" & ServerList(ServerIndex).Port & "..."
TimeoutTimer(Index).Enabled = True
LastTimer(Index) = Timer
WS_QueryServer(Index).RemoteHost = ServerList(ServerIndex).IP
WS_QueryServer(Index).RemotePort = ServerList(ServerIndex).Port
lblLeft.Caption = "Servers Left: " & (UBound(ServerList) - ServerIndex) & " (" & (100 - Int((ServerIndex / UBound(ServerList)) * 100)) & "%)"
WS_QueryServer(Index).SendData "����players"
End Sub
Private Sub WS_RefreshServer_DataArrival(ByVal bytesTotal As Long)
On Error GoTo ErrHandler
Dim RecvData As String
Dim PlayerTotal As Integer
Dim PlayerID As Integer
Dim PlayerName As String
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
WS_RefreshServer.GetData RecvData
WS_RefreshServer.Close
i2 = 7
PlayerTotal = Asc(Mid(RecvData, 6, 1))
For i = 1 To PlayerTotal
PlayerID = Asc(Mid(RecvData, i2, 1))
i2 = i2 + 1
PlayerName = 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))
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)
PlayerTime = Format(lngHours, "00:") & Format(lngMins, "00:") & Format(lngSecs2, "00")
i2 = i2 + 4
If PlayerName = RefreshName Then
If PlayerFrags > 512 Then PlayerFrags = -(1021 - PlayerFrags)
With LVPlayersFound.ListItems(RefreshIndex)
.SubItems(1) = Abs(Round(Timer - RefreshTimer, 3) * 1000)
.SubItems(3) = PlayerFrags
.SubItems(4) = PlayerTime
End With
Exit Sub
End If
Next i
With LVPlayersFound.ListItems(RefreshIndex)
.SubItems(1) = Abs(Round(Timer - RefreshTimer, 3) * 1000)
.SubItems(3) = "-"
.SubItems(4) = "-"
End With
ErrHandler:
End Sub
Download QuickQuery HL Edition/PlayerSearchForm.frm