Principal.bas

   1 Attribute VB_Name = "Principal"
   2 'Programado por Vlad para SVCommunity.org y TodoSV.com
   3 'Este código no tiene licencia que lo proteja, uselo a su voluntad.
   4 Option Explicit
   5 Private Declare Function ShellExecute _
   6                 Lib "shell32.dll" _
   7                 Alias "ShellExecuteA" (ByVal hwnd As Long, _
   8                                        ByVal lpOperation As String, _
   9                                        ByVal lpFile As String, _
  10                                        ByVal lpParameters As String, _
  11                                        ByVal lpDirectory As String, _
  12                                        ByVal nShowCmd As Long) As Long
  13 Private Type tipo_Marcas
  14     desCorta As String
  15     desLarga As String
  16     Extension As String
  17     PluginAsociado As String
  18     dirWeb As String
  19     ProgamaAsociado As String
  20 End Type
  21 Private Const iden_desCorta As String = "desCorta"
  22 Private Const iden_desLarga As String = "desLarga"
  23 Private Const iden_Extension As String = "Extension"
  24 Private Const iden_PluginAsociado As String = "PluginAsociado"
  25 Private Const iden_dirWeb As String = "dirWeb"
  26 Private Const iden_ProgamaAsociado As String = "ProgamaAsociado"
  27 Private buff_Marcas As New Collection
  28 Private buff_MarcasEx As tipo_Marcas
  29 Private Ruta_INI As String
  30 Private Bandera_Marca_Encontrada As Boolean
  31 Public Type tIdentificar
  32     sArchivo As String
  33     Salida As String
  34 End Type
  35 Public sIdentificar As tIdentificar
  36 'Soporte Archivo
  37 Public Archivo As String
  38 'Soporte RegEx
  39 Public objRegExp As New RegExp
  40 'Control de salida
  41 Public Mostrar_HexDump As Boolean
  42 Public Mostrar_AscDump As Boolean
  43 Public Ofrecer_Ejecucion As Boolean
  44 Public Mostrar_Coincidencia As Boolean
  45
  46 Public Sub Main()
  47         '<EhHeader>
  48         On Error GoTo Main_Err
  49         '</EhHeader>
  50         Dim Canal As Byte
  51 100     Ruta_INI = App.Path & "\marcas.ini"
  52 101     Set buff_Marcas = mINI_Obtener_Nombre_Secciones(Ruta_INI)
  53
  54 102     If Len(Command$) = 0 Then
  55 103         frmPrincipal.Show
  56             Exit Sub
  57         End If
  58
  59 104     Archivo = Command$
  60 105     Archivo = Replace$(Archivo, """", "")
  61 107     sIdentificar = Identificar(Archivo)
  62 108     Canal = FreeFile
  63 109     Open App.Path & IO_Titulo_de_Archivo(sIdentificar.sArchivo) & ".resultado.txt" For Binary Access Write As #Canal
  64 110     Put #Canal, , sIdentificar.Salida
  65 111     Close Canal
  66         '<EhFooter>
  67         Exit Sub
  68
  69 Main_Err:
  70         Controlar_Error Erl, Err.Description, "P10XB.Principal.Main.Ref 7/6/2008 : 13:03:02"
  71         Resume Next
  72         '</EhFooter>
  73 End Sub
  74
  75 Private Function Convertir_Caracteres(ByVal Texto As String) As String
  76         '<EhHeader>
  77         On Error GoTo Convertir_Caracteres_Err
  78         '</EhHeader>
  79         Dim i As Integer
  80         Dim f As Integer
  81 100     f = Len(Texto)
  82
  83 101     For i = 1 To f
  84 102         Convertir_Caracteres = Convertir_Caracteres & Right$("00" & Hex$(Asc(Mid$(Texto, i, 1))), 2)
  85         Next
  86
  87         '<EhFooter>
  88         Exit Function
  89 Convertir_Caracteres_Err:
  90         Controlar_Error Erl, Err.Description, "P10XB.Principal.Convertir_Caracteres.Ref 7/6/2008 : 11:57:57"
  91         Resume Next
  92         '</EhFooter>
  93 End Function
  94
  95 Public Sub Controlar_Error(ByRef nErl As Long, _
  96                            ByRef Descripcion As String, _
  97                            Donde As String)
  98     'CSEH: Skip
  99     Dim X_Err As Byte
 100 2   X_Err = MsgBox("El siguiente error se produjo: " & vbNewLine & Descripcion & vbNewLine & "En el módulo: " & Donde & ", en la linea " & nErl & vbCrLf & "El programa puede estar inestable, sin embargo puede continuar, ¿desea hacerlo? ([SI] continúa, [NO] termina el programa)", vbYesNo + vbCritical)
 101     On Error Resume Next
 102
 103 5   Select Case X_Err
 104
 105         Case Is = vbYes
 106
 107 6       Case Is = vbNo
 108 8           End
 109     End Select
 110
 111 End Sub
 112
 113 Public Function Comparar_Marca(ByVal Texto As String) As String
 114         '<EhHeader>
 115         On Error GoTo Comparar_Marca_Err
 116         '</EhHeader>
 117         Dim i As Long
 118         Dim Resultado As String
 119
 120 100     For i = 1 To buff_Marcas.Count
 121 101         Resultado = RegEx(buff_Marcas.Item(i), Texto)
 122
 123 102         If Resultado <> "" Then
 124 103             Debug.Print Resultado
 125 104             Cargar_datos_marcas i
 126 105             Comparar_Marca = "Coincide con la marca de un archivo del tipo:" & vbNewLine & buff_MarcasEx.desCorta & " (" & buff_MarcasEx.Extension & ")" & vbNewLine & vbNewLine & "Se describe como:" & vbNewLine & buff_MarcasEx.desLarga & vbNewLine & vbNewLine & "Puedes encontrar más información en esta ubicación: " & buff_MarcasEx.dirWeb & vbNewLine & vbNewLine & "Puedes usar este (estos) programa(s) para abrir este tipo de archivo: " & vbNewLine & Replace$(buff_MarcasEx.ProgamaAsociado, "|", vbNewLine)
 127
 128 106             If Mostrar_Coincidencia Then Comparar_Marca = Comparar_Marca & vbNewLine & vbNewLine & "Detectado por: " & vbNewLine & Resultado
 129 107             Bandera_Marca_Encontrada = True
 130                 Exit Function
 131             End If
 132
 133         Next
 134
 135 108     Bandera_Marca_Encontrada = False
 136 109     buff_MarcasEx.desCorta = ""
 137 110     buff_MarcasEx.desLarga = ""
 138 111     buff_MarcasEx.dirWeb = ""
 139 112     buff_MarcasEx.Extension = ""
 140 113     buff_MarcasEx.PluginAsociado = ""
 141 114     buff_MarcasEx.ProgamaAsociado = ""
 142 115     Comparar_Marca = "Marca desconocida, por favor notifique a los creadores de este programa sobre este archivo."
 143         '<EhFooter>
 144         Exit Function
 145 Comparar_Marca_Err:
 146         Controlar_Error Erl, Err.Description, "P10XB.Principal.Comparar_Marca.Ref 7/6/2008 : 11:57:57"
 147         Resume Next
 148         '</EhFooter>
 149 End Function
 150
 151 Public Sub Cargar_datos_marcas(Posicion_en_Buff_Marcas As Long)
 152         '<EhHeader>
 153         On Error GoTo Cargar_datos_marcas_Err
 154         '</EhHeader>
 155 100     buff_MarcasEx.desCorta = mINI_Leer_Clave_de_Seccion(Ruta_INI, buff_Marcas.Item(Posicion_en_Buff_Marcas), iden_desCorta)
 156 101     buff_MarcasEx.desLarga = mINI_Leer_Clave_de_Seccion(Ruta_INI, buff_Marcas.Item(Posicion_en_Buff_Marcas), iden_desLarga)
 157 102     buff_MarcasEx.dirWeb = mINI_Leer_Clave_de_Seccion(Ruta_INI, buff_Marcas.Item(Posicion_en_Buff_Marcas), iden_dirWeb)
 158 103     buff_MarcasEx.Extension = mINI_Leer_Clave_de_Seccion(Ruta_INI, buff_Marcas.Item(Posicion_en_Buff_Marcas), iden_Extension)
 159 104     buff_MarcasEx.PluginAsociado = mINI_Leer_Clave_de_Seccion(Ruta_INI, buff_Marcas.Item(Posicion_en_Buff_Marcas), iden_PluginAsociado)
 160 105     buff_MarcasEx.ProgamaAsociado = mINI_Leer_Clave_de_Seccion(Ruta_INI, buff_Marcas.Item(Posicion_en_Buff_Marcas), iden_ProgamaAsociado)
 161         '<EhFooter>
 162         Exit Sub
 163 Cargar_datos_marcas_Err:
 164         Controlar_Error Erl, Err.Description, "P10XB.Principal.Cargar_datos_marcas.Ref 7/6/2008 : 11:57:57"
 165         Resume Next
 166         '</EhFooter>
 167 End Sub
 168
 169 Public Function Identificar(Archivo As String) As tIdentificar
 170         '<EhHeader>
 171         On Error GoTo Identificar_Err
 172         '</EhHeader>
 173         Dim Salida As String
 174         Dim Entrada As String
 175         Dim Marca As String
 176         Dim Canal As Byte
 177
 178         ' Verificar si existe el archivo.
 179 100     If Len(Dir$(Archivo)) = 0 Or Len(Archivo) = 0 Then
 180 101         Salida = "Error: El archivo no pudo abrirse: " & Archivo
 181 102         Archivo = "\error " & Hour(Time) & "." & Minute(Time) & ".txt"
 182         Else
 183
 184             ' Verificar si es un directorio.
 185 103         If GetAttr(Archivo) = vbDirectory Then
 186 104             Salida = "Error: Era un directio: " & Archivo
 187             Else
 188                 ' Ok es un archivo y existe.
 189 105             Canal = FreeFile
 190
 191 106             If FileLen(Archivo) < 10000 Then
 192 107                 Entrada = Space$(FileLen(Archivo))
 193                 Else
 194 108                 Entrada = Space$(1000)
 195                 End If
 196
 197 109             Open Archivo$ For Binary Access Read As #Canal
 198 110             Get #Canal, , Entrada
 199 111             Close Canal
 200                 'Convertir los 1000 bytes a HEX
 201 112             Marca = Convertir_Caracteres(Entrada)
 202                 'Comparar los 1000 bytes con todas las marcas.
 203 113             Salida = Comparar_Marca(Marca) & vbNewLine & vbNewLine
 204
 205 114             If Mostrar_AscDump Then Salida = Salida & "Muestra ASCII del archivo: " & vbNewLine & Entrada & vbNewLine & vbNewLine
 206 115             If Mostrar_HexDump Then Salida = Salida & "Muestra HEX del archivo: " & vbNewLine & Marca & vbNewLine & vbNewLine & vbNewLine
 207 116             Salida = Salida & "Archivo generado por P10XB @ SvCommunity.org & TodoSV.com"
 208
 209 117             If Bandera_Marca_Encontrada = True Then
 210                     Dim Extensiones() As String
 211
 212 118                 If RegEx(LCase(IO_Extension_de_Archivo(Archivo)), LCase(buff_MarcasEx.Extension)) = "" Then
 213 119                     If MsgBox("La extensión del archivo procesado es """ & IO_Extension_de_Archivo(Archivo) & """, no coincide con la que P10XB cree que es la correcta """ & buff_MarcasEx.Extension & """" & vbNewLine & "¿Quisiera que P10XB cambiara la extensión del archivo?", vbQuestion + vbYesNo, "Solicito acción del usuario") = vbYes Then
 214 120                         Name Archivo As Archivo & "." & buff_MarcasEx.Extension
 215 121                         Archivo = Archivo & "." & buff_MarcasEx.Extension
 216                         End If
 217                     End If
 218
 219                     'Soporte de Plugins
 220                     'Verificamos que el plugin exista:
 221 122                 If Len(buff_MarcasEx.PluginAsociado) <> 0 Then
 222                         Dim Plugin_Nombre
 223                         Dim Plugin_Parametros
 224 123                     Plugin_Nombre = Trim$(Replace(Left$(buff_MarcasEx.PluginAsociado, InStr(1, buff_MarcasEx.PluginAsociado, "$") - 1), ".\", App.Path & "\"))
 225 124                     Plugin_Parametros = Mid$(buff_MarcasEx.PluginAsociado, InStr(1, buff_MarcasEx.PluginAsociado, "$"))
 226 125                     Plugin_Parametros = Replace$(Plugin_Parametros, "$1", """" & Archivo & """")
 227
 228 126                     If Ofrecer_Ejecucion Then
 229 127                         If MsgBox("P10XB cree conocer el programa con el que el archivo puede abrirse. " & vbNewLine & "Se ejecutará el siguiente comando para intentarlo: " & vbNewLine & Plugin_Nombre & " " & Plugin_Parametros & vbNewLine & "¿Esta de acuerdo?", vbYesNo + vbQuestion) = vbYes Then
 230 128                             If Len(buff_MarcasEx.PluginAsociado) <> 0 Then ShellExecute 0, "Open", Plugin_Nombre, Plugin_Parametros, 0, 1
 231                             End If
 232                         End If
 233                     End If
 234                 End If
 235             End If
 236         End If
 237
 238 129     Identificar.Salida = Salida
 239 130     Identificar.sArchivo = Archivo
 240         '<EhFooter>
 241         Exit Function
 242 Identificar_Err:
 243         Controlar_Error Erl, Err.Description, "P10XB.Principal.Identificar.Ref 7/6/2008 : 12:11:59"
 244         Resume Next
 245         '</EhFooter>
 246 End Function
 247
 248 Public Function Escapar_TextBox(ByRef Texto As String) As String
 249         'Escapar los NULL
 250         '<EhHeader>
 251         On Error GoTo Escapar_TextBox_Err
 252         '</EhHeader>
 253 100     Texto = Replace$(Texto, Chr(0), "[0]")
 254 101     Escapar_TextBox = Texto
 255         '<EhFooter>
 256         Exit Function
 257 Escapar_TextBox_Err:
 258         Controlar_Error Erl, Err.Description, "P10XB.Principal.Escapar_TextBox.Ref 7/6/2008 : 11:57:57"
 259         Resume Next
 260         '</EhFooter>
 261 End Function
 262
 263 Function RegEx(myPattern As String, myString As String)
 264         '<EhHeader>
 265         On Error GoTo RegEx_Err
 266         '</EhHeader>
 267         Dim RetStr As String
 268         Dim objMatch As Match
 269         Dim colMatches As MatchCollection
 270         ' Set Case Insensitivity.
 271 100     objRegExp.IgnoreCase = True
 272         'Set global applicability.
 273 101     objRegExp.Global = True
 274         'Set the pattern by using the Pattern property.
 275 102     objRegExp.Pattern = myPattern
 276
 277         'Test whether the String can be compared.
 278 103     If (objRegExp.Test(myString) = True) Then
 279             'Get the matches.
 280 104         Set colMatches = objRegExp.Execute(myString)   ' Execute search.
 281
 282 105         For Each objMatch In colMatches   ' Iterate Matches collection.
 283 106             RetStr = RetStr & "Coincidencia encontrada en pos. "
 284 107             RetStr = RetStr & objMatch.FirstIndex & ". Valor de la coincidencia es "
 285 108             RetStr = RetStr & objMatch.Value & vbCrLf
 286             Next
 287
 288         Else
 289 109         RetStr = ""
 290         End If
 291
 292 110     RegEx = RetStr
 293         '<EhFooter>
 294         Exit Function
 295 RegEx_Err:
 296         Controlar_Error Erl, Err.Description, "P10XB.Principal.RegEx.Ref 7/6/2008 : 11:57:57"
 297         Resume Next
 298         '</EhFooter>
 299 End Function