El código de gsNotas versión 3.0

Una utilidad para guardar anotaciones en una base de datos usando ADO

Publicado el 08/Oct/2001
Actualizado el 25/Oct/2006


El código de gsNotas v3.0 en formato zip: gsNotasv3.zip 166 KB

El resto del código está en esta otra página


 

Módulos BAS:

BuscarCombo

Nota del 25/Oct/2006:
Si quieres este mismo efecto de auto completar mientras se escribe para Visual Basic o C# 2003 (.NET 1.x)
sigue este link:

En Visual Basic 2005 y C# 2.0 puedes usar las propiedades AutoComplete y relacionadas.
 


'------------------------------------------------------------------------------
' Procedimiento para realizar búsqueda en combos                    ( 2/Abr/98)
' mientras se escribe (auto completar)
'
' ©Guillermo 'guille' Som, 1998-2001
'------------------------------------------------------------------------------
'
' Para usarlo:
' En el Form que contiene el combo en el que se hará el efecto:
'
'Private Sub Combo1_Change(Index As Integer)
'    Static YaEstoy As Boolean
'
'    On Local Error Resume Next
'
'    If Not YaEstoy Then
'        YaEstoy = True
'        unCombo_Change Combo1(Index).Text, Combo1(Index)
'        YaEstoy = False
'    End If
'    Err = 0
'End Sub
'
'Private Sub Combo1_KeyDown(Index As Integer, KeyCode As Integer, Shift As Integer)
'    unCombo_KeyDown KeyCode
'End Sub
'
'Private Sub Combo1_KeyPress(Index As Integer, KeyAscii As Integer)
'    unCombo_KeyPress KeyAscii
'End Sub
'------------------------------------------------------------------------------
Option Explicit

Dim Combo1Borrado As Boolean
Public Sub unCombo_KeyDown(KeyCode As Integer)
    If KeyCode = vbKeyDelete Then
        Combo1Borrado = True
    Else
        Combo1Borrado = False
    End If
End Sub
Public Sub unCombo_KeyPress(KeyAscii As Integer)
    'si se pulsa Borrar... ignorar la búsqueda al cambiar
    If KeyAscii = vbKeyBack Then
        Combo1Borrado = True
    Else
        Combo1Borrado = False
    End If
End Sub

Public Sub unCombo_Change(ByVal sText As String, elCombo As ComboBox)
    Dim i As Integer, L As Integer
    
    If Not Combo1Borrado Then
        L = Len(sText)
        With elCombo
            For i = 0 To .ListCount - 1
                If StrComp(sText, Left$(.List(i), L), 1) = 0 Then
                    .ListIndex = i
                    .Text = .List(.ListIndex)
                    .SelStart = L
                    .SelLength = Len(.Text) - .SelStart
                    Exit For
                End If
            Next
        End With
    End If
End Sub

 

gsDBR_bas (módulo para gsDBR.frm)


'------------------------------------------------------------------------------
' gsDBR.bas Módulo para el diálogo de Buscar y Reemplazar
'
' ©Guillermo 'guille' Som, 1997-2001
'------------------------------------------------------------------------------
Option Explicit

'Flag para usar con el RichTextBox                  (24/Mar/98)
Dim EsRichTextBox As Boolean

'Nuevas variables para palabra completa y dirección:    ( 6/Sep/97)
Global iFFCompleta As Boolean
Global iFFAtras As Boolean
Global Const cFFAc_Accion = 15      'para los valores normales
Global Const cFFAc_Completa = 32    'si se muestra palabra completa
Global Const cFFAc_Atras = 64       'si se muestra la dirección de búsqueda
'
'Para usar procedimientos genéricos de búsqueda         (31/Ago/97)
Global LineaEstado As Control
'Constantes para el menú de Edición
Global Const mEdDeshacer = 0
Global Const mEdCortar = 1
Global Const mEdCopiar = 2
Global Const mEdPegar = 3
'Const mEdSep1 = 4
Global Const mEdBuscarActual = 5
Global Const mEdBuscarSigActual = 6
Global Const mEdReemplazarActual = 7
'Const mEdSep2 = 8
Global Const mEdSeleccionarTodo = 9
'
'Constantes para las opciones de búsqueda en el TextBox actual
Global Const CMD_BuscarActual = 101
Global Const CMD_BuscarSigActual = 102
Global Const CMD_ReemplazarActual = 103
Global Const CMD_SeleccionarTodo = 104

'Variables y constantes para buscar/reemplazar
Global sFFBuscar As String
Global sFFPoner As String
Global iFFAccion As Integer
'
'Constantes para la acción a realizar
Global Const cFFAc_Cancelar = True
Global Const cFFAc_IDLE = 0
Global Const cFFAc_Buscar = 1
Global Const cFFAc_BuscarSiguiente = 2
Global Const cFFAc_Reemplazar = 3
Global Const cFFAc_ReemplazarTodo = 4
Global Const cFFAc_Aceptar = 5
'
Global sFFIni As String                     'Archivo de configuración

'Funciones Globales del API
Public Declare Function SendMessage Lib "user32" Alias "SendMessageA" _
    (ByVal hWnd As Long, ByVal wMsg As Long, _
     ByVal wParam As Long, lParam As Any) As Long
     
Private Declare Function PostMessage Lib "user32" Alias "PostMessageA" _
        (ByVal hWnd As Long, ByVal wMsg As Long, _
         ByVal wParam As Long, ByVal lParam As Long) As Long

'Declaración de las constantes, para usar con SendMessage/PostMessage
Global Const WM_CUT = &H300
Global Const WM_COPY = &H301
Global Const WM_PASTE = &H302
'Global Const WM_CLEAR = &H303
'
Global Const EM_CANUNDO = &HC6
Global Const EM_UNDO = &HC7

Public Function ActualizarLista(ByVal sTexto As String, cList As Control, Optional vTipoBusqueda, Optional vAddLista) As Long
    'Esta función comprobará si el texto indicado existe en la lista
    'Si no es así, lo añadirá
    'El valor devuelto, será la posición dentro de la lista ó -1 si hay "fallos"
    '
    'Para buscar en el List/combo usaremos una llamada al API
    '(si ya hay una forma de hacerlo, ¿para que re-hacerla?)
    '
    'Constantes para los combos
    Const CB_FINDSTRINGEXACT = &H158
    Const CB_FINDSTRING = &H14C
    Const CB_SELECTSTRING = &H14D
    'Constantes para las Listas
    Const LB_FINDSTRINGEXACT = &H1A2        'Busca la cadena exactamente igual
    Const LB_FINDSTRING = &H18F             'Busca en cualquier parte de la cadena
    Const LB_SELECTSTRING = &H18C           'Busca desde el principio de la cadena
    '
    Dim lTipoBusqueda As Long
    Dim bTipoBusqueda As Integer            '0= Exacta, 1= cualquier parte, 2=desde el principio
    Dim bAddLista As Boolean
    Dim L As Long
    
    'Si se busca palabra completa o parcial,
    'por defecto COMPLETA
    If IsMissing(vTipoBusqueda) Then
        bTipoBusqueda = False
    Else
        bTipoBusqueda = vTipoBusqueda
    End If
    'Si se debe añadir o no, por defecto SI
    If IsMissing(vAddLista) Then
        bAddLista = True
    Else
        bAddLista = vAddLista
    End If
    
    'Si el control es un Combo
    If TypeOf cList Is ComboBox Then
        If bTipoBusqueda = 1 Then
            lTipoBusqueda = CB_FINDSTRING
        ElseIf bTipoBusqueda = 2 Then
            lTipoBusqueda = CB_SELECTSTRING
        Else
            lTipoBusqueda = CB_FINDSTRINGEXACT
        End If
    'Si el control es un list
    ElseIf TypeOf cList Is ListBox Then
        If bTipoBusqueda = 1 Then
            lTipoBusqueda = LB_FINDSTRING
        ElseIf bTipoBusqueda = 2 Then
            lTipoBusqueda = LB_SELECTSTRING
        Else
            lTipoBusqueda = LB_FINDSTRINGEXACT
        End If
    Else
        'no es un control List o Combo, salir
        ActualizarLista = -1
        Exit Function
    End If
    
    If cList.ListCount = 0 Then
        'Seguro que no está, así que añadirla, si viene al caso...
        L = -1
    Else
        L = SendMessage(cList.hWnd, lTipoBusqueda, -1, ByVal sTexto)
    End If
    
    'Si no está, añadirla
    If L = -1 Then
        If bAddLista Then
            'Con el 0 se añade al principio de la lista
            cList.AddItem sTexto, 0
            L = ActualizarLista(sTexto, cList, bTipoBusqueda, bAddLista)
        End If
    End If
    ActualizarLista = L
End Function

Public Function gsReemplazar(sBuscar As String, sPoner As String, Optional vModo, Optional vCaption) As Integer
    'Prepara el diálogo de Reemplazar
    Dim iModo As Integer
    Dim sCaption As String
    
    If IsMissing(vModo) Then
        iModo = cFFAc_Reemplazar
    Else
        iModo = vModo
    End If
    
    If IsMissing(vCaption) Then
        sCaption = "Reemplazar"
    Else
        sCaption = CStr(vCaption)
    End If
    
    iFFAccion = cFFAc_IDLE
    With gsDBR
        'Por ahora no se muestra en reemplazar          ( 6/Sep/97)
        .chkCompleta.Visible = False
        .chkCompleta.Enabled = False
        .chkDireccion.Visible = False
        .chkDireccion.Enabled = False
        .Caption = sCaption
        .cmdFindNext.Default = False
        .cmdFindNext.Visible = False
        .cmdReplaceAll.Default = True
        .Combo1(0).Text = sBuscar
        .Combo1(1).Text = sPoner
        .PosicionarControles
        'Mostrar el form y esperar a que se tome una acción
        .Show vbModal
        'Do
        '    .Show
        '    DoEvents
        'Loop Until iFFAccion
    End With
    'Devolver la cadena a reemplazar y buscar
    sBuscar = sFFBuscar
    sPoner = sFFPoner
    'Si tanto buscar como poner están en blanco, devolver cancelar
    If Len(Trim$(sBuscar)) = 0 Then
        If Len(Trim$(sPoner)) = 0 Then
            iFFAccion = cFFAc_Cancelar
        End If
    End If
    'Devolver la acción
    gsReemplazar = iFFAccion
End Function

Public Function gsBuscar(sBuscar As String, Optional vModo, Optional vCaption) As Integer
    'Prepara el diálogo para buscar
    Dim iModo As Integer
    Dim sCaption As String
    Dim bCompleta As Boolean
    Dim bAtras As Boolean
        
    If IsMissing(vModo) Then
        iModo = cFFAc_Buscar
        bCompleta = False
        bAtras = False
    Else
        bCompleta = vModo And cFFAc_Completa
        bAtras = vModo And cFFAc_Atras
        'quedarse sólo con los valores normales
        iModo = vModo And cFFAc_Accion
    End If
    'Sólo permitir buscar y buscar-siguiente
    Select Case iModo
    Case cFFAc_Buscar, cFFAc_BuscarSiguiente
        'está bien, no hay nada que hacer
    Case Else
        iModo = cFFAc_Buscar
    End Select
    
    If IsMissing(vCaption) Then
        sCaption = "Buscar"
    Else
        sCaption = CStr(vCaption)
    End If
    
    iFFAccion = cFFAc_IDLE
    With gsDBR
        'Si se muestra la opción de palabra completa
        .chkCompleta.Visible = bCompleta
        .chkCompleta.Enabled = bCompleta
        .chkCompleta = Abs(CInt(iFFCompleta))
        'si se muestra la opción de dirección de búsqueda
        .chkDireccion.Visible = bAtras
        .chkDireccion.Enabled = bAtras
        .chkDireccion = Abs(CInt(iFFAtras))
        
        .Caption = sCaption
        .cmdReplace.Visible = False
        .lblReplace.Visible = False
        .cmdReplaceAll.Visible = False
        .Combo1(1).Visible = False
        .Combo1(1).Enabled = False
        .cmdFindNext.Left = .cmdReplaceAll.Left
        If iModo = cFFAc_BuscarSiguiente Then
            .cmdFindNext.Caption = "Siguiente"
            DoEvents
        End If
        .Combo1(0).Text = sBuscar
        .PosicionarControles
        'Mostrar el form y esperar a que se tome una acción
        .Show vbModal
        'Do
        '    .Show
        '    DoEvents
        'Loop Until iFFAccion
    End With
    'Devolver la cadena seleccionada/introducida
    sBuscar = sFFBuscar
    'Devolver la acción
    gsBuscar = iFFAccion
End Function


Public Sub gsPedirUnValor(spuvTitulo As String, spuvMensaje As String, spuvPregunta As String, spuvValor As String, spuvBoton As String)
    
    'Rutina de propósito general para pedir un valor (00.22 23/May/96)
    With gsDBR
        .chkCompleta.Visible = False
        .chkCompleta.Enabled = False
        .chkDireccion.Visible = False
        .chkDireccion.Enabled = False
        .Caption = spuvTitulo
        .Combo1(0).Visible = False
        .lblBuscar.Width = .ScaleWidth - 120
        .lblBuscar = spuvMensaje
        .Combo1(0).Visible = False
        .cmdReplace.Visible = False
        .cmdFindNext.Default = False
        .cmdFindNext.Visible = False
        .lblReplace = spuvPregunta
        .cmdReplaceAll.Default = True
        .cmdReplaceAll.Caption = spuvBoton
        If Len(Trim$(spuvValor)) Then
            .Combo1(1).Text = spuvValor
        Else
            If .Combo1(1).ListCount Then
                .Combo1(1).ListIndex = 0
            End If
        End If
        .PosicionarControles
        .Show vbModal
    End With
    spuvValor = sFFPoner
