Option Explicit
Dim strVars() As String
Dim colPlayers As Collection
Private Sub Form_Load()
On Error GoTo handle
Dim strTemp As String
If Command = "" Then
Err.Raise 60000
Else
strTemp = BeforeFirst(Command, " ")
If strTemp = "" Then
Err.Raise 60000
Else
Winsock.RemoteHost = strTemp
End If
strTemp = AfterFirst(Command, " ")
If strTemp = "" Then
Err.Raise 60000
Else
Winsock.RemotePort = strTemp
End If
End If
' Winsock.RemoteHost = "193.163.220.190"
' Winsock.RemotePort = 27974
Winsock.SendData "ÿÿÿÿgetstatus"
Exit Sub
handle:
Select Case Err.Number
Case 60000
MsgBox "Invalid input, most be: quake3info.exe <server_ip> <server_port>", vbCritical, "Invalid input"
Case Else
Err.Raise Err.Number, Err.Source, Err.Description, Err.HelpFile, Err.HelpContext
End Select
Unload Me
End Sub
Private Sub Winsock_DataArrival(ByVal bytesTotal As Long)
Dim strData As String
Winsock.GetData strData
ParseResult strData
End Sub
Private Sub ParseResult(strResult As String)
Dim intPos As Integer
Dim strTemp As String
'fjerner ÿÿÿÿstatusResponse og chr(10)
strResult = Mid(strResult, 21)
'finder ud af hvor player navnene begynder
intPos = InStr(1, strResult, Chr(10))
'Udtrækker indstillingerne
strTemp = Left(strResult, intPos - 1)
'Parser server indstillingerne
ParseVars strTemp
'Finder players
ParsePlayers Mid(strResult, intPos + 1)
Select Case GetVar("gamename")
Case "osp"
'Så skal players sættes på hold
'Players_Red
Asignteam GetVar("Players_Red"), "Red"
'Players_Blue
Asignteam GetVar("Players_Blue"), "Blue"
Case "arena"
End Select
SortPlayers
WriteDoc
End Sub
Private Sub ParseVars(strSettings As String)
Dim intPos As Integer, intTemp As Integer, intSize As Integer, i As Integer
Dim blnValue As Boolean
Dim strTemp As String, strName As String
Dim ting As Variant
ReDim strVars(2, 0)
Do
intTemp = InStr(intPos + 1, strSettings, "\")
If intTemp <> 0 Then
strTemp = Mid(strSettings, intPos + 1, intTemp - intPos - 1)
Else
strTemp = Mid(strSettings, intPos + 1)
End If
If blnValue Then
intSize = UBound(strVars, 2) + 1
ReDim Preserve strVars(2, intSize)
strVars(0, intSize) = strName
strVars(1, intSize) = strTemp
blnValue = False
Else
strName = strTemp
blnValue = True
End If
intPos = intTemp
Loop While intPos <> 0
End Sub
Private Sub ParsePlayers(strPlayers As String)
Dim intTemp As Integer, intPos As Integer, intFrags As Integer, intPing As Integer, intNumber As Integer
Dim strTemp As String, strName As String
Dim objPlayer As clsPlayer
Set colPlayers = New Collection
strPlayers = Replace(strPlayers, Chr(34), "")
If Left(strPlayers, 1) = Chr(10) Then
strPlayers = Right(strPlayers, Len(strPlayers) - 1)
End If
If Right(strPlayers, 1) = Chr(10) Then
strPlayers = Left(strPlayers, Len(strPlayers) - 1)
End If
Do
intNumber = intNumber + 1
intTemp = InStr(intPos + 1, strPlayers, Chr(10))
If intTemp <> 0 Then
strTemp = Mid(strPlayers, intPos + 1, intTemp - intPos - 1)
Else
strTemp = Mid(strPlayers, intPos + 1)
End If
If strTemp = "" Then Exit Do
intFrags = BeforeFirst(strTemp, " ")
strTemp = AfterFirst(strTemp, " ")
intPing = BeforeFirst(strTemp, " ")
strName = AfterFirst(strTemp, " ")
Set objPlayer = New clsPlayer
objPlayer.Frags = intFrags
objPlayer.Ping = intPing
objPlayer.Name = strName
objPlayer.Number = intNumber
colPlayers.Add objPlayer, objPlayer.Name
intPos = intTemp
Loop While intPos <> 0
End Sub
Public Function GetVar(strName As String) As String
Dim i As Integer
For i = 1 To UBound(strVars, 2)
If strVars(0, i) = strName Then
GetVar = strVars(1, i)
End If
Next
End Function
Private Sub Asignteam(strNumbers As String, strTeamName As String)
Dim strTemp As String
Dim objPlayer As clsPlayer
Do While strNumbers <> ""
strTemp = BeforeFirst(strNumbers, " ")
strNumbers = AfterFirst(strNumbers, " ")
For Each objPlayer In colPlayers
If objPlayer.Number = strTemp Then
objPlayer.Team = strTeamName
Exit For
End If
Next objPlayer
Loop
End Sub
Private Sub SortPlayers()
Dim i As Integer, j As Integer
Dim objPlayer As clsPlayer
Dim col As New Collection
Dim blnPlaced As Boolean
For i = 1 To colPlayers.Count
blnPlaced = False
For j = 1 To col.Count
If colPlayers(i).Frags > col(j).Frags Then
col.Add colPlayers(i), colPlayers(i).Name, j
blnPlaced = True
Exit For
End If
Next j
If blnPlaced = False Then
col.Add colPlayers(i), colPlayers(i).Name
End If
Next i
Set colPlayers = col
End Sub
Public Sub WriteDoc()
Dim doc As New DOMDocument
Dim root As IXMLDOMElement
Dim element As IXMLDOMElement, subelement As IXMLDOMElement, e As IXMLDOMElement
Dim node As IXMLDOMNode
Dim objPlayer As clsPlayer
Set root = doc.createElement("server")
doc.appendChild root
Set element = doc.createElement("refreshed")
root.appendChild element
Set node = doc.createTextNode(Format(Now(), "hh:nn:ss dd-mm-yyyy"))
element.appendChild node
Set element = doc.createElement("gametype")
root.appendChild element
Set node = doc.createTextNode(GetVar("gamename"))
element.appendChild node
Set element = doc.createElement("score")
root.appendChild element
Set subelement = doc.createElement("Red")
element.appendChild subelement
Set node = doc.createTextNode(GetVar("Score_Red"))
subelement.appendChild node
Set subelement = doc.createElement("Blue")
element.appendChild subelement
Set node = doc.createTextNode(GetVar("Score_Blue"))
subelement.appendChild node
Set element = doc.createElement("players")
root.appendChild element
For Each objPlayer In colPlayers
Set subelement = doc.createElement("player")
element.appendChild subelement
Set e = doc.createElement("name")
subelement.appendChild e
Set node = doc.createTextNode(objPlayer.Name)
e.appendChild node
Set e = doc.createElement("team")
subelement.appendChild e
Set node = doc.createTextNode(objPlayer.Team)
e.appendChild node
Set e = doc.createElement("ping")
subelement.appendChild e
Set node = doc.createTextNode(objPlayer.Ping)
e.appendChild node
Set e = doc.createElement("frags")
subelement.appendChild e
Set node = doc.createTextNode(objPlayer.Frags)
e.appendChild node
Next objPlayer
doc.save App.Path & "\out.xml"
Unload Me
End Sub
Public Function BeforeFirst(sHaystack As String, sNeedle As String) As String
Dim iPos As Integer
iPos = InStr(1, sHaystack, sNeedle)
If iPos <> 0 Then
BeforeFirst = Left$(sHaystack, iPos - 1)
Else
BeforeFirst = ""
End If
End Function
Public Function AfterFirst(sHaystack As String, sNeedle As String) As String
Dim iPos As Integer
iPos = InStr(1, sHaystack, sNeedle)
If iPos <> 0 Then
'AfterFirst = Right(sHaystack, Len(sHaystack) - iPos)
AfterFirst = Mid$(sHaystack, iPos + Len(sNeedle))
Else
AfterFirst = ""
End If
End Function
Ny bruger
Nybegynder
Opret
Preview
