Reinstalando todo...
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
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
'######################################################################
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
Private Sub Form_Timer()
Static blnFormOpen As Boolean
If Not blnFormOpen Then
blnFormOpen = True
Me.TimerInterval = 0
GoToLastSavedPosition
End If
End Sub

Function DamePC() As String
Set ObjetoRed = CreateObject("WScript.Network")
DamePC = ObjetoRed.ComputerName
Set ObjetoRed = Nothing
End Function
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
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
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
Cita de: KALKALIN preguntó
Necesito poder revincular las tablas de una base de datos externa.
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
Me!UnControl.AfterUpdate = "=UnaFuncion()"Me!UnControl.AfterUpdate = ""