Mensajes recientes

Páginas: 1 2 [3] 4 5 ... 10
21
Formularios / Crear menú flotante
« Último mensaje por xavi en Mayo 02, 2020, 05:08:16 pm »
Palabras clave: formulario, menú, API
Autor: Candace Tripp
Extraído de: Utter Access (allá por 2007)

Objetivo:
Crear un menú flotante en el formulario.

Utilizamos un formulario con 3 botones (el ejemplo original utiliza 3 botones transparentes encima de 3 etiquetas pero se puede hacer con botones de fondo transparente)
En el módulo de clase del ejemplo las opciones se definen "a pedal". Se podría trabajar con una tabla que llame a funciones (a estudiar)

El código del formulario es este:

Código: [Seleccionar]
Option Compare Database
Option Explicit

Dim oMenu As cMenu

Private Sub mnuFile_Click()
    oMenu.ShowMenu "File"
End Sub

Private Sub mnuEdit_Click()
    oMenu.ShowMenu "Edit"
End Sub

Private Sub mnuHelp_Click()
    oMenu.ShowMenu "About"
End Sub

Private Sub Form_Load()
   
    Set oMenu = New cMenu
    Set oMenu.CurrentForm = Me

End Sub

Después tenemos un módulo de clase como este:

Código: [Seleccionar]
Option Compare Database
Option Explicit
'######################################################################
'
'CLASSNAME      :   cMenu
'
'PURPOSE        :   Class to emulate a drop down menu using API calls
'
'DATE CREATED   :   2/2/2005
'
'AUTHOR         :   Candace Tripp
'                   http://www.candace-tripp.com/
'
'NOTE           :   This API calls/code is a modification of Bryan Stafford's
'                   popup menu demo project written in Visual Basic 6.
'                   This demo is released into the public domain "as is" without
'                   warranty or guaranty of any kind.  In other words, use at your own risk.
'                   His comments are below
'
'MODIFICATIONS:
'   DATE        MODIFIED BY     MODIFICATION DESCRIPTION
'   ----        -----------     -----------------------------------------
'
'######################################################################

'Bryan Stafford of New Vision Software
'######################################################################
' demo project showing how to use the API menu functions to create a
' popup menu. by Bryan Stafford of New Vision Software - newvision@mvps.org
' this demo is released into the public domain "as is" without warranty or
' guaranty of any kind.  In other words, use at your own risk.


