Mis utilidades (otras...) para Visual Basic

Publicado: 13-Jul-97 (revisado: 4/Sep/98)
Siguen sin estar todas, pero seguiré añadiendo más...
Este link te llevará a las utilidades anteriores.
Este link te llevará a una página con más utilidades (casi todas)


Unas cuantas de las que suelo tener en casi todos los programas que uso... si es que son realmente necesarias...
Estas son las que he añadido en esta ocasión. Si algunas las puedes mejorar o "depurar", no dudes en decirmelo.

  1. Quitar y (opcionalmente cambiar) caracteres de una cadena (revisión de la utilidad anterior).
    Otra versión para quitar y cambiar caracteres de una cadena (3/Sep/98)
  2. Convertir una fecha de formato ddmmaa a dd/mm/aa
  3. Filtrar los caracteres ANSI y convertirlos en ASCII
  4. Procesar el resultado de una consulta con varias tablas para evitar registros duplicados

Quitar y (opcionalmente cambiar) caracteres de una cadena (revisión de la utilidad anterior)

En la entrega anterior de mis utilidades, puse una función (con el mismo nombre) que servía para quitar cierto caracteres de una cadena, ahora he modificado, por necesidades del programa que la usaba, ampliando la utilidad, para que permita poder sustituir los caracteres de una cadena. En caso de que no se especifique el caracter a poner, el funcionamiento es idéntico al anterior e incluso no es necesario modificar el código que llame a esta función. ¿Código reutilizable? Si, gracias... y los de Microsoft a ver si tomais nota y aprendeis un poquito... 8-))))

Ejemplos:
sRet$ = QuitarCaracter("Hola Mundo", "Mundo ")
Devolverá: "Hla"
No es un fallo, es que comprueba los caracteres uno a uno. Normalmente la utilizo para quitar los caracteres de puntuación en los números, por eso el valor por defecto es "., " (punto coma espacio)

Para sustituir, se indicará el tercer parámetro.
sRet$ = QuitarCaracter(Format$(Now, "dd/mm/yyyy"), "/", "-")
Cambiará las / por - (esta es la forma para la que está pensada)
Prueba esto otro y verás lo que ocurre:
sRet$ = QuitarCaracter("Hola Mundo", "Mundo", "World")

Public Function QuitarCaracter(ByVal sValor As String, Optional ByVal vCaracter, Optional ByVal sPoner) As String
    '----------------------------------------------
    ' Quitar los símbolos               ( 5/Jun/96)
    ' Si se especifica sPoner, se cambiará por ese carácter (26/Abr/97)
    '
    ' NOTA: los caracteres a quitar se evalúan uno a uno,
    '       no como palabra completa.
    '----------------------------------------------
    Dim i As Long
    Dim j As Long
    Dim sTmp As String
    Dim sCaracter$
    Dim sCh$, bPoner As Boolean
        
    If IsMissing(vCaracter) Then
        sCaracter = "., "
    Else
        sCaracter = vCaracter
    End If
    
    bPoner = False
    If Not IsMissing(sPoner) Then
        sCh = sPoner
        bPoner = True
    End If
    sTmp = ""
    For i = 1 To Len(sValor)
        If InStr(sCaracter, Mid$(sValor, i, 1)) = 0 Then
            sTmp = sTmp & Mid$(sValor, i, 1)
        ElseIf bPoner Then
            sTmp = sTmp & sCh
        End If
    Next
    QuitarCaracter = sTmp
End Function

Convertir una fecha en formato ddmmaa a dd/mm/aa

Esta es otra función de mis días de MS-DOS. Y como el presonal que usa mis programas están habituados a que introduzcan las fechas de esta forma, uso esta función para evitar errores por culpa de los "despistes".

Public Function Text2Fecha(sTexto)
    'Convierte sTexto de formato ddmmaa en dd/mm/aa
    Dim sTmp As String
    
    sTmp = QuitarCaracter(CStr(sTexto), "/- :.,;")
    sTmp = Left$(sTmp & Space$(6), 6)
    Text2Fecha = Left$(sTmp, 2) & "/" & Mid$(sTmp, 3, 2) & "/" & Right$(sTmp, 2)
