Find all our projects in development below.
All source code is GNU General Public License (GPL)
Browsing MainForm.frm (50.09 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 MainForm
BorderStyle = 1 'Fixed Single
Caption = "Player Search Half-Life Edition"
ClientHeight = 5535
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 = "MainForm.frx":0000
MaxButton = 0 'False
ScaleHeight = 5535
ScaleWidth = 9735
StartUpPosition = 2 'CenterScreen
Begin VB.CommandButton Command3
Caption = "Close"
Height = 375
Left = 120
TabIndex = 2
Top = 5055
Width = 1095
End
Begin VB.CommandButton Command2
Caption = "&Next >"
Default = -1 'True
Height = 375
Index = 1
Left = 8520
TabIndex = 0
Top = 5055
Width = 1095
End
Begin VB.CommandButton Command2
Caption = "< &Back"
Enabled = 0 'False
Height = 375
Index = 0
Left = 7320
TabIndex = 1
Top = 5055
Width = 1095
End
Begin VB.PictureBox PictureContainer
BorderStyle = 0 'None
BeginProperty Font
Name = "MS Sans Serif"
Size = 8.25
Charset = 0
Weight = 400
Underline = 0 'False
Italic = 0 'False
Strikethrough = 0 'False
EndProperty
Height = 4695
Index = 0
Left = 120
ScaleHeight = 4695
ScaleWidth = 9375
TabIndex = 30
TabStop = 0 'False
Top = 120
Width = 9375
Begin VB.PictureBox HLLogo
BackColor = &H00000000&
Height = 1190
Left = 7080
Picture = "MainForm.frx":030A
ScaleHeight = 1125
ScaleWidth = 2070
TabIndex = 48
TabStop = 0 'False
ToolTipText = "Half-Life"
Top = 3360
Width = 2130
End
Begin VB.Image AppLogo
Height = 480
Index = 0
Left = 8760
ToolTipText = "Player Search Half-Life Edition"
Top = 120
Width = 480
End
Begin VB.Label Label11
Caption = $"MainForm.frx":1285
Height = 615
Left = 120
TabIndex = 36
Top = 2280
Width = 4815
End
Begin VB.Label Label8
Caption = "Contact: jasonspc69@hotmail.com"
Height = 255
Left = 120
TabIndex = 35
Top = 1440
Width = 3615
End
Begin VB.Label Label5
Caption = "Copyright � 1999 - 2001 Jason's PC Software"
Height = 255
Left = 120
TabIndex = 34
Top = 1200
Width = 3615
End
Begin VB.Label Label6
Caption = "With this program you can search for online players playing Half-Life."
Height = 255
Left = 120
TabIndex = 33
Top = 480
Width = 6255
End
Begin VB.Label Label4
Caption = "Press Next to continue..."
BeginProperty Font
Name = "Tahoma"
Size = 8.25
Charset = 0
Weight = 700
Underline = 0 'False
Italic = 0 'False
Strikethrough = 0 'False
EndProperty
Height = 255
Left = 120
TabIndex = 32
Top = 4320
Width = 3615
End
Begin VB.Label Label1
AutoSize = -1 'True
Caption = "Welcome to Jason's PC Player Search Half-Life Edition v"
Height = 195
Left = 120
TabIndex = 31
Top = 120
Width = 3990
End
End
Begin VB.PictureBox PictureContainer
BorderStyle = 0 'None
Height = 4695
Index = 2
Left = 120
ScaleHeight = 4695
ScaleWidth = 9375
TabIndex = 42
TabStop = 0 'False
Top = 120
Width = 9375
Begin VB.CommandButton Command8
Caption = "P&ing Server"
Enabled = 0 'False
Height = 375
Left = 8160
Style = 1 'Graphical
TabIndex = 26
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
Style = 1 'Graphical
TabIndex = 28
ToolTipText = "Stop refreshing servers"
Top = 2760
Width = 1095
End
Begin VB.TextBox txtCopy
Height = 285
Left = 8160
TabIndex = 49
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
Style = 1 'Graphical
TabIndex = 25
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 = 29
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
Style = 1 'Graphical
TabIndex = 27
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
Style = 1 'Graphical
TabIndex = 24
ToolTipText = "View info about the server"
Top = 840
Width = 1095
End
Begin ComctlLib.ListView LVPlayersFound
Height = 3495
Left = 240
TabIndex = 23
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 = 6
BeginProperty ColumnHeader(1) {0713E8C7-850A-101B-AFC0-4210102A8DA7}
Key = ""
Object.Tag = ""
Text = "Server IP"
Object.Width = 2646
EndProperty
BeginProperty ColumnHeader(2) {0713E8C7-850A-101B-AFC0-4210102A8DA7}
SubItemIndex = 1
Key = ""
Object.Tag = ""
Text = "Port"
Object.Width = 706
EndProperty
BeginProperty ColumnHeader(3) {0713E8C7-850A-101B-AFC0-4210102A8DA7}
Alignment = 2
SubItemIndex = 2
Key = ""
Object.Tag = ""
Text = "Ping"
Object.Width = 706
EndProperty
BeginProperty ColumnHeader(4) {0713E8C7-850A-101B-AFC0-4210102A8DA7}
SubItemIndex = 3
Key = ""
Object.Tag = ""
Text = "Player Name"
Object.Width = 4322
EndProperty
BeginProperty ColumnHeader(5) {0713E8C7-850A-101B-AFC0-4210102A8DA7}
Alignment = 2
SubItemIndex = 4
Key = ""
Object.Tag = ""
Text = "Frags"
Object.Width = 706
EndProperty
BeginProperty ColumnHeader(6) {0713E8C7-850A-101B-AFC0-4210102A8DA7}
Alignment = 1
SubItemIndex = 5
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 VB.Image AppLogo
Height = 480
Index = 2
Left = 8760
ToolTipText = "Player Search Half-Life Edition"
Top = 120
Width = 480
End
Begin VB.Label Label17
Caption = "&Players Found:"
Height = 255
Left = 240
TabIndex = 22
Top = 600
Width = 1215
End
Begin VB.Label lblLeft
AutoSize = -1 'True
Caption = "Servers Left:"
Height = 195
Left = 6000
TabIndex = 46
Top = 4440
Visible = 0 'False
Width = 945
End
Begin VB.Label lblTotal
AutoSize = -1 'True
Caption = "Total Servers:"
Height = 195
Left = 3960
TabIndex = 45
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 = 44
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 = 43
Top = 120
Width = 5175
End
End
Begin VB.PictureBox PictureContainer
BorderStyle = 0 'None
Height = 4695
Index = 1
Left = 120
ScaleHeight = 4695
ScaleWidth = 9375
TabIndex = 37
TabStop = 0 'False
Top = 120
Width = 9375
Begin VB.Frame Frame4
Caption = "Filter"
Height = 735
Left = 240
TabIndex = 50
Top = 3840
Width = 9015
Begin VB.TextBox txtMap
Height = 315
Left = 6600
MaxLength = 50
TabIndex = 21
Top = 240
Width = 2175
End
Begin VB.ComboBox cboGameType
Height = 315
ItemData = "MainForm.frx":134A
Left = 1680
List = "MainForm.frx":135A
TabIndex = 19
Top = 240
Width = 2055
End
Begin VB.Label Label3
Caption = "Are running m&ap:"
Height = 255
Left = 5160
TabIndex = 20
Top = 300
Width = 1335
End
Begin VB.Label Label2
Caption = "Are running &game:"
Height = 255
Left = 240
TabIndex = 18
Top = 300
Width = 1455
End
End
Begin VB.Frame Frame3
Caption = "Half-Life Master Server Settings"
Height = 855
Left = 240
TabIndex = 47
Top = 2880
Width = 9015
Begin VB.CheckBox chkMax
Caption = "&Max amount of servers to download:"
Height = 255
Left = 4680
TabIndex = 16
Top = 400
Width = 3015
End
Begin VB.TextBox txtMax
Enabled = 0 'False
Height = 315
Left = 7800
MaxLength = 6
TabIndex = 17
Text = "5000"
Top = 360
Width = 975
End
Begin VB.ComboBox cboMaster
Height = 315
ItemData = "MainForm.frx":1378
Left = 720
List = "MainForm.frx":1385
TabIndex = 15
Text = "half-life.east.won.net:27010"
Top = 360
Width = 3015
End
Begin VB.Label Label18
Caption = "Us&e:"
Height = 255
Left = 240
TabIndex = 14
Top = 420
Width = 375
End
End
Begin VB.Frame Frame2
Caption = "Server Query Settings"
Height = 855
Left = 240
TabIndex = 39
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 = "80"
Top = 360
Width = 495
End
Begin VB.Label Label12
Caption = "(in milliseconds)"
Height = 255
Left = 7680
TabIndex = 41
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 = 40
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.Frame Frame1
Caption = "&Search For..."
Height = 1215
Left = 240
TabIndex = 3
Top = 600
Width = 9015
Begin VB.CheckBox chkEnable
Caption = "Check1"
Height = 255
Index = 1
Left = 240
TabIndex = 7
Top = 750
Width = 230
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 chkUseWildcards
Caption = "Use Wildcards"
Enabled = 0 'False
Height = 255
Index = 1
Left = 6720
TabIndex = 9
Top = 750
Width = 1935
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"
Height = 255
Index = 0
Left = 6720
TabIndex = 6
Top = 360
Width = 2055
End
Begin VB.TextBox txtPlayerName
Height = 315
Index = 0
Left = 600
TabIndex = 5
ToolTipText = "Player name"
Top = 360
Width = 5895
End
End
Begin VB.Image AppLogo
Height = 480
Index = 1
Left = 8760
ToolTipText = "Player Search Half-Life Edition"
Top = 120
Width = 480
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 = 38
Top = 120
Width = 7455
End
End
Begin VB.Line Line5
BorderColor = &H00808080&
X1 = 9600
X2 = 120
Y1 = 4920
Y2 = 4920
End
Begin VB.Line Line6
BorderColor = &H00FFFFFF&
X1 = 9600
X2 = 120
Y1 = 4935
Y2 = 4935
End
End
Attribute VB_Name = "MainForm"
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 Ver As String
Dim CurrentPic As Integer
Dim SCount As Long
Dim bServersDone As Boolean
Dim RefreshIndex As Long
Dim RefreshTimer As Single
Dim RefreshName As String
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 chkEnable_Click(Index As Integer)
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
Public Function Hex2Dec(ByVal sHex As String) As Long
Dim i As Integer
Dim nDec As Long
Const HexChar As String = "0123456789ABCDEF"
For i = Len(sHex) To 1 Step -1
nDec = nDec + (InStr(1, HexChar, Mid(sHex, i, 1)) - 1) * 16 ^ (Len(sHex) - i)
Next i
Hex2Dec = CStr(nDec)
End Function
Private Sub chkMax_Click()
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 Command1_Click()
LaunchForm.GetInfo LVPlayersFound.SelectedItem.Text, LVPlayersFound.SelectedItem.SubItems(1)
LaunchForm.Icon = LoadResPicture(Val(Command1.Tag), 1)
LaunchForm.Show 1
End Sub
Private Sub Command2_Click(Index As Integer)
On Error Resume Next
Dim i As Integer
Dim wsHost As String
Dim wsPort As Long
Dim WSDataToSend As String
If CurrentPic = 1 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 = 2 Then
Command2(1).Enabled = False
Else
Command2(1).Enabled = True
End If
SetPictureContainerIndex CurrentPic
Select Case CurrentPic
Case 1
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 2
ReDim LastTimer(Val(txtMaxConn.Text))
ReDim ServerList(0)
MousePointer = vbHourglass
ServerIndex = 0
For i = 1 To Val(txtMaxConn.Text)
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)
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
MousePointer = vbDefault
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(3)
WS_RefreshServer.Close
WS_RefreshServer.RemoteHost = LVPlayersFound.SelectedItem.Text
WS_RefreshServer.RemotePort = Val(LVPlayersFound.SelectedItem.SubItems(1))
WS_RefreshServer.SendData "����players"
End Sub
Private Sub Command5_Click()
MousePointer = vbHourglass
Command5.Enabled = False
lblStatus.Caption = "Status: Done."
Label13.Caption = LVPlayersFound.ListItems.Count & " Players Found"
lblTotal.Visible = False
lblLeft.Visible = False
For i = WS_QueryServer.UBound To 1 Step -1
Unload WS_QueryServer(i)
Unload TimeoutTimer(i)
Next i
MousePointer = vbDefault
End Sub
Private Sub Command6_Click()
Dim NewInfoForm As New InfoForm
NewInfoForm.GetInfo LVPlayersFound.SelectedItem.Text, LVPlayersFound.SelectedItem.SubItems(1)
NewInfoForm.Show
End Sub
Private Sub Command7_Click()
txtCopy.Text = LVPlayersFound.SelectedItem.Text & ":" & LVPlayersFound.SelectedItem.SubItems(1)
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(LVPlayersFound.SelectedItem.Text, iStatCode, sStatMsg)
If iStatCode = 0 Then
LVPlayersFound.SelectedItem.SubItems(2) = RetVal
ElseIf iStatCode = 11010 Then
LVPlayersFound.SelectedItem.SubItems(2) = "9999"
ElseIf iStatCode <> -1 Then
MsgBox "Ping error: " + sStatMsg, vbExclamation
End If
End Sub
Private Sub Form_Load()
Dim i As Integer
Dim sRegData As String
Dim lRegData As Long
Dim bRegErr As Boolean
Ver = App.Major & "." & App.Minor & IIf(App.Revision = 0, "", "." & App.Revision)
CurrentPic = 0
SetPictureContainerIndex CurrentPic
Label1.Caption = Label1.Caption + Ver
LV_FullRowSelect LVPlayersFound
CButton Command6
CButton Command4
CButton Command8
CButton Command7
CButton Command5
Command1.DisabledPicture = LoadResPicture(2, 1)
For i = AppLogo.LBound To AppLogo.UBound
AppLogo(i).Picture = LoadResPicture(1, 1)
Next i
lRegData = Val(GetRegString(HKEY_LOCAL_MACHINE, RegAppRoot, "EnableSearch[2]", bRegErr))
If (lRegData <> 0 And lRegData <> 1) Or bRegErr Then lRegData = 0
chkEnable(1).Value = lRegData
lRegData = Val(GetRegString(HKEY_LOCAL_MACHINE, RegAppRoot, "UseWildcards[1]", bRegErr))
If (lRegData <> 0 And lRegData <> 1) Or bRegErr Then lRegData = 0
chkUseWildcards(0).Value = lRegData
lRegData = Val(GetRegString(HKEY_LOCAL_MACHINE, RegAppRoot, "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, RegAppRoot, "PlayerName[1]")
txtPlayerName(1).Text = GetRegString(HKEY_LOCAL_MACHINE, RegAppRoot, "PlayerName[2]")
lRegData = Val(GetRegString(HKEY_LOCAL_MACHINE, RegAppRoot, "MaxConnections", bRegErr))
If (lRegData < 1 And lRegData > 99) Or bRegErr Then lRegData = 80
txtMaxConn.Text = lRegData
lRegData = Val(GetRegString(HKEY_LOCAL_MACHINE, RegAppRoot, "QueryTimeout", bRegErr))
If (lRegData < 1 And lRegData > 99999) Or bRegErr Then lRegData = 1000
txtTimeout.Text = lRegData
cboMaster.Text = GetRegString(HKEY_LOCAL_MACHINE, RegAppRoot, "MasterServer")
If cboMaster.Text = "" Then cboMaster.Text = "half-life.east.won.net:27010"
lRegData = Val(GetRegString(HKEY_LOCAL_MACHINE, RegAppRoot, "EnableMaxServers", bRegErr))
If (lRegData <> 0 And lRegData <> 1) Or bRegErr Then lRegData = 0
chkMax.Value = lRegData
lRegData = Val(GetRegString(HKEY_LOCAL_MACHINE, RegAppRoot, "MaxServerAmount", bRegErr))
If (lRegData < 1 And lRegData > 999999) Or bRegErr Then lRegData = 5000
txtMax.Text = lRegData
cboGameType.Text = GetRegString(HKEY_LOCAL_MACHINE, RegAppRoot, "GameFilter")
txtMap.Text = GetRegString(HKEY_LOCAL_MACHINE, RegAppRoot, "MapFilter")
ExecutablePath = GetRegString(HKEY_LOCAL_MACHINE, RegAppRoot, "ExecutablePath")
If ExecutablePath = "" Then ExecutablePath = "C:\SIERRA\Half-Life\hl.exe"
End Sub
Private Sub Form_QueryUnload(Cancel As Integer, UnloadMode As Integer)
If UnloadMode < 2 Then
SaveRegString HKEY_LOCAL_MACHINE, RegAppRoot, "EnableSearch[2]", CStr(chkEnable(1).Value)
SaveRegString HKEY_LOCAL_MACHINE, RegAppRoot, "UseWildcards[1]", CStr(chkUseWildcards(0).Value)
SaveRegString HKEY_LOCAL_MACHINE, RegAppRoot, "UseWildcards[2]", CStr(chkUseWildcards(1).Value)
SaveRegString HKEY_LOCAL_MACHINE, RegAppRoot, "PlayerName[1]", txtPlayerName(0).Text
SaveRegString HKEY_LOCAL_MACHINE, RegAppRoot, "PlayerName[2]", txtPlayerName(1).Text
SaveRegString HKEY_LOCAL_MACHINE, RegAppRoot, "MaxConnections", txtMaxConn.Text
SaveRegString HKEY_LOCAL_MACHINE, RegAppRoot, "QueryTimeout", txtTimeout.Text
SaveRegString HKEY_LOCAL_MACHINE, RegAppRoot, "MasterServer", cboMaster.Text
SaveRegString HKEY_LOCAL_MACHINE, RegAppRoot, "EnableMaxServers", CStr(chkMax.Value)
SaveRegString HKEY_LOCAL_MACHINE, RegAppRoot, "MaxServerAmount", txtMax.Text
SaveRegString HKEY_LOCAL_MACHINE, RegAppRoot, "GameFilter", cboGameType.Text
SaveRegString HKEY_LOCAL_MACHINE, RegAppRoot, "MapFilter", txtMap.Text
SaveRegString HKEY_LOCAL_MACHINE, RegAppRoot, "ExecutablePath", ExecutablePath
End If
End Sub
Private Sub Form_Unload(Cancel As Integer)
End
End Sub
Private Sub GameInfoTimer_Timer()
GameInfoTimer.Enabled = False
WS_GameInfo.Close
Command1.Picture = 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 Command6.Enabled Then Command4_Click
End Sub
Private Sub LVPlayersFound_ItemClick(ByVal Item As ComctlLib.ListItem)
Command6.Enabled = True
Command4.Enabled = True
Command8.Enabled = True
Command7.Enabled = True
If lblTotal.Visible Then Command5.Enabled = True
If Command1.Enabled = False Then Command1.Enabled = True
If WS_GameInfo.RemoteHostIP <> LVPlayersFound.SelectedItem.Text Or _
WS_GameInfo.RemotePort <> Val(LVPlayersFound.SelectedItem.SubItems(1)) Then
Command1.Picture = LoadResPicture(9, 1)
Command1.Tag = "3"
GameInfoTimer.Enabled = False
GameInfoTimer.Enabled = True
WS_GameInfo.Close
WS_GameInfo.RemoteHost = LVPlayersFound.SelectedItem.Text
WS_GameInfo.RemotePort = Val(LVPlayersFound.SelectedItem.SubItems(1))
WS_GameInfo.SendData "����info"
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"
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 & " Players Found"
lblTotal.Visible = False
lblLeft.Visible = False
Command5.Enabled = False
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 "tfc"
Command1.Picture = LoadResPicture(4, 1)
Command1.Tag = "4"
Case "cstrike"
Command1.Picture = LoadResPicture(5, 1)
Command1.Tag = "6"
Case "dmc"
Command1.Picture = LoadResPicture(7, 1)
Command1.Tag = "8"
Case Else
Command1.Picture = LoadResPicture(2, 1)
End Select
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)))))
SCount = SCount + 1
lblStatus.Caption = "Status: Downloading Server List (" & SCount & ")..."
If chkMax.Value = 1 And SCount >= Val(txtMax.Text) Then
UniqueKey = String(4, vbNullChar)
Exit For
End If
DoEvents
Next i
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 try again later.", vbExclamation
lblStatus.Caption = "Status: Done."
Label13.Caption = "0 Players Found"
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
If chkMax.Value = 1 And ServerIndex > Val(txtMax.Text) Then Exit For
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 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 Integer
Dim PlayerTotal As Integer
Dim PlayerID As Integer
Dim PlayerName As String
Dim PlayerFound As String
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
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 = 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
If PlayerFound <> "" Then
If PlayerFrags > 512 Then PlayerFrags = -(1021 - PlayerFrags)
With LVPlayersFound.ListItems.Add()
.Text = WS_QueryServer(Index).RemoteHostIP
.SubItems(1) = WS_QueryServer(Index).RemotePort
.SubItems(2) = ServerPing
.SubItems(3) = PlayerFound
.SubItems(4) = PlayerFrags
lngHours = Fix(PlayerTime / 3600)
lngSecs = PlayerTime - (lngHours * 3600)
lngMins = Fix(lngSecs / 60)
lngSecs2 = lngSecs - (lngMins * 60)
.SubItems(5) = Format(lngHours, "00:") & Format(lngMins, "00:") & Format(lngSecs2, "00")
End With
PlayerFound = ""
End If
Next i
ServerIndex = ServerIndex + 1
If ServerIndex > UBound(ServerList) Then
lblStatus.Caption = "Status: Done."
Label13.Caption = LVPlayersFound.ListItems.Count & " Players Found"
lblTotal.Visible = False
lblLeft.Visible = False
Command5.Enabled = False
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 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_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 = 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
If PlayerName = RefreshName Then
If PlayerFrags > 512 Then PlayerFrags = -(1021 - PlayerFrags)
With LVPlayersFound.ListItems(RefreshIndex)
.SubItems(2) = Abs(Round(Timer - RefreshTimer, 3) * 1000)
.SubItems(4) = PlayerFrags
lngHours = Fix(PlayerTime / 3600)
lngSecs = PlayerTime - (lngHours * 3600)
lngMins = Fix(lngSecs / 60)
lngSecs2 = lngSecs - (lngMins * 60)
.SubItems(5) = Format(lngHours, "00:") & Format(lngMins, "00:") & Format(lngSecs2, "00")
End With
Exit Sub
End If
Next i
With LVPlayersFound.ListItems(RefreshIndex)
.SubItems(2) = Abs(Round(Timer - RefreshTimer, 3) * 1000)
.SubItems(4) = "-"
.SubItems(5) = "-"
End With
ErrHandler:
End Sub