' the handles to our popup menus.  we keep them at the module level so that
' we don't have to recreate the menus each time we want to display them.
'######################################################################
 
    Private m_CurrentForm As Form
    Private m_lngItemWidth As Long
    Private m_lngItemTop As Long
   
    Private m_hMenu(3) As Long
    Private m_hSubMenu(3) As Long
   
    Private Type POINTAPI
        X As Long
        Y As Long
    End Type
   
    Private Const MF_INSERT As Long = &H0&
    Private Const MF_CHANGE As Long = &H80&
    Private Const MF_APPEND As Long = &H100&
    Private Const MF_DELETE As Long = &H200&
    Private Const MF_REMOVE As Long = &H1000&
    Private Const MF_BYCOMMAND As Long = &H0&
    Private Const MF_BYPOSITION As Long = &H400&
    Private Const MF_SEPARATOR As Long = &H800&
    Private Const MF_ENABLED As Long = &H0&
    Private Const MF_GRAYED As Long = &H1&
    Private Const MF_DISABLED As Long = &H2&
    Private Const MF_UNCHECKED As Long = &H0&
    Private Const MF_CHECKED As Long = &H8&
    Private Const MF_USECHECKBITMAPS As Long = &H200&
    Private Const MF_STRING As Long = &H0&
    Private Const MF_BITMAP As Long = &H4&
    Private Const MF_OWNERDRAW As Long = &H100&
    Private Const MF_POPUP As Long = &H10&
    Private Const MF_MENUBARBREAK As Long = &H20&
    Private Const MF_MENUBREAK As Long = &H40&
    Private Const MF_UNHILITE As Long = &H0&
    Private Const MF_HILITE As Long = &H80&
    Private Const MF_SYSMENU As Long = &H2000&
    Private Const MF_HELP As Long = &H4000&
    Private Const MF_MOUSESELECT As Long = &H8000&
   
   
    Private Const TPM_RETURNCMD As Long = &H100&
   
   
    Private Const ID_BEEP As Long = &H6000&
    Private Const ID_SEPARATOR As Long = &H6001&
    Private Const ID_DISABLED As Long = &H6002&
    Private Const ID_MSGBOX As Long = &H6003&
   
    Private Const ID_ADD As Long = &H6004&
    Private Const ID_EDIT As Long = &H6005&
    Private Const ID_DELETE As Long = &H6006&
    Private Const ID_EXIT As Long = &H6007&
    Private Const ID_HELP As Long = &H6008&
   
    Private Declare Function CreatePopupMenu Lib "user32" () As Long
    Private Declare Function DestroyMenu Lib "user32" (ByVal hMenu&) As Long
    Private Declare Function AppendMenu Lib "user32" Alias "AppendMenuA" (ByVal hMenu&, ByVal wFlags&, ByVal wIDNewItem&, ByVal lpNewItem$) As Long
    Private Declare Function ClientToScreen& Lib "user32" (ByVal hwnd&, lpPoint As POINTAPI)
    Private Declare Function TrackPopupMenu Lib "user32" (ByVal hMenu&, ByVal wFlags&, ByVal X&, ByVal Y&, ByVal nReserved&, ByVal hwnd&, ByVal lpRect&) As Long
    Private Declare Function EnableMenuItem Lib "user32" (ByVal hMenu&, ByVal wIDEnableItem&, ByVal wEnable&) As Long
   
'PROPERTIES ###########################################################
Public Property Set CurrentForm(frmCurrent As Form)
    Set m_CurrentForm = frmCurrent
End Property
Public Property Get CurrentForm() As Form
On Error Resume Next
    If IsObject(m_CurrentForm) Then
        Set CurrentForm = m_CurrentForm
    End If
End Property


Public Property Let ItemTop(lngValue As Long)
    m_lngItemTop = lngValue
End Property
Public Property Get ItemTop() As Long
    ItemTop = m_lngItemTop
End Property


Public Property Let ItemWidth(lngValue As Long)
    m_lngItemWidth = lngValue
End Property
Public Property Get ItemWidth() As Long
    ItemWidth = m_lngItemWidth
End Property
'END PROPERTIES #######################################################

'METHODS ##############################################################
Public Sub ShowMenu(strMenuName As String)
    Dim intItem As Integer
    Select Case strMenuName
    Case "File"
        intItem = 0
    Case "Edit"
        intItem = 1
    Case Else '"About"
        intItem = 2
    End Select
   
    DisplayPopupMenu intItem, ItemWidth * intItem, ItemTop
End Sub
'END METHODS ##########################################################

'######################################################################
Private Sub Class_Initialize()
    ' defaults
    m_lngItemWidth = 64
    m_lngItemTop = 19
End Sub

Private Sub Class_Terminate()
On Error Resume Next

    Dim intItem1 As Integer
    Dim intItem2 As Integer
   
    For intItem1 = 0 To UBound(m_hMenu) - 1
        If m_hMenu(intItem1) Then
            Call DestroyMenu(m_hMenu(intItem1))
        End If
    Next intItem1
   
    For intItem2 = 0 To UBound(m_hSubMenu) - 1
        If m_hSubMenu(intItem2) Then
            Call DestroyMenu(m_hSubMenu(intItem2))
        End If
    Next intItem2
End Sub
'######################################################################

