Attribute VB_Name = "Rutinas"
Option Explicit

' API
Public Declare Function LockWindowUpdate Lib "user32" (ByVal hwndLock As Long) As Long
Public Declare Function GetTickCount Lib "kernel32" () As Long

Public Const HWND_BROADCAST = &HFFFF&
Public Const EM_LINEFROMCHAR = &HC9
Public Const EM_EXLINEFROMCHAR = &H436
Public Const EM_LINEINDEX = &HBB
Public Const EM_GETLINECOUNT = &HBA
Public Const EM_GETLINE = &HC4
Public Const EM_GETFIRSTVISIBLELINE = &HCE
Public Const EM_LINESCROLL = &HB6
Public Const EM_SCROLL = &HB5
Public Const EM_SCROLLCARET = &HB7
Public Const SB_LINEDOWN = 1
Public Const SB_LINEUP = 0
Public Const SB_PAGEDOWN = 3
Public Const SB_PAGEUP = 2
Public Const WM_FONTCHANGE = &H1D
Public Declare Function SendMessage Lib "user32" Alias "SendMessageA" (ByVal hwnd As Long, ByVal wMsg As Long, ByVal wParam As Long, lParam As Any) As Long

Public Const SWP_NOMOVE = &H2
Public Const SWP_NOSIZE = &H1
Public Const SWP_SHOWWINDOW = &H40
Public Const SWP_NOACTIVATE = &H10
Public Const SWP_FLAGS = SWP_NOMOVE Or SWP_NOSIZE Or SWP_SHOWWINDOW Or SWP_NOACTIVATE
Public Declare Function SetWindowPos Lib "user32" (ByVal hwnd As Long, ByVal hWndInsertAfter As Long, ByVal X As Long, ByVal Y As Long, ByVal cx As Long, ByVal cy As Long, ByVal wFlags As Long) As Long

Public Const SW_SHOWNORMAL = 1
Public Declare Function ShellExecute Lib "shell32.dll" Alias "ShellExecuteA" (ByVal hwnd As Long, ByVal lpOperation As String, ByVal lpFile As String, ByVal lpParameters As String, ByVal lpDirectory As String, ByVal nShowCmd As Long) As Long

Public Const SRCCOPY = &HCC0020
Public Declare Function BitBlt Lib "gdi32" (ByVal hDestDC As Long, ByVal X As Long, ByVal Y As Long, ByVal nWidth As Long, ByVal nHeight As Long, ByVal hSrcDC As Long, ByVal xSrc As Long, ByVal ySrc As Long, ByVal dwRop As Long) As Long

Public Const MAX_PATH = 260
Public Declare Function GetTempFileName Lib "kernel32" Alias "GetTempFileNameA" (ByVal lpszPath As String, ByVal lpPrefixString As String, ByVal wUnique As Long, ByVal lpTempFileName As String) As Long
Public Declare Function GetSystemDirectory Lib "kernel32" Alias "GetSystemDirectoryA" (ByVal lpBuffer As String, ByVal nSize As Long) As Long
Public Declare Function GetWindowsDirectory Lib "kernel32" Alias "GetWindowsDirectoryA" (ByVal lpBuffer As String, ByVal nSize As Long) As Long
Public Declare Function GetTempPath Lib "kernel32" Alias "GetTempPathA" (ByVal nBufferLength As Long, ByVal lpBuffer As String) As Long

Public Declare Sub Codifica Lib "vs" Alias "_Codifica@8" (ByVal s As String, ByVal clave As Integer)

Public Function InicializaDatosAventura()
    
    ReDim Localidades(0)
    bHayLoc = False
    PropiedadesLocalidades
    
    ReDim ObjProp(0)
    ReDim Objetos(0)
    bHayObj = False
    PropiedadesObjetos
    
    ReDim PSIProp(0)
    ReDim PSIs(0)
    bHayPSI = False
    PropiedadesPSIs
    
    ReDim Vocabulario(0)
    bHayVoc = False
    
    ReDim ListaMod(0)
    bHayModulos = False

End Function

' función genérica para leer las descripciones cortas o largas de los objetos,
' localidades, etc...
Public Function LeeDescripcion(ByVal iFich As Integer) As String
    Dim c As String, c1 As String, sDesc As String
    Dim i As Long, lCar As Long
    
    sDesc = ""
    
    Line Input #iFich, c
    i = InStr(c, "}")
    If i = 0 Then
        LeeDescripcion = ""
        Exit Function
    End If
    
    c1 = Mid(c, 2, i - 2)
    lCar = CLng(c1) - (Len(c) - i)
    sDesc = Mid(c, i + 1)

    Do While lCar > 0
        Line Input #iFich, c
        sDesc = sDesc & vbCrLf & c
        lCar = lCar - Len(c) - 2
    Loop

    LeeDescripcion = sDesc