End Sub
Private Sub AccionBuscar(Index As Integer)
    '--------------------------------------------------------------
    'Procedimiento genérico para realizar búsquedas     (31/Ago/97)
    '
    'Valores necesarios:
    '   LineaEstado     un control para mostrar mensajes temporales
    '   CMD_xxx         Apuntará a los índices del menú de edición
    '                   que deberá tener estas opciones:
    '           Deshacer
    '           Cortar
    '           Copiar
    '           Pegar
    '           ---
    '           Buscar
    '           Buscar Siguiente
    '           Reemplazar
    '           ---
    '           Seleccionar Todo
    '
    '--------------------------------------------------------------
    Static sBuscar As String
    Static lngUltimaPos As Long
    Dim lngPosActual As Long
    Dim sTmp As String
    Dim tText As Control
        
    Set tText = Screen.ActiveForm.ActiveControl
    'Si no es un cuadro de texto, salir
    If Not (TypeOf tText Is TextBox) And Not (TypeOf tText Is RichTextBox) Then
        Exit Sub
    End If
    
    LineaEstado.Tag = LineaEstado
    
    'para procesar las otras acciones adicionales   (15/Abr/97)
    Select Case Index
    Case CMD_BuscarActual
        'Si hay texto seleccionado...
        With tText
            If .SelLength > 0 Then
                sBuscar = Trim$(.SelText)
            End If
        End With
        'Para "personalizar" la sección de búsqueda...
        gsDBR.Combo1(0).Tag = "Buscar_" & sUsuario
        If gsBuscar(sBuscar, , "Buscar en el campo actual") > cFFAc_IDLE Then
            sBuscar = Trim$(sBuscar)
            If Len(sBuscar) Then
                LineaEstado = "Buscando en el campo actual " & sBuscar & "..."
                DoEvents
                lngUltimaPos = 0&
                lngPosActual = InStr(tText, sBuscar)
                If lngPosActual Then
                    lngUltimaPos = lngPosActual + 1
                    'posicionarse en esa palabra:
                    With tText
                        .SelStart = lngPosActual - 1
                        .SelLength = Len(sBuscar)
                    End With
                Else
                    Beep
                    MsgBox "No se ha hallado el texto buscado", vbOK + vbInformation, "Buscar en el campo actual"
                End If
                'posicionarse en ese control
                tText.SetFocus
            End If
        End If
    Case CMD_BuscarSigActual
        'Si no hay nada hallado con anterioridad
        'o no se ha procesado la última búsqueda en este control
        If Len(sBuscar) = 0 Or lngUltimaPos = 0& Then
            AccionBuscar CMD_BuscarActual
        Else
            LineaEstado = "Buscando " & sBuscar & "..."
            DoEvents
            lngPosActual = InStr(lngUltimaPos, tText, sBuscar)
            If lngPosActual Then
                lngUltimaPos = lngPosActual + Len(sBuscar)
                'posicionarse en esa palabra:
                With tText
                    .SelStart = lngPosActual - 1
                    .SelLength = Len(sBuscar)
                End With
            Else
                lngUltimaPos = 1&
                Beep
                MsgBox "No se ha hallado el texto buscado.", vbOK + vbInformation, "Buscar en el campo actual"
            End If
            'posicionarse en ese control
            tText.SetFocus
        End If
    Case CMD_ReemplazarActual
        'Si hay texto seleccionado...
        With tText
            If .SelLength > 0 Then
                sBuscar = Trim$(.SelText)
            End If
        End With
        
        sFFBuscar = sBuscar
        sFFPoner = ""
        'Personalizar las secciones de buscar/reemplazar
        gsDBR.Combo1(0).Tag = "Buscar_" & sUsuario
        gsDBR.Combo1(1).Tag = "Reemplazar_" & sUsuario
        iFFAccion = gsReemplazar(sFFBuscar, sFFPoner, , "Reemplazar en el campo actual")
        If iFFAccion <> cFFAc_Cancelar Then
            elForm.MousePointer = vbHourglass
            DoEvents
            sBuscar = Trim$(sFFBuscar)
            If Len(sFFBuscar) <> 0 And Len(sFFPoner) <> 0 Then
                If iFFAccion = cFFAc_Reemplazar Or iFFAccion = cFFAc_ReemplazarTodo Then
                    LineaEstado = "Reemplazando " & sBuscar & "..."
                    DoEvents
                    lngUltimaPos = 0&
                    lngPosActual = InStr(tText, sBuscar)
                    If lngPosActual Then
                        lngUltimaPos = lngPosActual + Len(sBuscar)
                        sTmp = tText 'Text1(ControlActual).Text
                        sTmp = Left$(sTmp, lngPosActual - 1) & sFFPoner & Mid$(sTmp, lngPosActual + Len(sFFBuscar))
                        tText = sTmp
                        'Si sólo es reemplazar uno...
                        If iFFAccion = cFFAc_Reemplazar Then Exit Sub
                        'Cambiar todas las coincidencias en el mísmo text
                        lngUltimaPos = 1
                        Do
                            lngPosActual = InStr(lngUltimaPos, sTmp, sFFBuscar)
                            If lngPosActual Then
                                lngUltimaPos = lngPosActual + 1
                                sTmp = Left$(sTmp, lngPosActual - 1) & sFFPoner & Mid$(sTmp, lngPosActual + Len(sFFBuscar))
                                tText = sTmp
                            End If
                        Loop While lngPosActual
                        DoEvents
                    Else
                        Beep
                        MsgBox "No se ha hallado el texto buscado.", vbOK + vbInformation, "Buscar en el campo actual"
                    End If
                    'Si se ha reemplazado to, no debe estar esta palabra...
                    lngUltimaPos = 0&
                End If
            End If
            elForm.MousePointer = vbDefault
            DoEvents
        End If
    Case CMD_SeleccionarTodo
        With tText
            .SelStart = 0
            .SelLength = Len(.Text)
        End With
    End Select
    LineaEstado = LineaEstado.Tag
End Sub

Public Sub menuEdi()
    'Habilitar las opciones disponibles
    Dim Habilitada As Boolean
    Dim i As Integer
    
    'los separadores no se pueden deshabilitar!!!
    On Local Error Resume Next
    
    EsRichTextBox = False
    'Asegurarnos que es un textbox
    If TypeOf Screen.ActiveForm.ActiveControl Is TextBox Then
        'ok, todo bien...
        Habilitada = True
    ElseIf TypeOf Screen.ActiveForm.ActiveControl Is RichTextBox Then
        Habilitada = True
        EsRichTextBox = True
    Else
        'no poder hacer estas cosas
        Habilitada = False
    End If
    For i = mEdDeshacer To mEdSeleccionarTodo
        elForm!mnuEdicion(i).Enabled = Habilitada
    Next
    'Algunos chequeos para las opciones de edición:
    If Habilitada Then
        'Si no se puede deshacer, no habilitarlo
        If SendMessage(Screen.ActiveForm.ActiveControl.hWnd, EM_CANUNDO, 0, ByVal 0&) Then
            elForm!mnuEdicion(mEdDeshacer).Enabled = True
        Else
            elForm!mnuEdicion(mEdDeshacer).Enabled = False
        End If
        'comprobar si hay algo que pegar...
        If Clipboard.GetFormat(vbCFText) Then
            elForm!mnuEdicion(mEdPegar).Enabled = True
        Else
            elForm!mnuEdicion(mEdPegar).Enabled = False
        End If
    End If
    Err = 0
    On Local Error GoTo 0
End Sub

Public Sub menuEdicion(Index As Integer)
    Dim sTmp As String
    
    Select Case Index
    Case mEdDeshacer
        '-------------------------------------------------------------
        ' IMPORTANTE:
        ' En ambos casos se podría usar SendMessage,
        ' pero en el caso de EM_CANUNDO, NO serviría PostMessage,
        ' porque esta función sólo devuelve un valor de
        ' si se ha puesto o no en la cola de mensajes de windows.
        '-------------------------------------------------------------
        'Si se puede deshacer...
        If SendMessage(Screen.ActiveForm.ActiveControl.hWnd, EM_CANUNDO, 0, ByVal 0&) Then
            'Deshacerlo!
            Call PostMessage(Screen.ActiveForm.ActiveControl.hWnd, EM_UNDO, 0, ByVal 0&)
        End If
    Case mEdCopiar
        Call PostMessage(Screen.ActiveForm.ActiveControl.hWnd, WM_COPY, 0, ByVal 0&)
'        '                                               ( 6/May/98)
'        'Si se copia desde el RichTextBox, algunas aplicaciones
'        'se hacen un lio..
'        If Screen.ActiveForm.ActiveControl.Name = "RichTextBox1" Then
'            'sTmp = Clipboard.GetText(vbCFRTF)
'            sTmp = Clipboard.GetText(vbCFText)
'            If Len(sTmp) Then
'                Clipboard.SetText sTmp, vbCFText
'            End If
'        End If
'        'Pues no sirve... ni aún usando Control+C
'
    Case mEdCortar
        Call PostMessage(Screen.ActiveForm.ActiveControl.hWnd, WM_CUT, 0, ByVal 0&)
    Case mEdPegar
        Call PostMessage(Screen.ActiveForm.ActiveControl.hWnd, WM_PASTE, 0, ByVal 0&)
    Case mEdBuscarActual
        AccionBuscar CMD_BuscarActual
    Case mEdBuscarSigActual
        AccionBuscar CMD_BuscarSigActual
    Case mEdReemplazarActual
        AccionBuscar CMD_ReemplazarActual
    Case mEdSeleccionarTodo
        AccionBuscar CMD_SeleccionarTodo
    End Select
End Sub

 

gsImprimir_Bas (módulo para el formulario Imprimir.frm)


'------------------------------------------------------------------------------
' Módulo con función genérica para imprimir                         (31/Ago/97)
'
' ©Guillermo 'guille' Som, 1997-2001
'------------------------------------------------------------------------------
Option Explicit


Public Sub gsImprimir(qControl As Control)
    '--------------------------------------------------------------
    'Procedimiento genérico para imprimir               (31/Ago/97)
    '
    'Entrada:
    '   qControl    control a imprimir (TextBox, ListBox)
    '
    '--------------------------------------------------------------
    Const MAXLINEA = 136&           ' Número de caracteres máximos por línea
    '
    Dim nFicSal As Long
    Dim sLpt As String
    Dim i As Long
    Dim j As Long
    Dim k As Long
    Dim sTmp As String
    Dim sImpresora As String
    Dim sngFS As Single
    Dim sFN As String
    Dim bDirecto As Boolean
    Dim bCourierNew As Boolean
    Dim nCourierNew As Currency
    Dim tPrinter As Printer
    Dim tOrientacion As Long
    Dim tOrientacionAnt As Long
    '
    Dim L1 As Long, L2 As Long
    Const EM_GETLINECOUNT = &HBA
    Const EM_LINEINDEX = &HBB
    Const EM_LINELENGTH = &HC1
    
    'On Local Error Resume Next 'GoTo ErrorImprimiendo

    Set tPrinter = Printer
    
    'Seleccionar impresora
    Dim frmImpresora As Imprimir 'Form
    '
    iFFAccion = cFFAc_IDLE
    '
    ' Cargar la ventana de selección de impresora
    Set frmImpresora = New Imprimir
    With frmImpresora
        ' Mostrar el Form
        ' Controlador de Windows
        .OptMétodoImpresión(0) = 1
        .chkCourierNew.Enabled = True
        ' Imprimir directamente
        .OptMétodoImpresión(1) = 0
        .Show vbModal
        If iFFAccion <> cFFAc_Cancelar Then
            sLpt = .sLpt
'            If Right$(sLpt, 1) <> ":" Then
'                sLpt = sLpt & ":"
'            End If
            bDirecto = .OptMétodoImpresión(1)
            bCourierNew = .chkCourierNew
            nCourierNew = .txtCourierNew
            'Seleccionar la impresora como predeterminada
            'Dim tPrinter2 As Printer
            'For Each tPrinter2 In Printers
            '    If tPrinter2.DeviceName = .CboImpresoras.Text Then
            '        Set Printer = tPrinter2
            '        Exit For
            '    End If
            'Next
            Set tPrinter = Printer
            If .chkOrientacion Then
                tOrientacionAnt = tPrinter.Orientation
                If .optOrientacion(0) Then
                    tOrientacion = vbPRORPortrait
                Else
                    tOrientacion = vbPRORLandscape
                End If
                tPrinter.Orientation = tOrientacion
            End If
        End If
    End With
    Unload frmImpresora
    Set frmImpresora = Nothing
    If iFFAccion = cFFAc_Cancelar Then Exit Sub
    'If Right$(sLpt, 1) = ":" Then
    '    sLpt = Left$(sLpt, Len(sLpt) - 1)
    'End If
    '
    If TypeOf qControl Is ListBox Then
        k = qControl.ListCount
    Else
        ' Número de líneas del TextBox
        k = SendMessage(qControl.hWnd, EM_GETLINECOUNT, 0, 0&)
    End If
    If bDirecto Then
        ' Imprimir directamente...
        j = 0
        nFicSal = FreeFile
        Open sLpt For Output As nFicSal
        Print #nFicSal, Chr$(15);   'Letra pequeña
    Else
        ' Usar controlador de Windows
        sngFS = tPrinter.FontSize
        sFN = tPrinter.FontName
        'If MsgBox("¿Quieres Imprimir con Courier New 8 puntos?", 4 + 32, "Imprimir") = 6 Then
        If bCourierNew Then
            tPrinter.FontSize = nCourierNew ' 8
            tPrinter.FontName = "Courier New"
        End If
        If Err Then Err = 0
        tPrinter.Print ""
        tPrinter.Print ""
    End If
    For i = 0 To k - 1
        DoEvents
        If iFFAccion = cFFAc_Cancelar Then Exit For
        'Caption = "Imprimiendo " & i + 1 & " de " & k
        If TypeOf qControl Is ListBox Then
            If bDirecto Then
                Print #nFicSal, Left$(qControl.List(i), MAXLINEA)
            Else
                tPrinter.Print Left$(qControl.List(i), MAXLINEA)
            End If
        Else
            ' Primer carácter de la línea actual
            L1 = SendMessage(qControl.hWnd, EM_LINEINDEX, i, 0&) + 1
            ' Longitud de la línea actual
            L2 = SendMessage(qControl.hWnd, EM_LINELENGTH, L1, 0&)
            If L2 > MAXLINEA Then L2 = MAXLINEA
            If bDirecto Then
                Print #nFicSal, Mid$(qControl.Text, L1, L2)
                j = j + 1
                ' cada 60 líneas en una página
                If j = 60 Then
                    Print #nFicSal, Chr$(12);
                    j = 0
                End If
            Else
                tPrinter.Print Mid$(qControl.Text, L1, L2)
            End If
        End If
    Next
    If bDirecto Then
        If j Then
            Print #nFicSal, Chr$(12);
        End If
        Print #nFicSal, Chr$(18);
        Close nFicSal
    Else
        tPrinter.EndDoc
        ' restaurar la fuente anterior
        tPrinter.FontSize = sngFS
        tPrinter.FontName = sFN
    End If
    ' Restaurar la orientación anterior del papel
    If tOrientacionAnt Then
        tPrinter.Orientation = tOrientacionAnt
    End If
End Sub
Public Sub gsImprimir1(qControl As Control, Optional vLPT, Optional vDirecto)
    '--------------------------------------------------------------
    'Procedimiento genérico para imprimir               (31/Ago/97)
    '
    'Entrada:
    '   qControl    control a imprimir (TextBox, ListBox)
    '   vLPT        Impresora de salida, sólo para impresión directa
    '   vDirecto    Si se imprime directamente o se usa el controlador
    '--------------------------------------------------------------
    Const MAXLINEA = 136        'Número de caracteres máximos por línea
    
    Dim nFicSal As Integer
    Dim sLpt As String
    Dim i As Long
    Dim j As Integer
    Dim k As Long
    Dim sTmp As String
    Dim sImpresora As String
    Dim bDirecto As Boolean
    Dim tPrinter As Printer
    
    Dim L1&, L2&
    Const EM_GETLINECOUNT = &HBA
    Const EM_LINEINDEX = &HBB
    Const EM_LINELENGTH = &HC1
    
    Set tPrinter = Printer
    
    'El port de impresora a usar
    If IsMissing(vLPT) Then         'Si no se especifica,
        sLpt = "LPT1:"              'usar LPT1:
    Else
        sLpt = CStr(vLPT)
    End If
    'Si se va a imprimir directamente en el puerto
    'o se va a usar el controlador de Windows
    If IsMissing(vDirecto) Then     'Si no se especifica,
        bDirecto = False            'usar el controlador de Windows
    Else
        bDirecto = CBool(vDirecto)
    End If
    
    'Quitarle los dos puntos, si lo tiene,
    'seguramente no es necesario, pero...
    If Right$(sLpt, 1) = ":" Then
        sLpt = Left$(sLpt, Len(sLpt) - 1)
    End If
    
    If TypeOf qControl Is ListBox Then
        'Número de items en el listbox
        k = qControl.ListCount
    Else
        'Número de líneas del TextBox
        k = SendMessage(qControl.hWnd, EM_GETLINECOUNT, 0, 0&)
    End If
    If bDirecto Then
        'Imprimir directamente...
        j = 0
        nFicSal = FreeFile
        'Abrir el puerto de impresora para salida...
        Open sLpt For Output As nFicSal
        Print #nFicSal, Chr$(15);   'Letra pequeña
    Else
        'Usar controlador de Windows
        tPrinter.Print ""
        tPrinter.Print ""
    End If
    'Se imprimirá cada una de las líneas del listbox o del textbox
    '-------------------------------------------------------------
    'En este último caso no sería necesario,
    'ya que se puede imprimir TODO de una vez, usando esto:
    'Printer.Print qControl.Text        'usando el controlador
    'Print #nFicSal, qControl.Text      'imprimiendo directamente
    '-------------------------------------------------------------
    For i = 0 To k - 1
        DoEvents
        If TypeOf qControl Is ListBox Then
            If bDirecto Then
                Print #nFicSal, Left$(qControl.List(i), MAXLINEA)
            Else
                tPrinter.Print Left$(qControl.List(i), MAXLINEA)
            End If
        Else
            'Primer carácter de la línea actual
            L1 = SendMessage(qControl.hWnd, EM_LINEINDEX, i, 0&) + 1
            'Longitud de la línea actual
            L2 = SendMessage(qControl.hWnd, EM_LINELENGTH, L1, 0&)
            If L2 > MAXLINEA Then L2 = MAXLINEA
            If bDirecto Then
                Print #nFicSal, Mid$(qControl.Text, L1, L2)
                j = j + 1
                'cada 60 líneas en una página
                If j = 60 Then
                    Print #nFicSal, Chr$(12);
                    j = 0
                End If
            Else
                tPrinter.Print Mid$(qControl.Text, L1, L2)
            End If
        End If
    Next
    If bDirecto Then
        'Restaurar el tamaño de la fuente a normal
        Print #nFicSal, Chr$(18);
        'Si j vale CERO, ya se imprimió un salto de página
        'en caso contrario, echar la hoja fuera
        If j Then
            Print #nFicSal, Chr$(12);
        End If
        Close nFicSal
    Else
        tPrinter.EndDoc
    End If