'######################################################################
Private Sub DisplayPopupMenu(intItem As Integer, ByVal X&, ByVal Y&)

    Dim pt As POINTAPI
    Dim lngReturn As Long
     
    ' if the menu hasn't already been created, create it....
    If m_hMenu(intItem) = 0 Then
        Select Case intItem
        Case 0 ' File
            m_hMenu(intItem) = CreatePopupMenu()
           
            ' add an item....
            Call AppendMenu(m_hMenu(intItem), MF_STRING, ID_BEEP, ByVal "Sound A ""Beep""")
           
            ' add a separator....
            Call AppendMenu(m_hMenu(intItem), MF_STRING Or MF_SEPARATOR, ID_SEPARATOR, ByVal vbNullString)
           
            ' add another item....
            Call AppendMenu(m_hMenu(intItem), MF_STRING, ID_DISABLED, ByVal "A Disabled Item")
            ' disable the last item we added....
            Call EnableMenuItem(m_hMenu(intItem), ID_DISABLED, MF_BYCOMMAND Or MF_DISABLED Or MF_GRAYED)
           
            ' add the next item....
            Call AppendMenu(m_hMenu(intItem), MF_STRING, ID_MSGBOX, ByVal "Display A MessageBox")
       
            ' add a separator....
            Call AppendMenu(m_hMenu(intItem), MF_STRING Or MF_SEPARATOR, ID_SEPARATOR, ByVal vbNullString)
       
            ' add the last item....
            Call AppendMenu(m_hMenu(intItem), MF_STRING, ID_EXIT, ByVal "Exit")
        Case 1 ' Edit
             ' first create our sub menu....
            m_hSubMenu(intItem) = CreatePopupMenu()
       
            ' add a couple of items to the sub menu....
            Call AppendMenu(m_hSubMenu(intItem), MF_STRING, ID_ADD, ByVal "Add")
            Call AppendMenu(m_hSubMenu(intItem), MF_STRING, ID_EDIT, ByVal "Edit")
            Call AppendMenu(m_hSubMenu(intItem), MF_STRING, ID_DELETE, ByVal "Delete")
           
            m_hMenu(intItem) = CreatePopupMenu()
           
            ' add the item to which we attach the sub menu....
            Call AppendMenu(m_hMenu(intItem), MF_STRING Or MF_POPUP, m_hSubMenu(intItem), ByVal "Edit")
           
        Case Else ' About
           
            m_hMenu(intItem) = CreatePopupMenu()
           
            ' add an item....
            Call AppendMenu(m_hMenu(intItem), MF_STRING, ID_HELP, ByVal "Help")
           
            ' add a separator....
            Call AppendMenu(m_hMenu(intItem), MF_STRING Or MF_SEPARATOR, ID_SEPARATOR, ByVal vbNullString)
           
            ' add the last item....
            Call AppendMenu(m_hMenu(intItem), MF_STRING, ID_MSGBOX, ByVal "About")
        End Select
       
    End If
   
   
    With pt  ' the x & y position where you want the menu displayed
        .X = X
        .Y = Y
       
        ' translate to screen coordinates
        Call ClientToScreen(CurrentForm.hwnd, pt)
       
        ' call the api function to display the menu and check the return value
        lngReturn = TrackPopupMenu(m_hMenu(intItem), TPM_RETURNCMD, .X, .Y, 0&, CurrentForm.hwnd, 0&)
       
        Call MenuAction(lngReturn)
       
    End With
   
End Sub


Private Sub MenuAction(lngReturn As Long)
On Error Resume Next

    Select Case lngReturn
        Case ID_BEEP
            Beep
       
        Case ID_MSGBOX
            MsgBox "Form with Menu created by Candace Tripp" & vbCrLf & "http://www.candace-tripp.com/", vbInformation
       
        Case ID_ADD
            MsgBox "You chose ""Add"".", vbExclamation
       
        Case ID_EDIT
            MsgBox "You chose ""Edit"".", vbExclamation
       
        Case ID_DELETE
            MsgBox "You chose ""Delete"".", vbExclamation
       
        Case ID_HELP
            SendKeys "{F1}"
           
        Case ID_EXIT
            DoCmd.Close acForm, CurrentForm.Name, acSavePrompt
               
        End Select

End Sub
'######################################################################





22
Formularios / Recuperar última posición en formulario
« Último mensaje por xavi en Mayo 02, 2020, 04:43:32 pm »
Palabras clave: guardar, almacenar, recordar, última, posición, registro
Autor: ¿?
Extraído de: Utter Access (allá por 2007)

