Find all our projects in development below.
All source code is GNU General Public License (GPL)
Browsing MainForm.frm (54.34 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 Quake 3 Arena 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 RA3Logo
BackColor = &H00000000&
Height = 975
Left = 8080
Picture = "MainForm.frx":030A
ScaleHeight = 915
ScaleWidth = 1215
TabIndex = 51
TabStop = 0 'False
ToolTipText = "Rocket Arena 3"
Top = 2160
Width = 1270
End
Begin VB.PictureBox Q3Logo
BackColor = &H00000000&
Height = 1240
Left = 7800
Picture = "MainForm.frx":0EB7
ScaleHeight = 1185
ScaleWidth = 1500
TabIndex = 48
TabStop = 0 'False
ToolTipText = "Quake 3 Arena"
Top = 3240
Width = 1560
End
Begin VB.Image AppLogo
Height = 480
Index = 0
Left = 8760
ToolTipText = "Player Search Quake 3 Arena Edition"
Top = 120
Width = 480
End
Begin VB.Label Label11
Caption = $"MainForm.frx":16AC
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 Quake 3 Arena and Rocket Arena 3."
Height = 255
Left = 120
TabIndex = 33
Top = 480
Width = 7215
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 Quake 3 Arena Edition v"
Height = 195
Left = 120
TabIndex = 31
Top = 120
Width = 4470
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.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 = 8160
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 the 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
Picture = "MainForm.frx":1771
Style = 1 'Graphical
TabIndex = 29
ToolTipText = "Launch Quake 3 Arena and connect to selected ip address"
Top = 3480
Width = 1095
End
Begin VB.Timer MSTimeoutTimer
Enabled = 0 'False
Interval = 1000
Left = 6720
Top = 0
End
Begin VB.Timer TimeoutTimer
Enabled = 0 'False
Index = 0
Interval = 1000
Left = 7680
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 = 9
BeginProperty ColumnHeader(1) {0713E8C7-850A-101B-AFC0-4210102A8DA7}
Key = ""
Object.Tag = ""
Text = "Server IP"
Object.Width = 2381
EndProperty
BeginProperty ColumnHeader(2) {0713E8C7-850A-101B-AFC0-4210102A8DA7}
SubItemIndex = 1
Key = ""
Object.Tag = ""
Text = "Port"
Object.Width = 617
EndProperty
BeginProperty ColumnHeader(3) {0713E8C7-850A-101B-AFC0-4210102A8DA7}
Alignment = 2
SubItemIndex = 2
Key = ""
Object.Tag = ""
Text = "Ping"
Object.Width = 441
EndProperty
BeginProperty ColumnHeader(4) {0713E8C7-850A-101B-AFC0-4210102A8DA7}
SubItemIndex = 3
Key = ""
Object.Tag = ""
Text = "Game"
Object.Width = 882
EndProperty
BeginProperty ColumnHeader(5) {0713E8C7-850A-101B-AFC0-4210102A8DA7}
SubItemIndex = 4
Key = ""
Object.Tag = ""
Text = "Map"
Object.Width = 882
EndProperty
BeginProperty ColumnHeader(6) {0713E8C7-850A-101B-AFC0-4210102A8DA7}
SubItemIndex = 5
Key = ""
Object.Tag = ""
Text = "Players"
Object.Width = 741
EndProperty
BeginProperty ColumnHeader(7) {0713E8C7-850A-101B-AFC0-4210102A8DA7}
SubItemIndex = 6
Key = ""
Object.Tag = ""
Text = "Player Name"
Object.Width = 1729
EndProperty
BeginProperty ColumnHeader(8) {0713E8C7-850A-101B-AFC0-4210102A8DA7}
Alignment = 2
SubItemIndex = 7
Key = ""
Object.Tag = ""
Text = "Frags"
Object.Width = 617
EndProperty
BeginProperty ColumnHeader(9) {0713E8C7-850A-101B-AFC0-4210102A8DA7}
Alignment = 1
SubItemIndex = 8
Key = ""
Object.Tag = ""
Text = "Ping"
Object.Width = 441
EndProperty
End
Begin MSWinsockLib.Winsock WS_QueryServer
Index = 0
Left = 7200
Top = 0
_ExtentX = 741
_ExtentY = 741
_Version = 393216
Protocol = 1
End
Begin MSWinsockLib.Winsock WS_GetServerList
Left = 6240
Top = 0
_ExtentX = 741
_ExtentY = 741
_Version = 393216
Protocol = 1
End
Begin ComctlLib.ImageList LVImgList
Left = 5520
Top = 0
_ExtentX = 1005
_ExtentY = 1005
BackColor = -2147483643
MaskColor = 12632256
_Version = 327682
End
Begin VB.Image AppLogo
Height = 480
Index = 2
Left = 8760
ToolTipText = "Player Search Quake 3 Arena 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 = "Other Settings"
Height = 735
Left = 240
TabIndex = 50
Top = 3840
Width = 9015
Begin VB.TextBox txtMTimeout
Height = 315
Left = 6960
MaxLength = 5
TabIndex = 21
Text = "3000"
Top = 240
Width = 615
End
Begin VB.TextBox txtProtocol
Height = 315
Left = 2760
MaxLength = 4
TabIndex = 19
Text = "66"
Top = 240
Width = 735
End
Begin VB.Label Label14
Caption = "(in milliseconds)"
Height = 255
Left = 7680
TabIndex = 52
Top = 300
Width = 1215
End
Begin VB.Label Label3
Caption = "Mas&ter server response timeout:"
Height = 255
Left = 4440
TabIndex = 20
Top = 300
Width = 2415
End
Begin VB.Label Label2
Caption = "Qu&ake 3 Query Protocol Version:"
Height = 255
Left = 240
TabIndex = 18
Top = 300
Width = 2415
End
End
Begin VB.Frame Frame3
Caption = "Quake 3 Arena 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 = "1000"
Top = 360
Width = 975
End
Begin VB.ComboBox cboMaster
Height = 315
ItemData = "MainForm.frx":1BB3
Left = 720
List = "MainForm.frx":1BBD
TabIndex = 15
Text = "master.quake3arena.com:27950"
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 Quake 3 Arena 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 Q3_SERVER
IP As String
Port As Long
End Type
Dim ServerList() As Q3_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
Dim bItemClicked As Boolean
Sub BeginQueries()
On Error Resume Next
WS_GetServerList.Close
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
Command5.Enabled = 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 "����getstatus xxx"
Next i
End Sub
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()
If LVPlayersFound.SelectedItem.SmallIcon = 2 Then MsgBox "Note: Your ping does not meet the server's requirements." + vbCrLf + vbCrLf + "You may not be able to join.", vbInformation
If LVPlayersFound.SelectedItem.SmallIcon = 3 Then MsgBox "Note: This server requires a password to join." + vbCrLf + vbCrLf + "You may not be able to join.", vbInformation
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 = "1000"
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 Val(txtProtocol.Text) < 1 Then
MsgBox "Please enter a number greater than zero.", vbExclamation
txtProtocol.SetFocus
txtProtocol.Text = "66"
txtProtocol.SelStart = 0
txtProtocol.SelLength = Len(txtProtocol.Text)
Exit Sub
End If
If Val(txtMTimeout.Text) < 1 Then
MsgBox "Please enter a number greater than zero.", vbExclamation
txtMTimeout.SetFocus
txtMTimeout.Text = "3000"
txtMTimeout.SelStart = 0
txtMTimeout.SelLength = Len(txtMTimeout.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
bServersDone = True
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
MSTimeoutTimer.Interval = Val(txtMTimeout.Text)
MSTimeoutTimer.Enabled = True
WS_GetServerList.Close
wsHost = cboMaster.Text
wsPort = 27950
If InStr(wsHost, ":") > 0 Then
wsPort = Val(Mid(wsHost, InStr(wsHost, ":") + 1))
wsHost = Left(wsHost, InStr(wsHost, ":") - 1)
If wsPort = 0 Then wsPort = 27950
End If
WS_GetServerList.RemoteHost = wsHost
WS_GetServerList.RemotePort = wsPort
WSDataToSend = "����getservers " + txtProtocol.Text + " full"
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(6)
WS_RefreshServer.Close
WS_RefreshServer.RemoteHost = LVPlayersFound.SelectedItem.Text
WS_RefreshServer.RemotePort = Val(LVPlayersFound.SelectedItem.SubItems(1))
WS_RefreshServer.SendData "����getstatus xxx"
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
For i = AppLogo.LBound To AppLogo.UBound
AppLogo(i).Picture = LoadResPicture(1, 1)
Next i
LVImgList.ImageWidth = 16
LVImgList.ImageHeight = 16
LVImgList.ListImages.Add , , LoadResPicture(100, 1)
LVImgList.ListImages.Add , , LoadResPicture(101, 1)
LVImgList.ListImages.Add , , LoadResPicture(102, 1)
LVPlayersFound.SmallIcons = LVImgList
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 = "master.quake3arena.com:27950"
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 = 1000
txtMax.Text = lRegData
lRegData = Val(GetRegString(HKEY_LOCAL_MACHINE, RegAppRoot, "ProtocolVersion", bRegErr))
If (lRegData < 1 And lRegData > 9999) Or bRegErr Then lRegData = 66
txtProtocol.Text = lRegData
lRegData = Val(GetRegString(HKEY_LOCAL_MACHINE, RegAppRoot, "MasterResponseTimeout", bRegErr))
If (lRegData < 1 And lRegData > 99999) Or bRegErr Then lRegData = 3000
txtMTimeout.Text = lRegData
ExecutablePath = GetRegString(HKEY_LOCAL_MACHINE, RegAppRoot, "ExecutablePath")
If ExecutablePath = "" Then ExecutablePath = "C:\Quake III Arena\Quake3.exe"
CreateQ3ColorArray
SubClassListViewParentWnd PictureContainer(2).hWnd, Me, LVPlayersFound, 6
End Sub
Private Sub Form_QueryUnload(Cancel As Integer, UnloadMode As Integer)
Dim i As Long
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, "ProtocolVersion", txtProtocol.Text
SaveRegString HKEY_LOCAL_MACHINE, RegAppRoot, "MasterResponseTimeout", txtMTimeout.Text
SaveRegString HKEY_LOCAL_MACHINE, RegAppRoot, "ExecutablePath", ExecutablePath
End If
For i = (Forms.Count - 1) To 1 Step -1
Unload Forms(i)
Next i
End Sub
Private Sub Form_Unload(Cancel As Integer)
UnSubClassListViewParentWnd PictureContainer(2).hWnd
End
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 Command1.Enabled = False Then Command1.Enabled = True
LVGotFocus PictureContainer(2).hWnd
LVPlayersFound.Refresh
bItemClicked = True
End Sub
Private Sub LVPlayersFound_LostFocus()
LVLostFocus PictureContainer(2).hWnd
LVPlayersFound.Refresh
End Sub
Private Sub LVPlayersFound_MouseDown(Button As Integer, Shift As Integer, x As Single, y As Single)
If Button = vbLeftButton Then
If Not bItemClicked Then
LVNoFocus PictureContainer(2).hWnd
LVPlayersFound.Refresh
Else
bItemClicked = False
End If
End If
End Sub
Private Sub LVPlayersFound_MouseUp(Button As Integer, Shift As Integer, x As Single, y As Single)
If Button = vbLeftButton Then
bItemClicked = False
If Not (LVPlayersFound.SelectedItem Is Nothing) Then
If Not LVPlayersFound.SelectedItem.Selected Then LVPlayersFound.Refresh
End If
End If
End Sub
Private Sub MSTimeoutTimer_Timer()
MSTimeoutTimer.Enabled = False
BeginQueries
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 "����getstatus xxx"
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 txtMTimeout_KeyPress(KeyAscii As Integer)
If KeyAscii >= 48 And KeyAscii <= 57 Or KeyAscii = 8 Then Exit Sub
KeyAscii = 0
End Sub
Private Sub txtMTimeout_LostFocus()
txtMTimeout.Text = Val(txtMTimeout.Text)
End Sub
Private Sub txtProtocol_KeyPress(KeyAscii As Integer)
If KeyAscii >= 48 And KeyAscii <= 57 Or KeyAscii = 8 Then Exit Sub
KeyAscii = 0
End Sub
Private Sub txtProtocol_LostFocus()
txtProtocol.Text = Val(txtProtocol.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_GetServerList_DataArrival(ByVal bytesTotal As Long)
On Error GoTo ErrHandler
Dim RecvData As String
Dim IPArray() As String
Dim i As Long
If bServersDone Then Exit Sub
WS_GetServerList.GetData RecvData
If LCase(Left(RecvData, 22)) = "����getserversresponse" Then
MSTimeoutTimer.Enabled = False
RecvData = Mid(RecvData, 24)
IPArray = Split(RecvData, "\")
For i = 0 To UBound(IPArray)
If Len(IPArray(i)) = 6 Then
ReDim Preserve ServerList(UBound(ServerList) + 1)
ServerList(UBound(ServerList)).IP = CStr(Asc(Mid(IPArray(i), 1, 1))) + "." + CStr(Asc(Mid(IPArray(i), 2, 1))) + "." + CStr(Asc(Mid(IPArray(i), 3, 1))) + "." + CStr(Asc(Mid(IPArray(i), 4, 1)))
ServerList(UBound(ServerList)).Port = Val(Hex2Dec(Hex(Asc(Mid(IPArray(i), 5, 1))) + Hex(Asc(Mid(IPArray(i), 6, 1)))))
SCount = SCount + 1
lblStatus.Caption = "Status: Downloading Server List (" & SCount & ")..."
If chkMax.Value = 1 And SCount >= Val(txtMax.Text) Then
WS_GetServerList.Close
bServersDone = True
BeginQueries
Exit Sub
End If
DoEvents
End If
Next i
MSTimeoutTimer.Enabled = True
Else
WS_GetServerList.Close
MSTimeoutTimer.Enabled = False
bServersDone = True
MsgBox "Bad master server response." & vbCrLf & vbCrLf & "Please try again later.", vbExclamation
lblStatus.Caption = "Status: Done."
End If
Exit Sub
ErrHandler:
WS_GetServerList.Close
MSTimeoutTimer.Enabled = False
bServersDone = True
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 Settings() As String
Dim TmpStr As String
Dim PlayerArray() As String
Dim PlayerCount As Integer
Dim OldPlayerName As String
Dim PlayerName As String
Dim PlayerFrags As Long
Dim PlayerPing As Long
Dim PlayerFound As String
Dim GameName As String
Dim MapName As String
Dim MaxClients As Long
Dim MinPing As Integer
Dim MaxPing As Integer
Dim NeedPass As Integer
Dim i As Integer
Dim i2 As Integer
WS_QueryServer(Index).GetData RecvData
WS_QueryServer(Index).Close
TimeoutTimer(Index).Enabled = False
ServerPing = Abs(Round(Timer - LastTimer(Index), 3) * 1000)
RecvData = Mid(RecvData, InStr(RecvData, vbLf) + 2)
TmpStr = Mid(RecvData, InStr(RecvData, vbLf) + 1)
RecvData = Left(RecvData, InStr(RecvData, vbLf) - 1)
Settings = Split(RecvData, "\")
PlayerArray = Split(TmpStr, vbLf)
PlayerCount = UBound(PlayerArray)
If Err.Number Or PlayerCount < 0 Then PlayerCount = 0
For i = 0 To UBound(Settings) Step 2
If Settings(i) = "gamename" Then GameName = Settings(i + 1)
If Settings(i) = "mapname" Then MapName = Settings(i + 1)
If LCase(Settings(i)) = "sv_maxclients" Then MaxClients = Val(Settings(i + 1))
If LCase(Settings(i)) = "sv_minping" Then MinPing = Val(Settings(i + 1))
If LCase(Settings(i)) = "sv_maxping" Then MaxPing = Val(Settings(i + 1))
If LCase(Settings(i)) = "g_needpass" Then NeedPass = Val(Settings(i + 1))
Next i
If PlayerCount > 0 Then
For i = 0 To UBound(PlayerArray) - 1
OldPlayerName = Mid(PlayerArray(i), InStr(PlayerArray(i), """") + 1, InStrRev(PlayerArray(i), """") - InStr(PlayerArray(i), """") - 1)
PlayerName = StripQ3Colors(OldPlayerName)
PlayerFrags = Trim(Left(PlayerArray(i), InStr(PlayerArray(i), " ") - 1))
PlayerPing = CStr(Val(Mid(PlayerArray(i), InStr(PlayerArray(i), " ") + 1)))
For i2 = chkEnable.LBound To chkEnable.UBound
If chkEnable(i2).Value = 1 Then
If chkUseWildcards(i2).Value = 1 Then
If LCase(PlayerName) Like LCase(txtPlayerName(i2).Text) Then
PlayerFound = PlayerName
Exit For
End If
Else
If InStr(LCase(PlayerName), LCase(txtPlayerName(i2).Text)) Then
PlayerFound = PlayerName
Exit For
End If
End If
End If
Next i2
If PlayerFound <> "" Then
With LVPlayersFound.ListItems.Add()
If MinPing > 0 And ServerPing < MinPing Then
.SmallIcon = 2
ElseIf MaxPing > 0 And ServerPing > MaxPing Then
.SmallIcon = 2
ElseIf NeedPass <> 0 Then
.SmallIcon = 3
Else
.SmallIcon = 1
End If
.Text = WS_QueryServer(Index).RemoteHostIP
.SubItems(1) = WS_QueryServer(Index).RemotePort
.SubItems(2) = ServerPing
.SubItems(3) = GameName
.SubItems(4) = MapName
.SubItems(5) = PlayerCount & "/" & MaxClients
.SubItems(6) = PlayerFound
.SubItems(7) = PlayerFrags
.SubItems(8) = PlayerPing
.Tag = OldPlayerName
End With
PlayerFound = ""
End If
Next i
End If
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 "����getstatus xxx"
End Sub
Private Sub WS_RefreshServer_DataArrival(ByVal bytesTotal As Long)
On Error Resume Next
Dim RecvData As String
Dim ServerPing As Integer
Dim Settings() As String
Dim TmpStr As String
Dim PlayerArray() As String
Dim PlayerCount As Integer
Dim PlayerName As String
Dim PlayerFrags As Long
Dim PlayerPing As Long
Dim GameName As String
Dim MapName As String
Dim MaxClients As Long
Dim MinPing As Integer
Dim MaxPing As Integer
Dim NeedPass As Integer
Dim i As Integer
WS_RefreshServer.GetData RecvData
WS_RefreshServer.Close
ServerPing = Abs(Round(Timer - RefreshTimer, 3) * 1000)
RecvData = Mid(RecvData, InStr(RecvData, vbLf) + 2)
TmpStr = Mid(RecvData, InStr(RecvData, vbLf) + 1)
RecvData = Left(RecvData, InStr(RecvData, vbLf) - 1)
Settings = Split(RecvData, "\")
PlayerArray = Split(TmpStr, vbLf)
PlayerCount = UBound(PlayerArray)
If Err.Number Or PlayerCount < 0 Then PlayerCount = 0
For i = 0 To UBound(Settings) Step 2
If Settings(i) = "gamename" Then GameName = Settings(i + 1)
If Settings(i) = "mapname" Then MapName = Settings(i + 1)
If LCase(Settings(i)) = "sv_maxclients" Then MaxClients = Val(Settings(i + 1))
If LCase(Settings(i)) = "sv_minping" Then MinPing = Val(Settings(i + 1))
If LCase(Settings(i)) = "sv_maxping" Then MaxPing = Val(Settings(i + 1))
If LCase(Settings(i)) = "g_needpass" Then NeedPass = Val(Settings(i + 1))
Next i
If PlayerCount > 0 Then
For i = 0 To UBound(PlayerArray) - 1
PlayerName = StripQ3Colors(Mid(PlayerArray(i), InStr(PlayerArray(i), """") + 1, InStrRev(PlayerArray(i), """") - InStr(PlayerArray(i), """") - 1))
PlayerFrags = Trim(Left(PlayerArray(i), InStr(PlayerArray(i), " ") - 1))
PlayerPing = CStr(Val(Mid(PlayerArray(i), InStr(PlayerArray(i), " ") + 1)))
If PlayerName = RefreshName Then
With LVPlayersFound.ListItems(RefreshIndex)
If MinPing > 0 And ServerPing < MinPing Then
.SmallIcon = 2
ElseIf MaxPing > 0 And ServerPing > MaxPing Then
.SmallIcon = 2
ElseIf NeedPass <> 0 Then
.SmallIcon = 3
Else
.SmallIcon = 1
End If
.SubItems(2) = ServerPing
.SubItems(3) = GameName
.SubItems(4) = MapName
.SubItems(5) = PlayerCount & "/" & MaxClients
.SubItems(7) = PlayerFrags
.SubItems(8) = PlayerPing
End With
Exit Sub
End If
Next i
End If
With LVPlayersFound.ListItems(RefreshIndex)
If MinPing > 0 And ServerPing < MinPing Then
.SmallIcon = 2
ElseIf MaxPing > 0 And ServerPing > MaxPing Then
.SmallIcon = 2
ElseIf NeedPass <> 0 Then
.SmallIcon = 3
Else
.SmallIcon = 1
End If
.SubItems(2) = ServerPing
.SubItems(3) = GameName
.SubItems(4) = MapName
.SubItems(5) = PlayerCount & "/" & MaxClients
.SubItems(7) = "-"
.SubItems(8) = "-"
End With
End Sub