End Function

' convierte de hexadecimal a decimal (devuelve -1 si error)
Public Function HexADec(ByVal sHex As String) As Long
    Dim c As String, sH As String
    Dim i As Integer, j As Integer
    Dim lDec As Long, lMult As Long
    
    ' caracteres hexadecimales
    sH = "0123456789ABCDEF"
    lDec = 0
    lMult = 1
    For i = Len(sHex) To 1 Step -1
        c = UCase(Mid(sHex, i, 1))
        j = InStr(sH, c)
        If j = 0 Then
            HexADec = -1
            Exit Function
        End If
        lDec = lDec + ((j - 1) * lMult)
        lMult = lMult * 16
    Next

    HexADec = lDec
    
End Function

' devuelve la línea actual de un Textbox
Public Function LineaTextbox(ByVal Txt As Object) As Long

    LineaTextbox = SendMessage(Txt.hwnd, EM_LINEFROMCHAR, -1, 0)
    If LineaTextbox < 0 Then
        LineaTextbox = 0
    End If

End Function

' devuelve la línea que contiene al carácter en la posición 'n' de un Textbox
Public Function LineaCarTextbox(ByVal Txt As Object, ByVal n As Long) As Long

    LineaCarTextbox = Txt.GetLineFromChar(n)

End Function

' devuelve la posición del primer carácter de una línea de un Textbox
Public Function CarLineaTextbox(ByVal Txt As Object, ByVal lLin As Long) As Long
    
    CarLineaTextbox = SendMessage(Txt.hwnd, EM_LINEINDEX, lLin, 0)

End Function

' devuelve la columna actual de un Textbox
Public Function ColumnaTextbox(ByVal Txt As Object) As Long

    ColumnaTextbox = Txt.SelStart - SendMessage(Txt.hwnd, EM_LINEINDEX, -1, 0)
    If ColumnaTextbox < 0 Then
        ColumnaTextbox = 0
    End If

End Function

' devuelve el número de líneas de un Textbox
Public Function NumLineasTextbox(ByVal Txt As Object) As Long
    Dim i As Long

    i = SendMessage(Txt.hwnd, EM_GETLINECOUNT, 0, 0)
    NumLineasTextbox = i

End Function

' devuelve el contenido de una línea de un Textbox
Public Function ContenidoLineaTextbox(ByVal Txt As Object, ByVal lLin As Long) As String
    Const MAX_LONGLIN = 1024
    Dim s As String
    Dim i As Long
    Dim iByteBajo As Integer, iByteAlto As Integer
    
    ' creamos un buffer para recoger el contenido de la línea
    ' la primera palabra del buffer debe contener la longitud del mismo
    iByteBajo = MAX_LONGLIN And 255
    iByteAlto = CInt(MAX_LONGLIN / 256)
    s = Chr(iByteBajo) + Chr(iByteAlto) + Space(MAX_LONGLIN - 2)
    i = SendMessage(Txt.hwnd, EM_GETLINE, lLin, ByVal s)
    
    If i > 0 Then
        ContenidoLineaTextbox = Left(s, i)
    Else
        ContenidoLineaTextbox = ""
    End If
    
    ' eliminamos saltos de línea finales
    i = InStr(ContenidoLineaTextbox, vbCrLf)
    If i > 1 Then
        ContenidoLineaTextbox = Left(ContenidoLineaTextbox, i - 1)
    End If

End Function

' devuelve el nº de la primera línea de un Textbox
Public Function PrimeraLineaTextbox(ByVal Txt As Object) As Long

    PrimeraLineaTextbox = SendMessage(Txt.hwnd, EM_GETFIRSTVISIBLELINE, 0, 0)
    
End Function

' se posiciona dentro del Textbox, como primera línea del Textbox
' se coloca 'lPrimeraLinea', el cursor se sitúa en 'lCarCur'
Public Sub PosicionTextbox(ByVal Txt As Object, _
  ByVal lPrimeraLinea As Long, ByVal lCarCur As Long)
    Dim i As Long, j As Long
    
    i = NumLineasTextbox(Txt)
    If lPrimeraLinea > i Then
        lPrimeraLinea = i
    End If
   
    ' calcula el número de líneas que hay que desplazar
    i = PrimeraLineaTextbox(Txt)
    i = lPrimeraLinea - i
    LockWindowUpdate Txt.hwnd
    If i > 0 Then
        For j = 1 To i
            SendMessage Txt.hwnd, EM_SCROLL, SB_LINEDOWN, 0
        Next
    Else
        For j = -1 To i Step -1
            SendMessage Txt.hwnd, EM_SCROLL, SB_LINEUP, 0
        Next
    End If
    
    ' sitúa el cursor en el primer carácter de la primera línea
    Txt.SelStart = lCarCur
    Txt.SelLength = 0
    
    LockWindowUpdate 0
    