End Sub

 

MgsNotas (módulo para gsNotas)


'------------------------------------------------------------------------------
' glbNotas   Módulo para las declaraciones globales                 (28/Feb/97)
'
' Revisado: 01/Oct/2001
'
' ©Guillermo 'guille' Som, 1997-2001
'------------------------------------------------------------------------------
Option Explicit

Public gCD As cgsFileOp                 ' Para manejar los ficheros INIs y otras cosas
' Dependiendo del proveedor, el tipo de datos a usar será diferente
Public DataProvider As String
Public Cnn As ADODB.Connection          ' La conexión para acceder a la base de datos
'
Global gNoCargar As Boolean             ' Poder seleccionar otra    (10/Nov/00)
                                        ' base sin procesar la línea de comandos
Global Const MaxApartados As Long = 7   ' Número máximo de apartados
Global asApartados() As String          ' Las imágenes de los apartados
Private pNumApartados As Long           ' Número de apartados       (07/Ago/00)

Global sClasif As String                ' orden de clasificación

Global NumCampos As Long                ' Numero de campos

Global elForm As gsNotas 'Form

' Tipo para los fields (campos) de la base de datos
Type Campo_t
    Nombre As String                    ' Name
    Tipo As Long                        ' Type
    Tamaño As Long                      ' Size
    Anterior As String                  ' Dato anterior
End Type
Global Campos() As Campo_t              ' Para el manejo de los campos
Global sSepFecha As String              ' El separador de las fechas

Global sFicIni As String                ' Fichero de configuración
Global sUsuario As String               ' Nombre del usuario actual
Global sBase As String                  ' Nombre de la base
Global sTabla As String                 ' Nombre de la tabla (10/Abr/97)

Public Function AjustarFecha(ByVal sFecha As String) As String
    ' Ajustar la cadena introducida a formato de fecha              (27/Abr/01)
    Dim i As Long
    Dim s As String
    '
    If sFecha = "" Then
        AjustarFecha = ""
        Exit Function
    End If
    '
    'On Error Resume Next
    On Error GoTo 0
    '
    ' Comprobar si se usan puntos como separador
    ' si es así, cambiarlos por /
    Do
        i = InStr(sFecha, ".")
        If i Then
            Mid$(sFecha, i, 1) = "/"
        End If
    Loop While i
    '
    ' Comprobar si se usan - como separador
    ' si es así, cambiarlos por /
    Do
        i = InStr(sFecha, "-")
        If i Then
            Mid$(sFecha, i, 1) = "/"
        End If
    Loop While i
    '
    s = ""
    Do
        i = InStr(sFecha, "/")
        If i Then
            s = s & Right$("0" & Left$(sFecha, i - 1), 2) & "/"
            sFecha = Mid$(sFecha, i + 1)
        End If
    Loop While i
    sFecha = s & sFecha
    '
    If InStr(sFecha, "/") Then
        If Len(sFecha) = 5 Then
            ' Si es igual a 5 caracteres, es que falta el año
            sFecha = sFecha & "/"
        ElseIf Len(sFecha) < 3 Then
            ' Si es menor de 3 caracteres es que falta el mes
            sFecha = sFecha & "/" & CStr(Month(Now)) & "/"
        End If
    ElseIf Len(sFecha) < 3 Then
        sFecha = sFecha & "/" & CStr(Month(Now)) & "/"
    Else
        s = ""
        For i = 1 To 2
            s = s & "/" & Mid$(sFecha, (i - 1) * 2 + 1, 2)
        Next
        s = s & "/" & Mid$(sFecha, 5)
        sFecha = s
    End If
    sFecha = Trim$(sFecha)
    '
    ' Comprobar si tiene una barra al principio, si es así, quitarla
    If Left$(sFecha, 1) = "/" Then
        sFecha = Mid$(sFecha, 2)
    End If
    ' Si tiene una barra al final, es que falta el año
    If Right$(sFecha, 1) = "/" Then
        sFecha = sFecha & CStr(Year(Now))
    End If
    '
    ' Convertir la fecha, por si no se especifican todos los caracteres
    ' Nota: Aquí puedes usar el formato que más te apetezca
    sFecha = Format$(sFecha, "dd/mm/yyyy")
    '
'    ' Si no es una fecha correcta...
'    If IsDate(sFecha) = False Then
'        AjustarFecha = sFecha
'    Else
'        AjustarFecha = sFecha
'    End If
    '
    Err = 0
    '
    AjustarFecha = sFecha
End Function

Public Property Get dbByte() As Long
    ' Devuelve el valor para un campo Byte, dependiendo del proveedor
    dbByte = adUnsignedTinyInt
End Property

Public Sub CrearConexion(ByRef Cnn As ADODB.Connection, _
                         Optional ByVal CrearSiempre As Boolean = False)
    ' Crear la conexión a la base de datos,                         (01/Oct/01)
    ' Se intenta conectar con la cadena de OLEDB.4.0, si da error,
    ' se intentará con OLEDB.3.51
    '
    ' Intentarlo primero con OLEDB.4.0 para que sea compatible con Access 2000
    If DataProvider = "" Then
        DataProvider = "Microsoft.Jet.OLEDB.4.0"
    End If
    '
    ' El nombre de la base ya está asignado en sBase
    '
    If Cnn Is Nothing Then
        CrearSiempre = True
    End If
    '
    If CrearSiempre Then
        ' Crear los objetos
        Set Cnn = New ADODB.Connection
        '
        On Error Resume Next
        '
        ' Para usar con password                                    (28/Ago/01)
        ' Probar primero con OLEDB.4.0                              (31/Ago/01)
        Cnn.Open "Provider=" & DataProvider & "; " & _
                 "Data Source=" & sBase & ";"
                 '& _
                 "Jet OLEDB:Database Password=xxx"
        If Err Then
            Err = 0
            DataProvider = "Microsoft.Jet.OLEDB.3.51"
            ' Si da error con el 4.0, probar con el 3.51            (31/Ago/01)
            Cnn.Open "Provider=" & DataProvider & "; " & _
                     "Data Source=" & sBase & ";"
                     '& _
                     "Jet OLEDB:Database Password=xxx"
            ' Si tampoco... avisar del error
            If Err Then
                MsgBox "ERROR al crear la conexión a la base de datos:" & vbCrLf & _
                       Err.Number & " " & Err.Description & vbCrLf & vbCrLf & _
                       "Toma nota del error y avisa a Guillermo."
            End If
        End If
        '
        Err = 0
    End If
End Sub

Public Property Get dbDate() As Long
    ' Devuelve el valor para un campo Date, es el mismo valor para todos los proveedores
    dbDate = adDate
End Property
Public Property Get dbText() As Long
    ' Devuelve el valor para un campo Text, dependiendo del proveedor
    Select Case DataProvider
    Case "Microsoft.Jet.OLEDB.3.51"
        dbText = adVarChar
    Case "Microsoft.Jet.OLEDB.4.0"
        dbText = adVarWChar
    End Select
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 Integer
    
    bPoner = False
    If Not IsMissing(sPoner) Then
        sCh = sPoner
        bPoner = True
    End If
    iLen = Len(sCaracter)
    
    i = 1
    Do While i <= Len(sValor)
        If Mid$(sValor, i, iLen) = sCaracter Then
            If bPoner Then
                sValor = Left$(sValor, i - 1) & sCh & Mid$(sValor, i + iLen)
                i = i - 1
            Else
                sValor = Left$(sValor, i - 1) & Mid$(sValor, i + iLen)
            End If
        End If
        i = i + 1
    Loop
    QuitarCaracterEx = sValor
End Function

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)
    '----------------------------------------------
    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)
        Else
            If bPoner Then
                sTmp = sTmp & sCh
            End If
        End If
    Next
    QuitarCaracter = sTmp
End Function

Public Sub SplitPath(ByVal sTodo As String, sPath As String, Optional vNombre, Optional vExt)
    '----------------------------------------------------------------
    'Divide el nombre recibido en la ruta, nombre y extensión
    '(c)Guillermo Som, 1997                         ( 1/Mar/97)
    '
    'Esta rutina aceptará los siguientes parámetros:
    'sTodo      Valor de entrada con la ruta completa
    'Devolverá la información en:
    'sPath      Ruta completa, incluida la unidad
    'vNombre    Nombre del archivo incluida la extensión
    'vExt       Extensión del archivo
    '
    'Los parámetros opcionales sólo se usarán si se han especificado
    '----------------------------------------------------------------
    Dim bNombre As Boolean      'Flag para saber si hay que devolver el nombre
    Dim i As Integer
    
    If Not IsMissing(vNombre) Then
        bNombre = True
        vNombre = sTodo
    End If
    
    If Not IsMissing(vExt) Then
        vExt = ""
        i = InStr(sTodo, ".")
        If i Then
            vExt = Mid$(sTodo, i + 1)
        End If
    End If
        
    sPath = ""
    'Asignar el path
    For i = Len(sTodo) To 1 Step -1
        If Mid$(sTodo, i, 1) = "\" Then
            sPath = Left$(sTodo, i - 1)
            'Si hay que devolver el nombre
            If bNombre Then
                vNombre = Mid$(sTodo, i + 1)
            End If
            Exit For
        End If
    Next
End Sub

Public Property Get NumApartados() As Long
    ' Devolver el número almacenado
    NumApartados = pNumApartados
End Property

Public Property Let NumApartados(ByVal NewValue As Long)
    ' Asignar el nuevo valor de apartados                           (07/Ago/00)
    ' Aquí se redimensionará el array con las imágenes
    If NewValue > MaxApartados Then NewValue = MaxApartados
    pNumApartados = NewValue
    If pNumApartados > 0 Then
        ReDim Preserve asApartados(0 To pNumApartados - 1)
    End If
End Property

Public Property Get dbMemo() As Long
    ' Devuelve el valor para un campo Memo, dependiendo del proveedor
    Select Case DataProvider
    Case "Microsoft.Jet.OLEDB.3.51"
        dbMemo = adLongVarChar
    Case "Microsoft.Jet.OLEDB.4.0"
        dbMemo = adLongVarWChar
    End Select
End Property

 

Módulos de clases:

 

cgsFileOP (colección de rutinas y funciones para manejo de ficheros, etc.)


'------------------------------------------------------------------------------
' Clase para entrada/salida de ficheros                             (27/Oct/97)
'
' Últimas revisiones:   13/Abr/98
'                       26/Dic/99
'                       17/Jul/00
'                       09/Feb/01
'                       04/Abr/01   Añadida la constante BIF_BROWSEINCLUDEFILES
'                       03/May/01   Añadida la función AppPath
'                       20/May/01   Añadida la función ShowPrinter y ShowColor
'                       24/May/01   Algunos retoques en ShowPrinter
'                       31/Jul/01   Nueva función: AppShow
'                       03/Ago/01   Nueva función: ExecCmdPipe
'                       26/Sep/01   Nuevas funciones de manejo de ficheros INI:
'                                   IniDeleteKey, IniDeleteSection, IniGet, IniGetSection,
'                                   IniGetSections, IniWrite
'                       09/Oct/01   Modificada el método NameFromFileName
'
' ©Guillermo 'guille' Som, 1997-2001 
'------------------------------------------------------------------------------
'
' Métodos añadidos el 03/Ago/2001:
'   ExecCmdPipe             Ejecutar un comando y capturar la salida del programa
'
' Métodos añadidos el 31/Jul/2001:
'   AppShow                 Activar la aplicación con el Caption indicado
'
' Métodos añadidos el 17/Jul/2000:
'   PathFromFileName        Devuelve sólo el path del fichero indicado
'   NameFromFileName        Devuelve el nombre y extensión de un fichero
'   ExtFromFileName         Devuelve la extensión del fichero indicado
'
' Métodos añadidos el 26/Dic/1999:
'   GetLongFilename         Convertir a un nombre largo
'   QuitarComillasDobles    Quitar las comillas dobles que haya en una cadena
'
'------------------------------------------------------------------------------
'La mayoría de los métodos están sacados de las Knowledge de Microsoft
'pero adaptados/mejorados por un servidor... 8-)
'------------------------------------------------------------------------------
'
'Esta clase incluye los siguientes métodos:
'                           Un archivo origen y/o uno de destino
'   FileCopy                para copiar
'   FileMove                para mover
'   FileRename              para renombrar
'
'   FileDelete              Sólo el archivo a borrar
'
'   FilesCopy               Varios archivos a un directorio
'   FilesMove               NOTA: el último valor será
'   FilesRename             el directorio de destino
'
'   FilesDelete             Uno varios archivos a borrar
'
'   FileExist               Comprueba si existe un archivo (no lo busca)
'   FolderExist             Comprueba si existe un directorio (no lo busca)
'
'   FileFind                Busca coincidencias de la especificación de archivo, en el directorio (opcional) indicado
'   FileFindAll             Devuelve una colección de archivos que coincidan con la especificación de búsqueda, NULL si no halla ninguno
'   FileFindCustom          Customiza la forma de buscar y lo que se debe buscar
'
'   FolderFind              Busca coincidencias de la carpeta
'   FolderFindAll           Devuelve una colección con todos los directorios que cumplan la especificación
'
'   FileRead o OpenFile     Lee un archivo y lo guarda en una cadena
'   FileSave o SaveFile     Graba el contenido de una cadena en un archivo
'   ShowOpen                Muestra el diálogo de abrir archivos
'   ShowSave                Muestra el diálogo de guardar archivos
'   ShowPrinter             Muestra el diálogo de Imprimir y seleccionar impresora
'   ShowColor               Muestra el diálogo de seleccionar colores
'
'   BrowseForFolder         Para seleccionar un directorio
'-  BrowseForFile
'
'   FileOperationDescription
'                           Devuelve una cadena con la descripción
'                           de la acción realizada, para usar con el evento Done
'
'Otros métodos:
'   AgregarALista           Añade a una lista una serie de archivos
'   AgregarAText            Añade a un textbox una serie de archivos, los separa por comas
'   QuitarCaracterEx        Quitar/cambiar caracteres de una cadena
'
'   ExecCmd                 Ejecuta un comando y espera a que termine
'   AddBackSlash            Añade \ a un nombre, si no la tiene
'   QuitarBackSlash         Quita el \ del path introducido...
'   RTrimNull               Devuelve una cadena normal de una cadena terminada en NULL
'
'   GetSetting              Leer de un archivo INI
'   SaveSetting             Escribir en un archivo INI
'
'   SplitPath               Divide una ruta en Path, File y Extensión
'   AddPath                 Añade el path indicado si no tiene
'
'Las propiedades son:
'   Flags
'   FilesOnly
'   NoConfirmation
'   NoConfirmMKDIR
'   RenameOnCollision
'   Silent
'   SimpleProgress
'
'   (además de las de los diálogos comunes, ver más abajo)
'
'Los eventos producidos serán:
'   Done                        Una vez terminada la operación
'--------------------------------------------------------------
Option Explicit
Option Compare Text