Objetivo:
La idea es almacenar la última posición del usuario al entrar en un formulario. Sirve para tipo Lista o tipo Ficha. Requiere de varias acciones.

1. Tener una tabla de posiciones (puede ser local ya que es del propio usuario)
2. Las tablas deben tener un campo ID único.
3. En el formulario, asignar una función a todos los controles del registro para el evento "Al recibir enfoque". Esa función almacena en memoria el registro y el campo enfocado.
4. En el evento Close, se almacena:
  - Formulario
  - Id del registro
  - Último campo enfocado
  - Usuario (redundante si es local)
  - Momento
  El almacenado de los datos puede ser acumulativo (nuevo registro por lo que Momento es relevante) o sustitutivo (editar el registro para combinación de formulario-usuario por lo que Momento es irrelevante)

En el momento de abrir el formulario, abrir un recordset o utilizar un Dlookup para recuperar el ID de la combinación formulario-usuario (si es acumulativo, incluir Momento en la "ecuación")
Mediante Bookmarks, posicionar el registro. Algo así:


Código: [Seleccionar]
Private Sub GoToLastSavedPosition()
    Dim strSQL           As String
    Dim rstFormPositions As DAO.Recordset
   
    strSQL = " SELECT Last(tblFormPositions.LastRecordID) AS LastOfLastRecordID," & _
                    " Last(tblFormPositions.LastActiveControl) AS LastOfLastActiveControl," & _
                    " Max(tblFormPositions.LastTimeSaved) AS MaxOfLastTimeSaved" & _
             " FROM tblFormPositions" & _
             " GROUP BY tblFormPositions.FormName," & _
                      " tblFormPositions.LastUser" & _
             " HAVING tblFormPositions.FormName = " & Chr$(34) & Me.Name & Chr$(34) & _
             " AND tblFormPositions.LastUser = " & Chr$(34) & CurrentUser() & Chr$(34)

    Set rstFormPositions = CurrentDb.OpenRecordset(strSQL, dbOpenDynaset)
   
    With rstFormPositions
        If .RecordCount <> 0 Then
            If !LastOfLastRecordID <> 0 And Not IsNull(!LastOfLastActiveControl) Then
                Me.RecordsetClone.FindFirst "[ID] = " & !LastOfLastRecordID
                Me.Bookmark = Me.RecordsetClone.Bookmark
                Me(!LastOfLastActiveControl).SetFocus
            End If
        End If
        .Close
    End With
   
    Set rstFormPositions = Nothing
   
End Sub
El ejemplo original lanza ese código en el Form_Timer del formulario (Intervalo = 1) con este códig:

Código: [Seleccionar]
Private Sub Form_Timer()
    Static blnFormOpen As Boolean
   
    If Not blnFormOpen Then
        blnFormOpen = True
        Me.TimerInterval = 0
       
        GoToLastSavedPosition
    End If
   
End Sub
23
Consejos, técnicas, artículos / Localizar error. Número de línea
« Último mensaje por xavi en Abril 28, 2020, 01:38:10 pm »
Palabras clave: control errores, línea
Autor: xavi
Extraído de: experiencia

Objetivo:
Localizar la línea del error exacta.

En nuestras aplicaciones a veces es necesario no solo controlar el error y devolver la respuesta adecuada. En algunos casos podemos recibir el "feedback" de un cliente con un error pero no es posible saber cual de las líneas de código ha sido la que ha generado el error.

En desarrollo, dentro de mi control de errores, ya está preparado para que, en caso de error, el código de pare (Stop) y a continuación vaya a la línea del error (Resume). El problema es en el cliente dónde no interesa mostrar ciertas cosas. En ese caso estaría bien poder recuperar la línea del error y que el cliente nos la comunicara.

¿Y cómo se obtiene la línea de error?
Pues ("back to the past") ¡numerando las líneas! y recuperando el número de línea con la propiedad Erl.
Algunos no lo habréis visto nunca y otros no numeran una línea desde que dejaron GWBasic.

