Show General.bas syntax highlighted
Attribute VB_Name = "Mod_General"
'Argentum Online 0.11.6
'
'Copyright (C) 2002 Márquez Pablo Ignacio
'Copyright (C) 2002 Otto Perez
'Copyright (C) 2002 Aaron Perkins
'Copyright (C) 2002 Matías Fernando Pequeño
'
'This program is free software; you can redistribute it and/or modify
'it under the terms of the Affero General Public License;
'either version 1 of the License, or any later version.
'
'This program is distributed in the hope that it will be useful,
'but WITHOUT ANY WARRANTY; without even the implied warranty of
'MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
'Affero General Public License for more details.
'
'You should have received a copy of the Affero General Public License
'along with this program; if not, you can find it at http://www.affero.org/oagpl.html
'
'Argentum Online is based on Baronsoft's VB6 Online RPG
'You can contact the original creator of ORE at aaron@baronsoft.com
'for more information about ORE please visit http://www.baronsoft.com/
'
'
'You can contact me at:
'morgolock@speedy.com.ar
'www.geocities.com/gmorgolock
'Calle 3 número 983 piso 7 dto A
'La Plata - Pcia, Buenos Aires - Republica Argentina
'Código Postal 1900
'Pablo Ignacio Márquez
Option Explicit
Public iplst As String
Public bFogata As Boolean
Public bLluvia() As Byte ' Array para determinar si
'debemos mostrar la animacion de la lluvia
Private lFrameTimer As Long
Public Function DirGraficos() As String
DirGraficos = App.path & "\" & Config_Inicio.DirGraficos & "\"
End Function
Public Function DirSound() As String
DirSound = App.path & "\" & Config_Inicio.DirSonidos & "\"
End Function
Public Function DirMidi() As String
DirMidi = App.path & "\" & Config_Inicio.DirMusica & "\"
End Function
Public Function DirMapas() As String
DirMapas = App.path & "\" & Config_Inicio.DirMapas & "\"
End Function
Public Function RandomNumber(ByVal LowerBound As Long, ByVal UpperBound As Long) As Long
'Initialize randomizer
Randomize Timer
'Generate random number
RandomNumber = (UpperBound - LowerBound) * Rnd + LowerBound
End Function
Sub CargarAnimArmas()
On Error Resume Next
Dim loopc As Long
Dim arch As String
arch = App.path & "\init\" & "armas.dat"
NumWeaponAnims = Val(GetVar(arch, "INIT", "NumArmas"))
ReDim WeaponAnimData(1 To NumWeaponAnims) As WeaponAnimData
For loopc = 1 To NumWeaponAnims
InitGrh WeaponAnimData(loopc).WeaponWalk(1), Val(GetVar(arch, "ARMA" & loopc, "Dir1")), 0
InitGrh WeaponAnimData(loopc).WeaponWalk(2), Val(GetVar(arch, "ARMA" & loopc, "Dir2")), 0
InitGrh WeaponAnimData(loopc).WeaponWalk(3), Val(GetVar(arch, "ARMA" & loopc, "Dir3")), 0
InitGrh WeaponAnimData(loopc).WeaponWalk(4), Val(GetVar(arch, "ARMA" & loopc, "Dir4")), 0
Next loopc
End Sub
Sub CargarVersiones()
On Error GoTo errorH:
Versiones(1) = Val(GetVar(App.path & "\init\" & "versiones.ini", "Graficos", "Val"))
Versiones(2) = Val(GetVar(App.path & "\init\" & "versiones.ini", "Wavs", "Val"))
Versiones(3) = Val(GetVar(App.path & "\init\" & "versiones.ini", "Midis", "Val"))
Versiones(4) = Val(GetVar(App.path & "\init\" & "versiones.ini", "Init", "Val"))
Versiones(5) = Val(GetVar(App.path & "\init\" & "versiones.ini", "Mapas", "Val"))
Versiones(6) = Val(GetVar(App.path & "\init\" & "versiones.ini", "E", "Val"))
Versiones(7) = Val(GetVar(App.path & "\init\" & "versiones.ini", "O", "Val"))
Exit Sub
errorH:
Call MsgBox("Error cargando versiones")
End Sub
Sub CargarColores()
On Error Resume Next
Dim archivoC As String
archivoC = App.path & "\init\colores.dat"
If Not FileExist(archivoC, vbArchive) Then
'TODO : Si hay que reinstalar, porque no cierra???
Call MsgBox("ERROR: no se ha podido cargar los colores. Falta el archivo colores.dat, reinstale el juego", vbCritical + vbOKOnly)
Exit Sub
End If
Dim i As Long
For i = 0 To 48 '49 y 50 reservados para ciudadano y criminal
ColoresPJ(i).r = CByte(GetVar(archivoC, CStr(i), "R"))
ColoresPJ(i).g = CByte(GetVar(archivoC, CStr(i), "G"))
ColoresPJ(i).b = CByte(GetVar(archivoC, CStr(i), "B"))
Next i
ColoresPJ(50).r = CByte(GetVar(archivoC, "CR", "R"))
ColoresPJ(50).g = CByte(GetVar(archivoC, "CR", "G"))
ColoresPJ(50).b = CByte(GetVar(archivoC, "CR", "B"))
ColoresPJ(49).r = CByte(GetVar(archivoC, "CI", "R"))
ColoresPJ(49).g = CByte(GetVar(archivoC, "CI", "G"))
ColoresPJ(49).b = CByte(GetVar(archivoC, "CI", "B"))
End Sub
#If SeguridadAlkon Then
Sub InitMI()
Dim alternativos As Integer
Dim CualMITemp As Integer
alternativos = RandomNumber(1, 7368)
CualMITemp = RandomNumber(1, 1233)
Set MI(CualMITemp) = New clsManagerInvisibles
Call MI(CualMITemp).Inicializar(alternativos, 10000)
If CualMI <> 0 Then
Call MI(CualMITemp).CopyFrom(MI(CualMI))
Set MI(CualMI) = Nothing
End If
CualMI = CualMITemp
End Sub
#End If
Sub CargarAnimEscudos()
On Error Resume Next
Dim loopc As Long
Dim arch As String
arch = App.path & "\init\" & "escudos.dat"
NumEscudosAnims = Val(GetVar(arch, "INIT", "NumEscudos"))
ReDim ShieldAnimData(1 To NumEscudosAnims) As ShieldAnimData
For loopc = 1 To NumEscudosAnims
InitGrh ShieldAnimData(loopc).ShieldWalk(1), Val(GetVar(arch, "ESC" & loopc, "Dir1")), 0
InitGrh ShieldAnimData(loopc).ShieldWalk(2), Val(GetVar(arch, "ESC" & loopc, "Dir2")), 0
InitGrh ShieldAnimData(loopc).ShieldWalk(3), Val(GetVar(arch, "ESC" & loopc, "Dir3")), 0
InitGrh ShieldAnimData(loopc).ShieldWalk(4), Val(GetVar(arch, "ESC" & loopc, "Dir4")), 0
Next loopc
End Sub
Sub AddtoRichTextBox(ByRef RichTextBox As RichTextBox, ByVal Text As String, Optional ByVal red As Integer = -1, Optional ByVal green As Integer, Optional ByVal blue As Integer, Optional ByVal bold As Boolean = False, Optional ByVal italic As Boolean = False, Optional ByVal bCrLf As Boolean = False)
'******************************************
'Adds text to a Richtext box at the bottom.
'Automatically scrolls to new text.
'Text box MUST be multiline and have a 3D
'apperance!
'Pablo (ToxicWaste) 01/26/2007 : Now the list refreshes properly.
'Juan Martín Sotuyo Dodero (Maraxus) 03/29/2007 : Replaced ToxicWaste's code for extra performance.
'******************************************
With RichTextBox
If Len(.Text) > 1000 Then
'Get rid of first line
.SelStart = InStr(1, .Text, vbCrLf) + 1
.SelLength = Len(.Text) - .SelStart + 2
.TextRTF = .SelRTF
End If
.SelStart = Len(RichTextBox.Text)
.SelLength = 0
.SelBold = bold
.SelItalic = italic
If Not red = -1 Then .SelColor = RGB(red, green, blue)
.SelText = IIf(bCrLf, Text, Text & vbCrLf)
RichTextBox.Refresh
End With
End Sub
'TODO : Never was sure this is really necessary....
'TODO : 08/03/2006 - (AlejoLp) Esto hay que volarlo...
Public Sub RefreshAllChars()
'*****************************************************************
'Goes through the charlist and replots all the characters on the map
'Used to make sure everyone is visible
'*****************************************************************
Dim loopc As Long
For loopc = 1 To LastChar
If charlist(loopc).Active = 1 Then
MapData(charlist(loopc).Pos.x, charlist(loopc).Pos.y).charIndex = loopc
End If
Next loopc
End Sub
Sub SaveGameini()
'Grabamos los datos del usuario en el Game.ini
Config_Inicio.Name = "BetaTester"
Config_Inicio.Password = "DammLamers"
Config_Inicio.Puerto = UserPort
Call EscribirGameIni(Config_Inicio)
End Sub
Function AsciiValidos(ByVal cad As String) As Boolean
Dim car As Byte
Dim i As Long
cad = LCase$(cad)
For i = 1 To Len(cad)
car = Asc(mid$(cad, i, 1))
If ((car < 97 Or car > 122) Or car = Asc("º")) And (car <> 255) And (car <> 32) Then
Exit Function
End If
Next i
AsciiValidos = True
End Function
Function CheckUserData(ByVal checkemail As Boolean) As Boolean
'Validamos los datos del user
Dim loopc As Long
Dim CharAscii As Integer
If checkemail And UserEmail = "" Then
MsgBox ("Dirección de email invalida")
Exit Function
End If
If UserPassword = "" Then
MsgBox ("Ingrese un password.")
Exit Function
End If
For loopc = 1 To Len(UserPassword)
CharAscii = Asc(mid$(UserPassword, loopc, 1))
If Not LegalCharacter(CharAscii) Then
MsgBox ("Password inválido. El caractér " & Chr$(CharAscii) & " no está permitido.")
Exit Function
End If
Next loopc
If UserName = "" Then
MsgBox ("Ingrese un nombre de personaje.")
Exit Function
End If
If Len(UserName) > 30 Then
MsgBox ("El nombre debe tener menos de 30 letras.")
Exit Function
End If
For loopc = 1 To Len(UserName)
CharAscii = Asc(mid$(UserName, loopc, 1))
If Not LegalCharacter(CharAscii) Then
MsgBox ("Nombre inválido. El caractér " & Chr$(CharAscii) & " no está permitido.")
Exit Function
End If
Next loopc
CheckUserData = True
End Function
Sub UnloadAllForms()
On Error Resume Next
#If SeguridadAlkon Then
Call UnprotectForm
#End If
Dim mifrm As Form
For Each mifrm In Forms
Unload mifrm
Next
End Sub
Function LegalCharacter(ByVal KeyAscii As Integer) As Boolean
'*****************************************************************
'Only allow characters that are Win 95 filename compatible
'*****************************************************************
'if backspace allow
If KeyAscii = 8 Then
LegalCharacter = True
Exit Function
End If
'Only allow space, numbers, letters and special characters
If KeyAscii < 32 Or KeyAscii = 44 Then
Exit Function
End If
If KeyAscii > 126 Then
Exit Function
End If
'Check for bad special characters in between
If KeyAscii = 34 Or KeyAscii = 42 Or KeyAscii = 47 Or KeyAscii = 58 Or KeyAscii = 60 Or KeyAscii = 62 Or KeyAscii = 63 Or KeyAscii = 92 Or KeyAscii = 124 Then
Exit Function
End If
'else everything is cool
LegalCharacter = True
End Function
Sub SetConnected()
'*****************************************************************
'Sets the client to "Connect" mode
'*****************************************************************
'Set Connected
Connected = True
Call SaveGameini
#If SeguridadAlkon Then
'Unprotect character creation form
Call UnprotectForm
#End If
'Unload the connect form
Unload frmConnect
Unload frmPasswd
Unload frmCrearPersonaje
frmMain.Label8.Caption = UserName
'Load main form
frmMain.Visible = True
#If SeguridadAlkon Then
'Protect the main form
Call ProtectForm(frmMain)
#End If
End Sub
Sub CargarTip()
Dim N As Integer
N = RandomNumber(1, UBound(Tips))
frmtip.tip.Caption = Tips(N)
End Sub
Sub MoveTo(ByVal Direccion As E_Heading)
'***************************************************
'Author: Alejandro Santos (AlejoLp)
'Last Modify Date: 12/08/2007
'Last Modified By: Lucas Tavolaro Ortiz (Tavo)
' 06/03/2006: AlejoLp - Elimine las funciones Move[NSWE] y las converti a esta
' 12/08/2007: Tavo - Si el usuario esta paralizado no se puede mover.
'***************************************************
If UserParalizado Then Exit Sub
Dim LegalOk As Boolean
If Cartel Then Cartel = False
Select Case Direccion
Case E_Heading.NORTH
LegalOk = LegalPos(UserPos.x, UserPos.y - 1)
Case E_Heading.EAST
LegalOk = LegalPos(UserPos.x + 1, UserPos.y)
Case E_Heading.SOUTH
LegalOk = LegalPos(UserPos.x, UserPos.y + 1)
Case E_Heading.WEST
LegalOk = LegalPos(UserPos.x - 1, UserPos.y)
End Select
If LegalOk Then
Call WriteWalk(Direccion)
If Not UserDescansar And Not UserMeditar And Not UserParalizado Then
MoveCharbyHead UserCharIndex, Direccion
MoveScreen Direccion
End If
Else
If charlist(UserCharIndex).Heading <> Direccion Then
Call WriteChangeHeading(Direccion)
End If
End If
If frmMain.macrotrabajo.Enabled Then frmMain.DesactivarMacroTrabajo
End Sub
Sub RandomMove()
'***************************************************
'Author: Alejandro Santos (AlejoLp)
'Last Modify Date: 06/03/2006
' 06/03/2006: AlejoLp - Ahora utiliza la funcion MoveTo
'***************************************************
MoveTo RandomNumber(NORTH, WEST)
End Sub
Sub CheckKeys()
'*****************************************************************
'Checks keys and respond
'*****************************************************************
On Error Resume Next
'No input allowed while Argentum is not the active window
If Not Api.IsAppActive() Then Exit Sub
'Don't allow any these keys during movement..
If UserMoving = 0 Then
If Not UserEstupido Then
'Move Up
If GetKeyState(CustomKeys.BindedKey(eKeyType.mKeyUp)) < 0 Then
If frmMain.TrainingMacro.Enabled Then frmMain.DesactivarMacroHechizos
Call MoveTo(NORTH)
frmMain.Coord.Caption = "(" & UserMap & "," & UserPos.x & "," & UserPos.y & ")"
Exit Sub
End If
'Move Right
If GetKeyState(CustomKeys.BindedKey(eKeyType.mKeyRight)) < 0 Then
If frmMain.TrainingMacro.Enabled Then frmMain.DesactivarMacroHechizos
Call MoveTo(EAST)
frmMain.Coord.Caption = "(" & UserMap & "," & UserPos.x & "," & UserPos.y & ")"
Exit Sub
End If
'Move down
If GetKeyState(CustomKeys.BindedKey(eKeyType.mKeyDown)) < 0 Then
If frmMain.TrainingMacro.Enabled Then frmMain.DesactivarMacroHechizos
Call MoveTo(SOUTH)
frmMain.Coord.Caption = "(" & UserMap & "," & UserPos.x & "," & UserPos.y & ")"
Exit Sub
End If
'Move left
If GetKeyState(CustomKeys.BindedKey(eKeyType.mKeyLeft)) < 0 Then
If frmMain.TrainingMacro.Enabled Then frmMain.DesactivarMacroHechizos
Call MoveTo(WEST)
frmMain.Coord.Caption = "(" & UserMap & "," & UserPos.x & "," & UserPos.y & ")"
Exit Sub
End If
Else
Dim kp As Boolean
kp = (GetKeyState(CustomKeys.BindedKey(eKeyType.mKeyUp)) < 0) Or _
GetKeyState(CustomKeys.BindedKey(eKeyType.mKeyRight)) < 0 Or _
GetKeyState(CustomKeys.BindedKey(eKeyType.mKeyDown)) < 0 Or _
GetKeyState(CustomKeys.BindedKey(eKeyType.mKeyLeft)) < 0
If kp Then Call RandomMove
If frmMain.TrainingMacro.Enabled Then frmMain.DesactivarMacroHechizos
frmMain.Coord.Caption = "(" & UserPos.x & "," & UserPos.y & ")"
End If
End If
End Sub
'TODO : esto no es del tileengine??
Sub MoveScreen(ByVal nHeading As E_Heading)
'******************************************
'Starts the screen moving in a direction
'******************************************
Dim x As Integer
Dim y As Integer
Dim tX As Integer
Dim tY As Integer
'Figure out which way to move
Select Case nHeading
Case E_Heading.NORTH
y = -1
Case E_Heading.EAST
x = 1
Case E_Heading.SOUTH
y = 1
Case E_Heading.WEST
x = -1
End Select
'Fill temp pos
tX = UserPos.x + x
tY = UserPos.y + y
If Not (tX < MinXBorder Or tX > MaxXBorder Or tY < MinYBorder Or tY > MaxYBorder) Then
AddtoUserPos.x = x
UserPos.x = tX
AddtoUserPos.y = y
UserPos.y = tY
UserMoving = 1
bTecho = IIf(MapData(UserPos.x, UserPos.y).Trigger = 1 Or _
MapData(UserPos.x, UserPos.y).Trigger = 2 Or _
MapData(UserPos.x, UserPos.y).Trigger = 4, True, False)
Exit Sub
End If
End Sub
'TODO : esto no es del tileengine??
Function NextOpenChar()
'******************************************
'Finds next open Char
'******************************************
Dim loopc As Long
loopc = 1
Do While charlist(loopc).Active And loopc < UBound(charlist)
loopc = loopc + 1
Loop
NextOpenChar = loopc
End Function
'TODO : Si bien nunca estuvo allí, el mapa es algo independiente o a lo sumo dependiente del engine, no va acá!!!
Sub SwitchMap(ByVal Map As Integer)
'**************************************************************
'Formato de mapas optimizado para reducir el espacio que ocupan.
'Diseñado y creado por Juan Martín Sotuyo Dodero (Maraxus) (juansotuyo@hotmail.com)
'**************************************************************
Dim loopc As Long
Dim y As Long
Dim x As Long
Dim tempint As Integer
Dim ByFlags As Byte
Open DirMapas & "Mapa" & Map & ".map" For Binary As #1
Seek #1, 1
'map Header
Get #1, , MapInfo.MapVersion
Get #1, , MiCabecera
Get #1, , tempint
Get #1, , tempint
Get #1, , tempint
Get #1, , tempint
'Load arrays
For y = YMinMapSize To YMaxMapSize
For x = XMinMapSize To XMaxMapSize
Get #1, , ByFlags
MapData(x, y).Blocked = (ByFlags And 1)
Get #1, , MapData(x, y).Graphic(1).GrhIndex
InitGrh MapData(x, y).Graphic(1), MapData(x, y).Graphic(1).GrhIndex
'Layer 2 used?
If ByFlags And 2 Then
Get #1, , MapData(x, y).Graphic(2).GrhIndex
InitGrh MapData(x, y).Graphic(2), MapData(x, y).Graphic(2).GrhIndex
Else
MapData(x, y).Graphic(2).GrhIndex = 0
End If
'Layer 3 used?
If ByFlags And 4 Then
Get #1, , MapData(x, y).Graphic(3).GrhIndex
InitGrh MapData(x, y).Graphic(3), MapData(x, y).Graphic(3).GrhIndex
Else
MapData(x, y).Graphic(3).GrhIndex = 0
End If
'Layer 4 used?
If ByFlags And 8 Then
Get #1, , MapData(x, y).Graphic(4).GrhIndex
InitGrh MapData(x, y).Graphic(4), MapData(x, y).Graphic(4).GrhIndex
Else
MapData(x, y).Graphic(4).GrhIndex = 0
End If
'Trigger used?
If ByFlags And 16 Then
Get #1, , MapData(x, y).Trigger
Else
MapData(x, y).Trigger = 0
End If
'Erase NPCs
If MapData(x, y).charIndex > 0 Then
Call EraseChar(MapData(x, y).charIndex)
End If
'Erase OBJs
MapData(x, y).ObjGrh.GrhIndex = 0
Next x
Next y
Close #1
MapInfo.Name = ""
MapInfo.Music = ""
CurMap = Map
End Sub
Function ReadField(ByVal Pos As Integer, ByRef Text As String, ByVal SepASCII As Byte) As String
'*****************************************************************
'Gets a field from a delimited string
'Author: Juan Martín Sotuyo Dodero (Maraxus)
'Last Modify Date: 11/15/2004
'*****************************************************************
Dim i As Long
Dim lastPos As Long
Dim CurrentPos As Long
Dim delimiter As String * 1
delimiter = Chr$(SepASCII)
For i = 1 To Pos
lastPos = CurrentPos
CurrentPos = InStr(lastPos + 1, Text, delimiter, vbBinaryCompare)
Next i
If CurrentPos = 0 Then
ReadField = mid$(Text, lastPos + 1, Len(Text) - lastPos)
Else
ReadField = mid$(Text, lastPos + 1, CurrentPos - lastPos - 1)
End If
End Function
Function FieldCount(ByRef Text As String, ByVal SepASCII As Byte) As Long
'*****************************************************************
'Gets the number of fields in a delimited string
'Author: Juan Martín Sotuyo Dodero (Maraxus)
'Last Modify Date: 07/29/2007
'*****************************************************************
Dim Count As Long
Dim curPos As Long
Dim delimiter As String * 1
If LenB(Text) = 0 Then Exit Function
delimiter = Chr$(SepASCII)
curPos = 0
Do
curPos = InStr(curPos + 1, Text, delimiter)
Count = Count + 1
Loop While curPos <> 0
FieldCount = Count
End Function
Function FileExist(ByVal file As String, ByVal FileType As VbFileAttribute) As Boolean
FileExist = (Dir$(file, FileType) <> "")
End Function
Sub WriteClientVer()
Dim hFile As Integer
hFile = FreeFile()
Open App.path & "\init\Ver.bin" For Binary Access Write Lock Read As #hFile
Put #hFile, , CLng(777)
Put #hFile, , CLng(777)
Put #hFile, , CLng(777)
Put #hFile, , CInt(App.Major)
Put #hFile, , CInt(App.Minor)
Put #hFile, , CInt(App.Revision)
Close #hFile
End Sub
Public Function IsIp(ByVal Ip As String) As Boolean
Dim i As Long
For i = 1 To UBound(ServersLst)
If ServersLst(i).Ip = Ip Then
IsIp = True
Exit Function
End If
Next i
End Function
Public Sub CargarServidores()
'********************************
'Author: Unknown
'Last Modification: 07/26/07
'Last Modified by: Rapsodius
'Added Instruction "CloseClient" before End so the mutex is cleared
'********************************
On Error GoTo errorH
Dim f As String
Dim c As Integer
Dim i As Long
f = App.path & "\init\sinfo.dat"
c = Val(GetVar(f, "INIT", "Cant"))
ReDim ServersLst(1 To c) As tServerInfo
For i = 1 To c
ServersLst(i).desc = GetVar(f, "S" & i, "Desc")
ServersLst(i).Ip = Trim$(GetVar(f, "S" & i, "Ip"))
ServersLst(i).PassRecPort = CInt(GetVar(f, "S" & i, "P2"))
ServersLst(i).Puerto = CInt(GetVar(f, "S" & i, "PJ"))
Next i
CurServer = 1
Exit Sub
errorH:
Call MsgBox("Error cargando los servidores, actualicelos de la web", vbCritical + vbOKOnly, "Argentum Online")
Call CloseClient
End
End Sub
Public Sub InitServersList(ByVal Lst As String)
On Error Resume Next
Dim NumServers As Integer
Dim i As Integer
Dim Cont As Integer
i = 1
Do While (ReadField(i, RawServersList, Asc(";")) <> "")
i = i + 1
Cont = Cont + 1
Loop
ReDim ServersLst(1 To Cont) As tServerInfo
For i = 1 To Cont
Dim cur$
cur$ = ReadField(i, RawServersList, Asc(";"))
ServersLst(i).Ip = ReadField(1, cur$, Asc(":"))
ServersLst(i).Puerto = ReadField(2, cur$, Asc(":"))
ServersLst(i).desc = ReadField(4, cur$, Asc(":"))
ServersLst(i).PassRecPort = ReadField(3, cur$, Asc(":"))
Next i
CurServer = 1
End Sub
Public Function CurServerPasRecPort() As Integer
If CurServer <> 0 Then
CurServerPasRecPort = 7667
Else
CurServerPasRecPort = CInt(frmConnect.PortTxt)
End If
End Function
Public Function CurServerIp() As String
If CurServer <> 0 Then
CurServerIp = ServersLst(CurServer).Ip
Else
CurServerIp = frmConnect.IPTxt
End If
End Function
Public Function CurServerPort() As Integer
If CurServer <> 0 Then
CurServerPort = ServersLst(CurServer).Puerto
Else
CurServerPort = Val(frmConnect.PortTxt)
End If
End Function
Sub Main()
Call WriteClientVer
'Load config file
If FileExist(App.path & "\init\Inicio.con", vbNormal) Then
Config_Inicio = LeerGameIni()
End If
'Load ao.dat config file
If FileExist(App.path & "\init\ao.dat", vbArchive) Then
Call LoadClientSetup
If ClientSetup.bDinamic Then
Set SurfaceDB = New clsSurfaceManDyn
Else
Set SurfaceDB = New clsSurfaceManStatic
End If
Else
'Use dynamic by default
Set SurfaceDB = New clsSurfaceManDyn
End If
Set CustomKeys = New clsCustomKeys
'Read command line. Do it AFTER config file is loaded to prevent this from
'canceling the effects of "/nores" option.
Call LeerLineaComandos
If FindPreviousInstance Then
Call MsgBox("Argentum Online ya esta corriendo! No es posible correr otra instancia del juego. Haga click en Aceptar para salir.", vbApplicationModal + vbInformation + vbOKOnly, "Error al ejecutar")
End
End If
'usaremos esto para ayudar en los parches
Call SaveSetting("ArgentumOnlineCliente", "Init", "Path", App.path & "\")
ChDrive App.path
ChDir App.path
#If SeguridadAlkon Then
'Obtener el HushMD5
Dim fMD5HushYo As String * 32
fMD5HushYo = md5.GetMD5File(App.path & "\" & App.EXEName & ".exe")
Call md5.MD5Reset
MD5HushYo = txtOffset(hexMd52Asc(fMD5HushYo), 55)
Debug.Print fMD5HushYo
#Else
MD5HushYo = "0123456789abcdef" 'We aren't using a real MD5
#End If
tipf = Config_Inicio.tip
frmCargando.Show
frmCargando.Refresh
frmConnect.version = "v" & App.Major & "." & App.Minor & " Build: " & App.Revision
AddtoRichTextBox frmCargando.status, "Buscando servidores....", 0, 0, 0, 0, 0, 1
Call CargarServidores
'TODO : esto de ServerRecibidos no se podría sacar???
ServersRecibidos = True
AddtoRichTextBox frmCargando.status, "Encontrado", , , , 1
AddtoRichTextBox frmCargando.status, "Iniciando constantes...", 0, 0, 0, 0, 0, 1
Call InicializarNombres
' Initialize FONTTYPES
Call Protocol.InitFonts
frmOldPersonaje.NameTxt.Text = Config_Inicio.Name
frmOldPersonaje.PasswordTxt.Text = ""
AddtoRichTextBox frmCargando.status, "Hecho", , , , 1
IniciarObjetosDirectX
AddtoRichTextBox frmCargando.status, "Cargando Sonidos....", 0, 0, 0, 0, 0, 1
AddtoRichTextBox frmCargando.status, "Hecho", , , , 1
Dim loopc As Integer
LastTime = GetTickCount
Call InitTileEngine(frmMain.hWnd, 160, 7, 32, 32, 13, 17, 9)
Call AddtoRichTextBox(frmCargando.status, "Creando animaciones extra....")
Call CargarAnimsExtra
Call CargarTips
UserMap = 1
Call CargarArrayLluvia
Call CargarAnimArmas
Call CargarAnimEscudos
Call CargarVersiones
Call CargarColores
#If SeguridadAlkon Then
CualMI = 0
Call InitMI
#End If
AddtoRichTextBox frmCargando.status, " ¡Bienvenido a Argentum Online!", , , , 1
Unload frmCargando
'Inicializamos el sonido
Call AddtoRichTextBox(frmCargando.status, "Iniciando DirectSound....", 0, 0, 0, 0, 0, True)
Call Audio.Initialize(DirectX, frmMain.hWnd, App.path & "\" & Config_Inicio.DirSonidos & "\", App.path & "\" & Config_Inicio.DirMusica & "\")
'Enable / Disable audio
Audio.MusicActivated = Not ClientSetup.bNoMusic
Audio.SoundActivated = Not ClientSetup.bNoSound
Call AddtoRichTextBox(frmCargando.status, "Hecho", , , , 1, , False)
'Inicializamos el inventario gráfico
Call Inventario.Initialize(DirectDraw, frmMain.picInv)
Call Audio.PlayMIDI(MIdi_Inicio & ".mid")
frmPres.Picture = LoadPicture(App.path & "\Graficos\bosquefinal.jpg")
frmPres.Show vbModal 'Es modal, así que se detiene la ejecución de Main hasta que se desaparece
#If UsarWrench = 1 Then
frmMain.Socket1.Startup
#End If
frmConnect.Visible = True
'TODO : Esto va en Engine Initialization
MainViewRect.Left = MainViewLeft
MainViewRect.Top = MainViewTop
MainViewRect.Right = MainViewRect.Left + MainViewWidth
MainViewRect.Bottom = MainViewRect.Top + MainViewHeight
'TODO : Esto va en Engine Initialization
MainDestRect.Left = TilePixelWidth * TileBufferSize - TilePixelWidth
MainDestRect.Top = TilePixelHeight * TileBufferSize - TilePixelHeight
MainDestRect.Right = MainDestRect.Left + MainViewWidth
MainDestRect.Bottom = MainDestRect.Top + MainViewHeight
'Inicialización de variables globales
PrimeraVez = True
prgRun = True
pausa = False
'Set the intervals of timers
Call MainTimer.SetInterval(TimersIndex.Attack, INT_ATTACK)
Call MainTimer.SetInterval(TimersIndex.Work, INT_WORK)
Call MainTimer.SetInterval(TimersIndex.UseItemWithU, INT_USEITEMU)
Call MainTimer.SetInterval(TimersIndex.UseItemWithDblClick, INT_USEITEMDCK)
Call MainTimer.SetInterval(TimersIndex.SendRPU, INT_SENTRPU)
Call MainTimer.SetInterval(TimersIndex.CastSpell, INT_CAST_SPELL)
Call MainTimer.SetInterval(TimersIndex.Arrows, INT_ARROWS)
Call MainTimer.SetInterval(TimersIndex.CastAttack, INT_CAST_ATTACK)
frmMain.macrotrabajo.Interval = INT_MACRO_TRABAJO
frmMain.macrotrabajo.Enabled = False
'Init timers
Call MainTimer.Start(TimersIndex.Attack)
Call MainTimer.Start(TimersIndex.Work)
Call MainTimer.Start(TimersIndex.UseItemWithU)
Call MainTimer.Start(TimersIndex.UseItemWithDblClick)
Call MainTimer.Start(TimersIndex.SendRPU)
Call MainTimer.Start(TimersIndex.CastSpell)
Call MainTimer.Start(TimersIndex.Arrows)
Call MainTimer.Start(TimersIndex.CastAttack)
'Set the dialog's font
Dialogos.font = frmMain.font
DialogosClanes.font = frmMain.font
' Load the form for screenshots
Call Load(frmScreenshots)
Do While prgRun
'Sólo dibujamos si la ventana no está minimizada
If frmMain.WindowState <> 1 And frmMain.Visible Then
Call ShowNextFrame
'Play ambient sounds
Call RenderSounds
End If
'TODO : Porque el pausado de 20 ms???
If GetTickCount - LastTime > 20 Then
If Not pausa And frmMain.Visible And Not frmForo.Visible And Not frmComerciar.Visible And Not frmComerciarUsu.Visible And Not frmBancoObj.Visible Then
CheckKeys
LastTime = GetTickCount
End If
End If
'Limitamos los FPS a 18 (con el nuevo engine 60 es un número mucho mejor)
'While (GetTickCount - lFrameTimer) \ 56 < FramesPerSecCounter
' Sleep 5
'Wend
'FPS Counter - mostramos las FPS
If GetTickCount - lFrameTimer >= 1000 Then
FramesPerSec = FramesPerSecCounter
If FPSFLAG Then frmMain.Caption = FramesPerSec
FramesPerSecCounter = 0
lFrameTimer = GetTickCount
End If
#If SeguridadAlkon Then
Call CheckSecurity
#End If
' If there is anything to be sent, we send it
Call FlushBuffer
DoEvents
Loop
' Allow new instances of the client to be opened
Call PrevInstance.CloseClient
' Unload the form for screenshots
Unload frmScreenshots
EngineRun = False
frmCargando.Show
AddtoRichTextBox frmCargando.status, "Liberando recursos...", 0, 0, 0, 0, 0, 1
LiberarObjetosDX
'TODO : Esto debería ir en otro lado como al cambair a esta res
If Not bNoResChange Then
Dim typDevM As typDevMODE
Dim lRes As Long
lRes = EnumDisplaySettings(0, 0, typDevM)
With typDevM
.dmFields = DM_PELSWIDTH Or DM_PELSHEIGHT
.dmPelsWidth = oldResWidth
.dmPelsHeight = oldResHeight
End With
lRes = ChangeDisplaySettings(typDevM, CDS_TEST)
End If
'Destruimos los objetos públicos creados
Set CustomMessages = Nothing
Set CustomKeys = Nothing
Set SurfaceDB = Nothing
Set Dialogos = Nothing
Set DialogosClanes = Nothing
Set Audio = Nothing
Set Inventario = Nothing
Set MainTimer = Nothing
Set incomingData = Nothing
Set outgoingData = Nothing
#If SeguridadAlkon Then
Set md5 = Nothing
#End If
Call UnloadAllForms
'Actualizar tip
Config_Inicio.tip = tipf
Call EscribirGameIni(Config_Inicio)
End
End Sub
Sub WriteVar(ByVal file As String, ByVal Main As String, ByVal Var As String, ByVal value As String)
'*****************************************************************
'Writes a var to a text file
'*****************************************************************
writeprivateprofilestring Main, Var, value, file
End Sub
Function GetVar(ByVal file As String, ByVal Main As String, ByVal Var As String) As String
'*****************************************************************
'Gets a Var from a text file
'*****************************************************************
Dim sSpaces As String ' This will hold the input that the program will retrieve
sSpaces = Space$(100) ' This tells the computer how long the longest string can be. If you want, you can change the number 100 to any number you wish
getprivateprofilestring Main, Var, vbNullString, sSpaces, Len(sSpaces), file
GetVar = RTrim$(sSpaces)
GetVar = Left$(GetVar, Len(GetVar) - 1)
End Function
'[CODE 002]:MatuX
'
' Función para chequear el email
'
' Corregida por Maraxus para que reconozca como válidas casillas con puntos antes de la arroba y evitar un chequeo innecesario
Public Function CheckMailString(ByVal sString As String) As Boolean
On Error GoTo errHnd
Dim lPos As Long
Dim lX As Long
Dim iAsc As Integer
'1er test: Busca un simbolo @
lPos = InStr(sString, "@")
If (lPos <> 0) Then
'2do test: Busca un simbolo . después de @ + 1
If Not (InStr(lPos, sString, ".", vbBinaryCompare) > lPos + 1) Then _
Exit Function
'3er test: Recorre todos los caracteres y los valída
For lX = 0 To Len(sString) - 1
If Not (lX = (lPos - 1)) Then 'No chequeamos la '@'
iAsc = Asc(mid$(sString, (lX + 1), 1))
If Not CMSValidateChar_(iAsc) Then _
Exit Function
End If
Next lX
'Finale
CheckMailString = True
End If
errHnd:
End Function
' Corregida por Maraxus para que reconozca como válidas casillas con puntos antes de la arroba
Private Function CMSValidateChar_(ByVal iAsc As Integer) As Boolean
CMSValidateChar_ = (iAsc >= 48 And iAsc <= 57) Or _
(iAsc >= 65 And iAsc <= 90) Or _
(iAsc >= 97 And iAsc <= 122) Or _
(iAsc = 95) Or (iAsc = 45) Or (iAsc = 46)
End Function
'TODO : como todo lo relativo a mapas, no tiene nada que hacer acá....
Function HayAgua(ByVal x As Integer, ByVal y As Integer) As Boolean
HayAgua = ((MapData(x, y).Graphic(1).GrhIndex >= 1505 And MapData(x, y).Graphic(1).GrhIndex <= 1520) Or _
(MapData(x, y).Graphic(1).GrhIndex >= 5665 And MapData(x, y).Graphic(1).GrhIndex <= 5680) Or _
(MapData(x, y).Graphic(1).GrhIndex >= 13547 And MapData(x, y).Graphic(1).GrhIndex <= 13562)) And _
MapData(x, y).Graphic(2).GrhIndex = 0
End Function
Public Sub ShowSendTxt()
If Not frmCantidad.Visible Then
frmMain.SendTxt.Visible = True
frmMain.SendTxt.SetFocus
End If
End Sub
Public Sub ShowSendCMSGTxt()
If Not frmCantidad.Visible Then
frmMain.SendCMSTXT.Visible = True
frmMain.SendCMSTXT.SetFocus
End If
End Sub
Public Sub LeerLineaComandos()
Dim T() As String
Dim i As Long
'Parseo los comandos
T = Split(Command, " ")
For i = LBound(T) To UBound(T)
Select Case UCase$(T(i))
Case "/NORES" 'no cambiar la resolucion
NoRes = True
End Select
Next i
End Sub
Private Sub LoadClientSetup()
'**************************************************************
'Author: Juan Martín Sotuyo Dodero (Maraxus)
'Last Modify Date: 24/06/2006
'
'**************************************************************
Dim fHandle As Integer
fHandle = FreeFile
Open App.path & "\init\ao.dat" For Binary Access Read Lock Write As fHandle
Get fHandle, , ClientSetup
Close fHandle
NoRes = ClientSetup.bNoRes
End Sub
Private Sub InicializarNombres()
'**************************************************************
'Author: Juan Martín Sotuyo Dodero (Maraxus)
'Last Modify Date: 11/27/2005
'Inicializa los nombres de razas, ciudades, clases, skills, atributos, etc.
'**************************************************************
Ciudades(eCiudad.cUllathorpe) = "Ullathorpe"
Ciudades(eCiudad.cNix) = "Nix"
Ciudades(eCiudad.cBanderbill) = "Banderbill"
Ciudades(eCiudad.cLindos) = "Lindos"
Ciudades(eCiudad.cArghal) = "Arghâl"
ListaRazas(eRaza.Humano) = "Humano"
ListaRazas(eRaza.Elfo) = "Elfo"
ListaRazas(eRaza.ElfoOscuro) = "Elfo Oscuro"
ListaRazas(eRaza.Gnomo) = "Gnomo"
ListaRazas(eRaza.Enano) = "Enano"
ListaClases(eClass.Mage) = "Mago"
ListaClases(eClass.Cleric) = "Clerigo"
ListaClases(eClass.Warrior) = "Guerrero"
ListaClases(eClass.Assasin) = "Asesino"
ListaClases(eClass.Thief) = "Ladron"
ListaClases(eClass.Bard) = "Bardo"
ListaClases(eClass.Druid) = "Druida"
ListaClases(eClass.Bandit) = "Bandido"
ListaClases(eClass.Paladin) = "Paladin"
ListaClases(eClass.Hunter) = "Cazador"
ListaClases(eClass.Fisher) = "Pescador"
ListaClases(eClass.Blacksmith) = "Herrero"
ListaClases(eClass.Lumberjack) = "Leñador"
ListaClases(eClass.Miner) = "Minero"
ListaClases(eClass.Carpenter) = "Carpintero"
ListaClases(eClass.Pirat) = "Pirata"
SkillsNames(eSkill.Suerte) = "Suerte"
SkillsNames(eSkill.Magia) = "Magia"
SkillsNames(eSkill.Robar) = "Robar"
SkillsNames(eSkill.Tacticas) = "Tacticas de combate"
SkillsNames(eSkill.Armas) = "Combate con armas"
SkillsNames(eSkill.Meditar) = "Meditar"
SkillsNames(eSkill.Apuñalar) = "Apuñalar"
SkillsNames(eSkill.Ocultarse) = "Ocultarse"
SkillsNames(eSkill.Supervivencia) = "Supervivencia"
SkillsNames(eSkill.Talar) = "Talar árboles"
SkillsNames(eSkill.Comerciar) = "Comercio"
SkillsNames(eSkill.Defensa) = "Defensa con escudos"
SkillsNames(eSkill.Pesca) = "Pesca"
SkillsNames(eSkill.Mineria) = "Mineria"
SkillsNames(eSkill.Carpinteria) = "Carpinteria"
SkillsNames(eSkill.Herreria) = "Herreria"
SkillsNames(eSkill.Liderazgo) = "Liderazgo"
SkillsNames(eSkill.Domar) = "Domar animales"
SkillsNames(eSkill.Proyectiles) = "Armas de proyectiles"
SkillsNames(eSkill.Wrestling) = "Wrestling"
SkillsNames(eSkill.Navegacion) = "Navegacion"
AtributosNames(eAtributos.Fuerza) = "Fuerza"
AtributosNames(eAtributos.Agilidad) = "Agilidad"
AtributosNames(eAtributos.Inteligencia) = "Inteligencia"
AtributosNames(eAtributos.Carisma) = "Carisma"
AtributosNames(eAtributos.Constitucion) = "Constitucion"
End Sub
''
' Removes all text from the console and dialogs
Public Sub CleanDialogs()
'**************************************************************
'Author: Juan Martín Sotuyo Dodero (Maraxus)
'Last Modify Date: 11/27/2005
'Removes all text from the console and dialogs
'**************************************************************
'Clean console and dialogs
frmMain.RecTxt.Text = vbNullString
Call DialogosClanes.RemoveDialogs
Call Dialogos.RemoveAllDialogs
End Sub
See more files for this project here