End Sub

' se posiciona en una línea de un Textbox
Public Sub IrALineaTextbox(ByVal Txt As Object, ByVal lLin As Long)
    Dim i As Long, j As Long
    
    i = NumLineasTextbox(Txt)
    If lLin > i Then
        lLin = i
    End If
    
    ' calcula el número de líneas que hay que desplazar
    i = PrimeraLineaTextbox(Txt)
    i = lLin - i
    LockWindowUpdate Txt.hwnd
    If i > 0 Then
        For j = 1 To i
            SendMessage Txt.hwnd, EM_SCROLL, SB_LINEDOWN, 0
        Next
    Else
        For j = -1 To i Step -1
            SendMessage Txt.hwnd, EM_SCROLL, SB_LINEUP, 0
        Next
    End If
    
    ' sitúa el cursor en el primer carácter de la primera línea
    i = PrimeraLineaTextbox(Txt)
    Txt.SelStart = CarLineaTextbox(Txt, i)
    Txt.SelLength = 0
    
    LockWindowUpdate 0
    
End Sub

' indica si un formulario está o no cargado
Public Function EstaCargado(frm As Form) As Boolean
    Dim i As Integer
    
    For i = 0 To Forms.Count - 1
        If Forms(i) Is frm Then
            EstaCargado = True
            Exit Function
        End If
    Next
    
    EstaCargado = False
    
End Function

' separa el nombre y el adjetivo de una cadena de la forma: NOMBRE ADJETIVO
Public Sub SeparaNombreAdj(ByVal sDesc As String, ByRef sNombre As String, _
  ByRef sAdj As String)
    Dim i As Long

    i = InStr(sDesc, " ")
    If i = 0 Then
        sNombre = sDesc
        sAdj = ""
        Exit Sub
    End If

    On Error Resume Next
    sNombre = ""
    sAdj = ""
    sNombre = Left(sDesc, i - 1)
    sAdj = Right(sDesc, Len(sDesc) - i)

End Sub

' junta el nombre y adjetivo en una cadena
Public Function JuntaNombreAdj(ByVal sNombre As String, ByVal sAdj As String) As String

    JuntaNombreAdj = sNombre & IIf(sAdj = "", "", " " & sAdj)

End Function