¿Y cómo numero las lineas? Porque mi aplicación tiene miles de líneas...
La mejor forma si no quieres dejarte las uñas en el teclado es utilizar una herramienta externa: MZ-Tools

Esa herramienta permite poner y quitar números de línea de forma muy sencilla. El alcance de esa utilidad es el que nosotros queramos: desde un procedimiento hasta un grupo de proyectos.

¿Y cuando hago eso?
Pues yo lo haría justo antes de entregar la aplicación al cliente.

¿Es cómodo trabajar con números de línea puestos?
La verdad es que es un engorro porque cualquier nueva línea deberá tener su número. Lo mejor es quitar todos los números de línea del proyecto cuando se tenga que editar el código, modificar y volver a poner números de línea. Dado que los números de línea sólo sirven para la propiedad Erl, no debería representar un problema (a diferencia del pasado dónde los GoTo se hacían por número de línea).

¿Cómo utilizo Erl?
Muy sencillo. Dentro del control de errores, la propiedad Erl devuelve el número de línea. Si no hay números de línea, devuelve 0.

MsgBox "Error en línea: " & Erl & vbNewLIne & Err.Number & " - " & Err.Description

Dicho todo esto, yo nunca he numerado líneas  8)
24
WSH / Nombre del PC
« Último mensaje por xavi en Abril 28, 2020, 01:13:19 pm »
Palabras clave: nombre, ordenador, PC
Autor: ¿?
Extraído de: ¿?

Objetivo:
Obtener el nombre del PC dónde se ejecuta el código.

Alternativa a Environ("ComputerName")

Código: [Seleccionar]
Function DamePC() As String
  Set ObjetoRed = CreateObject("WScript.Network")
  DamePC = ObjetoRed.ComputerName
  Set ObjetoRed = Nothing
End Function

25
Varias / Sin tildes
« Último mensaje por xavi en Abril 23, 2020, 12:58:52 am »
Palabras clave: tildes, acentos, limpiar
Autor: Xavi
Extraído de: Experiencia propia

Intentando generalizar una función que me permita convertir cualquier texto con acentos a otro sin acentos y añadiendo la capacidad de poder incluir niveles de restricción de caracteres especiales, ha salido esta función.

Debe copiarse en un módulo independiente.

A la hora de utilizarse se debe pasar la cadena a convertir.
Opcionalmente se indica el nivel de restricción de los especiales. Por defecto es Libre lo que devolverá todos los caracteres especiales y únicamente sustituirá los caracteres acentuados.
Si se utiliza el nivel de restricción 1 (restringido), debe indicarse la cadena de caracteres prohibidos. Si no se indica el sistema propone una colección.
Si se utiliza el nivel de restricción 3 (Estricto) la cadena de respuesta solo permitirá letras mayúsculas, letras minúsculas, números y espacios.

La función puede ampliar los caracteres acentuados. Solo es necesario añadir los caracteres adecuados a las cadenas strConAcentos y strSinAcentos.


Código: [Seleccionar]
Public Enum eUtl_TildesRestriccion
    Libre = 0
    Restringido = 1
    Estricto = 2
End Enum