Public Color As Long
'
Public hDC As Long
Public FromPage As Long
Public ToPage As Long
Public MinPage As Long
Public MaxPage As Long
Public Copies As Long
'
Public Flags As eOFN

'Constantes para la operación realizada
Public Enum eFileOperation
    eFileCopy = 1
    eFileMove
    eFileRename
    eFileDelete
    eFileFindFirst
    eFileFindNext
    eFileExist
    eFolderExist
    eFileRead
    eFileSave
    eBrowseForFolder
    eFileFind
End Enum

'Indicará que ha terminado, el valor de error estará en Success
'el tipo de operación realizada en FileOperation
Public Event Done(ByVal Success As Long, ByVal FileOperation As eFileOperation)
'
'------------------------------------------------------------------------------
' Constantes
'------------------------------------------------------------------------------
'
'
'------------------------------------------------------------------------------
' 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 Long
    lpszTitle               As 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

'----------------------------------------------------------------
' cComDlg Clase para simular el control de Diálogos Comunes
'
' Primera tentativa:                            (04:57 25/Ago/97)
'
' Versión reducida Diálogos de Abrir y Guardar        (21/Oct/97)
'
' ©Guillermo 'guille' Som, 1997 
'----------------------------------------------------------------

Private 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

'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

'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
    'Constantes para FileOperation
    FO_COPY = &H2                         'Copiar
    FO_DELETE = &H3                       'Borrar
    FO_MOVE = &H1                         'Mover
    FO_RENAME = &H4                       'Renombrar
    '
    FOF_ALLOWUNDO = &H40                  'Permitir deshacer
    FOF_CONFIRMMOUSE = &H2                'No está implementada
    FOF_FILESONLY = &H80                  'Si se especifica *.*, hacerlo sólo con archivos
    FOF_MULTIDESTFILES = &H1              'Multiples archivos de destino
    FOF_NOCONFIRMATION = &H10             'No pedir confirmación
    FOF_NOCONFIRMMKDIR = &H200            'No confirmar la creación de directorios
    FOF_RENAMEONCOLLISION = &H8           'Cambiar el nombre si el archivo de destino ya existe
    FOF_SILENT = &H4                      'No mostrar el progreso
    FOF_SIMPLEPROGRESS = &H100            'No mostrar los nombres de los archivos
    FOF_WANTMAPPINGHANDLE = &H20          'Rellena el valor de hNameMappings
    '
    ' Constantes para ShowPrinter
    '
    '/* field selection bits */
    DM_ORIENTATION = &H1&
    DM_PAPERSIZE = &H2&
    DM_PAPERLENGTH = &H4&
    DM_PAPERWIDTH = &H8&
    DM_SCALE = &H10&
    '
    DM_DUPLEX = &H1000&
    '
    '#if(WINVER >= 0x0500)
    '#define DM_POSITION         0x00000020L
    '#endif /* WINVER >= 0x0500 */
    '#define DM_COPIES           0x00000100L
    '#define DM_DEFAULTSOURCE    0x00000200L
    '#define DM_PRINTQUALITY     0x00000400L
    '#define DM_COLOR            0x00000800L
    '#define DM_DUPLEX           0x00001000L
    '#define DM_YRESOLUTION      0x00002000L
    '#define DM_TTOPTION         0x00004000L
    '#define DM_COLLATE          0x00008000L
    '#define DM_FORMNAME         0x00010000L
    '#define DM_LOGPIXELS        0x00020000L
    '#define DM_BITSPERPEL       0x00040000L
    '#define DM_PELSWIDTH        0x00080000L
    '#define DM_PELSHEIGHT       0x00100000L
    '#define DM_DISPLAYFLAGS     0x00200000L
    '#define DM_DISPLAYFREQUENCY 0x00400000L
    '#if(WINVER >= 0x0400)
    '#define DM_ICMMETHOD        0x00800000L
    '#define DM_ICMINTENT        0x01000000L
    '#define DM_MEDIATYPE        0x02000000L
    '#define DM_DITHERTYPE       0x04000000L
    '#define DM_PANNINGWIDTH     0x08000000L
    '#define DM_PANNINGHEIGHT    0x10000000L
    '#endif /* WINVER >= 0x0400 */
    '
    PD_ALLPAGES = &H0
    PD_SELECTION = &H1
    PD_PAGENUMS = &H2
    PD_NOSELECTION = &H4
    PD_NOPAGENUMS = &H8
    PD_COLLATE = &H10
    PD_PRINTTOFILE = &H20
    PD_PRINTSETUP = &H40
    PD_NOWARNING = &H80
    PD_RETURNDC = &H100
    PD_RETURNIC = &H200
    PD_RETURNDEFAULT = &H400
    PD_SHOWHELP = &H800
    PD_ENABLEPRINTHOOK = &H1000
    PD_ENABLESETUPHOOK = &H2000
    PD_ENABLEPRINTTEMPLATE = &H4000
    PD_ENABLESETUPTEMPLATE = &H8000
    PD_ENABLEPRINTTEMPLATEHANDLE = &H10000
    PD_ENABLESETUPTEMPLATEHANDLE = &H20000
    PD_USEDEVMODECOPIES = &H40000
    PD_USEDEVMODECOPIESANDCOLLATE = &H40000
    PD_DISABLEPRINTTOFILE = &H80000
    PD_HIDEPRINTTOFILE = &H100000
    PD_NONETWORKBUTTON = &H200000
    '
End Enum

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

' Para esperar a que un proceso termine
Private Type STARTUPINFO
    cb                As Long
    lpReserved        As String
    lpDesktop         As String
    lpTitle           As String
    dwX               As Long
    dwY               As Long
    dwXSize           As Long
    dwYSize           As Long
    dwXCountChars     As Long
    dwYCountChars     As Long
    dwFillAttribute   As Long
    dwFlags           As Long
    wShowWindow       As Integer
    cbReserved2       As Integer
    lpReserved2       As Long
    hStdInput         As Long
    hStdOutput        As Long
    hStdError         As Long
End Type

Const STARTF_USESHOWWINDOW = &H1
Const STARTF_USESIZE = &H2
Const STARTF_USEPOSITION = &H4
Const STARTF_USECOUNTCHARS = &H8
Const STARTF_USEFILLATTRIBUTE = &H10
Const STARTF_RUNFULLSCREEN = &H20              '// ignored for non-x86 platforms
Const STARTF_FORCEONFEEDBACK = &H40
Const STARTF_FORCEOFFFEEDBACK = &H80
Const STARTF_USESTDHANDLES = &H100
'#if(WINVER >= 0x0400)
'Const STARTF_USEHOTKEY = &H200
'#endif /* WINVER >= 0x0400 */

'/*
' * ShowWindow() Commands
' */
Public Enum eSW
    SW_HIDE = 0
    SW_SHOWNORMAL = 1
    SW_NORMAL = 1
    SW_SHOWMINIMIZED = 2
    SW_SHOWMAXIMIZED = 3
    SW_MAXIMIZE = 3
    SW_SHOWNOACTIVATE = 4
    SW_SHOW = 5
    SW_MINIMIZE = 6
    SW_SHOWMINNOACTIVE = 7
    SW_SHOWNA = 8
    SW_RESTORE = 9
    SW_SHOWDEFAULT = 10
    SW_MAX = 10
End Enum
'
Private Declare Function FindWindow Lib "user32.dll" Alias "FindWindowA" _
    (ByVal lpClassName As String, ByVal lpWindowName As String) As Long
Private Declare Function SetForegroundWindow Lib "user32.dll" _
    (ByVal hWnd As Long) As Long
'
Private Declare Function ShowWindow Lib "user32.dll" _
    (ByVal hWnd As Long, ByVal nCmdShow As Long) As Long

'
Private Type PROCESS_INFORMATION
    hProcess          As Long
    hThread           As Long
    dwProcessID       As Long
    dwThreadID        As Long
End Type

Private Declare Function WaitForSingleObject Lib "kernel32" _
    (ByVal hHandle As Long, ByVal dwMilliseconds As Long) As Long

Private Declare Function CreateProcessA Lib "kernel32" _
    (ByVal lpApplicationName As Long, ByVal lpCommandLine As String, _
    ByVal lpProcessAttributes As Long, ByVal lpThreadAttributes As Long, _
    ByVal bInheritHandles As Long, ByVal dwCreationFlags As Long, _
    ByVal lpEnvironment As Long, ByVal lpCurrentDirectory As Long, _
    lpStartupInfo As STARTUPINFO, lpProcessInformation As PROCESS_INFORMATION) As Long

Private Declare Function CloseHandle Lib "kernel32" _
    (ByVal hObject As Long) As Long

Private Const NORMAL_PRIORITY_CLASS = &H20&
Private Const INFINITE = -1&

Private Declare Function OpenProcess Lib "kernel32" _
    (ByVal dwDesiredAccess As Long, ByVal bInheritHandle As Long, _
    ByVal dwProcessID As Long) As Long
Private Declare Function GetExitCodeProcess Lib "kernel32" _
    (ByVal hProcess As Long, lpExitCode As Long) As Long
Private Declare Sub Sleep Lib "kernel32" _
    (ByVal dwMilliseconds As Long)

Const STILL_ACTIVE = &H103
Const PROCESS_QUERY_INFORMATION = &H400

'Tipos de datos y funciones para FindFirstFile y FindNextFile
Private Type FILETIME
    dwLowDateTime       As Long
    dwHighDateTime      As Long
End Type

Private Type WIN32_FIND_DATA
    dwFileAttributes    As Long
    ftCreationTime      As FILETIME
    ftLastAccessTime    As FILETIME
    ftLastWriteTime     As FILETIME
    nFileSizeHigh       As Long
    nFileSizeLow        As Long
    dwReserved0         As Long
    dwReserved1         As Long
    cFileName           As String * MAX_PATH
    cAlternate          As String * 14
End Type

Private Declare Function FindFirstFile Lib "kernel32" Alias "FindFirstFileA" _
    (ByVal lpFileName As String, lpFindFileData As WIN32_FIND_DATA) As Long
Private Declare Function FindNextFile Lib "kernel32" Alias "FindNextFileA" _
    (ByVal hFindFile As Long, lpFindFileData As WIN32_FIND_DATA) As Long
Private Declare Function FindClose Lib "kernel32" _
    (ByVal hFindFile As Long) As Long

Const INVALID_HANDLE_VALUE = -1

'------------------------------------------------------------------------------
' Funciones del API para leer ficheros INI                          (26/Sep/01)
'------------------------------------------------------------------------------
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

'------------------------------------------------------------------------------
'' Declaraciones para leer ficheros 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
'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
'------------------------------------------------------------------------------

' data buffer for the PrintDlg function
Private Type PRINTDLGT
    lStructSize As Long
    hwndOwner As Long
    hDevMode As Long
    hDevNames As Long
    hDC As Long
    Flags As Long
    nFromPage As Integer
    nToPage As Integer
    nMinPage As Integer
    nMaxPage As Integer
    nCopies As Integer
    hInstance As Long
    lCustData As Long
    lpfnPrintHook As Long
    lpfnSetupHook As Long
    lpPrintTemplateName As String
    lpSetupTemplateName As String
    hPrintTemplate As Long
    hSetupTemplate As Long
End Type
' API function called by ShowPrint method
Private Declare Function PrintDlg Lib "comdlg32.dll" Alias "PrintDlgA" (pPrintdlg As PRINTDLGT) As Long

' data buffer for the ChooseColor function
Private Type CHOOSECOLORT
    lStructSize As Long
    hwndOwner As Long
    hInstance As Long
    rgbResult As Long
    lpCustColors As Long
    Flags As Long
    lCustData As Long
    lpfnHook As Long
    lpTemplateName As String
End Type
' API function called by ChooseColor method
Private Declare Function ChooseColor Lib "comdlg32.dll" Alias "ChooseColorA" (pChoosecolor As CHOOSECOLORT) As Long

' constants for API memory functions
Private Const GMEM_MOVEABLE = &H2
Private Const GMEM_ZEROINIT = &H40
Private Const GHND = (GMEM_MOVEABLE Or GMEM_ZEROINIT)
' API memory functions
Private Declare Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" _
    (Destination As Any, Source As Any, ByVal Length As Long)
Private Declare Function GlobalAlloc Lib "kernel32" (ByVal wFlags As Long, ByVal dwBytes As Long) As Long
Private Declare Function GlobalFree Lib "kernel32" (ByVal hMem As Long) As Long
Private Declare Function GlobalLock Lib "kernel32" (ByVal hMem As Long) As Long
Private Declare Function GlobalUnlock Lib "kernel32" (ByVal hMem As Long) As Long
'
Const CCHDEVICENAME = 32
Const CCHFORMNAME = 32
Private Type DEVMODE_TYPE
    dmDeviceName As String * CCHDEVICENAME
    dmSpecVersion As Integer
    dmDriverVersion As Integer
    dmSize As Integer
    dmDriverExtra As Integer
    dmFields As Long
    dmOrientation As Integer
    dmPaperSize As Integer
    dmPaperLength As Integer
    dmPaperWidth As Integer
    dmScale As Integer
    dmCopies As Integer
    dmDefaultSource As Integer
    dmPrintQuality As Integer
    dmColor As Integer
    dmDuplex As Integer
    dmYResolution As Integer
    dmTTOption As Integer
    dmCollate As Integer
    dmFormName As String * CCHFORMNAME
    dmUnusedPadding As Integer
    dmBitsPerPel As Integer
    dmPelsWidth As Long
    dmPelsHeight As Long
    dmDisplayFlags As Long
    dmDisplayFrequency As Long
End Type
'Public DevMode As DEVMODE_TYPE
Private mDevMode As DEVMODE_TYPE

Private Type DEVNAMES_TYPE
    wDriverOffset As Integer
    wDeviceOffset As Integer
    wOutputOffset As Integer
    wDefault As Integer
    extra As String * 100
End Type

'------------------------------------------------------------------------------
' Para capturar la salida dirigida a StdOut y StdError              (03/Ago/01)
'------------------------------------------------------------------------------
'This example illustrates a Visual Basic application starting
'another process with the purpose of redirecting that process's
'standard IO handles.
'The Visual Basic application redirects the created process's
'standard output handle to an anonymous pipe,
'then proceeds to read the output through the pipe.
'This sample just redirects STDOUT of the new process.
'
'To redirect other handles (STDIN and STDERR),
'create a pipe for each handle for which redirection is desired.
'The Visual Basic application would read from the read ends
'of the pipes for the redirected STDOUT and STDERR.
'If STDIN redirection was desired, the Visual Basic application
'would write to the write end of the appropriate pipe.
'
'An example follows:
'
'
'   'A pipe for redirection of STDOUT
'   CreatePipe(hReadPipe1, hWritePipe1, sa, 0)
'
'   'A pipe for redirection of STDERR
'   CreatePipe(hReadPipe2, hWritePipe2, sa, 0)
'
'   'A pipe for redirection of STDIN
'   CreatePipe(hReadPipe3, hWritePipe3, sa, 0)
'
'   'Preparing to start the process with redirected handles
'   start.hStdOutput = hWritePipe1
'   start.hStdError = hWritePipe2
'   start.hStdInput = hReadPipe3
'
'   'Reading output from the started process's STDOUT
'   ReadFile(hReadPipe1, mybuff1, 100, bytesread, ByVal 0&)
'
'   'Reading output from the started process's STDERR
'   ReadFile(hReadPipe2, mybuff2, 100, bytesread, ByVal 0&)
'
'   'Writing to the started process's STDIN
'   WriteFile(hWritePipe3, mybuff3, 100, byteswritten, ByVal 0&)
'
    
Private Type SECURITY_ATTRIBUTES
    nLength As Long
    lpSecurityDescriptor As Long
    bInheritHandle As Long