' devuelve la ruta de un fichero
Public Function Ruta(ByVal sFich As String) As String
    Dim i As Long
    Dim s As String
    
    i = InStrRev(sFich, "\")
    If i > 1 Then
        s = Left(sFich, i - 1)
    Else
        s = ""
    End If

    Ruta = s

End Function

' devuelve el registro n-ésimo de una cadena de la forma: reg1/reg2/reg2/...
' donde cada registro es de la forma: "campo1";"campo2";"campo3";...
Public Function SeparaRegistro(ByVal s As String, ByVal n As Long, _
  ByVal sDelimCmp As String, ByVal sSepCmp As String, ByVal sSepReg As String) As String
    Dim i As Long, lReg As Long, lDelim1 As Long, lDelim2 As Long
    Dim c As String
        
    If n < 1 Then
        SeparaRegistro = ""
        Exit Function
    End If
    
    lReg = 0
    i = 1
    Do While i <= Len(s)
        c = Mid(s, i, 1)
        ' buscamos el primer delimitador de campo
        If c = sDelimCmp Then
            lDelim1 = i
            i = i + 1
            Do While i <= Len(s)
                c = Mid(s, i, 1)
                ' buscamos el 2º delimitador de campo
                If c = sDelimCmp Then
                    i = i + 1
                    If i > Len(s) Then
                        SeparaRegistro = ""
                        Exit Function
                    End If
                    c = Mid(s, i, 1)
                    ' buscamos el separador de campo
                    If c = sSepCmp Then
                        lDelim2 = i
                        i = i + 1
                        If i > Len(s) Then
                            SeparaRegistro = ""
                            Exit Function
                        End If
                        c = Mid(s, i, 1)
                        ' buscamos el separador de registro
                        If c = sSepReg Then
                            lReg = lReg + 1
                            If lReg = n Then
                                If (lDelim2 - lDelim1 + 1) > 0 Then
                                    SeparaRegistro = Mid(s, lDelim1, lDelim2 - lDelim1 + 1)
                                Else
                                    SeparaRegistro = ""
                                End If
                                Exit Function
                            Else
                                Exit Do
                            End If
                        End If
                    End If
                End If
                i = i + 1
            Loop
        End If
        i = i + 1
    Loop

End Function

' devuelve el campo n-ésimo de una cadena de la forma: "campo1";"campo2";"campo3";...
' le pasamos el delimitador y el separador de campos
' la cadena debe terminar con un separador de campos
Public Function SeparaCampo(ByVal s As String, ByVal n As Long, _
  ByVal sDelimCmp As String, ByVal sSepCmp As String) As String
    Dim i As Long, lCmp As Long, lDelim1 As Long, lDelim2 As Long
    Dim c As String
        
    If n < 1 Then
        SeparaCampo = ""
        Exit Function
    End If
    
    lCmp = 0
    i = 1
    Do While i <= Len(s)
        c = Mid(s, i, 1)
        ' buscamos el primer delimitador de campo
        If c = sDelimCmp Then
            lDelim1 = i
            i = i + 1
            Do While i <= Len(s)
                c = Mid(s, i, 1)
                ' buscamos el 2º delimitador de campo
                If c = sDelimCmp Then
                    lDelim2 = i
                    i = i + 1
                    If i > Len(s) Then
                        SeparaCampo = ""
                        Exit Function
                    End If
                    c = Mid(s, i, 1)
                    ' buscamos el separador de campo
                    If c = sSepCmp Then
                        lCmp = lCmp + 1
                        If lCmp = n Then
                            If (lDelim2 - lDelim1 - 1) > 0 Then
                                SeparaCampo = Mid(s, lDelim1 + 1, lDelim2 - lDelim1 - 1)
                            Else
                                SeparaCampo = ""
                            End If
                            Exit Function
                        Else
                            Exit Do
                        End If
                    End If
                End If
                i = i + 1
            Loop
        End If
        i = i + 1
    Loop
    
End Function

' sustituye vocales acentuadas por vocales sin acentuar
Public Function QuitaAcentos(ByVal sTxt As String) As String
    Const VOC_AC = "áéíóúÁÉÍÓÚàèìòùÀÈÌÒÙäëïöüÄËÏÖÜ"
    Const VOC_NOAC = "aeiouAEIOUaeiouAEIOUaeiouAEIOU"
    Dim i As Long, j As Long
    Dim s As String, c As String

    s = ""
    For i = 1 To Len(sTxt)
        c = Mid(sTxt, i, 1)
        ' buscamos vocal acentuada y si la encontramos devolvemos la correspondiente
        ' sin acentuar
        j = InStr(VOC_AC, c)
        If j > 0 Then
            c = Mid(VOC_NOAC, j, 1)
        End If
        s = s & c
    Next

    QuitaAcentos = s
    
End Function

' carga la lista de módulos, devuelve False si error
Public Function CargarModulos(ByVal sFich As String) As Boolean
    Dim i As Long
    Dim iFich As Integer
    Dim c As String, sNombre As String, sFichero As String

    On Error GoTo Error_CargarMod

    iFich = FreeFile
    Open sFich For Input As #iFich
    
    i = 0
    ReDim ListaMod(0)
    Do While Not EOF(iFich)
        Line Input #iFich, c
        ' si encontramos un línea en blanco es que no hay módulos
        If c = "" Then
            Close #iFich
            ReDim ListaMod(0)
            bHayModulos = False
            CargarModulos = True
            Exit Function
        Else
            ReDim Preserve ListaMod(i)
            sNombre = SeparaCampo(c, 1, """", ";")
            sFichero = SeparaCampo(c, 2, """", ";")
            ListaMod(i).Nombre = sNombre
            ListaMod(i).Fichero = sFichero
            i = i + 1
        End If
    Loop

    Close #iFich
    If i > 0 Then
        bHayModulos = True
    End If
    
    CargarModulos = True
    Exit Function

Error_CargarMod:
    Close #iFich
    ReDim ListaMod(0)
    bHayModulos = False
    MsgBox "Error al cargar lista de módulos: " & Err.Description, _
      vbOKOnly + vbCritical, "Error"
    CargarModulos = False
End Function

' guarda la lista de módulos, devuelve False si error
Public Function GuardarModulos(ByVal sFich As String) As Boolean
    Dim i As Long
    Dim iFich As Integer

    On Error GoTo Error_GuardarMod

    iFich = FreeFile
    Open sFich For Output As #iFich
    If bHayModulos Then
        For i = 0 To UBound(ListaMod)
            Print #iFich, """" & ListaMod(i).Nombre & """;""" & ListaMod(i).Fichero & """;"
        Next
    Else
        Print #iFich, ""
    End If
    Close #iFich
    GuardarModulos = True
    Exit Function

Error_GuardarMod:
    Close #iFich
    MsgBox "Error al guardar lista de módulos: " & Err.Description, _
      vbOKOnly + vbCritical, "Error"
    GuardarModulos = False
End Function

' devuelve el nombre de un fichero
Public Function NombreFich(ByVal s As String) As String
    Dim i As Long

    i = InStrRev(s, "\")
    If Len(s) - i > 0 Then
        NombreFich = Right(s, Len(s) - i)
    Else
        NombreFich = ""
    End If
    
End Function

' devuelve la ruta de un fichero
Public Function RutaFich(ByVal s As String) As String
    Dim i As Long

    i = InStrRev(s, "\")
    If i > 1 Then
        RutaFich = Left(s, i - 1)
    Else
        RutaFich = ""
    End If
    
End Function

' comprueba si existe un fichero
Public Function ExisteFichero(ByVal sFich As String) As Boolean
    Dim iFich As Integer

    On Error Resume Next
    iFich = FreeFile
    Open sFich For Input As #iFich
    If Err.Number <> 0 Then
        ExisteFichero = False
        Exit Function
    End If
    Close #iFich
    ExisteFichero = True
    
End Function

' devuelve el nombre de un fichero temporal (y lo crea), o cadena vacía si error
' el nombre del fichero comienza con la cadena que le pasamos a 'sPref'
' el fichero se crea en la ruta especificada por 'sRuta'
Public Function FichTemp(ByVal sRuta As String, ByVal sPref As String) As String
    Dim s As String
    Dim i As Long
    
    s = String(MAX_PATH, Chr(0))
    If GetTempFileName(sRuta, sPref, 0, s) = 0 Then
        s = ""
    Else
        ' eliminamos caracteres sobrantes
        i = InStr(s, Chr(0))
        If i > 1 Then
            s = Left(s, i - 1)
        Else
            s = ""
        End If
    End If
    
    FichTemp = s
    
End Function

' devuelve la ruta del directorio WINDOWS
Public Function DirWindows() As String
    Const MAXLNG = 256
    Dim s As String
    Dim i As Long
    
    s = Space(MAXLNG)
    GetWindowsDirectory s, MAXLNG
    
    ' quitamos los Chr(0) finales
    i = InStr(s, Chr(0))
    If i > 1 Then
        s = Trim(Left(s, i - 1))
    Else
        s = ""
    End If
    
    ' añadimos '\' final si no tiene
    If Len(s) > 0 And Right(s, 1) <> "\" Then
        s = s & "\"
    End If
    
    DirWindows = s

End Function

' devuelve la ruta del directorio SYSTEM
Public Function DirSystem() As String
    Const MAXLNG = 256
    Dim s As String
    Dim i As Long
    
    s = Space(MAXLNG)
    GetSystemDirectory s, MAXLNG
    
    ' quitamos los Chr(0) finales
    i = InStr(s, Chr(0))
    If i > 1 Then
        s = Trim(Left(s, i - 1))
    Else
        s = ""
    End If
    
    ' añadimos '\' final si no tiene
    If Len(s) > 0 And Right(s, 1) <> "\" Then
        s = s & "\"
    End If
    
    DirSystem = s

End Function

' devuelve la ruta del directorio TEMP
Public Function DirTemp() As String
    Const MAXLNG = 256
    Dim s As String
    Dim i As Long
    
    s = Space(MAXLNG)
    GetTempPath MAXLNG, s
    
    ' quitamos los Chr(0) finales
    i = InStr(s, Chr(0))
    If i > 1 Then
        s = Trim(Left(s, i - 1))
    Else
        s = ""
    End If
    
    ' añadimos '\' final si no tiene
    If Len(s) > 0 And Right(s, 1) <> "\" Then
        s = s & "\"
    End If
    
    DirTemp = s

End Function

' devuelve las extensión de un fichero
Public Function ExtensionFich(ByVal sFich As String) As String
    Dim i As Long

    i = InStrRev(sFich, ".")
    If i > 1 Then
        ExtensionFich = Right(sFich, Len(sFich) - i)
    Else
        ExtensionFich = ""
    End If

End Function