'###############################################################################
'# Parte de código de ejemplo para un insertor de scripts en Visual Basic 6.0 #
'# Hexplus - Fortaleza Romhack 2007 #
'# Este código aplica para un solo diálogo #
'# Este código fuente no pretende ser el mejor código para realizar esto #
'# Si utilizas este código en tus programas o parte de él, por favor, hazlo #
'# saber por favor en él. Nada cuesta dar gracias. #
'# Consultas a: hexplus@gmail.com #
'###############################################################################
'---------------------------------------------------------------------------------------------------------------
'Esta es la estructura de la tabla, esto deberia ir en un módulo
Type tabla
hexa As String
valor As String
End Type
'Al igual, la declaración de la tabla, deberia estar en el mismo módulo
Public tablaT(1 To 5000) As tabla
'---------------------------------------------------------------------------------------------------------------
'Este es el procedimiento para convertir e insertar ese texto convertido en bytes en la ROM
'Podría estar mejor optimizado creo yo, no pretende ser el estándar, ni el mejor código existente
Private Sub cmdInsertar_click()
'Definición de variables
Dim texto As String 'Esta variable recogerá el texto que traducimos y queremos insertar
texto = "" 'la inicializo
Dim cadenaInsertar As String 'Recogerá el texto traducido ya convertido en bytes
cadenaInsertar = "" 'inicializo
Dim maximo As Integer 'maximo es una variable que me indica cual es la palabra mas larga en la
'tabla MTE, si es DTE obvio que siempre es 2
maximo = 0 'Inicializo
Dim i As Integer 'Contador para For
Dim j As Integer 'Contador para For
Dim k As Integer 'Contador para For
Dim tmp As String 'Variable temporal para recoger texto
tmp = ""
Dim tag As String 'Etiqueta
If Len(rtxtTraducido.Text) = 0 Then
MsgBox "¡Nada que insertar!"
Exit Sub
End If
Dim offset As Long 'Direccion a insertar
Dim nroArchivo As Integer 'Numero de archivo en donde vamos a insertar
'Pedimos confirmación
mensaje = MsgBox("¿Está seguro de insertar el Script?", vbQuestion + vbYesNo, "Confirmación requerida")
If mensaje <> vbYes Then Exit Sub
'Transformación a formato de inserción:
texto = rtxtTraducido.Text 'Es el texto de la caja de texto traducido, se la asignamos a la variable texto
maximo = masLargoO 'Es el valor del largo de la palabra mas larga de la tabla
For i = 1 To Len(texto) 'De 1 al largo total del texto, recorro todo el texto
For j = maximo To 1 Step -1 'Del largo de la palabra mas larga a 1
tmp = Mid(texto, i, j) 'Leo una porción de cadena del texto
'Primero trato los saltos de linea
If tmp = vbCr Then 'Si esa porción es un vbCr, entonces es un salto de línea
For k = 1 To 5000 'En busca del * del salto de línea en la tabla
If tablaT(k).valor = "LINE" Then 'En este caso busco 'LINE' en la tabla ¨"traducida"
'valor que asigne para en salto de linea
'Si buscara un * me devolvería el valor del asterisco
cadenaInsertar = cadenaInsertar & HexToStr(tablaT(k).hexa) 'Acumulo el byte en la cadena a insertar
Exit For 'Aborto el For
End If
Next
i = i + 1 'Sumo 1 a la posicion en el texto
GoTo siguiente ´Voy a siguiente, para leer otra cadena / A veces GoTo es una maldicion, a veces ideal ^^
End If
'Luego trato los fines de bloque
If tmp = lEnclosure Then 'Cierre izquierdo(lEnclosure), ya sea { o <
tag = ""
While tmp <> rEnclosure 'Mientras tmp sea diferente a cierre derecho (rEnclosure)
i = i + 1 'Sumo 1 a la posición que tenemos en el texto
tmp = Mid(texto, i, j) 'Leo del texto
tag = tag & tmp 'Voy acumulando lo que hay despues del inicio de la llave
If Left(tag, Len(tag) - 1) = "END" Then 'Comparo si tag es igual a END
For k = 1 To 5000 'En busca del / del fin de bloque
If tablaT(k).valor = "END" Then
cadenaInsertar = cadenaInsertar & HexToStr(tablaT(k).hexa) 'Acumulamos el byte
Exit For
End If
Next
i = i + 1
GoTo siguiente 'Continuamos con la siguiente cadena o siguiente byte
End If
Wend
End If
'Cualquier otro valor que no sea un salto de línea o un fin de bloque
For k = 1 To 5000
If tablaT(k).valor = vbNullString Then Exit For
If tmp = "END" Then Exit For 'Esto es por si existiese una palabra por ejemplo 'TENDENCIA'
If tmp = "LINE" Then Exit For 'Similar al anterior
If tmp = tablaT(k).valor Then 'Aqui entra cualquier otro valor que no sean saltos ni fin de bloque
cadenaInsertar = cadenaInsertar & HexToStr(tablaT(k).hexa) 'Acumulamos
i = i + Len(tmp) - 1
GoTo siguiente
End If
Next
Next
'Se supone que para este punto que el largo de tmp tiene que quedar en cero
If Len(tmp) = 1 Then 'Si el largo de tmp es 1, quiere decir que no se encontró ese caracter en la tabla traducida
mensaje = MsgBox("Caracter '" & tmp & "'" & vbCrLf & "[Ascii: " & Asc(tmp) & "] no existe en la tabla." & vbCrLf & "¿Desea insertar el script de todos modos?", vbCritical + vbYesNo, "Precaución")
If mensaje = vbNo Then
rtxtTraducido.SelStart = i 'Nos posicionamos en donde está el caracter no encontrado en el RichTexbox
rtxtTraducido.SelLength = 1
rtxtTraducido.SetFocus
Exit Sub
End If
End If
siguiente:
Next
'Inserción:
'Se llega a este punto cuando ya se ha recorrido toda la cadena de texto que queremos insertar
offset = HexToDec(Left(Scripts.FileName, Len(Scripts.FileName) - 4)) + 1 'Esto lo hago pues este codigo utiliza el nombre
'de archivos del Hextractor (programa que hice para extraer scripts)
nroArchivo = FreeFile
Open ROM For Binary As #nroArchivo
Put #nroArchivo, offset, cadenaInsertar
Close #nroArchivo
MsgBox "Se han insertado " & Len(cadenaInsertar) & " bytes en la dirección 0x" & Left(Scripts.FileName, Len(Scripts.FileName) - 4) & "."
End Sub
'---------------------------------------------------------------------------------------------------------------
'Procedimiento sencillísimo para cargar una tabla thingy con salto de linea y fin de bloque de texto
'Podría mejorarse, por supuesto
'En este caso recibimos el número de archivo como parámetro, pero puedes adecuarlo a tu gusto
Private Sub cargarTablaT(nro As Integer)
'On Error Resume Next
Dim cadena As String
Dim i As Integer
i = 1
'Tblt ya habia sido declarado globalmente y este es el nombre de la tabla
Open TbLt For Input As #nro
While Not EOF(nro) 'Mientras no sea el fin de la tabla
Line Input #nro, cadena
If InStr(1, cadena, "=") > 0 Then
tablaT(i).hexa = Left(cadena, InStr(cadena, "=") - 1)
tablaT(i).valor = Right(cadena, Len(cadena) - InStr(cadena, "="))
i = i + 1
Else
If Left(cadena, 1) = "/" Then 'Fin de linea
tablaT(i).hexa = Right(cadena, Len(cadena) - 1)
tablaT(i).valor = "END" 'Pongo valor en "END" para no interferir con el valor de /
i = i + 1
Else
If Left(cadena, 1) = "*" Then 'Salto de linea
tablaT(i).hexa = Right(cadena, Len(cadena) - 1)
tablaT(i).valor = "LINE" 'Igual, para no interferir con el "*" (asterisco)
i = i + 1
End If
End If
End If
Wend
End Sub
'---------------------------------------------------------------------------------------------------------------
'Función que devuelve la palabra más larga en la tabla
Private Function masLargaT() As Integer
'Esta funcion mide cual palabra es la más larga que existe en la tabla
Dim masLargo As Integer
masLargo = 1
Dim largo As Integer
largo = 0
'Primero verifico los triples
Dim i As Integer
For i = 1 To 5000
If tablaT(i).valor = vbNullString Then Exit For
If tablaT(i).valor = "END" Or tablaT(i).valor = "LINE" Then GoTo siguiente 'Para no tomar en cuenta estas dos palabras
largo = Len(tablaT(i).valor)
If largo > masLargo Then
masLargo = largo
End If
siguiente:
Next
masLargaT = masLargo
End Function
'-------------------------------------------------------------------------------------------------------------------------
'Función para convertir de Hexadecimal a Decimal, utilizo ésta, pues la funcion Hex$(String) tiene límitantes cuando
'se trata de numeros muy grandes
Function HexToDec(HexStr As String) As Long 'Funcion para convertir de hexadecimal a decimal
Dim strlen As Integer
Dim Ctr As Integer
Dim Word As String * 1
Dim lngTemp As Long
strlen = Len(HexStr)
HexStr = UCase(HexStr)
For Ctr = strlen To 1 Step -1
Word = Left$(HexStr, 1)
HexStr = Mid(HexStr, 2, Len(HexStr) - 1)
Select Case Word
Case "0"
lngTemp = lngTemp
Case "1"
lngTemp = (16 ^ (Ctr - 1)) * 1 + lngTemp
Case "2"
lngTemp = (16 ^ (Ctr - 1)) * 2 + lngTemp
Case "3"
lngTemp = (16 ^ (Ctr - 1)) * 3 + lngTemp
Case "4"
lngTemp = (16 ^ (Ctr - 1)) * 4 + lngTemp
Case "5"
lngTemp = (1616 ^ (Ctr - 1)) * 5 + lngTemp
Case "6"
lngTemp = (16 ^ (Ctr - 1)) * 6 + lngTemp
Case "7"
lngTemp = (16 ^ (Ctr - 1)) * 7 + lngTemp
Case "8"
lngTemp = (16 ^ (Ctr - 1)) * 8 + lngTemp
Case "9"
lngTemp = (16 ^ (Ctr - 1)) * 9 + lngTemp
Case "A"
lngTemp = (16 ^ (Ctr - 1)) * 10 + lngTemp
Case "B"
lngTemp = (16 ^ (Ctr - 1)) * 11 + lngTemp
Case "C"
lngTemp = (16 ^ (Ctr - 1)) * 12 + lngTemp
Case "D"
lngTemp = (16 ^ (Ctr - 1)) * 13 + lngTemp
Case "E"
lngTemp = (16 ^ (Ctr - 1)) * 14 + lngTemp
Case "F"
lngTemp = (16 ^ (Ctr - 1)) * 15 + lngTemp
Case Else
End Select
Next
HexToDec = lngTemp
End Function
'---------------------------------------------------------------------------------------------------------------
Convierte un número hexadecimal a una cadena de "texto"
Function HexToStr(HexStr As String) As String
Dim nCtr As Long
Dim nCount As Long
Dim tmpBuffer As String
Dim tmpBuffer1 As String
Dim tmpChar As String
Trim (HexStr)
For nCtr = 1 To Len(HexStr)
tmpChar = Mid(HexStr, nCtr, 1)
If Not tmpChar = " " Then
tmpBuffer = tmpBuffer & tmpChar
tmpChar = ""
End If
Next
nCount = Len(tmpBuffer)
If Not (nCount Mod 2) = 0 Then Exit Function
For nCtr = 1 To nCount Step 2
tmpBuffer1 = tmpBuffer1 & Chr(HexToDec(Mid(tmpBuffer, nCtr, 2)))
Next
HexToStr = tmpBuffer1
End Function
'-----------------------------------------------------------------------------------------------------------------------------
Volver a 'Documentos' - Ir al inicio