End Type
'Private Type STARTUPINFO
'    cb As Long
'    lpReserved As Long
'    lpDesktop As Long
'    lpTitle As Long
'    dwX As Long
'    dwY As Long
'    dwXSize As Long
'    dwYSize As Long
'    dwXCountChars As Long
'    dwYCountChars As Long
'    dwFillAttribute As Long
'    dwFlags As Long
'    wShowWindow As Integer
'    cbReserved2 As Integer
'    lpReserved2 As Long
'    hStdInput As Long
'    hStdOutput As Long
'    hStdError As Long
'End Type

'Private Type PROCESS_INFORMATION
'    hProcess As Long
'    hThread As Long
'    dwProcessID As Long
'    dwThreadID As Long
'End Type

Private Declare Function CreateProcessAny Lib "kernel32" Alias "CreateProcessA" _
    (ByVal lpApplicationName As Long, ByVal lpCommandLine As String, _
    lpProcessAttributes As Any, lpThreadAttributes As Any, _
    ByVal bInheritHandles As Long, ByVal dwCreationFlags As Long, _
    ByVal lpEnvironment As Long, ByVal lpCurrentDirectory As Long, _
    lpStartupInfo As Any, lpProcessInformation As Any) As Long

'Private Declare Function CloseHandle Lib "kernel32" (ByVal _
   hObject As Long) As Long

'Private Declare Function WaitForSingleObject Lib "kernel32" _
    (ByVal hHandle As Long, ByVal dwMilliseconds As Long) As Long

'Private Const NORMAL_PRIORITY_CLASS = &H20&
'Private Const STARTF_USESTDHANDLES = &H100&
'
'Private Const SW_SHOWMINNOACTIVE = 7
'Private Const STARTF_USESHOWWINDOW = &H1
'Private Const INFINITE = -1&

Private Declare Function CreatePipe Lib "kernel32" _
    (phReadPipe As Long, phWritePipe As Long, _
    lpPipeAttributes As Any, ByVal nSize As Long) As Long

'Private Declare Function WriteFile Lib "kernel32" ( _
    ByVal hFile As Long, _
    ByVal lpBuffer As String, _
    ByVal nNumberOfBytesToWrite As Long, _
    lpNumberOfBytesWritten As Long, _
    ByVal lpOverlapped As Any) As Long

Private Declare Function ReadFile Lib "kernel32" _
    (ByVal hFile As Long, ByVal lpBuffer As String, _
    ByVal nNumberOfBytesToRead As Long, lpNumberOfBytesRead As Long, _
    ByVal lpOverlapped As Any) As Long

Public Function ExecCmdPipe(ByVal CmdLine As String) As String
    '--------------------------------------------------------------------------
    ' Ejecuta el comando indicado, espera a que termine
    ' se devuelve la salida normal así como la de error
    '--------------------------------------------------------------------------
    Dim proc As PROCESS_INFORMATION
    Dim ret As Long, bSuccess As Long
    Dim start As STARTUPINFO
    Dim sa As SECURITY_ATTRIBUTES
    Dim hReadPipe As Long, hWritePipe As Long
    Dim bytesread As Long, mybuff As String
    '
    Dim sReturnStr As String
    '
    '=== Longitud de la cadena, en teoría 64 KB,
    '   pero no en la práctica
    'mybuff = String(64 * 1024, Chr$(65))
    ' Con 10KB hay más que suficiente
    mybuff = String(10 * 1024, Chr$(65))
    '
    sa.nLength = Len(sa)
    sa.bInheritHandle = 1&
    sa.lpSecurityDescriptor = 0&
    ret = CreatePipe(hReadPipe, hWritePipe, sa, 0)
    If ret = 0 Then
        '===Error
        ExecCmdPipe = "Error: CreatePipe failed. " & Err.LastDllError
        Exit Function
    End If
    start.cb = Len(start)
    'start.dwFlags = STARTF_USESTDHANDLES
    start.hStdOutput = hWritePipe
    ' Si se produce error, usar el mismo "pipe" que para escribir
    start.hStdError = hWritePipe
    start.dwFlags = STARTF_USESTDHANDLES + STARTF_USESHOWWINDOW
    start.wShowWindow = SW_SHOWMINNOACTIVE
    '
    ' Start the shelled application:
    ret = CreateProcessAny(0&, CmdLine, sa, sa, 1&, _
                    NORMAL_PRIORITY_CLASS, 0&, 0&, start, proc)
    If ret <> 1 Then
        '===Error
        sReturnStr = "Error: CreateProcess failed. " & Err.LastDllError
    End If
    '
    ' Wait for the shelled application to finish:
    ret = WaitForSingleObject(proc.hProcess, INFINITE)
    '
    ' Si la aplicación acaba con error...                           (03/Ago/01)
    ' se queda colgado en esta llamada...
    ' ¡SOLUCIONADO!                                                 (03/Ago/01)
    ' He asignado a hStdError el mismo handle que a hStdOutput
    bSuccess = ReadFile(hReadPipe, mybuff, Len(mybuff), bytesread, 0&)
    If bSuccess = 1 Then
        sReturnStr = Left(mybuff, bytesread)
    Else
        '===Error
        sReturnStr = "Error: ReadFile failed. " & Err.LastDllError
    End If
    ret = CloseHandle(proc.hProcess)
    ret = CloseHandle(proc.hThread)
    ret = CloseHandle(hReadPipe)
    ret = CloseHandle(hWritePipe)
    '
    ExecCmdPipe = sReturnStr
End Function

Public Sub AppShow(ByVal sCaption As String, _
                   Optional ByVal nCmdShow As eSW = SW_RESTORE)
    '
    ' Activar la aplicación con el Caption indicado                 (31/Jul/01)
    '
    Dim lhWnd       As Long
    Dim sClassName  As String
    '
    lhWnd = FindWindow(sClassName, sCaption)
    If lhWnd Then
        Call SetForegroundWindow(lhWnd)
        '
        Call ShowWindow(lhWnd, nCmdShow)
        '
    End If
End Sub

Public Function QuitarComillasDobles(ByVal sFic As String) As String
    Dim i As Long, j As Long

    ' Si tiene comillas dobles, quitárselas                         (26/Dic/99)
    Do
        i = InStr(sFic, Chr$(34))
        If i Then
            j = InStr(i + 1, sFic, Chr$(34))
            If j = 0 Then
                j = Len(sFic) + 1
            End If
            If j Then
                sFic = Left$(sFic, i - 1) & Mid$(sFic, i + 1, j - (i + 1)) & Mid$(sFic, j + 1)
            End If
        Else
            Exit Do
        End If
    Loop

    QuitarComillasDobles = sFic
End Function

