Esta "utilidad" sirve
para colorear las instrucciones, los comentarios e incluso el
texto entrecomillado de código de Visual Basic, (también de
vb.Net, c# y C/C++), y generar el código HTML correspondiente,
(también permite guardarlo en un fichero).
La verdad es que no será mucha
gente la que necesite de una utilidad así, pero... yo voy a
empezar a usarla, ya que cuando pego el código a mostrar en una
página HTML, éste se muestra en el color predeterminado de la
página y luego si quiero colorear los comentarios, (que es lo
que he estado haciendo hasta hace poco), seleccionaba cada una de
las líneas de comnetarios, les asignaba el color verde y así
sucesivamente. Pero era cuando también quiero colorear cada una
de las instrucciones... en ese caso, tenía que seleccionar una
palabra, asignarle el color azul y así sucesivamente ¡con cada
una de las palabras clave del código!. Con esta utilidad, todo
ese trabajo tedioso se elimina.
Ahora lo único que hay que hacer es: seleccionar el fichero a
colorear, (también se puede colorear sólo una parte del
código), pulsar y botón y el código está coloreado...
Después sólo hay que abrir el fichero que lo contendrá, usando
un editor de textos, y pegarlo en la parte que queramos. No se
puede pegar directamente en un fichero abierto con un editor
HTML, ya que lo que se pegaría sería el código HTML que genera
los colores...
La utilidad está basado en
un código que hice originalmente con la versión
Beta1 de Visual Basic.Net
y la he adaptado a Visual Basic 6.
En esta versión para VB6 he añadido
Drag & Drop
para poder arrastrar ficheros a ciertas partes del programa y
asignar automáticamente los ficheros soltados donde
corresponda...
Te muestro el código completo
de la utilidad, incluidas las clases usadas, con la esperanza de
que alguna parte de éste código te pudiera servir de algo.
Una lista de cosas que
te pueden interesar:
La clase cFileToArray tiene métodos que te permiten hacer lo
siguiente:
- Devuelve una cadena con el
contenido de un fichero, cada linea separada con CrLf
- Devuelve un array con el
contenido de un fichero
- Guarda el contenido de un
array en un fichero
- Guarda el contenido de una
cadena en un fichero
- Insertar una cadena en un
array, tanto al principio como al final
- Comprueba si existe un
fichero
La clase cComDlg implementa una versión reducida del
control de diálogos comunes, (sólo ShowOpen y ShowSave). A
diferencia del control, estos dos métodos devuelven True o
False, según se pulse en los botones Aceptar o Cancelar
respectivamente, (realmente no hay un botón Aceptar, sino uno de
Abrir o Guardar, según se elija ShowOpen o ShowSave).
También tiene una función que permite usar el cuadro de
diálogo de seleccionar directorios e incluso seleccionar
ficheros, (si así se indica en el parámetro), el resultado de
dicha función será el directorio o fichero seleccionado o una
cadena vacia si se pulsa en Cancelar.
La clase cPalabrasFile implementa una colección de datos del
tipo cPalabra, permitiendo guardar el contenido de la
propiedad ID en un fichero, así como leerlos. También se pueden
leer y guardar el resto de las propiedades, (usando los métodos
destinados a ello).
Para esto último, he usado la clase
cIniArray ya que cada palabra
se guarda como una sección, y las claves y valores de cada sección son
los nombres de las propiedades y sus respectivos valores.
Espero que le saques algún
provecho a esta utilidad.
Nos vemos.
Guillermo
Link
al fichero con el código completo, así como un ejecutable compilado con el Service
Pack 4: gsHTMCodeColor1.zip (41.4KB)
También se incluyen los ficheros de palabras clave para Visual
Basic, VB.Net y C/C++/c#
Los listados.
El
listado del formulario:
'------------------------------------------------------------------------------
' Procesar un fichero de código (03/Abr/01)
' y generar el código HTML coloreado para pegar en una página.
'
' Se pueden procesar ficheros de vb.Net y c#
'
' Basado en un código realizado en vb.Net
'
' ©Guillermo 'guille' Som, 2001
'------------------------------------------------------------------------------
'
Option Explicit ' Obliga a declarar todas las variables
Option Compare Text ' No hacer distinción en las cadenas
'
' Objetos (clases) usadas en el formulario
Private OFD As cComDlg ' Clase para diálogos comunes
Private mPalabras As cPalabrasFile ' Colección para las palabras clave
Private mFile As cFileToArray ' Clase para manejar ficheros...
'
Private mPalabrasModificadas As Boolean ' Si se modifican las palabras
'
Private LineaCompleta As String ' Variable para procesar cada palabra
'
' Constantes para el tipo de lenguaje (usadas en las opciones de lenguaje)
Private Enum eLenguaje
esVB
esCS
esHTM
End Enum
'
'------------------------------------------------------------------------------
' Constantes para los tags a añadir
'
' Color verde para los comentarios.
Const sTagFontGreen As String = "<font color = #008000>"
' Color azul de las palabras reservadas.
Const sTagFontBlue As String = "<font color = #0000FF>"
' Color cian para las cadenas de texto, no es estándard, pero queda bien.
Const sTagFontText As String = "<font color = #408080>"
Const sEndFontTag As String = "</font>"
' Líneas a añadir al código
Private sTagFontTipo As String
Const sEndFontTipo As String = "</font></pre>"
' Constantes de algunos caracteres especiales: (31/Mar/01)
' Nota: no uso los caracteres que se pondrán, ya que de otra forma,
' si este código se convierte, no mostraría el código correcto.
Const sTagQuote As String = "quot;" ' comillas dobles
Const sTagLT As String = "lt;" ' signo menor que
Const sTagGT As String = "gt;" ' signo mayor que
Private Sub cmdAdd_Click()
' Añadir la palabra al ListBox y colección de palabras, (si es que no está)
Dim tPalabra As cPalabra
Dim sID As String
'
sID = txtWord.Text
If mPalabras.Exists(sID) = False Then
' Si no existe esa palabra, crear una nueva entrada en la colección
Set tPalabra = New cPalabra
tPalabra.ID = sID
mPalabras.Add tPalabra
lstWords.AddItem sID
' Indicador de que se han modificado las palabras
mPalabrasModificadas = True
End If
End Sub
Private Sub cmdBrowseTo_Click()
' Seleccionar el fichero en el que se guardará el código convertido
With OFD
.hWnd = Me.hWnd
.DialogTitle = "Seleccionar el fichero de destino"
.Filter = "Fichero HTML|*.htm;*.html|Todos los ficheros (*.*)|*.*"
If .ShowSave Then
txtFileTo.Text = .FileName
End If
End With
End Sub
Private Sub cmdDel_Click()
' Eliminar los elementos seleccionados del ListBox
Dim i As Long
Dim n As Long
Dim sID As String
'
' El elemento que estaba seleccionado
n = lstWords.ListIndex
'
' Recorrer todos los elementos seleccionados
For i = lstWords.ListCount - 1 To 0 Step -1
' Si está seleccionado
If lstWords.Selected(i) Then
' Obtener el ID de la colección de palabras
sID = lstWords.List(i)
' borrarla de la colección
mPalabras.Remove sID
' borrar este índice del ListBox
lstWords.RemoveItem i
End If
Next
' Indicar que se han modificado las palabras
mPalabrasModificadas = True
'
' Seleccionar el elemento que antes estaba seleccionado
If n > lstWords.ListCount - 1 Then
n = lstWords.ListCount - 1
End If
lstWords.ListIndex = n
End Sub
Private Sub cmdBrowseFP_Click(Index As Integer)
' Seleccionar el fichero de palabras del lenguaje a usar
With OFD
.hWnd = Me.hWnd
.DialogTitle = "Seleccionar el fichero del lenguaje"
' Asignar el fichero y nombre del lenguaje seleccionado
' según el botón pulsado
If Index = esVB Then
.FileName = txtFP(esVB).Text
rbFP(esVB).Value = True
ElseIf Index = esCS Then
.FileName = txtFP(esCS).Text
rbFP(esCS).Value = True
ElseIf Index = esHTM Then
.FileName = txtFP(esHTM).Text
rbFP(esHTM).Value = True
End If
.Filter = "Ficheros de texto (*.txt)|*.txt|Todos los ficheros (*.*)|*.*"
If .ShowOpen Then
' Asignar el nombre según el lenguaje seleccionado
If rbFP(esVB).Value = True Then
txtFP(esVB).Text = .FileName
ElseIf rbFP(esCS).Value = True Then
txtFP(esCS).Text = .FileName
ElseIf rbFP(esHTM).Value = True Then
txtFP(esHTM).Text = .FileName
End If
End If
End With
End Sub
Private Sub cmdBrowseFrom_Click()
' Seleccionar el fichero de origen
With OFD
.hWnd = Me.hWnd
.DialogTitle = "Seleccionar el fichero de código a procesar"
.Filter = "Ficheros .NET|*.vb;*.cs|Visual Basic|*.vb;*.bas;*.frm;*.cls;*.ctl|Ficheros de c# y C/C++|*.cs;*.c;*.h;*.cpp;*.hpp|Ficheros HTML|*.ht*|Todos los ficheros (*.*)|*.*"
'
' Seleccionar el tipo de ficheros, según el lenguaje seleccionado
If rbFP(esVB).Value = True Then
.FilterIndex = 2
ElseIf rbFP(esCS).Value = True Then
.FilterIndex = 3
ElseIf rbFP(esHTM).Value = True Then
.FilterIndex = 4
End If
'
If .ShowOpen Then
txtFileFrom.Text = .FileName
' Mostrar el fichero en el TextBox
txtCode.Text = mFile.StringFromFile(.FileName)
End If
End With
End Sub
Private Sub cmdExit_Click()
' Salir
Unload Me
End Sub
Private Sub cmdOpen_Click()
' Leer el fichero con las palabras
With OFD
.hWnd = Me.hWnd
.DialogTitle = "Seleccionar el fichero del lenguaje"
' Asignar el fichero según el lenguaje seleccionado
If rbFP(esVB).Value = True Then
.FileName = txtFP(esVB).Text
ElseIf rbFP(esCS).Value = True Then
.FileName = txtFP(esCS).Text
ElseIf rbFP(esHTM).Value = True Then
.FileName = txtFP(esHTM).Text
End If
'
.Filter = "Ficheros de texto (*.txt)|*.txt|Todos los ficheros (*.*)|*.*"
If .ShowOpen Then
' Leer el fichero de palabras y asignarlas al ListBox
LeerPalabras .FileName
End If
End With
End Sub
Private Sub cmdProcessFile_Click()
' Procesar el contenido del fichero de origen
' y guardarlo en el fichero de destino
Dim s As String
'
' Si no se especifica el fichero de origen o destino...
If Len(Trim$(txtFileFrom.Text)) = 0 Then
MsgBox "Debes seleccionar el fichero de origen.", vbInformation, "Procesar Fichero"
cmdBrowseFrom.SetFocus
Exit Sub
End If
'
If Len(Trim$(txtFileTo.Text)) = 0 Then
MsgBox "Debes seleccionar el fichero de destino.", vbInformation, "Procesar Fichero"
cmdBrowseTo.SetFocus
Exit Sub
End If
'
' Leer el fichero de origen, procesarlo y guardarlo en el de destino
s = mFile.StringFromFile(txtFileFrom.Text)
s = ProcesarFichero(s)
' Guardar el contenido en el fichero indicado
Call mFile.WriteStringToFile(txtFileTo.Text, s)
End Sub
Private Sub cmdProcessText_Click()
' Procesar el contenido del TextBox
'
txtCode.Text = ProcesarFichero(txtCode.Text)
' Copiarlo en el portapapeles
Clipboard.SetText txtCode.Text
End Sub
Private Sub cmdSave_Click()
' Guardar las palabras en el fichero indicado
With OFD
.hWnd = Me.hWnd
.DialogTitle = "Seleccionar el fichero en el que se guardarán las palabras"
.Filter = "Ficheros de texto (*.txt)|*.txt|Todos los ficheros (*.*)|*.*"
If .ShowSave Then
' Copiar las palabras del ListBox (que ya está clasificado)
Dim i As Long
Dim tPalabra As cPalabra
'
mPalabras.Clear
For i = 0 To lstWords.ListCount - 1
Set tPalabra = New cPalabra
tPalabra.ID = lstWords.List(i)
mPalabras.Add tPalabra
Next
' Guardar el contenido de mPalabras en el fichero
mPalabras.SaveIDsToFile .FileName
'
mPalabrasModificadas = False
End If
End With
End Sub
Private Sub Form_Load()
' Crear una instancia de los objetos (clases)
Set OFD = New cComDlg
Set mPalabras = New cPalabrasFile
Set mFile = New cFileToArray
'
' Centrar a lo ancho de la pantalla
Move (Screen.Width - Width) \ 2, -30
'
' Asignar el tipo de fuente a usar (para añadir al principio del fichero)
sTagFontTipo = "<pre><font face=" & Chr$(34) & "Courier New" & Chr$(34) & " size=2>"
'
' Un poco de limpieza
txtFileFrom.Text = ""
txtFileTo.Text = ""
txtWord.Text = ""
lstWords.Clear
txtCode.Text = ""
'
' Crear y asignar los captions al TabStrip
With Me.TabStrip1
.Tabs(1).Caption = "Colorear código"
.Tabs.Add , , "Palabras clave"
End With
Frame1(0).ZOrder
'
' Leer las preferencias
Dim FileName As String
Dim boolVal As Boolean
'
' Si se debe leer el fichero al iniciar el programa
boolVal = CBool(GetSetting("gsHTMColorCode", "Ficheros", "Cargar al iniciar", "0"))
If boolVal Then
chkFP.Value = vbChecked
Else
chkFP.Value = vbUnchecked
End If
' Fichero con las palabras a usar, si se carga al iniciar el programa
FileName = GetSetting("gsHTMColorCode", "Ficheros", "Palabras", "")
'
If chkFP.Value = vbChecked Then
If mFile.FileExists(FileName) Then
' Leer el fichero de palabras y asignarlas al ListBox
LeerPalabras FileName
End If
End If
'
' Si se debe colorear también las cadenas de texto
boolVal = CBool(GetSetting("gsHTMColorCode", "Ficheros", "Colorear textos", "1"))
If boolVal Then
chkTextColor.Value = vbChecked
Else
chkTextColor.Value = vbUnchecked
End If
'
'--------------------------------------------------------------------------
' Estos valores no tienen preferencia sobre el lenguaje indicado al cargar,
' aunque el fichero que se usa al iniciar el programa, es el del lenguaje
' que estaba seleccionado cuando se cerró por última vez.
'--------------------------------------------------------------------------
'
' Asignar los valores de la opción del lenguaje seleccionado
rbFP(esVB).Value = CBool(GetSetting("gsHTMColorCode", "Ficheros", "rbVB", "1"))
rbFP(esCS).Value = CBool(GetSetting("gsHTMColorCode", "Ficheros", "rbCS", "0"))
rbFP(esHTM).Value = CBool(GetSetting("gsHTMColorCode", "Ficheros", "rbHTM", "0"))
'
' Leer los nombres de los ficheros de palabras clave
txtFP(esVB).Text = GetSetting("gsHTMColorCode", "Ficheros", "vb", AppPath & "vbasic.txt")
txtFP(esCS).Text = GetSetting("gsHTMColorCode", "Ficheros", "cs", AppPath & "csharp.txt")
txtFP(esHTM).Text = GetSetting("gsHTMColorCode", "Ficheros", "HTM", AppPath & "html.txt")
'
' Deshabilitar los valores de HTML, ya que no está implementado
rbFP(esHTM).Enabled = False
txtFP(esHTM).Enabled = False
cmdBrowseFP(esHTM).Enabled = False
'
End Sub
Private Sub Form_QueryUnload(Cancel As Integer, UnloadMode As Integer)
' Cuando se vaya a cerrar, comprobar si hay que guardar las palabras
If mPalabrasModificadas = True Then
' Preguntar si se quiere guardar
If MsgBox("Se ha modificado la lista de palabras" & Chr(13) & "¿Quieres guardarlas?", "Palabras modificadas", vbYesNo + vbQuestion) = vbYes Then
cmdSave_Click
End If
End If
'
' Guardar las configuraciones
Call SaveSetting("gsHTMColorCode", "Ficheros", "Cargar al iniciar", CStr(chkFP.Value))
Call SaveSetting("gsHTMColorCode", "Ficheros", "Colorear textos", CStr(chkTextColor.Value))
'
' El nombre del fichero a usar al iniciar será el del lenguaje seleccionado
If rbFP(esVB).Value = True Then
Call SaveSetting("gsHTMColorCode", "Ficheros", "Palabras", txtFP(esVB).Text)
ElseIf rbFP(esCS).Value = True Then
Call SaveSetting("gsHTMColorCode", "Ficheros", "Palabras", txtFP(esCS).Text)
ElseIf rbFP(esHTM).Value = True Then
Call SaveSetting("gsHTMColorCode", "Ficheros", "Palabras", txtFP(esHTM).Text)
End If
'
' Guardar las configuración de los ficheros de lenguaje
Call SaveSetting("gsHTMColorCode", "Ficheros", "rbVB", CStr(rbFP(esVB).Value))
Call SaveSetting("gsHTMColorCode", "Ficheros", "rbCS", CStr(rbFP(esCS).Value))
Call SaveSetting("gsHTMColorCode", "Ficheros", "rbHTM", CStr(rbFP(esHTM).Value))
'
Call SaveSetting("gsHTMColorCode", "Ficheros", "vb", txtFP(esVB).Text)
Call SaveSetting("gsHTMColorCode", "Ficheros", "cs", txtFP(esCS).Text)
Call SaveSetting("gsHTMColorCode", "Ficheros", "HTM", txtFP(esHTM).Text)
End Sub
Private Sub Form_Unload(Cancel As Integer)
' Eliminar las referencias a los objetos usados
Set OFD = Nothing
Set mPalabras = Nothing
Set mFile = Nothing
'
Set fColorCode = Nothing
End Sub
Private Sub lstWords_Click()
' Al seleccionar una palabra del ListBox, mostrarla
Dim i As Long
'
With lstWords
i = .ListIndex
If i > -1 Then
txtWord.Text = .List(i)
End If
End With
End Sub
Private Sub lstWords_KeyDown(KeyCode As Integer, Shift As Integer)
' Si se pulsa la tecla Supr (Del), borrar los elementos seleccionados
If KeyCode = vbKeyDelete Then
cmdDel_Click
End If
End Sub
Private Sub TabStrip1_Click()
Dim i As Long
i = TabStrip1.SelectedItem.Index - 1
Frame1(i).ZOrder
End Sub
Private Function AppPath() As String
If Right$(App.Path, 1) <> "\" Then
AppPath = App.Path & "\"
Else
AppPath = App.Path
End If
End Function
Private Function CadaPalabra(Optional ByVal sLinea As String = "") As String
' Desglosar la línea en palabras
' Si se indica el parámetro, se devolverá la primera palabra.
' Si no se indica el parámetro se devolverán las siguientes.
' Si no hay más palabras, devuelve una cadena vacia.
'
Dim i As Long, j As Long, k As Long
Dim s As String, c As String, sID As String
'
Dim sSep As String
' Estos signos se considerarán separadores de palabras
sSep = " .,;:()<>[]{}'/*" & Chr$(34) & Chr$(9)
'
If sLinea <> "" Then
LineaCompleta = sLinea
End If
If LineaCompleta = "" Then
CadaPalabra = ""
Exit Function
End If
'
s = LineaCompleta
'
' Desglosar en palabras
sID = ""
j = Len(s)
For i = 1 To j
c = Mid$(s, i, 1)
If c = "" Then
k = 0
Else
k = InStr(sSep, c)
End If
If k = 0 And i = j Then
k = 1
sID = sID & c
End If
If k > 0 Or i = j Then
' Se ha encontrado una palabra
If i < j Then
If i = 1 Then
LineaCompleta = Mid$(s, i + 1)
Else
LineaCompleta = Mid$(s, i)
End If
Else
If LineaCompleta = c Then
LineaCompleta = ""
ElseIf LineaCompleta <> sID Then
LineaCompleta = Mid$(s, i)
Else
LineaCompleta = ""
End If
End If
If sID = "" Then
' Comprobar si es < o >
' y cambiarlo por el tag correspondiente
If c = "<" Then
c = "&" & sTagLT
ElseIf c = ">" Then
c = "&" & sTagGT
End If
sID = c
End If
Exit For
Else
sID = sID & c
End If
Next
CadaPalabra = sID
End Function
Private Function ProcesarFichero(ByVal sCodigo As String) As String
' Procesar el contenido de la cadena pasada y convertirlo a HTM
Dim i As Long, j As Long
Dim s, s2, sID As String
Dim HayComillas As Boolean
Dim HayRem As Boolean
Dim saCodigo() As String
'
Dim HayMultipleRem As Boolean
Dim k As Long
'
If mPalabras.Count = 0 Then
MsgBox "¡ATENCION! debes seleccionar el fichero de palabras clave."
' Seleccionar la segunda solapa, para mostrar la lista de palabras
TabStrip1.Tabs(2).Selected = True
' Seleccionar el botón de abrir
cmdOpen.SetFocus
Exit Function
End If
'
lblStatus.Caption = " Procesando código..."
lblStatus.Refresh
'
saCodigo = Split(sCodigo, vbCrLf)
'
j = UBound(saCodigo) '- 1
For i = 0 To j
s = saCodigo(i)
s2 = Trim(s)
' Si es una línea vacia
If s2 = "" Then
saCodigo(i) = s
ElseIf Left$(s2, 1) = "'" Then
' Si es una línea con comentarios
saCodigo(i) = sTagFontGreen & s & sEndFontTag
Else
' Tomar la primera palabra
s2 = s
sID = CadaPalabra(s2)
s = ""
' Mientras no sea una cadena vacía
Do While sID <> ""
If sID = Chr$(34) Then
' Convertirlo en el tag de comillas (31/Mar/01)
sID = "&" & sTagQuote
If HayComillas Then
If chkTextColor.Value = vbChecked Then
s = s & sID & sEndFontTag
Else
s = s & sID
End If
HayComillas = False
Else
HayComillas = True
If chkTextColor.Value = vbChecked Then
s = s & sTagFontText & sID
Else
s = s & sID
End If
End If
ElseIf HayComillas = True Or HayRem = True Then
' No interpretar lo que haya entre comillas (31/Mar/01)
' Ni lo que esté en un comentario (03/Abr/01)
s = s & sID
ElseIf rbFP(esVB).Value = True And (sID = "'" And HayRem = False) Then
s = s & sTagFontGreen & sID
HayRem = True
ElseIf mPalabras.Exists(sID) And HayComillas = False Then
' Si está en la colección de palabras clave
s = s & sTagFontBlue & sID & sEndFontTag
Else
s = s & sID
End If
sID = CadaPalabra()
Loop
If HayComillas Then
If chkTextColor.Value = vbChecked Then
s = s & Chr$(34) & sEndFontTag
Else
s = s & Chr$(34)
End If
HayComillas = False
End If
'
' Si se está procesando un fichero de C (c#, C/C++)
If rbFP(esCS).Value = True Then
' Comprobar si hay comentarios de c# o C/C++
'
' Comprobar si hay un comentario múltiple
k = InStr(s, "/*")
If k > 0 Then
HayMultipleRem = True
s = Left$(s, k - 1) & sTagFontGreen & Mid$(s, k)
End If
' Comprobar si hay un final de comentario mútiple
k = InStr(s, "*/")
If k > 0 Then
HayMultipleRem = False
s = Left$(s, k - 1) & sEndFontTag & Mid$(s, k)
End If
' Comprobar si hay un comentario de línea completa
k = InStr(s, "//")
If k > 0 Then
s = Left$(s, k) & sTagFontGreen & Mid$(s, k) & sEndFontTag
End If
'
If HayMultipleRem Then
s = sTagFontGreen & s & sEndFontTag
End If
'
End If
'
If HayRem Then
s = s & sEndFontTag
HayRem = False
End If
'
saCodigo(i) = s
End If
Next
' Convertir el array en una cadena
s = Join(saCodigo, vbCrLf)
'
' Añadir los Tags del tipo de letra
s = sTagFontTipo & vbCrLf & s
s = s & vbCrLf & sEndFontTipo
'
lblStatus.Caption = " Código convertido."
lblStatus.Refresh
' Devolver el texto procesado
ProcesarFichero = s
End Function
Private Sub Palabras2List()
Dim tPalabra As cPalabra
' Añadir al ListBox
With lstWords
.Clear
For Each tPalabra In mPalabras
.AddItem tPalabra.ID
Next
End With
mPalabrasModificadas = False
End Sub
Private Sub LeerPalabras(ByVal FileName As String)
' Leer las palabras del fichero indicado
mPalabras.Clear
mPalabras.ReadIDsFromFile FileName
'
' Añadir al ListBox
Palabras2List
End Sub
'------------------------------------------------------------------------------
' Los eventos OLEDragDrop, para asignar los ficheros soltados
'------------------------------------------------------------------------------
'
Private Sub cmdBrowseTo_OLEDragDrop(Data As DataObject, Effect As Long, Button As Integer, Shift As Integer, X As Single, Y As Single)
' Si se suelta un fichero en el botón del fichero de destino
txtFileTo.Text = Data.Files(1)
End Sub
Private Sub cmdBrowseFP_OLEDragDrop(Index As Integer, Data As DataObject, Effect As Long, Button As Integer, Shift As Integer, X As Single, Y As Single)
' Asignar el fichero del lenguaje, según donde se suelte el fichero
txtFP(Index) = Data.Files(1)
End Sub
Private Sub cmdBrowseFrom_OLEDragDrop(Data As DataObject, Effect As Long, Button As Integer, Shift As Integer, X As Single, Y As Single)
txtFileFrom.Text = Data.Files(1)
End Sub
Private Sub Frame1_OLEDragDrop(Index As Integer, Data As DataObject, Effect As Long, Button As Integer, Shift As Integer, X As Single, Y As Single)
If Index = 0 Then
txtFileFrom.Text = Data.Files(1)
Else
' Leer el fichero de palabras y asignarlas al ListBox
LeerPalabras Data.Files(1)
End If
End Sub
Private Sub Label1_OLEDragDrop(Index As Integer, Data As DataObject, Effect As Long, Button As Integer, Shift As Integer, X As Single, Y As Single)
If Index = 0 Then
txtFileFrom.Text = Data.Files(1)
ElseIf Index = 1 Then
txtFileTo.Text = Data.Files(1)
End If
End Sub
Private Sub lstWords_OLEDragDrop(Data As DataObject, Effect As Long, Button As Integer, Shift As Integer, X As Single, Y As Single)
' Leer el fichero de palabras y asignarlas al ListBox
LeerPalabras Data.Files(1)
End Sub
Private Sub rbFP_OLEDragDrop(Index As Integer, Data As DataObject, Effect As Long, Button As Integer, Shift As Integer, X As Single, Y As Single)
txtFP(Index) = Data.Files(1)
End Sub
Private Sub txtCode_OLEDragDrop(Data As DataObject, Effect As Long, Button As Integer, Shift As Integer, X As Single, Y As Single)
' Asignar al textBox el fichero soltado
Dim FileName As String
'
FileName = Data.Files(1)
txtCode.Text = mFile.StringFromFile(FileName)
End Sub
Private Sub txtFileFrom_OLEDragDrop(Data As DataObject, Effect As Long, Button As Integer, Shift As Integer, X As Single, Y As Single)
txtFileFrom.Text = Data.Files(1)
End Sub
Private Sub txtFileTo_OLEDragDrop(Data As DataObject, Effect As Long, Button As Integer, Shift As Integer, X As Single, Y As Single)
txtFileTo.Text = Data.Files(1)
End Sub
Private Sub txtFP_OLEDragDrop(Index As Integer, Data As DataObject, Effect As Long, Button As Integer, Shift As Integer, X As Single, Y As Single)
txtFP(Index) = Data.Files(1)
End Sub
El
listado de la clase cFileToArray:
'------------------------------------------------------------------------------
' Clase para leer de un fichero y convertirlo en un array (03/Abr/01)
'
' Esta clase permite leer de un fichero y devolver:
' -Devuelve una cadena con el contenido de un fichero,
' cada linea separada con CrLf
' -Devuelve un array con el contenido de un fichero
' -Guarda el contenido de un array en un fichero
' -Guarda el contenido de una cadena en un fichero
' -Insertar una cadena en un array, tanto al principio como al final
' -Comprueba si existe un fichero
'
' ©Guillermo 'guille' Som, 2001
'------------------------------------------------------------------------------
'
Option Explicit
Public Function InsertAtStart(ByRef StrArray() As String, ByVal sLine As String) As String()
' Insertar la cadena indicada al principio del array
Dim i As Long
Dim j As Long
Dim tmpArray() As String ' Array temporal
'
j = UBound(StrArray)
ReDim tmpArray(j + 1)
For i = 0 To j
tmpArray(i + 1) = StrArray(i)
Next
tmpArray(0) = sLine
' Copiar el array en el indicado, por si quiere usar como Sub
StrArray = tmpArray
' Devolver el array generado
InsertAtStart = tmpArray
End Function
Public Function InsertAtEnd(ByRef StrArray() As String, ByVal sLine As String) As String()
' Insertar la cadena indicada al final del array
Dim j As Long
Dim tmpArray() As String
'
j = UBound(StrArray)
tmpArray = StrArray
ReDim Preserve tmpArray(j + 1)
tmpArray(j + 1) = sLine
' Copiar el array en el indicado, por si quiere usar como Sub
StrArray = tmpArray
' Devolver el array generado
InsertAtEnd = tmpArray
End Function
Public Function StringFromFile(ByVal FileName As String) As String
' Leer el fichero indicado y devolver una cadena con el contenido
Dim n As Long
Dim s As String
Dim nFile As Long
'
' Si no se especifica el fichero, salir
If Len(FileName) = 0 Then
Exit Function
End If
'
If FileExists(FileName) Then
nFile = FreeFile
Open FileName For Input Shared As nFile
' El número de caracteres
n = LOF(nFile)
' Leemos todo el fichero
s = Input$(n, nFile)
'
Close
End If
' Devolver la cadena
StringFromFile = s
End Function
Public Function StringArrayFromFile(ByVal FileName As String) As String()
' Leer el fichero indicado y devolver un array con cada línea
' Leer el contenido del fichero y guardarlo en el array indicado
Dim s As String
'
' Si no se especifica el fichero, salir
If Len(FileName) = 0 Then
Exit Function
End If
'
' Leemos el contenido del fichero
s = StringFromFile(FileName)
'
' Devolver el array
StringArrayFromFile = Split(s, vbCrLf)
End Function
Public Sub WriteStringToFile(ByVal FileName As String, ByVal sString As String)
' Guarda en FileName el contenido de la cadena
Dim i As Long
Dim nFile As Long
'
' Si no se especifica el fichero, salir
If Len(FileName) = 0 Then
Exit Sub
End If
'
' Si existe, borrarlo
If FileExists(FileName) Then
Kill FileName
End If
nFile = FreeFile
Open FileName For Output As nFile
Print #nFile, sString
Close
End Sub
Public Sub WriteArrayToFile(ByVal FileName As String, ByRef sFileArray() As String)
' Guarda en FileName el contenido del array indicado
Dim s As String
Dim nFile As Long
'
' Si no se especifica el fichero, salir
If Len(FileName) = 0 Then
Exit Sub
End If
'
' Convertimos el array en una cadena, usando CrLf como separador
s = Join(sFileArray, vbCrLf)
'
nFile = FreeFile
Open FileName For Output As nFile
Print #nFile, s
Close
End Sub
Public Function FileExists(ByVal FileName As String) As Boolean
' Devuelve True si el fichero existe
' False si no existe o da error el acceso
Dim i As Long
'
If Len(FileName) = 0 Then
FileExists = False
Exit Function
End If
'
On Error Resume Next
'
i = Len(Dir$(FileName))
If Err Then
Err = 0
i = 0
End If
'
If i = 0 Then
FileExists = False
Else
FileExists = True
End If
End Function
El
listado de la clase cComDlg (diálogos comunes y más):
'------------------------------------------------------------------------------
' cComDlg Clase para simular el control de Diálogos Comunes
' Sólo tiene las opciones de Abrir y Guardar (como estra: BrowseForFolder)
'
' Primera tentativa: (04:57 25/Ago/1997)
'
' Versión reducida, sólo Abrir (10:20 18/Sep/1997)
' Versión reducida Diálogos de Abrir y Guardar (21/Oct/1997)
' Con BrowseForFolder (01:20 04/Dic/2000)
'
' Revisada para Windows 2000 (15:12 27/Dic/2000)
'
' ©Guillermo 'guille' Som, 1997-2001
'------------------------------------------------------------------------------
Option Explicit
Private sFilter As String
Private tmp_sFilter As String
' Esta propiedad hará referencia al hWnd de un Form
Public hWnd As Long
' Propiedades genéricas de los diálogos comunes
Public DialogTitle As String
Public CancelError As Boolean
Public Flags As eOFN 'Long
' Propiedades para Abrir y Guardar como
Public DefaultExt As String
Public FileName As String
Public FileTitle As String
Public FilterIndex As Long
Public InitDir As String
'Public MaxFileSize As Long (será 260)
'----------------------------------------------------------------------------
' Estructura de datos para Abrir y Guardar como...
'----------------------------------------------------------------------------
Private Type OPENFILENAME
lStructSize As Long
hwndOwner As Long
hInstance As Long
lpstrFilter As String
lpstrCustomFilter As String
nMaxCustFilter As Long
nFilterIndex As Long
lpstrFile As String
nMaxFile As Long
lpstrFileTitle As String
nMaxFileTitle As Long
lpstrInitialDir As String
lpstrTitle As String
Flags As Long
nFileOffset As Integer
nFileExtension As Integer
lpstrDefExt As String
lCustData As Long
lpfnHook As Long
lpTemplateName As String
End Type
Private Declare Function GetOpenFileName Lib "comdlg32.dll" Alias "GetOpenFileNameA" _
(pOpenFilename As OPENFILENAME) As Long
Private Declare Function GetSaveFileName Lib "comdlg32.dll" Alias "GetSaveFileNameA" _
(pOpenFilename As OPENFILENAME) As Long
'------------------------------------------------------------------------------
' Constantes para las funciones de archivos
Public Enum eOFN
' Tamaño máximo de un nombre de archivo (incluyendo el path)
MAX_PATH = 260
' Constantes para el diálogo de archivos
OFN_READONLY = &H1
OFN_OVERWRITEPROMPT = &H2
OFN_HIDEREADONLY = &H4
OFN_NOCHANGEDIR = &H8
OFN_SHOWHELP = &H10
OFN_ENABLEHOOK = &H20
OFN_ENABLETEMPLATE = &H40
OFN_ENABLETEMPLATEHANDLE = &H80
OFN_NOVALIDATE = &H100
OFN_ALLOWMULTISELECT = &H200
OFN_EXTENSIONDIFFERENT = &H400
OFN_PATHMUSTEXIST = &H800
OFN_FILEMUSTEXIST = &H1000
OFN_CREATEPROMPT = &H2000
OFN_SHAREAWARE = &H4000
OFN_NOREADONLYRETURN = &H8000
OFN_NOTESTFILECREATE = &H10000
OFN_NONETWORKBUTTON = &H20000
OFN_NOLONGNAMES = &H40000 ' force no long names for 4.x modules
OFN_EXPLORER = &H80000 ' new look commdlg
OFN_NODEREFERENCELINKS = &H100000
OFN_LONGNAMES = &H200000 ' force long names for 3.x modules
'
OFN_SHAREFALLTHROUGH = 2
OFN_SHARENOWARN = 1
OFN_SHAREWARN = 0
End Enum
'------------------------------------------------------------------------------
' Para la función BrowseForFolders (04/Dic/00)
'------------------------------------------------------------------------------
'
Public Enum eBIF
BIF_RETURNONLYFSDIRS = &H1 ' Sólo directorios del sistema
BIF_DONTGOBELOWDOMAIN = &H2 ' No incluir carpetas de red
BIF_STATUSTEXT = &H4 '
BIF_RETURNFSANCESTORS = &H8 '
BIF_BROWSEFORCOMPUTER = &H1000 ' Buscar PCs
BIF_BROWSEFORPRINTER = &H2000 ' Buscar impresoras
BIF_BROWSEINCLUDEFILES = &H4000& ' Incluir los ficheros (04/Abr/01)
' (esta constante no estaba asignada)
End Enum
' Valores para usar con pIDLRoot
'Public Enum ShellSpecialFolderConstants
' ssfDESKTOP = &H0
' ssfPROGRAMS = &H2
' ssfCONTROLS = &H3
' ssfPRINTERS = &H4
' ssfPERSONAL = &H5
' ssfFAVORITES = &H6
' ssfSTARTUP = &H7
' ssfRECENT = &H8
' ssfSENDTO = &H9
' ssfBITBUCKET = &HA
' ssfSTARTMENU = &HB
' ssfDESKTOPDIRECTORY = &H10
' ssfDRIVES = &H11
' ssfNETWORK = &H12
' ssfNETHOOD = &H13
' ssfFONTS = &H14
' ssfTEMPLATES = &H15
'End Enum
' Estructuras
Private Type SHFILEOPSTRUCT
hWnd As Long
wFunc As Long
pFrom As String
pTo As String
fFlags As Integer
fAnyOperationsAborted As Boolean
hNameMappings As Long
lpszProgressTitle As String
End Type
'Declaración de SHFILEOPSTRUCT
'typedef WORD FILEOP_FLAGS;
'
'typedef struct _SHFILEOPSTRUCTA
'{
' HWND hwnd;
' UINT wFunc;
' LPCSTR pFrom;
' LPCSTR pTo;
' FILEOP_FLAGS fFlags;
' BOOL fAnyOperationsAborted;
' LPVOID hNameMappings;
' LPCSTR lpszProgressTitle; // only used if FOF_SIMPLEPROGRESS
'} SHFILEOPSTRUCTA, FAR *LPSHFILEOPSTRUCTA;
'también me he encontrado con esta declaración:
'(pero después de comprobar cómo se declara en ShellApi.h...)
'Private Type SHFILEOPSTRUCT2
' hWnd As Long
' wFunc As Long
' pFrom As String
' pTo As String
' fFlags As Long
' fAnyOperationsAborted As Long
' hNameMappings As Long
' lpszProgressTitle As String
'End Type
Private Type BrowseInfo
hwndOwner As Long
pIDLRoot As Long ' Especifica dónde se empezará a mostrar
'pszDisplayName As String 'Long
pszDisplayName As Long ' El nombre del directorio, sin el Path completo
lpszTitle As String 'Long
ulFlags As Long
lpfnCallback As Long
lParam As Long
iImage As Long
End Type
' Funciones del API
Private Declare Function SHFileOperation Lib "shell32.dll" Alias "SHFileOperationA" _
(lpFileOp As SHFILEOPSTRUCT) As Long
Private Declare Function SHBrowseForFolder Lib "shell32.dll" _
(lpbi As BrowseInfo) As Long
Private Declare Sub CoTaskMemFree Lib "OLE32.DLL" _
(ByVal hMem As Long)
Private Declare Function lstrcat Lib "kernel32.dll" Alias "lstrcatA" _
(ByVal lpString1 As String, ByVal lpString2 As String) As Long
Private Declare Function SHGetPathFromIDList Lib "shell32.dll" _
(ByVal pidList As Long, ByVal lpBuffer As String) As Long
Public Function BrowseForFolder(ByVal hwndOwner As Long, _
ByVal sPrompt As String, _
Optional ByVal lFlags As eBIF = BIF_RETURNONLYFSDIRS) As String
'
Dim iNull As Integer
Dim lpIDList As Long
Dim lResult As Long
Dim sPath As String
Dim udtBI As BrowseInfo
'
With udtBI
.hwndOwner = hwndOwner
.lpszTitle = sPrompt 'lstrcat(sPrompt, "")
.ulFlags = lFlags 'Or BIF_RETURNONLYFSDIRS
End With
'
lpIDList = SHBrowseForFolder(udtBI)
If lpIDList Then
sPath = String$(MAX_PATH, 0)
lResult = SHGetPathFromIDList(lpIDList, sPath)
Call CoTaskMemFree(lpIDList)
iNull = InStr(sPath, vbNullChar)
If iNull Then
sPath = Left$(sPath, iNull - 1)
End If
Else
' Se ha pulsado en cancelar
sPath = ""
If CancelError Then
With Err
.Source = "cComDialog.BrowseForFolder"
.Number = 32755
.Description = "Cancelada la operación de BrowseForFolder"
End With
End If
End If
'
BrowseForFolder = sPath
End Function
Public Function ShowOpen(Optional ByVal vFileName As String = "", _
Optional ByVal vTitle As String = "", _
Optional ByVal vFilter As String = "", _
Optional ByVal vFlags As Long = 0, _
Optional ByVal vhWnd As Long = 0) As Boolean
'----------------------------------------------------------
'Método para mostrar el cuadro de diálogo de Abrir
'
'(c) Guillermo Som Cerezo 24/Oct/93
'
'Convertido en objeto (clase) (25/Ago/97)
'
'Los parámetros opcionales especificarán:
' vFileName El nombre del archivo
' vTitle Título del cuadro de diálogo
' vFilter Extensiones
' vFlags Los flags
' vhWnd El hWnd del Form
'----------------------------------------------------------
Dim resultado As Long
Dim ofn As OPENFILENAME
Err.Clear
Err.Number = 0
'
If Len(vFileName) Then _
FileName = CStr(vFileName)
If vhWnd <> 0 Then _
hWnd = CLng(vhWnd)
If Len(vFilter) Then _
Me.Filter = CStr(vFilter)
If Len(vTitle) Then _
DialogTitle = CStr(vTitle)
If vFlags <> 0 Then _
Flags = CLng(vFlags)
'
With ofn
.lStructSize = Len(ofn)
.hwndOwner = hWnd
.hInstance = 0
If Len(sFilter) = 0 Then _
sFilter = "Todos los Archivos (*.*)" & Chr$(0) & "*.*" & Chr$(0) & Chr$(0)
'
.lpstrFilter = sFilter
.nFilterIndex = FilterIndex
.lpstrFile = Left$(FileName & String$(MAX_PATH, 0), MAX_PATH)
.nMaxFile = MAX_PATH
.nFileOffset = 0
.nFileExtension = 0
.lpstrDefExt = DefaultExt
.lpstrFileTitle = Left$(FileTitle & String$(260, 0), MAX_PATH)
.nMaxFileTitle = MAX_PATH
.lpstrInitialDir = Left$(InitDir & String$(260, 0), MAX_PATH)
'
'Nombres largos y estilo explorer (21/Oct/97)
'y otros valore "obvios"
'Flags = Flags Or OFN_LONGNAMES Or OFN_EXPLORER Or OFN_PATHMUSTEXIST Or OFN_FILEMUSTEXIST
.Flags = Flags
If Len(DialogTitle) = 0 Then 'Si no se especifica el título
DialogTitle = "Abrir"
End If
.lpstrTitle = DialogTitle
'
.nFileOffset = 0
.lpstrDefExt = 0
.lCustData = 0
.lpfnHook = 0
.lpTemplateName = 0
End With
resultado = GetOpenFileName(ofn)
If resultado <> 0 Then
If Flags And OFN_ALLOWMULTISELECT Then
'Si está multiselect, se separan los nombres con Chr$(0)
FileName = Chr$(34) & Trim$(QuitarCaracterEx(ofn.lpstrFile, Chr$(0), Chr$(34) & " " & Chr$(34))) & Chr$(34)
FileTitle = Chr$(34) & Trim$(QuitarCaracterEx(ofn.lpstrFileTitle, Chr$(0), Chr$(34) & " " & Chr$(34))) & Chr$(34)
InitDir = Chr$(34) & Trim$(QuitarCaracterEx(ofn.lpstrInitialDir, Chr$(0), Chr$(34) & " " & Chr$(34))) & Chr$(34)
Else
FileName = Left$(ofn.lpstrFile, InStr(ofn.lpstrFile, Chr$(0)) - 1)
FileTitle = Left$(ofn.lpstrFileTitle, InStr(ofn.lpstrFileTitle, Chr$(0)) - 1)
InitDir = Left$(ofn.lpstrInitialDir, InStr(ofn.lpstrInitialDir, Chr$(0)) - 1)
End If
Else
If CancelError Then
'Err.Raise 32755, "cComDlgR.ShowOpen", "Error en Abrir (clase cComDlg)"
With Err
.Source = "cComDlgR2.ShowOpen"
.Number = 32755
.Description = "Error en Abrir (clase cComDlgR)"
End With
End If
End If
'Devuelve True si se puede abrir
ShowOpen = (resultado <> 0)
End Function
Public Function ShowSave(Optional ByVal vFileName As String = "", _
Optional ByVal vTitle As String = "", _
Optional ByVal vFilter As String = "", _
Optional ByVal vFlags As Long = 0, _
Optional ByVal vhWnd As Long = 0) As Boolean
'----------------------------------------------------------
'Método para mostrar el cuadro de diálogo de Guardar como...
'
'(c) Guillermo Som Cerezo 24/Oct/93
'
'Convertido en objeto (clase) (25/Ago/97)
'
'Los parámetros opcionales especificarán:
' vFileName El nombre del archivo
' vTitle Título del cuadro de diálogo
' vFilter Extensiones
' vFlags Los flags
' vhWnd El hWnd del Form
'----------------------------------------------------------
Dim resultado As Long
Dim ofn As OPENFILENAME
Err.Clear
Err.Number = 0
If Len(vFileName) Then _
FileName = CStr(vFileName)
If vhWnd <> 0 Then _
hWnd = CLng(vhWnd)
If Len(vFilter) Then _
Me.Filter = CStr(vFilter)
If Len(vTitle) Then _
DialogTitle = CStr(vTitle)
If vFlags <> 0 Then _
Flags = CLng(vFlags)
'
With ofn
.lStructSize = Len(ofn)
.hwndOwner = hWnd
.hInstance = 0
If Len(sFilter) = 0 Then _
sFilter = "Todos los Archivos (*.*)" & Chr$(0) & "*.*" & Chr$(0) & Chr$(0)
.lpstrFilter = sFilter
'.lpstrCustomFilter = ""
'.nMaxCustFilter = 0
.nFilterIndex = FilterIndex
.lpstrFile = Left$(FileName & String$(260, 0), 260)
.nMaxFile = 260
.lpstrFileTitle = Left$(FileTitle & String$(260, 0), 260)
.nMaxFileTitle = 260
.lpstrDefExt = DefaultExt
.lpstrInitialDir = Left$(InitDir & String$(260, 0), 260)
'
'Nombres largos y estilo explorer (21/Oct/97)
'Flags = Flags Or OFN_LONGNAMES Or OFN_EXPLORER Or OFN_HIDEREADONLY
'
.Flags = Flags
If Len(DialogTitle) = 0 Then
DialogTitle = "Guardar como..."
End If
.lpstrTitle = DialogTitle
'
.nFileOffset = 0
.lpstrDefExt = 0
.lCustData = 0
.lpfnHook = 0
.lpTemplateName = 0
'
End With
'
resultado = GetSaveFileName(ofn)
If resultado <> 0 Then
FileName = Left$(ofn.lpstrFile, InStr(ofn.lpstrFile, Chr$(0)) - 1)
FileTitle = Left$(ofn.lpstrFileTitle, InStr(ofn.lpstrFileTitle, Chr$(0)) - 1)
InitDir = Left$(ofn.lpstrInitialDir, InStr(ofn.lpstrInitialDir, Chr$(0)) - 1)
Else
If CancelError Then
With Err
.Source = "cComDlgR2.ShowSave"
.Number = 32755
.Description = "Error en Guardar como... (clase cComDlgR2)"
End With
End If
End If
'Devuelve True si se puede abrir
ShowSave = (resultado <> 0)
End Function
Public Property Let Action(ByVal vNewValue As Integer)
' Está declarada como Property para que se pueda usar de esta forma:
' objeto.Action = 1
'0 Ninguna acción.
'1 Muestra el cuadro de diálogo Abrir.
'2 Muestra el cuadro de diálogo Guardar como.
'3 Muestra el cuadro de diálogo Color.
'4 Muestra el cuadro de diálogo Fuente.
'5 Muestra el cuadro de diálogo Impresora.
'6 Ejecuta WINHELP.EXE.
'
Select Case vNewValue
Case 1: ShowOpen
Case 2: ShowSave
Case 3: 'ShowColor
Case 4: 'ShowFont
Case 5: 'ShowPrinter
Case 6: 'ShowHelp
Case Else
'nada que mostrar
End Select
End Property
Public Property Get Filter() As String
Filter = tmp_sFilter
End Property
Public Property Let Filter(ByVal sNewFilter As String)
' Procesar el parámetro para convertirlo a formato C,
' Se usará | como separador.
Dim i As Long
Dim j As Long
Dim sTmp As String
'
tmp_sFilter = sNewFilter
'
sTmp = ""
If InStr(sNewFilter, "|") Then
sNewFilter = Trim$(sNewFilter)
If Right$(sNewFilter, 1) <> "|" Then
sNewFilter = sNewFilter & "|"
End If
Do
i = InStr(sNewFilter, "|")
If i Then
sTmp = sTmp & Left$(sNewFilter, i - 1) & Chr$(0)
sNewFilter = Mid$(sNewFilter, i + 1)
Else
Exit Do
End If
Loop While i
If Right$(sTmp, 1) = Chr$(0) Then
sNewFilter = sTmp & Chr$(0)
Else
sNewFilter = sTmp & Chr$(0) & Chr$(0)
End If
ElseIf InStr(sNewFilter, Chr$(0)) = 0 Then
sNewFilter = ""
End If
sFilter = sNewFilter
End Property
Public Function QuitarCaracterEx(ByVal sValor As String, ByVal sCaracter As String, Optional ByVal sPoner) As String
'----------------------------------------------------------
' Cambiar/Quitar caracteres (17/Sep/97)
' Si se especifica sPoner, se cambiará por ese carácter
'
'Esta versión permite cambiar los caracteres (17/Sep/97)
'y sustituirlos por el/los indicados
'a diferencia de QuitarCaracter, no se buscan uno a uno,
'sino todos juntos
'----------------------------------------------------------
Dim i As Long
Dim sCh As String
Dim bPoner As Boolean
Dim iLen As Long
bPoner = False
If Not IsMissing(sPoner) Then
sCh = sPoner
bPoner = True
End If
iLen = Len(sCaracter)
If iLen = 0 Then
QuitarCaracterEx = sValor
Exit Function
End If
'Si el caracter a quitar/cambiar es Chr$(0), usar otro método
If Asc(sCaracter) = 0 Then
'Quitar todos los chr$(0) del final
Do While Right$(sValor, 1) = Chr$(0)
sValor = Left$(sValor, Len(sValor) - 1)
If Len(sValor) = 0 Then Exit Do
Loop
iLen = 1
Do
i = InStr(iLen, sValor, sCaracter)
If i Then
If bPoner Then
sValor = Left$(sValor, i - 1) & sCh & Mid$(sValor, i + 1)
Else
sValor = Left$(sValor, i - 1) & Mid$(sValor, i + 1)
End If
iLen = i
Else
'ya no hay más, salir del bucle
Exit Do
End If
Loop
Else
i = 1
Do While i <= Len(sValor)
'Debug.Print Mid$(sValor, i, 1); Asc(Mid$(sValor, i, 1));
If Mid$(sValor, i, iLen) = sCaracter Then
If bPoner Then
sValor = Left$(sValor, i - 1) & sCh & Mid$(sValor, i + iLen)
i = i - 1
'Si lo que hay que poner está incluido en
'lo que se busca, incrementar el puntero
' (11/Jun/98)
If InStr(sCh, sCaracter) Then
i = i + 1
End If
Else
sValor = Left$(sValor, i - 1) & Mid$(sValor, i + iLen)
End If
End If
i = i + 1
Loop
End If
QuitarCaracterEx = sValor
End Function
El
listado de la clase cPalabra:
'------------------------------------------------------------------------------
' cPalabra (15/Ene/01)
'
' ©Guillermo 'guille' Som, 2001
'------------------------------------------------------------------------------
Option Explicit
'
Private bIDAsignado As Boolean
Private sID As String
Private sDefinicion As String
Private nVeces As Long
Private bMostrar As Boolean
Public Property Get ID() As String
Attribute ID.VB_Description = "El ID de este objeto (valor por defecto)"
Attribute ID.VB_UserMemId = 0
ID = sID
End Property
Public Property Let ID(ByVal sNewValue As String)
If Not bIDAsignado Then
bIDAsignado = True
sID = sNewValue
End If
End Property
Public Function Clone(Optional ByVal sNuevoID As String = "") As cPalabra
Attribute Clone.VB_Description = "Hace una copia de este objeto"
' Devuelve una copia de este objeto
Dim tPalabra As cPalabra
Set tPalabra = New cPalabra
'
On Error Resume Next
'
' Si se especifica un nuevo ID, asignarlo (11/Oct/00)
If Len(sNuevoID) Then
tPalabra.ID = sNuevoID
Else
' sino, usar el actual
tPalabra.ID = Me.ID
End If
With tPalabra
.Definicion = Me.Definicion
.Mostrar = Me.Mostrar
.Veces = Me.Veces
End With
'
Set Clone = tPalabra
'
Err = 0
End Function
Public Property Get Definicion() As String
Definicion = sDefinicion
End Property
Public Property Let Definicion(ByVal NewValue As String)
sDefinicion = NewValue
End Property
Public Property Get Veces() As Long
Veces = nVeces
End Property
Public Property Let Veces(ByVal NewValue As Long)
nVeces = NewValue
End Property
Public Property Get Letras() As Long
Attribute Letras.VB_Description = "Número de letras de la palabra"
' Devuelve el número de letras del nombre (ID) de la palabra
Letras = Len(sID)
End Property
Public Property Get Nombre() As String
Attribute Nombre.VB_Description = "Igual que el ID"
' Devuelve el nombre de esta palabra, realmente el ID
Nombre = sID
End Property
Public Property Let Nombre(ByVal NewValue As String)
' Si ya está asignado, no se puede cambiar el nombre de esta palabra
' Pero dejarlo por si se asigna en lugar del ID
' Dejar que el procedimiento Let compruebe si ya está asignado...
Me.ID = NewValue
End Property
Public Property Get Mostrar() As Boolean
Mostrar = bMostrar
End Property
Public Property Let Mostrar(ByVal NewValue As Boolean)
bMostrar = NewValue
End Property
El
listado de la clase/colección cPalabrasFile:
'------------------------------------------------------------------------------
' cPalabrasFile (03/Abr/01)
' Colección de cPalabra con acceso a disco
' Esta clase necesita cIniArray
'
' ©Guillermo 'guille' Som, 2001
'------------------------------------------------------------------------------
Option Explicit
Private m_col As Collection
Private mIni As cIniArray
Public Sub Clear()
Attribute Clear.VB_Description = "Borrar el contenido de la colección"
' Elimnar las palabras de la colección
On Error Resume Next
'
Set m_col = Nothing
Set m_col = New Collection
'
Err.Number = 0
End Sub
Public Function NewEnum() As IUnknown
Attribute NewEnum.VB_Description = "Para enumerar el contenido de la colección"
Attribute NewEnum.VB_UserMemId = -4
Attribute NewEnum.VB_MemberFlags = "40"
' Debe ser un miembro oculto y
' el id del procedimiento debe ser -4
'
Set NewEnum = m_col.[_NewEnum]
End Function
Public Sub Remove(ByVal sIndex As String)
Attribute Remove.VB_Description = "Borrar el elemento indicado de la colección"
' Método Remove de una colección
'
On Error Resume Next
'
m_col.Remove sIndex
'
Err = 0
End Sub
Public Function Item(ByVal sIndex As String) As cPalabra
Attribute Item.VB_Description = "Devuelve o añade un nuevo elemento a la colección (predeterminado)"
Attribute Item.VB_UserMemId = 0
' Método Item de una colección.
' Asignarlo como método predeterminado
Dim tPalabra As cPalabra
Dim i As Long
'
' Iniciamos la detección de errores
On Error Resume Next
'
' Si el valor es númerico...
i = Val(sIndex)
If i > 0 Then
Set Item = m_col.Item(i)
Else
Set Item = m_col.Item(sIndex)
End If
If Err Then
' no existe ese elemento
Err = 0
' Creamos una nueva referencia
Set tPalabra = New cPalabra
tPalabra.ID = sIndex
' lo añadimos a la colección
m_col.Add tPalabra, sIndex
Set Item = tPalabra
' Eliminamos el objeto
Set tPalabra = Nothing
End If
'
Err.Number = 0
End Function
Public Function Count() As Long
Attribute Count.VB_Description = "Devuelve el número de elementos de la colección"
' Método Count de las colección
Count = m_col.Count
End Function
Public Sub Add(ByVal tPalabra As cPalabra)
Attribute Add.VB_Description = "Añade un nuevo elemento a la colección"
' Añadir un nuevo elemento a la colección
'
On Local Error Resume Next
'
' Añadirlo a la colección
m_col.Add tPalabra, tPalabra.ID
'
Err = 0
End Sub
Private Sub Class_Initialize()
Set m_col = New Collection
Set mIni = New cIniArray
End Sub
Private Sub Class_Terminate()
Set m_col = Nothing
Set mIni = Nothing
End Sub
Public Function Clone() As cPalabrasFile
Attribute Clone.VB_Description = "Copia este objeto, pero no se puede añadir a una colección que ya contenga este objeto"
' Hacer una copia de este objeto (06/Oct/00)
'
On Error Resume Next
'
' Esta copia no se puede añadir a una colección que previamente contenga este objeto
Dim tPalabras As cPalabrasFile
Dim tPalabra As cPalabra
'
Set tPalabras = New cPalabrasFile
'
' Añadir a la nueva colección los elementos de la contenida en este objeto
For Each tPalabra In m_col
tPalabras.Add tPalabra.Clone()
Next
'
Set Clone = tPalabras
'
Err.Number = 0
End Function
Public Function Exists(ByVal sID As String) As Boolean
Attribute Exists.VB_Description = "Comprueba si un elemento está en la colección"
' Comprueba si el ID indicado existe en la colección (11/Oct/00)
' Devuelve verdadero o falso, según sea el caso
Dim tPalabra As cPalabra
'
On Error Resume Next
Set tPalabra = m_col(sID)
If Err Then
Exists = False
Else
Exists = True
End If
'
Err = 0
End Function
Public Sub ReadFromFile(ByVal FileName As String)
' Leer las palabras del fichero indicado (04/Abr/01)
'
' El contenido del fichero tendrá el formato de un fichero INI
' Cada ID será una sección y a continuación estarán los valores,
' en el formato habitual:
' Propiedad = Valor
'
Dim tPalabra As cPalabra
Dim aSections() As String
Dim aSection() As String
Dim i As Long
Dim j As Long
Dim sKey As String
Dim sValue As String
'
On Error GoTo ErrReadFromFile
'
If FileExists(FileName) Then
Me.Clear
' Leer todas las secciones
aSections = mIni.IniGetSections(FileName)
' Si tiene menos de 1 elemento, es que no hay datos
If UBound(aSections) = 0 Then
Exit Sub
End If
For j = 1 To UBound(aSections)
aSection = mIni.IniGetSection(FileName, aSections(j))
If UBound(aSection) > 1 Then
Set tPalabra = New cPalabra
tPalabra.ID = aSections(j)
For i = 0 To UBound(aSection) - 1 Step 2
sKey = aSection(i)
sValue = aSection(i + 1)
' Asignar el valor
Select Case sKey
Case "Definicion"
tPalabra.Definicion = sValue
Case "Mostrar"
tPalabra.Mostrar = sValue
Case "Veces"
tPalabra.Veces = sValue
'Case "ID", "Nombre", "Letras", "Clone"
' ' Nada que hacer
'Case Else
' ' Error, no es una propiedad de cPalabra
' With Err
' ' Devolver el error 17:
' ' No se pudo realizar la operación solicitada
' .Source = "cPalabrasFile"
' .Number = 17 ' Can't perfom requested operation
' .Description = "'" & sKey & "' no es una propiedad de cPalabra (ReadFromFile)"
' End With
' Exit For
End Select
Next
Me.Add tPalabra
End If
Next
End If
Exit Sub
'
ErrReadFromFile:
Err = 0
End Sub
Public Sub ReadIDsFromFile(ByVal FileName As String)
' Leer los IDs del fichero indicado
Dim tPalabra As cPalabra
Dim s As String
Dim nFile As Long
'
' Si no se especifica el fichero, salir
If Len(FileName) = 0 Then
Exit Sub
End If
'
If FileExists(FileName) Then
nFile = FreeFile
Open FileName For Input Shared As nFile
Do While Not EOF(nFile)
Line Input #nFile, s
If s <> "" Then
If Me.Exists(s) = False Then
Set tPalabra = New cPalabra
tPalabra.ID = s
Me.Add tPalabra
End If
End If
Loop
Close
End If
End Sub
Public Sub SaveIDsToFile(ByVal FileName As String)
' Guardar los IDs en el fichero
Dim tPalabra As cPalabra
Dim nFile As Long
'
' Si no se especifica el fichero, salir
If Len(FileName) = 0 Then
Exit Sub
End If
'
' Borrarlo si ya existe
If FileExists(FileName) Then
Kill FileName
End If
'
' Guardar las palabras
'
nFile = FreeFile
Open FileName For Output Access Write Lock Read As nFile
For Each tPalabra In m_col
Print #nFile, tPalabra.ID
Next
Close
End Sub
Public Sub SaveToFile(ByVal FileName As String)
' Guardar las palabras en el fichero indicado (04/Abr/01)
'
' El contenido del fichero tendrá el formato de un fichero INI
' Cada ID será una sección y a continuación estarán los valores,
' en el formato habitual:
' Propiedad = Valor
'
Dim tPalabra As cPalabra
'
' Si no se especifica el fichero, salir
If Len(FileName) = 0 Then
Exit Sub
End If
'
' Borrarlo si ya existe
If FileExists(FileName) Then
Kill FileName
End If
'
' Guardar las palabras
For Each tPalabra In m_col
mIni.IniWrite FileName, tPalabra.ID, "Definicion", tPalabra.Definicion
mIni.IniWrite FileName, tPalabra.ID, "Mostrar", tPalabra.Mostrar
mIni.IniWrite FileName, tPalabra.ID, "Veces", tPalabra.Veces
Next
End Sub
Private Function FileExists(ByVal FileName As String) As Boolean
' Devuelve True si el fichero existe
' False si no existe o da error el acceso
Dim i As Long
'
If Len(FileName) = 0 Then
FileExists = False
Exit Function
End If
'
On Error Resume Next
'
i = Len(Dir$(FileName))
If Err Then
Err = 0
i = 0
End If
'
If i = 0 Then
FileExists = False
Else
FileExists = True
End If
End Function
La clase cIniArray
(para manejar ficheros INIs, usada por cPalabrasFile):
'------------------------------------------------------------------------------
' Clase para manejar ficheros INIs
' Permite leer secciones enteras y todas las secciones de un fichero INI
'
' Última revisión: (04/Abr/01)
'
' ©Guillermo 'guille' Som, 1997-2001
'------------------------------------------------------------------------------
Option Explicit
Private sBuffer As String ' Para usarla en las funciones GetSection(s)
'--- Declaraciones para leer ficheros INI ---
' Leer todas las secciones de un fichero INI, esto seguramente no funciona en Win95
' Esta función no estaba en las declaraciones del API que se incluye con el VB
Private Declare Function GetPrivateProfileSectionNames Lib "kernel32" Alias "GetPrivateProfileSectionNamesA" _
(ByVal lpszReturnBuffer As String, ByVal nSize As Long, _
ByVal lpFileName As String) As Long
' Leer una sección completa
Private Declare Function GetPrivateProfileSection Lib "kernel32" Alias "GetPrivateProfileSectionA" _
(ByVal lpAppName As String, ByVal lpReturnedString As String, _
ByVal nSize As Long, ByVal lpFileName As String) As Long
' Leer una clave de un fichero INI
Private Declare Function GetPrivateProfileString Lib "kernel32" Alias "GetPrivateProfileStringA" _
(ByVal lpApplicationName As String, ByVal lpKeyName As Any, _
ByVal lpDefault As String, ByVal lpReturnedString As String, _
ByVal nSize As Long, ByVal lpFileName As String) As Long
' Escribir una clave de un fichero INI (también para borrar claves y secciones)
Private Declare Function WritePrivateProfileString Lib "kernel32" Alias "WritePrivateProfileStringA" _
(ByVal lpApplicationName As String, ByVal lpKeyName As Any, _
ByVal lpString As Any, ByVal lpFileName As String) As Long
Public Sub IniDeleteKey(ByVal sIniFile As String, ByVal sSection As String, _
Optional ByVal sKey As String = "")
'--------------------------------------------------------------------------
' Borrar una clave o entrada de un fichero INI (16/Feb/99)
' Si no se indica sKey, se borrará la sección indicada en sSection
' En otro caso, se supone que es la entrada (clave) lo que se quiere borrar
'
' Para borrar una sección se debería usar IniDeleteSection
'
If Len(sKey) = 0 Then
' Borrar una sección
Call WritePrivateProfileString(sSection, 0&, 0&, sIniFile)
Else
' Borrar una entrada
Call WritePrivateProfileString(sSection, sKey, 0&, sIniFile)
End If
End Sub
Public Sub IniDeleteSection(ByVal sIniFile As String, ByVal sSection As String)
'--------------------------------------------------------------------------
' Borrar una sección de un fichero INI (04/Abr/01)
' Borrar una sección
Call WritePrivateProfileString(sSection, 0&, 0&, sIniFile)
End Sub
Public Function IniGet(ByVal sFileName As String, ByVal sSection As String, _
ByVal sKeyName As String, _
Optional ByVal sDefault As String = "") As String
'--------------------------------------------------------------------------
' Devuelve el valor de una clave de un fichero INI
' Los parámetros son:
' sFileName El fichero INI
' sSection La sección de la que se quiere leer
' sKeyName Clave
' sDefault Valor opcional que devolverá si no se encuentra la clave
'--------------------------------------------------------------------------
Dim ret As Long
Dim sRetVal As String
'
sRetVal = String$(255, 0)
'
ret = GetPrivateProfileString(sSection, sKeyName, sDefault, sRetVal, Len(sRetVal), sFileName)
If ret = 0 Then
IniGet = sDefault
Else
IniGet = Left$(sRetVal, ret)
End If
End Function
Public Sub IniWrite(ByVal sFileName As String, ByVal sSection As String, _
ByVal sKeyName As String, ByVal sValue As String)
'--------------------------------------------------------------------------
' Guarda los datos de configuración
' Los parámetros son los mismos que en LeerIni
' Siendo sValue el valor a guardar
'
Call WritePrivateProfileString(sSection, sKeyName, sValue, sFileName)
End Sub
Public Function IniGetSection(ByVal sFileName As String, _
ByVal sSection As String) As String()
'--------------------------------------------------------------------------
' Lee una sección entera de un fichero INI (27/Feb/99)
' Adaptada para devolver un array de string (04/Abr/01)
'
' Esta función devolverá un array de índice cero
' con las claves y valores de la sección
'
' Parámetros de entrada:
' sFileName Nombre del fichero INI
' sSection Nombre de la sección a leer
' Devuelve:
' Un array con el nombre de la clave y el valor
' Para leer los datos:
' For i = 0 To UBound(elArray) -1 Step 2
' sClave = elArray(i)
' sValor = elArray(i+1)
' Next
'
Dim i As Long
Dim j As Long
Dim sTmp As String
Dim sClave As String
Dim sValor As String
'
Dim aSeccion() As String
Dim n As Long
'
ReDim aSeccion(0)
'
' El tamaño máximo para Windows 95
sBuffer = String$(32767, Chr$(0))
'
n = GetPrivateProfileSection(sSection, sBuffer, Len(sBuffer), sFileName)
'
If n Then
'
' Cortar la cadena al número de caracteres devueltos
sBuffer = Left$(sBuffer, n)
' Quitar los vbNullChar extras del final
i = InStr(sBuffer, vbNullChar & vbNullChar)
If i Then
sBuffer = Left$(sBuffer, i - 1)
End If
'
n = -1
' Cada una de las entradas estará separada por un Chr$(0)
Do
i = InStr(sBuffer, Chr$(0))
If i Then
sTmp = LTrim$(Left$(sBuffer, i - 1))
If Len(sTmp) Then
' Comprobar si tiene el signo igual
j = InStr(sTmp, "=")
If j Then
sClave = Left$(sTmp, j - 1)
sValor = LTrim$(Mid$(sTmp, j + 1))
'
n = n + 2
ReDim Preserve aSeccion(n)
aSeccion(n - 1) = sClave
aSeccion(n) = sValor
End If
End If
sBuffer = Mid$(sBuffer, i + 1)
End If
Loop While i
If Len(sBuffer) Then
j = InStr(sBuffer, "=")
If j Then
sClave = Left$(sBuffer, j - 1)
sValor = LTrim$(Mid$(sBuffer, j + 1))
n = n + 2
ReDim Preserve aSeccion(n)
aSeccion(n - 1) = sClave
aSeccion(n) = sValor
End If
End If
End If
' Devolver el array
IniGetSection = aSeccion
End Function
Public Function IniGetSections(ByVal sFileName As String) As String()
'--------------------------------------------------------------------------
' Devuelve todas las secciones de un fichero INI (27/Feb/99)
' Adaptada para devolver un array de string (04/Abr/01)
'
' Esta función devolverá un array con todas las secciones del fichero
'
' Parámetros de entrada:
' sFileName Nombre del fichero INI
' Devuelve:
' Un array con todos los nombres de las secciones
' La primera sección estará en el elemento 1,
' por tanto, si el array contiene cero elementos es que no hay secciones
'
Dim i As Long
Dim sTmp As String
Dim n As Long
Dim aSections() As String
'
ReDim aSections(0)
'
' El tamaño máximo para Windows 95
sBuffer = String$(32767, Chr$(0))
'
' Esta función del API no está definida en el fichero TXT
n = GetPrivateProfileSectionNames(sBuffer, Len(sBuffer), sFileName)
'
If n Then
' Cortar la cadena al número de caracteres devueltos
sBuffer = Left$(sBuffer, n)
' Quitar los vbNullChar extras del final
i = InStr(sBuffer, vbNullChar & vbNullChar)
If i Then
sBuffer = Left$(sBuffer, i - 1)
End If
'
n = 0
' Cada una de las entradas estará separada por un Chr$(0)
Do
i = InStr(sBuffer, Chr$(0))
If i Then
sTmp = LTrim$(Left$(sBuffer, i - 1))
If Len(sTmp) Then
n = n + 1
ReDim Preserve aSections(n)
aSections(n) = sTmp
End If
sBuffer = Mid$(sBuffer, i + 1)
End If
Loop While i
If Len(sBuffer) Then
n = n + 1
ReDim Preserve aSections(n)
aSections(n) = sBuffer
End If
End If
' Devolver el array
IniGetSections = aSections
End Function
