Attribute VB_Name = "Run" Option Explicit ''''''JABA: 24-4-2000 '''' constantes del analizador '''Const TIPO_ID = 0 '''Const TIPO_OPERADOR = 1 '''Const TIPO_NUMERO = 2 '''Const TIPO_DESCONOCIDO = 3 '''Const TIPO_CADENA = 4 '''Const TIPO_FIN = 5 '''Const TIPO_ERRONEO = 999 '''Const TIPO_CORRECTO = 1000 ''''''JABA: 24-4-2000 '''' formato de retorno de tokens del analizador léxico '''Type LexBuf ''' TipoTok As Integer ' tipo de token (0=id, 1=otro, 2=número entero) ''' Cad As String ''' Num As Integer '''End Type ''' '''' formato de los valores (tipo + valor) '''Type Valor ''' Con As String ''' Tipo As Integer ' las mismas ctes. que LexBuf '''End Type ' formato de línea de un módulo Type Linea Modulo As String ' módulo Numero As Long ' número dentro del módulo Tipo As Integer ' tipo de línea Lin As String ' contenido de la línea End Type ' definición de variable Type Variable Nombre As String ' nombre de la variable Valor As String ' valor Proc As Long ' índice del procedimiento en el que se ha definido (-1 si global) NumSerie As Long ' para ligar con el nº de serie (nº de llamada) del proc. End Type ' definición de procedimiento Type Proc Nombre As String ' nombre del procedimiento Param() As String ' lista de parámetros HayParam As Boolean ' indicador de si hay parámetros Lineas() As Linea ' lista de líneas HayLineas As Boolean ' indicador de si hay líneas definidas NumSerie As Long ' se incrementa en cada llamada y se decrementa al final ' sirve para ligar con variables locales propias en caso de ' que llamemos recursivamente End Type ' identificador de variable global Public Const VAR_GLOBAL = -1 ' identificador del fichero de estado Const ID_FICHESTADO = "#VSINTAC/1.0#" Const DELIM_CMP = 3 ' carácter delimitador de campo de fichero de estado (no poner 0) Const SEP_CMP = 2 ' carácter separador de campo de fichero de estado (no poner 0) Const SEP_REG = 1 ' carácter separador de registro de fichero de estado (no poner 0) ' variables del sistema Public Const VERVS = "VerVS" ' versión del intérprete Public Const VAR_ERROR = "Error" ' último error producido Public Const SCREEN_ACT = "ScreenAct" ' "pantalla" activa Public Const RES_X = "ResX" ' resolución en pixels de la pantalla Public Const RES_Y = "ResY" Public Const RUTA_PRG = "RutaPrg" ' ruta del programa Public Const RUTA_DAT = "RutaDat" ' ruta de los ficheros de datos Public Const NUM_LOC = "NumLocalidades" ' nº de localidades Public Const NUM_OBJ = "NumObjetos" ' nº de objetos Public Const NUM_PSI = "NumPSI" ' nº de PSIs Public Const NUM_PAL = "NumPalabras" ' nº palabras en vocabulario Public Const PARSE_SEPAR = "ParseSepar" ' separadores para PARSE Public Const PARSE_COMILL = "ParseComill" ' para entrecomillar frases en PARSE Public Const PARSE_TERMVERB = "PaserTermVerb" ' terminaciones verbales (LO/LA/LE...) Public Const PARSE_VERBO = "ParseVerbo" ' verbo encontrado por PARSE Public Const PARSE_VERBOMOV = "EsVerboMov" ' si es verbo de movimiento o no Public Const PARSE_NOMBRE1 = "ParseNombre1" ' nombre 1 encontrado por PARSE Public Const PARSE_ADJETIVO1 = "ParseAdjetivo1" ' adjetivo 1 encontrado por PARSE Public Const PARSE_NOMBRE2 = "ParseNombre2" ' nombre 2 encontrado por PARSE Public Const PARSE_ADJETIVO2 = "ParseAdjetivo2" ' adjetivo 2 encontrado por PARSE Public Const PARSE_PREPOS = "ParsePreposicion" ' preposición encontrada por PARSE Public Const PARSE_FRASE = "ParseFrase" ' frase encontrada entrecomillada Public Const PSI_JUGADOR = "PSIJugador" ' nombre del PSI que controla el jugador ' caracteres válidos para operandos Const CAR_NUMEROS = "0123456789" Const CAR_ALFA = "ABCDEFGHIJKLMNOPQRSTUVWXYZÑ_[]" Const CAR_OPERANDO = CAR_NUMEROS & CAR_ALFA ' caracteres válidos para nombres de procedimientos y variables Public Const CAR_PROC = "ABCDEFGHIJKLMNOPQRSTUVWXYZÑ_" Const CORCHETE1 = "[" ' corchete de apertura Const CORCHETE2 = "]" ' corchete de cierre Const SEPAR_PROPIEDAD = "." ' separador de propiedad de una referencia a objeto Const PARENTESIS1 = "(" ' paréntesis de apertura Const PARENTESIS2 = ")" ' paréntesis de cierre Const CONT_LINEA = "_" ' carácter de continuación de línea Const COMENTARIO = "//" ' comentario Const ESCAPE = "\" ' inicio de secuencia de escape dentro de una cadena Public Const COMILLAS = """" ' inicio/fin de cadena de texto Public Const SEPAR_PARAM = "," ' separador de parámetros Public Const SEPAR_ARRAY = 1 ' carácter separador de elementos de un array ' operadores Const OPERADORES = "+-*/=<>&|" Const OPER_MAS = "+" ' suma/concatenación Const OPER_MENOS = "-" ' resta Const OPER_MULTIPL = "*" ' multiplicación Const OPER_DIV = "/" ' división Const OPER_IGUAL = "=" ' igualdad Const OPER_MAYOR = ">" ' mayor que Const OPER_MENOR = "<" ' menor que Const OPER_MAYIGUAL = ">=" ' mayor o igual que Const OPER_MENIGUAL = "<=" ' menor o igual que Const OPER_DISTINTO = "<>" ' distinto de Const OPER_AND = "&" ' Y lógico Const OPER_OR = "|" ' O lógico ' prefijos de objetos Const PREFOBJ_LOC = "LOC" Const PREFOBJ_OBJ = "OBJ" Const PREFOBJ_PSI = "PSI" ' tipos de objetos Const TIPOBJ_LOC = 1 Const TIPOBJ_OBJ = 2 Const TIPOBJ_PSI = 3 ' tipos de líneas Const LIN_VACIA = 0 ' línea vacía Const LIN_COMANDO = 1 ' comando Const LIN_COMENTARIO = 2 ' comentario Const LIN_ASIGN = 3 ' asignación de variable Const LIN_FOR = 4 ' inicio de bucle FOR Const LIN_NEXT = 5 ' fin de bucle FOR Const LIN_WHILE = 6 ' inicio de bucle WHILE Const LIN_LOOP = 7 ' fin de bucle WHILE Const LIN_IF = 8 ' inicio de claúsula IF Const LIN_ELSE = 9 ' línea ELSE de una claúsula IF Const LIN_ENDIF = 10 ' línea END de una claúsula IF Const LIN_SELECT = 11 ' inicio de claúsula SELECT Const LIN_CASE = 12 ' línea CASE de una claúsula SELECT Const LIN_ENDSELECT = 13 ' línea END de una claúsula SELECT Const LIN_EXIT = 14 ' fin de ejecución Const LIN_SUB = 15 ' inicio de procedimiento Const LIN_RETURN = 16 ' fin de procedimiento Const LIN_RESTART = 17 ' reinicia la ejecución del programa ' tipos de operandos en una expresión Const OP_NUMERICO = 0 ' valor numérico Const OP_VARIABLE = 1 ' variable Const OP_DESCONOCIDO = -1 ' desconocido ' valores para TRUE y FALSE Public Const EXPR_TRUE = "1" Public Const EXPR_FALSE = "0" ' valor a asignar a 'lPunteroLinea' para salir del módulo Const PUNTERO_SALIR = -1 ' definición de comandos básicos Const CMD_ASIGN = ":=" Const CMD_FOR = "FOR" Const CMD_TO = "TO" Const CMD_NEXT = "NEXT" Const CMD_WHILE = "WHILE" Const CMD_LOOP = "LOOP" Const CMD_IF = "IF" Const CMD_THEN = "THEN" Const CMD_ELSE = "ELSE" Const CMD_ENDIF = "ENDIF" Const CMD_SELECT = "SELECT" Const CMD_CASE = "CASE" Const CMD_ENDSELECT = "ENDSELECT" Const CMD_EXIT = "EXIT" Public Const CMD_SUB = "SUB" ' público: lo necesitamos para el editor Const CMD_RETURN = "RETURN" Const CMD_RESTART = "RESTART" Private bReiniciar As Boolean ' indica si queremos reiniciar el programa Private bReturn As Boolean ' indica que estamos volviendo de un procedimiento Private cmd As VSComandos ' comandos de VisualSINTAC Private Errores() As String ' lista de errores producidos (si Errores(0)="" ninguno) ''''''JABA: 24-4-2000 '''' variables globales para comunicar el analizador léxico y el sintáctico '''Private Prebuscado As LexBuf ' símbolo de look-ahead '''Private L_Cad As String ' cadena que está siendo analizada Public Lineas() As Linea ' lista de líneas Public lPunteroLinea As Long ' puntero a la línea que se está ejecutando Public VarGlobales() As Variable ' variables globales Public bHayGlobales As Boolean ' si hay alguna variable global definida Public VarLocales() As Variable ' variables locales Public bHayLocales As Boolean ' si hay alguna variable local definida Public Procedimientos() As Proc ' procedimientos Public bHayProc As Boolean ' si hay algún procedimiento definido Public lProcActual As Long ' índice del procedimiento actual (-1 si ninguno) Public bDepurar As Boolean ' si el depurador está activado o no Public bIgnorarErrores As Boolean ' si se ignoran los errores en ejecución Public sDescError As String ' descripción detallada del último error Public bFinProg As Boolean ' cuando es True, sale del programa (EXIT) ' ejecuta el programa Public Sub Ejecuta() Dim sErr As String Dim i As Long If Not bHayModulos Then MsgBox "Tabla de descripción de módulos vacía", vbOKOnly + vbCritical, "Ejecutar" Exit Sub End If ' guardamos el estado para reiniciar Reiniciar_Guarda Reiniciar: InicializaEjecucion EjecutaBloque If Errores(0) <> "" Then sErr = "" For i = 0 To UBound(Errores) If sErr = "" Then sErr = "<" & CStr(i + 1) & ">" & Errores(i) Else sErr = sErr & vbCrLf & "<" & CStr(i + 1) & ">" & Errores(i) End If Next MsgBox sErr, vbOKOnly + vbExclamation, "Error de ejecución" End If FinalizaEjecucion ' si hay que reiniciar... If bReiniciar Then Reiniciar_Carga GoTo Reiniciar End If End Sub ' inicializa el entorno de ejecución: variables, visualización, ... Public Sub InicializaEjecucion() Dim frm As Form Dim bVis As Boolean ' --- SONIDO --- InicializaSonido ' --- TABLAS DE NOMBRES y ADJETIVOS --- CreaTablasNombAdj ' --- VARIABLES --- ReDim Variables(0) bHayGlobales = False bHayLocales = False ' --- COMANDOS --- Set cmd = New VSComandos ' variables del sistema (globales) CreaVariable VERVS, App.Major & "." & App.Minor & "R" & App.Revision, VAR_GLOBAL, 0 CreaVariable VAR_ERROR, "", VAR_GLOBAL, 0 CreaVariable SCREEN_ACT, "0", VAR_GLOBAL, 0 CreaVariable RES_X, Screen.Width / Screen.TwipsPerPixelX, VAR_GLOBAL, 0 CreaVariable RES_Y, Screen.Height / Screen.TwipsPerPixelY, VAR_GLOBAL, 0 CreaVariable RUTA_PRG, App.Path, VAR_GLOBAL, 0 CreaVariable RUTA_DAT, Ruta(sFichAventura), VAR_GLOBAL, 0 CreaVariable NUM_LOC, IIf(bHayLoc, CStr(UBound(Localidades) + 1), "0"), VAR_GLOBAL, 0 CreaVariable NUM_OBJ, IIf(bHayObj, CStr(UBound(Objetos) + 1), "0"), VAR_GLOBAL, 0 CreaVariable NUM_PSI, IIf(bHayPSI, CStr(UBound(PSIs) + 1), "0"), VAR_GLOBAL, 0 CreaVariable NUM_PAL, IIf(bHayVoc, CStr(UBound(Vocabulario) + 1), "0"), VAR_GLOBAL, 0 CreaVariable PARSE_SEPAR, ".,:;", VAR_GLOBAL, 0 CreaVariable PARSE_COMILL, "'""", VAR_GLOBAL, 0 CreaVariable PARSE_TERMVERB, "LO" & Chr(SEPAR_ARRAY) & "LA" & Chr(SEPAR_ARRAY) & _ "LE" & Chr(SEPAR_ARRAY) & "LOS" & Chr(SEPAR_ARRAY) & "LAS" & Chr(SEPAR_ARRAY) & _ "LES" & Chr(SEPAR_ARRAY), VAR_GLOBAL, 0 CreaVariable PARSE_VERBO, "", VAR_GLOBAL, 0 CreaVariable PARSE_VERBOMOV, EXPR_FALSE, VAR_GLOBAL, 0 CreaVariable PARSE_NOMBRE1, "", VAR_GLOBAL, 0 CreaVariable PARSE_ADJETIVO1, "", VAR_GLOBAL, 0 CreaVariable PARSE_NOMBRE2, "", VAR_GLOBAL, 0 CreaVariable PARSE_ADJETIVO2, "", VAR_GLOBAL, 0 CreaVariable PARSE_PREPOS, "", VAR_GLOBAL, 0 CreaVariable PARSE_FRASE, "", VAR_GLOBAL, 0 CreaVariable PSI_JUGADOR, "0", VAR_GLOBAL, 0 ' --- VISUALIZACION --- Load frmVis frmVis.Inicializa '''frmVis.TamVentana 640, 480 '''frmVis.PosVentana ((Screen.Width - frmVis.Width) / 2) / Screen.TwipsPerPixelX, _ ((Screen.Height - frmVis.Height) / 2) / Screen.TwipsPerPixelY '''frmVis.Show ' --- OTROS --- Randomize bFinProg = False bReiniciar = False bReturn = False lProcActual = -1 ' control de errores ReDim Errores(0) Errores(0) = "" bIgnorarErrores = False sDescError = "" #If Not EsInterprete Then If bDepurar Then frmDebug.Show End If #End If End Sub ' finaliza la ejecución Public Sub FinalizaEjecucion() Unload frmVis FinalizaSonido End Sub ' ejecuta un bloque de código contenido en 'Lineas' ' devuelve el valor de la expresión del RETURN (si lo hay) si no devuelve cadena vacía ' si hay errores devuelve Chr(0) Private Function EjecutaBloque() As String Dim PilaLineas() As Linea Dim bSelect As Boolean Dim s As String, sResultado As String, sExpr As String, sError As String, _ sValSelect As String Dim i As Long, lPunteroLinAux As Long, lPunteroLinEnd As Long EjecutaBloque = "" If bFinProg Then Exit Function End If On Error GoTo Error_Ejecuta lPunteroLinea = 0 sError = "" bSelect = False sValSelect = "" Do While lPunteroLinea <> PUNTERO_SALIR And lPunteroLinea <= UBound(Lineas) _ And Not bFinProg And Not bReturn sDescError = "" #If Not EsInterprete Then ' actualiza ventana de depuración If bDepurar Then frmDebug.Depurar End If #End If ' si no está cargada la ventana de visualización, finalizamos If Not EstaCargado(frmVis) Then bFinProg = True End If If Not bFinProg Then Select Case Lineas(lPunteroLinea).Tipo Case LIN_COMANDO sResultado = EjecutaComando(Lineas(lPunteroLinea).Lin) If sResultado = Chr(0) Then sError = "Error al ejecutar comando" GoTo Error_Ejecuta End If Case LIN_COMENTARIO ' no debería aparecer ninguna de estas ya que son eliminadas antes lPunteroLinea = lPunteroLinea + 1 Case LIN_ASIGN sResultado = AnalizaExpresion(Lineas(lPunteroLinea).Lin) If sResultado = Chr(0) Then sError = "Error en asignación" GoTo Error_Ejecuta End If lPunteroLinea = lPunteroLinea + 1 Case LIN_FOR ' comprobamos que la sintaxis del FOR es correcta y analizamos ' la 1ª expresión (entre el FOR y el TO) que será de asignación If CompruebaFor(Lineas(lPunteroLinea).Lin) Then sExpr = SeparaExpr1For(Lineas(lPunteroLinea).Lin) sResultado = AnalizaExpresion(sExpr) If sResultado = Chr(0) Then sError = "Error en la expresión FOR" GoTo Error_Ejecuta End If Else sError = "Error en sentencia FOR" GoTo Error_Ejecuta End If lPunteroLinea = lPunteroLinea + 1 Case LIN_NEXT If Not Ejecuta_NEXT(Lineas(lPunteroLinea).Lin) Then sError = "Error en NEXT" GoTo Error_Ejecuta End If Case LIN_WHILE ' analizamos la expresión del WHILE y si es verdadera seguimos ' la ejecución en la sentencia siguiente, si no salimos del bucle sExpr = SeparaExprWhile(Lineas(lPunteroLinea).Lin) sResultado = AnalizaExpresion(sExpr) If sResultado = Chr(0) Then sError = "Error en la expresión WHILE" GoTo Error_Ejecuta ElseIf sResultado = EXPR_TRUE Then lPunteroLinea = lPunteroLinea + 1 Else lPunteroLinEnd = BuscarLoop If lPunteroLinEnd = PUNTERO_SALIR Then sError = "WHILE sin LOOP" GoTo Error_Ejecuta End If lPunteroLinea = lPunteroLinEnd + 1 End If Case LIN_LOOP If Not Ejecuta_LOOP(Lineas(lPunteroLinea).Lin) Then sError = "Error en LOOP" GoTo Error_Ejecuta End If Case LIN_IF If CompruebaIf(Lineas(lPunteroLinea).Lin) Then sExpr = SeparaExprIf(Lineas(lPunteroLinea).Lin) sResultado = AnalizaExpresion(sExpr) ' si la expresión es verdadera ejecutamos el bloque de código ' hasta el ELSE o el END, y si no ejecutamos el bloque de ' código desde el ELSE (si lo hay) If sResultado = Chr(0) Then sError = "Error en la expresión IF" GoTo Error_Ejecuta ElseIf sResultado = EXPR_TRUE Then lPunteroLinEnd = BuscarEndIf If lPunteroLinEnd = PUNTERO_SALIR Then sError = "IF sin ENDIF" GoTo Error_Ejecuta End If lPunteroLinAux = BuscarElse If lPunteroLinAux = PUNTERO_SALIR Then lPunteroLinAux = lPunteroLinEnd End If ' guardamos las líneas de código actual ReDim PilaLineas(UBound(Lineas)) For i = 0 To UBound(Lineas) PilaLineas(i) = Lineas(i) Next ' separamos el bloque entre el IF...ELSE/ENDIF ' y lo ejecutamos If Not SeparaBloque(lPunteroLinea + 1, lPunteroLinAux - 1) Then sError = "Error en bloque IF...ELSE" GoTo Error_Ejecuta End If If EjecutaBloque() = Chr(0) Then sError = "Error al ejecutar bloque IF" GoTo Error_Ejecuta End If ' recuperamos las líneas guardadas ReDim Lineas(UBound(PilaLineas)) For i = 0 To UBound(PilaLineas) Lineas(i) = PilaLineas(i) Next ' colocamos el puntero en el END (más tarde lo incrementamos) lPunteroLinea = lPunteroLinEnd Else lPunteroLinEnd = BuscarEndIf If lPunteroLinEnd = PUNTERO_SALIR Then sError = "IF sin ENDIF" GoTo Error_Ejecuta End If ' si encontramos un ELSE, ejecutamos el bloque desde ' ahí hasta el END, si no continuamos la ejecución ' después del END lPunteroLinAux = BuscarElse If lPunteroLinAux <> PUNTERO_SALIR Then ' guardamos las líneas de código actual ReDim PilaLineas(UBound(Lineas)) For i = 0 To UBound(Lineas) PilaLineas(i) = Lineas(i) Next ' separamos el bloque entre el ELSE...ENDIF ' y lo ejecutamos If Not SeparaBloque(lPunteroLinAux + 1, lPunteroLinEnd - 1) Then sError = "Error en bloque ELSE...ENDIF" GoTo Error_Ejecuta End If If EjecutaBloque() = Chr(0) Then sError = "Error al ejecutar bloque ELSE" GoTo Error_Ejecuta End If ' recuperamos las líneas guardadas ReDim Lineas(UBound(PilaLineas)) For i = 0 To UBound(PilaLineas) Lineas(i) = PilaLineas(i) Next ' colocamos el puntero en el ENDIF (más tarde lo incrementamos) lPunteroLinea = lPunteroLinEnd Else ' colocamos el puntero en el ENDIF (más tarde lo incrementamos) lPunteroLinea = lPunteroLinEnd End If End If Else sError = "Error en sentencia IF" GoTo Error_Ejecuta End If lPunteroLinea = lPunteroLinea + 1 Case LIN_ELSE lPunteroLinea = lPunteroLinea + 1 Case LIN_ENDIF lPunteroLinea = lPunteroLinea + 1 Case LIN_SELECT sExpr = SeparaExprCmd(Lineas(lPunteroLinea).Lin, CMD_SELECT) sResultado = AnalizaExpresion(sExpr) If sResultado = Chr(0) Then sError = "Error en la expresión SELECT" GoTo Error_Ejecuta Else ' guardamos el valor de la expresión del SELECT y saltamos ' hasta el primer CASE (todo lo que haya entre el SELECT y el CASE ' se ignora) sValSelect = sResultado bSelect = True lPunteroLinAux = BuscarCase If lPunteroLinAux = PUNTERO_SALIR Then sError = "SELECT sin CASE" GoTo Error_Ejecuta End If lPunteroLinea = lPunteroLinAux End If Case LIN_CASE If Not bSelect Then sError = "CASE sin SELECT" GoTo Error_Ejecuta End If sExpr = SeparaExprCmd(Lineas(lPunteroLinea).Lin, CMD_CASE) ' si es CASE * equiparamos al valor del SELECT para que ' coincida en la comprobación If sExpr = "*" Then sResultado = sValSelect Else sResultado = AnalizaExpresion(sExpr) End If If sResultado = Chr(0) Then sError = "Error en la expresión CASE" GoTo Error_Ejecuta Else If Not bSelect Then sError = "CASE sin SELECT" GoTo Error_Ejecuta Else ' si el resultado de la expresión del CASE es igual que ' el valor de la expresión del SELECT, ejecutamos el bloque ' de código hasta el siguiente CASE, si no saltamos al ' siguiente CASE o ENDSELECT If sResultado = sValSelect Then lPunteroLinAux = BuscarCase If lPunteroLinAux = PUNTERO_SALIR Then lPunteroLinAux = BuscarEndSelect If lPunteroLinAux = PUNTERO_SALIR Then sError = "SELECT sin CASE/ENDSELECT" GoTo Error_Ejecuta End If End If ' guardamos las líneas de código actual lPunteroLinEnd = lPunteroLinea ReDim PilaLineas(UBound(Lineas)) For i = 0 To UBound(Lineas) PilaLineas(i) = Lineas(i) Next ' separamos el bloque entre el CASE y el CASE/ENDSELECT siguiente ' y lo ejecutamos If Not SeparaBloque(lPunteroLinea + 1, lPunteroLinAux - 1) Then sError = "Error en bloque CASE" GoTo Error_Ejecuta End If If EjecutaBloque() = Chr(0) Then sError = "Error al ejecutar bloque CASE" GoTo Error_Ejecuta End If ' recuperamos las líneas guardadas ReDim Lineas(UBound(PilaLineas)) For i = 0 To UBound(PilaLineas) Lineas(i) = PilaLineas(i) Next lPunteroLinea = lPunteroLinEnd ' colocamos el puntero en el ENDSELECT siguiente lPunteroLinAux = BuscarEndSelect If lPunteroLinAux = PUNTERO_SALIR Then sError = "SELECT sin ENDSELECT" GoTo Error_Ejecuta End If lPunteroLinea = lPunteroLinAux Else lPunteroLinAux = BuscarCase If lPunteroLinAux = PUNTERO_SALIR Then lPunteroLinAux = BuscarEndSelect If lPunteroLinAux = PUNTERO_SALIR Then sError = "No se encontró CASE o ENDSELECT" GoTo Error_Ejecuta End If End If lPunteroLinea = lPunteroLinAux End If End If End If Case LIN_ENDSELECT If Not bSelect Then sError = "ENDSELECT sin SELECT" GoTo Error_Ejecuta End If lPunteroLinea = lPunteroLinea + 1 ' salida del programa Case LIN_EXIT lPunteroLinea = PUNTERO_SALIR bFinProg = True ' reinicio del programa Case LIN_RESTART lPunteroLinea = PUNTERO_SALIR bFinProg = True bReiniciar = True ' retorno de un procedimiento Case LIN_RETURN ' miramos si hay una expresión detrás del RETURN y la analizamos s = Lineas(lPunteroLinea).Lin If Len(s) > Len(CMD_RETURN) Then sExpr = Trim(Right(s, Len(s) - Len(CMD_RETURN))) sResultado = AnalizaExpresion(sExpr) If sResultado <> Chr(0) Then sError = "Error en RETURN" EjecutaBloque = sResultado End If End If lPunteroLinea = PUNTERO_SALIR bReturn = True End Select End If Loop Exit Function Error_Ejecuta: sError = IIf(sDescError = "", sError, sDescError) CreaVariable VAR_ERROR, sError, VAR_GLOBAL, 0 If Not bIgnorarErrores Then EjecutaBloque = Chr(0) If lProcActual = VAR_GLOBAL Then s = "***" Else s = Procedimientos(lProcActual).Nombre End If sError = s & " (" & Lineas(lPunteroLinea).Modulo & "/" & _ Lineas(lPunteroLinea).Numero & "): " & Lineas(lPunteroLinea).Lin & _ vbCrLf & Space(6) & sError '''MsgBox sError, vbOKOnly + vbCritical, "Error de ejecución" If Errores(0) = "" Then Errores(0) = sError Else i = UBound(Errores) + 1 ReDim Preserve Errores(i) Errores(i) = sError End If Else EjecutaBloque = "" End If sDescError = "" End Function ' ejecuta un comando de un módulo, devuelve Chr(0) si error Private Function EjecutaComando(ByVal sLin As String) As String Dim sCmd As String, sResultado As String Dim i As Long On Error GoTo Error_Ejecuta If cmd Is Nothing Then DescError "No se ha inicializado el intérprete" GoTo Error_Ejecuta End If If Not CompruebaLlamadaProc(sLin) Then GoTo Error_Ejecuta End If ' separa el comando y llama al método correspondiente i = InStr(sLin, PARENTESIS1) If i = 0 Then i = Len(sLin) + 1 End If If i > 1 Then sCmd = UCase(Left(sLin, i - 1)) ' intentamos con los comandos del sistema y si no evaluamos la expresión ' para que se ejecute el procedimiento correspondiente (si lo es) On Error Resume Next sResultado = CallByName(cmd, "VS_" & sCmd, VbMethod, sLin) If Err.Number = 0 Then If sResultado <> Chr(0) Then lPunteroLinea = lPunteroLinea + 1 EjecutaComando = sResultado Exit Function End If Else Err.Clear sResultado = AnalizaExpresion(sLin) If sResultado <> Chr(0) Then lPunteroLinea = lPunteroLinea + 1 EjecutaComando = sResultado Exit Function End If End If End If Error_Ejecuta: DescError "Error al ejecutar " & UCase(sCmd) EjecutaComando = Chr(0) End Function ' formatea y limpia una línea de caracteres extraños Public Function LimpiaLinea(ByVal sLin As String) As String Dim c As String, s As String Dim i As Long sLin = Trim(sLin) s = "" For i = 1 To Len(sLin) c = Mid(sLin, i, 1) If Asc(c) >= 32 Then s = s & c End If Next LimpiaLinea = s End Function ' quitamos los comentarios de la línea Public Function QuitaComentLin(ByVal sLin As String) As String Dim bComillas As Boolean, bEscape As Boolean Dim s As String, c As String, sComent As String Dim i As Long, l As Long Dim iComent As Integer ''' i = InStrRev(sLin, COMENTARIO) ''' If i = 1 Then ''' s = "" ''' ElseIf i > 1 Then ''' s = Left(sLin, i - 1) ''' Else ''' s = sLin ''' End If s = "" sComent = COMENTARIO iComent = 1 bComillas = False bEscape = False For i = 1 To Len(sLin) c = Mid(sLin, i, 1) If Not bComillas Then If c = COMILLAS Then bComillas = True ElseIf c = Mid(sComent, iComent, 1) Then iComent = iComent + 1 If iComent > Len(sComent) Then l = Len(s) - (iComent - 2) If l > 0 Then QuitaComentLin = Left(s, l) Else QuitaComentLin = "" End If Exit Function End If End If Else If c = ESCAPE Then bEscape = Not (bEscape) ElseIf c = COMILLAS Then If Not bEscape Then bComillas = False End If bEscape = False Else bEscape = False End If End If s = s & c Next QuitaComentLin = s End Function ' carga el "script" y lo almacena en la variable 'Lineas()' ' se cargan los módulos definidos por 'ListaMod()' ' devuelve una descripción del error o cadena vacía si no se produjo ninguno Public Function CargarScript() As String Dim i As Long Dim iFich As Integer Dim s As String, sFich As String, sScript As String, sErr As String #If Not EsInterprete Then Load frmCompilar frmCompilar.ProgressBar1.Min = 0 frmCompilar.ProgressBar1.Max = UBound(ListaMod) + 1 frmCompilar.ProgressBar1.value = 1 frmCompilar.Caption = "Ejecutar aventura" frmCompilar.Show SetWindowPos frmCompilar.hwnd, -1, 0, 0, 0, 0, SWP_FLAGS frmCompilar.lblInfo.Caption = "Cargando módulos..." frmCompilar.Refresh #End If ReDim Lineas(0) ReDim Procedimientos(0) bHayProc = False Screen.MousePointer = vbHourglass For i = 0 To UBound(ListaMod) #If Not EsInterprete Then frmCompilar.ProgressBar1.value = i + 1 frmCompilar.Refresh #End If On Error GoTo Error_Cargar2 sFich = RutaFich(sFichAventura) & "\" & ListaMod(i).Fichero iFich = FreeFile Open sFich For Input As #iFich On Error GoTo Error_Cargar1 sScript = "" Do While Not EOF(iFich) Line Input #iFich, s sScript = sScript & s & vbCrLf Loop Close #iFich sErr = SeparaLineas(ListaMod(i).Nombre, sScript) If sErr <> "" Then Err.Description = sErr GoTo Error_Cargar2 End If Next #If Not EsInterprete Then Unload frmCompilar #End If Screen.MousePointer = vbDefault CargarScript = "" Exit Function Error_Cargar1: Close #iFich Error_Cargar2: Screen.MousePointer = vbDefault CargarScript = Err.Description #If Not EsInterprete Then Unload frmCompilar #End If End Function ' construimos una lista con las líneas del módulo ' 'sModulo' es el nombre del módulo y 'sScript' es una cadena con el contenido del módulo ' devuelve una descripción si error o cadena vacía si no, Public Function SeparaLineas(ByVal sModulo As String, sScript As String) As String Dim sLin As String, sNombreProc As String Dim i As Long, n As Long, lLin As Long, lNumeroLinea As Long, lUltProc As Long Dim iTipo As Integer lLin = UBound(Lineas) lNumeroLinea = 0 ' esta variable indica si estamos dentro de un procedimiento lUltProc = -1 ' separamos las líneas y construimos una lista de líneas para ejecutar sLin = "" Do While sScript <> "" ' número de línea dentro del módulo lNumeroLinea = lNumeroLinea + 1 ' cada línea acaba con un retorno de carro (vbCrLf) a menos que encontremos ' un carácter de continuación de línea i = InStr(sScript, vbCrLf) If i = 0 Then sLin = sLin & sScript sScript = "" Else sLin = sLin & Left(sScript, i - 1) n = Len(sScript) - i - 1 If n > 0 Then sScript = Right(sScript, n) Else sScript = "" End If End If ' reformatea la línea sLin = LimpiaLinea(sLin) ' quitamos comentarios de la línea sLin = QuitaComentLin(sLin) ' si no tiene al final el carácter de continuación de línea ' es que tenemos una línea completa, en este caso comprobamos su tipo ' y la guardamos (excepto si es un comentario o una línea vacía) If sLin <> "" And Right(sLin, 1) <> CONT_LINEA Then iTipo = TipoLinea(sLin) If iTipo <> LIN_VACIA And iTipo <> LIN_COMENTARIO Then ' si es un procedimiento, crea una entrada en la lista de procedimientos ' para guardarlo If iTipo = LIN_SUB Then sNombreProc = GuardarProc(sLin) If sNombreProc = "" Then SeparaLineas = sModulo & " / " & CStr(lNumeroLinea) & ": error en definición de procedimiento" Exit Function Else ' si se ha podido insertar el procedimiento en la lista, guardamo ' su posición para introducirle las líneas de código lUltProc = UBound(Procedimientos) End If Else ' si estamos en un procedimiento, guardamos sus líneas de código If lUltProc >= 0 Then If Not Procedimientos(lUltProc).HayLineas Then i = 0 Else i = UBound(Procedimientos(lUltProc).Lineas) + 1 End If ReDim Preserve Procedimientos(lUltProc).Lineas(i) Procedimientos(lUltProc).Lineas(i).Modulo = sModulo Procedimientos(lUltProc).Lineas(i).Numero = lNumeroLinea Procedimientos(lUltProc).Lineas(i).Tipo = iTipo Procedimientos(lUltProc).Lineas(i).Lin = sLin Procedimientos(lUltProc).HayLineas = True Else ReDim Preserve Lineas(lLin) Lineas(lLin).Modulo = sModulo Lineas(lLin).Numero = lNumeroLinea Lineas(lLin).Tipo = iTipo Lineas(lLin).Lin = sLin lLin = lLin + 1 End If End If End If sLin = "" ElseIf Right(sLin, 1) = CONT_LINEA Then ' eliminamos el carácter de continuación de línea para seguir agregando sLin = Left(sLin, Len(sLin) - 1) End If Loop SeparaLineas = "" End Function ' guarda un procedimiento, devuelve el nombre del procedimiento si pudo guardarlo ' o cadena vacía si error Private Function GuardarProc(ByVal sLin As String) As String Dim i As Long, j As Long Dim c As String, sPar As String, sParam() As String If Len(sLin) = Len(CMD_SUB) Then GuardarProc = "" Exit Function End If sLin = UCase(Trim(Right(sLin, Len(sLin) - Len(CMD_SUB)))) ' separamos el nombre del procedimiento de los parámetros (si los tiene) ' esperamos algo de la forma: PROCEDIMIENTO(par1,par2,...) sPar = SeparaParametros(sLin) If sPar = Chr(0) Then GuardarProc = "" Exit Function End If sLin = Left(sLin, Len(sLin) - Len(sPar) - 2) ' comprueba el nombre del procedimiento If Not CompruebaNombreProcVar(sLin) Then GuardarProc = "" Exit Function End If ' separamos los parámetros (deben ir de la forma: a,b,c...) ReDim sParam(0) sParam(0) = "" If sPar <> "" Then i = 1 Do While True c = CogeParametro(sPar, i) ' si no encontramos más parámetros, salimos If c = Chr(0) Then Exit Do End If ReDim Preserve sParam(i - 1) sParam(i - 1) = c i = i + 1 Loop End If If Not bHayProc Then ReDim Procedimientos(0) i = 0 bHayProc = True Else ' comprueba que no exista ya un procedimiento definido con el mismo nombre For i = 0 To UBound(Procedimientos) If Procedimientos(i).Nombre = sLin Then GuardarProc = "" Exit Function End If Next i = UBound(Procedimientos) i = i + 1 ReDim Preserve Procedimientos(i) End If Procedimientos(i).Nombre = sLin ReDim Procedimientos(i).Lineas(0) Procedimientos(i).HayLineas = False ' guardamos los parámetros ReDim Procedimientos(i).Param(0) If sParam(0) = "" Then Procedimientos(i).HayParam = False Else For j = 0 To UBound(sParam) ReDim Preserve Procedimientos(i).Param(j) Procedimientos(i).Param(j) = sParam(j) Next Procedimientos(i).HayParam = True End If Procedimientos(i).NumSerie = 0 GuardarProc = Procedimientos(i).Nombre End Function ' devuelve el parámetro n-ésimo de una cadena de la forma par1,par2,par3,... ' devuelve Chr(0) si no se encuentra Public Function CogeParametro(ByVal s As String, ByVal n As Integer) As String Dim bComillas As Boolean, bEncontrado As Boolean Dim i As Long, lPar As Long, lInicio As Long, lFin As Long, lParentesis As Long Dim c As String, sPar As String If n < 1 Then CogeParametro = Chr(0) Exit Function End If sPar = "" ' buscamos el inicio y el final del campo lPar = 0 bComillas = False lInicio = 1 lFin = 0 bEncontrado = False lParentesis = 0 For i = 1 To Len(s) c = Mid(s, i, 1) If c = PARENTESIS1 Then lParentesis = lParentesis + 1 ElseIf c = PARENTESIS2 Then lParentesis = lParentesis - 1 ElseIf c = COMILLAS Then bComillas = Not bComillas End If If lParentesis = 0 And ((c = SEPAR_PARAM And Not bComillas) Or i = Len(s)) Then lPar = lPar + 1 lInicio = lFin + 1 lFin = i If lPar = n Then If lFin < Len(s) Then lFin = lFin - 1 End If bEncontrado = True Exit For End If End If Next ' no lo encontró If Not bEncontrado Then CogeParametro = Chr(0) Exit Function End If On Error Resume Next sPar = Mid(s, lInicio, lFin - lInicio + 1) If Err.Number = 0 Then CogeParametro = sPar Else CogeParametro = Chr(0) End If End Function ' devuelve el tipo de una línea de un módulo Private Function TipoLinea(ByVal sLin As String) As Integer Dim i As Integer Dim s As String sLin = UCase(sLin) ' línea vacía If Trim(sLin) = "" Then TipoLinea = LIN_VACIA Exit Function End If ' comentario If Left(sLin, Len(COMENTARIO)) = COMENTARIO Then TipoLinea = LIN_COMENTARIO Exit Function End If ' asignación de variable i = InStr(sLin, CMD_ASIGN) If i > 0 Then s = Trim(Left(sLin, i - 1)) If TipoOperando(s) = OP_VARIABLE Then TipoLinea = LIN_ASIGN Exit Function End If End If ' FOR If Left(sLin, Len(CMD_FOR)) = CMD_FOR Then TipoLinea = LIN_FOR Exit Function End If ' NEXT If Left(sLin, Len(CMD_NEXT)) = CMD_NEXT Then TipoLinea = LIN_NEXT Exit Function End If ' WHILE If Left(sLin, Len(CMD_WHILE)) = CMD_WHILE Then TipoLinea = LIN_WHILE Exit Function End If ' LOOP If Left(sLin, Len(CMD_LOOP)) = CMD_LOOP Then TipoLinea = LIN_LOOP Exit Function End If ' IF If Left(sLin, Len(CMD_IF)) = CMD_IF Then TipoLinea = LIN_IF Exit Function End If ' ELSE If Left(sLin, Len(CMD_ELSE)) = CMD_ELSE Then TipoLinea = LIN_ELSE Exit Function End If ' ENDIF If Left(sLin, Len(CMD_ENDIF)) = CMD_ENDIF Then TipoLinea = LIN_ENDIF Exit Function End If ' SELECT If Left(sLin, Len(CMD_SELECT)) = CMD_SELECT Then TipoLinea = LIN_SELECT Exit Function End If ' CASE If Left(sLin, Len(CMD_CASE)) = CMD_CASE Then TipoLinea = LIN_CASE Exit Function End If ' ENDSELECT If Left(sLin, Len(CMD_ENDSELECT)) = CMD_ENDSELECT Then TipoLinea = LIN_ENDSELECT Exit Function End If ' EXIT If Left(sLin, Len(CMD_EXIT)) = CMD_EXIT Then TipoLinea = LIN_EXIT Exit Function End If ' SUB If Left(sLin, Len(CMD_SUB)) = CMD_SUB Then TipoLinea = LIN_SUB Exit Function End If ' RETURN If Left(sLin, Len(CMD_RETURN)) = CMD_RETURN Then TipoLinea = LIN_RETURN Exit Function End If ' RESTART If Left(sLin, Len(CMD_RESTART)) = CMD_RESTART Then TipoLinea = LIN_RESTART Exit Function End If TipoLinea = LIN_COMANDO End Function ''''''JABA: 24-4-2000 '''Private Function EsNumerico(ByVal s As String) As Boolean ''' ''' EsNumerico = InStr(CAR_NUMEROS, s) > 0 ''' '''End Function ''' '''Private Function EsLetra(ByVal s As String) As Boolean ''' Dim c As String ''' Dim i As Integer ''' ''' If Len(s) = 0 Then ''' EsLetra = False ''' Else ''' c = UCase(Left(s, 1)) ''' '''EsLetra = (c >= "A" And c <= "Z") _ ''' ''' Or c = "_" Or c = "Ñ" _ ''' ''' Or c = "Á" Or c = "É" Or c = "Í" _ ''' ''' Or c = "Ó" Or c = "Ú" ''' EsLetra = InStr(CAR_PROC, c) > 0 ''' End If ''' '''End Function ''' '''' obtiene el siguiente token '''Public Function GetTok(ByRef cadena As String) As LexBuf ''' Dim s As String, sUno As String, sDos As String, sTok As String ''' Dim iTokn As Integer ''' ''' ' primero mira si se acabó, en ese caso devuelve el token del final ''' If Len(cadena) = 0 Then ''' GetTok.TipoTok = TIPO_FIN ''' Exit Function ''' End If ''' ''' 'toma el primer carácter pero elimina los espacios ''' '''Inicio: ''' '''s = Mid(cadena, 1, 1) ''' '''If s = " " Then ''' ''' cadena = Right(cadena, Len(cadena) - 1) ''' ''' GoTo Inicio ''' '''End If ''' cadena = RTrim(cadena) ''' If Len(cadena) = 0 Then ''' GetTok.TipoTok = TIPO_FIN ''' Exit Function ''' End If ''' s = Left(cadena, 1) ''' ''' If EsLetra(s) Then ' es un identificador ''' sTok = GetId(cadena) ''' GetTok.Cad = sTok ''' GetTok.TipoTok = TIPO_ID ' tipo cadena ''' ElseIf EsNumerico(s) Then ' es un número ''' iTokn = GetNum(cadena) ''' GetTok.Num = iTokn ''' GetTok.Cad = Trim(Str(iTokn)) ''' GetTok.TipoTok = TIPO_NUMERO ''' ElseIf s = COMILLAS Then ' cadena de caracteres ''' sTok = GetCad(cadena) ''' GetTok.Cad = sTok ''' GetTok.TipoTok = TIPO_CADENA ''' Else ' debería ser un operador ''' If Len(cadena) > 1 Then ''' sDos = Left(cadena, 2) ''' Else ''' sDos = "" ''' End If ''' ''' ' reconoce operador ''' ' primero busca operadores dobles ''' sUno = s ''' If sDos = OPER_MAYIGUAL Or sDos = OPER_MENIGUAL _ ''' Or sDos = OPER_DISTINTO Or sDos = CMD_ASIGN Then ''' GetTok.Cad = sDos ''' GetTok.TipoTok = TIPO_OPERADOR ''' cadena = Mid(cadena, 3, Len(cadena) - 2) ''' ElseIf sUno = PARENTESIS1 Or sUno = PARENTESIS2 _ ''' Or sUno = OPER_MAS Or sUno = OPER_MENOS _ ''' Or sUno = OPER_MULTIPL Or sUno = OPER_DIV _ ''' Or sUno = OPER_DIV Or sUno = OPER_IGUAL _ ''' Or sUno = OPER_MAYOR Or sUno = OPER_MENOR _ ''' Or sUno = OPER_AND Or sUno = OPER_OR Then ''' GetTok.Cad = sUno ''' GetTok.TipoTok = TIPO_OPERADOR ''' cadena = Mid(cadena, 2, Len(cadena) - 1) ''' Else ''' GetTok.TipoTok = TIPO_DESCONOCIDO ''' End If ''' End If ''' '''End Function ''' '''' extrae la cadena de un String '''' devuelve Chr(0) si error '''Private Function GetCad(ByRef cadena As String) As String ''' Dim s As String ''' Dim iLng As Integer ''' ''' If Left(cadena, 1) <> COMILLAS Then ''' GetCad = Chr(0) ''' Exit Function ''' End If ''' ''' iLng = ExtraeCadena(cadena, s, 2) ''' cadena = Mid(cadena, iLng + 1, Len(cadena)) ''' GetCad = s ''' '''End Function ''' '''' obtiene el siguiente identificador de un string '''' devuelve Chr(0) si error '''Private Function GetId(ByRef cadena As String) As String ''' Dim i As Long ''' Dim sCad As String ''' ''' i = 1 ' contador de por dónde vamos extrayendo ''' sCad = "" ' cadena temporal donde vamos guardando lo extraido ''' ''' Do While (EsLetra(Mid(cadena, i, 1)) Or (i > 1 And EsNumerico(Mid(cadena, i, 1)))) _ ''' And i <= Len(cadena) ''' sCad = sCad + Mid(cadena, i, 1) ''' i = i + 1 ''' Loop ''' ''' If sCad = "" Then ''' GetId = Chr(0) ''' Exit Function ''' End If ''' ''' ' quita el número de la cadena ''' cadena = Mid(cadena, i, Len(cadena)) ''' ''' GetId = sCad ''' '''End Function ''' '''' obtiene el siguiente número de un string '''' devuelve Chr(0) si error '''Private Function GetNum(ByRef cadena As String) As Long ''' Dim i As Long ''' Dim sCad As String ''' ''' i = 1 ' contador de por dónde vamos extrayendo ''' sCad = "" ' cadena temporal donde vamos guardando lo extraido ''' ''' Do While EsNumerico(Mid(cadena, i, 1)) And (i <= Len(cadena)) ''' sCad = sCad + Mid(cadena, i, 1) ''' i = i + 1 ''' Loop ''' ''' If sCad = "" Then ''' GetNum = Chr(0) ''' Exit Function ''' End If ''' ''' ' quita el número de la cadena ''' cadena = Mid(cadena, i, Len(cadena)) ''' ''' GetNum = CLng(sCad) ''' '''End Function ''' '''' GRAMÁTICA DE LAS EXPRESIONES DE VS '''' '''' E -> id := E '''' E -> func() '''' E -> T MT '''' MT -> + T MT '''' MT -> nada '''' '''' T -> F MF '''' MF -> * F MF '''' MF -> nada '''' '''' F -> id '''' F -> INT '''' F -> CAD '''' F -> (E) '''' F -> -E ''' '''' realiza el look-ahead '''Private Sub Prebuscar() ''' Prebuscado = GetTok(L_Cad) '''End Sub ''' '''' deshace el último look-ahead '''Sub DesPrebuscar() ''' L_Cad = Prebuscado.Cad + L_Cad '''End Sub ''' '''Function FACTOR() As Valor ''' Dim SigToken As LexBuf ''' Dim Temp As Valor ''' Dim c As String, sTmpCad As String, sResultado As String, _ ''' sExpr As String, sResSubExpr As String, sSubExpr As String ''' Dim bEsProcedimiento As Boolean, bTieneD As Boolean ''' Dim i As Long, j As Long, k As Long ''' Dim iVarObj As Integer, iErr As Integer ''' ''' ' obtener siguiente token ''' SigToken = Prebuscado ''' ''' If SigToken.TipoTok = TIPO_NUMERO Then ''' ' F -> INT ''' FACTOR.Tipo = SigToken.TipoTok ''' FACTOR.Con = Trim(Str(SigToken.Num)) ''' Prebuscar ''' ElseIf SigToken.TipoTok = TIPO_CADENA Then ''' ' F-> CAD ''' FACTOR.Tipo = SigToken.TipoTok ''' FACTOR.Con = SigToken.Cad ''' Prebuscar ''' ElseIf SigToken.TipoTok = TIPO_ID Then ''' ' F -> id ''' ' podría ser un objeto, un procedimiento o una variable ''' ' vemos si tiene paréntesis o corchete delante, sino es una variable ''' If Len(L_Cad) = 0 Then ''' bTieneD = False ''' Else ''' bTieneD = (Left(L_Cad, 1) = "(") Or (Left(L_Cad, 1) = "[") ''' End If ''' ''' If Not bTieneD Then ' es variable ''' FACTOR.Con = ValorVariable(SigToken.Cad) ''' ' averiguar el tipo del identificador ''' sTmpCad = FACTOR.Con ''' If sTmpCad = "" Then ''' FACTOR.Tipo = TIPO_CADENA ''' Else ''' FACTOR.Tipo = GetTok(sTmpCad).TipoTok ''' If FACTOR.Tipo <> TIPO_NUMERO Then ''' FACTOR.Tipo = TIPO_CADENA ''' End If ''' End If ''' Prebuscar ''' Else ' no es una variable ''' ' asignaciones para compatibilizar el código de JABA con el código de JSJ ''' ' lo que hay antes de los paréntesis, el identificador ''' sResultado = Prebuscado.Cad ''' sExpr = L_Cad ''' i = 1 ''' c = Left(L_Cad, 1) ''' ''' If c = PARENTESIS1 Then ''' sResSubExpr = Chr(0) ''' ''' ' en 'sResultado' tenemos lo que hay antes del paréntesis ''' ' comprobamos si es una referencia a un objeto ''' iVarObj = EsVarObj(sResultado) ''' If iVarObj <> 0 Then ''' ' separamos los parámetros ''' k = BuscaCierreParentesis(sExpr, i + 1) ''' If k = 0 Then ''' DescError "Falta paréntesis de cierre" ''' FACTOR.Tipo = TIPO_ERRONEO ''' Exit Function ''' End If ''' sSubExpr = Mid(sExpr, i + 1, k - i - 1) ''' ''' sResSubExpr = ValorVarObj(sResultado & PARENTESIS1 & sSubExpr & PARENTESIS2, iVarObj) ''' If sResSubExpr = Chr(0) Then ''' DescError "Error al ejecutar método de objeto: " & UCase(sResultado) ''' FACTOR.Tipo = TIPO_ERRONEO ''' Exit Function ''' End If ''' Else ''' ' probamos si es un comando del sistema ''' On Error Resume Next ''' ' cogemos los parámetros ''' k = BuscaCierreParentesis(sExpr, i + 1) ''' If k = 0 Then ''' sSubExpr = "" ''' Else ''' sSubExpr = Mid(sExpr, i, k - i + 1) ''' End If ''' sResSubExpr = CallByName(cmd, "VS_" & sResultado, VbMethod, sResultado & sSubExpr) ''' ' guardamos el código de error (0 si era un comando válido) ''' iErr = Err.Number ''' On Error GoTo Error_Analiza ''' ' si era un comando del sistema ''' If iErr = 0 Then ''' If sResSubExpr = Chr(0) Then ''' FACTOR.Tipo = TIPO_ERRONEO ''' Exit Function ''' End If ''' Else ''' ' comprobamos si es el nombre de un procedimiento en cuyo caso le llamamos ''' ' con los parámetros dentro del paréntesis ''' bEsProcedimiento = False ''' For j = 0 To UBound(Procedimientos) ''' If Procedimientos(j).Nombre = UCase(sResultado) Then ''' bEsProcedimiento = True ''' Exit For ''' End If ''' Next ''' ''' If bEsProcedimiento Then ''' ' separamos los parámetros ''' k = BuscaCierreParentesis(sExpr, i + 1) ''' If k = 0 Then ''' DescError "Falta paréntesis de cierre" ''' FACTOR.Tipo = TIPO_ERRONEO ''' Exit Function ''' End If ''' sSubExpr = Mid(sExpr, i + 1, k - i - 1) ''' ''' sResSubExpr = EjecutaProc(sResultado, sSubExpr) ''' If sResSubExpr = Chr(0) Then ''' DescError "Error al ejecutar " & UCase(sResultado) ''' FACTOR.Tipo = TIPO_ERRONEO ''' Exit Function ''' End If ''' End If ''' End If ''' End If ''' ''' ' si pudo ejecutar un comando del sistema o un procedimiento ''' If sResSubExpr <> Chr(0) Then ''' ' si el valor devuelto por el procedimiento no es numérico lo formateamos ''' ' como si fuese una cadena ''' If TipoOperando(sResSubExpr) <> OP_NUMERICO Then ''' sResSubExpr = COMILLAS & sResSubExpr & COMILLAS ''' End If ''' ''' ' sustituimos la llamada al procedimiento por el valor devuelto ''' sResultado = sResSubExpr ''' Else ''' ' si hemos encontrado el paréntesis de apertura al final de la expresión ''' ' devuelve error ''' If i = Len(sExpr) Then ''' DescError "Falta paréntesis de cierre" ''' FACTOR.Tipo = TIPO_ERRONEO ''' Exit Function ''' End If ''' ' buscamos cierre de paréntesis y si no lo encontramos devolvemos error ''' j = BuscaCierreParentesis(sExpr, i + 1) ''' If j = 0 Then ''' DescError "Falta paréntesis de cierre" ''' FACTOR.Tipo = TIPO_ERRONEO ''' Exit Function ''' Else ''' sSubExpr = Mid(sExpr, i + 1, j - i - 1) ''' ' nos llamamos recursivamente para analizar la subexpresión... ''' sResSubExpr = AnalizaExpresion(sSubExpr) ''' ' ...y sustituimos la subexpresión por el resultado (si no hubo error) ''' If sResSubExpr = Chr(0) Then ''' DescError "Error en la expresión: " & sSubExpr ''' FACTOR.Tipo = TIPO_ERRONEO ''' Exit Function ''' End If ''' sExpr = Sustituye(sExpr, i, j - i + 1, sResSubExpr) ''' ' retrocedemos una posición para analizar a partir de la sustitución ''' i = i - 1 ''' End If ''' End If ''' ElseIf c = CORCHETE1 Then ''' j = BuscaCierreCorchete(sExpr, i + 1) ''' If j = 0 Then ''' DescError "Falta corchete de cierre" ''' FACTOR.Tipo = TIPO_ERRONEO ''' Exit Function ''' End If ''' sSubExpr = Mid(sExpr, i + 1, j - i - 1) ''' ''' ' analizamos la expresión entre corchetes ''' sResSubExpr = AnalizaExpresion(sSubExpr) ''' If sResSubExpr = Chr(0) Then ''' DescError "Error en la expresión: " & sSubExpr ''' FACTOR.Tipo = TIPO_ERRONEO ''' Exit Function ''' End If ''' ''' ' sustituimos en el resultado la expresión por su valor (el valor lo ponemos ''' ' entre comillas ya que, supuestamente, por estar entre corchetes, estamos ''' ' analizando una referencia a un objeto) ''' sResultado = sResultado & CORCHETE1 & COMILLAS & sResSubExpr & COMILLAS & CORCHETE2 ''' ''' '''JSJ::: ''' '''tenemos OBJ[val] ''' '''hay que evaluar OBJ[val].ID o OBJ[val].ID(par1,par2,...) ''' End If ''' ''' FACTOR.Con = sResultado ''' ''' ' averiguar el tipo del identificador ''' sTmpCad = FACTOR.Con ''' If sTmpCad = "" Then ''' FACTOR.Tipo = TIPO_CADENA ''' Else ''' FACTOR.Tipo = GetTok(sTmpCad).TipoTok ''' If FACTOR.Tipo <> TIPO_NUMERO Then ''' FACTOR.Tipo = TIPO_CADENA ''' End If ''' End If ''' End If ''' ElseIf SigToken.Cad = "(" Then ''' ' F->(E) ''' Prebuscar ''' FACTOR = EXPRESION() ''' If Prebuscado.Cad <> ")" Then ''' DescError ("Se esperaba el cierre de paréntesis, pero se encontró " + Prebuscado.Cad) ''' FACTOR.Tipo = TIPO_ERRONEO ''' End If ''' ElseIf SigToken.Cad = "-" Then ''' Prebuscar ''' Temp = EXPRESION() ''' Select Case Temp.Tipo ''' Case TIPO_ERRONEO ''' FACTOR.Tipo = TIPO_ERRONEO ''' Case TIPO_NUMERO ''' FACTOR = Temp ''' FACTOR.Con = Trim(Str(CLng(FACTOR.Con) * (-1))) ''' Case TIPO_CADENA ''' DescError ("No puede aplicarse el operador de negación a cadenas") ''' FACTOR.Tipo = TIPO_ERRONEO ''' Case Else ''' DescError "Algo horroroso ha sucedido en Factor - contacta con el autor" ''' FACTOR.Tipo = TIPO_ERRONEO ''' End Select ''' Else ' no conocido ''' GoTo Error_Analiza ''' End If ''' ''' Exit Function ''' '''Error_Analiza: ''' FACTOR.Tipo = TIPO_ERRONEO '''End Function ''' '''' T -> F MF '''Function TERMINO() As Valor ''' Dim Temp As Valor ''' ''' Temp = FACTOR ''' If Temp.Tipo = TIPO_ERRONEO Then ''' TERMINO.Tipo = TIPO_ERRONEO ''' Else ''' TERMINO = MF(Temp) ''' End If ''' '''End Function ''' '''' MT -> + T MT '''' MT -> - T MT '''' MT -> AND T MT '''' MT -> OR T MT '''' MT -> nada '''Function MT(T_H As Valor) As Valor ''' Dim Temp As Valor, NuevoTok As Valor ''' Dim bTres As Boolean ''' ''' Select Case Prebuscado.Cad ''' Case "+" ''' Prebuscar ''' Temp = TERMINO ''' If Temp.Tipo = TIPO_ERRONEO Then ''' MT.Tipo = TIPO_ERRONEO ''' Else ''' NuevoTok.Con = CalculaOperacion("+", T_H.Con, (T_H.Tipo = TIPO_CADENA), Temp.Con, (Temp.Tipo = TIPO_CADENA), bTres) ''' If bTres Then ''' NuevoTok.Tipo = TIPO_CADENA ''' Else ''' NuevoTok.Tipo = TIPO_NUMERO ''' End If ''' MT = MT(NuevoTok) ''' End If ''' Case "-" ''' Prebuscar ''' Temp = TERMINO ''' If Temp.Tipo = TIPO_ERRONEO Then ''' MT.Tipo = TIPO_ERRONEO ''' Else ''' NuevoTok.Con = CalculaOperacion("-", T_H.Con, (T_H.Tipo = TIPO_CADENA), Temp.Con, (Temp.Tipo = TIPO_CADENA), bTres) ''' If bTres Then ''' NuevoTok.Tipo = TIPO_CADENA ''' Else ''' NuevoTok.Tipo = TIPO_NUMERO ''' End If ''' MT = MT(NuevoTok) ''' End If ''' Case OPER_AND ''' Prebuscar ''' Temp = TERMINO ''' If Temp.Tipo = TIPO_ERRONEO Then ''' MT.Tipo = TIPO_ERRONEO ''' Else ''' NuevoTok.Con = CalculaOperacion(OPER_AND, T_H.Con, (T_H.Tipo = TIPO_CADENA), Temp.Con, (Temp.Tipo = TIPO_CADENA), bTres) ''' If bTres Then ''' NuevoTok.Tipo = TIPO_CADENA ''' Else ''' NuevoTok.Tipo = TIPO_NUMERO ''' End If ''' MT = MT(NuevoTok) ''' End If ''' Case OPER_OR ''' Prebuscar ''' Temp = TERMINO() ''' If Temp.Tipo = TIPO_ERRONEO Then ''' MT.Tipo = TIPO_ERRONEO ''' Else ''' NuevoTok.Con = CalculaOperacion("&", T_H.Con, (T_H.Tipo = TIPO_CADENA), Temp.Con, (Temp.Tipo = TIPO_CADENA), bTres) ''' If bTres Then ''' NuevoTok.Tipo = TIPO_CADENA ''' Else ''' NuevoTok.Tipo = TIPO_NUMERO ''' End If ''' MT = MT(NuevoTok) ''' End If ''' Case Else ' nada ''' MT = T_H ''' End Select ''' '''End Function ''' '''' MF -> * F MF '''' MF -> / F MF '''' MF -> oplog F MF (oplog es <,>,etc...) '''' MF -> nada '''Private Function MF(T_H As Valor) As Valor ''' Dim Temp As Valor, NuevoTok As Valor ''' Dim bTres As Boolean ''' ''' Select Case Prebuscado.Cad ''' Case "*" ''' Prebuscar ''' Temp = FACTOR ''' If Temp.Tipo = TIPO_ERRONEO Then ''' MF.Tipo = TIPO_ERRONEO ''' Else ''' NuevoTok.Con = CalculaOperacion("*", T_H.Con, (T_H.Tipo = TIPO_CADENA), Temp.Con, (Temp.Tipo = TIPO_CADENA), bTres) ''' If bTres Then ''' NuevoTok.Tipo = TIPO_CADENA ''' Else ''' NuevoTok.Tipo = TIPO_NUMERO ''' End If ''' MF = MF(NuevoTok) ''' End If ''' Case "/" ''' Prebuscar ''' Temp = FACTOR ''' If Temp.Tipo = TIPO_ERRONEO Then ''' MF.Tipo = TIPO_ERRONEO ''' Else ''' NuevoTok.Con = CalculaOperacion("/", T_H.Con, (T_H.Tipo = TIPO_CADENA), Temp.Con, (Temp.Tipo = TIPO_CADENA), bTres) ''' If bTres Then ''' NuevoTok.Tipo = TIPO_CADENA ''' Else ''' NuevoTok.Tipo = TIPO_NUMERO ''' End If ''' MF = MF(NuevoTok) ''' End If ''' Case "<" ''' Prebuscar ''' Temp = FACTOR ''' If Temp.Tipo = TIPO_ERRONEO Then ''' MF.Tipo = TIPO_ERRONEO ''' Else ''' NuevoTok.Con = CalculaOperacion("<", T_H.Con, (T_H.Tipo = TIPO_CADENA), Temp.Con, (Temp.Tipo = TIPO_CADENA), bTres) ''' If bTres Then ''' NuevoTok.Tipo = TIPO_CADENA ''' Else ''' NuevoTok.Tipo = TIPO_NUMERO ''' End If ''' MF = MF(NuevoTok) ''' End If ''' Case ">" ''' Prebuscar ''' Temp = FACTOR ''' If Temp.Tipo = TIPO_ERRONEO Then ''' MF.Tipo = TIPO_ERRONEO ''' Else ''' NuevoTok.Con = CalculaOperacion(">", T_H.Con, (T_H.Tipo = TIPO_CADENA), Temp.Con, (Temp.Tipo = TIPO_CADENA), bTres) ''' If bTres Then ''' NuevoTok.Tipo = TIPO_CADENA ''' Else ''' NuevoTok.Tipo = TIPO_NUMERO ''' End If ''' MF = MF(NuevoTok) ''' End If ''' Case "<=" ''' Prebuscar ''' Temp = FACTOR ''' If Temp.Tipo = TIPO_ERRONEO Then ''' MF.Tipo = TIPO_ERRONEO ''' Else ''' NuevoTok.Con = CalculaOperacion("<=", T_H.Con, (T_H.Tipo = TIPO_CADENA), Temp.Con, (Temp.Tipo = TIPO_CADENA), bTres) ''' If bTres Then ''' NuevoTok.Tipo = TIPO_CADENA ''' Else ''' NuevoTok.Tipo = TIPO_NUMERO ''' End If ''' MF = MF(NuevoTok) ''' End If ''' Case ">=" ''' Prebuscar ''' Temp = FACTOR ''' If Temp.Tipo = TIPO_ERRONEO Then ''' MF.Tipo = TIPO_ERRONEO ''' Else ''' NuevoTok.Con = CalculaOperacion(">=", T_H.Con, (T_H.Tipo = TIPO_CADENA), Temp.Con, (Temp.Tipo = TIPO_CADENA), bTres) ''' If bTres Then ''' NuevoTok.Tipo = TIPO_CADENA ''' Else ''' NuevoTok.Tipo = TIPO_NUMERO ''' End If ''' MF = MF(NuevoTok) ''' End If ''' Case "<>" ''' Prebuscar ''' Temp = FACTOR ''' If Temp.Tipo = TIPO_ERRONEO Then ''' MF.Tipo = TIPO_ERRONEO ''' Else ''' NuevoTok.Con = CalculaOperacion("<>", T_H.Con, (T_H.Tipo = TIPO_CADENA), Temp.Con, (Temp.Tipo = TIPO_CADENA), bTres) ''' If bTres Then ''' NuevoTok.Tipo = TIPO_CADENA ''' Else ''' NuevoTok.Tipo = TIPO_NUMERO ''' End If ''' MF = MF(NuevoTok) ''' End If ''' Case "=" ''' Prebuscar ''' Temp = FACTOR ''' If Temp.Tipo = TIPO_ERRONEO Then ''' MF.Tipo = TIPO_ERRONEO ''' Else ''' NuevoTok.Con = CalculaOperacion("=", T_H.Con, (T_H.Tipo = TIPO_CADENA), Temp.Con, (Temp.Tipo = TIPO_CADENA), bTres) ''' If bTres Then ''' NuevoTok.Tipo = TIPO_CADENA ''' Else ''' NuevoTok.Tipo = TIPO_NUMERO ''' End If ''' MF = MF(NuevoTok) ''' End If ''' Case Else ' nada ''' MF = T_H ''' End Select ''' '''End Function ''' '''Private Function EXPRESION() As Valor ''' Dim sID As String, sSubExp As String ''' Dim Temp As Valor ''' ''' Select Case Prebuscado.TipoTok ''' Case TIPO_ID ' ¿E -> id := E? ''' sID = Prebuscado.Cad ''' Prebuscar ''' If Prebuscado.Cad <> CMD_ASIGN Then ' no era signación sino FACTOR NORMAL ''' ' deshacer el look-ahead ''' DesPrebuscar ''' Prebuscado.Cad = sID ''' Prebuscado.TipoTok = TIPO_ID ''' Temp = TERMINO ' era E -> T MT ''' If Temp.Tipo = TIPO_ERRONEO Then ''' EXPRESION.Tipo = TIPO_ERRONEO ''' Else ''' EXPRESION = MT(Temp) ''' End If ''' Else ' es E -> id := E ''' ' analiza la subexpresión que se asigna a la variable ''' sSubExp = AnalizaExpresion(L_Cad) ''' If sSubExp = Chr(0) Then ''' EXPRESION.Tipo = TIPO_ERRONEO ''' Exit Function ''' End If ''' ''' ' ya tenemos el nombre de la variable y su valor, asignamos ''' If AsignaVariable(sID, sSubExp) = Chr(0) Then ''' ' si no pudimos asignar, devolvemos error ''' EXPRESION.Tipo = TIPO_ERRONEO ''' Else ''' EXPRESION.Con = EXPR_TRUE ''' EXPRESION.Tipo = TIPO_CORRECTO ''' End If ''' End If ''' Case Else ''' ' E -> T MT ''' Temp = TERMINO ' era E -> T MT ''' If Temp.Tipo = TIPO_ERRONEO Then ''' EXPRESION.Tipo = TIPO_ERRONEO ''' Else ''' EXPRESION = MT(Temp) ''' End If ''' '''EXPRESION = FACTOR() ''' End Select ''' '''End Function ''' '''' analizador de expresiones '''Public Function AnalizaExpresion(ByVal sExpr As String) As String ''' Dim Res As Valor ''' ''' L_Cad = sExpr ''' Prebuscar ' inicia el análisis léxico ''' Res = EXPRESION ''' ''' If Res.Tipo = TIPO_ERRONEO Then ''' AnalizaExpresion = Chr(0) ''' Else ''' AnalizaExpresion = Res.Con ''' End If ''' '''End Function ' analiza una expresión y devuelve el resultado ' devuelve Chr(0) si hay errores en la expresión ' CUIDADO: no se tiene en cuenta el orden de precedencia 'lógico' de operadores ' además en las expresiones lógicas compuestas se deben usar paréntesis para que ' se evalúen correctamente (ej.: (a>5) & (b<>10)) Public Function AnalizaExpresion(ByVal sExpr As String) As String Dim bAcumuladorCadena As Boolean, bResultadoCadena As Boolean, _ bEsProcedimiento As Boolean Dim i As Long, j As Long, k As Long Dim iErr As Integer, iVarObj As Integer Dim c As String, sElem As String, sResultado As String, sAcumulador As String, _ sOper As String, sSubExpr As String, sResSubExpr As String On Error GoTo Error_Analiza sExpr = Trim(sExpr) bAcumuladorCadena = False sAcumulador = "" bResultadoCadena = False sResultado = "" sOper = "" i = 1 Do While i <= Len(sExpr) c = Mid(sExpr, i, 1) ' si encontramos un paréntesis separamos la subexpresión y la analizamos If c = PARENTESIS1 Then sResSubExpr = Chr(0) ' en 'sResultado' tenemos lo que hay antes del paréntesis ' comprobamos si es una referencia a un objeto iVarObj = EsVarObj(sResultado) If iVarObj <> 0 Then ' separamos los parámetros k = BuscaCierreParentesis(sExpr, i + 1) If k = 0 Then DescError "Falta paréntesis de cierre" AnalizaExpresion = Chr(0) Exit Function End If sSubExpr = Mid(sExpr, i + 1, k - i - 1) sResSubExpr = ValorVarObj(sResultado & PARENTESIS1 & sSubExpr & PARENTESIS2, iVarObj) If sResSubExpr = Chr(0) Then DescError "Error al ejecutar método de objeto: " & UCase(sResultado) AnalizaExpresion = Chr(0) Exit Function End If Else ' probamos si es un comando del sistema On Error Resume Next ' cogemos los parámetros k = BuscaCierreParentesis(sExpr, i + 1) If k = 0 Then sSubExpr = "" Else sSubExpr = Mid(sExpr, i, k - i + 1) End If sResSubExpr = CallByName(cmd, "VS_" & sResultado, VbMethod, sResultado & sSubExpr) ' guardamos el código de error (0 si era un comando válido) iErr = Err.Number On Error GoTo Error_Analiza ' si era un comando del sistema If iErr = 0 Then If sResSubExpr = Chr(0) Then AnalizaExpresion = Chr(0) Exit Function End If Else ' comprobamos si es el nombre de un procedimiento en cuyo caso le llamamos ' con los parámetros dentro del paréntesis bEsProcedimiento = False For j = 0 To UBound(Procedimientos) If Procedimientos(j).Nombre = UCase(sResultado) Then bEsProcedimiento = True Exit For End If Next If bEsProcedimiento Then ' separamos los parámetros k = BuscaCierreParentesis(sExpr, i + 1) If k = 0 Then DescError "Falta paréntesis de cierre" AnalizaExpresion = Chr(0) Exit Function End If sSubExpr = Mid(sExpr, i + 1, k - i - 1) sResSubExpr = EjecutaProc(sResultado, sSubExpr) If sResSubExpr = Chr(0) Then DescError "Error al ejecutar " & UCase(sResultado) AnalizaExpresion = Chr(0) Exit Function End If End If End If End If ' si pudo ejecutar un comando del sistema o un procedimiento If sResSubExpr <> Chr(0) Then ' si el valor devuelto por el procedimiento no es numérico lo formateamos ' como si fuese una cadena If TipoOperando(sResSubExpr) <> OP_NUMERICO Then sResSubExpr = COMILLAS & sResSubExpr & COMILLAS End If ' sustituimos la llamada al procedimiento por el valor devuelto ' y nos situamos al inicio i = i - Len(sResultado) If i < 1 Then i = 1 End If sExpr = Sustituye(sExpr, i, k - i + 1, sResSubExpr) ' retrocedemos una posición para analizar a partir de la sustitución i = i - 1 sResultado = "" bResultadoCadena = False Else ' si hemos encontrado el paréntesis de apertura al final de la expresión ' devuelve error If i = Len(sExpr) Then DescError "Falta paréntesis de cierre" AnalizaExpresion = Chr(0) Exit Function End If ' buscamos cierre de paréntesis y si no lo encontramos devolvemos error j = BuscaCierreParentesis(sExpr, i + 1) If j = 0 Then DescError "Falta paréntesis de cierre" AnalizaExpresion = Chr(0) Exit Function Else sSubExpr = Mid(sExpr, i + 1, j - i - 1) ' nos llamamos recursivamente para analizar la subexpresión... sResSubExpr = AnalizaExpresion(sSubExpr) ' ...y sustituimos la subexpresión por el resultado (si no hubo error) If sResSubExpr = Chr(0) Then DescError "Error en la expresión: " & sSubExpr AnalizaExpresion = Chr(0) Exit Function End If sExpr = Sustituye(sExpr, i, j - i + 1, sResSubExpr) ' retrocedemos una posición para analizar a partir de la sustitución i = i - 1 End If End If ElseIf c = CORCHETE1 Then j = BuscaCierreCorchete(sExpr, i + 1) If j = 0 Then DescError "Falta corchete de cierre" AnalizaExpresion = Chr(0) Exit Function End If sSubExpr = Mid(sExpr, i + 1, j - i - 1) ' analizamos la expresión entre corchetes sResSubExpr = AnalizaExpresion(sSubExpr) If sResSubExpr = Chr(0) Then DescError "Error en la expresión: " & sSubExpr AnalizaExpresion = Chr(0) Exit Function End If ' sustituimos en el resultado la expresión por su valor (el valor lo ponemos ' entre comillas ya que, supuestamente, por estar entre corchetes, estamos ' analizando una referencia a un objeto) sResultado = sResultado & c & COMILLAS & sResSubExpr & COMILLAS ' nos posicionamos en el corchete de cierre i = j - 1 ElseIf c = COMILLAS Then ' si encontramos el inicio de una cadena, la separamos i = ExtraeCadena(sExpr, sSubExpr, i + 1) sResultado = sSubExpr bResultadoCadena = True ElseIf InStr(OPERADORES, c) <> 0 Then ' si hay alguna operación pendiente, la hacemos ahora If sOper <> "" Then sAcumulador = CalculaOperacion(sOper, sAcumulador, bAcumuladorCadena, _ sResultado, bResultadoCadena, bAcumuladorCadena) If sAcumulador = Chr(0) Then DescError "Error al realizar operación " & sOper AnalizaExpresion = Chr(0) Exit Function End If Else ' copia lo que llevamos hasta el momento en el acumulador sAcumulador = sResultado bAcumuladorCadena = bResultadoCadena End If ' si encontramos el operador menos unario, metemos -1 en acumulador y ' la operación de multiplicación If c = OPER_MENOS And sAcumulador = "" Then sAcumulador = "-1" sOper = OPER_MULTIPL bAcumuladorCadena = False Else sOper = c ' puede ser un operador compuesto (<=, >=, <>) c = Mid(sExpr, i + 1, 1) If InStr(OPERADORES, c) Then sOper = sOper & c i = i + 1 End If End If sResultado = "" bResultadoCadena = False ' comprobamos si viene el operador de asignación ElseIf Mid(sExpr, i, Len(CMD_ASIGN)) = CMD_ASIGN Then ' posicionamos el puntero detrás del operador de asignación (menos 1 que ' se suma luego) i = i + Len(CMD_ASIGN) - 1 ' el operando de la izquierda no puede ser una cadena If bResultadoCadena Then DescError "El operando de la izquierda de la expresión no debería ser una cadena" AnalizaExpresion = Chr(0) Exit Function End If ' el operando de la izquierda debería ser una variable If TipoOperando(sResultado) = OP_VARIABLE Then ' evaluamos la expresión de la derecha... sSubExpr = Mid(sExpr, i + 1) sResSubExpr = AnalizaExpresion(sSubExpr) If sResSubExpr = Chr(0) Then DescError "Error en la expresión: " & sSubExpr AnalizaExpresion = Chr(0) Exit Function End If ' ...y se la asignamos a la variable If AsignaVariable(sResultado, sResSubExpr) = Chr(0) Then ' si no pudimos asignar, devolvemos error AnalizaExpresion = Chr(0) Exit Function Else ' si hemos asignado correctamente devolvemos TRUE sAcumulador = "" sResultado = "" bAcumuladorCadena = False bResultadoCadena = False sExpr = EXPR_TRUE i = 0 End If Else DescError "El operando de la izquierda debería ser una variable" AnalizaExpresion = Chr(0) Exit Function End If ElseIf InStr(CAR_OPERANDO & SEPAR_PROPIEDAD, UCase(c)) <> 0 Then sResultado = sResultado & c ' ignoramos los espacios ElseIf c <> " " Then AnalizaExpresion = Chr(0) Exit Function End If i = i + 1 Loop ' última operación If sOper <> "" Then sResultado = CalculaOperacion(sOper, sAcumulador, bAcumuladorCadena, _ sResultado, bResultadoCadena, bResultadoCadena) End If If bResultadoCadena Or TipoOperando(sResultado) = OP_NUMERICO Then AnalizaExpresion = sResultado Else AnalizaExpresion = ValorVariable(sResultado) End If Exit Function Error_Analiza: DescError "Error " & CStr(Err.Number) AnalizaExpresion = Chr(0) End Function ' calcula la operación 'sOper' entre los operandos 'sOp1' y 'sOp2' y devuelve el ' resultado, si 'bOp1Cadena' y 'bOp2Cadena' indican si los operandos son cadenas ' de caracteres o valores numéricos ' la función devuelve el carácter Chr(0) si no pudo realizar la operación ' y además devuelve True en la variable 'bResultadoCadena' si el resultado es ' de tipo cadena de caracteres o False si es numérico Private Function CalculaOperacion(ByVal sOper As String, ByVal sOp1 As String, _ ByVal bOp1Cadena As Boolean, ByVal sOp2 As String, ByVal bOp2Cadena As Boolean, _ bResultadoCadena As Boolean) As String Dim iTipo1 As Integer, iTipo2 As Integer iTipo1 = TipoOperando(sOp1) iTipo2 = TipoOperando(sOp2) ' si ninguno de los operadores es una cadena y los dos son desconocidos ' salimos con error If (Not bOp1Cadena And iTipo1 = OP_DESCONOCIDO) Or _ (Not bOp2Cadena And iTipo2 = OP_DESCONOCIDO) Then CalculaOperacion = Chr(0) Exit Function End If ' si alguno de los operandos es una variable, lo sustituye por su valor On Error Resume Next If Not bOp1Cadena And iTipo1 = OP_VARIABLE Then sOp1 = ValorVariable(sOp1) If sOp1 = Chr(0) Then CalculaOperacion = Chr(0) Exit Function Else ' comprobamos el tipo de dato de la variable If TipoOperando(sOp1) <> OP_NUMERICO Then bOp1Cadena = True End If End If End If If Not bOp2Cadena And iTipo2 = OP_VARIABLE Then sOp2 = ValorVariable(sOp2) If sOp2 = Chr(0) Then CalculaOperacion = Chr(0) Exit Function Else ' comprobamos el tipo de dato de la variable If TipoOperando(sOp2) <> OP_NUMERICO Then bOp2Cadena = True End If End If End If Select Case sOper Case OPER_MAS If bOp1Cadena Or bOp2Cadena Then CalculaOperacion = sOp1 & sOp2 Else CalculaOperacion = CStr(CLng(sOp1) + CLng(sOp2)) End If Case OPER_MENOS If bOp1Cadena Or bOp2Cadena Then CalculaOperacion = Chr(0) Else CalculaOperacion = CStr(CLng(sOp1) - CLng(sOp2)) End If Case OPER_MULTIPL If bOp1Cadena Or bOp2Cadena Then CalculaOperacion = Chr(0) Else CalculaOperacion = CStr(CLng(sOp1) * CLng(sOp2)) End If Case OPER_DIV If bOp1Cadena Or bOp2Cadena Then CalculaOperacion = Chr(0) Else CalculaOperacion = CStr(CLng(CLng(sOp1) / CLng(sOp2))) End If Case OPER_IGUAL If bOp1Cadena Or bOp2Cadena Then CalculaOperacion = IIf(sOp1 = sOp2, EXPR_TRUE, EXPR_FALSE) Else CalculaOperacion = IIf(CLng(sOp1) = CLng(sOp2), EXPR_TRUE, EXPR_FALSE) End If Case OPER_MAYOR If bOp1Cadena Or bOp2Cadena Then CalculaOperacion = IIf(sOp1 > sOp2, EXPR_TRUE, EXPR_FALSE) Else CalculaOperacion = IIf(CLng(sOp1) > CLng(sOp2), EXPR_TRUE, EXPR_FALSE) End If Case OPER_MENOR If bOp1Cadena Or bOp2Cadena Then CalculaOperacion = IIf(sOp1 < sOp2, EXPR_TRUE, EXPR_FALSE) Else CalculaOperacion = IIf(CLng(sOp1) < CLng(sOp2), EXPR_TRUE, EXPR_FALSE) End If Case OPER_MAYIGUAL If bOp1Cadena Or bOp2Cadena Then CalculaOperacion = IIf(sOp1 >= sOp2, EXPR_TRUE, EXPR_FALSE) Else CalculaOperacion = IIf(CLng(sOp1) >= CLng(sOp2), EXPR_TRUE, EXPR_FALSE) End If Case OPER_MENIGUAL If bOp1Cadena Or bOp2Cadena Then CalculaOperacion = IIf(sOp1 <= sOp2, EXPR_TRUE, EXPR_FALSE) Else CalculaOperacion = IIf(CLng(sOp1) <= CLng(sOp2), EXPR_TRUE, EXPR_FALSE) End If Case OPER_DISTINTO If bOp1Cadena Or bOp2Cadena Then CalculaOperacion = IIf(sOp1 <> sOp2, EXPR_TRUE, EXPR_FALSE) Else CalculaOperacion = IIf(CLng(sOp1) <> CLng(sOp2), EXPR_TRUE, EXPR_FALSE) End If Case OPER_AND CalculaOperacion = IIf((sOp1 = EXPR_TRUE) And (sOp2 = EXPR_TRUE), EXPR_TRUE, EXPR_FALSE) Case OPER_OR CalculaOperacion = IIf((sOp1 = EXPR_TRUE) Or (sOp2 = EXPR_TRUE), EXPR_TRUE, EXPR_FALSE) Case Else CalculaOperacion = Chr(0) End Select ' tipo de datos del resultado de la operación bResultadoCadena = bOp1Cadena Or bOp2Cadena End Function ' sustituye en la cadena 's1', los 'lLong' caracteres empezando en 'lInicio' por ' la cadena 's2' Private Function Sustituye(ByVal s1 As String, ByVal lInicio As Long, _ ByVal lLong As Long, ByVal s2 As String) As String On Error Resume Next Sustituye = Left(s1, lInicio - 1) & s2 & Mid(s1, lInicio + lLong) If Err.Number <> 0 Then Sustituye = s1 End If End Function ' busca el paréntesis de cierre dentro de 'sExpr', comenzando desde 'lInicio' ' devuelve 0 si no lo encuentra Private Function BuscaCierreParentesis(ByVal sExpr As String, lInicio As Long) As Long Dim i As Long Dim bComillas As Boolean, bEscape As Boolean Dim iNivel As Integer Dim c As String iNivel = 0 bComillas = False bEscape = False For i = lInicio To Len(sExpr) c = Mid(sExpr, i, 1) If c = ESCAPE And bComillas Then ' tenemos cuidado ya que el carácter ' de escape puede ir seguido de otro carácter ' de escape bEscape = Not bEscape ElseIf c = COMILLAS Then If Not bEscape Then bComillas = Not bComillas End If bEscape = False ElseIf c = PARENTESIS2 And Not bComillas Then If iNivel = 0 Then BuscaCierreParentesis = i Exit Function Else iNivel = iNivel - 1 End If bEscape = False ElseIf c = PARENTESIS1 And Not bComillas Then iNivel = iNivel + 1 bEscape = False Else bEscape = False End If Next BuscaCierreParentesis = 0 End Function ' busca el corchete de cierre dentro de 'sExpr', comenzando desde 'lInicio' ' devuelve 0 si no lo encuentra Private Function BuscaCierreCorchete(ByVal sExpr As String, lInicio As Long) As Long Dim i As Long Dim iNivel As Integer Dim c As String iNivel = 0 For i = lInicio To Len(sExpr) c = Mid(sExpr, i, 1) If c = CORCHETE2 Then If iNivel = 0 Then BuscaCierreCorchete = i Exit Function Else iNivel = iNivel - 1 End If ElseIf c = CORCHETE1 Then iNivel = iNivel + 1 End If Next BuscaCierreCorchete = 0 End Function ' extraemos una cadena de caracteres delimitada entre comillas, comenzando en 'lInicio' ' que será el carácter detrás de las primeras comillas que no formen parte de una ' secuencia de escape (\") ' deja en 'sCad' la cadena y devuelve la posición dónde están las comillas de cierre Private Function ExtraeCadena(ByVal sExpr As String, sCad As String, ByVal lInicio As Long) As Long Dim bEscape As Boolean Dim i As Long Dim c As String sCad = "" bEscape = False For i = lInicio To Len(sExpr) c = Mid(sExpr, i, 1) If bEscape Then ' si las comillas forman parte de una secuencia de escape ' sólo deja las comillas If c = COMILLAS Then If Len(sCad) > 1 Then sCad = Left(sCad, Len(sCad) - 1) & c Else sCad = c End If Else If c <> ESCAPE Then sCad = sCad & c End If End If bEscape = False Else If c = ESCAPE Then bEscape = True sCad = sCad & c ElseIf c = COMILLAS Then ' termina si encuentra unas comillas solas Exit For Else sCad = sCad & c End If End If Next ExtraeCadena = i End Function ' comprueba el tipo de un operando (numérico, variable o desconocido) Private Function TipoOperando(ByVal sOp As String) As Integer Dim i As Integer Dim c As String ' comprobamos si es una referencia a un objeto If EsVarObj(sOp) Then TipoOperando = OP_VARIABLE Exit Function End If ' si empieza por una letra y todos los caracteres son válidos es que es una variable ' si no es desconocido c = UCase(Left(sOp, 1)) If InStr(CAR_ALFA, c) <> 0 Then For i = 2 To Len(sOp) c = UCase(Mid(sOp, i, 1)) If InStr(CAR_ALFA & CAR_NUMEROS & SEPAR_PROPIEDAD, c) = 0 Then TipoOperando = OP_DESCONOCIDO Exit Function End If Next TipoOperando = OP_VARIABLE Exit Function End If ' si tiene todos números (el primer carácter puede ser un OPER_MENOS) es numérico ' y si no es desconocido For i = 1 To Len(sOp) c = Mid(sOp, i, 1) If (i = 1 And c <> OPER_MENOS And InStr(CAR_NUMEROS, c) = 0) Or _ (i > 1 And InStr(CAR_NUMEROS, c) = 0) Then TipoOperando = OP_DESCONOCIDO Exit Function End If Next TipoOperando = OP_NUMERICO End Function ' añade una variable a la tabla de variables o modifica el valor de una existente ' devuelve Chr(0) si error Public Function CreaVariable(ByVal sVar As String, ByVal sValor As String, _ ByVal lProc As Long, ByVal lNumSerie As Long) As String Dim i As Long sVar = UCase(sVar) ' comprobamos que el nombre de la variable sea correcto If Not CompruebaNombreProcVar(sVar) Then DescError "No es un nombre válido de variable: " & sVar CreaVariable = Chr(0) Exit Function End If ' variables global If lProc = VAR_GLOBAL Then If Not bHayGlobales Then ReDim VarGlobales(0) i = 0 bHayGlobales = True Else ' busca la variable entre las globales For i = 0 To UBound(VarGlobales) If VarGlobales(i).Nombre = sVar Then VarGlobales(i).Valor = sValor CreaVariable = sValor Exit Function End If Next i = UBound(VarGlobales) + 1 ReDim Preserve VarGlobales(i) End If VarGlobales(i).Nombre = sVar VarGlobales(i).Valor = sValor VarGlobales(i).Proc = VAR_GLOBAL Else If Not bHayLocales Then ReDim VarLocales(0) i = 0 bHayLocales = True Else ' busca la variable entre las locales al procedimiento For i = 0 To UBound(VarLocales) If VarLocales(i).Nombre = sVar And VarLocales(i).Proc = lProc _ And VarLocales(i).NumSerie = lNumSerie Then VarLocales(i).Valor = sValor CreaVariable = sValor Exit Function End If Next i = UBound(VarLocales) + 1 ReDim Preserve VarLocales(i) End If VarLocales(i).Nombre = sVar VarLocales(i).Valor = sValor VarLocales(i).Proc = lProc VarLocales(i).NumSerie = lNumSerie End If CreaVariable = sValor End Function ' asigna un valor a una variable y devuelve Chr(0) si no pudo (la variable no existe) Public Function AsignaVariable(ByVal sVariable As String, ByVal sValor As String) As String Dim i As Long Dim iVarObj As Integer iVarObj = EsVarObj(sVariable) If iVarObj <> 0 Then AsignaVariable = AsignaVarObj(sVariable, iVarObj, sValor) If AsignaVariable = Chr(0) Then DescError "Objeto (o propiedad) no definido: " & sVariable End If Exit Function End If On Error GoTo Error_Asigna sVariable = UCase(sVariable) If Not bHayLocales And Not bHayGlobales Then DescError "Variable no definida " & UCase(sVariable) AsignaVariable = Chr(0) Exit Function End If ' busca la variable entre las locales al procedimiento actual If bHayLocales Then For i = 0 To UBound(VarLocales) If VarLocales(i).Nombre = sVariable And VarLocales(i).Proc = lProcActual _ And VarLocales(i).NumSerie = Procedimientos(lProcActual).NumSerie Then VarLocales(i).Valor = sValor AsignaVariable = sValor Exit Function End If Next End If ' busca la variable entre las globales If bHayGlobales Then For i = 0 To UBound(VarGlobales) If VarGlobales(i).Nombre = sVariable Then VarGlobales(i).Valor = sValor AsignaVariable = sValor Exit Function End If Next End If ' si no la encontró, error DescError "Variable no definida " & UCase(sVariable) AsignaVariable = Chr(0) Exit Function Error_Asigna: DescError "Error al asignar la variable " & UCase(sVariable) AsignaVariable = Chr(0) End Function ' comprueba si la variable hace referencia a un objeto (OBJ[expr].Propiedad) ' y devuelve su tipo (0 si no es objeto) Private Function EsVarObj(ByVal sVar As String) As Integer Dim s As String s = UCase(Left(sVar, 3)) If (s = PREFOBJ_LOC Or s = PREFOBJ_OBJ Or s = PREFOBJ_PSI) _ And Mid(sVar, 4, 1) = CORCHETE1 And InStr(sVar, CORCHETE2 & SEPAR_PROPIEDAD) <> 0 Then Select Case s Case PREFOBJ_LOC EsVarObj = TIPOBJ_LOC Case PREFOBJ_OBJ EsVarObj = TIPOBJ_OBJ Case PREFOBJ_PSI EsVarObj = TIPOBJ_PSI End Select Exit Function End If EsVarObj = 0 End Function ' devuelve el valor de una variable, devuelve Chr(0) si variable no encontrada Public Function ValorVariable(ByVal sVariable As String) As String Dim i As Long Dim iVarObj As Integer iVarObj = EsVarObj(sVariable) If iVarObj <> 0 Then ValorVariable = ValorVarObj(sVariable, iVarObj) Exit Function End If If Not bHayGlobales And Not bHayLocales Then DescError "No hay variables definidas" ValorVariable = Chr(0) Exit Function End If sVariable = UCase(sVariable) ' busca la variable entre las locales al procedimiento actual If bHayLocales Then For i = 0 To UBound(VarLocales) If VarLocales(i).Nombre = sVariable And VarLocales(i).Proc = lProcActual _ And VarLocales(i).NumSerie = Procedimientos(lProcActual).NumSerie Then ValorVariable = VarLocales(i).Valor Exit Function End If Next End If ' busca la variable entre las globales If bHayGlobales Then For i = 0 To UBound(VarGlobales) If VarGlobales(i).Nombre = sVariable Then ValorVariable = VarGlobales(i).Valor Exit Function End If Next End If DescError "No se ha encontrado la variable " & UCase(sVariable) ValorVariable = Chr(0) End Function ' elimina las variables locales correspondientes a un procedimiento Private Sub EliminaVariablesLocales(ByVal lProc As Long) Dim i As Long, j As Long, lUlt As Long ' salimos si no hay variables definidas If Not bHayLocales Then Exit Sub End If i = 0 lUlt = UBound(VarLocales) Do While i < lUlt If VarLocales(i).Proc = lProc And VarLocales(i).NumSerie = Procedimientos(lProc).NumSerie Then For j = i To lUlt - 1 VarLocales(j) = VarLocales(j + 1) Next i = i - 1 lUlt = lUlt - 1 ReDim Preserve VarLocales(lUlt) End If i = i + 1 Loop ' último elemento If VarLocales(lUlt).Proc = lProc And VarLocales(i).NumSerie = Procedimientos(lProc).NumSerie Then If lUlt > 0 Then ReDim Preserve VarLocales(lUlt - 1) Else bHayLocales = False VarLocales(0).Nombre = "" VarLocales(0).Valor = "" VarLocales(0).Proc = 0 End If End If End Sub ' separa el nombre del objeto, devuelve Chr(0) si error Private Function NombreObjeto(ByVal sVar As String) As String Dim i As Integer, j As Integer, iLng As Integer Dim sExpr As String i = InStr(sVar, CORCHETE1) If i <> 0 Then j = InStr(i + 1, sVar, CORCHETE2) If j = 0 Then NombreObjeto = Chr(0) Exit Function Else iLng = j - i - 1 If iLng < 1 Then NombreObjeto = Chr(0) Else ' analizamos la expresión entre los corchetes y devolvemos el resultado ' excepto si hubo error en la expresión que la devolvemos tal cual sExpr = Mid(sVar, i + 1, iLng) NombreObjeto = AnalizaExpresion(sExpr) End If Exit Function End If End If NombreObjeto = Chr(0) End Function ' separa la propiedad del objeto, devuelve Chr(0) si error Private Function PropiedadObjeto(ByVal sVar As String) As String Dim i As Long, j As Long i = InStr(sVar, SEPAR_PROPIEDAD) If i <> 0 Then ' comprobamos si es un método j = InStr(sVar, PARENTESIS1) If j = 0 Then PropiedadObjeto = Right(sVar, Len(sVar) - i) Else PropiedadObjeto = Mid(sVar, i + 1, j - i - 1) End If Exit Function End If PropiedadObjeto = Chr(0) End Function ' devuelve el valor de una propiedad de un objeto, devuelve Chr(0) si error Private Function ValorVarObj(ByVal sVar As String, ByVal iTipo As Integer) As String Dim sObjeto As String, sPropiedad As String, sValor As String, sParam As String sObjeto = NombreObjeto(sVar) If sObjeto = Chr(0) Then DescError "No se encuentra objeto " & UCase(sVar) ValorVarObj = Chr(0) Exit Function End If sPropiedad = PropiedadObjeto(sVar) If sPropiedad = Chr(0) Then DescError "No se encuentra propiedad " & UCase(sPropiedad) ValorVarObj = Chr(0) Exit Function End If ' parámetros que puede haber si estamos invocando un método del objeto sParam = SeparaParametros(sVar) If sParam = Chr(0) Then sParam = "" sDescError = "" End If Select Case iTipo Case TIPOBJ_LOC sValor = PropiedadLoc(sObjeto, sPropiedad, sParam) Case TIPOBJ_OBJ sValor = PropiedadObj(sObjeto, sPropiedad, sParam) Case TIPOBJ_PSI sValor = PropiedadPSI(sObjeto, sPropiedad, sParam) End Select If sValor = Chr(0) Then DescError "El objeto o la propiedad no son válidos: " & sVar End If ValorVarObj = sValor End Function ' asigna un valor a una propiedad de un objeto, devuelve Chr(0) si error Private Function AsignaVarObj(ByVal sVar As String, ByVal iTipo As Integer, _ ByVal sValor As String) As String Dim s As String, sObjeto As String, sPropiedad As String sObjeto = NombreObjeto(sVar) If sObjeto = Chr(0) Then DescError "No se encuentra objeto " & UCase(sVar) AsignaVarObj = Chr(0) Exit Function End If sPropiedad = PropiedadObjeto(sVar) If sPropiedad = Chr(0) Then DescError "No se encuentra propiedad " & UCase(sPropiedad) AsignaVarObj = Chr(0) Exit Function End If Select Case iTipo Case TIPOBJ_LOC s = AsignaPropiedadLoc(sObjeto, sPropiedad, sValor) Case TIPOBJ_OBJ s = AsignaPropiedadObj(sObjeto, sPropiedad, sValor) Case TIPOBJ_PSI s = AsignaPropiedadPSI(sObjeto, sPropiedad, sValor) End Select AsignaVarObj = s End Function ' comprueba la síntaxis del FOR Private Function CompruebaFor(ByVal sLin As String) As Boolean Dim i As Long Dim sTo As String On Error GoTo Error_Comprueba sLin = UCase(sLin) ' la síntaxis esperada es: FOR := TO ' buscamos la asignacion i = InStr(sLin, CMD_ASIGN) If i = 0 Then CompruebaFor = False Exit Function End If ' buscamos el TO sTo = " " & CMD_TO & " " i = InStr(sLin, sTo) If i = 0 Then CompruebaFor = False Exit Function End If ' no puede haber más de un TO If InStr(i + Len(sTo), sLin, sTo) <> 0 Then CompruebaFor = False Exit Function End If CompruebaFor = True Exit Function Error_Comprueba: CompruebaFor = False End Function ' separa la 1ª expresión de un FOR Private Function SeparaExpr1For(ByVal sLin As String) As String Dim i As Long Dim sTo As String, sExpr As String sExpr = "" ' quitamos el FOR inicial sLin = Trim(Right(sLin, Len(sLin) - Len(CMD_FOR))) ' buscamos el TO y separamos hasta ahí sTo = " " & CMD_TO & " " i = InStr(UCase(sLin), sTo) If i > 0 Then sExpr = Left(sLin, i - 1) End If SeparaExpr1For = sExpr End Function ' separa la 2ª expresión de un FOR Private Function SeparaExpr2For(ByVal sLin As String) As String Dim i As Long Dim sTo As String, sExpr As String sExpr = "" ' quitamos el FOR inicial sLin = Trim(Right(sLin, Len(sLin) - Len(CMD_FOR))) ' buscamos el TO y separamos desde ahí hasta el final sTo = " " & CMD_TO & " " i = InStr(UCase(sLin), sTo) If i > 0 Then sExpr = Mid(sLin, i + Len(sTo)) End If SeparaExpr2For = sExpr End Function ' separa la expresión del WHILE Private Function SeparaExprWhile(ByVal sLin As String) As String SeparaExprWhile = Trim(Right(sLin, Len(sLin) - Len(CMD_WHILE))) End Function ' busca una sentencia LOOP, en el mismo nivel que el WHILE, empezando en la línea actual ' devuelve el número de línea si la encuentra o PUNTERO_SALIR si no Private Function BuscarLoop() As Long Dim i As Long, lNivel As Long lNivel = 0 For i = lPunteroLinea + 1 To UBound(Lineas) If Lineas(i).Tipo = LIN_LOOP Then If lNivel = 0 Then BuscarLoop = i Exit Function Else lNivel = lNivel - 1 End If ElseIf Lineas(i).Tipo = LIN_WHILE Then lNivel = lNivel + 1 End If Next BuscarLoop = PUNTERO_SALIR End Function ' comprueba la sintaxis del IF Private Function CompruebaIf(ByVal sLin As String) As Boolean Dim sThen As String Dim i As Long On Error GoTo Error_Comprueba sLin = UCase(sLin) ' la síntaxis esperada es: IF THEN ' ' ELSE ' ' END ' la claúsula ELSE es opcional ' buscamos el THEN sThen = " " & CMD_THEN i = InStr(sLin, sThen) If i = 0 Then CompruebaIf = False Exit Function End If ' no puede haber más de un THEN If InStr(i + Len(sThen), sLin, sThen) <> 0 Then CompruebaIf = False Exit Function End If CompruebaIf = True Exit Function Error_Comprueba: CompruebaIf = False End Function ' separa la expresión de un IF Private Function SeparaExprIf(ByVal sLin As String) As String Dim i As Long Dim sThen As String, sExpr As String sExpr = "" ' quitamos el IF inicial sLin = Trim(Right(sLin, Len(sLin) - Len(CMD_IF))) ' buscamos el THEN y separamos hasta ahí sThen = " " & CMD_THEN i = InStr(UCase(sLin), sThen) If i > 0 Then sExpr = Left(sLin, i - 1) End If SeparaExprIf = sExpr End Function ' separa la expresión de un comando (CMD expr) Private Function SeparaExprCmd(ByVal sLin As String, ByVal sCmd As String) As String Dim sExpr As String ' quitamos el CMD inicial sExpr = Trim(Right(sLin, Len(sLin) - Len(sCmd))) SeparaExprCmd = sExpr End Function ' busca una sentencia ELSE, en el mismo nivel que el IF, empezando en la línea actual ' devuelve el número de línea si la encuentra o PUNTERO_SALIR si no Private Function BuscarElse() As Long Dim i As Long, lNivel As Long lNivel = 0 For i = lPunteroLinea + 1 To UBound(Lineas) If Lineas(i).Tipo = LIN_ELSE And lNivel = 0 Then BuscarElse = i Exit Function ElseIf Lineas(i).Tipo = LIN_IF Then lNivel = lNivel + 1 ElseIf Lineas(i).Tipo = LIN_ENDIF Then ' si encontramos el ENDIF correspondiente salimos If lNivel = 0 Then BuscarElse = PUNTERO_SALIR Exit Function Else lNivel = lNivel - 1 End If End If Next BuscarElse = PUNTERO_SALIR End Function ' busca una sentencia ENDIF, en el mismo nivel que el IF, empezando en la línea actual ' devuelve el número de línea si la encuentra o PUNTERO_SALIR si no Private Function BuscarEndIf() As Long Dim i As Long, lNivel As Long lNivel = 0 For i = lPunteroLinea + 1 To UBound(Lineas) If Lineas(i).Tipo = LIN_ENDIF Then If lNivel = 0 Then BuscarEndIf = i Exit Function Else lNivel = lNivel - 1 End If ElseIf Lineas(i).Tipo = LIN_IF Then lNivel = lNivel + 1 End If Next BuscarEndIf = PUNTERO_SALIR End Function ' busca la siguiente sentencia CASE, empezando en la línea actual y que esté ' en el mismo nivel ' devuelve el número de línea si la encuentra o PUNTERO_SALIR si no Private Function BuscarCase() As Long Dim i As Long, lNivel As Long lNivel = 0 For i = lPunteroLinea + 1 To UBound(Lineas) If Lineas(i).Tipo = LIN_SELECT Then lNivel = lNivel + 1 ElseIf Lineas(i).Tipo = LIN_ENDSELECT Then lNivel = lNivel - 1 ElseIf Lineas(i).Tipo = LIN_CASE And lNivel = 0 Then BuscarCase = i Exit Function End If Next BuscarCase = PUNTERO_SALIR End Function ' busca la siguiente sentencia ENDSELECT, empezando en la línea actual y que esté ' en el mismo nivel ' devuelve el número de línea si la encuentra o PUNTERO_SALIR si no Private Function BuscarEndSelect() As Long Dim i As Long, lNivel As Long lNivel = 0 For i = lPunteroLinea + 1 To UBound(Lineas) If Lineas(i).Tipo = LIN_SELECT Then lNivel = lNivel + 1 ElseIf Lineas(i).Tipo = LIN_ENDSELECT Then If lNivel = 0 Then BuscarEndSelect = i Exit Function Else lNivel = lNivel - 1 End If End If Next BuscarEndSelect = PUNTERO_SALIR End Function ' separa un bloque de código entre dos líneas y lo almacena en 'Lineas' ' CUIDADO: el contenido de 'Lineas' se destruye ' devuelve True si lo pudo separar o False si error Private Function SeparaBloque(ByVal lLin1 As Long, ByVal lLin2 As Long) As Boolean Dim LineasAux() As Linea Dim i As Long, lLin As Long ' comprueba la validez del bloque a separar If lLin1 > lLin2 Then SeparaBloque = False Exit Function End If ReDim LineasAux(0) lLin = 0 For i = lLin1 To lLin2 ReDim Preserve LineasAux(lLin) LineasAux(lLin) = Lineas(i) lLin = lLin + 1 Next ReDim Lineas(UBound(LineasAux)) For i = 0 To UBound(LineasAux) Lineas(i) = LineasAux(i) Next SeparaBloque = True End Function ' ejecuta un procedimiento 'sProc' con los parámetros contenidos en 'sParam' (de la ' forma: param1,param2,...), devuelve el valor de retorno si lo pudo ejecutar ' o Chr(0) si error Public Function EjecutaProc(ByVal sProc As String, ByVal sParam As String) As String Dim PilaLineas() As Linea Dim i As Long, lProc As Long, lPunteroGuardado As Long, lProcAnt As Long Dim sExpr As String, sVal As String If Not bHayProc Then DescError "No se encuentra ningún procedimiento" EjecutaProc = Chr(0) Exit Function End If ' buscamos el procedimiento en la lista de procedimientos sProc = UCase(sProc) For lProc = 0 To UBound(Procedimientos) If sProc = Procedimientos(lProc).Nombre Then Exit For End If Next If lProc > UBound(Procedimientos) Then DescError "No se encuentra el procedimiento " & UCase(sProc) EjecutaProc = Chr(0) Exit Function End If ' incrementamos nº de serie (nº de llamada) Procedimientos(lProc).NumSerie = Procedimientos(lProc).NumSerie + 1 ' creamos los parámetros (variables locales) If Procedimientos(lProc).HayParam Then For i = 0 To UBound(Procedimientos(lProc).Param) sExpr = CogeParametro(sParam, i + 1) If sExpr = Chr(0) Then DescError "Faltan parámetros en la llamada a " & UCase(sProc) EjecutaProc = Chr(0) Exit Function End If sVal = AnalizaExpresion(sExpr) If sVal = Chr(0) Then EjecutaProc = Chr(0) Exit Function End If ' creamos la variable local If CreaVariable(Procedimientos(lProc).Param(i), sVal, lProc, Procedimientos(lProc).NumSerie) = Chr(0) Then EjecutaProc = Chr(0) Exit Function End If Next Else ' si no tiene parámetros, comprobamos que no le pasamos nada If CogeParametro(sParam, 2) <> Chr(0) Then EjecutaProc = Chr(0) Exit Function End If End If ' guardamos el índice del procedimiento actual y ponemos como procedimento actual ' el que estamos ejecutando lProcAnt = lProcActual lProcActual = lProc ' ejecutamos el procedimiento ' guardamos las líneas de código actual lPunteroGuardado = lPunteroLinea ReDim PilaLineas(UBound(Lineas)) For i = 0 To UBound(Lineas) PilaLineas(i) = Lineas(i) Next If Procedimientos(lProc).HayLineas Then ReDim Lineas(UBound(Procedimientos(lProc).Lineas)) For i = 0 To UBound(Procedimientos(lProc).Lineas) Lineas(i) = Procedimientos(lProc).Lineas(i) Next sVal = EjecutaBloque End If ' recuperamos las líneas guardadas ReDim Lineas(UBound(PilaLineas)) For i = 0 To UBound(PilaLineas) Lineas(i) = PilaLineas(i) Next lPunteroLinea = lPunteroGuardado ' desactivamos el indicador de salida de procedimiento bReturn = False ' eliminamos las variables locales del procedimiento EliminaVariablesLocales lProcActual ' decrementamos nº de serie (nº de llamada) Procedimientos(lProc).NumSerie = Procedimientos(lProc).NumSerie - 1 ' recuperamos el índice del procedimiento desde el que llamamos a este lProcActual = lProcAnt If sVal = Chr(0) Then EjecutaProc = Chr(0) Else EjecutaProc = sVal End If End Function ' NEXT Private Function Ejecuta_NEXT(ByVal sLin As String) As Boolean Dim sExpr As String, sVar As String, sValor As String, sResultado As String Dim i As Long, j As Long, lNivel As Long ' si estamos saliendo del procedimiento actual, rompemos el bucle If bReturn Then lPunteroLinea = lPunteroLinea + 1 Ejecuta_NEXT = True Exit Function End If ' buscamos el inicio del bucle FOR correspondiente a este NEXT lNivel = 0 For i = lPunteroLinea - 1 To 0 Step -1 If Lineas(i).Tipo = LIN_NEXT Then lNivel = lNivel + 1 ElseIf Lineas(i).Tipo = LIN_FOR Then If lNivel = 0 Then ' cogemos la variable del bucle sExpr = SeparaExpr1For(Lineas(i).Lin) j = InStr(sExpr, CMD_ASIGN) If j > 0 Then sVar = Left(sExpr, j - 1) Else Ejecuta_NEXT = False Exit Function End If ' incrementamos la variable sValor = ValorVariable(sVar) If sValor = Chr(0) Then Ejecuta_NEXT = False Exit Function End If sValor = CStr(CLng(sValor) + 1) If AsignaVariable(sVar, sValor) = Chr(0) Then Ejecuta_NEXT = False Exit Function End If ' cogemos y evaluamos la expresión detrás del TO sExpr = SeparaExpr2For(Lineas(i).Lin) sResultado = AnalizaExpresion(sExpr) If sResultado = Chr(0) Then Ejecuta_NEXT = False Exit Function End If If CLng(sValor) > CLng(sResultado) Then ' sale del bucle si el valor de la variable alcanzó en límite lPunteroLinea = lPunteroLinea + 1 Else ' sitúa el puntero en la línea siguiente del FOR lPunteroLinea = i + 1 End If Ejecuta_NEXT = True Exit Function Else lNivel = lNivel - 1 End If End If Next ' si no ha encontrado el inicio del bucle, sale con error Ejecuta_NEXT = False End Function ' LOOP Private Function Ejecuta_LOOP(ByVal sLin As String) As Boolean Dim sExpr As String, sResultado As String Dim i As Long, j As Long, lNivel As Long ' si estamos saliendo del procedimiento actual, rompemos el bucle If bReturn Then lPunteroLinea = lPunteroLinea + 1 Ejecuta_LOOP = True Exit Function End If ' buscamos el inicio del bucle WHILE correspondiente a este LOOP lNivel = 0 For i = lPunteroLinea - 1 To 0 Step -1 If Lineas(i).Tipo = LIN_LOOP Then lNivel = lNivel + 1 ElseIf Lineas(i).Tipo = LIN_WHILE Then If lNivel = 0 Then ' cogemos y evaluamos la expresión detrás del WHILE sExpr = SeparaExprWhile(Lineas(i).Lin) sResultado = AnalizaExpresion(sExpr) If sResultado = Chr(0) Then Ejecuta_LOOP = False Exit Function End If ' sale del bucle si la expresión no es verdadera If sResultado = EXPR_TRUE Then ' sitúa el puntero en la línea siguiente del WHILE lPunteroLinea = i + 1 Else ' sale del bucle si el valor de la variable alcanzó en límite lPunteroLinea = lPunteroLinea + 1 End If Ejecuta_LOOP = True Exit Function Else lNivel = lNivel - 1 End If End If Next ' si no ha encontrado el inicio del bucle, sale con error Ejecuta_LOOP = False End Function #If Not EsInterprete Then ' muestra/oculta la ventana de depuración, en función de la variable 'bDepurar' Public Sub VentanaDepuracion() If bDepurar Then frmDebug.Show frmVis.ZOrder 0 frmDebug.Depurar Else frmDebug.bPausa = False frmDebug.Hide End If frmVis.ZOrder 0 End Sub #End If ' separa los parámetros de un procedimiento de la forma: PROCEDIMIENTO(par1,par2,...) ' devuelve Chr(0) si error Public Function SeparaParametros(ByVal sLin As String) As String Dim i As Long, j As Long i = InStr(sLin, PARENTESIS1) If i = 0 Then DescError "Falta paréntesis de apertura" SeparaParametros = Chr(0) Exit Function End If j = BuscaCierreParentesis(sLin, i + 1) If j = 0 Then DescError "Falta paréntesis de cierre" SeparaParametros = Chr(0) Exit Function End If If j - i > 1 Then SeparaParametros = Trim(Mid(sLin, i + 1, j - i - 1)) Else SeparaParametros = "" End If End Function ' comprueba que la sintaxis de llamada a un procedimiento sea de la forma: ' PROCEDIMIENTO([param1,param2,...]) ' devuelve True si es correcta, False si no Public Function CompruebaLlamadaProc(ByVal sLin As String) As Boolean Dim i As Long, j As Long i = InStr(sLin, PARENTESIS1) If i <= 1 Then DescError "Error en llamada: " & sLin CompruebaLlamadaProc = False Exit Function End If j = InStr(i + 1, sLin, PARENTESIS2) If j <= 0 Then DescError "Falta paréntesis de cierre: " & sLin CompruebaLlamadaProc = False Exit Function End If CompruebaLlamadaProc = True End Function ' alamacena la descripción detallada del error producido Public Sub DescError(ByVal sErr As String) If sDescError = "" Then sDescError = sErr End If End Sub ' comprueba que el nombre de una variable o procedimiento sea correcto, devuelve True ' si lo es o False si no Public Function CompruebaNombreProcVar(ByVal s As String) As Boolean Dim i As Long Dim c As String If Len(s) < 1 Then CompruebaNombreProcVar = False Exit Function End If ' no debe empezar con un número c = Left(s, 1) If InStr(CAR_NUMEROS, c) <> 0 Then CompruebaNombreProcVar = False Exit Function End If ' debe contener caracteres válidos For i = 1 To Len(s) c = Mid(s, i, 1) If InStr(CAR_PROC & CAR_NUMEROS, c) = 0 Then CompruebaNombreProcVar = False Exit Function End If Next CompruebaNombreProcVar = True End Function ' devuelve el nº de elementos de un array Public Function ArrayLen(ByVal sArray As String) As Long Dim i As Long, lNumElem As Long If sArray = "" Then ArrayLen = 0 Exit Function End If i = 1 Do While True i = InStr(i, sArray, Chr(SEPAR_ARRAY)) If i < 1 Then Exit Do End If lNumElem = lNumElem + 1 i = i + 1 Loop ArrayLen = lNumElem End Function ' devuelve el elemento n-ésimo de un array o Chr(0) si no lo encuentra Public Function ArrayItem(ByVal sArray As String, ByVal n As Long) As String Dim sElem As String Dim i As Long, j As Long On Error Resume Next If n < 1 Then DescError "No se encuentra el elemento " & CStr(n) ArrayItem = Chr(0) Exit Function End If sElem = "" ' nos saltamos los primeros n-1 elementos j = 1 For i = 1 To n - 1 j = InStr(j, sArray, Chr(SEPAR_ARRAY)) + 1 ' si no encontramos más elementos, salimos If j = 1 Then DescError "No se encuentra el elemento " & CStr(n) ArrayItem = Chr(0) Exit Function End If Next i = InStr(j, sArray, Chr(SEPAR_ARRAY)) If i < j Then DescError "No se encuentra el elemento " & CStr(n) ArrayItem = Chr(0) Exit Function End If sElem = Mid(sArray, j, i - j) If Err.Number = 0 Then ArrayItem = sElem Else DescError "No se encuentra el elemento " & CStr(n) ArrayItem = Chr(0) End If End Function ' devuelve la posición de un elemento dentro de un array o 0 si no lo encontró Public Function InArray(ByVal sArray As String, ByVal sElem As String) As Long Dim i As Long For i = 1 To ArrayLen(sArray) If ArrayItem(sArray, i) = sElem Then InArray = i Exit Function End If Next InArray = 0 End Function ' comprueba si un valor es un array Public Function EsArray(ByVal sArray As String) As Boolean If InStr(sArray, Chr(SEPAR_ARRAY)) >= 1 Then EsArray = True Else EsArray = False End If End Function ' inserta un elemento en la posición n-ésima de un array, devuelve el array nuevo Public Function ArrayInsert(ByVal sArray As String, ByVal n As Long, ByVal sElem As String) As String Dim i As Long, j As Long, k As Long Dim s As String ' nos saltamos los primeros n elementos j = 1 For i = 1 To n - 1 j = InStr(j, sArray, Chr(SEPAR_ARRAY)) + 1 ' si no encontramos más elementos, salimos If j = 1 Then k = Len(sArray) Exit For Else ' posición anterior al separador de elementos del array k = j - 1 End If Next ' insertamos el elemento s = Left(sArray, k) & sElem & Chr(SEPAR_ARRAY) & _ IIf(Len(sArray) - k > 0, Right(sArray, Len(sArray) - k), "") ArrayInsert = s End Function ' modifica el elemento en la posición n-ésima de un array, devuelve el array nuevo Public Function ArrayLet(ByVal sArray As String, ByVal n As Long, ByVal sValor As String) As String Dim i As Long, j As Long, k As Long Dim s As String ' nos saltamos los primeros n elementos j = 1 For i = 1 To n - 1 j = InStr(j, sArray, Chr(SEPAR_ARRAY)) + 1 ' si no encontramos más elementos, salimos If j = 1 Then ArrayLet = "" Exit Function Else ' posición anterior al separador de elementos del array k = j - 1 End If Next ' insertamos el elemento s = Left(sArray, k) & sValor & Chr(SEPAR_ARRAY) ' buscamos el elemento n If k > 0 Then j = InStr(k + 1, sArray, Chr(SEPAR_ARRAY)) Else j = InStr(sArray, Chr(SEPAR_ARRAY)) End If If j > k Then s = s & IIf(Len(sArray) - j > 0, Right(sArray, Len(sArray) - j), "") End If ArrayLet = s End Function ' guarda el estado en un fichero, devuelve True si pudo o False si error Public Function GuardaEstado(ByVal sFich As String) As Boolean Dim iFich As Integer, iOpc As Integer Dim i As Long, j As Long, lVar As Long Dim s As String, sDelimCmp As String, sSepCmp As String, sSepReg As String ' delimitador de campo y separadores de campo y registro sDelimCmp = Chr(DELIM_CMP) sSepCmp = Chr(SEP_CMP) sSepReg = Chr(SEP_REG) ' comprobamos la existencia del fichero If ExisteFichero(sFich) Then iOpc = MsgBox("El fichero ya existe. ¿Quieres sobreescribirlo?", vbYesNo + vbQuestion, "Guardar estado aventura") If iOpc <> vbYes Then GuardaEstado = True Exit Function End If End If Screen.MousePointer = vbHourglass On Error GoTo Error_Guarda2 iFich = FreeFile Open sFich For Output As #iFich On Error GoTo Error_Guarda1 Write #iFich, ID_FICHESTADO ' variables globales If bHayGlobales Then ' dejamos el número en blanco, luego se lo añadiremos s = "1000000000" lVar = 0 For i = 0 To UBound(VarGlobales) s = s & sDelimCmp & VarGlobales(i).Nombre & sDelimCmp & sSepCmp & _ sDelimCmp & VarGlobales(i).Valor & sDelimCmp & sSepCmp & _ sDelimCmp & CStr(VarGlobales(i).Proc) & sDelimCmp & sSepCmp & sSepReg lVar = lVar + 1 Next ' ahora ponemos el número de variables que hemos guardado If lVar = 0 Then Mid(s, 1, 1) = "0" Else Mid(s, 2, 9) = Format(lVar, "000000000") End If Else s = "0" End If Codifica s, CODIGO_RES Write #iFich, s ' localidades If bHayLoc Then s = "1" & Format(UBound(Localidades) + 1, "000000000") For i = 0 To UBound(Localidades) If Localidades(i).Conexiones(0).Localidad = "" And Localidades(i).Conexiones(0).Verbo = "" Then j = 0 Else j = UBound(Localidades(i).Conexiones) + 1 End If s = s & sDelimCmp & Localidades(i).Nombre & sDelimCmp & sSepCmp & _ sDelimCmp & Localidades(i).DescCorta & sDelimCmp & sSepCmp & _ sDelimCmp & Localidades(i).DescLarga & sDelimCmp & sSepCmp & _ sDelimCmp & IIf(Localidades(i).Iluminada, "1", "0") & sDelimCmp & sSepCmp & _ sDelimCmp & IIf(Localidades(i).Exterior, "1", "0") & sDelimCmp & sSepCmp & _ sDelimCmp & Localidades(i).Grafico & sDelimCmp & sSepCmp & _ sDelimCmp & Localidades(i).Sonido & sDelimCmp & sSepCmp & _ sDelimCmp & Localidades(i).Usuario & sDelimCmp & sSepCmp & _ sDelimCmp & CStr(j) & sDelimCmp & sSepCmp ' conexiones For j = 1 To UBound(Localidades(i).Conexiones) + 1 s = s & sDelimCmp & Localidades(i).Conexiones(j - 1).Localidad & sDelimCmp & sSepCmp & _ sDelimCmp & Localidades(i).Conexiones(j - 1).Verbo & sDelimCmp & sSepCmp & _ sDelimCmp & IIf(Localidades(i).Conexiones(j - 1).Abierta, "S", "N") & sDelimCmp & sSepCmp Next ' propiedades definidas por el usuario If HayPropUsrLoc Then For j = 0 To UBound(Localidades(i).PropUsr) s = s & sDelimCmp & Localidades(i).PropUsr(j) & sDelimCmp & sSepCmp Next End If s = s & sSepReg Next Else s = "0" End If Codifica s, CODIGO_RES Write #iFich, s ' objetos If bHayObj Then s = "1" & Format(UBound(Objetos) + 1, "000000000") For i = 0 To UBound(Objetos) s = s & sDelimCmp & Objetos(i).Nombre & sDelimCmp & sSepCmp & _ sDelimCmp & Objetos(i).Adjetivo & sDelimCmp & sSepCmp & _ sDelimCmp & Objetos(i).DescCorta & sDelimCmp & sSepCmp & _ sDelimCmp & Objetos(i).DescLarga & sDelimCmp & sSepCmp & _ sDelimCmp & CStr(Objetos(i).Peso) & sDelimCmp & sSepCmp & _ sDelimCmp & CStr(Objetos(i).Tam) & sDelimCmp & sSepCmp & _ sDelimCmp & CStr(Objetos(i).TipoContenedor) & sDelimCmp & sSepCmp & _ sDelimCmp & Objetos(i).Contenedor & sDelimCmp & sSepCmp & _ sDelimCmp & Objetos(i).Propiedades & sDelimCmp & sSepCmp & _ sDelimCmp & Objetos(i).Grafico & sDelimCmp & sSepCmp & _ sDelimCmp & Objetos(i).Sonido & sDelimCmp & sSepCmp & _ sDelimCmp & Objetos(i).Usuario & sDelimCmp & sSepCmp ' propiedades definidas por el usuario If HayPropUsrObj Then For j = 0 To UBound(Objetos(i).PropUsr) s = s & sDelimCmp & Objetos(i).PropUsr(j) & sDelimCmp & sSepCmp Next End If s = s & sSepReg Next Else s = "0" End If Codifica s, CODIGO_RES Write #iFich, s ' PSIs If bHayPSI Then s = "1" & Format(UBound(PSIs) + 1, "000000000") For i = 0 To UBound(PSIs) s = s & sDelimCmp & PSIs(i).Nombre & sDelimCmp & sSepCmp & _ sDelimCmp & PSIs(i).Adjetivo & sDelimCmp & sSepCmp & _ sDelimCmp & PSIs(i).DescCorta & sDelimCmp & sSepCmp & _ sDelimCmp & PSIs(i).DescLarga & sDelimCmp & sSepCmp & _ sDelimCmp & CStr(PSIs(i).Peso) & sDelimCmp & sSepCmp & _ sDelimCmp & CStr(PSIs(i).Tam) & sDelimCmp & sSepCmp & _ sDelimCmp & PSIs(i).Localidad & sDelimCmp & sSepCmp & _ sDelimCmp & PSIs(i).Propiedades & sDelimCmp & sSepCmp & _ sDelimCmp & PSIs(i).Grafico & sDelimCmp & sSepCmp & _ sDelimCmp & PSIs(i).Sonido & sDelimCmp & sSepCmp & _ sDelimCmp & PSIs(i).Usuario & sDelimCmp & sSepCmp ' propiedades definidas por el usuario If HayPropUsrPSI Then For j = 0 To UBound(PSIs(i).PropUsr) s = s & sDelimCmp & PSIs(i).PropUsr(j) & sDelimCmp & sSepCmp Next End If s = s & sSepReg Next Else s = "0" End If Codifica s, CODIGO_RES Write #iFich, s Close #iFich GuardaEstado = True Screen.MousePointer = vbDefault Exit Function Error_Guarda1: Close #iFich Error_Guarda2: DescError "Error al guardar el estado" GuardaEstado = False Screen.MousePointer = vbDefault End Function ' recupera el estado desde un fichero, devuelve True si pudo o False si error Public Function RecuperaEstado(ByVal sFich As String) As Boolean Dim iFich As Integer Dim i As Long, j As Long, n As Long, lNum As Long Dim s As String, sNum As String, sReg As String, sCmp1 As String, sCmp2 As String, sCmp3 As String Screen.MousePointer = vbHourglass On Error GoTo Error_Recupera2 iFich = FreeFile Open sFich For Input As #iFich On Error GoTo Error_Recupera1 Input #iFich, s If s <> ID_FICHESTADO Then GoTo Error_Recupera1 End If ' variables globales Input #iFich, s Codifica s, CODIGO_RES If s <> "" Then If Left(s, 1) = "1" Then sNum = Mid(s, 2, 9) lNum = CLng(sNum) ' quitamos la "cabecera" s = Right(s, Len(s) - 10) For i = 1 To lNum sReg = SeparaRegistro(s, i, Chr(DELIM_CMP), Chr(SEP_CMP), Chr(SEP_REG)) ' Nombre sCmp1 = SeparaCampo(sReg, 1, Chr(DELIM_CMP), Chr(SEP_CMP)) ' Valor sCmp2 = SeparaCampo(sReg, 2, Chr(DELIM_CMP), Chr(SEP_CMP)) ' Proc '''sCmp3 = SeparaCampo(sReg, 3, Chr(DELIM_CMP), Chr(SEP_CMP)) ' creamos la variable correspondiente, si no existe, si no le asignamos ' el valor CreaVariable sCmp1, sCmp2, VAR_GLOBAL, 0 Next End If End If ' localidades ReDim Localidades(0) bHayLoc = False Input #iFich, s Codifica s, CODIGO_RES If s <> "" Then If Left(s, 1) = "1" Then sNum = Mid(s, 2, 9) lNum = CLng(sNum) ' quitamos la "cabecera" s = Right(s, Len(s) - 10) ReDim Localidades(lNum - 1) For i = 1 To lNum sReg = SeparaRegistro(s, i, Chr(DELIM_CMP), Chr(SEP_CMP), Chr(SEP_REG)) ' Nombre Localidades(i - 1).Nombre = SeparaCampo(sReg, 1, Chr(DELIM_CMP), Chr(SEP_CMP)) ' DescCorta Localidades(i - 1).DescCorta = SeparaCampo(sReg, 2, Chr(DELIM_CMP), Chr(SEP_CMP)) ' DescLarga Localidades(i - 1).DescLarga = SeparaCampo(sReg, 3, Chr(DELIM_CMP), Chr(SEP_CMP)) ' Iluminada sCmp1 = SeparaCampo(sReg, 4, Chr(DELIM_CMP), Chr(SEP_CMP)) Localidades(i - 1).Iluminada = IIf(sCmp1 = "1", True, False) ' Exterior sCmp1 = SeparaCampo(sReg, 5, Chr(DELIM_CMP), Chr(SEP_CMP)) Localidades(i - 1).Exterior = IIf(sCmp1 = "1", True, False) ' Grafico Localidades(i - 1).Grafico = SeparaCampo(sReg, 6, Chr(DELIM_CMP), Chr(SEP_CMP)) ' Sonido Localidades(i - 1).Sonido = SeparaCampo(sReg, 7, Chr(DELIM_CMP), Chr(SEP_CMP)) ' Usuario Localidades(i - 1).Usuario = SeparaCampo(sReg, 8, Chr(DELIM_CMP), Chr(SEP_CMP)) ' conexiones j = CLng(SeparaCampo(sReg, 9, Chr(DELIM_CMP), Chr(SEP_CMP))) If j = 0 Then ReDim Localidades(i - 1).Conexiones(0) Else ReDim Localidades(i - 1).Conexiones(j - 1) For j = 0 To UBound(Localidades(i - 1).Conexiones) Localidades(i - 1).Conexiones(j).Localidad = SeparaCampo(sReg, 10 + (j * 3), Chr(DELIM_CMP), Chr(SEP_CMP)) Localidades(i - 1).Conexiones(j).Verbo = SeparaCampo(sReg, 11 + (j * 3), Chr(DELIM_CMP), Chr(SEP_CMP)) sCmp1 = SeparaCampo(sReg, 12 + (j * 3), Chr(DELIM_CMP), Chr(SEP_CMP)) Localidades(i - 1).Conexiones(j).Abierta = IIf(sCmp1 = "S", True, False) Next End If ' propiedades definidas por el usuario If HayPropUsrLoc Then n = UBound(LocProp) - NUM_LOCPROP_PREDEF ReDim Localidades(i - 1).PropUsr(n) For j = 0 To n Localidades(i - 1).PropUsr(j) = SeparaCampo(sReg, 13 + j, Chr(DELIM_CMP), Chr(SEP_CMP)) Next End If Next bHayLoc = True End If End If ' objetos ReDim Objetos(0) bHayObj = False Input #iFich, s Codifica s, CODIGO_RES If s <> "" Then If Left(s, 1) = "1" Then sNum = Mid(s, 2, 9) lNum = CLng(sNum) ' quitamos la "cabecera" s = Right(s, Len(s) - 10) ReDim Objetos(lNum - 1) For i = 1 To lNum sReg = SeparaRegistro(s, i, Chr(DELIM_CMP), Chr(SEP_CMP), Chr(SEP_REG)) ' Nombre Objetos(i - 1).Nombre = SeparaCampo(sReg, 1, Chr(DELIM_CMP), Chr(SEP_CMP)) ' Adjetivo Objetos(i - 1).Adjetivo = SeparaCampo(sReg, 2, Chr(DELIM_CMP), Chr(SEP_CMP)) ' DescCorta Objetos(i - 1).DescCorta = SeparaCampo(sReg, 3, Chr(DELIM_CMP), Chr(SEP_CMP)) ' DescLarga Objetos(i - 1).DescLarga = SeparaCampo(sReg, 4, Chr(DELIM_CMP), Chr(SEP_CMP)) ' Peso sCmp1 = SeparaCampo(sReg, 5, Chr(DELIM_CMP), Chr(SEP_CMP)) Objetos(i - 1).Peso = CLng(sCmp1) ' Tam sCmp1 = SeparaCampo(sReg, 6, Chr(DELIM_CMP), Chr(SEP_CMP)) Objetos(i - 1).Tam = CLng(sCmp1) ' TipoContenedor sCmp1 = SeparaCampo(sReg, 7, Chr(DELIM_CMP), Chr(SEP_CMP)) Objetos(i - 1).TipoContenedor = CLng(sCmp1) ' Contenedor Objetos(i - 1).Contenedor = SeparaCampo(sReg, 8, Chr(DELIM_CMP), Chr(SEP_CMP)) ' Propiedades Objetos(i - 1).Propiedades = SeparaCampo(sReg, 9, Chr(DELIM_CMP), Chr(SEP_CMP)) ' Grafico Objetos(i - 1).Grafico = SeparaCampo(sReg, 10, Chr(DELIM_CMP), Chr(SEP_CMP)) ' Sonido Objetos(i - 1).Sonido = SeparaCampo(sReg, 11, Chr(DELIM_CMP), Chr(SEP_CMP)) ' Usuario Objetos(i - 1).Usuario = SeparaCampo(sReg, 12, Chr(DELIM_CMP), Chr(SEP_CMP)) ' propiedades definidas por el usuario If HayPropUsrObj Then n = UBound(ObjProp) - NUM_OBJPROP_PREDEF ReDim Objetos(i - 1).PropUsr(n) For j = 0 To n Objetos(i - 1).PropUsr(j) = SeparaCampo(sReg, 13 + j, Chr(DELIM_CMP), Chr(SEP_CMP)) Next End If Next bHayObj = True End If End If ' PSIs ReDim PSIs(0) bHayPSI = False Input #iFich, s Codifica s, CODIGO_RES If s <> "" Then If Left(s, 1) = "1" Then sNum = Mid(s, 2, 9) lNum = CLng(sNum) ' quitamos la "cabecera" s = Right(s, Len(s) - 10) ReDim PSIs(lNum - 1) For i = 1 To lNum sReg = SeparaRegistro(s, i, Chr(DELIM_CMP), Chr(SEP_CMP), Chr(SEP_REG)) ' Nombre PSIs(i - 1).Nombre = SeparaCampo(sReg, 1, Chr(DELIM_CMP), Chr(SEP_CMP)) ' Adjetivo PSIs(i - 1).Adjetivo = SeparaCampo(sReg, 2, Chr(DELIM_CMP), Chr(SEP_CMP)) ' DescCorta PSIs(i - 1).DescCorta = SeparaCampo(sReg, 3, Chr(DELIM_CMP), Chr(SEP_CMP)) ' DescLarga PSIs(i - 1).DescLarga = SeparaCampo(sReg, 4, Chr(DELIM_CMP), Chr(SEP_CMP)) ' Peso sCmp1 = SeparaCampo(sReg, 5, Chr(DELIM_CMP), Chr(SEP_CMP)) PSIs(i - 1).Peso = CLng(sCmp1) ' Tam sCmp1 = SeparaCampo(sReg, 6, Chr(DELIM_CMP), Chr(SEP_CMP)) PSIs(i - 1).Tam = CLng(sCmp1) ' Localidad PSIs(i - 1).Localidad = SeparaCampo(sReg, 7, Chr(DELIM_CMP), Chr(SEP_CMP)) ' Propiedades PSIs(i - 1).Propiedades = SeparaCampo(sReg, 8, Chr(DELIM_CMP), Chr(SEP_CMP)) ' Grafico PSIs(i - 1).Grafico = SeparaCampo(sReg, 9, Chr(DELIM_CMP), Chr(SEP_CMP)) ' Sonido PSIs(i - 1).Sonido = SeparaCampo(sReg, 10, Chr(DELIM_CMP), Chr(SEP_CMP)) ' Usuario PSIs(i - 1).Usuario = SeparaCampo(sReg, 11, Chr(DELIM_CMP), Chr(SEP_CMP)) ' propiedades definidas por el usuario If HayPropUsrPSI Then n = UBound(PSIProp) - NUM_PSIPROP_PREDEF ReDim PSIs(i - 1).PropUsr(n) For j = 0 To n PSIs(i - 1).PropUsr(j) = SeparaCampo(sReg, 12 + j, Chr(DELIM_CMP), Chr(SEP_CMP)) Next End If Next bHayPSI = True End If End If Close #iFich RecuperaEstado = True Screen.MousePointer = vbDefault Exit Function Error_Recupera1: Close #iFich Error_Recupera2: DescError "Error al recuperar el estado" RecuperaEstado = False Screen.MousePointer = vbDefault End Function ' guarda el estado para reiniciar el programa Private Sub Reiniciar_Guarda() Dim i As Long ' localidades ReDim Localidades2(UBound(Localidades)) For i = 0 To UBound(Localidades) Localidades2(i) = Localidades(i) Next ' objetos ReDim Objetos2(UBound(Objetos)) For i = 0 To UBound(Objetos) Objetos2(i) = Objetos(i) Next ' PSIs ReDim PSIs2(UBound(PSIs)) For i = 0 To UBound(PSIs) PSIs2(i) = PSIs(i) Next End Sub ' carga el estado para reiniciar el programa Private Sub Reiniciar_Carga() Dim i As Long ' localidades For i = 0 To UBound(Localidades) Localidades(i) = Localidades2(i) Next ' objetos For i = 0 To UBound(Objetos) Objetos(i) = Objetos2(i) Next ' PSIs For i = 0 To UBound(PSIs) PSIs(i) = PSIs2(i) Next End Sub