End Function

Filtrar los caracteres ANSI y convertirlos en ASCII

Otra rutina de conversión, en este caso la suelo usar para imprimir en una impresora matricial usando salida directa, es decir sin usar el controlador de Windows. ¿Por qué? Pues porque estoy habituado a hacer algunas cosas como las hacía en MS-DOS y mientras me funcionen bien, ¿para que cambiar?
La forma de usar será pasar como argumento la cadena que obtenemos en Windows y al filtrarla la impresora sabrá lo que debe imprimir... Sé que existen rutinas del API (creo) para hacer esto, pero...

Nota: Después de preparar esta página me puse a repasar las colaboraciones y me encontré con la de J.L.Soler, que precisamente envía la "famosa" rutina esa del API para hecer esta conversión.
... si cuando yo digo que a esta cabeza mía le hacen falta unos cuantos megas... no es en vano...
(y no es la edad... que desde "chico" ya me pasaba... ¡que-lo-se-pas!)
En fin, está puesto en las colaboraciones. Así que
pincha aquí y vete a verla.

En caso de que algunos de los caracteres no estén definidos, pondrá el que se pasa en el string.

Antes de usar esta función, (FiltroMSDOS), se debe llamar al procedimiento que inicializa el array (IniciarFiltroMSDOS).
Este array debe estar en el mismo módulo en el que se encuentran la función y el procedimiento.

Para usarlo tendrás que hacer algo por el estilo a esto:
sMSDOS = FiltroMSDOS("La cigüeña")

'En la parte de las declaraciones del módulo
Dim iASCII(1 To 63) As Integer       'Para conversión a MS-DOS
'Este sub se debe llamar antes de usar la función
Public Sub IniciarFiltroMSDOS()
    'Convertir de ANSI (windows) a ASCII (dos)
    Dim i As Integer
    Dim p As Integer
    '
    p = 0
    For i = 128 To 156          'de Ç a £   29
        p = p + 1
        iASCII(p) = i
    Next
    For i = 160 To 168          'de á a ¿   9
        p = p + 1
        iASCII(p) = i
    Next
    For i = 170 To 175          'de ¬ a »   6
        p = p + 1
        iASCII(p) = i
    Next
    '44 códigos asignados hasta aquí
    iASCII(45) = 225            'ß
    iASCII(46) = 230            'µ
    iASCII(47) = 241            '±
    iASCII(48) = 246            '÷
    iASCII(49) = 253            '²
    iASCII(50) = 65             'Á (A)
    iASCII(51) = 73             'Í (I)
    iASCII(52) = 79             'Ó (O)
    iASCII(53) = 85             'Ú (U)
    iASCII(54) = 73             'Ï (I)
    iASCII(55) = 65             'À (A)
    iASCII(56) = 69             'È (E)
    iASCII(57) = 73             'Ì (I)
    iASCII(58) = 79             'Ò (O)
    iASCII(59) = 85             'Ù (U)
    iASCII(60) = 69             'Ë (E)
    For i = 61 To 63            ''`´ (')
        iASCII(i) = 39
    Next
End Sub
Public Function FiltroMSDOS(sWIN As String) As String
    'Filtrar la cadena para convertirla en compatible MS-DOS
    Const sANSI = "ÇüéâäàåçêëèïîìÄÅÉæÆôöòûùÿÖÜø£áíóúñѪº¿¬½¼¡«»ßµ±÷²ÁÍÓÚÏÀÈÌÒÙË'`´"
    '
    Dim i As Integer
    Dim p As Integer
    Dim sC As Integer
    Dim sMSD As String
    
    'Aquí se puede poner esta comparación para saber
    'si el array está inicializado.
    'De esta forma no será necesario llamar al procedimiento
    'de inicialización antes de usar esta función.
    '(deberás quitar los comentarios)
    'If iASCII(1) = 0 Then       'El primer valor debe ser 128
    '    IniciarFiltroMSDOS
    'End If

    sMSD = ""
    For i = 1 To Len(sWIN)
        sC = Asc(Mid$(sWIN, i, 1))
        p = InStr(sANSI, Chr$(sC))
        If p Then
            sC = iASCII(p)
        End If
        sMSD = sMSD & Chr$(sC)
    Next
    FiltroMSDOS = sMSD
