Office Developer

'***** Begin ***** Declaraciones para usar en rvg_SetClipBoard **********************************************************
Private Const GHND As Long = &H42
Private Const CF_TEXT As Long = &H1
Private Declare Function GlobalAlloc Lib "kernel32" (ByVal wFlags&, ByVal dwBytes 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
Private Declare Function lstrcpy Lib "kernel32" (ByVal lpString1 As Any, ByVal lpString2 As Any) As Long
Private Declare Function OpenClipboard Lib "user32" (ByVal hwnd As Long) As Long
Private Declare Function EmptyClipboard Lib "user32" () As Long
Private Declare Function SetClipboardData Lib "user32" (ByVal wFormat As Long, ByVal hMem As Long) As Long
Private Declare Function CloseClipboard Lib "user32" () As Long
'***** End **************************************************************************************************************

 

Public Sub rvg_SetClipBoard(ByVal strCadena As String)
'------------------------------------------------------------------------------------------------------------------------
' Sub           :   rvg_SetClipBoard                                                    Forma parte de McMódulosVXXXX.mdb
' Título        :   Copiar al portapapeles (portafolios) del Windows.
' Creación      :   19/06/2007 17:41
' Revisión      :   Copyright ©1999-2007 McPegasus, www.mcpegasus.es, mcpegasus@mcpegasus.es
' Origen        :   Gracias Rubén Vigón, http://groups.google.es:80/group/microsoft.public.es.vb/msg/b3ce518280c901fa
' Propósito     :   Copiar un texto que se pasa por parámetro al portapapeles del Windows.
'
'Argumento/s, la sintaxis del Procedimiento o Función consta de/los siguiente/s argumento/s:
'Parte              Descripción
'------------------------------------------------------------------------------------------------------------------------
'strCadena          Requerido   Cadena a copiar al portapapeles del Windows.
'------------------------------------------------------------------------------------------------------------------------
' Nota          :   Para visualizar el contenido del portapapeles, Inicio | Ejecutar | Clipbrd.exe
   
    Dim hGMem   As Long
   
On Error GoTo rvg_SetClipBoard_CapturarError

    hGMem = GlobalAlloc(GHND, Len(strCadena) + 1)
    lstrcpy GlobalLock(hGMem), strCadena
    If GlobalUnlock(hGMem) = 0 Then
        If OpenClipboard(0) Then
            EmptyClipboard
            SetClipboardData CF_TEXT, hGMem
            CloseClipboard
        End If
    End If

rvg_SetClipBoard_Salida:
    On Error GoTo 0
    Exit Sub

rvg_SetClipBoard_CapturarError:
    Select Case Err.Number
        Case Else
            'Cazar todos aquellos errores inesperados.
            MsgBox "Error " & Err.Number & " (" & Err.Description & ") in procedure rvg_SetClipBoard."
    End Select
    'Salida a otro procedimiento.
    Resume rvg_SetClipBoard_Salida

End Sub

Sub test_mcblnSetToCreateFieldProperty()

    Dim intItem             As Integer
   
    Dim strField            As String
    Dim strPathNamedbs      As String
    Dim strProperty(4)      As String
    Dim strPWD              As String
    Dim strTable            As String
    Dim strValue(4)         As String
   
   
    strPathNamedbs = Application.CurrentProject.Path & "\dMcCrearTablas.mdb"
   
    strTable = "tblPruebaAA"
    strField = "fldIdCampoAD"
   
    strProperty(0) = "AllowZeroLength"
    strProperty(1) = "Description"
    strProperty(2) = "Format"
    strProperty(3) = "UnicodeCompression"
    strProperty(4) = "DefaultValue"
   
    strValue(0) = "True"
    strValue(1) = "Descripción de " & strField
    strValue(2) = "Yes/No"
    strValue(3) = "True"
    strValue(4) = "Automatización"
   
    strPWD = ""
   
    Do While Not intItem = 5
        Debug.Print mcblnSetToCreateFieldProperty(strPathNamedbs, strTable, strField, strProperty(intItem), strValue(intItem), strPWD)
        intItem = intItem + 1
    Loop

End Sub

Public Function mcblnSetToCreateFieldProperty(ByVal strPathNamedbs As String, _
                                              ByVal strTable As String, _
                                              ByVal strField As String, _
                                              ByVal strProperty As String, _
                                              ByVal strValue As String, _
                                              Optional ByVal strPWD As String) As Boolean
'------------------------------------------------------------------------------------------------------------------------
' Function      :   mcblnSetToCreateFieldProperty                   Forma parte de McMódulosVXXXX.mdb
' Título        :   Crear una propiedad de un campo ya existente en tiempo de ejecución.
' Creación      :   30/05/2007 15:51
' Autor         :   Copyright ©1999-2007 McPegasus, www.mcpegasus.es, mcpegasus@mcpegasus.es
' Propósito     :   Crear una propiedad de una tabla ya existente. _
                    Código pensado y desarrollado para usar cuando se quiere actualizar la base de datos FrontEnd en _
                    una actualización al abrir la apps.
'------------------------------------------------------------------------------------------------------------------------
' Referencia/s  :   Nombre:     Microsoft DAO x.x Object Library
'                   Ruta:       C:\Archivos de programa\Archivos comunes\Microsoft Shared\DAO\daoxxx.dll
'------------------------------------------------------------------------------------------------------------------------
' Retorno       :   True / False, según se haya ejecutado el código con éxito o se haya producido un error.
'------------------------------------------------------------------------------------------------------------------------
'Argumento/s, la sintaxis del Procedimiento o Función consta de/los siguiente/s argumento/s:
'Parte              Descripción
'------------------------------------------------------------------------------------------------------------------------
'strPathNamedbs     Requerido   Ruta completa con nombre de la base de datos a crear la tabla.
'strTable           Requerido   Nombre de la tabla a crear.
'strField           Requerido   Nombre del primer campo a crear.
'strProperty        Requerido   Nombre de la propiedad a crear.
'strValue           Requerido   Valor de la propiedad a crear.
'strPWD             Optional    Contraseña de la dbs según strPathNamedbs.
'------------------------------------------------------------------------------------------------------------------------
   
    Dim dbs             As DAO.Database
   
    Dim tdf             As DAO.TableDef
   
    Dim fld             As DAO.Field
   
    Dim prp             As DAO.Property
   
    Dim blnActualizar   As Boolean                      'Para indicar que se actualiza el valor, no crear la propiedad.
    Dim blnSalirFor     As Boolean                      'Indicar a los Fors que ya se puede salir.
  
    Dim bytType         As Byte
   
   
On Error GoTo mcblnSetToCreateFieldProperty_CapturarError

    If strPWD = "" Then
        Set dbs = OpenDatabase(strPathNamedbs, True, False)
    Else
        Set dbs = OpenDatabase(strPathNamedbs, True, False, ";PWD=" & strPWD)
    End If
   
    Select Case strProperty
        Case "AllowZeroLength"          'Permitir longitud cero
            blnActualizar = True
            bytType = DAO.dbBoolean
        Case "Description"              'Descripción
            bytType = DAO.dbText
        Case "InputMask"                'Máscara de entrada
            bytType = DAO.dbText
        Case "UnicodeCompression"       'Compresión unicode
            bytType = DAO.dbBoolean
        Case "Format"                   'Formato
            bytType = DAO.dbText
        Case "DefaultValue"             'Valor predeterminado
            blnActualizar = True
            bytType = DAO.dbBoolean
        Case "ValidationRule"           'Regla de validación
            bytType = DAO.dbText
        Case "ValidationText"           'Texto de validación
            bytType = DAO.dbText
        Case "Required"                 'Requerido
            bytType = DAO.dbBoolean
    End Select
   
    If Not blnActualizar Then
        For Each tdf In dbs.TableDefs
            If tdf.Name = strTable Then
                For Each fld In tdf.Fields
                    If fld.Name = strField Then
                        For Each prp In fld.Properties
                            If prp.Name = strProperty Then
                                mcblnSetToCreateFieldProperty = True
                                Exit For
                            End If
                        Next prp
                        'Al pasar por el último bucle hay que indicar a los Each parents que se salga también.
                        blnSalirFor = True
                    End If
                    If blnSalirFor Then Exit For
                Next fld
            End If
            If blnSalirFor Then Exit For
        Next tdf
    End If
   
    If Not mcblnSetToCreateFieldProperty Then
        Set tdf = dbs.TableDefs(strTable)
        Set fld = tdf.Fields(strField)
       
        If blnActualizar Then
            fld.Properties(strProperty) = strValue
        Else
            Set prp = fld.CreateProperty(strProperty, bytType, strValue)
            fld.Properties.Append prp
        End If
       
        mcblnSetToCreateFieldProperty = True
    End If
   
mcblnSetToCreateFieldProperty_Salida:
    If Not prp Is Nothing Then Set prp = Nothing

    If Not fld Is Nothing Then Set fld = Nothing

    If Not tdf Is Nothing Then Set tdf = Nothing
       
    If Not dbs Is Nothing Then
        dbs.Close
        Set dbs = Nothing
    End If

    On Error GoTo 0
    Exit Function

mcblnSetToCreateFieldProperty_CapturarError:
    Select Case Err.Number
        Case Else
            'Cazar todos aquellos errores inesperados.
            MsgBox "Error " & Err.Number & " (" & Err.Description & ") in procedure mcblnSetToCreateFieldProperty."
    End Select
    'Salida a otro procedimiento.
    Resume mcblnSetToCreateFieldProperty_Salida
   
End Function

Sub test_mcblnSetToCreateField()

    Dim bytType             As Byte
   
    Dim intSize             As Integer
    Dim intItem             As Integer
   
    Dim strField            As String
    Dim strPathNamedbs      As String
    Dim strPWD              As String
    Dim strTable            As String
   
   
    intItem = 0
   
    strPathNamedbs = Application.CurrentProject.Path & "\dMcCrearTablas.mdb"
    strPWD = ""
   
    strTable = "tblPruebaAA"
    strField = "fldIdCampoAB"
   
    bytType = DAO.dbText
    intSize = 100
   
    Debug.Print mcblnSetToCreateField(strPathNamedbs, strTable, strField, bytType, intSize, strPWD)

End Sub

Public Function mcblnSetToCreateField(ByVal strPathNamedbs As String, _
                                      ByVal strTable As String, _
                                      ByVal strField As String, _
                                      Optional bytType As Byte, _
                                      Optional ByVal intSize As Integer, _
                                      Optional ByVal strPWD As String) As Boolean

'------------------------------------------------------------------------------------------------------------------------
' Function      :   mcblnSetToCreateField
' Título        :   Crear un campo en una tabla en tiempo de ejecución.
' Creación      :   30/05/2007 15:10
' Autor         :   Copyright ©1999-2007 McPegasus, www.mcpegasus.es, mcpegasus@mcpegasus.es
' Propósito     :   Crear un campo en una tabla ya existente. _
                    Código pensado y desarrollado para usar cuando se quiere actualizar la base de datos FrontEnd en _
                    una actualización al abrir la apps.
'------------------------------------------------------------------------------------------------------------------------
' Referencia/s  :   Nombre:     Microsoft DAO x.x Object Library
'                   Ruta:       C:\Archivos de programa\Archivos comunes\Microsoft Shared\DAO\daoxxx.dll
'------------------------------------------------------------------------------------------------------------------------
' Retorno       :   True / False, según se haya ejecutado el código con éxito o se haya producido un error.
'------------------------------------------------------------------------------------------------------------------------
'Argumento/s, la sintaxis del Procedimiento o Función consta de/los siguiente/s argumento/s:
'Parte              Descripción
'------------------------------------------------------------------------------------------------------------------------
'strPathNamedbs     Requerido   Ruta completa con nombre de la base de datos a crear la tabla.
'strTable           Requerido   Nombre de la tabla a crear.
'strField           Requerido   Nombre del primer campo a crear.
'bytType            Optional   Determina el tipo de datos para el nuevo objeto Field. Si no se pasa será dbText. _
'intSize            Optional    Determina el tamaño del nuevo objeto Field que contenga texto. Si no se pasa será 255.
'strPWD             Optional    Contraseña de la dbs según strPathNamedbs.
'------------------------------------------------------------------------------------------------------------------------
   
    Dim dbs             As DAO.Database
   
    Dim tdf             As DAO.TableDef
   
    Dim fld             As DAO.Field
       
    Dim bytMétodo       As Byte                     'Método a seleccionar para crear el campo.
   
    Dim blnSalirFor     As Boolean                      'Indicar a los Fors que ya se puede salir.
   
    Dim strSql          As String
    Dim strType         As String
   
   
On Error GoTo mcblnSetToCreateField_CapturarError

    If strPWD = "" Then
        Set dbs = OpenDatabase(strPathNamedbs, True, False)
    Else
        Set dbs = OpenDatabase(strPathNamedbs, True, False, ";PWD=" & strPWD)
    End If
   
    For Each tdf In dbs.TableDefs
        If tdf.Name = strTable Then
            For Each fld In tdf.Fields
                If fld.Name = strField Then
                    mcblnSetToCreateField = True
                    Exit For
                End If
            Next fld
           'Al pasar por el último bucle hay que indicar a los Each parents que se salga también.
            blnSalirFor = True
        End If
        If blnSalirFor Then Exit For
    Next tdf
   
    If bytType = 0 Then
        bytType = DAO.dbText
    End If
   
    If Not mcblnSetToCreateField Then
       
        bytMétodo = 4
        'Esta explicación de métodos es para que me quede constancia de las diferentes posibilidades que tenemos para _
        realizar la misma operación de crear una tabla, la finalidad es la misma pero en según que ocasiones nos puede _
        interesar sobre todo en no declarar los objetos.
   
        If bytMétodo = 1 Then
            'Este primer método nos permite no declarar ningún objeto ni como Database, ni Tabledef, ni Field, es un _
            modo de proceder directo.
            OpenDatabase(strPathNamedbs, True, False).TableDefs(strTable).Fields.Append _
                    OpenDatabase(strPathNamedbs, True, False).TableDefs(strTable).CreateField(strField, bytType, intSize)
        ElseIf bytMétodo = 2 Then
            'Si tenemos necesidad de declarar una variable como objeto Database, esta sentencia es más corta.
            dbs.TableDefs(strTable).Fields.Append dbs.TableDefs(strTable).CreateField(strField, bytType, intSize)
        ElseIf bytMétodo = 3 Then
            'Más corto este tercer método aunque se debe de hacer en dos líneas.
            Set tdf = dbs.TableDefs(strTable)
            tdf.Fields.Append tdf.CreateField(strField, bytType, intSize)                 'Crear el campo.
        ElseIf bytMétodo = 4 Then
            'El método cuarto es el más estructurado aunque necesita declarar cada uno de los objeto.
            Set tdf = dbs.TableDefs(strTable)
            Set fld = tdf.CreateField(strField, bytType, intSize)
            tdf.Fields.Append fld
        ElseIf bytMétodo = 5 Then
            'Método que usa una sentencia SQL y que no es necesario DAO salvo cuando la tabla a crear está fuera de la _
            que ejecuta este código.
            If intSize = 0 Then intSize = 255
            Select Case bytType
                Case DAO.dbByte
                    strType = "BYTE"
                Case DAO.dbText
                    strType = "TEXT" & "(" & intSize & ")"
                Case DAO.dbInteger
                    strType = "INTEGER"
                Case DAO.dbMemo
                    strType = "MEMO"
                'etc. etc.
                Case Else
                    MsgBox "No se ha indicado un tipo de datos conocido.", vbCritical, "McPegasus informa"
            End Select
           
            strSql = "ALTER TABLE " & strTable & " ADD COLUMN " & strField & " " & bytType & ""
            dbs.Execute (strSql)
           
            'Método en caso de ejecutar en la propia dbs y sin DAO.
            'CodeDb.Execute (strSql)
        End If
    End If

mcblnSetToCreateField_Salida:
    If Not fld Is Nothing Then
        Set fld = Nothing
    End If

    If Not tdf Is Nothing Then
        Set tdf = Nothing
    End If
       
    If Not dbs Is Nothing Then
        dbs.Close
        Set dbs = Nothing
    End If
  
   On Error GoTo 0
   Exit Function

mcblnSetToCreateField_CapturarError:
    Select Case Err.Number
        Case Else
            'Cazar todos aquellos errores inesperados.
            MsgBox "Error " & Err.Number & " (" & Err.Description & ") in procedure mcblnSetToCreateField."
    End Select
    'Salida a otro procedimiento.
    Resume mcblnSetToCreateField_Salida
   
End Function

Sub demo_mcblnSetToModifyFieldProperty()

    Dim bytType             As Byte                     'Indicar el Tipo de datos al crear una tabla.
   
    Dim intSize             As Integer
   
    Dim strField            As String
    Dim strPathNamedbs      As String
    Dim strPWD              As String
    Dim strTable            As String
   
   
    strPathNamedbs = Application.CurrentProject.Path & "\dMcCrearTablas.mdb"
    strPWD = ""
   
    strTable = "tblPruebaAA"
   
    strField = "fldIdCampoAA"
    bytType = DAO.dbText
    intSize = 100

    Debug.Print mcblnSetToModifyFieldProperty(strPathNamedbs, strTable, strField, bytType, intSize, strPWD)

End Sub

Public Function mcblnSetToModifyFieldProperty(ByVal strPathNamedbs As String, _
                                              ByVal strTable As String, _
                                              ByVal strField As String, _
                                              ByVal bytType As Byte, _
                                              Optional ByVal intSize As Integer, _
                                              Optional ByVal strPWD As String) As Boolean
'------------------------------------------------------------------------------------------------------------------------
' Function      :   mcblnSetToModifyFieldProperty
' Title         :   Modificar una propiedad de un campo de una tabla en tiempo de ejecución.
' Creación      :   30/05/2007 10:42
' Autor         :   Copyright ©1999-2007 McPegasus, www.mcpegasus.es, mcpegasus@mcpegasus.es
' Propósito     :   Modificar una propiedad de un campo de una tabla ya existente. _
                    Código pensado y desarrollado para usar cuando se quiere actualizar la base de datos FrontEnd en _
                    una actualización al abrir la apps.
'------------------------------------------------------------------------------------------------------------------------
' Referencia/s  :   Nombre:     Microsoft DAO x.x Object Library
'                   Ruta:       C:\Archivos de programa\Archivos comunes\Microsoft Shared\DAO\daoxxx.dll
'------------------------------------------------------------------------------------------------------------------------
' Retorno       :   True / False, según se haya ejecutado el código con éxito o se haya producido un error.
'------------------------------------------------------------------------------------------------------------------------
'Argumento/s, la sintaxis del Procedimiento o Función consta de/los siguiente/s argumento/s:
'Parte              Descripción
'------------------------------------------------------------------------------------------------------------------------
'strPathNamedbs     Requerido   Ruta completa con nombre de la base de datos a crear la tabla.
'strTable           Requerido   Nombre de la tabla a modificar.
'strField           Requerido   Nombre del campo a modificar.
'bytType            Requerido   Determina el tipo de datos para la modificación del objeto Field. _
'intSize            Optional    Determina el tamaño del nuevo objeto Field que contenga texto. Si no se pasa será 255.
'strPWD             Optional    Contraseña de la dbs según strPathNamedbs.
'------------------------------------------------------------------------------------------------------------------------
  
    Dim dbs             As DAO.Database
   
    Dim strSql          As String
    Dim strType         As String
   
   
On Error GoTo mcblnSetToModifyFieldProperty_CapturarError

    If strPWD = "" Then
        Set dbs = OpenDatabase(strPathNamedbs, True, False)
    Else
        Set dbs = OpenDatabase(strPathNamedbs, True, False, ";PWD=" & strPWD)
    End If
   
    Select Case bytType
        Case DAO.dbByte
            strType = "BYTE"
        Case DAO.dbText
            strType = "TEXT" & "(" & intSize & ")"
        Case DAO.dbInteger
            strType = "INTEGER"
        Case DAO.dbMemo
            strType = "MEMO"
        'etc. etc.
       
        Case Else
            MsgBox "No se ha indicado un tipo de datos conocido.", vbCritical, "McPegasus informa"
    End Select
   
    If Not strType = "" Then
        'Ejemplo:   ALTER TABLE tblPruebaAA ALTER COLUMN fldIdCampoAA TEXT(100)
        strSql = "ALTER TABLE " & strTable & " ALTER COLUMN " & strField & " " & strType
        dbs.Execute strSql
        mcblnSetToModifyFieldProperty = True
    End If
   
mcblnSetToModifyFieldProperty_Salida:
       
    If Not dbs Is Nothing Then
        dbs.Close
        Set dbs = Nothing
    End If

   On Error GoTo 0
   Exit Function

mcblnSetToModifyFieldProperty_CapturarError:
    Select Case Err.Number
        Case Else
            'Cazar todos aquellos errores inesperados.
            MsgBox "Error " & Err.Number & " (" & Err.Description & ") in procedure mcblnSetToModifyFieldProperty."
    End Select
    'Salida a otro procedimiento.
    Resume mcblnSetToModifyFieldProperty_Salida
   
End Function

Sub test_mcblnSetToCreateTable()

    Dim bytType             As Byte                     'Indicar el Tipo de datos al crear una tabla.
   
    Dim intSize             As Integer
   
    Dim strField            As String
    Dim strPathNamedbs      As String
    Dim strPWD              As String
    Dim strTable            As String
   
   
    strPathNamedbs = Application.CurrentProject.Path & "\dMcCrearTablas.mdb"
    strPWD = ""
   
    strTable = "tblPruebaAA"
   
    strField = "fldIdCampoAA"
    bytType = DAO.dbText
    intSize = 50

    'Para crear una tabla hay que crear como mínimo un campo.
    Debug.Print mcblnSetToCreateTable(strPathNamedbs, strTable, strField, bytType, intSize, strPWD)

End Sub

Public Function mcblnSetToCreateTable(ByVal strPathNamedbs As String, _
                                      ByVal strTable As String, _
                                      ByVal strField As String, _
                                      Optional bytType As Byte, _
                                      Optional ByVal intSize As Integer, _
                                      Optional ByVal strPWD As String) As Boolean
'------------------------------------------------------------------------------------------------------------------------
' Function      :   mcblnSetToCreateTable
' Title         :   Crear una tabla en tiempo de ejecución.
' Creación      :   30/05/2007 10:42
' Autor         :   Copyright ©1999-2007 McPegasus, www.mcpegasus.es, mcpegasus@mcpegasus.es
' Propósito     :   Crear una tabla. _
                    Código pensado y desarrollado para usar cuando se quiere actualizar la base de datos FrontEnd en _
                    una actualización al abrir la apps.
'------------------------------------------------------------------------------------------------------------------------
' Referencia/s  :   Nombre:     Microsoft DAO x.x Object Library
'                   Ruta:       C:\Archivos de programa\Archivos comunes\Microsoft Shared\DAO\daoxxx.dll
'------------------------------------------------------------------------------------------------------------------------
' Retorno       :   True / False, según se haya ejecutado el código con éxito o se haya producido un error.
'------------------------------------------------------------------------------------------------------------------------
'Argumento/s, la sintaxis del Procedimiento o Función consta de/los siguiente/s argumento/s:
'Parte              Descripción
'------------------------------------------------------------------------------------------------------------------------
'strPathNamedbs     Requerido   Ruta completa con nombre de la base de datos a crear la tabla.
'strTable           Requerido   Nombre de la tabla a crear.
'strField           Requerido   Nombre del primer campo a crear, es requerido para crear una tabla.
'bytType            Optional    Determina el tipo de datos para el nuevo objeto Field. Si no se pasa será dbText. _
'intSize            Optional    Determina el tamaño del nuevo objeto Field que contenga texto. Si no se pasa será 255.
'strPWD             Optional    Contraseña de la dbs según strPathNamedbs.
'------------------------------------------------------------------------------------------------------------------------
'Type (Propiedad), valores que se pueden establecer. Extracto de la ayuda de Access.
'   Constante       Valor   Descripción _
    dbBigInt        16      Big Integer,  Tipo de datos que almacena valores numéricos exactos con signo con una precisión 19 (con signo) o 20 (sin signo), escala 0 (con signo: -263 = n = 263-1; sin signo: 0 = n = 264-1). _
    dbBinary         9      Binary, Tipo de datos que almacena datos binarios de longitud fija. La longitud máxima es de 255 bytes. _
    dbBoolean        1      Boolean (Sí/No), Valor True/False o Sí/No. Los valores Boolean se almacenar normalmente en campos de tipo Bit de una base de datos Microsoft Jet. Sin embargo, algunas bases de datos no soportan este tipo de datos directamente. _
    dbByte           2      Byte, Tipo de datos fundamental utilizado para admitir números enteros positivos pequeños, en el intervalo de 0 a 255. _
    dbChar          18      Char, Tipo de datos que almacena una cadena de caracteres de longitud fija. La longitud se establece con la propiedad Size. _
    dbCurrency       5      Currency, Tipo de dato muy útil para los cálculos que incluyen dinero o cálculos de signo decimal fijo, en los que la exactitud es extremadamente importante. Este tipo de datos se utiliza para almacenar números de hasta 15 dígitos a la izquierda del signo decimal y 4 dígitos a la derecha. Dado que el tipo de datos Currency utiliza valores discretos para todas las cantidades, los redondeos binarios no son un factor cuando se calculan totales. _
    dbDate           8      Date / Time, Las fechas y horas se almacenan internamente como partes diferentes de un número real. _
                            El valor a la izquierda del signo decimal representa una fecha entre el 30 de diciembre de 1899 y el 30 de diciembre de 9999, ambos inclusive. Los valores negativos representas fechas anteriores al 30 de diciembre de 1899. _
                            El valor a la derecha del signo decimal representa una hora entre las 0:00:00 y las 23:59:59, ambas inclusive. El mediodía se representa por un .5. _
    dbDecimal       20      Decimal, Tipo de datos que almacena un valor numérico exacto con signo con una precisión p y una escala e (1 = p =15; 0 = e = p). _
    dbDouble         7      Double, Un tipo de dato fundamental que contiene números de signo flotante de doble precisión en formato IEEE. Una variable Double se almacena como un número de 64 bits (8 bytes) que varía entre -1.79769313486231E308 y -4.94065645841247E-324 para los valores negativos, desde 4.94065645841247E-324 a 1.79769313486231E308 para los valores positivos y 0. _
    dbFloat         21      Float, Tipo de datos que almacena un valor numérico aproximado con signo con una precisión de mantisa 15 (cero o valor absoluto de 10-308 a 10+308). _
    dbGUID          15      Guid, Identificador único global (Globally Unique Identifier/Universally Unique Identifier). Cadena de identificación única utilizada con las llamadas a procedimiento remotos. Cada interfaz y clase de objeto utiliza un GUID para su identificación. Un GUID es un valor de 128 bits de longitud. Por ejemplo, 12345678-1234-1234-1234-123456789ABC es un GUID con una sintaxis correcta. Los GUID del cliente y del servidor deben coincidir para que el cliente y el servidor se relacionen. Los vendedores de objetos OLE puede requerir que Microsoft reserve uno o más juegos de 256 GUID para su uso exclusivo. De forma alternativa, si tiene una tarjeta de red, puede ejecutar una herramienta llamada UUIDGEN.EXE, que le proporciona un conjunto de 256 GUID basados en la hora del día, la fecha y un número único contenido en su tarjeta de red. _
    dbInteger        3      Integer, Un tipo de datos fundamental que contiene números enteros. Una variable de tipo Integer se almacena como un número de 16 bits (2 bytes) de longitud, con un valor entre -32,768 y 32,767. _
    dbLong           4      Long, Tipo de datos fundamental que contiene valores de enteros largos. Una variable de tipo Long se almacena como un número de 32 bits de longitud (4 bytes) con un valor comprendido en el rango -2,147,483,648 a 2,147,483,647. _
    dbLongBinary    11      Long Binary (Objeto OLE). Ole Object, Tipo de datos de campo que se utiliza en objetos creados en otras aplicaciones que se pueden vincular e incrustar a una base de datos Microsoft Jet. Por ejemplo, puede utilizar un Objeto OLE para almacenar una colección de imágenes. _
    dbMemo          12      Memo, Tipo de datos de campo. Como los campos, puede contener hasta 1.2 GB de datos. _
    dbNumeric       19      Numeric, Tipo de datos que almacena un valor numérico exacto con signo con una precisión p y una escala e (1 = p =15; 0 = e = p). _
    dbSingle         6      Single, Tipo de datos fundamental que contiene un números de punto flotante de precisión simple en formato numérico IEEE. Una variable Single se almacena como un número de 32 bits de longitud (4 bytes) cuyo valor está comprendido entre -3.402823E38 y -1.401298E-45 para números negativo, entre 1.401298E-45 y 3.402823E38 si es positivo y 0. _
    dbText          10      Text, Tipo de datos de campo. Los campos de texto pueden contener hasta 255 caracteres o el número de caracteres especificado por la propiedad Size de objeto Field, siempre que sea menor. Si la propiedad Size del campo de texto está establecido a 0, el campo de texto puede contener hasta 255 caracteres de datos. _
    dbTime          22      Time, Tipo de datos que almacena un valor de hora. El valor depende del valor del reloj del origen de datos. _
    dbTimeStamp     23      TimeStamp, Tipo de datos que almacena una marca de hora. El valor depende del valor del reloj del origen de datos. _
    dbVarBinary     17      VarBinary, Tipo de datos que almacena datos binarios de longitud variable. La longitud máxima es de 255 bytes.
'------------------------------------------------------------------------------------------------------------------------
  
    Dim dbs             As DAO.Database
   
    Dim tdf             As DAO.TableDef
   
    Dim fld             As DAO.Field
   
    Dim bytMétodo       As Byte                     'Método a seleccionar para crear la tabla.
   
    Dim strSql          As String
    Dim strType         As String
   
   
On Error GoTo mcblnSetToCreateTable_CapturarError

    If strPWD = "" Then
        Set dbs = OpenDatabase(strPathNamedbs, True, False)
    Else
        Set dbs = OpenDatabase(strPathNamedbs, True, False, ";PWD=" & strPWD)
    End If
   
    For Each tdf In dbs.TableDefs
        If tdf.Name = strTable Then
            mcblnSetToCreateTable = True
            Exit For
        End If
    Next tdf
   
    If bytType = 0 Then
        bytType = DAO.dbText
    End If
   
    If Not mcblnSetToCreateTable Then
        bytMétodo = 4
        'Esta explicación de métodos es para que me quede constancia de las diferentes posibilidades que tenemos para _
        realizar la misma operación de crear una tabla, la finalidad es la misma pero en según que ocasiones nos puede _
        interesar sobre todo en no declarar los objetos.
   
        If bytMétodo = 1 Then
            'Este primer método nos permite no declarar ningún objeto ni como Database, ni Tabledef, ni Field, es un _
            modo de proceder directo.
'            OpenDatabase(strPathNamedbs, True, False).TableDefs(strTable).Fields.Append _
                    OpenDatabase(strPathNamedbs, True, False).TableDefs(strTable).CreateField(strField, bytType, intSize)
'            mcblnSetToCreateTable = True
        ElseIf bytMétodo = 2 Then
            'Si tenemos necesidad de declarar una variable como objeto Database, esta sentencia es más corta.
'            dbs.TableDefs(strTable).Fields.Append dbs.TableDefs(strTable).CreateField(strField, bytType, intSize)
'            mcblnSetToCreateTable = True
        ElseIf bytMétodo = 3 Then
            'Más corto este tercer método aunque se debe de hacer en dos líneas.
'            Set tdf = dbs.TableDefs(strTable)
'            tdf.Fields.Append tdf.CreateField(strField, bytType, intSize)                 'Crear el campo.
'            mcblnSetToCreateTable = True
        ElseIf bytMétodo = 4 Then
            'El método cuarto es el más estructurado aunque necesita declarar cada uno de los objeto.
            Set tdf = dbs.CreateTableDef(strTable)
            Set fld = tdf.CreateField(strField, bytType, intSize)
            tdf.Fields.Append fld
            dbs.TableDefs.Append tdf
            mcblnSetToCreateTable = True
        ElseIf bytMétodo = 5 Then
            'Método que usa una sentencia SQL y que no es necesario DAO salvo cuando la tabla a crear está fuera de la _
            que ejecuta este código.
            If intSize = 0 Then intSize = 255
            Select Case bytType
                Case DAO.dbByte
                    strType = "BYTE"
                Case DAO.dbText
                    strType = "TEXT" & "(" & intSize & ")"
                Case DAO.dbInteger
                    strType = "INTEGER"
                Case DAO.dbMemo
                    strType = "MEMO"
                'etc. etc.
                Case Else
                    MsgBox "No se ha indicado un tipo de datos conocido.", vbCritical, "McPegasus informa"
            End Select
            'Ejemplo:   CREATE TABLE tblPruebaAA (fldIdCampoAA TEXT(50))
            strSql = "CREATE TABLE " & strTable & " (" & strField & " " & strType & ")"
            dbs.Execute (strSql)
           
            'Método en caso de ejecutar en la propia dbs y sin DAO.
            'CodeDb.Execute (strSql)
           
            mcblnSetToCreateTable = True
        End If
    End If

mcblnSetToCreateTable_Salida:
    If Not fld Is Nothing Then
        Set fld = Nothing
    End If
   
    If Not tdf Is Nothing Then
        Set tdf = Nothing
    End If
       
    If Not dbs Is Nothing Then
        dbs.Close
        Set dbs = Nothing
    End If

   On Error GoTo 0
   Exit Function

mcblnSetToCreateTable_CapturarError:
    Select Case Err.Number
        Case Else
            'Cazar todos aquellos errores inesperados.
            MsgBox "Error " & Err.Number & " (" & Err.Description & ") in procedure mcblnSetToCreateTable."
    End Select
    'Salida a otro procedimiento.
    Resume mcblnSetToCreateTable_Salida
   
End Function

Option Compare Database
Option Explicit
'------------------------------------------------------------------------------------------------------------------------
' Módulo        :   basMcCompresiónCabXP
' Creación      :   23/05/2007 09:31
' Autor         :   Copyright ©1999-2007 McPegasus, www.mcpegasus.es, mcpegasus@mcpegasus.es
' Propósito     :   Con los recursos propios de Windows, conseguir en un archivo .cab creado desde cero y que contenga _
                    uno o varios archivos. _
                    Es posible incluir también un archivo que esté abierto, por ejemplo la propia base de datos que se _
                    está ejecutando el código.
' Qué hacer     :   Copiar todo el texto, crear un nuevo módulo en tu base de datos y pegar. _
                    Guardar con el nombre basMcCompresiónCabXP
'------------------------------------------------------------------------------------------------------------------------
'Documentación  :   Guille, http://www.elguille.info/vb/utilidades/MakeCab_TypeLibrary_w2000.htm _
                            http://www.elguille.info/vb/utilidades/MakeCabXP.htm
'------------------------------------------------------------------------------------------------------------------------
'Observaciones  :   Sólo crear archivos .cab, no hay utilidad de descompresión, para ello hay que usar una herramienta _
                    externa.
'------------------------------------------------------------------------------------------------------------------------

Sub test_mcblnComprimirArchivosCab()

    Dim strPathsFields          As String
   
    Dim strPathNameCab          As String

   
    strPathNameCab = "C:\Test.cab"
   
'    strPathsFields = "c:\Temp\Text01.txt;c:\Temp\Text02.txt"
    strPathsFields = CodeDb.Name
   
    If mcblnComprimirArchivosCab(strPathNameCab, strPathsFields) Then
        MsgBox "Se ha producido la compresión .cab con éxito.", vbInformation, "McPegasus informa"
    End If

End Sub

Public Function mcblnComprimirArchivosCab(ByVal strPathNameCab As String, ByVal strPathsNames As String) As Boolean
'------------------------------------------------------------------------------------------------------------------------
' Function      :   mcblnComprimirArchivosCab
' Creación      :   22/05/2007 16:45
' Autor         :   Copyright ©1999-2007 McPegasus, www.mcpegasus.es, mcpegasus@mcpegasus.es
' Origen        :   Adaptación de la idea original en http://www.mvp-access.com/emilio de Emilio Sancha, Gracias Emilio.
' Propósito     :   Comprimir uno o varios archivos a formato .zip con los recursos propios de Windows XP.
'------------------------------------------------------------------------------------------------------------------------
' Referencia/s  :   Nombre: COM MakeCab 1.0 Type Library
'                   Ruta:   c:\Windows\System32\catsrvut.dll
'------------------------------------------------------------------------------------------------------------------------
' Retorno       :   True / False, en caso de producirse la acción con éxito. False en caso de cualquier error.
'
'Argumento/s, la sintaxis del Procedimiento o Función consta de/los siguiente/s argumento/s:
'Parte              Descripción
'------------------------------------------------------------------------------------------------------------------------
'strPathNameCab     Requerido   Ruta y nombre completo con extensión .zip donde se creará el archivo destino.
'strPathsNames      Opcional    Cadena de texto donde establecer la ruta o rutas de los archivos a comprimir, separadas _
                                por ; en caso de haber más de una.
'------------------------------------------------------------------------------------------------------------------------

    Dim cab                     As COMMKCABLib.MakeCab
   
    Dim blnCopiar               As Boolean
   
    Dim intCount                As Integer
    Dim intPos                  As Integer
   
    Dim strArchivo              As String
    Dim strNombreDestino        As String           'Independizar el nombre destino del archivo a comprimir a .cab.
    Dim strNewPathName          As String           'En caso de estar abierto, copiarlo a Temp.
    Dim strWorkMatriz()         As String
   
   
On Error GoTo mcblnComprimirArchivosCab_CapturarError

    'Comprobar que la matriz no está vacía.
    If Not strPathsNames = "" Then
        Set cab = New COMMKCABLib.MakeCab
        cab.CreateCab strPathNameCab, False, 0, False
        strWorkMatriz = Split(strPathsNames, ";")
        For intCount = LBound(strWorkMatriz) To UBound(strWorkMatriz)
            strArchivo = strWorkMatriz(UBound(strWorkMatriz))
            strNombreDestino = Dir(strArchivo)
            'Comprobar si el/lo archivo/s está/n abierto/s, en ese caso crear una copia en Temp.
            If eshblnEstáAbiertoArchivo(strArchivo) Then
                'Copiar el archivo en la ruta Temp del sistema para copiarlo desde ese con extensión tmp.
                strNewPathName = Environ("TEMP") & "\" & IIf(InStr(1, Dir(strArchivo), ".") = 0, Dir(strArchivo), Mid(Dir(strArchivo), 1, InStr(1, Dir(strArchivo), ".") - 1) & ".tmp")
                blnCopiar = kbblnCopyFile(strArchivo, strNewPathName)
                If blnCopiar Then                       'En caso de true se ha realizado la copia con éxito.
                    'Establecer la nueva ruta para que se copie al archivo zip.
                    strWorkMatriz(intCount) = strNewPathName
                End If
            Else
                blnCopiar = True
            End If
            If blnCopiar Then
                'Copiar / introducir un archivo dentro del archivo .cab.
                cab.AddFile strWorkMatriz(intCount), strNombreDestino
                mcblnComprimirArchivosCab = True
                If Not strNewPathName = "" Then
                    'En caso de estar abierto el archivo, borrar la copia que se ha generado en Temp.
 'Lo ideal es poder borrar el archivo temporal, pero hay que hacer una pausa en el código hasta que se haya realizado _
 toda la copia por el método oShell. _
 En este caso del .cab, se ha podido enmascarar el archivo en Temp, con la extensión .tmp.
 '                  Kill (strNewPathName)
                End If
            End If
        Next intCount
        cab.CloseCab
    End If
   
Salida:
   Set cab = Nothing
   On Error GoTo 0
   Exit Function

mcblnComprimirArchivosCab_CapturarError:
    MsgBox "Error " & Err.Number & " (" & Err.Description & ") in procedure mcblnComprimirArchivosCab."
Resume
    Resume Salida                       'Salida a otro procedimiento.

End Function

Sub test_eshblnEstáAbiertoArchivo()

    Dim strPathNameCab          As String

   
    strPathNameCab = "c:\Temp\Prueba.Graficos.mdb"

    If eshblnEstáAbiertoArchivo(strPathNameCab) Then
        MsgBox "El archivo está abiero y usándose por otra aplicación.", vbInformation, "Mcpegasus informa"
    End If

End Sub

Private Function eshblnEstáAbiertoArchivo(ByVal strPathName As String) As Boolean

'------------------------------------------------------------------------------------------------------------------------
' Function      :   eshblnEstáAbiertoArchivo                    Forma parte de McMódulosVXXXX.mdb
' Creación      :   22/05/2007 15:00
' Autor         :   Copyright ©1999-2007 McPegasus, www.mcpegasus.es, mcpegasus@mcpegasus.es
' Origen        :   Idea original en http://www.mvp-access.com/emilio de Emilio Sancha, procedimiento EstaAbierto. _
                    ESH 07/04/05 10:15
' Propósito     :   Comprobar si un archivo está siendo usado por otra aplicación.
'------------------------------------------------------------------------------------------------------------------------
' Retorno       :   True / False, en caso de que el archivo está abierto o cerrado.
'
'Argumento/s, la sintaxis del Procedimiento o Función consta de/los siguiente/s argumento/s:
'Parte              Descripción
'------------------------------------------------------------------------------------------------------------------------
'strPathName    Requerido   Ruta y nombre del archivo a comprobar si está abierto y usándose por otro programa.
'------------------------------------------------------------------------------------------------------------------------

On Error GoTo eshblnEstáAbiertoArchivo_CapturarError

    Dim lngArchivo As Long

   
    lngArchivo = FreeFile

    'Intentar abrirlo con bloqueo de lectura y escritura, si falla, es porque ya está abierto.
    Open strPathName For Random Access Read Write Lock Read Write As lngArchivo

eshblnEstáAbiertoArchivo_Salida:
   Close lngArchivo
   On Error GoTo 0
   Exit Function

eshblnEstáAbiertoArchivo_CapturarError:
    Select Case Err.Number
        Case 70                         'Permiso denegado.
            'No hacer nada, filtrar el error ya que se retorna un valor True.
        Case Else
            MsgBox "Error " & Err.Number & " (" & Err.Description & ") in procedure eshblnEstáAbiertoArchivo."
    End Select
    eshblnEstáAbiertoArchivo = True
    Resume eshblnEstáAbiertoArchivo_Salida
   
End Function

Sub demo_kbblnCopyFile()

    Dim strOrigen   As String
    Dim strDestino  As String

   
    strOrigen = "c:\Temp\Text02.txt"
    strDestino = "C:\Test.zip"

    If kbblnCopyFile(strOrigen, strDestino) Then
        MsgBox "Se ha realizado la copia del archivo con éxito.", vbInformation, "Mcpegasus informa"
    End If

End Sub

Private Function kbblnCopyFile(ByVal strPathNameFileOrigin As String, _
                               ByVal strPathNameFileDestination As String) As Boolean
'------------------------------------------------------------------------------------------------------------------------
' Function      :   kbblnCopyFile
' Creación      :   23/05/2007 10:22
' Autor         :   Copyright ©1999-2007 McPegasus, www.mcpegasus.es, mcpegasus@mcpegasus.es
' Origen        :   http://support.microsoft.com/kb/102671/es
' Propósito     :   Copiar un archivo de un lugar de disco a otra ruta diferente. La particularidad de este _
                    procedimiento es que puede copiar archivos abiertos, un problema habitual al intentar copiar la _
                    propia dbs que ejecuta el código. Hay una excepción que he encontrado y es que se produce el error _
                    70 Acceso denegado en caso de querer copiar una dbs que se está abriendo con Access desde otra _
                    versión posterior y sale el mensaje "Convertir o abrir base de datos".
'------------------------------------------------------------------------------------------------------------------------
' Retorno       :   True o False, según la copia se ha realizado con éxito o no.
'
'Argumento/s, la sintaxis del Procedimiento o Función consta de/los siguiente/s argumento/s:
'Parte                      Descripción
'------------------------------------------------------------------------------------------------------------------------
'strPathNameFileOrigin      Requerido   Ruta completa con el nombre del archivo origen que se va a copiar en otra lugar.
'strPathNameFileDestination Opcional    Ruta completa con el nombre del archivo destino.
'------------------------------------------------------------------------------------------------------------------------
   
    Const BlockSize = 32768
   
    Dim Index1          As Integer
    Dim NumBlocks       As Integer
    Dim SourceFile      As Integer
    Dim DestFile        As Integer
   
    Dim FileLength      As Long
    Dim LeftOver        As Long
    Dim FileData        As String
   

    On Error GoTo Err_kbblnCopyFile

    ' Remove the destination file.
    DestFile = FreeFile
    Open strPathNameFileDestination For Output As DestFile
    Close DestFile

    ' Open the source file to read from.
    SourceFile = FreeFile
    Open strPathNameFileOrigin For Binary Access Read As FreeFile

    ' Open the destination file to write to.
    DestFile = FreeFile
    Open strPathNameFileDestination For Binary As DestFile

    ' Get the length of the source file.
    FileLength = LOF(SourceFile)

    ' Calculate the number of blocks in the file and left over.
    NumBlocks = FileLength \ BlockSize
    LeftOver = FileLength Mod BlockSize

    ' Create a buffer for the leftover amount.
    FileData = String$(LeftOver, 32)

    ' Read and write the leftover amount.
    Get SourceFile, , FileData
    Put DestFile, , FileData

    ' Create a buffer for a block to be read.
    FileData = String$(BlockSize, 32)

    ' Read and write the remaining blocks of data.
    For Index1 = 1 To NumBlocks
       ' Read and write one block of data.
       Get SourceFile, , FileData
       Put DestFile, , FileData
    Next Index1

    Close SourceFile, DestFile
    kbblnCopyFile = True

Bye_kbblnCopyFile:
    Exit Function

Err_kbblnCopyFile:
    MsgBox "Error " & Err.Number & " (" & Err.Description & ") in procedure kbblnCopyFile."
    Debug.Print Err.Number & " " & Err.Description
    kbblnCopyFile = False
    Resume Bye_kbblnCopyFile

End Function

 

 

 

MOD xp.

 

Descripción del problema:

El error que se trata se produce al instalar un paquete generado con el Packaging Wizard de Office XP (2002) sobre un sistema operativo Windows Server 2003 o Windows XP con el SP2, no se produce sin mencionado Service Pack.

Título del error:

    Visual Basic 6.0 Setup Toolkit

 

Mensaje:

    Office System Pack no se puede instalar en este sistema. Necesita Windows NT 4.0 Service Pack 6 o posterior.

 

Solución:

    En español, http://support.microsoft.com/default.aspx?scid=kb;es-es;837150

    Idioma origen, http://support.microsoft.com/default.aspx?scid=kb;en-us;837150

Cuando quiero iniciar el programa Access 97 aparece el siguiente mensaje:  "Imposible iniciar Microsoft Access porque no hay licencia para el producto en este equipo".

Este problema está documentado por Microsoft en la KB con el Id. de artículo 191224,  http://support.microsoft.com/default.aspx?scid=kb;es-es;Q191224

 

En The Access Web proponen la siguiente solución (incluyen Access 95), http://www.mvps.org/access/bugs/bugs0013.htm

Este ejemplo puede sustituir a los botones de desplazamiento que trae por defecto Access en los formularios.

 

Con esta personalización se tiene un subformulario con los botones de desplazamiento de registros personalizados y que se puede usar en varios formularios en la misma base de datos o proyecto, de este modo evitamos duplicidades.

 

Una característica es que añade un botón para borrar el registro, tal y como tiene el navegador del objeto Página de las versiones 2000 y superiores.

 

 

'------------------------------------------------------------------------------------------------------------------------
' Módulo    : basHideOrShowAccessWindow
' Creación  : 26/07/2006 14:38
' Autor     : McPegasus, www.mcpegasus.es, mcpegasus@mcpegasus.es
' Qué hacer : Copiar todo el texto, crear un nuevo módulo en tu base de datos y pegar. Guardar con el nombre basHideOrShowAccessWindow
'------------------------------------------------------------------------------------------------------------------------

 

Option Compare Database
Option Explicit

 

    Dim lngReturn           As Long

 

    Public Const SW_HIDE           As Long = 0
    Public Const SW_SHOWNORMAL     As Long = 1
    Public Const SW_SHOWMINIMIZED  As Long = 2
    Public Const SW_SHOWMAXIMIZED  As Long = 3

Private Declare Function ShowWindow Lib "user32" (ByVal hwnd As Long, ByVal nCmdShow As Long) As Long
Private Declare Function IsWindowVisible Lib "user32" (ByVal hwnd As Long) As Long

 

Sub demo_mcblnEstadoAccessWindow_A()

    Dim strMensaje      As String
   
    Dim strRetVal       As String
   

    strMensaje = "El estado visible de la ventana de Access es: " & vbCr & vbCr
    strMensaje = strMensaje & "          " & mcblnEstadoAccessWindow(, True) & vbCr & vbCr & vbCr & vbCr
    strMensaje = strMensaje & "Seleccionar una opción para cambiarlo, " & vbCr & vbCr
    strMensaje = strMensaje & "0.- Hacer invisible la ventana de Access." & vbCr _
                            & "1.- Restaurar el tamaño." & vbCr _
                            & "2.- Minimizar." & vbCr _
                            & "3.- Maximizar."

    strRetVal = Nz(InputBox(strMensaje, "McPegasus informa.", 0))

    If Not strRetVal = "" Then
        Call mcblnEstadoAccessWindow(Int(strRetVal))
    End If

End Sub

 

Private Sub demo_mcblnEstadoAccessWindow_B()

    'Se puede usar esta llamada en el formulario de inicio de la aplicación y en su evento "Al abrir".
    Call mcblnEstadoAccessWindow(SW_HIDE)                       'Esconder la ventana.

'    Debug.Print mcblnEstadoAccessWindow(SW_SHOWMINIMIZED)      'Minimizar.
'    Debug.Print mcblnEstadoAccessWindow(SW_SHOWMAXIMIZED)      'Maximizar.
'    Debug.Print mcblnEstadoAccessWindow(SW_SHOWNORMAL)         'Tamaño restaurado.

End Sub

 

Public Function mcblnEstadoAccessWindow(Optional ByVal lngProcedure As Long, _
                                        Optional ByVal blnVerificarEstado As Boolean) As Boolean
'------------------------------------------------------------------------------------------------------------------------
' Function      :   mcblnEstadoAccessWindow                                             Forma parte de McMódulosV26k2.mdb
' Creación      :   27/01/2002
' Autor         :   McPegasus, www.mcpegasus.es, mcpegasus@mcpegasus.es
' Origen        :   Desconocido, adaptado de un código encontrado en la red.
' Propósito     :   Cambiar el estado de la ventana de Access, hacer invisible, maximizar, minimizar o restaurar.
'------------------------------------------------------------------------------------------------------------------------
' Actualizado   :   26/07/2006, Reestructuración y optimización del código, cambia el nombre de la función de _
                    fAccessWindow a el actual mcblnEstadoAccessWindow.
'------------------------------------------------------------------------------------------------------------------------
' Retorno       :   Si el valor de blnVerificarEstado es True, el retorno será el estado en el que está la ventana de _
                    Access es decir True para visible o False si está invisible.
'
'La sintaxis del Procedimiento o Función, consta de estos argumentos:
'Parte                  Descripción
'------------------------------------------------------------------------------------------------------------------------
'lngProcedure       Opcional    Para indicar el estado a cambiar de la ventana, según las constantes declaradas.
'blnVerificarEstado Opcional    Para conocer el estado actual de la ventana.

    If blnVerificarEstado Then
        mcblnEstadoAccessWindow = IIf(IsWindowVisible(hWndAccessApp) = 0, False, True)
    Else
        mcblnEstadoAccessWindow = ShowWindow(Application.hWndAccessApp, lngProcedure)
    End If

End Function

 

 

Public Function mcstrSustituirCadena(ByVal intInicio As Integer, _
                                     ByVal strValor As String, _
                                     ByVal strValorASustituir As String, _
                                     ByVal strValorAInsertar As String, _
                                     Optional ByVal intVeces As Integer = 1) As String

'------------------------------------------------------------------------------------------------------------------------
' Function    : mcstrSustituirCadena                                                    Forma parte de McMódulosV26k2.mdb
' Creación    : 24/07/2006 13:16
' Autor       : McPegasus, www.mcpegasus.es, mcpegasus@mcpegasus.es
' Propósito   : Sustituir una cadena (strValorAInsertar) por otra (strValorASustituir) incluida en otra strValor.
'------------------------------------------------------------------------------------------------------------------------
' Retorno     : Una nueva cadena con los valores sustituidos.
'------------------------------------------------------------------------------------------------------------------------
'La sintaxis del Procedimiento o Función, consta de estos argumentos:
º 'Parte                          Descripción
'------------------------------------------------------------------------------------------------------------------------
'intInicio          Requerido   Posición inicial donde buscar.
'strValor           Requerido   Cadena donde está el valor a buscar y sustituir.
'strValorASustituir Requerido   Valor de la cadena a sustituir.
'strValorAInsertar  Requerido   Valor de la cadena que va a sustituir.
'intVeces           Opcional    Cantidad de veces a realizar la sustitución.

    Dim intPosición     As Integer
    Dim intCount        As Integer
   
    Dim strTemporal     As String

    intPosición = InStr(intInicio, strValor, strValorASustituir)
    Do While Not intPosición = 0
        If intVeces <= intCount Then
            intPosición = 0
        Else
            If Not intPosición = 0 Then
                strTemporal = Mid(strValor, intInicio, intPosición - 1)
                strTemporal = strTemporal & strValorAInsertar
                strTemporal = strTemporal & Mid(strValor, intPosición + Len(strValorASustituir))
                strValor = strTemporal
                intPosición = InStr(intInicio, strValor, strValorASustituir)
            End If
        End If
        intCount = intCount + 1
    Loop
   
    mcstrSustituirCadena = strValor

End Function

Sub demo_mcstrSustituirCadena()

    Dim intVeces                As Integer

    Dim strValor                As String
    Dim strValorASustituir      As String
    Dim strValorAInsertar       As String
   

    strValor = "Esto es una prueba de sustitución de texto y una prueba muy funcional prueba prueba."
'    strValor = "1.prueba 2.prueba 3.prueba 4.prueba"
    strValorASustituir = "prueba"
    strValorAInsertar = "demo"

    intVeces = 2
   
    Debug.Print mcstrSustituirCadena(1, strValor, strValorASustituir, strValorAInsertar, intVeces)

End Sub

 

Si se tiene la necesidad de cerrar el formulario pulsando la tecla Esc, podemos conseguirlo con las instrucciones siguientes,

Con este código conseguimos simplificar la entrada de una fecha tal como podemos conseguir con Excel que al poner por ejemplo 10/05 en una celda conseguimos que nos ponga el año o depende del formato que tenga la celda.

 

En caso de tener el formato dd/mm/aaaa y al poner 21/04 en una celda, obtenemos 21/04/2006, ha añadido el año que tenga el sistema.

 

Rizando el rizo y con la intención de mejorar la calidad del usuario que usa la aplicación, con McFechas.AutomatizarEntradas obtenemos el código de ejemplo para la conversión al introducir los datos siguientes,

 

Microsoft Snapshot Viewer 10.0 El Visor de instantáneas Snapshot Viewer le permite ver una instantánea de informe sin tener el estándar de
versiones en tiempo de ejecución de Microsoft Access 97, Access 2000, o Access 2002.

 

Centro de descarga de Microsoft

 

'Crea un módulo nuevo y pega este código. Nombre: basQuitarBarraTitulos

Option Compare Database
Option Explicit

Const NombreModulo = "basFormGlobal"

' Store rectangle coordinates.
Type adhTypeRect
    X1 As Long
    Y1 As Long
    x2 As Long
    Y2 As Long
End Type

Declare Function adh_apiIsIconic Lib "user32" _
        Alias "IsIconic" (ByVal hWnd As Long) As Long

Declare Function adh_apiGetDeviceCaps Lib "gdi32" _
        Alias "GetDeviceCaps" (ByVal hdc As Long, ByVal nIndex As Long) As Long

Declare Function adh_apiGetWindowRect Lib "user32" _
        Alias "GetWindowRect" (ByVal hWnd As Long, lpRect As adhTypeRect) As Long

Declare Function adh_apiGetParent Lib "user32" _
        Alias "GetParent" (ByVal hWnd As Long) As Long

Declare Function adh_apiGetClientRect Lib "user32" _
        Alias "GetClientRect" (ByVal hWnd As Long, lpRect As adhTypeRect) As Long

Declare Function adh_apiGetWindowLong Lib "user32" _
        Alias "GetWindowLongA" (ByVal hWnd As Long, ByVal nIndex As Long) As Long

Declare Function adh_apiGetSystemMetrics Lib "user32" _
        Alias "GetSystemMetrics" (ByVal nIndex As Long) As Long

Declare Function adh_apiGetActiveWindow Lib "user32" _
        Alias "GetActiveWindow" () As Long

'=======================================================================

' Store group/subform dimensions.
Type adhTypeDimensions
    sglLeft As Double
    sglTop As Double
    sglWidth As Double
    sglHeight As Double
    strCtlName As String
End Type

' These are the class names used in Access.
Public Const adhcAccessClass = "OMain"
Public Const adhcMDIClientClass = "MDICLIENT"
Public Const adhcAccessDBCClass = "ODb"
Public Const adhcAccessFormClass = "OForm"

' Windows API declarations.
Declare Function adh_apiCreateIC Lib "gdi32" _
        Alias "CreateICA" (ByVal lpDriverName As String, _
        ByVal lpDeviceName As String, ByVal lpOutput As String, lpInitData As Any) As Long

Declare Function adh_apiDeleteDC Lib "gdi32" _
        Alias "DeleteDC" (ByVal hdc As Long) As Long

Declare Function adh_apiMoveWindow Lib "user32" _
        Alias "MoveWindow" (ByVal hWnd As Long, _
        ByVal x As Long, ByVal Y As Long, ByVal nWidth As Long, _
        ByVal nHeight As Long, ByVal bRepaint As Long) As Long

Declare Function adh_apiSetWindowLong Lib "user32" _
        Alias "SetWindowLongA" (ByVal hWnd As Long, _
        ByVal nIndex As Long, ByVal dwNewLong As Long) As Long

Declare Function adh_apiGetWindow Lib "user32" _
        Alias "GetWindow" (ByVal hWnd As Long, ByVal wCmd As Long) As Long

Declare Function adh_apiGetClassName Lib "user32" _
        Alias "GetClassNameA" (ByVal hWnd As Long, _
        ByVal lpClassName As String, ByVal nMaxCount As Long) As Long

Declare Function adh_apiFindWindow Lib "user32" _
        Alias "FindWindowA" (ByVal lpClassName As String, _
        ByVal lpWindowName As String) As Long

Declare Function adh_apiGetNextWindow Lib "user32" _
        Alias "GetNextWindow" (ByVal hWnd As Long, ByVal wFlag As Long) As Long

Declare Function adh_apiSetFocus Lib "user32" _
        Alias "SetFocus" (ByVal hWnd As Long) As Long

' Get a string from a private INI file.  Returns the number of bytes
' copied into strReturned, not including the trailing null.
Declare Function adh_apiGetPrivateProfileString Lib "kernel32" _
        Alias "GetPrivateProfileStringA" (ByVal lpApplicationName As String, _
        ByVal lpKeyName As String, ByVal lpDefault As String, _
        ByVal lpReturnedString As String, ByVal nSize As Long, _
        ByVal lpFileName As String) As Long

' Write a string to a private INI file.  Returns a non-zero value if successful,
' otherwise it returns a 0.
Declare Function adh_apiWritePrivateProfileString Lib "kernel32" _
        Alias "WritePrivateProfileStringA" (ByVal lpApplicationName As String, _
        ByVal lpKeyName As String, ByVal lpString As String, _
        ByVal lpFileName As String) As Long

' These functions aren't actually used
' but are provided here for reference only.

' Get a string from WIN.INI. Returns the number of bytes copied into strReturned,
' not including the trailing null.
Declare Function adh_apiGetProfileString Lib "kernel32" _
        Alias "GetProfileStringA" (ByVal lpadhcAppName As String, _
        ByVal lpKeyName As String, ByVal lpDefault As String, _
        ByVal lpReturnedString As String, ByVal nSize As Long) As Long

' Get an integer from WIN.INI.  Returns either the integer it found,
' or the value sent in intDefault.
Declare Function adh_apiGetProfileInt Lib "kernel32" _
        Alias "GetProfileIntA" (ByVal lpadhcAppName As String, _
        ByVal lpKeyName As String, ByVal nDefault