Find all our projects in development below.
All source code is GNU General Public License (GPL)
Browsing QuickQuery HL Edition/MainForm.frm (101.07 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
Caption = "QuickQuery Half-Life Edition"
ClientHeight = 5520
ClientLeft = 60
ClientTop = 630
ClientWidth = 8295
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
ScaleHeight = 5520
ScaleWidth = 8295
StartUpPosition = 2 'CenterScreen
Begin VB.Timer ShowRegFormTimer
Enabled = 0 'False
Interval = 1
Left = 600
Top = 840
End
Begin ComctlLib.StatusBar SBar
Align = 2 'Align Bottom
Height = 255
Left = 0
TabIndex = 4
Top = 5265
Width = 8295
_ExtentX = 14631
_ExtentY = 450
SimpleText = ""
_Version = 327682
BeginProperty Panels {0713E89E-850A-101B-AFC0-4210102A8DA7}
NumPanels = 4
BeginProperty Panel1 {0713E89F-850A-101B-AFC0-4210102A8DA7}
AutoSize = 1
Object.Width = 5741
Text = "0 Servers (Click Here to Update)"
TextSave = "0 Servers (Click Here to Update)"
Object.Tag = ""
EndProperty
BeginProperty Panel2 {0713E89F-850A-101B-AFC0-4210102A8DA7}
AutoSize = 1
Object.Width = 5741
Text = "0 Players Online"
TextSave = "0 Players Online"
Object.Tag = ""
EndProperty
BeginProperty Panel3 {0713E89F-850A-101B-AFC0-4210102A8DA7}
AutoSize = 2
Object.Visible = 0 'False
Text = "Cancel"
TextSave = "Cancel"
Object.Tag = ""
EndProperty
BeginProperty Panel4 {0713E89F-850A-101B-AFC0-4210102A8DA7}
AutoSize = 2
Text = "0 Filters In Use"
TextSave = "0 Filters In Use"
Object.Tag = ""
EndProperty
EndProperty
End
Begin ComctlLib.ListView LVRules
Height = 1380
Left = 5040
TabIndex = 7
Top = 3900
Width = 3255
_ExtentX = 5741
_ExtentY = 2434
View = 3
LabelEdit = 1
LabelWrap = -1 'True
HideSelection = -1 'True
_Version = 327682
ForeColor = -2147483640
BackColor = -2147483643
BorderStyle = 1
Appearance = 1
NumItems = 2
BeginProperty ColumnHeader(1) {0713E8C7-850A-101B-AFC0-4210102A8DA7}
Key = ""
Object.Tag = ""
Text = "Rule"
Object.Width = 2646
EndProperty
BeginProperty ColumnHeader(2) {0713E8C7-850A-101B-AFC0-4210102A8DA7}
SubItemIndex = 1
Key = ""
Object.Tag = ""
Text = "Value"
Object.Width = 1764
EndProperty
End
Begin VB.Timer PostLoadTimer
Enabled = 0 'False
Interval = 1
Left = 120
Top = 840
End
Begin VB.TextBox txtCopy
Height = 285
Left = 120
MultiLine = -1 'True
TabIndex = 5
TabStop = 0 'False
Top = 480
Visible = 0 'False
Width = 735
End
Begin MSWinsockLib.Winsock WS_Rules
Left = 3000
Top = 0
_ExtentX = 741
_ExtentY = 741
_Version = 393216
Protocol = 1
End
Begin MSWinsockLib.Winsock WS_Players
Left = 2520
Top = 0
_ExtentX = 741
_ExtentY = 741
_Version = 393216
Protocol = 1
End
Begin MSWinsockLib.Winsock WS_RefreshServer
Left = 2040
Top = 0
_ExtentX = 741
_ExtentY = 741
_Version = 393216
Protocol = 1
End
Begin MSWinsockLib.Winsock WS_QueryServer
Index = 0
Left = 1080
Top = 0
_ExtentX = 741
_ExtentY = 741
_Version = 393216
Protocol = 1
End
Begin MSWinsockLib.Winsock WS_GetServerList
Left = 120
Top = 0
_ExtentX = 741
_ExtentY = 741
_Version = 393216
Protocol = 1
End
Begin VB.Timer TimeoutTimer
Enabled = 0 'False
Index = 0
Interval = 500
Left = 1560
Top = 0
End
Begin VB.Timer MSTimeoutTimer
Enabled = 0 'False
Interval = 30000
Left = 600
Top = 0
End
Begin ComctlLib.ListView LVPlayers
Height = 1380
Left = 0
TabIndex = 1
Top = 3900
Width = 4995
_ExtentX = 8811
_ExtentY = 2434
View = 3
LabelEdit = 1
LabelWrap = -1 'True
HideSelection = -1 'True
_Version = 327682
ForeColor = -2147483640
BackColor = -2147483643
BorderStyle = 1
Appearance = 1
NumItems = 4
BeginProperty ColumnHeader(1) {0713E8C7-850A-101B-AFC0-4210102A8DA7}
Key = ""
Object.Tag = ""
Text = "ID"
Object.Width = 265
EndProperty
BeginProperty ColumnHeader(2) {0713E8C7-850A-101B-AFC0-4210102A8DA7}
SubItemIndex = 1
Key = ""
Object.Tag = ""
Text = "Player Name"
Object.Width = 4586
EndProperty
BeginProperty ColumnHeader(3) {0713E8C7-850A-101B-AFC0-4210102A8DA7}
Alignment = 2
SubItemIndex = 2
Key = ""
Object.Tag = ""
Text = "Frags"
Object.Width = 882
EndProperty
BeginProperty ColumnHeader(4) {0713E8C7-850A-101B-AFC0-4210102A8DA7}
Alignment = 1
SubItemIndex = 3
Key = ""
Object.Tag = ""
Text = "Time"
Object.Width = 1058
EndProperty
End
Begin ComctlLib.ListView LVServers
Height = 3855
Left = 0
TabIndex = 0
Top = 0
Width = 8295
_ExtentX = 14631
_ExtentY = 6800
View = 3
LabelEdit = 1
LabelWrap = -1 'True
HideSelection = 0 'False
_Version = 327682
ForeColor = -2147483640
BackColor = -2147483643
BorderStyle = 1
Appearance = 1
NumItems = 9
BeginProperty ColumnHeader(1) {0713E8C7-850A-101B-AFC0-4210102A8DA7}
Key = ""
Object.Tag = ""
Text = "Server Name"
Object.Width = 2540
EndProperty
BeginProperty ColumnHeader(2) {0713E8C7-850A-101B-AFC0-4210102A8DA7}
SubItemIndex = 1
Key = ""
Object.Tag = ""
Text = "Address"
Object.Width = 3175
EndProperty
BeginProperty ColumnHeader(3) {0713E8C7-850A-101B-AFC0-4210102A8DA7}
Alignment = 2
SubItemIndex = 2
Key = ""
Object.Tag = "2"
Text = "Ping"
Object.Width = 1235
EndProperty
BeginProperty ColumnHeader(4) {0713E8C7-850A-101B-AFC0-4210102A8DA7}
SubItemIndex = 3
Key = ""
Object.Tag = ""
Text = "Game"
Object.Width = 2646
EndProperty
BeginProperty ColumnHeader(5) {0713E8C7-850A-101B-AFC0-4210102A8DA7}
SubItemIndex = 4
Key = ""
Object.Tag = ""
Text = "Map"
Object.Width = 2646
EndProperty
BeginProperty ColumnHeader(6) {0713E8C7-850A-101B-AFC0-4210102A8DA7}
Alignment = 1
SubItemIndex = 5
Key = ""
Object.Tag = ""
Text = "Players"
Object.Width = 1587
EndProperty
BeginProperty ColumnHeader(7) {0713E8C7-850A-101B-AFC0-4210102A8DA7}
SubItemIndex = 6
Key = ""
Object.Tag = ""
Text = "Locked"
Object.Width = 0
EndProperty
BeginProperty ColumnHeader(8) {0713E8C7-850A-101B-AFC0-4210102A8DA7}
SubItemIndex = 7
Key = ""
Object.Tag = ""
Text = "Type"
Object.Width = 0
EndProperty
BeginProperty ColumnHeader(9) {0713E8C7-850A-101B-AFC0-4210102A8DA7}
SubItemIndex = 8
Key = ""
Object.Tag = ""
Text = "Favorite"
Object.Width = 0
EndProperty
End
Begin VB.PictureBox VerticalBar
BorderStyle = 0 'None
Height = 1395
Left = 4980
MousePointer = 9 'Size W E
ScaleHeight = 1395
ScaleWidth = 75
TabIndex = 3
TabStop = 0 'False
Top = 3900
Width = 75
End
Begin VB.PictureBox HorizontalBar
BorderStyle = 0 'None
Height = 75
Left = 0
MousePointer = 7 'Size N S
ScaleHeight = 75
ScaleWidth = 8295
TabIndex = 2
TabStop = 0 'False
Top = 3840
Width = 8295
End
Begin ComctlLib.StatusBar MenuSBar
Height = 255
Left = 0
TabIndex = 6
Top = 5280
Visible = 0 'False
Width = 8295
_ExtentX = 14631
_ExtentY = 450
SimpleText = ""
_Version = 327682
BeginProperty Panels {0713E89E-850A-101B-AFC0-4210102A8DA7}
NumPanels = 1
BeginProperty Panel1 {0713E89F-850A-101B-AFC0-4210102A8DA7}
AutoSize = 1
Bevel = 0
Object.Width = 14579
Object.Tag = ""
EndProperty
EndProperty
End
Begin ComctlLib.ImageList MenuImgList
Left = 0
Top = 0
_ExtentX = 1005
_ExtentY = 1005
BackColor = -2147483643
MaskColor = 12632256
_Version = 327682
End
Begin ComctlLib.ImageList LVServersImgList
Left = 7560
Top = 0
_ExtentX = 1005
_ExtentY = 1005
BackColor = -2147483643
MaskColor = 12632256
_Version = 327682
End
Begin VB.Menu FileMenu
Caption = "&File"
Begin VB.Menu UpdateServersMenu
Caption = "|Updates the server list with selected filters|&Update Servers"
Shortcut = ^U
End
Begin VB.Menu LanServersMenu
Caption = "|Updates local area network servers with selected filters|Update &Lan Servers"
Shortcut = ^L
End
Begin VB.Menu RefreshServersMenu
Caption = "|Refreshes the server list with selected filters|&Refresh Servers"
Shortcut = ^R
End
Begin VB.Menu CancelMenu
Caption = "|Stops updating or refreshing|&Cancel"
End
Begin VB.Menu Blank1
Caption = "-"
End
Begin VB.Menu ExitMenu
Caption = "|Quits the program|E&xit"
End
End
Begin VB.Menu ViewMenu
Caption = "&View"
Begin VB.Menu HighlightLockedMenu
Caption = "#|Highlight servers which require a password to join|Highlight &Locked Servers"
Checked = -1 'True
Shortcut = ^{F1}
End
Begin VB.Menu HighlightProxyMenu
Caption = "#|Highlight servers which are only used for HLTV purposes|Highlight &Proxy Servers"
Checked = -1 'True
Shortcut = ^{F2}
End
End
Begin VB.Menu FavoritesMenu
Caption = "F&avorites"
Begin VB.Menu AddNewFavMenu
Caption = "|Add a new favorite to the favorites list|&Add New Favorite..."
Shortcut = ^N
End
Begin VB.Menu ManageFavMenu
Caption = "|Manage the servers in your favorites list|&Manage Favorites..."
Shortcut = ^M
End
Begin VB.Menu Blank7
Caption = "-"
End
Begin VB.Menu RefreshFavMenu
Caption = "|Refresh all the servers in your favorites list|&Refresh All Favorites"
Shortcut = ^{INSERT}
End
End
Begin VB.Menu ToolsMenu
Caption = "&Tools"
Begin VB.Menu ServerQueryMenu
Caption = "|Query a Half-Life server and get its information and players|&Server Query Tool..."
Shortcut = +{F1}
End
Begin VB.Menu PlayerSearchToolMenu
Caption = "|Searches for a player in a multiplayer game|&Player Search Tool..."
Shortcut = +{F2}
End
Begin VB.Menu RCONToolMenu
Caption = "|Send commands to a server remotely using RCON|&RCON Tool..."
Shortcut = +{F3}
End
Begin VB.Menu Blank2
Caption = "-"
End
Begin VB.Menu FilterMenu
Caption = "|Configure and select which filters to use|&Filter Settings..."
Shortcut = ^F
End
Begin VB.Menu OptionsMenu
Caption = "|Edit the programs settings|&Options..."
Shortcut = ^O
End
End
Begin VB.Menu HelpMenu
Caption = "&Help"
Begin VB.Menu OnlineHelpMenu
Caption = "|Shows the online help contents|&Online Documentation..."
Shortcut = {F1}
End
Begin VB.Menu ACLinksMenu
Caption = "Anti-Cheat &Links"
Begin VB.Menu PBMenu
Caption = "|Go to the PunkBuster website|&PunkBuster..."
End
Begin VB.Menu PaladinMenu
Caption = "|Go to the Paladin website|P&aladin..."
End
Begin VB.Menu CDMenu
Caption = "|Go to the Cheating-Death website|&Cheating-Death..."
End
End
Begin VB.Menu Blank8
Caption = "-"
End
Begin VB.Menu UpdateCheckMenu
Caption = "|Check for a newer version of QuickQuery Half-Life Edition|&Check For Update..."
End
Begin VB.Menu HowToRegisterMenu
Caption = "|Opens the How to register page|&How to Register..."
End
Begin VB.Menu Blank9
Caption = "-"
End
Begin VB.Menu RegMenu
Caption = "|Enter your registration code|&Enter Registration..."
End
Begin VB.Menu AboutMenu
Caption = "|Displays information about the program|&About..."
End
End
Begin VB.Menu LVServersPopupMenu
Caption = "LVServersPopupMenu"
Visible = 0 'False
Begin VB.Menu LaunchMenu
Caption = "&Launch Half-Life..."
End
Begin VB.Menu Blank3
Caption = "-"
End
Begin VB.Menu CopyAddressMenu
Caption = "&Copy Server Address"
End
Begin VB.Menu CopySelectionMenu
Caption = "C&opy Selection"
End
Begin VB.Menu Blank4
Caption = "-"
End
Begin VB.Menu AddToFavsMenu
Caption = "Add &to Favorites..."
End
Begin VB.Menu FindServerMenu
Caption = "&Find Server..."
End
Begin VB.Menu RemoveServerMenu
Caption = "&Remove Server"
End
Begin VB.Menu RemoveFavoriteMenu
Caption = "R&emove From Favorites"
End
Begin VB.Menu Blank6
Caption = "-"
End
Begin VB.Menu ServerDetailsMenu
Caption = "Server &Details..."
End
Begin VB.Menu RCONConsoleMenu
Caption = "RCO&N Console..."
End
Begin VB.Menu Blank5
Caption = "-"
End
Begin VB.Menu RefreshAllMenu
Caption = "Refresh &All Servers"
End
Begin VB.Menu PingServerMenu
Caption = "&Ping Selected Server"
End
Begin VB.Menu AutoRefreshMenu
Caption = "A&utoRefresh Selected Server..."
End
Begin VB.Menu RefreshSelectedMenu
Caption = "Refresh &Selected Server"
End
End
Begin VB.Menu LVPlayersPopupMenu
Caption = "LVPlayersPopupMenu"
Visible = 0 'False
Begin VB.Menu PlayersRefreshMenu
Caption = "&Refresh"
End
Begin VB.Menu PlayersCopyMenu
Caption = "&Copy"
End
End
Begin VB.Menu LVRulesPopupMenu
Caption = "LVRulesPopupMenu"
Visible = 0 'False
Begin VB.Menu RulesRefreshMenu
Caption = "&Refresh"
End
Begin VB.Menu RulesCopyMenu
Caption = "&Copy"
End
End
End
Attribute VB_Name = "MainForm"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = True
Attribute VB_Exposed = False
Private WithEvents HelpObj As HelpCallBack
Attribute HelpObj.VB_VarHelpID = -1
Private Type ObjectProportions
ProportionX As Variant
ProportionY As Variant
End Type
Dim LVServersP As ObjectProportions
Dim LVPlayersP As ObjectProportions
Dim LVRulesP As ObjectProportions
Dim bHorizontalBarMoving As Boolean
Dim bVerticalBarMoving As Boolean
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 SCount As Long
Public PCount As Double
Dim bServersDone As Boolean
Dim RefreshIndex As Long
Dim RefreshTimer As Single
Dim bRefreshingFavs As Boolean
Private LVServers_HdrIcons As New cLVHeaderSortIcons
Private Declare Function GetMenu Lib "user32" (ByVal hWnd As Long) As Long
Private Declare Function GetSubMenu Lib "user32" (ByVal hMenu As Long, ByVal nPos As Long) As Long
Private Declare Function SetMenuDefaultItem Lib "user32" (ByVal hMenu As Long, ByVal uItem As Long, ByVal fByPos As Long) As Long
Private Declare Function GetSysColor Lib "user32" (ByVal nIndex As Long) As Long
Private Const COLOR_APPWORKSPACE = 12
Private Const COLOR_BTNFACE = 15
Private Declare Function InitCommonControls Lib "comctl32.dll" () As Long
Private Sub BoldCancelMenu()
SetMenuDefaultItem GetSubMenu(GetMenu(hWnd), 0), 3, 1
End Sub
Private Sub BoldUpdateServersMenu()
SetMenuDefaultItem GetSubMenu(GetMenu(hWnd), 0), 0, 1
End Sub
Public Sub ClickLVServersItem(ByVal Item As ComctlLib.ListItem)
LVServers_ItemClick Item
End Sub
Private Sub AboutMenu_Click()
AboutForm.Show 1
End Sub
Private Sub AddNewFavMenu_Click()
AddFavoriteForm.Caption = "Add New Favorite"
AddFavoriteForm.ListIndex = -1
AddFavoriteForm.Show 1
End Sub
Private Sub AddToFavsMenu_Click()
AddFavoriteForm.Caption = "Add New Favorite"
AddFavoriteForm.ListIndex = -1
AddFavoriteForm.txtAddress.Text = LVServers.SelectedItem.SubItems(1)
AddFavoriteForm.txtAddress.SelStart = 0
AddFavoriteForm.txtAddress.SelLength = Len(AddFavoriteForm.txtAddress.Text)
AddFavoriteForm.Show 1
End Sub
Private Sub AutoRefreshMenu_Click()
With AutoRefreshForm
.Caption = "AutoRefreshing " + LVServers.SelectedItem.SubItems(1)
.Show 0, MainForm
.RefreshTimer.Enabled = False
.ServerRulesRecvd False
.LVGameInfo.ListItems.Clear
.LVGameInfo.ListItems.Add , , "Receiving game rules..."
.WS_GameRules.RemoteHost = Left(LVServers.SelectedItem.SubItems(1), InStr(LVServers.SelectedItem.SubItems(1), ":") - 1)
.WS_GameRules.RemotePort = Mid(LVServers.SelectedItem.SubItems(1), InStr(LVServers.SelectedItem.SubItems(1), ":") + 1)
.WS_GameRules.SendData "����rules"
End With
End Sub
Private Sub CancelMenu_Click()
Dim i As Integer
bServersDone = True
WS_GetServerList.Close
MSTimeoutTimer.Enabled = False
SBar.Panels(3).Visible = False
CancelMenu.Visible = False
UpdateServersMenu.Visible = True
LanServersMenu.Visible = True
RefreshServersMenu.Visible = True
FilterMenu.Enabled = True
RefreshFavMenu.Enabled = True
For i = WS_QueryServer.UBound To 1 Step -1
Unload WS_QueryServer(i)
Unload TimeoutTimer(i)
Next i
If LVServers.ListItems.Count > 0 Then
SBar.Panels(1).Text = LVServers.ListItems.Count & " Server" + IIf(LVServers.ListItems.Count = 1, "", "s")
SBar.Panels(2).Text = PCount & " Player" + IIf(PCount = 1, "", "s") + " Online"
Else
SBar.Panels(1).Text = "0 Servers (Click Here to Update)"
SBar.Panels(2).Text = "0 Players Online"
BoldUpdateServersMenu
End If
End Sub
Private Sub CDMenu_Click()
LaunchURL "http://www.cheating-death.com"
End Sub
Private Sub CopyAddressMenu_Click()
txtCopy.Text = LVServers.SelectedItem.SubItems(1)
txtCopy.SelStart = 0
txtCopy.SelLength = Len(txtCopy.Text)
ClipboardCut txtCopy.hWnd
End Sub
Private Sub CopySelectionMenu_Click()
Dim i As Integer
txtCopy.Text = LVServers.SelectedItem.Text
For i = 2 To LVServers.ColumnHeaders.Count
txtCopy.Text = txtCopy.Text + vbTab + IIf(i = 3, CStr(Val(LVServers.SelectedItem.SubItems(i - 1))), LVServers.SelectedItem.SubItems(i - 1))
Next i
txtCopy.SelStart = 0
txtCopy.SelLength = Len(txtCopy.Text)
ClipboardCut txtCopy.hWnd
End Sub
Private Sub ExitMenu_Click()
Unload Me
End Sub
Private Sub FilterMenu_Click()
FilterForm.Show 1
End Sub
Private Sub FindServerMenu_Click()
On Error Resume Next
FindServerForm.Show 0, Me
FindServerForm.txtFind.SetFocus
FindServerForm.txtFind.SelStart = 0
FindServerForm.txtFind.SelLength = Len(FindServerForm.txtFind.Text)
End Sub
Private Sub Form_Load()
On Error Resume Next
Dim i As Long
Dim i2 As Long
Dim iOffset As Long
Dim lRegData As Long
Dim sRegData As String
Dim bRegErr As Boolean
Dim TmpArray1() As String
Dim TmpArray2() As String
Dim Filters As Integer
Call InitCommonControls
Ver = App.Major & "." & App.Minor & IIf(App.Revision = 0, "", "." & App.Revision)
bIsLaunched = False
LVServersP.ProportionX = LVServers.Width / ScaleWidth
LVServersP.ProportionY = LVServers.Height / (ScaleHeight - SBar.Height)
LVPlayersP.ProportionX = LVPlayers.Width / ScaleWidth
LVPlayersP.ProportionY = LVPlayers.Height / (ScaleHeight - SBar.Height)
CancelMenu.Visible = False
LV_FullRowSelect LVServers
LV_LabelTip LVServers
LV_FullRowSelect LVPlayers
With MenuImgList
.ImageWidth = 16
.ImageHeight = 16
' Top menus
.ListImages.Add , , LoadResPicture(1001, 0)
i = 1
.ListImages(i).Tag = "&Update Servers"
.ListImages.Add , , LoadResPicture(1001, 0)
i = i + 1
.ListImages(i).Tag = "Update &Lan Servers"
.ListImages.Add , , LoadResPicture(1002, 0)
i = i + 1
.ListImages(i).Tag = "&Refresh Servers"
.ListImages.Add , , LoadResPicture(1003, 0)
i = i + 1
.ListImages(i).Tag = "E&xit"
.ListImages.Add , , LoadResPicture(1004, 0)
i = i + 1
.ListImages(i).Tag = "&Add New Favorite..."
.ListImages.Add , , LoadResPicture(1002, 0)
i = i + 1
.ListImages(i).Tag = "&Refresh All Favorites"
.ListImages.Add , , LoadResPicture(1005, 0)
i = i + 1
.ListImages(i).Tag = "&Server Query Tool..."
.ListImages.Add , , LoadResPicture(1006, 0)
i = i + 1
.ListImages(i).Tag = "&Player Search Tool..."
.ListImages.Add , , LoadResPicture(1007, 0)
i = i + 1
.ListImages(i).Tag = "&RCON Tool..."
.ListImages.Add , , LoadResPicture(1008, 0)
i = i + 1
.ListImages(i).Tag = "&Online Documentation..."
.ListImages.Add , , LoadResPicture(1011, 0)
i = i + 1
.ListImages(i).Tag = "&Check For Update..."
.ListImages.Add , , LoadResPicture(1012, 0)
i = i + 1
.ListImages(i).Tag = "&How to Register..."
.ListImages.Add , , LoadResPicture(1009, 0)
i = i + 1
.ListImages(i).Tag = "&Enter Registration..."
.ListImages.Add , , LoadResPicture(1010, 0)
i = i + 1
.ListImages(i).Tag = "&About..."
.ListImages.Add , , LoadResPicture(1201, 0)
i = i + 1
.ListImages(i).Tag = "&Punkbuster..."
.ListImages.Add , , LoadResPicture(1202, 0)
i = i + 1
.ListImages(i).Tag = "P&aladin..."
.ListImages.Add , , LoadResPicture(1203, 0)
i = i + 1
.ListImages(i).Tag = "&Cheating-Death..."
' Popup menus
.ListImages.Add , , LoadResPicture(1101, 0)
i = i + 1
.ListImages(i).Tag = "&Launch Half-Life..."
.ListImages.Add , , LoadResPicture(1102, 0)
i = i + 1
.ListImages(i).Tag = "&Copy Server Address"
.ListImages.Add , , LoadResPicture(1102, 0)
i = i + 1
.ListImages(i).Tag = "C&opy Selection"
.ListImages.Add , , LoadResPicture(1004, 0)
i = i + 1
.ListImages(i).Tag = "Add &to Favorites..."
.ListImages.Add , , LoadResPicture(1103, 0)
i = i + 1
.ListImages(i).Tag = "&Find Server..."
.ListImages.Add , , LoadResPicture(1104, 0)
i = i + 1
.ListImages(i).Tag = "&Remove Server"
.ListImages.Add , , LoadResPicture(1104, 0)
i = i + 1
.ListImages(i).Tag = "R&emove From Favorites"
.ListImages.Add , , LoadResPicture(1105, 0)
i = i + 1
.ListImages(i).Tag = "Server &Details..."
.ListImages.Add , , LoadResPicture(1007, 0)
i = i + 1
.ListImages(i).Tag = "RCO&N Console..."
.ListImages.Add , , LoadResPicture(1002, 0)
i = i + 1
.ListImages(i).Tag = "Refresh &All Servers"
.ListImages.Add , , LoadResPicture(1106, 0)
i = i + 1
.ListImages(i).Tag = "&Ping Selected Server"
.ListImages.Add , , LoadResPicture(1107, 0)
i = i + 1
.ListImages(i).Tag = "A&utoRefresh Selected Server..."
.ListImages.Add , , LoadResPicture(1002, 0)
i = i + 1
.ListImages(i).Tag = "Refresh &Selected Server"
.ListImages.Add , , LoadResPicture(1002, 0)
i = i + 1
.ListImages(i).Tag = "&Refresh"
.ListImages.Add , , LoadResPicture(1102, 0)
i = i + 1
.ListImages(i).Tag = "&Copy"
End With
With LVServersImgList
.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
LVServers.SmallIcons = LVServersImgList
Set LVServers_HdrIcons.ListView = LVServers
LVServers_HdrIcons.ExcludeColumn = -1
If sFileCRC <> sCRC32 Then
End
Exit Sub
End If
lRegData = GetRegDWORD(HKEY_LOCAL_MACHINE, SettingsReg, "LVHotTrack", bRegErr)
If (lRegData <> 0 And lRegData <> 1) Or bRegErr Then lRegData = 1
Optn_LVHotTrack = lRegData
If Optn_LVHotTrack = 1 Then LV_HotTracking LVServers, True
lRegData = GetRegDWORD(HKEY_LOCAL_MACHINE, SettingsReg, "SaveServers", bRegErr)
If (lRegData <> 0 And lRegData <> 1) Or bRegErr Then lRegData = 1
Optn_SaveServers = lRegData
Optn_ServerFile = GetRegString(HKEY_LOCAL_MACHINE, SettingsReg, "ServerFile")
If Optn_ServerFile = "" Then Optn_ServerFile = "serverlist.txt"
If Optn_SaveServers = 1 Then PostLoadTimer.Enabled = True
lRegData = GetRegDWORD(HKEY_LOCAL_MACHINE, SettingsReg, "AutoPB", bRegErr)
If (lRegData <> 0 And lRegData <> 1) Or bRegErr Then lRegData = 0
Optn_AutoPB = lRegData
lRegData = GetRegDWORD(HKEY_LOCAL_MACHINE, SettingsReg, "AutoPaladin", bRegErr)
If (lRegData <> 0 And lRegData <> 1) Or bRegErr Then lRegData = 0
Optn_AutoPaladin = lRegData
lRegData = GetRegDWORD(HKEY_LOCAL_MACHINE, SettingsReg, "AutoCD", bRegErr)
If (lRegData <> 0 And lRegData <> 1) Or bRegErr Then lRegData = 0
Optn_AutoCD = lRegData
Optn_MasterServer = GetRegString(HKEY_LOCAL_MACHINE, SettingsReg, "MasterServer")
If Optn_MasterServer = "" Then Optn_MasterServer = "half-life.east.won.net:27010"
lRegData = GetRegDWORD(HKEY_LOCAL_MACHINE, SettingsReg, "LimitServers", bRegErr)
If (lRegData <> 0 And lRegData <> 1) Or bRegErr Then lRegData = 0
Optn_LimitServers = lRegData
lRegData = GetRegDWORD(HKEY_LOCAL_MACHINE, SettingsReg, "MaxServers", bRegErr)
If (lRegData < 1 Or lRegData > 999999) Or bRegErr Then lRegData = 5000
Optn_MaxServers = lRegData
lRegData = GetRegDWORD(HKEY_LOCAL_MACHINE, SettingsReg, "MaxConnections", bRegErr)
If (lRegData < 1 Or lRegData > 99) Or bRegErr Then lRegData = 40
Optn_MaxConnections = lRegData
lRegData = GetRegDWORD(HKEY_LOCAL_MACHINE, SettingsReg, "RequestTimeout", bRegErr)
If (lRegData < 1 Or lRegData > 99999) Or bRegErr Then lRegData = 500
Optn_RequestTimeout = lRegData
lRegData = GetRegDWORD(HKEY_LOCAL_MACHINE, SettingsReg, "AutoRefreshRate", bRegErr)
If (lRegData < 1 Or lRegData > 999999) Or bRegErr Then lRegData = 2000
Optn_AutoRefreshRate = lRegData
lRegData = GetRegDWORD(HKEY_LOCAL_MACHINE, SettingsReg, "UnloadWSControls", bRegErr)
If (lRegData <> 0 And lRegData <> 1) Or bRegErr Then lRegData = 0
Optn_UnloadWSControls = lRegData
lRegData = GetRegDWORD(HKEY_LOCAL_MACHINE, SettingsReg, "ProcessPriority", bRegErr)
If (lRegData < 0 Or lRegData > 5) Or bRegErr Then lRegData = 2
Optn_ProcessPriority = lRegData
If Optn_ProcessPriority = 1 Or Optn_ProcessPriority = 3 Then
If Not IsCompatible() Then Optn_ProcessPriority = 2
End If
lRegData = GetRegDWORD(HKEY_LOCAL_MACHINE, SettingsReg, "WaitForReturn", bRegErr)
If (lRegData <> 0 And lRegData <> 1) Or bRegErr Then lRegData = 1
Optn_WaitForReturn = lRegData
lRegData = GetRegDWORD(HKEY_LOCAL_MACHINE, SettingsReg, "ResetMSNStatus", bRegErr)
If (lRegData <> 0 And lRegData <> 1) Or bRegErr Then lRegData = 1
Optn_ResetMSNStatus = lRegData
lRegData = GetRegDWORD(HKEY_LOCAL_MACHINE, SettingsReg, "ClosePB", bRegErr)
If (lRegData <> 0 And lRegData <> 1) Or bRegErr Then lRegData = 1
Optn_ClosePB = lRegData
lRegData = GetRegDWORD(HKEY_LOCAL_MACHINE, SettingsReg, "CloseCD", bRegErr)
If (lRegData <> 0 And lRegData <> 1) Or bRegErr Then lRegData = 1
Optn_CloseCD = lRegData
lRegData = GetRegDWORD(HKEY_LOCAL_MACHINE, SettingsReg, "FilterFavorites", bRegErr)
If (lRegData <> 0 And lRegData <> 1) Or bRegErr Then lRegData = 0
Optn_FilterFavorites = lRegData
lRegData = GetRegDWORD(HKEY_LOCAL_MACHINE, SettingsReg, "AutoSort", bRegErr)
If (lRegData <> 0 And lRegData <> 1) Or bRegErr Then lRegData = 0
Optn_bSort = lRegData
lRegData = GetRegDWORD(HKEY_LOCAL_MACHINE, SettingsReg, "AutoSortMethod", bRegErr)
If (lRegData < 0 Or lRegData > 15) Or bRegErr Then lRegData = 0
Optn_iSort = lRegData
ExecutablePath = GetRegString(HKEY_LOCAL_MACHINE, SettingsReg, "ExecutablePath")
If ExecutablePath = "" Then ExecutablePath = "C:\SIERRA\Half-Life\hl.exe"
CmdLineArguments = GetRegString(HKEY_LOCAL_MACHINE, SettingsReg, "CmdLineArguments")
lRegData = GetRegDWORD(HKEY_LOCAL_MACHINE, SettingsReg, "HighlightLocked")
If (lRegData <> 0 And lRegData <> 1) Or bRegErr Then lRegData = 1
HighlightLockedMenu.Checked = CBool(lRegData)
lRegData = GetRegDWORD(HKEY_LOCAL_MACHINE, SettingsReg, "HighlightProxy")
If (lRegData <> 0 And lRegData <> 1) Or bRegErr Then lRegData = 1
HighlightProxyMenu.Checked = CBool(lRegData)
lRegData = GetRegDWORD(HKEY_LOCAL_MACHINE, FiltersReg, "AreResponding", bRegErr)
If (lRegData <> 0 And lRegData <> 1) Or bRegErr Then lRegData = 0
Filter_AreResponding = lRegData
lRegData = GetRegDWORD(HKEY_LOCAL_MACHINE, FiltersReg, "Linux", bRegErr)
If (lRegData <> 0 And lRegData <> 1) Or bRegErr Then lRegData = 0
Filter_Linux = lRegData
lRegData = GetRegDWORD(HKEY_LOCAL_MACHINE, FiltersReg, "Dedicated", bRegErr)
If (lRegData <> 0 And lRegData <> 1) Or bRegErr Then lRegData = 0
Filter_Dedicated = lRegData
lRegData = GetRegDWORD(HKEY_LOCAL_MACHINE, FiltersReg, "NotEmpty", bRegErr)
If (lRegData <> 0 And lRegData <> 1) Or bRegErr Then lRegData = 0
Filter_NotEmpty = lRegData
lRegData = GetRegDWORD(HKEY_LOCAL_MACHINE, FiltersReg, "RunningMap", bRegErr)
If (lRegData <> 0 And lRegData <> 1) Or bRegErr Then lRegData = 0
Filter_RunningMap = lRegData
Filter_MapName = GetRegString(HKEY_LOCAL_MACHINE, FiltersReg, "MapName")
lRegData = GetRegDWORD(HKEY_LOCAL_MACHINE, FiltersReg, "RunningGame", bRegErr)
If (lRegData <> 0 And lRegData <> 1) Or bRegErr Then lRegData = 0
Filter_RunningGame = lRegData
Filter_GameName = GetRegString(HKEY_LOCAL_MACHINE, FiltersReg, "GameName")
lRegData = GetRegDWORD(HKEY_LOCAL_MACHINE, FiltersReg, "NotFull", bRegErr)
If (lRegData <> 0 And lRegData <> 1) Or bRegErr Then lRegData = 0
Filter_NotFull = lRegData
lRegData = GetRegDWORD(HKEY_LOCAL_MACHINE, FiltersReg, "Proxy", bRegErr)
If (lRegData < 0 Or lRegData > 2) Or bRegErr Then lRegData = 0
Filter_Proxy = lRegData
If Filter_AreResponding = 1 Then Filters = Filters + 1
If Filter_Linux = 1 Then Filters = Filters + 1
If Filter_Dedicated = 1 Then Filters = Filters + 1
If Filter_NotEmpty = 1 Then Filters = Filters + 1
If Filter_RunningMap = 1 Then Filters = Filters + 1
If Filter_RunningGame = 1 Then Filters = Filters + 1
If Filter_NotFull = 1 Then Filters = Filters + 1
If Filter_Proxy > 0 Then Filters = Filters + 1
SBar.Panels(4).Text = Filters & " Filter" + IIf(Filters = 1, "", "s") + " In Use"
lRegData = GetRegDWORD(HKEY_LOCAL_MACHINE, SettingsReg, "RunPB", bRegErr)
If (lRegData <> 0 And lRegData <> 1) Or bRegErr Then lRegData = 0
LaunchOptn_RunPB = lRegData
LaunchOptn_PBLocation = GetRegString(HKEY_LOCAL_MACHINE, SettingsReg, "PBLocation")
lRegData = GetRegDWORD(HKEY_LOCAL_MACHINE, SettingsReg, "RunPaladin", bRegErr)
If (lRegData <> 0 And lRegData <> 1) Or bRegErr Then lRegData = 0
LaunchOptn_RunPaladin = lRegData
LaunchOptn_PaladinLocation = GetRegString(HKEY_LOCAL_MACHINE, SettingsReg, "PaladinLocation")
lRegData = GetRegDWORD(HKEY_LOCAL_MACHINE, SettingsReg, "RunCD", bRegErr)
If (lRegData <> 0 And lRegData <> 1) Or bRegErr Then lRegData = 0
LaunchOptn_RunCD = lRegData
LaunchOptn_CDLocation = GetRegString(HKEY_LOCAL_MACHINE, SettingsReg, "CDLocation")
lRegData = GetRegDWORD(HKEY_LOCAL_MACHINE, SettingsReg, "ChangeMSNStatus", bRegErr)
If (lRegData <> 0 And lRegData <> 1) Or bRegErr Then lRegData = 0
LaunchOptn_ChangeMSNStatus = lRegData
lRegData = GetRegDWORD(HKEY_LOCAL_MACHINE, SettingsReg, "MSNStatus", bRegErr)
If (lRegData < 0 Or lRegData > 5) Or bRegErr Then lRegData = 0
LaunchOptn_MSNStatus = lRegData
lRegData = GetRegDWORD(HKEY_LOCAL_MACHINE, MessagesReg, "Filter", bRegErr)
If (lRegData <> 0 And lRegData <> 1) Or bRegErr Then lRegData = 0
Msg_Filter = lRegData
lRegData = GetRegDWORD(HKEY_LOCAL_MACHINE, MessagesReg, "PBError", bRegErr)
If (lRegData <> 0 And lRegData <> 1) Or bRegErr Then lRegData = 0
Msg_PBError = lRegData
lRegData = GetRegDWORD(HKEY_LOCAL_MACHINE, MessagesReg, "PBPaladinError", bRegErr)
If (lRegData <> 0 And lRegData <> 1) Or bRegErr Then lRegData = 0
Msg_PBPaladinError = lRegData
lRegData = GetRegDWORD(HKEY_LOCAL_MACHINE, MessagesReg, "CDError", bRegErr)
If (lRegData <> 0 And lRegData <> 1) Or bRegErr Then lRegData = 0
Msg_CDError = lRegData
lRegData = GetRegDWORD(HKEY_LOCAL_MACHINE, MessagesReg, "MSNError", bRegErr)
If (lRegData <> 0 And lRegData <> 1) Or bRegErr Then lRegData = 1
Msg_MSNError = lRegData
lRegData = GetRegDWORD(HKEY_LOCAL_MACHINE, FavoritesReg, "FavoritesCount")
If lRegData > 0 Then
ReDim FavoritesList(lRegData)
iOffset = 0
For i = 1 To lRegData
FavoritesList(i - iOffset) = Left(GetRegString(HKEY_LOCAL_MACHINE, FavoritesReg, "Favorite[" & i & "]"), 100)
If FavoritesList(i - iOffset) = "" Then
ReDim Preserve FavoritesList(UBound(FavoritesList) - 1)
iOffset = iOffset + 1
Else
For i2 = 1 To (i - iOffset) - 1
If LCase(FavoritesList(i - iOffset)) = LCase(FavoritesList(i2)) Then
ReDim Preserve FavoritesList(UBound(FavoritesList) - 1)
iOffset = iOffset + 1
Exit For
End If
Next i2
End If
Next i
Else
ReDim FavoritesList(0)
End If
Err.Clear
ReDim RCONPasswordsList(0)
sRegData = GetRegBinary(HKEY_LOCAL_MACHINE, RegAppRoot, "RCONPasswords", , bRegErr)
If bRegErr = False And sRegData <> "" Then
TmpArray1 = Split(sRegData, vbLf)
For i = 0 To UBound(TmpArray1)
If Err.Number <> 0 Then Exit For
If TmpArray1(i) <> "" Then
TmpArray2 = Split(TmpArray1(i), vbTab)
If TmpArray2(1) <> "" Then
If Err.Number = 0 Then
ReDim Preserve RCONPasswordsList(UBound(RCONPasswordsList) + 1)
RCONPasswordsList(UBound(RCONPasswordsList)).Address = Left(TmpArray2(0), 100)
RCONPasswordsList(UBound(RCONPasswordsList)).Password = Left(TmpArray2(1), 100)
End If
End If
Err.Clear
End If
Next i
End If
lRegData = GetRegDWORD(HKEY_LOCAL_MACHINE, ProgramsReg, "ProgramsCount")
If lRegData > 0 Then
ReDim ProgramsList(lRegData)
iOffset = 0
For i = 1 To lRegData
ProgramsList(i - iOffset).Target = Left(GetRegString(HKEY_LOCAL_MACHINE, ProgramsReg, "Program[" & i & "].Target"), 1000)
ProgramsList(i - iOffset).Path = Left(GetRegString(HKEY_LOCAL_MACHINE, ProgramsReg, "Program[" & i & "].Path"), 1000)
ProgramsList(i - iOffset).CmdLine = Left(GetRegString(HKEY_LOCAL_MACHINE, ProgramsReg, "Program[" & i & "].CmdLine"), 1000)
lRegData = GetRegDWORD(HKEY_LOCAL_MACHINE, ProgramsReg, "Program[" & i & "].RunMode", bRegErr)
If (lRegData < 0 Or lRegData > 2) Or bRegErr Then lRegData = 0
ProgramsList(i - iOffset).RunMode = lRegData
lRegData = GetRegDWORD(HKEY_LOCAL_MACHINE, ProgramsReg, "Program[" & i & "].ProcessPriority", bRegErr)
If (lRegData < 0 Or lRegData > 5) Or bRegErr Then lRegData = 2
ProgramsList(i - iOffset).ProcessPriority = lRegData
If ProgramsList(i - iOffset).ProcessPriority = 1 Or ProgramsList(i - iOffset).ProcessPriority = 3 Then
If Not IsCompatible() Then ProgramsList(i - iOffset).ProcessPriority = 2
End If
lRegData = GetRegDWORD(HKEY_LOCAL_MACHINE, ProgramsReg, "Program[" & i & "].AutoClose", bRegErr)
If (lRegData <> 0 And lRegData <> 1) Or bRegErr Then lRegData = 0
ProgramsList(i - iOffset).iClose = lRegData
lRegData = GetRegDWORD(HKEY_LOCAL_MACHINE, ProgramsReg, "Program[" & i & "].Enabled", bRegErr)
If (lRegData <> 0 And lRegData <> 1) Or bRegErr Then lRegData = 0
ProgramsList(i - iOffset).Enabled = CBool(lRegData)
ProgramsList(i - iOffset).PID = 0
If ProgramsList(i - iOffset).Target = "" Or ProgramsList(i - iOffset).Path = "" Then
ReDim Preserve ProgramsList(UBound(ProgramsList) - 1)
iOffset = iOffset + 1
End If
Next i
Else
ReDim ProgramsList(0)
End If
sReg_Name = GetRegString(HKEY_LOCAL_MACHINE, RegAppRoot, "RegistrationName")
sReg_Code = GetRegBinary(HKEY_LOCAL_MACHINE, RegAppRoot, "RegistrationCode")
If sReg_Code <> "" Then
sReg_Code = RegistryRegCode(sReg_Code, True)
If sReg_Name <> "" Then bReg_Valid = CheckRegistration(sReg_Name, sReg_Code)
If bReg_Valid = True Then RegMenu.Enabled = False
End If
If sFileCRC <> sCRC32 Then
End
Exit Sub
End If
BoldUpdateServersMenu
SetLVType LVServers.hWnd, 2
SetLVType LVRules.hWnd, 1
SubClassListViewParentWnd hWnd, True
FixSize Me, Width + 400, Height, Screen.Width, Screen.Height
Set HelpObj = New HelpCallBack
Install hWnd, HelpObj, MenuImgList
ComplexChecks hWnd, False
Width = Screen.Width * 0.75
Height = Screen.Height * 0.75
lRegData = GetRegDWORD(HKEY_LOCAL_MACHINE, RegAppRoot, "LastWindowState", bRegErr)
If (lRegData <> 0 And lRegData <> 2) Or bRegErr Then lRegData = 0
WindowState = lRegData
End Sub
Private Sub Form_QueryUnload(Cancel As Integer, UnloadMode As Integer)
On Error Resume Next
Dim i As Long
Dim tmpstr As String
If WS_QueryServer.UBound > 0 Then
For i = WS_QueryServer.UBound To 1 Step -1
Unload WS_QueryServer(i)
Unload TimeoutTimer(i)
Next i
End If
If Forms.Count > 1 Then
For i = Forms.Count - 1 To 1 Step -1
Unload Forms(i)
Next i
End If
SaveRegDWORD HKEY_LOCAL_MACHINE, RegAppRoot, "LastWindowState", CLng(WindowState)
SaveRegDWORD HKEY_LOCAL_MACHINE, SettingsReg, "LVHotTrack", CLng(Optn_LVHotTrack)
SaveRegDWORD HKEY_LOCAL_MACHINE, SettingsReg, "SaveServers", CLng(Optn_SaveServers)
SaveRegString HKEY_LOCAL_MACHINE, SettingsReg, "ServerFile", Optn_ServerFile
SaveRegDWORD HKEY_LOCAL_MACHINE, SettingsReg, "AutoPB", CLng(Optn_AutoPB)
SaveRegDWORD HKEY_LOCAL_MACHINE, SettingsReg, "AutoPaladin", CLng(Optn_AutoPaladin)
SaveRegDWORD HKEY_LOCAL_MACHINE, SettingsReg, "AutoCD", CLng(Optn_AutoCD)
SaveRegString HKEY_LOCAL_MACHINE, SettingsReg, "MasterServer", Optn_MasterServer
SaveRegDWORD HKEY_LOCAL_MACHINE, SettingsReg, "LimitServers", CLng(Optn_LimitServers)
SaveRegDWORD HKEY_LOCAL_MACHINE, SettingsReg, "MaxServers", Optn_MaxServers
SaveRegDWORD HKEY_LOCAL_MACHINE, SettingsReg, "MaxConnections", CLng(Optn_MaxConnections)
SaveRegDWORD HKEY_LOCAL_MACHINE, SettingsReg, "RequestTimeout", Optn_RequestTimeout
SaveRegDWORD HKEY_LOCAL_MACHINE, SettingsReg, "AutoRefreshRate", Optn_AutoRefreshRate
SaveRegDWORD HKEY_LOCAL_MACHINE, SettingsReg, "UnloadWSControls", CLng(Optn_UnloadWSControls)
SaveRegDWORD HKEY_LOCAL_MACHINE, SettingsReg, "ProcessPriority", CLng(Optn_ProcessPriority)
SaveRegDWORD HKEY_LOCAL_MACHINE, SettingsReg, "WaitForReturn", CLng(Optn_WaitForReturn)
SaveRegDWORD HKEY_LOCAL_MACHINE, SettingsReg, "ResetMSNStatus", CLng(Optn_ResetMSNStatus)
SaveRegDWORD HKEY_LOCAL_MACHINE, SettingsReg, "ClosePB", CLng(Optn_ClosePB)
SaveRegDWORD HKEY_LOCAL_MACHINE, SettingsReg, "CloseCD", CLng(Optn_CloseCD)
SaveRegDWORD HKEY_LOCAL_MACHINE, SettingsReg, "AutoSort", CLng(Optn_bSort)
SaveRegDWORD HKEY_LOCAL_MACHINE, SettingsReg, "AutoSortMethod", CLng(Optn_iSort)
SaveRegDWORD HKEY_LOCAL_MACHINE, SettingsReg, "FilterFavorites", CLng(Optn_FilterFavorites)
SaveRegString HKEY_LOCAL_MACHINE, SettingsReg, "ExecutablePath", ExecutablePath
SaveRegString HKEY_LOCAL_MACHINE, SettingsReg, "CmdLineArguments", CmdLineArguments
If CmdLineArguments = "" Then SaveRegString HKEY_LOCAL_MACHINE, SettingsReg, "CmdLineArguments", ""
SaveRegDWORD HKEY_LOCAL_MACHINE, SettingsReg, "HighlightLocked", CLng(Abs(HighlightLockedMenu.Checked))
SaveRegDWORD HKEY_LOCAL_MACHINE, SettingsReg, "HighlightProxy", CLng(Abs(HighlightProxyMenu.Checked))
SaveRegDWORD HKEY_LOCAL_MACHINE, FiltersReg, "AreResponding", CLng(Filter_AreResponding)
SaveRegDWORD HKEY_LOCAL_MACHINE, FiltersReg, "Linux", CLng(Filter_Linux)
SaveRegDWORD HKEY_LOCAL_MACHINE, FiltersReg, "Dedicated", CLng(Filter_Dedicated)
SaveRegDWORD HKEY_LOCAL_MACHINE, FiltersReg, "NotEmpty", CLng(Filter_NotEmpty)
SaveRegDWORD HKEY_LOCAL_MACHINE, FiltersReg, "RunningMap", CLng(Filter_RunningMap)
SaveRegString HKEY_LOCAL_MACHINE, FiltersReg, "MapName", Filter_MapName
If Filter_MapName = "" Then SaveRegString HKEY_LOCAL_MACHINE, FiltersReg, "MapName", ""
SaveRegDWORD HKEY_LOCAL_MACHINE, FiltersReg, "RunningGame", CLng(Filter_RunningGame)
SaveRegString HKEY_LOCAL_MACHINE, FiltersReg, "GameName", Filter_GameName
If Filter_GameName = "" Then SaveRegString HKEY_LOCAL_MACHINE, FiltersReg, "GameName", ""
SaveRegDWORD HKEY_LOCAL_MACHINE, FiltersReg, "NotFull", CLng(Filter_NotFull)
SaveRegDWORD HKEY_LOCAL_MACHINE, FiltersReg, "Proxy", CLng(Filter_Proxy)
SaveRegDWORD HKEY_LOCAL_MACHINE, SettingsReg, "RunPB", CLng(LaunchOptn_RunPB)
SaveRegString HKEY_LOCAL_MACHINE, SettingsReg, "PBLocation", LaunchOptn_PBLocation
If LaunchOptn_PBLocation = "" Then SaveRegString HKEY_LOCAL_MACHINE, SettingsReg, "PBLocation", ""
SaveRegDWORD HKEY_LOCAL_MACHINE, SettingsReg, "RunPaladin", CLng(LaunchOptn_RunPaladin)
SaveRegString HKEY_LOCAL_MACHINE, SettingsReg, "PaladinLocation", LaunchOptn_PaladinLocation
If LaunchOptn_PaladinLocation = "" Then SaveRegString HKEY_LOCAL_MACHINE, SettingsReg, "PaladinLocation", ""
SaveRegDWORD HKEY_LOCAL_MACHINE, SettingsReg, "RunCD", CLng(LaunchOptn_RunCD)
SaveRegString HKEY_LOCAL_MACHINE, SettingsReg, "CDLocation", LaunchOptn_CDLocation
If LaunchOptn_CDLocation = "" Then SaveRegString HKEY_LOCAL_MACHINE, SettingsReg, "CDLocation", ""
SaveRegDWORD HKEY_LOCAL_MACHINE, SettingsReg, "ChangeMSNStatus", CLng(LaunchOptn_ChangeMSNStatus)
SaveRegDWORD HKEY_LOCAL_MACHINE, SettingsReg, "MSNStatus", CLng(LaunchOptn_MSNStatus)
SaveRegDWORD HKEY_LOCAL_MACHINE, MessagesReg, "Filter", CLng(Msg_Filter)
SaveRegDWORD HKEY_LOCAL_MACHINE, MessagesReg, "PBError", CLng(Msg_PBError)
SaveRegDWORD HKEY_LOCAL_MACHINE, MessagesReg, "PBPaladinError", CLng(Msg_PBPaladinError)
SaveRegDWORD HKEY_LOCAL_MACHINE, MessagesReg, "CDError", CLng(Msg_CDError)
SaveRegDWORD HKEY_LOCAL_MACHINE, MessagesReg, "MSNError", CLng(Msg_MSNError)
SaveRegDWORD HKEY_LOCAL_MACHINE, FavoritesReg, "FavoritesCount", CLng(UBound(FavoritesList))
For i = 1 To UBound(FavoritesList)
SaveRegString HKEY_LOCAL_MACHINE, FavoritesReg, "Favorite[" & i & "]", FavoritesList(i)
Next i
For i = 1 To UBound(RCONPasswordsList)
tmpstr = tmpstr + RCONPasswordsList(i).Address + vbTab + RCONPasswordsList(i).Password + vbLf
Next i
If tmpstr = "" Then
DeleteValue HKEY_LOCAL_MACHINE, RegAppRoot, "RCONPasswords"
Else
SaveRegBinary HKEY_LOCAL_MACHINE, RegAppRoot, "RCONPasswords", tmpstr
End If
For i = 1 To UBound(ProgramsList)
SaveRegString HKEY_LOCAL_MACHINE, ProgramsReg, "Program[" & i & "].Target", ProgramsList(i).Target
SaveRegString HKEY_LOCAL_MACHINE, ProgramsReg, "Program[" & i & "].Path", ProgramsList(i).Path
SaveRegString HKEY_LOCAL_MACHINE, ProgramsReg, "Program[" & i & "].CmdLine", ProgramsList(i).CmdLine
SaveRegDWORD HKEY_LOCAL_MACHINE, ProgramsReg, "Program[" & i & "].RunMode", CLng(ProgramsList(i).RunMode)
SaveRegDWORD HKEY_LOCAL_MACHINE, ProgramsReg, "Program[" & i & "].ProcessPriority", CLng(ProgramsList(i).ProcessPriority)
SaveRegDWORD HKEY_LOCAL_MACHINE, ProgramsReg, "Program[" & i & "].AutoClose", CLng(ProgramsList(i).iClose)
SaveRegDWORD HKEY_LOCAL_MACHINE, ProgramsReg, "Program[" & i & "].Enabled", CLng(Abs(CInt(ProgramsList(i).Enabled)))
Next i
SaveRegDWORD HKEY_LOCAL_MACHINE, ProgramsReg, "ProgramsCount", CLng(UBound(ProgramsList))
If bReg_Valid = True Then
If sReg_Name <> "" And sReg_Code <> "" Then
SaveRegString HKEY_LOCAL_MACHINE, RegAppRoot, "RegistrationName", sReg_Name
SaveRegBinary HKEY_LOCAL_MACHINE, RegAppRoot, "RegistrationCode", RegistryRegCode(sReg_Code, False)
End If
End If
ProgressForm.TaskID = 2
ProgressForm.Show 1
End Sub
Private Sub Form_Resize()
On Error Resume Next
Dim OffsetX As Long
Dim OffsetY As Long
If WindowState <> vbMinimized Then
LVServers.Width = ScaleWidth * LVServersP.ProportionX
OffsetX = ScaleWidth - (LVServers.Width + 40)
LVServers.Width = LVServers.Width + (OffsetX * 0.7)
LVServers.Height = ScaleHeight * LVServersP.ProportionY
LVServers.ColumnHeaders(1).Width = LVServers.Width - (LVServers.ColumnHeaders(2).Width + _
LVServers.ColumnHeaders(3).Width + LVServers.ColumnHeaders(4).Width + _
LVServers.ColumnHeaders(5).Width + LVServers.ColumnHeaders(6).Width + _
LVServers.ColumnHeaders(7).Width + LVServers.ColumnHeaders(8).Width + LVServers.ColumnHeaders(9).Width) - 2080
HorizontalBar.Top = LVServers.Height - 20
LVPlayers.Top = HorizontalBar.Top + HorizontalBar.Height
LVPlayers.Width = ScaleWidth * LVPlayersP.ProportionX
LVPlayers.Height = ScaleHeight * LVPlayersP.ProportionY
OffsetY = ScaleHeight - (LVPlayers.Top + LVPlayers.Height + SBar.Height)
LVPlayers.Height = LVPlayers.Height + OffsetY
LVPlayers.ColumnHeaders(2).Width = LVPlayers.Width - (LVPlayers.ColumnHeaders(1).Width + LVPlayers.ColumnHeaders(3).Width) - 2090
VerticalBar.Left = LVPlayers.Width
VerticalBar.Top = LVPlayers.Top
VerticalBar.Height = LVPlayers.Height
LVRules.Left = VerticalBar.Left + VerticalBar.Width
LVRules.Top = LVPlayers.Top
LVRules.Width = LVServers.Width - LVRules.Left
LVRules.Height = LVPlayers.Height
LVRules.ColumnHeaders(2).Width = LVRules.Width - LVRules.ColumnHeaders(1).Width - 920
HorizontalBar.Width = LVRules.Left + LVRules.Width
MenuSBar.Top = LVRules.Top + LVRules.Height
MenuSBar.Width = SBar.Width
If bIsLaunched = True Then
Hide
Show
TerminateWaitForm.WindowState = vbNormal
TerminateWaitForm.Show 1, LaunchForm
End If
End If
End Sub
Private Sub Form_Unload(Cancel As Integer)
'UnfixSize Me
RemoveLVType LVServers.hWnd
RemoveLVType LVRules.hWnd
'UnSubClassListViewParentWnd hWnd
Uninstall hWnd
Set HelpObj = Nothing
End
End Sub
Private Sub HelpObj_MenuHelp(ByVal MenuText As String, ByVal MenuHelp As String, ByVal Enabled As Boolean)
If Enabled And MenuText <> "" Then
MenuSBar.Panels(1).Text = MenuHelp
MenuSBar.Visible = True
SBar.Visible = False
Else
SBar.Visible = True
MenuSBar.Visible = False
End If
End Sub
Private Sub HighlightLockedMenu_Click()
HighlightLockedMenu.Checked = Not HighlightLockedMenu.Checked
LVServers.Refresh
End Sub
Private Sub HighlightProxyMenu_Click()
HighlightProxyMenu.Checked = Not HighlightProxyMenu.Checked
LVServers.Refresh
End Sub
Private Sub HorizontalBar_MouseDown(Button As Integer, Shift As Integer, x As Single, y As Single)
If Button = vbLeftButton Or (Button = vbRightButton And IsMouseSwapped()) Then
HorizontalBar.BackColor = GetSysColor(COLOR_APPWORKSPACE)
bHorizontalBarMoving = True
End If
End Sub
Private Sub HorizontalBar_MouseMove(Button As Integer, Shift As Integer, x As Single, y As Single)
If bHorizontalBarMoving Then
If y < 0 Then
If Height * 0.25 < LVServers.Height Then
HorizontalBar.Top = HorizontalBar.Top - 15
LVServers.Height = LVServers.Height - 15
LVPlayers.Height = LVPlayers.Height + 15
LVPlayers.Top = LVPlayers.Top - 15
VerticalBar.Height = VerticalBar.Height + 15
VerticalBar.Top = VerticalBar.Top - 15
LVRules.Height = LVRules.Height + 15
LVRules.Top = LVRules.Top - 15
End If
Else
If Width * 0.15 < LVPlayers.Height Then
HorizontalBar.Top = HorizontalBar.Top + 15
LVServers.Height = LVServers.Height + 15
LVPlayers.Height = LVPlayers.Height - 15
LVPlayers.Top = LVPlayers.Top + 15
VerticalBar.Height = VerticalBar.Height - 15
VerticalBar.Top = VerticalBar.Top + 15
LVRules.Height = LVRules.Height - 15
LVRules.Top = LVRules.Top + 15
End If
End If
End If
End Sub
Private Sub HorizontalBar_MouseUp(Button As Integer, Shift As Integer, x As Single, y As Single)
If Button = vbLeftButton Or (Button = vbRightButton And IsMouseSwapped()) Then
HorizontalBar.BackColor = GetSysColor(COLOR_BTNFACE)
bHorizontalBarMoving = False
LVServersP.ProportionX = LVServers.Width / Width
LVServersP.ProportionY = LVServers.Height / (Height - SBar.Height)
LVPlayersP.ProportionX = LVPlayers.Width / Width
LVPlayersP.ProportionY = LVPlayers.Height / (Height - SBar.Height)
End If
End Sub
Private Sub HowToRegisterMenu_Click()
LaunchURL "http://quickquery.jasonspcsoftware.com/howtoregister.shtml"
End Sub
Private Sub LanServersMenu_Click()
On Error Resume Next
Dim i As Integer
Dim wsHost As String
Dim wsPort As Long
Dim WSDataToSend As String
ReDim LastTimer(Optn_MaxConnections)
ReDim ServerList(0)
bRefreshingFavs = False
LVServers.ListItems.Clear
LVServers.Sorted = False
LVServers.SortOrder = Abs(CInt(Not CBool(LVServers.SortOrder)))
LVServers_HdrIcons.SetHeaderIcons -1, LVServers.SortOrder
LVPlayers.ListItems.Clear
LVRules.ListItems.Clear
CancelMenu.Visible = True
BoldCancelMenu
UpdateServersMenu.Visible = False
LanServersMenu.Visible = False
RefreshServersMenu.Visible = False
FilterMenu.Enabled = False
RefreshFavMenu.Enabled = False
SBar.Panels(2).Text = ""
SBar.Panels(3).Visible = True
If WS_QueryServer.UBound > 0 Then
SBar.Panels(1).Text = "Status: Unloading Used Winsock Controls..."
For i = WS_QueryServer.UBound To 1 Step -1
Unload WS_QueryServer(i)
Unload TimeoutTimer(i)
Next i
End If
SBar.Panels(1).Text = "Status: Loading Winsock Controls..."
For i = 1 To Optn_MaxConnections
Load WS_QueryServer(i)
Load TimeoutTimer(i)
TimeoutTimer(i).Interval = Optn_RequestTimeout
DoEvents
Next i
SCount = Optn_MaxConnections
PCount = 0
SBar.Panels(1).Text = "Status: Refreshing Servers..."
SBar.Panels(2).Text = SCount & " Servers Remaining"
SBar.Panels(2).Visible = True
For i = WS_QueryServer.LBound + 1 To WS_QueryServer.UBound
TimeoutTimer(i).Enabled = True
LastTimer(i) = Timer
WS_QueryServer(i).RemoteHost = "255.255.255.255"
WS_QueryServer(i).RemotePort = (27015 + (i - 1))
WS_QueryServer(i).SendData "����infostring"
Next i
End Sub
Private Sub LaunchMenu_Click()
Dim i As Long
LaunchForm.txtAddress.Text = LVServers.SelectedItem.SubItems(1)
Select Case LVServers.SelectedItem.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 = LVServers.SelectedItem.SubItems(3)
LaunchForm.Tag = LVServers.SelectedItem.Tag
LaunchForm.bHasPassword = False
If Optn_AutoPB = 1 Then
LaunchForm.bNoSet = True
LaunchForm.lstOptions.Selected(0) = False
LaunchForm.bNoSet = False
End If
If Optn_AutoPaladin = 1 Then
LaunchForm.bNoSet = True
LaunchForm.lstOptions.Selected(1) = False
LaunchForm.bNoSet = False
End If
If Optn_AutoCD = 1 Then
LaunchForm.bNoSet = True
LaunchForm.lstOptions.Selected(2) = False
LaunchForm.bNoSet = False
End If
If LVRules.ListItems.Count > 0 Then
If InStr(LVServers.SelectedItem.SubItems(1), ":") Then
If Left(LVServers.SelectedItem.SubItems(1), InStr(LVServers.SelectedItem.SubItems(1), ":") - 1) = WS_Rules.RemoteHostIP Then
For i = 1 To LVRules.ListItems.Count
If (LCase(LVRules.ListItems(i).Text) = "sv_contact" And InStr(LVRules.ListItems(i).SubItems(1), "{PB REQ}")) And Optn_AutoPB = 1 Then
LaunchForm.bNoSet = True
LaunchForm.lstOptions.Selected(0) = True
LaunchForm.bNoSet = False
ElseIf (LCase(LVRules.ListItems(i).Text) = "sv_contact" And InStr(LVRules.ListItems(i).SubItems(1), "{PALADIN REQ}")) And Optn_AutoPaladin = 1 Then
LaunchForm.bNoSet = True
LaunchForm.lstOptions.Selected(1) = True
LaunchForm.bNoSet = False
ElseIf (LCase(LVRules.ListItems(i).Text) = "cdrequired" And Val(LVRules.ListItems(i).SubItems(1)) > 0) And Optn_AutoCD = 1 Then
LaunchForm.bNoSet = True
LaunchForm.lstOptions.Selected(2) = True
LaunchForm.bNoSet = False
ElseIf LCase(LVRules.ListItems(i).Text) = "sv_password" And Val(LVRules.ListItems(i).SubItems(1)) > 0 Then
LaunchForm.bHasPassword = True
End If
Next i
End If
End If
End If
LaunchForm.Show 0, Me
End Sub
Private Sub LVPlayers_ColumnClick(ByVal ColumnHeader As ComctlLib.ColumnHeader)
LVPlayers.SortOrder = Abs(Not (LVPlayers.SortOrder * -1))
LVPlayers.SortKey = ColumnHeader.Index - 1
LVPlayers.Sorted = True
End Sub
Private Sub LVPlayers_KeyDown(KeyCode As Integer, Shift As Integer)
If KeyCode = KEY_F5 Then PlayersRefreshMenu_Click
End Sub
Private Sub LVPlayers_MouseUp(Button As Integer, Shift As Integer, x As Single, y As Single)
If Button = vbRightButton Or (Button = vbLeftButton And IsMouseSwapped()) Then PopupMenu LVPlayersPopupMenu, vbPopupMenuRightButton
End Sub
Private Sub LVRules_ColumnClick(ByVal ColumnHeader As ComctlLib.ColumnHeader)
LVRules.SortOrder = Abs(Not (LVRules.SortOrder * -1))
LVRules.SortKey = ColumnHeader.Index - 1
LVRules.Sorted = True
End Sub
Private Sub LVRules_KeyDown(KeyCode As Integer, Shift As Integer)
If KeyCode = KEY_F5 Then RulesRefreshMenu_Click
End Sub
Private Sub LVRules_MouseUp(Button As Integer, Shift As Integer, x As Single, y As Single)
If Button = vbRightButton Or (Button = vbLeftButton And IsMouseSwapped()) Then PopupMenu LVRulesPopupMenu, vbPopupMenuRightButton
End Sub
Private Sub LVServers_Click()
If LVServers.ListItems.Count = 0 Then
SBar.Panels(1).Text = "0 Servers (Click Here to Update)"
SBar.Panels(2).Text = "0 Players Online"
End If
End Sub
Private Sub LVServers_ColumnClick(ByVal ColumnHeader As ComctlLib.ColumnHeader)
If (ColumnHeader.Index - 1) = LVServers.SortKey Then LVServers.SortOrder = Abs(Not (LVServers.SortOrder * -1))
LVServers.SortKey = ColumnHeader.Index - 1
LVServers_HdrIcons.SetHeaderIcons LVServers.SortKey, LVServers.SortOrder
LVServers.Sorted = True
End Sub
Private Sub LVServers_DblClick()
If Not (LVServers.SelectedItem Is Nothing) Then
If LVServers.SelectedItem.Selected Then LaunchMenu_Click
End If
End Sub
Private Sub LVServers_ItemClick(ByVal Item As ComctlLib.ListItem)
On Error GoTo ErrHandler
LVPlayers.ListItems.Clear
LVPlayers.Sorted = False
LVPlayers.SortOrder = lvwDescending
WS_Players.Close
WS_Players.RemoteHost = Left(Item.SubItems(1), InStr(Item.SubItems(1), ":") - 1)
WS_Players.RemotePort = Val(Mid(Item.SubItems(1), InStr(Item.SubItems(1), ":") + 1))
WS_Players.SendData "����players"
LVRules.ListItems.Clear
LVRules.Sorted = False
LVRules.SortOrder = lvwDescending
WS_Rules.Close
WS_Rules.RemoteHost = Left(Item.SubItems(1), InStr(Item.SubItems(1), ":") - 1)
WS_Rules.RemotePort = Val(Mid(Item.SubItems(1), InStr(Item.SubItems(1), ":") + 1))
WS_Rules.SendData "����rules"
ErrHandler:
End Sub
Private Sub LVServers_KeyDown(KeyCode As Integer, Shift As Integer)
If KeyCode = KEY_F5 Then
If Not (LVServers.SelectedItem Is Nothing) Then
If LVServers.SelectedItem.Selected Then RefreshSelectedMenu_Click
End If
End If
End Sub
Private Sub LVServers_MouseUp(Button As Integer, Shift As Integer, x As Single, y As Single)
If Button = vbRightButton Or (Button = vbLeftButton And IsMouseSwapped()) Then
If Not (LVServers.SelectedItem Is Nothing) Then
If LVServers.SelectedItem.Selected Then
If Val(LVServers.SelectedItem.SubItems(8)) = 1 Then
RemoveFavoriteMenu.Visible = True
AddToFavsMenu.Visible = False
Else
AddToFavsMenu.Visible = True
RemoveFavoriteMenu.Visible = False
End If
PopupMenu LVServersPopupMenu, vbPopupMenuRightButton, , , LaunchMenu
End If
End If
End If
End Sub
Private Sub ManageFavMenu_Click()
ManageFavoritesForm.Show 1
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
SBar.Panels(1).Text = "0 Servers (Click Here to Update)"
SBar.Panels(2).Text = "0 Players Online"
SBar.Panels(3).Visible = False
CancelMenu.Visible = False
UpdateServersMenu.Visible = True
LanServersMenu.Visible = True
RefreshServersMenu.Visible = True
FilterMenu.Enabled = True
RefreshFavMenu.Enabled = True
BoldUpdateServersMenu
Exit Sub
End If
SBar.Panels(1).Text = "Status: Refreshing Servers..."
SBar.Panels(2).Text = SCount & " Servers Remaining"
For i = WS_QueryServer.LBound + 1 To WS_QueryServer.UBound
ServerIndex = ServerIndex + 1
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 "����infostring"
Next i
End Sub
Private Sub OnlineHelpMenu_Click()
LaunchURL "http://quickquery.jasonspcsoftware.com/documentation/"
End Sub
Private Sub OptionsMenu_Click()
OptionsForm.Show 1
End Sub
Private Sub PaladinMenu_Click()
LaunchURL "http://www.paladin-anticheat.com"
End Sub
Private Sub PBMenu_Click()
LaunchURL "http://www.punkbuster.com"
End Sub
Private Sub PingServerMenu_Click()
Dim iStatCode As Integer
Dim sStatMsg As String
Dim RetVal As Long
RetVal = PingIP(Left(LVServers.SelectedItem.SubItems(1), InStr(LVServers.SelectedItem.SubItems(1), ":") - 1), iStatCode, sStatMsg)
If iStatCode = 0 Then
LVServers.SelectedItem.SubItems(2) = String(5 - Len(CStr(RetVal)), "0") & RetVal
SetSubItemText LVServers.hWnd, LVServers.SelectedItem.Index - 1, 2, CStr(RetVal)
ElseIf iStatCode = 11010 Then
LVServers.SelectedItem.SubItems(2) = "09999"
SetSubItemText LVServers.hWnd, LVServers.SelectedItem.Index - 1, 2, "9999"
ElseIf iStatCode <> -1 Then
MsgBox "Ping error: " + sStatMsg, vbExclamation
End If
End Sub
Private Sub PlayersCopyMenu_Click()
Dim i As Integer
Dim i2 As Integer
For i = 1 To LVPlayers.ListItems.Count
txtCopy.Text = txtCopy.Text + LVPlayers.ListItems(i).Text
For i2 = 2 To LVPlayers.ColumnHeaders.Count
txtCopy.Text = txtCopy.Text + vbTab + IIf(i2 = 3, CStr(Val(LVPlayers.ListItems(i).SubItems(i2 - 1))), LVPlayers.ListItems(i).SubItems(i2 - 1))
Next i2
txtCopy.Text = txtCopy.Text + vbCrLf
Next i
txtCopy.SelStart = 0
txtCopy.SelLength = Len(txtCopy.Text)
ClipboardCut txtCopy.hWnd
End Sub
Private Sub PlayerSearchToolMenu_Click()
PlayerSearchForm.Show 0, Me
End Sub
Private Sub PlayersRefreshMenu_Click()
On Error Resume Next
LVPlayers.ListItems.Clear
WS_Players.Close
WS_Players.SendData "����players"
End Sub
Private Sub PostLoadTimer_Timer()
PostLoadTimer.Enabled = False
ProgressForm.TaskID = 1
ProgressForm.Show 1
End Sub
Private Sub RCONConsoleMenu_Click()
Dim NewRCONForm As New RCONForm
Load NewRCONForm
NewRCONForm.RCON_Address = Left(LVServers.SelectedItem.SubItems(1), InStr(LVServers.SelectedItem.SubItems(1), ":") - 1)
NewRCONForm.RCON_Port = CLng(Val(Mid(LVServers.SelectedItem.SubItems(1), InStr(LVServers.SelectedItem.SubItems(1), ":") + 1)))
NewRCONForm.Show 0, Me
End Sub
Private Sub RCONToolMenu_Click()
Dim NewRCONForm As New RCONForm
Load NewRCONForm
NewRCONForm.Show 0, Me
End Sub
Private Sub RefreshAllMenu_Click()
RefreshServersMenu_Click
End Sub
Private Sub RefreshFavMenu_Click()
On Error Resume Next
Dim i As Long
Dim wsHost As String
Dim wsPort As Long
SCount = UBound(FavoritesList)
If SCount = 0 Then
MsgBox "The favorites list is empty.", vbExclamation
Exit Sub
End If
ReDim LastTimer(Optn_MaxConnections)
ReDim ServerList(SCount)
ServerIndex = 0
bRefreshingFavs = True
CancelMenu.Visible = True
BoldCancelMenu
UpdateServersMenu.Visible = False
LanServersMenu.Visible = False
RefreshServersMenu.Visible = False
FilterMenu.Enabled = False
RefreshFavMenu.Enabled = False
SBar.Panels(2).Text = ""
SBar.Panels(3).Visible = True
If WS_QueryServer.UBound > 0 Then
SBar.Panels(1).Text = "Status: Unloading Used Winsock Controls..."
For i = WS_QueryServer.UBound To 1 Step -1
Unload WS_QueryServer(i)
Unload TimeoutTimer(i)
Next i
End If
SBar.Panels(1).Text = "Status: Loading Winsock Controls..."
For i = 1 To Optn_MaxConnections
Load WS_QueryServer(i)
Load TimeoutTimer(i)
TimeoutTimer(i).Interval = Optn_RequestTimeout
DoEvents
Next i
SBar.Panels(1).Text = "Status: Building Server List Array..."
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
DoEvents
Next i
LVServers.ListItems.Clear
LVServers.Sorted = False
LVServers.SortOrder = Abs(CInt(Not CBool(LVServers.SortOrder)))
LVServers_HdrIcons.SetHeaderIcons -1, LVServers.SortOrder
LVPlayers.ListItems.Clear
LVRules.ListItems.Clear
PCount = 0
SBar.Panels(1).Text = "Status: Refreshing Servers..."
SBar.Panels(2).Text = SCount & " Servers Remaining"
SBar.Panels(2).Visible = True
For i = WS_QueryServer.LBound + 1 To WS_QueryServer.UBound
ServerIndex = ServerIndex + 1
If ServerIndex > SCount Then Exit Sub
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 "����infostring"
Next i
End Sub
Private Sub RefreshSelectedMenu_Click()
On Error Resume Next
RefreshTimer = Timer
RefreshIndex = LVServers.SelectedItem.Index
WS_RefreshServer.Close
WS_RefreshServer.RemoteHost = Left(LVServers.SelectedItem.SubItems(1), InStr(LVServers.SelectedItem.SubItems(1), ":") - 1)
WS_RefreshServer.RemotePort = Val(Mid(LVServers.SelectedItem.SubItems(1), InStr(LVServers.SelectedItem.SubItems(1), ":") + 1))
WS_RefreshServer.SendData "����infostring"
End Sub
Private Sub RefreshServersMenu_Click()
On Error Resume Next
Dim i As Long
SCount = LVServers.ListItems.Count
If SCount = 0 Then
MsgBox "No servers to refresh, try updating first.", vbExclamation
Exit Sub
End If
ReDim LastTimer(Optn_MaxConnections)
ReDim ServerList(SCount)
ServerIndex = 0
bRefreshingFavs = False
CancelMenu.Visible = True
BoldCancelMenu
UpdateServersMenu.Visible = False
LanServersMenu.Visible = False
RefreshServersMenu.Visible = False
FilterMenu.Enabled = False
RefreshFavMenu.Enabled = False
SBar.Panels(2).Text = ""
SBar.Panels(3).Visible = True
If WS_QueryServer.UBound > 0 Then
SBar.Panels(1).Text = "Status: Unloading Used Winsock Controls..."
For i = WS_QueryServer.UBound To 1 Step -1
Unload WS_QueryServer(i)
Unload TimeoutTimer(i)
Next i
End If
SBar.Panels(1).Text = "Status: Loading Winsock Controls..."
For i = 1 To Optn_MaxConnections
Load WS_QueryServer(i)
Load TimeoutTimer(i)
TimeoutTimer(i).Interval = Optn_RequestTimeout
DoEvents
Next i
SBar.Panels(1).Text = "Status: Building Server List Array..."
For i = 1 To SCount
ServerList(i).IP = Left(LVServers.ListItems(i).SubItems(1), InStr(LVServers.ListItems(i).SubItems(1), ":") - 1)
ServerList(i).Port = Val(Mid(LVServers.ListItems(i).SubItems(1), InStr(LVServers.ListItems(i).SubItems(1), ":") + 1))
DoEvents
Next i
LVServers.ListItems.Clear
LVServers.Sorted = False
LVServers.SortOrder = Abs(CInt(Not CBool(LVServers.SortOrder)))
LVServers_HdrIcons.SetHeaderIcons -1, LVServers.SortOrder
LVPlayers.ListItems.Clear
LVRules.ListItems.Clear
PCount = 0
SBar.Panels(1).Text = "Status: Refreshing Servers..."
SBar.Panels(2).Text = SCount & " Servers Remaining"
SBar.Panels(2).Visible = True
For i = WS_QueryServer.LBound + 1 To WS_QueryServer.UBound
ServerIndex = ServerIndex + 1
If ServerIndex > SCount Then Exit Sub
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 "����infostring"
Next i
End Sub
Private Sub RegMenu_Click()
RegForm.Show 1
End Sub
Private Sub RemoveFavoriteMenu_Click()
Dim i As Long
Dim i2 As Long
For i = 1 To UBound(FavoritesList)
If LCase(LVServers.SelectedItem.SubItems(1)) = LCase(FavoritesList(i)) Then
For i2 = i + 1 To UBound(FavoritesList)
FavoritesList(i2 - 1) = FavoritesList(i2)
Next i2
ReDim Preserve FavoritesList(UBound(FavoritesList) - 1)
LVServers.SelectedItem.SubItems(8) = ""
Exit For
End If
Next i
End Sub
Private Sub RemoveServerMenu_Click()
LVServers.ListItems.Remove LVServers.SelectedItem.Index
If Not (LVServers.SelectedItem Is Nothing) Then
LVServers.SelectedItem.Selected = True
PCount = PCount + Val(Left(LVServers.SelectedItem.SubItems(5), InStr(LVServers.SelectedItem.SubItems(5), "/") - 1))
SBar.Panels(1).Text = LVServers.ListItems.Count & " Server" + IIf(LVServers.ListItems.Count = 1, "", "s")
SBar.Panels(2).Text = PCount & " Player" + IIf(PCount = 1, "", "s") + " Online"
Else
WS_RefreshServer.Close
WS_Players.Close
WS_Rules.Close
LVPlayers.ListItems.Clear
LVRules.ListItems.Clear
End If
End Sub
Private Sub RulesCopyMenu_Click()
Dim i As Integer
Dim i2 As Integer
For i = 1 To LVRules.ListItems.Count
txtCopy.Text = txtCopy.Text + LVRules.ListItems(i).Text
For i2 = 2 To LVRules.ColumnHeaders.Count
txtCopy.Text = txtCopy.Text + vbTab + LVRules.ListItems(i).SubItems(i2 - 1)
Next i2
txtCopy.Text = txtCopy.Text + vbCrLf
Next i
txtCopy.SelStart = 0
txtCopy.SelLength = Len(txtCopy.Text)
ClipboardCut txtCopy.hWnd
End Sub
Private Sub RulesRefreshMenu_Click()
On Error Resume Next
LVRules.ListItems.Clear
WS_Rules.Close
WS_Rules.SendData "����rules"
End Sub
Private Sub SBar_PanelClick(ByVal Panel As ComctlLib.Panel)
Select Case Panel.Index
Case 1
If Panel.Text = "0 Servers (Click Here to Update)" Then UpdateServersMenu_Click
Case 3
CancelMenu_Click
Case 4
If FilterMenu.Enabled Then FilterMenu_Click
End Select
End Sub
Private Sub ServerDetailsMenu_Click()
On Error Resume Next
DetailsForm.lblDetails.Caption = "&Details for " + LVServers.SelectedItem.SubItems(1) + ":"
DetailsForm.Show 0, Me
If DetailsForm.Command2.Caption = "DNS &Address <<" Then
DetailsForm.Height = DetailsForm.txtDNS.Top + (DetailsForm.Height - DetailsForm.ScaleHeight) - 105
DetailsForm.Command2.Caption = "DNS &Address >>"
DetailsForm.txtDNS.TabStop = False
End If
DetailsForm.LVDetails.ListItems.Clear
DetailsForm.WS_Details.Close
DetailsForm.WS_Details.RemoteHost = Left(LVServers.SelectedItem.SubItems(1), InStr(LVServers.SelectedItem.SubItems(1), ":") - 1)
DetailsForm.WS_Details.RemotePort = Mid(LVServers.SelectedItem.SubItems(1), InStr(LVServers.SelectedItem.SubItems(1), ":") + 1)
DetailsForm.WS_Details.SendData "����infostring"
End Sub
Private Sub ServerQueryMenu_Click()
ServerQueryForm.Show 0, Me
End Sub
Private Sub ShowRegFormTimer_Timer()
ShowRegFormTimer.Enabled = False
RegForm.Show 1
End Sub
Private Sub TimeoutTimer_Timer(Index As Integer)
On Error Resume Next
Dim NewIndex As Long
TimeoutTimer(Index).Enabled = False
ServerIndex = ServerIndex + 1
If Filter_AreResponding = 0 Then
With LVServers.ListItems.Add()
.SubItems(1) = IIf(WS_QueryServer(Index).RemoteHostIP = "", WS_QueryServer(Index).RemoteHost, WS_QueryServer(Index).RemoteHostIP) & ":" & WS_QueryServer(Index).RemotePort
.SubItems(2) = "9999"
.SubItems(3) = "-"
.SubItems(4) = "-"
.SubItems(5) = "-"
NewIndex = .Index
End With
SetSubItemText LVServers.hWnd, NewIndex - 1, 2, "9999"
End If
If ServerIndex > UBound(ServerList) Then
If LVServers.ListItems.Count = 0 Then
SBar.Panels(1).Text = "0 Servers (Click Here to Update)"
Else
SBar.Panels(1).Text = LVServers.ListItems.Count & " Server" + IIf(LVServers.ListItems.Count = 1, "", "s")
End If
SBar.Panels(2).Text = PCount & " Player" + IIf(PCount = 1, "", "s") + " Online"
SBar.Panels(3).Visible = False
CancelMenu.Visible = False
UpdateServersMenu.Visible = True
LanServersMenu.Visible = True
RefreshServersMenu.Visible = True
FilterMenu.Enabled = True
RefreshFavMenu.Enabled = True
If Optn_bSort = 1 Then
LVServers.SortOrder = IIf((Optn_iSort / 2) = Int(Optn_iSort / 2), lvwAscending, lvwDescending)
LVServers.SortKey = Int(Optn_iSort / 2)
LVServers_HdrIcons.SetHeaderIcons LVServers.SortKey, LVServers.SortOrder
LVServers.Sorted = True
End If
If Optn_UnloadWSControls = 1 Then
Unload WS_QueryServer(Index)
Unload TimeoutTimer(Index)
End If
Exit Sub
End If
SBar.Panels(1).Text = "Status: Refreshing " & ServerList(ServerIndex).IP & ":" & ServerList(ServerIndex).Port & "..."
SBar.Panels(2).Text = (UBound(ServerList) - ServerIndex) & " Servers Remaining"
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
WS_QueryServer(Index).SendData "����infostring"
End Sub
Private Sub UpdateCheckMenu_Click()
LaunchURL "http://quickquery.jasonspcsoftware.com/php/updatecheck.php?ver=" + Ver + "®istered=" + IIf(bReg_Valid, "1", "0")
End Sub
Private Sub UpdateServersMenu_Click()
On Error Resume Next
Dim i As Integer
Dim wsHost As String
Dim wsPort As Long
Dim WSDataToSend As String
ReDim LastTimer(Optn_MaxConnections)
ReDim ServerList(0)
ServerIndex = 0
bRefreshingFavs = False
LVServers.ListItems.Clear
LVServers.Sorted = False
LVServers.SortOrder = Abs(CInt(Not CBool(LVServers.SortOrder)))
LVServers_HdrIcons.SetHeaderIcons -1, LVServers.SortOrder
LVPlayers.ListItems.Clear
LVRules.ListItems.Clear
CancelMenu.Visible = True
BoldCancelMenu
UpdateServersMenu.Visible = False
LanServersMenu.Visible = False
RefreshServersMenu.Visible = False
FilterMenu.Enabled = False
RefreshFavMenu.Enabled = False
SBar.Panels(2).Text = ""
SBar.Panels(3).Visible = True
If WS_QueryServer.UBound > 0 Then
SBar.Panels(1).Text = "Status: Unloading Used Winsock Controls..."
For i = WS_QueryServer.UBound To 1 Step -1
Unload WS_QueryServer(i)
Unload TimeoutTimer(i)
Next i
End If
SBar.Panels(1).Text = "Status: Loading Winsock Controls..."
For i = 1 To Optn_MaxConnections
Load WS_QueryServer(i)
Load TimeoutTimer(i)
TimeoutTimer(i).Interval = Optn_RequestTimeout
DoEvents
Next i
SBar.Panels(1).Text = "Status: Downloading Server List..."
SCount = 0
PCount = 0
bServersDone = False
MSTimeoutTimer.Enabled = True
WS_GetServerList.Close
wsHost = Optn_MasterServer
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(Filter_Dedicated = 1, "\dedicated\1", "") + _
IIf(Filter_RunningGame = 1, IIf(Filter_GameName <> "", "\gamedir\" + Filter_GameName, ""), "") + _
IIf(Filter_RunningMap = 1, IIf(Filter_MapName <> "", "\map\" + Filter_MapName, ""), "") + _
IIf(Filter_Linux = 1, "\linux\1", "") + IIf(Filter_NotEmpty = 1, "\empty\1", "") + _
IIf(Filter_NotFull = 1, "\full\1", "") + IIf(Filter_Proxy = 0, "\type\p", "") & vbNullChar
WS_GetServerList.SendData WSDataToSend
If Err.Number <> 0 Then WS_GetServerList.SendData WSDataToSend
End Sub
Private Sub VerticalBar_MouseDown(Button As Integer, Shift As Integer, x As Single, y As Single)
If Button = vbLeftButton Or (Button = vbRightButton And IsMouseSwapped()) Then
VerticalBar.BackColor = GetSysColor(COLOR_APPWORKSPACE)
bVerticalBarMoving = True
End If
End Sub
Private Sub VerticalBar_MouseMove(Button As Integer, Shift As Integer, x As Single, y As Single)
If bVerticalBarMoving Then
If x < 0 Then
If Width * 0.3 < LVPlayers.Width Then
VerticalBar.Left = VerticalBar.Left - 15
LVPlayers.Width = LVPlayers.Width - 15
LVRules.Width = LVRules.Width + 15
LVRules.Left = LVRules.Left - 15
End If
Else
If Width * 0.3 < LVRules.Width Then
VerticalBar.Left = VerticalBar.Left + 15
LVPlayers.Width = LVPlayers.Width + 15
LVRules.Width = LVRules.Width - 15
LVRules.Left = LVRules.Left + 15
End If
End If
LVPlayers.ColumnHeaders(2).Width = LVPlayers.Width - (LVPlayers.ColumnHeaders(1).Width + LVPlayers.ColumnHeaders(3).Width) - 2090
LVRules.ColumnHeaders(2).Width = LVRules.Width - LVRules.ColumnHeaders(1).Width - 920
End If
End Sub
Private Sub VerticalBar_MouseUp(Button As Integer, Shift As Integer, x As Single, y As Single)
If Button = vbLeftButton Or (Button = vbRightButton And IsMouseSwapped()) Then
VerticalBar.BackColor = GetSysColor(COLOR_BTNFACE)
bVerticalBarMoving = False
LVPlayersP.ProportionX = LVPlayers.Width / Width
LVPlayersP.ProportionY = LVPlayers.Height / (Height - SBar.Height)
End If
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 Optn_LimitServers And UBound(ServerList) >= Optn_MaxServers Then
UniqueKey = String(4, vbNullChar)
Exit For
End If
Next i
SCount = UBound(ServerList)
SBar.Panels(1).Text = "Status: Downloading Server List (" & SCount & ")..."
Else
MsgBox "Bad master server response." & vbCrLf & vbCrLf & "Please try again later.", vbExclamation
SBar.Panels(1).Text = "0 Servers (Click Here to Update)"
SBar.Panels(2).Text = "0 Players Online"
SBar.Panels(3).Visible = False
CancelMenu.Visible = False
UpdateServersMenu.Visible = True
LanServersMenu.Visible = True
RefreshServersMenu.Visible = True
FilterMenu.Enabled = True
RefreshFavMenu.Enabled = True
BoldUpdateServersMenu
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(Filter_Dedicated = 1, "\dedicated\1", "") + _
IIf(Filter_RunningGame = 1, IIf(Filter_GameName <> "", "\gamedir\" + Filter_GameName, ""), "") + _
IIf(Filter_RunningMap = 1, IIf(Filter_MapName <> "", "\map\" + Filter_MapName, ""), "") + _
IIf(Filter_Linux = 1, "\linux\1", "") + IIf(Filter_NotEmpty = 1, "\empty\1", "") + _
IIf(Filter_NotFull = 1, "\full\1", "") + IIf(Filter_Proxy = 0, "\type\p", "") & 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
SBar.Panels(1).Text = "0 Servers (Click Here to Update)"
SBar.Panels(2).Text = "0 Players Online"
SBar.Panels(3).Visible = False
CancelMenu.Visible = False
UpdateServersMenu.Visible = True
LanServersMenu.Visible = True
RefreshServersMenu.Visible = True
FilterMenu.Enabled = True
RefreshFavMenu.Enabled = True
BoldUpdateServersMenu
Exit Sub
End If
SBar.Panels(1).Text = "Status: Refreshing Servers..."
SBar.Panels(2).Text = SCount & " Servers Remaining"
For i = WS_QueryServer.LBound + 1 To WS_QueryServer.UBound
ServerIndex = ServerIndex + 1
If Optn_LimitServers = 1 And ServerIndex > Optn_MaxServers Then Exit For
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 "����infostring"
Next i
End If
Exit Sub
ErrHandler:
MsgBox "An unknown error occurred while obtaining the server list." & vbCrLf & vbCrLf & "Please try again later.", vbExclamation
SBar.Panels(1).Text = "0 Servers (Click Here to Update)"
SBar.Panels(2).Text = "0 Players Online"
SBar.Panels(3).Visible = False
CancelMenu.Visible = False
UpdateServersMenu.Visible = True
LanServersMenu.Visible = True
RefreshServersMenu.Visible = True
FilterMenu.Enabled = True
RefreshFavMenu.Enabled = True
BoldUpdateServersMenu
End Sub
Private Sub WS_Players_DataArrival(ByVal bytesTotal As Long)
On Error Resume Next
Dim RecvData As String
Dim PlayerTotal As Integer
Dim PlayerFrags As Long
Dim PlayerTime As String
Dim binPlayerTime As String
Dim lngSecs As Long
Dim lngSecs2 As Long
Dim lngHours As Long
Dim lngMins As Long
Dim i As Integer
Dim i2 As Long
Dim i3 As Integer
Dim NewIndex As Long
Dim strSubItem1 As String
WS_Players.GetData RecvData
WS_Players.Close
i2 = 7
PlayerTotal = Asc(Mid(RecvData, 6, 1))
For i = 1 To PlayerTotal
With LVPlayers.ListItems.Add
.Text = Asc(Mid(RecvData, i2, 1))
strText = CStr(Asc(Mid(RecvData, i2, 1)))
i2 = i2 + 1
.SubItems(1) = Mid(RecvData, i2, InStr(i2 + 1, RecvData, vbNullChar) - i2)
i2 = InStr(i2, RecvData, vbNullChar) + 1
PlayerFrags = Asc(Mid(RecvData, i2, 1)) + Asc(Mid(RecvData, i2 + 1, 1)) + Asc(Mid(RecvData, i2 + 2, 1)) + Asc(Mid(RecvData, i2 + 3, 1))
If PlayerFrags > 512 Then PlayerFrags = -(1021 - PlayerFrags)
strSubItem1 = CStr(PlayerFrags)
.SubItems(2) = IIf(PlayerFrags < 0, "-", "") + String(3 - Len(strSubItem1), "0") & Abs(PlayerFrags)
i2 = i2 + 4
PlayerTime = ""
For i3 = 0 To 3
binPlayerTime = Dec2Bin(Asc(Mid(RecvData, i2 + i3, 1)))
If Len(binPlayerTime) < 8 Then binPlayerTime = String(8 - Len(binPlayerTime), "0") + binPlayerTime
PlayerTime = binPlayerTime + PlayerTime
Next i3
lngSecs = Float2Int(PlayerTime)
lngHours = Fix(lngSecs / 3600)
lngSecs = lngSecs - (lngHours * 3600)
lngMins = Fix(lngSecs / 60)
lngSecs2 = lngSecs - (lngMins * 60)
.SubItems(3) = Format(lngHours, "00:") & Format(lngMins, "00:") & Format(lngSecs2, "00")
i2 = i2 + 4
NewIndex = .Index
End With
SetSubItemText LVPlayers.hWnd, NewIndex - 1, 2, strSubItem1
Next i
End Sub
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 Settings() As String
Dim PlayerCount As Integer
Dim i As Integer
Dim NewIndex As Long
Dim LIndex As Long
WS_QueryServer(Index).GetData RecvData
WS_QueryServer(Index).Close
TimeoutTimer(Index).Enabled = False
If RecvData = "" Then GoTo NextServer
ServerPing = Abs(Round(Timer - LastTimer(Index), 3) * 1000)
If ServerPing > Optn_RequestTimeout Then GoTo NextServer
RecvData = Mid(RecvData, InStr(RecvData, vbNullChar) + 2)
If InStr(RecvData, vbNullChar) Then RecvData = Left(RecvData, InStr(RecvData, vbNullChar) - 1)
Settings = Split(RecvData, "\")
With LVServers.ListItems.Add
.SubItems(1) = WS_QueryServer(Index).RemoteHostIP & ":" & WS_QueryServer(Index).RemotePort
.SubItems(2) = String(5 - Len(CStr(ServerPing)), "0") & ServerPing
For i = 0 To UBound(Settings) Step 2
If Settings(i) = "hostname" Then .Text = Settings(i + 1)
If Settings(i) = "description" Then .SubItems(3) = Settings(i + 1)
If Settings(i) = "gamedir" Then
.Tag = LCase(Settings(i + 1))
Select Case .Tag
Case "action"
.SmallIcon = 7
Case "cstrike"
.SmallIcon = 3
Case "dmc"
.SmallIcon = 4
Case "dod"
.SmallIcon = 5
Case "firearms"
.SmallIcon = 6
Case "frontline"
.SmallIcon = 8
Case "tfc"
.SmallIcon = 2
Case "valve"
.SmallIcon = 1
End Select
If Filter_RunningGame = 1 And Filter_GameName <> "" Then
If LCase(.Tag) <> LCase(Filter_GameName) Then LIndex = .Index
End If
End If
If Settings(i) = "map" Then
.SubItems(4) = Settings(i + 1)
If Filter_RunningMap = 1 And Filter_MapName <> "" Then
If LCase(.SubItems(4)) <> LCase(Filter_MapName) Then LIndex = .Index
End If
End If
If Settings(i) = "players" Then PlayerCount = Settings(i + 1)
If Settings(i) = "max" Then
.SubItems(5) = PlayerCount & "/" & Settings(i + 1)
PCount = PCount + PlayerCount
If Filter_NotEmpty = 1 Then
If PlayerCount = 0 Then LIndex = .Index
End If
If Filter_NotFull = 1 Then
If PlayerCount = Settings(i + 1) Then LIndex = .Index
End If
End If
If Settings(i) = "password" Then .SubItems(6) = Settings(i + 1)
If Settings(i) = "type" Then
.SubItems(7) = Settings(i + 1)
If Filter_Proxy = 1 Then
If Settings(i + 1) <> "p" Then LIndex = .Index
End If
If Filter_Proxy = 2 Then
If Settings(i + 1) = "p" Then LIndex = .Index
End If
End If
Next i
NewIndex = .Index
End With
SetSubItemText LVServers.hWnd, NewIndex - 1, 2, CStr(ServerPing)
If LIndex > 0 And (bRefreshingFavs = False Or (bRefreshingFavs = True And Optn_FilterFavorites = 1)) Then
PCount = PCount - PlayerCount
LVServers.ListItems.Remove LIndex
ElseIf Not (bRefreshingFavs = False Or (bRefreshingFavs = True And Optn_FilterFavorites = 1)) Then
LVServers.ListItems(NewIndex).SubItems(8) = "1"
End If
NextServer:
ServerIndex = ServerIndex + 1
If ServerIndex > UBound(ServerList) Then
If LVServers.ListItems.Count = 0 Then
SBar.Panels(1).Text = "0 Servers (Click Here to Update)"
Else
SBar.Panels(1).Text = LVServers.ListItems.Count & " Server" + IIf(LVServers.ListItems.Count = 1, "", "s")
End If
SBar.Panels(2).Text = PCount & " Player" + IIf(PCount = 1, "", "s") + " Online"
SBar.Panels(3).Visible = False
CancelMenu.Visible = False
UpdateServersMenu.Visible = True
LanServersMenu.Visible = True
RefreshServersMenu.Visible = True
FilterMenu.Enabled = True
RefreshFavMenu.Enabled = True
If Optn_bSort = 1 Then
LVServers.SortOrder = IIf((Optn_iSort / 2) = Int(Optn_iSort / 2), lvwAscending, lvwDescending)
LVServers.SortKey = Int(Optn_iSort / 2)
LVServers_HdrIcons.SetHeaderIcons LVServers.SortKey, LVServers.SortOrder
LVServers.Sorted = True
End If
If Optn_UnloadWSControls = 1 Then
Unload WS_QueryServer(Index)
Unload TimeoutTimer(Index)
End If
Exit Sub
End If
SBar.Panels(1).Text = "Status: Refreshing " & ServerList(ServerIndex).IP & ":" & ServerList(ServerIndex).Port & "..."
SBar.Panels(2).Text = (UBound(ServerList) - ServerIndex) & " Servers Remaining"
TimeoutTimer(Index).Enabled = True
LastTimer(Index) = Timer
WS_QueryServer(Index).RemoteHost = ServerList(ServerIndex).IP
WS_QueryServer(Index).RemotePort = ServerList(ServerIndex).Port
WS_QueryServer(Index).SendData "����infostring"
End Sub
Private Sub WS_RefreshServer_DataArrival(ByVal bytesTotal As Long)
On Error Resume Next
Dim RecvData As String
Dim ServerPing As Long
Dim Settings() As String
Dim PlayerCount As Integer
Dim OldPlayerCount As Integer
Dim i As Integer
Dim LIndex As Long
WS_RefreshServer.GetData RecvData
WS_RefreshServer.Close
If RecvData = "" Then
LVServers.ListItems.Remove RefreshIndex
Exit Sub
End If
ServerPing = Abs(Round(Timer - RefreshTimer, 3) * 1000)
RecvData = Mid(RecvData, InStr(RecvData, vbNullChar) + 2)
If InStr(RecvData, vbNullChar) Then RecvData = Left(RecvData, InStr(RecvData, vbNullChar) - 1)
Settings = Split(RecvData, "\")
With LVServers.ListItems(RefreshIndex)
OldPlayerCount = Val(Left(.SubItems(5), InStr(.SubItems(5), "/") - 1))
.SubItems(2) = String(5 - Len(CStr(ServerPing)), "0") & ServerPing
For i = 0 To UBound(Settings) Step 2
If Settings(i) = "hostname" Then .Text = Settings(i + 1)
If Settings(i) = "description" Then .SubItems(3) = Settings(i + 1)
If Settings(i) = "gamedir" Then
.Tag = LCase(Settings(i + 1))
Select Case .Tag
Case "action"
.SmallIcon = 7
Case "cstrike"
.SmallIcon = 3
Case "dmc"
.SmallIcon = 4
Case "dod"
.SmallIcon = 5
Case "firearms"
.SmallIcon = 6
Case "frontline"
.SmallIcon = 8
Case "tfc"
.SmallIcon = 2
Case "valve"
.SmallIcon = 1
End Select
If Filter_RunningGame = 1 And Filter_GameName <> "" Then
If LCase(.Tag) <> LCase(Filter_GameName) Then LIndex = .Index
End If
End If
If Settings(i) = "map" Then
.SubItems(4) = Settings(i + 1)
If Filter_RunningMap = 1 And Filter_MapName <> "" Then
If LCase(.SubItems(4)) <> LCase(Filter_MapName) Then LIndex = .Index
End If
End If
If Settings(i) = "players" Then PlayerCount = Settings(i + 1)
If Settings(i) = "max" Then
.SubItems(5) = PlayerCount & "/" & Settings(i + 1)
If PlayerCount <> OldPlayerCount Then
PCount = PCount + (PlayerCount - OldPlayerCount)
SBar.Panels(2).Text = PCount & " Player" + IIf(PCount = 1, "", "s") + " Online"
End If
If Filter_NotEmpty = 1 Then
If PlayerCount = 0 Then LIndex = .Index
End If
If Filter_NotFull = 1 Then
If PlayerCount = Settings(i + 1) Then LIndex = .Index
End If
End If
If Settings(i) = "password" Then .SubItems(6) = Settings(i + 1)
If Settings(i) = "type" Then
.SubItems(7) = Settings(i + 1)
If Filter_Proxy = 1 Then
If Settings(i + 1) <> "p" Then LIndex = .Index
End If
If Filter_Proxy = 2 Then
If Settings(i + 1) = "p" Then LIndex = .Index
End If
End If
Next i
SetSubItemText LVServers.hWnd, .Index - 1, 2, CStr(ServerPing)
End With
If LIndex > 0 And Val(LVServers.ListItems(RefreshIndex).SubItems(8)) = 0 Then
PCount = PCount - PlayerCount
LVServers.ListItems.Remove LIndex
If LVServers.ListItems.Count = 0 Then
SBar.Panels(1).Text = "0 Servers (Click Here to Update)"
SBar.Panels(2).Text = "0 Players Online"
BoldUpdateServersMenu
End If
End If
End Sub
Private Sub WS_Rules_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_Rules.GetData RecvData
WS_Rules.Close
i2 = InStr(7, RecvData, vbNullChar) + 1
TotalRules = Asc(Mid(RecvData, 6, 1))
For i = 1 To TotalRules
With LVRules.ListItems.Add
.Text = Mid(RecvData, i2, InStr(i2 + 1, RecvData, vbNullChar) - i2)
i2 = InStr(i2, RecvData, vbNullChar) + 1
.SubItems(1) = Mid(RecvData, i2, InStr(i2 + 1, RecvData, vbNullChar) - i2)
i2 = InStr(i2, RecvData, vbNullChar) + 1
If (.Text = "sv_password" And Val(.SubItems(1)) > 0) Or _
(.Text = "mp_friendlyfire" And Val(.SubItems(1)) > 0) Or _
(.Text = "reserve_slots" And Val(.SubItems(1)) > 0) Or _
(.Text = "cdrequired" And Val(.SubItems(1)) > 0) Or _
(.Text = "sv_contact" And InStr(.SubItems(1), "{PB REQ}")) Or _
(.Text = "sv_contact" And InStr(.SubItems(1), "{PALADIN REQ}")) Then
LIndex = .Index
strText = .Text
strSubItem = .SubItems(1)
End If
End With
If LIndex > 0 Then
LVRules.ListItems.Remove LIndex
With LVRules.ListItems.Add(1)
.Text = strText
.SubItems(1) = strSubItem
End With
LIndex = 0
End If
Next i
ErrHandler:
End Sub
Download QuickQuery HL Edition/MainForm.frm