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.
- 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)- Convertir una fecha de formato ddmmaa a dd/mm/aa
- Filtrar los caracteres ANSI y convertirlos en ASCII
- 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 SubPublic 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