Public Function GetLongFilename(ByVal sShortName As String) As String
    ' Convertir un Path corto en otro largo                         (26/Dic/99)
    '
    ' HOWTO: Get a Long Filename from a Short Filename (Article ID: Q163227)
    '
    Dim sLongName As String
    Dim sTemp As String
    Dim iSlashPos As Integer

    ' Add \ to short name to prevent Instr from failing
    sShortName = sShortName & "\"

    ' Start from 4 to ignore the "[Drive Letter]:\" characters
    'If InStr(sShortName, ":\") Then
        iSlashPos = InStr(4, sShortName, "\")
    'Else
    '    ' Comprobar si es un path UNC
    'End If

    ' Pull out each string between \ character for conversion
    While iSlashPos
        sTemp = Dir$(Left$(sShortName, iSlashPos - 1), vbNormal + vbHidden + vbSystem + vbDirectory)
        If sTemp = "" Then
            'Error 52 - Bad File Name or Number
            GetLongFilename = ""
            Exit Function
        End If
        sLongName = sLongName & "\" & sTemp
        iSlashPos = InStr(iSlashPos + 1, sShortName, "\")
    Wend

    ' Prefix with the drive letter
    GetLongFilename = Left$(sShortName, 2) & sLongName
End Function

Public Sub IniDelete(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

    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 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

Public Sub SaveSetting(ByVal lpFileName As String, ByVal lpAppName As String, ByVal lpKeyName As String, ByVal lpString As String)
    'Guarda los datos de configuración
    'Los parámetros son los mismos que en LeerIni
    'Siendo lpString el valor a guardar
    '
    Dim LTmp As Long

    LTmp = WritePrivateProfileString(lpAppName, lpKeyName, lpString, lpFileName)
End Sub

Public Function GetSetting(ByVal lpFileName As String, ByVal lpAppName As String, ByVal lpKeyName As String, Optional ByVal vDefault As Variant) As String
    'Nota 14/Abr/98,    antes el valor devuelto era Variant
    '                   Lo he cambiado para compatibilizarlo
    '                   con LeerIni
    '
    'Los parámetros son:
    'lpFileName:    La Aplicación (fichero INI)
    'lpAppName:     La sección que suele estar entrre corchetes
    'lpKeyName:     Clave
    'vDefault:      Valor opcional que devolverá
    '               si no se encuentra la clave.
    '
    Dim lpString As String
    Dim LTmp As Long
    Dim sRetVal As String

    'Si no se especifica el valor por defecto,
    'asignar incialmente una cadena vacía
    If IsMissing(vDefault) Then
        lpString = ""
    Else
        lpString = CStr(vDefault)
    End If

    sRetVal = String$(255, 0)

    LTmp = GetPrivateProfileString(lpAppName, lpKeyName, lpString, sRetVal, Len(sRetVal), lpFileName)
    If LTmp = 0 Then
        GetSetting = lpString
    Else
        GetSetting = Left(sRetVal, LTmp)
    End If
End Function

Private Function FindAllFiles(ByVal sFile As String, ByVal sPath As String, colAllFiles As Variant, ByVal bSubDirs As Boolean, ByVal bOnlyOne As Boolean, ByVal bOnlyDir As Boolean) As Boolean
    '
    Static sFileName As String
    Static WFD As WIN32_FIND_DATA
    Dim hFindFile As Long
    Dim ret As Long

    'Si no se indica el directorio, se usa el actual
    sPath = AddBackSlash(sPath)
    'Buscar la primera coincidencia
    hFindFile = FindFirstFile(sPath & "*.*", WFD)
    ret = (hFindFile <> INVALID_HANDLE_VALUE)
    DoEvents
    Do While ret
        sFileName = RTrimNull(WFD.cFileName)
        'Ajustar el nuevo valor del path
        ' No examinar . ni ..
        If Left$(sFileName, 1) <> "." Then
            'Si es un directorio
            If WFD.dwFileAttributes And vbDirectory Then
                'Si sólo se buscan directorios
                If bOnlyDir Then
                    If (sFileName Like sFile) Then
                        If TypeOf colAllFiles Is Collection Then
                            colAllFiles.Add AddBackSlash(sPath) & sFileName
                        Else
                            colAllFiles.AddItem AddBackSlash(sPath) & sFileName
                        End If
                        If bOnlyOne Then
                            FindAllFiles = True
                            Exit Function
                        End If
                    End If
                End If
                'Si NO es un directorio oculto y del sistema (¿Recycled?)
                If Not (WFD.dwFileAttributes = vbDirectory + vbSystem + vbHidden) Then
                    'Comprobar si hay que continuar
                    If bSubDirs Then
                        FindAllFiles = FindAllFiles(sFile, sPath & sFileName, colAllFiles, bSubDirs, bOnlyOne, bOnlyDir)
                        If FindAllFiles Then Exit Function
                    Else
                        If bOnlyDir Then
                            FindAllFiles = True
                            Exit Function
                        End If
                    End If
                End If
            Else
                'Añadirlo a la colección si coincide
                'con el tipo solicitado
                If (sFileName Like sFile) Then
                    If TypeOf colAllFiles Is Collection Then
                        colAllFiles.Add AddBackSlash(sPath) & sFileName
                    Else
                        colAllFiles.AddItem AddBackSlash(sPath) & sFileName
                    End If
                    If bOnlyOne Then
                        FindAllFiles = True
                        Exit Function
                    End If
                End If
            End If
        End If
        'continuar buscando archivos
        ret = FindNextFile(hFindFile, WFD)
    Loop
    ret = FindClose(hFindFile)
End Function

Public Sub ExecCmdWithFocus(ByVal CmdLine As String)
    'Esperar a que un proceso termine,
    'la ventana se mostrará en primer plano con foco
    '
    Dim tProc As PROCESS_INFORMATION
    Dim tStart As STARTUPINFO
    Dim ret&

    ' Initialize the STARTUPINFO structure:
    tStart.cb = Len(tStart)
    'Start.dwFlags = STARTF_USESHOWWINDOW
    'Start.wShowWindow = SW_SHOWMINNOACTIVE

    ' Start the shelled application:
    ret = CreateProcessA(0&, CmdLine$, 0&, 0&, 1&, _
        NORMAL_PRIORITY_CLASS, 0&, 0&, tStart, tProc)

    ' Wait for the shelled application to finish:
    ret = WaitForSingleObject(tProc.hProcess, INFINITE)
    ret = CloseHandle(tProc.hProcess)
End Sub

Public Sub ExecCmd(ByVal CmdLine As String, Optional vNoFocus As Boolean = True)
    'Ejecutar un comando y esperar a que termine
    '
    'Parámetros:
    '   CmdLine
    '   vNoFocus    Si es False se ejecuta con foco
    '               Si es True  se ejecuta sin foco (valor por defecto)
    '
    '---------------------------------------------------------
    'NOTA: Si se va a enviar un comando del DOS, se debe usar
    'con Command /C 
    'sino, no se cerrará la ventana y el proceso no terminará
    '---------------------------------------------------------
    If vNoFocus Then
        ExecCmdNoFocus CmdLine
    Else
        ExecCmdWithFocus CmdLine
    End If
End Sub

Public Sub ExecCmdNoFocus(ByVal CmdLine As String, Optional ByVal bConShell As Boolean = True)
    'Esperar a que un proceso termine,
    'la ventana se mostrará minimizada sin foco
    Dim hProcess As Long
    Dim RetVal As Long

    'Usando el Id del proceso de la orden Shell
    If bConShell Then
        'The next line launches CmdLine as icon,
        'captures process ID
        hProcess = OpenProcess(PROCESS_QUERY_INFORMATION, False, Shell(CmdLine, vbMinimizedNoFocus))
        'hProcess = OpenProcess(PROCESS_QUERY_INFORMATION, False, Shell(CmdLine, vbHide))
        Do
            'Get the status of the process
            GetExitCodeProcess hProcess, RetVal
            'Sleep command recommended as well
            'as DoEvents
            DoEvents
            Sleep 100
        'Loop while the process is active
        Loop While RetVal = STILL_ACTIVE
    Else
        'Esperar a que un proceso termine,
        'la ventana se mostrará en primer plano con foco
        '
        Dim tProc As PROCESS_INFORMATION
        Dim tStart As STARTUPINFO

        ' Initialize the STARTUPINFO structure:
        tStart.cb = Len(tStart)
        tStart.dwFlags = STARTF_USESHOWWINDOW
        tStart.wShowWindow = SW_SHOWMINNOACTIVE

        ' Start the shelled application:
        RetVal = CreateProcessA(0&, CmdLine$, 0&, 0&, 1&, _
            NORMAL_PRIORITY_CLASS, 0&, 0&, tStart, tProc)

        ' Wait for the shelled application to finish:
        RetVal = WaitForSingleObject(tProc.hProcess, INFINITE)
        RetVal = CloseHandle(tProc.hProcess)
    End If
End Sub

Public Sub AgregarAText(ByVal sArchivos As String, queControl As Object, Optional ByVal vSeparador As Variant)
    ' Agregar los archivos indicados al control indicado
    ' Parámetros:
    '   sArchivos       Los archivos estarán separados por
    '                   espacios y dentro de comillas
    '                   o simplemente será un archivo
    '   queControl      Será cualquier control que acepte una cadena
    '                   en la propiedad predeterminada
    '   vSeparador      Separador a usar entre cada nombre de archivo
    '
    ' La cambios realizados en el tratamiento de las comillas,
    ' están copiados de las modificaciones que hice a AgregarALista en Dic/99
    '
    Dim i As Long, j As Long
    Dim sTmp As String, sDir As String
    'Dim colArchivos As New Collection
    Dim colArchivos As Collection
    Dim sSeparador As String
    '
    sArchivos = Trim$(sArchivos)
    If Len(sArchivos) = 0 Then Exit Sub
    '
    Set colArchivos = New Collection

    If IsMissing(vSeparador) Then
        sSeparador = " "
    Else
        sSeparador = CStr(vSeparador)
    End If

    ' Si hay varios ficheros,                                       (09/Feb/01)
    ' irán separados por comillas, espacio, comillas
    If InStr(sArchivos, Chr$(34) & " " & Chr$(34)) Then
    'If InStr(sArchivos, Chr$(34)) Then
        ' hay comillas, es que hay varios archivos
        j = 0
        Do While Len(sArchivos)
            Do While Left$(sArchivos, 1) = Chr$(34)
                sArchivos = Trim$(Mid$(sArchivos, 2))
            Loop
            i = InStr(sArchivos, Chr$(34))
            If i Then
                sTmp = Left$(sArchivos, i - 1)
                sArchivos = Trim$(Mid$(sArchivos, i + 1))
                If j Then
                    ' Si ya tiene el nombre del directorio          (09/Feb/01)
                    If InStr(sTmp, ":\") Then
                        colArchivos.Add sTmp
                    Else
                        colArchivos.Add sDir & sTmp
                    End If
                Else
                    'El primer parámetro es el directorio
                    j = j + 1
                    sDir = sTmp
                    'Si no tiene la barra ponersela
                    If Right$(sDir, 1) <> "\" Then
                        sDir = sDir & "\"
                    End If
                End If
            Else
                Exit Do
            End If
        Loop
        If Len(sArchivos) Then
            ' Si ya tiene el nombre del directorio                  (09/Feb/01)
            If InStr(sArchivos, ":\") Then
                colArchivos.Add sArchivos
            Else
                colArchivos.Add sDir & sArchivos
            End If
        End If
        'Por si sólo se selecciona un archivo
        If colArchivos.Count = 0 Then
            colArchivos.Add sTmp
        End If
    ElseIf InStr(sArchivos, Chr$(34) & " " & Chr$(34)) = 0 Then    '(09/Feb/01)
        ' Quitar las comillas y añadirlo
        colArchivos.Add QuitarComillasDobles(sArchivos)
    Else
        'no hay comillas, es sólo un archivo
        colArchivos.Add sArchivos
    End If

    'Asignar los datos anteriores
    sTmp = Trim$(queControl)
    If Len(sTmp) Then
        If Right$(RTrim$(sTmp), 1) <> sSeparador Then
            sTmp = sTmp & sSeparador
        End If
    End If
    For i = colArchivos.Count To 1 Step -1
        If i > 1 Then
            sTmp = sTmp & colArchivos(i) & sSeparador
        Else
            sTmp = sTmp & colArchivos(i)
        End If
    Next
    queControl = sTmp

    Set colArchivos = Nothing
End Sub

Public Sub AgregarALista(ByVal sArchivos As String, _
                         queControl As Object, _
                         Optional ByVal bAlPrincipio As Boolean = False)
    'Agregar los archivos indicados a la lista
    'Parámetros:
    '   sArchivos       Los archivos estarán separados por
    '                   espacios y dentro de comillas
    '                   o simplemente será un archivo
    '   queControl      será un List o un Combo
    '   vAlPrincipio    si True se añade al principio de la lista
    '
    Dim i&, j&
    Dim sTmp$, sDir$
    'Dim bAlPrincipio As Boolean
    Dim colArchivos As Collection

    sArchivos = Trim$(sArchivos)
    If Len(sArchivos) = 0 Then Exit Sub

    Set colArchivos = New Collection

    'If IsMissing(vAlPrincipio) Then
    '    bAlPrincipio = False
    'Else
    '    bAlPrincipio = CBool(vAlPrincipio)
    'End If

    ' Si hay varios ficheros,                                       (26/Dic/99)
    ' irán separados por comillas, espacio, comillas
    If InStr(sArchivos, Chr$(34) & " " & Chr$(34)) Then
    'If InStr(sArchivos, Chr$(34)) Then
        ' Hay comillas, es que hay varios archivos...
        ' o no...
        j = 0
        Do While Len(sArchivos)
            Do While Left$(sArchivos, 1) = Chr$(34)
                sArchivos = Trim$(Mid$(sArchivos, 2))
            Loop
            i = InStr(sArchivos, Chr$(34))
            If i Then
                sTmp = Left$(sArchivos, i - 1)
                sArchivos = Trim$(Mid$(sArchivos, i + 1))
                If j Then
                    ' Si ya tiene el nombre del directorio          (15/May/99)
                    If InStr(sTmp, ":\") Then
                        colArchivos.Add sTmp
                    Else
                        colArchivos.Add sDir & sTmp
                    End If
                Else
                    'El primer parámetro es el directorio
                    j = j + 1
                    sDir = sTmp
                    'Si no tiene la barra ponersela
                    If Right$(sDir, 1) <> "\" Then
                        sDir = sDir & "\"
                    End If
                End If
            Else
                Exit Do
            End If
        Loop
        If Len(sArchivos) Then
            ' Si ya tiene el nombre del directorio                  (15/May/99)
            If InStr(sArchivos, ":\") Then
                colArchivos.Add sArchivos
            Else
                colArchivos.Add sDir & sArchivos
            End If
        End If
        'Por si sólo se selecciona un archivo
        If colArchivos.Count = 0 Then
            colArchivos.Add sTmp
        End If
    ElseIf InStr(sArchivos, Chr$(34) & " " & Chr$(34)) = 0 Then    '(26/Dic/99)
        ' Quitar las comillas y añadirlo
        colArchivos.Add QuitarComillasDobles(sArchivos)
    Else
        'no hay comillas, es sólo un archivo
        colArchivos.Add sArchivos
    End If

    For i = colArchivos.Count To 1 Step -1
        If bAlPrincipio Then
            queControl.AddItem colArchivos(i), 0
        Else
            queControl.AddItem colArchivos(i)
        End If
    Next

    Set colArchivos = Nothing
End Sub

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
    '
    'On Error GoTo 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
        '
        ' Indicar el tamaño máximo de los ficheros seleccionados    (09/Feb/01)
        ' el máximo de cada fichero individual es de 260
        .nMaxFile = 260 * 20 '260
        .lpstrFile = Left$(FileName & String$(.nMaxFile, 0), .nMaxFile)
        '.lpstrFile = Left$(FileName & String$(260, 0), 260)
        '
        .nFileOffset = 0
        .nFileExtension = 0
        .lpstrDefExt = DefaultExt
        .lpstrFileTitle = Left$(FileTitle & String$(260, 0), 260)
        .nMaxFileTitle = 260
        .lpstrInitialDir = Left$(InitDir & String$(260, 0), 260)
        '
        '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
        If InitDir = """" Then InitDir = ""
    Else
        If CancelError Then
            'Err.Raise 32755, "cComDlg.ShowOpen", "Error en Abrir (clase cComDlg)"
            With Err
                .Source = "cgsFileOp.ShowOpen"
                .Number = 32755
                .Description = "Error en ShowOpen..."
            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
            'Err.Raise 32755, "cComDlg.ShowSave", "Error en Guardar como... (clase cComDlg)"
            With Err
                .Source = "cgsFileOp.ShowSave"
                .Number = 32755
                .Description = "Error en ShowSave..."
            End With
        End If
    End If
    'Devuelve True si se puede abrir
    ShowSave = (resultado <> 0)
End Function

Public Function ShowPrinter() As Boolean
    ' Código para seleccionar de la impresora, etc tomado de:       (13/Mar/01)
    ' PRB: Working with Print Dialog and Printer Object under NT 4.0
    ' Article ID: Q173981
    '
    Dim tPrintDlg As PRINTDLGT
    'Dim mDevMode As mDevMode_TYPE
    Dim DevName As DEVNAMES_TYPE
    '
    Dim lpDevMode As Long, lpDevName As Long
    Dim bReturn As Long 'Integer
    Dim objPrinter As Printer, NewPrinterName As String
    Dim strSetting As String
    Dim resultado As Long
    '
    ' Use PrintDialog to get the handle to a memory
    ' block with a mDevMode and DevName structures
    '
    tPrintDlg.lStructSize = Len(tPrintDlg)
    tPrintDlg.hwndOwner = Me.hWnd
    '
    tPrintDlg.Flags = Flags
    '
    'Set the current orientation and duplex setting
    mDevMode.dmDeviceName = Printer.DeviceName
    mDevMode.dmSize = Len(mDevMode)
    mDevMode.dmFields = DM_ORIENTATION Or DM_DUPLEX Or DM_PAPERSIZE
    mDevMode.dmOrientation = Printer.Orientation
    On Error Resume Next
    mDevMode.dmDuplex = Printer.Duplex
    On Error GoTo 0
    '
    'Allocate memory for the initialization hmDevMode structure
    'and copy the settings gathered above into this memory
    tPrintDlg.hDevMode = GlobalAlloc(GMEM_MOVEABLE Or GMEM_ZEROINIT, Len(mDevMode))
    lpDevMode = GlobalLock(tPrintDlg.hDevMode)
    If lpDevMode > 0 Then
        CopyMemory ByVal lpDevMode, mDevMode, Len(mDevMode)
        bReturn = GlobalUnlock(tPrintDlg.hDevMode)
    End If
    '
    'Set the current driver, device, and port name strings
    With DevName
        .wDriverOffset = 8
        .wDeviceOffset = .wDriverOffset + 1 + Len(Printer.DriverName)
        .wOutputOffset = .wDeviceOffset + 1 + Len(Printer.Port)
        .wDefault = 0
    End With
    With Printer
        DevName.extra = .DriverName & Chr(0) & .DeviceName & Chr(0) & .Port & Chr(0)
    End With
    '
    'Allocate memory for the initial hDevName structure
    'and copy the settings gathered above into this memory
    tPrintDlg.hDevNames = GlobalAlloc(GMEM_MOVEABLE Or GMEM_ZEROINIT, Len(DevName))
    lpDevName = GlobalLock(tPrintDlg.hDevNames)
    If lpDevName > 0 Then
        CopyMemory ByVal lpDevName, DevName, Len(DevName)
        bReturn = GlobalUnlock(lpDevName)
    End If
    '
    'Call the print dialog up and let the user make changes
    resultado = PrintDlg(tPrintDlg)
    If resultado Then
        'First get the DevName structure.
        lpDevName = GlobalLock(tPrintDlg.hDevNames)
        CopyMemory DevName, ByVal lpDevName, 45
        bReturn = GlobalUnlock(lpDevName)
        GlobalFree tPrintDlg.hDevNames
        '
        'Next get the mDevMode structure and set the printer
        'properties appropriately
        lpDevMode = GlobalLock(tPrintDlg.hDevMode)
        CopyMemory mDevMode, ByVal lpDevMode, Len(mDevMode)
        bReturn = GlobalUnlock(tPrintDlg.hDevMode)
        GlobalFree tPrintDlg.hDevMode
        NewPrinterName = UCase$(Left(mDevMode.dmDeviceName, InStr(mDevMode.dmDeviceName, Chr$(0)) - 1))
        If Printer.DeviceName <> NewPrinterName Then
            For Each objPrinter In Printers
               If UCase$(objPrinter.DeviceName) = NewPrinterName Then
                    Set Printer = objPrinter
               End If
            Next
        End If
        On Error Resume Next
        '
        'Set printer object properties according to selections made
        'by user
        With Printer
            .Copies = mDevMode.dmCopies
            .Duplex = mDevMode.dmDuplex
            .Orientation = mDevMode.dmOrientation
            .PaperSize = mDevMode.dmPaperSize
        End With
        On Error GoTo 0
    End If
    '
    ' Devuelve True si se todo fue bien
    ShowPrinter = (resultado <> 0)
    '
    '--------------------------------------------------------------------------
'    'display the print dialog
'    Dim tPrintDlg As PRINTDLGT
'    Dim resultado As Long
'    '
'    '
'    ttPrintDlg.lStructSize = Len(tPrintDlg)
'    ' hdc As Long - init from hDC property
'    ttPrintDlg.hDC = hDC
'    '
'    ttPrintDlg.hwndOwner = hWnd
'    '
'    ttPrintDlg.Flags = Flags
'    '
'    ttPrintDlg.nFromPage = FromPage
'    '
'    ttPrintDlg.nToPage = ToPage
'    '
'    ttPrintDlg.nMinPage = MinPage
'    '
'    ttPrintDlg.nMaxPage = MaxPage
'    '
'    ttPrintDlg.nCopies = Copies
'    '
'    resultado = PrintDlg(tPrintDlg)
'    '
'    If resultado <> 0 Then
'        ' nFromPage As Integer - store to FromPage property
'        FromPage = ttPrintDlg.nFromPage
'        ' nToPage As Integer - store to ToPage property
'        ToPage = ttPrintDlg.nToPage
'        ' nMinPage As Integer - store to Min property
'        MinPage = ttPrintDlg.nMinPage
'        ' nMaxPage As Integer - store to Max property
'        MaxPage = ttPrintDlg.nMaxPage
'        ' nCopies As Integer - store to Copies property
'        Copies = ttPrintDlg.nCopies
'    Else
'        If CancelError Then
'            'Err.Raise 32755, "cComDlg.ShowSave", "Error en Guardar como... (clase cComDlg)"
'            With Err
'                .Source = "cgsFileOp.ShowPrinter"
'                .Number = 32755
'                .Description = "Error en ShowPrinter..."
'            End With
'        End If
'    End If
'    ' Devuelve True si se todo fue bien
'    ShowPrinter = (resultado <> 0)
End Function

Public Function ShowColor() As Boolean
    ' display the color dialog box
    Dim tChooseColor As CHOOSECOLORT
    Dim alCustomColors(15) As Long
    Dim lCustomColorSize As Long
    Dim lCustomColorAddress As Long
    Dim lMemHandle As Long
    Dim n As Long
    Dim resultado As Long
    '
    '
    tChooseColor.lStructSize = Len(tChooseColor)
    '
    tChooseColor.hwndOwner = hWnd
    '
    tChooseColor.rgbResult = Color
    '
    ' Fill custom colors array with all white
    For n = 0 To UBound(alCustomColors)
        alCustomColors(n) = &HFFFFFF
    Next
    ' Get size of memory needed for custom colors
    lCustomColorSize = Len(alCustomColors(0)) * 16
    ' Get a global memory block to hold a copy of the custom colors
    lMemHandle = GlobalAlloc(GHND, lCustomColorSize)
    If lMemHandle = 0 Then
        Exit Function
    End If
    ' Lock the custom color's global memory block
    lCustomColorAddress = GlobalLock(lMemHandle)
    If lCustomColorAddress = 0 Then
        Exit Function
    End If
    ' Copy custom colors to the global memory block
    Call CopyMemory(ByVal lCustomColorAddress, alCustomColors(0), lCustomColorSize)
    tChooseColor.lpCustColors = lCustomColorAddress
    '
    tChooseColor.Flags = Flags
    '
    resultado = ChooseColor(tChooseColor)
    '
    If resultado <> 0 Then
        Color = tChooseColor.rgbResult
    Else
        If CancelError Then
            With Err
                .Source = "cgsFileOp.ShowColor"
                .Number = 32755
                .Description = "Error en ShowColor..."
            End With
        End If
    End If
    ' Devuelve True si se todo fue bien
    ShowColor = (resultado <> 0)
End Function

Public Property Let Action(ByVal vNewValue As Integer)
    '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 Let Filter(ByVal sNewFilter As String)
    'Procesar el parámetro para convertirlo a formato C,
    'Se usará | como separador.
    Dim i As Integer, j As Integer
    Dim sTmp As String

    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 OpenFile(ByVal sFile As String, sCadena As String) As Boolean
    'devuelve True si no se ha leido
    OpenFile = FileRead(sFile, sCadena)
End Function

Public Function SaveFile(ByVal sFile As String, sCadena As String, Optional bOverWrite As Boolean = True) As Boolean
    SaveFile = FileSave(sFile, sCadena, bOverWrite)
End Function

Public Function FileSave(ByVal sFile As String, sCadena As String, Optional bOverWrite As Boolean = True) As Boolean
    '----------------------------------------------------------
    'Guarda una cadena en un archivo                (27/Ago/97)
    '
    'Entrada:
    '   sFile       Archivo dónde se guardará
    '   sCadena     Cadena a guardar
    '   bOverWrite  Si se sobreescribe sin pedir confirmación
    '               por defecto =TRUE (no pedir confirmación)
    'Salida:
    '   True        Si NO se pudo guardar
    '----------------------------------------------------------
    Dim nF As Integer

    On Local Error Resume Next

    Err = 0
    If FileExist(sFile) Then
        If Not bOverWrite Then
            'Preguntar si se sobreescribe
            If MsgBox("Ya existe el archivo:" & vbCrLf & sFile & "¿quieres sobreescribirlo?", vbYesNo + vbQuestion, "Guardar Archivo") = vbNo Then
                'Se ha contestado que no, salir
                Err = 76
            End If
        End If
        If Err = 0 Then Kill sFile
    End If

    If Err = 0 Then
        'Guardar el contenido de sCadena
        nF = FreeFile
        Open sFile For Output As nF
        Print #nF, sCadena
        Close nF
        FileSave = False
    Else
        FileSave = True
    End If

    Err = 0
    On Local Error GoTo 0
End Function

Public Function FileRead(ByVal sFile As String, sCadena As String) As Boolean
    '----------------------------------------------------------
    'Abrir el archivo y asignarlo a una cadena      (27/Ago/97)
    '
    'Entrada:
    '   sFile       Archivo dónde se guardará
    '   sCadena     Cadena a guardar
    'Salida:
    '   True        Si NO se pudo abrir
    '----------------------------------------------------------
    Dim nF As Integer

    On Local Error Resume Next

    If FileExist(sFile) Then
        'Abrir y guardar el contenido de sCadena
        nF = FreeFile
        Open sFile For Input As nF
        sCadena = Input$(LOF(nF), nF)
        Close nF
    Else
        Err = 76
    End If

    If Err Then
        FileRead = True
    Else
        FileRead = False
    End If

    Err = 0
    On Local Error GoTo 0
End Function

Public Property Get FilesOnly() As Boolean
    FilesOnly = (Flags And FOF_FILESONLY)
End Property

Public Property Let FilesOnly(ByVal bNewValue As Boolean)
    Flags = Flags Xor FOF_FILESONLY
    If bNewValue Then
        Flags = Flags Or FOF_FILESONLY
    End If
End Property

Public Function FileRename(ByVal sFileFrom As String, ByVal sFileTo As String) As Long
    Dim SHFileOp As SHFILEOPSTRUCT

    On Local Error Resume Next

    sFileFrom = sFileFrom & vbNullChar & vbNullChar
    sFileTo = sFileTo & vbNullChar & vbNullChar

    With SHFileOp
        .wFunc = FO_RENAME
        .pFrom = sFileFrom
        'Flags = Flags Xor FOF_ALLOWUNDO
        .fFlags = FOF_ALLOWUNDO Or Flags
        If Err Then
            Err = 0
            .fFlags = FOF_ALLOWUNDO
        End If
        .pTo = sFileTo
    End With

    FileRename = SHFileOperation(SHFileOp)
    RaiseEvent Done(FileRename, eFileRename)
End Function

Public Function FilesRename(ByVal sFilesFrom As String, ParamArray vFiles() As Variant) As Long
    'Si sFilesFrom contiene una o más comas, se supone que
    'es un string con múltiples archivos separados por comas
    'a continuación estará el archivo/directorio de destino.
    'Los demás parámetros SIEMPRE estarán separados por comas

    Dim i As Long
    Dim sFiles As String
    Dim DestDir As String
    Dim SHFileOp As SHFILEOPSTRUCT
    Dim lb As Long
    Dim ub As Long

    On Local Error Resume Next

    'Convertir los caracteres "," en vbNullChar
    If InStr(sFilesFrom, ",") Then
        sFiles = Me.QuitarCaracterEx(sFilesFrom, ",", vbNullChar)
        If Right$(sFiles, 1) <> vbNullChar Then
            sFiles = sFiles & vbNullChar
        End If
    Else
        sFiles = sFilesFrom & vbNullChar
    End If

    lb = LBound(vFiles)
    ub = UBound(vFiles)
    DestDir = vFiles(ub) & vbNullChar & vbNullChar
    For i = lb To ub - 1
        sFiles = sFiles & vFiles(i) & vbNullChar
    Next
    sFiles = sFiles & vbNullChar

    With SHFileOp
        .wFunc = FO_RENAME
        .pFrom = sFiles
        'Flags = Flags Xor FOF_ALLOWUNDO
        .fFlags = FOF_ALLOWUNDO Or Flags
        If Err Then
            Err = 0
            .fFlags = FOF_ALLOWUNDO
        End If
        .pTo = DestDir
    End With

    FilesRename = SHFileOperation(SHFileOp)
    RaiseEvent Done(FilesRename, eFileRename)
End Function

Public Function FileCopy(ByVal sFileFrom As String, ByVal sFileTo As String) As Long
    Dim SHFileOp As SHFILEOPSTRUCT

    On Local Error Resume Next

    sFileFrom = sFileFrom & vbNullChar & vbNullChar
    sFileTo = sFileTo & vbNullChar & vbNullChar

    With SHFileOp
        .wFunc = FO_COPY
        .pFrom = sFileFrom
        'Flags = Flags Xor FOF_ALLOWUNDO
        .fFlags = FOF_ALLOWUNDO Or Flags
        If Err Then
            Err = 0
            .fFlags = FOF_ALLOWUNDO
        End If
        .pTo = sFileTo
    End With

    FileCopy = SHFileOperation(SHFileOp)
    RaiseEvent Done(FileCopy, eFileCopy)
End Function

Public Function FilesCopy(ByVal sFilesFrom As String, ParamArray vFiles() As Variant) As Long
    'Si sFileFrom contiene una o más comas, se supone que
    'es un string con múltiples archivos separados por comas
    'a continuación estará el archivo/directorio de destino.
    'Los demás parámetros SIEMPRE estarán separados por comas

    Dim i As Long
    Dim sFiles As Variant
    Dim DestDir As String
    Dim SHFileOp As SHFILEOPSTRUCT
    Dim lb As Long
    Dim ub As Long

    On Local Error Resume Next

    'Convertir los caracteres "," en vbNullChar
    If InStr(sFilesFrom, ",") Then
        sFiles = Me.QuitarCaracterEx(sFilesFrom, ",", vbNullChar)
        If Right$(sFiles, 1) <> vbNullChar Then
            sFiles = sFiles & vbNullChar
        End If
    Else
        sFiles = sFilesFrom & vbNullChar
    End If

    lb = LBound(vFiles)
    ub = UBound(vFiles)
    DestDir = vFiles(ub) & vbNullChar & vbNullChar
    For i = lb To ub - 1
        sFiles = sFiles & vFiles(i) & vbNullChar
    Next
    sFiles = sFiles & vbNullChar

    With SHFileOp
        .wFunc = FO_COPY
        .pFrom = sFiles
        'Flags = Flags Xor FOF_ALLOWUNDO
        .fFlags = FOF_ALLOWUNDO Or Flags
        If Err Then
            Err = 0
            .fFlags = FOF_ALLOWUNDO
        End If
        .pTo = DestDir
    End With

    FilesCopy = SHFileOperation(SHFileOp)
    RaiseEvent Done(FilesCopy, eFileCopy)
End Function

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

Public Function FileMove(ByVal sFileFrom As String, ByVal sFileTo As String) As Long
    Dim SHFileOp As SHFILEOPSTRUCT

    On Local Error Resume Next

    sFileFrom = sFileFrom & vbNullChar & vbNullChar
    sFileTo = sFileTo & vbNullChar & vbNullChar

    With SHFileOp
        .wFunc = FO_MOVE
        .pFrom = sFileFrom
        'Flags = Flags Xor FOF_ALLOWUNDO
        .fFlags = FOF_ALLOWUNDO Or Flags
        If Err Then
            Err = 0
            .fFlags = FOF_ALLOWUNDO
        End If
        .pTo = sFileTo
    End With

    FileMove = SHFileOperation(SHFileOp)
    RaiseEvent Done(FileMove, eFileMove)
End Function

Public Function FilesMove(ByVal sFilesFrom As String, ParamArray vFiles() As Variant) As Long
    'Si sFileFrom contiene una o más comas, se supone que
    'es un string con múltiples archivos separados por comas,
    'a continuación estará el archivo/directorio de destino.
    'Los demás parámetros SIEMPRE estarán separados por comas

    Dim i As Long
    Dim sFiles As Variant
    Dim DestDir As String
    Dim SHFileOp As SHFILEOPSTRUCT
    Dim lb As Long
    Dim ub As Long

    On Local Error Resume Next

    'Convertir los caracteres "," en vbNullChar
    If InStr(sFilesFrom, ",") Then
        sFiles = Me.QuitarCaracterEx(sFilesFrom, ",", vbNullChar)
        If Right$(sFiles, 1) <> vbNullChar Then
            sFiles = sFiles & vbNullChar
        End If
    Else
        sFiles = sFilesFrom & vbNullChar
    End If

    lb = LBound(vFiles)
    ub = UBound(vFiles)
    DestDir = vFiles(ub) & vbNullChar & vbNullChar
    For i = lb To ub - 1
        sFiles = sFiles & vFiles(i) & vbNullChar
    Next
    sFiles = sFiles & vbNullChar

    With SHFileOp
        .wFunc = FO_MOVE
        .pFrom = sFiles
        'Flags = Flags Xor FOF_ALLOWUNDO
        .fFlags = FOF_ALLOWUNDO Or Flags
        If Err Then
            Err = 0
            .fFlags = FOF_ALLOWUNDO
        End If
        .pTo = DestDir
    End With

    FilesMove = SHFileOperation(SHFileOp)
    RaiseEvent Done(FilesMove, eFileMove)
End Function

Public Function FileDelete(ByVal sFileFrom As String) As Long
    Dim SHFileOp As SHFILEOPSTRUCT

    On Local Error Resume Next

    sFileFrom = sFileFrom & vbNullChar & vbNullChar

    With SHFileOp
        .wFunc = FO_DELETE
        .pFrom = sFileFrom
        'Flags = Flags Xor FOF_ALLOWUNDO
        .fFlags = FOF_ALLOWUNDO Or Flags
        If Err Then
            Err = 0
            .fFlags = FOF_ALLOWUNDO
        End If
    End With

    FileDelete = SHFileOperation(SHFileOp)
    RaiseEvent Done(FileDelete, eFileDelete)
End Function

Public Function FilesDelete(ByVal sFilesFrom As String, ParamArray vFiles() As Variant) As Long
    '--------------------------------------------------------------------------
    ' Si sFileFrom contiene una o más comas, se supone que
    ' es un string con múltiples archivos separados por comas,
    ' a continuación puede haber más archivos a borrar.
    ' SIEMPRE separados por comas
    '
    '--------------------------------------------------------------------------
    ' Si se especifica: PATH\*.*                                    (31/Jul/01)
    ' se borra el directorio y su contenido (algunas veces)
    '--------------------------------------------------------------------------
    Dim i As Long
    Dim sFiles As String
    Dim SHFileOp As SHFILEOPSTRUCT
    
    On Local Error Resume Next
    
    ' Convertir los caracteres "," en vbNullChar
    If InStr(sFilesFrom, ",") Then
        sFiles = Me.QuitarCaracterEx(sFilesFrom, ",", vbNullChar)
        If Right$(sFiles, 1) <> vbNullChar Then
            sFiles = sFiles & vbNullChar
        End If
    Else
        sFiles = sFilesFrom & vbNullChar
    End If
    
    For i = LBound(vFiles) To UBound(vFiles)
        sFiles = sFiles & vFiles(i) & vbNullChar
    Next
    sFiles = sFiles & vbNullChar
    
    With SHFileOp
        .wFunc = FO_DELETE
        .pFrom = sFiles
        'Flags = Flags Xor FOF_ALLOWUNDO
        .fFlags = FOF_ALLOWUNDO Or Flags
        If Err Then
            Err = 0
            .fFlags = FOF_ALLOWUNDO
        End If
    End With
    
    FilesDelete = SHFileOperation(SHFileOp)
    RaiseEvent Done(FilesDelete, eFileDelete)
End Function

Public Function FileFindCustom(ByVal sFile As String, ByVal sPath As String, colFiles As Variant, Optional ByVal vSubDirs As Variant, Optional ByVal vOnlyOne As Variant, Optional ByVal vOnlyDir As Variant) As Variant
    '----------------------------------------------------------
    'Parámetros:
    '   sFile       Fichero o extensión a buscar
    '   sPath       Directorio o unidad de búsqueda
    '   vSubDirs    Incluir subdirectorios
    '   vOnlyOne    Devolver sólo el primero hallado
    '               Si no se especifica este parámetro o
    '               el valor es False, se devuelve
    '               una colección con todos los hallados
    '   vOnlyDir    Sólo buscar directorios
    '----------------------------------------------------------
    Dim bSubDirs As Boolean
    Dim bOnlyOne As Boolean
    Dim bOnlyDir As Boolean
    Dim sFileName As String
    Dim sFileTmp As String
    Dim WFD As WIN32_FIND_DATA
    Dim hFindFile As Long
    Dim ret As Long
    Dim esColObjeto As Boolean

    If IsMissing(vSubDirs) Then
        bSubDirs = False
    Else
        bSubDirs = CBool(vSubDirs)
    End If

    If IsMissing(vOnlyOne) Then
        bOnlyOne = False
    Else
        bOnlyOne = CBool(vOnlyOne)
    End If

    If IsMissing(vOnlyDir) Then
        bOnlyDir = False
    Else
        bOnlyDir = CBool(vOnlyDir)
    End If

    esColObjeto = False
    If TypeOf colFiles Is Collection Then
        esColObjeto = True
    ElseIf TypeOf colFiles Is Object  Then
        esColObjeto = True
    End If

    If esColObjeto Then
        Call FindAllFiles(sFile, sPath, colFiles, bSubDirs, bOnlyOne, bOnlyDir)
    Else
        'Crear una colección
        Dim BrowcolFiles As New Collection
        Call FindAllFiles(sFile, sPath, BrowcolFiles, bSubDirs, bOnlyOne, bOnlyDir)
    End If

    On Local Error Resume Next

    If bOnlyOne Then
        ret = 1
        If Not esColObjeto Then
            If BrowcolFiles.Count Then
                colFiles = BrowcolFiles(1)
            Else
                colFiles = ""
                ret = 0
            End If
            Set BrowcolFiles = Nothing
        End If
        'si se produce un error
        If Err Then
            Err = 0
            ret = 0
        End If
        FileFindCustom = ret
    Else
        If esColObjeto Then
            If TypeOf colFiles Is Collection Then
                ret = colFiles.Count
            Else
                ret = colFiles.ListCount
            End If
        Else
            If BrowcolFiles.Count Then
                colFiles = BrowcolFiles(1)
                ret = 1
            Else
                colFiles = ""
                ret = 0
            End If
            Set BrowcolFiles = Nothing
        End If
        'si se produce un error
        If Err Then
            Err = 0
            ret = 0
        End If
        FileFindCustom = ret
    End If

    'Devolverá -1 si no ha tenido éxito
    RaiseEvent Done(ret - 1, eFileFind)

    Err = 0
    On Local Error GoTo 0
End Function

Public Sub SplitPath(ByVal sTodo As String, ByRef sPath As String, _
                     Optional ByRef vNombre, Optional ByRef vExt)
    '----------------------------------------------------------------
    ' Divide el nombre recibido en la ruta, nombre y extensión
    ' (c)Guillermo Som, 1997                         ( 1/Mar/97)
    '
    ' Esta rutina aceptará los siguientes parámetros:
    ' sTodo      Valor de entrada con la ruta completa
    ' Devolverá la información en:
    ' sPath      Ruta completa, incluida la unidad
    ' vNombre    Nombre del archivo incluida la extensión
    ' vExt       Extensión del archivo (sin el punto)
    '
    ' Los parámetros opcionales sólo se usarán si se han especificado
    '----------------------------------------------------------------
    Dim bNombre As Boolean      ' Flag para saber si hay que devolver el nombre
    Dim i As Long
    '
    If Not IsMissing(vNombre) Then
        bNombre = True
        vNombre = sTodo
    End If
    '
    ' La extensión se debe buscar desde atrás,                      (13/Ene/99)
    ' ya que el nombre puede contener puntos en el nombre.
    If Not IsMissing(vExt) Then
        vExt = ""
        i = InStrRev(sTodo, ".")
        If i Then
            vExt = Mid$(sTodo, i + 1)
        End If
'        For i = Len(sTodo) To 1 Step -1
'            If Mid$(sTodo, i, 1) = "." Then
'                vExt = Mid$(sTodo, i + 1)
'                Exit For
'            End If
'        Next
        If Len(vExt) = 0 Then
            vExt = "*"
        End If
    End If
    '
    sPath = ""
    ' Asignar el path
    For i = Len(sTodo) To 1 Step -1
        If Mid$(sTodo, i, 1) = "\" Then
            sPath = Left$(sTodo, i - 1)
            ' Si hay que devolver el nombre
            If bNombre Then
                vNombre = Mid$(sTodo, i + 1)
            End If
            Exit For
        End If
    Next
End Sub

Public Function BrowseForFolder(ByVal hwndOwner As Long, _
                                ByVal sPrompt As String, _
                                Optional ByVal lFlags As eBIF = BIF_RETURNONLYFSDIRS) As String
    '--------------------------------------------------------------------------
    ' Seleccionar el directorio
    '--------------------------------------------------------------------------
    Dim iNull As Long
    Dim lpIDList As Long
    Dim lResult As Long
    Dim sPath As String
    Dim udtBI As BrowseInfo
    'Dim lFlags As Long
    '
    'If IsMissing(vFlags) Then
    '    lFlags = BIF_RETURNONLYFSDIRS
    'Else
    'If Not IsMissing(vFlags) Then
        'lFlags = CInt(vFlags)
        'If lFlags = 0 Then
        '    lFlags = BIF_RETURNONLYFSDIRS
        'End If
    'End If
    '
    With udtBI
        .hwndOwner = hwndOwner
        .lpszTitle = 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 = "cgsFileOp.BrowseForFolder"
                .Number = 32755
                .Description = "Cancelada la operación de BrowseForFolder"
            End With
        End If
    End If
    '
    BrowseForFolder = sPath
    '
    RaiseEvent Done(Len(sPath), eBrowseForFolder)
End Function

Public Property Get NoConfirmation() As Boolean
    NoConfirmation = (Flags And FOF_NOCONFIRMATION)
End Property

Public Property Let NoConfirmation(ByVal bNewValue As Boolean)
    Flags = Flags Xor FOF_NOCONFIRMATION
    If bNewValue Then
        Flags = Flags Or FOF_NOCONFIRMATION
    End If
End Property

Public Property Get Silent() As Boolean
    Silent = (Flags And FOF_SILENT)
End Property

Public Property Let Silent(ByVal bNewValue As Boolean)
    Flags = Flags Xor FOF_SILENT
    If bNewValue Then
        Flags = Flags Or FOF_SILENT
    End If
End Property

Public Property Get RenameOnCollision() As Boolean
    RenameOnCollision = (Flags And FOF_RENAMEONCOLLISION)
End Property

Public Property Let RenameOnCollision(ByVal bNewValue As Boolean)
    Flags = Flags Xor FOF_RENAMEONCOLLISION
    If bNewValue Then
        Flags = Flags Or FOF_RENAMEONCOLLISION
    End If
End Property

Public Property Get NoConfirmMKDIR() As Boolean
    NoConfirmMKDIR = (Flags And FOF_NOCONFIRMMKDIR)
End Property

Public Property Let NoConfirmMKDIR(ByVal bNewValue As Boolean)
    Flags = Flags Xor FOF_NOCONFIRMMKDIR
    If bNewValue Then
        Flags = Flags Or FOF_NOCONFIRMMKDIR
    End If
End Property

Public Property Get SimpleProgress() As Boolean
    SimpleProgress = (Flags And FOF_SIMPLEPROGRESS)
End Property

Public Property Let SimpleProgress(ByVal bNewValue As Boolean)
    Flags = Flags Xor FOF_SIMPLEPROGRESS
    If bNewValue Then
        Flags = Flags Or FOF_SIMPLEPROGRESS
    End If
End Property

Public Function FileOperationDescription(ByVal FileOperation As eFileOperation) As String
    Dim sTmp As String

    Select Case FileOperation
    Case eFileCopy
        sTmp = "FileCopy / FilesCopy"
    Case eFileMove
        sTmp = "FileMove / FilesMove"
    Case eFileRename
        sTmp = "FileRename / FilesRename"
    Case eFileDelete
        sTmp = "FileDelete / FileDelete"
    Case eFileFindFirst
        sTmp = "FileFindFirst"
    Case eFileFindNext
        sTmp = "FileFindNext"
    Case eFileExist
        sTmp = "FileExist"
    Case eFolderExist
        sTmp = "FolderExist"
    Case eFileRead
        sTmp = "FileRead"
    Case eFileSave
        sTmp = "FileSave"
    Case eBrowseForFolder
        sTmp = "BrowseForfolder"
    Case eFileFind
        sTmp = "FileFind"
    Case Else
        sTmp = "<desconocido>"
    End Select

    FileOperationDescription = sTmp
End Function

Public Function RTrimNull(ByVal sFileName As String) As String
    'Devuelve una cadena hasta el primer Null
    Dim i%

    i = InStr(sFileName, vbNullChar)
    If i > 1 Then
        sFileName = Left(sFileName, i - 1)
    End If
    RTrimNull = sFileName
End Function

Public Function AddBackSlash(ByVal sPath As String) As String
    'Si no tiene la barra de directorio añadirsela
    'Nota: Para quitarla, ver QuitarBackSlah            (13/abr/98)
    If Len(sPath) Then                      '           (30/Ene/99)
        If Right$(sPath, 1) <> "\" Then
            sPath = sPath & "\"
        End If
    End If
    AddBackSlash = sPath
End Function

Public Function FolderExist(ByVal sFile As String) As Boolean
    'comprobar si existe este directorio
    Dim WFD As WIN32_FIND_DATA
    Dim hFindFile As Long

    hFindFile = FindFirstFile(sFile, WFD)
    'Si no se ha encontrado
    If hFindFile = INVALID_HANDLE_VALUE Then
        FolderExist = False
    Else
        If WFD.dwFileAttributes And vbDirectory Then
            FolderExist = True
        End If
        'Cerrar el handle de FindFirst
        hFindFile = FindClose(hFindFile)
    End If

    RaiseEvent Done(FolderExist, eFolderExist)
End Function

Public Function FileExist(ByVal sFile As String) As Boolean
    'comprobar si existe este fichero
    Dim WFD As WIN32_FIND_DATA
    Dim hFindFile As Long

    hFindFile = FindFirstFile(sFile, WFD)
    'Si no se ha encontrado
    If hFindFile = INVALID_HANDLE_VALUE Then
        FileExist = False
    Else
        FileExist = True
        'Cerrar el handle de FindFirst
        hFindFile = FindClose(hFindFile)
    End If

    RaiseEvent Done(FileExist, eFileExist)
End Function

Public Function FolderFindAll(ByVal sFileSpec As String, Optional ByVal vPath As Variant) As Variant
    'Busca todos los directorios que coincidan con la especificación indicada
    '
    'Parámetros:
    '   sFileSpec   Directorio a buscar, permite caracteres de comodines
    '   vPath       Path de inicio de la búsqueda (opcional)
    '
    'Nota: se buscará también en todos los directorios que estén debajo del especificado
    '
    Dim sPath As String
    Dim colFiles As New Collection

    If IsMissing(vPath) Then
        'Si no se especifica el path, buscar en el directorio actual
        sPath = CurDir$
    Else
        sPath = CStr(vPath)
    End If
    Call FileFindCustom(sFileSpec, sPath, colFiles, True, False, True)
    Set FolderFindAll = colFiles
    RaiseEvent Done(colFiles.Count, eFileFind)
    Set colFiles = Nothing
End Function

Public Function FileFindAll(ByVal sFileSpec As String, Optional ByVal vPath As Variant) As Variant
    'Busca todas las coincidencias de la especificación indicada
    'y lo devuelve como una colección
    '
    'Parámetros:
    '   sFileSpec   Archivo a buscar, permite caracteres de comodines
    '   vPath       Path de inicio de la búsqueda (opcional)
    '
    'Nota: se buscará también en todos los directorios que estén debajo del especificado
    '
    Dim sPath As String
    Dim colFiles As New Collection

    If IsMissing(vPath) Then
        'Si no se especifica el path, buscar en el directorio actual
        sPath = CurDir$
    Else
        sPath = CStr(vPath)
    End If
    Call FileFindCustom(sFileSpec, sPath, colFiles, True, False)
    Set FileFindAll = colFiles
    RaiseEvent Done(colFiles.Count, eFileFind)
    Set colFiles = Nothing
End Function

Public Function FolderFind(ByVal sFileSpec As String, Optional ByVal vPath As Variant) As String
    'Busca el primer directorio que coincida con la especificación indicada
    '
    'Parámetros:
    '   sFileSpec   Archivo a buscar, permite caracteres de comodines
    '   vPath       Path de inicio de la búsqueda (opcional)
    '
    'Nota: se buscará también en todos los directorios que estén debajo del especificado
    '
    Dim sPath As String
    Dim sFileName As String

    If IsMissing(vPath) Then
        'Si no se especifica el path, buscar en el directorio actual
        sPath = CurDir$
    Else
        sPath = CStr(vPath)
    End If
    Call FileFindCustom(sFileSpec, sPath, sFileName, True, True, True)
    FolderFind = sFileName
    RaiseEvent Done(Len(sFileName) - 1, eFileFind)
End Function

Public Function FileFind(ByVal sFileSpec As String, Optional ByVal vPath As Variant) As String
    'Busca la primera coincidencia de la especificación indicada
    '
    'Parámetros:
    '   sFileSpec   Archivo a buscar, permite caracteres de comodines
    '   vPath       Path de inicio de la búsqueda (opcional)
    '
    'Nota: se buscará también en todos los directorios que estén debajo del especificado
    '
    Dim sPath As String
    Dim sFileName As String

    If IsMissing(vPath) Then
        'Si no se especifica el path, buscar en el directorio actual
        sPath = CurDir$
    Else
        sPath = CStr(vPath)
    End If
    Call FileFindCustom(sFileSpec, sPath, sFileName, True, True)
    FileFind = sFileName
    RaiseEvent Done(Len(sFileName) - 1, eFileFind)
End Function

Public Function AddPath(ByVal sFile As String, Optional ByVal vPath As Variant) As String
    'Añadir el path sino lo tiene                   ( 2/Nov/97)
    'Si no se especifica el path a añadir, usar App.Path
    Dim sTmp As String
    Dim sPath As String

    'Si ya incluye el path, devolver el valor actual
    If InStr(sFile, "\") Then
        AddPath = sFile
    Else
        If IsMissing(vPath) Then
            sPath = App.Path
        Else
            sPath = Trim$(CStr(vPath))
        End If
        'si se indica con cadena vacía...           ( 8/Nov/97)
        'añadir el path actual
        If Len(sPath) = 0 Then
            sPath = CurDir$
        End If
        AddPath = AddBackSlash(sPath) & sFile
    End If
End Function

Public Function QuitarBackSlash(ByVal sPath As String) As String
    'Quitarle el \ del final
    'Para añadirsela, ver AddBackSlash
    If Right$(sPath, 1) = "\" Then
        sPath = Left$(sPath, Len(sPath) - 1)
    End If
    QuitarBackSlash = sPath
End Function

Public Function LeerIni(ByVal lpFileName As String, ByVal lpAppName As String, ByVal lpKeyName As String, Optional ByVal vDefault As Variant) As String
    If IsMissing(vDefault) Then
        LeerIni = Me.GetSetting(lpFileName, lpAppName, lpKeyName)
    Else
        LeerIni = Me.GetSetting(lpFileName, lpAppName, lpKeyName, vDefault)
    End If
End Function

Public Sub GuardarIni(ByVal lpFileName As String, ByVal lpAppName As String, ByVal lpKeyName As String, ByVal lpString As String)
    Me.SaveSetting lpFileName, lpAppName, lpKeyName, lpString
End Sub

Public Function GetDir(ByVal sPath As String) As String
    Dim i&
    'Devuelve el directorio del path indicado
    GetDir = sPath
    For i = Len(sPath) To 1 Step -1
        If Mid$(sPath, i, 1) = "\" Then
            GetDir = Left$(sPath, i - 1)
            Exit For
        End If
    Next
End Function

Public Sub DeleteSetting(ByVal sIniFile As String, ByVal sSection As String, _
                         Optional ByVal sKey As String = "")
    '
    ' Añadida a cgsFileOP                                           (10/Jul/00)
    '
    ' 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
    '
    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 Function NameFromFileName(ByVal sFileName As String, _
                                 Optional ByVal ConExt As Boolean = True) As String
    ' Devuelve sólo el Nombre y extensión del fichero indicado      (17/Jul/00)
    ' Si se indica False en ConExt, no devolver la extensión
    Dim sPath As String
    Dim sName As String
    Dim i As Long
    '
    ' Usar SplitPath para hacer el trabajo "sucio"
    SplitPath sFileName, sPath, sName
    If ConExt = False Then
        ' Si no debe devolverse la extensión, comprobar si tiene    (09/Oct/01)
        i = InStrRev(sName, ".")
        If i Then
            sName = Left$(sName, i - 1)
        End If
    End If
    NameFromFileName = sName
End Function

Public Function PathFromFileName(ByVal sFileName As String) As String
    ' Devuelve sólo el Path del fichero indicado                    (17/Jul/00)
    Dim sPath As String
    '
    ' Usar SplitPath para hacer el trabajo "sucio"
    SplitPath sFileName, sPath
    PathFromFileName = sPath
End Function

Public Function ExtFromFileName(ByVal sFileName As String) As String
    ' Devuelve sólo la extensión del fichero indicado               (17/Jul/00)
    Dim sPath As String
    Dim sName As String
    Dim sExt As String
    '
    ' Usar SplitPath para ahcer el trabajo "sucio"
    SplitPath sFileName, sPath, sName, sExt
    ExtFromFileName = sExt
End Function

Public Function AppPath(Optional ByVal conBackSlash As Boolean = True) As String
    ' Devuelve el path de la aplicación con la barra al final       (03/May/01)
    ' o sin ella, según se especifique en el parámetro
    Dim s As String
    '
    s = App.Path
    If conBackSlash Then
        If Right$(s, 1) <> "\" Then
            s = s & "\"
        End If
    Else
        If Right$(s, 1) = "\" Then
            s = Left$(s, Len(s) - 1)
        End If
    End If
    AppPath = s
End Function

Friend Function DevMode() As DEVMODE_TYPE
    LSet DevMode = mDevMode
End Function

Volver a la página de gsNotas v3.0

la Luna del Guille o... el Guille que está en la Luna... tanto monta...