Function SinTildesEvo(strText As String, Optional intSinEspeciales As eUtl_TildesRestriccion = 0, Optional strEspeciales As String = ".,:;()-&%!?¡¿ºª*çÇ@_·)$") As String
   
    On Error GoTo ErrorHandler

    Dim strConAcentos   As String
    Dim strSinAcentos   As String
    Dim c               As Integer
    Dim strChar         As String
    Dim intPos          As Integer
    Dim strLimpia1      As String
    Dim strLimpia2      As String
   
    strConAcentos = "áàäâéèëêíìïîóòöôúùüûÁÀÄÂÉÈËÊÍÌÏÎÓÒÖÔÚÙÜÛ"
    strSinAcentos = "aaaaeeeeiiiioooouuuuAAAAEEEEIIIIOOOOUUUU"
   
    ' Recorremos el texto pasado como argumento
    For c = 1 To Len(strText)
        ' Obtenemos el carácter a evaluar
        strChar = Mid(strText, c, 1)
        ' Miramos si existe en la cadena de caracteres acentuados
        intPos = InStr(1, strConAcentos, strChar, vbBinaryCompare)
        If intPos > 0 Then
            ' Al existir sustituimos
            strLimpia1 = strLimpia1 & Mid(strSinAcentos, intPos, 1)
        Else
            ' Al no existir lo aceptamos
            strLimpia1 = strLimpia1 & strChar
        End If
    Next
   
    ' Evaluamos si se quitan los especiales
    Select Case intSinEspeciales
        Case eUtl_TildesRestriccion.Libre  ' Sin restricción: no se obvia ningún caracter especial
            ' Igualamos cadenas
            strLimpia2 = strLimpia1
        Case eUtl_TildesRestriccion.Restringido  ' Restrictivo:solo los de la lista
            ' Recorremos la cadena
            For c = 1 To Len(strLimpia1)
                ' Obtenemos el caracter a evaluar
                strChar = Mid(strLimpia1, c, 1)
                ' Miramos si existe en la cadena de caracteres especiales
                intPos = InStr(1, strEspeciales, strChar, vbBinaryCompare)
                If intPos = 0 Then
                    ' Al no existir podemos  añadir el caracter
                    strLimpia2 = strLimpia2 & strChar
                End If
            Next
        Case eUtl_TildesRestriccion.Estricto  ' Ultrarestrictivo: ningun caractrer que no sea letra, numero o espacio
            For c = 1 To Len(strLimpia1)
                strChar = Mid(strLimpia1, c, 1)
                Select Case Asc(strChar)
                    Case 48 To 57, 65 To 90, 97 To 122, 32
                        strLimpia2 = strLimpia2 & strChar
                End Select
            Next
    End Select
   
    SinTildesEvo = strLimpia2


ExitProcedure:
    On Error GoTo 0
    Exit Function
ErrorHandler:
    Select Case Err.Number
        Case 0
        Case Else
            MsgBox "Error " & Err.Number & " - " & Err.Description
            Resume ExitProcedure
    End Select
End Function

26
Consejos, técnicas, artículos / Sintaxis para subformularios
« Último mensaje por xavi en Abril 21, 2020, 07:21:07 pm »
Documento posteado varias veces por diferentes personas pero que parece ser que el autor original es Keri Hardwick


Sintaxis para subformularios
27
FSO / Saber si un directorio existe
« Último mensaje por xavi en Abril 21, 2020, 04:08:17 pm »
Palabras clave: FSO, averiguar, saber, directorio, folder, carpeta
Autor: Xavi
Extraído de: Centro de desarrollo de Office


Objetivo
Averiguar si un directorio existe mediante FSO. Es la alternativa a Dir(strFolder, vbDirectory)

Código: [Seleccionar]
Public Function ExistsFolder(strFolder As String) As Boolean
    Dim fso As Object
   
    Set fso = CreateObject("Scripting.FileSystemObject")
   
    On Error Resume Next
    If fso.FolderExists(strFolder) = False Then
        ExistsFolder = False
    Else
        ExistsFolder = True
    End If
   
    If Err <> 0 Then
        ExistsFolder = False
    End If
   
    Set fso = Nothing
       
End Function

28
FSO / Saber si un fichero existe
« Último mensaje por xavi en Abril 21, 2020, 04:05:29 pm »
Palabras clave: FSO, averiguar, saber, archivo, fichero
Autor: Xavi
Extraído de: Centro de desarrollo de Office


Objetivo
Averiguar si un fichero existe mediante FSO. Es la alternativa a Dir(strFileName, vbArchive) que puede dar errores cuando strFileName = ""

Código: [Seleccionar]
Public Function ExistsFile(strFileName As String) As Boolean
    Dim fso As Object
   
    Set fso = CreateObject("Scripting.FileSystemObject")
   
    On Error Resume Next
    If fso.FileExists(strFileName) = False Then
        ExistsFile = False
    Else
        ExistsFile = True
    End If
   
    If Err <> 0 Then
        ExistsFile = False
    End If
   
    Set fso = Nothing
       