End Function

Procesar el resultado de una consulta con varias tablas para evitar registros duplicados

Esta rutina, modificada para que pueda ser de utilidad general, la uso para comprobar (filtrar?) el resultado de una consulta en la que intervienen varias tablas. Se ejecutará una consulta que se guardará en un recordset (normalmente un Snapshot) y se pasará como argumento a esta función que devolverá una colección de bookmarks a cada uno de los registros diferentes.
Después se usará el contenido de esa colección para efectuar un bucle sobre cada uno de los registros que son diferentes.
Si hay una forma más fácil de hacerlo, me lo dices... pero es lo que me salvo en su día el problema que se me presentaba al salir el mismo registro repetido...

Para usarlo deberás crear la consulta y llamar a esta función, pasando como parámetros el recordset y el nombre del campo que quieres usar como clave para asignar a la colección, después haces un bucle recorriendo cada uno de los elementos de la colección y usando el valor devuelto como un "apuntador" para situar el puntero en el sitio adecuado...

'Este sólo es una forma de usarlo, el código no está completo...
Dim miRs As Recordset		'El recordset en el que se hará la consulta
Dim miCol As New Collection	'La colección en la que se almacenarán los bookmarks
Dim i As Integer, j As Integer	'Variables para el proceso...
Dim sBookmark As String

'Asignar la consulta al Recordset
'...Este código debes ponerlo tú...

On Local Error Resume Next

'nomCampo será el campo que vamos a usar de CLAVE
'debe ser alguno que sepamos que no va a tener duplicidades
'normalmente será un campo índice... yo suelo usar un campo contador
Set miCol = ProcesarSnap(miRs, nomCampo)

j = miCol.Count
If Err = 0 Then 
    For i = 1 to j
	sBookmark = miCol(i)
	miRs.Bookmark = sBookmark
	If Err = 0 Then
	    'mostrar los datos o hacer lo que quieras con ellos...
	End If
	Err = 0
    Next
End If
Err = 0
On Local Error Goto 0

'Fin del proceso de datos
'...


'Esta es la función... realmente tal como está no la he probado,
'pero debe funcionar, (espero)
Public Function ProcesarSnap(queSnap As Recordset, queID As String) As Variant

'queID será la clave a usar, es decir el campo que usaremos
'como CLAVE para evitar las duplicidades

    'Procesar cada dato y pasarlo a la colección    (27/Oct/96)
    Dim colHist As New Collection
    Dim sID As String
    Dim sContenido As String
    '
    On Local Error Resume Next

    With queSnap
        If (.BOF = True) And (.EOF = True) Then
            Set ProcesarSnap = Nothing
            Exit Function
        End If
	.MoveFirst 
	Do While Not .EOF
            Set tDatoH = Nothing
            sID = "H" & queSnap(queID)
            sContenido = queSnap.Bookmark
            colHist.Add sContenido, sID
	    'Si ya existe, da error y no la añade
            If Err Then Err = 0
            queSnap.MoveNext
        Loop
    End With
    Set ProcesarSnap = colHist
    If Err Then Err = 0
    On Local Error GoTo 0
End Function

Quitar y (opcionalmente cambiar) caracteres de una cadena

Esta es otra versión de la función publicada el 13/Jul/97, pero en esta nueva versión, cuando se indican los caracteres a cambiar, se toman todos como una sola palabra, a diferencia de la anterior que se cambiaba cada uno de los caracteres, no es que fuese un "fallo", es que la idea era poder sustituir sólo caracteres de uno en uno...
También permite sustituir los CHR$(0)

No recuerdo si esta función ya está publicada, al menos no la he visto por sí sola, puede que esté con algún programa o dentro de alguna otra utilidad, pero... aquí la pongo por separado.
Confirmado, estaba en los listados de gsSetDT, pero esta versión es más reciente.

'
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
    '
    'Última revisión:				    (11/Jun/98)
    '----------------------------------------------------------
    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

ir al índice principal