End Function

29
Tablas / Revinculación de tablas (indolora)
« Último mensaje por xavi en Abril 21, 2020, 03:25:47 pm »
Palabras clave: vinculación, tablas
Autor: KALKALIN
Extraído de: MVP-ACCESS.com

Cita de: KALKALIN preguntó
Necesito poder revincular las tablas de una base de datos externa.

Y el mismo se respondió con algo parecido a esto (que yo he estandarizado a mi conveniencia)

Copiar en un módulo independiente. Antes de llamar, asignar los valores a la estructura uLinkTable

Código: [Seleccionar]
Option Compare Database
Option Explicit

Public Type udtLinkTable
    RemoteDatabase      As String
    RemoteTableName     As String
    LocalTableName      As String
End Type
Public uLinkTable       As udtLinkTable

Public Sub CrearTablaVinculada()
    Dim dbsActual       As DAO.Database
    Dim tdfTableLink    As DAO.TableDef
 
    Dim rstRemoto   As DAO.Recordset    ' para las pruebas (en producción borrar y eliminar las últimas líneas)
   
   'Ubicacion de la base de datos remota se toma de uLinkTable.RemoteDatabase
   'Ubicacion de la base de datos local se toma de CurrentProject.FullName

   ' Abre la base de datos a la que se le va a agregar la tabla vinculada.
   Set dbsActual = OpenDatabase(CurrentProject.FullName)
 
   ' Crea una tabla vinculada que se conecta a una base de datos Access
   ' uLinkTable.LocalTableName será el nombre de la nueva tabla vinculada (en la base local)
   Set tdfTableLink = dbsActual.CreateTableDef(uLinkTable.LocalTableName)

   'creamos la conexion
   tdfTableLink.Connect = ";DATABASE=" & uLinkTable.RemoteDatabase & ";"

   'Aqui uLinkTable.LocalTableName es el nombre de la tabla de origen (si no existe da error)
   tdfTableLink.SourceTableName = uLinkTable.RemoteTableName
   dbsActual.TableDefs.Append tdfTableLink
 
   Set rstRemoto = dbsActual.OpenRecordset(uLinkTable.LocalTableName)
 
   'muestro la cantidad de registros de la tabla vinculada (Algo sencillo para ver si todo ha salido bien)
   rstRemoto.MoveLast
   MsgBox rstRemoto.RecordCount
 
   rstRemoto.Close
 
End Sub


La ventaja de este método es que no "levanta" la ventana de objetos de la base de datos (interesante opción en clientes quisquillosos)
30
Consejos, técnicas, artículos / Asignación de funciones a eventos
« Último mensaje por xavi en Abril 20, 2020, 12:29:38 am »
Palabras clave: Funciones, procedimientos
Autor: Xavi
Extraído de: Experiencia propia

A menudo tenemos la tentación de asignar las funciones directamente a partir de la hoja de propiedades del control. Eso que parece una buena opción en aras de ahorrar líneas de código puede volverse en nuestra contra si, por el motivo que sea, la función que llamamos ha cambiado de nombre o, simplemente, desaparecido.

Cuando ello ocurre nos encontramos un un error no controlado en el momento de abrir el formulario que puede llevarnos un buen rato de trazar.

Para evitar encontrarnos en ese escenario mi consejo es NO utilizar la ventana de propiedades para asignar las funciones. En su lugar es más adecuado utilizar el procedimiento Form_Open o Form_Load (yo prefiero el Load) para realizar la asignación:

Código: [Seleccionar]
Me!UnControl.AfterUpdate = "=UnaFuncion()"
Recordar que la función puede estar en el mismo módulo o en un módulo independiente siempre que la función esté declarada como Public.

Si la paranoia anti-errores es similar a la mía, también es una buena práctica "desasignar" a la salida del formulario (evento Unload).

Código: [Seleccionar]
Me!UnControl.AfterUpdate = ""
Ver Vista presentación. Pros y contras para entender mi paranoia.



Páginas: 1 2 [3] 4 5 ... 10