Option Compare Database
Option Explicit
' ActivateControlBox
' ActivateCloseBox
' ActivateMaximizeBox
' ActivateMinimizeBox
'
' Código escrito originalmente por Juan M Afán de Ribera.
' Estás autorizado a utilizarlo dentro de una aplicación
' siempre que esta nota de autor permanezca inalterada.
' En el caso de querer publicarlo en una página Web,
' por favor, contactar con el autor en
'
' accessvbafaq@ya.com
'
' Este código se brinda por cortesía de
' Juan M. Afán de Ribera
'
Private Declare PtrSafe Function GetWindowLong Lib "user32" _
Alias "GetWindowLongA" _
(ByVal hwnd As Long, _
ByVal nIndex As Long) As Long
Private Declare PtrSafe Function SetWindowLong Lib "user32" _
Alias "SetWindowLongA" _
(ByVal hwnd As Long, _
ByVal nIndex As Long, _
ByVal dwNewLong As Long) As Long
Private Declare PtrSafe Function GetSystemMenu _
Lib "user32" _
(ByVal hwnd As Long, _
ByVal bRevert As Long) As Long
Private Declare PtrSafe Function DrawMenuBar _
Lib "user32" _
(ByVal hwnd As Long) As Long
Private Declare PtrSafe Function DeleteMenu _
Lib "user32" _
(ByVal hMenu As Long, _
ByVal nPosition As Long, _
ByVal wFlags As Long) As Long
Private Const MF_BYCOMMAND = &H0&
Private Const SC_CLOSE = &HF060
Private Const WS_SYSMENU = &H80000
Private Const WS_MAXIMIZEBOX = &H10000
Private Const WS_MINIMIZEBOX = &H20000
Private Const GWL_STYLE = (-16)
Function ap_DesactivaShift()
' Esta función desactiva la tecla SHIFT permitiendo se ejecute la macro
' Autoexec y demás propiedades de inicilaización
On Error GoTo errDisableShift
Dim db As Database
Dim prop As Property
Const conPropNotFound = 3270
Set db = CurrentDb()
'La siguiente linea desactiva la tecla Shift en el arranque
db.Properties("AllowByPassKey") = False
'function successful
Exit Function
errDisableShift:
'Esta primera parte de la subrutina de error crea la propiead "AllowByPassKey
'si esta no existe
If Err = conPropNotFound Then
Set prop = db.CreateProperty("AllowByPassKey", _ dbBoolean, False)
db.Properties.Append prop
Resume Next
Else
MsgBox "Función 'ap_DisableShift' no se completó satisfactoriamente."
Exit Function
End If
End Function
Function EnableShift()
'Esta función habilita la tecla SHIFT al inicio. Esta acción provoca
'la macro Autoexec y las propiedades de inicio se omitirán
'si el usuario mantiene presionada la tecla MAYÚS cuando abre la base de datos.
On Error GoTo errEnableShift
Dim db As DAO.Database
Dim prop As DAO.Property
Const conPropNotFound = 3270
Set db = CurrentDb()
'La siguiente línea de código activa la tecla SHIFT al inicio.
db.Properties("AllowByPassKey") = True
'function successful
Debug.Print "Enabled Shift Key - Successful"
GoTo ExitHere
errEnableShift:
'La primera parte de esta rutina de error crea el "AllowByPassKey
'propiedad si no existe.
If Err = conPropNotFound Then
Set prop = db.CreateProperty("AllowByPassKey", _ dbBoolean, True)
db.Properties.Append prop
Resume Next
Else
MsgBox "Function 'ap_DisableShift' did not complete successfully."
GoTo ExitHere
End If
ExitHere:
Set prop = Nothing
Set db = Nothing
Exit Function
End Function
'---------------------------------------------------------
'
' ActivateControlBox
'
' Activa/desactiva el cuadro de control de la barra de
' título de la ventana principal de Access (junto con el
' icono y el menú completo)
'
Function ActivateControlBox(Enable As Boolean)
Dim CurStyle As Long
Dim hwnd As Long
hwnd = Access.hWndAccessApp
CurStyle = GetWindowLong(hwnd, GWL_STYLE)
If Enable Then
If Not (CurStyle And WS_SYSMENU) Then
CurStyle = CurStyle Or WS_SYSMENU
End If
Else
If (CurStyle And WS_SYSMENU) = WS_SYSMENU Then
CurStyle = CurStyle - WS_SYSMENU
End If
End If
Call SetWindowLong(hwnd, GWL_STYLE, CurStyle)
Call DrawMenuBar(hwnd)
End Function
'---------------------------------------------------------
'---------------------------------------------------------
'
' ActivateCloseBox
'
' Activa/desactiva el botón cerrar [X] de la barra de
' título de la ventana principal de Access (junto con la
' correspondiente opción en el menú)
'
Function ActivateCloseBox(Enable As Boolean)
Dim hMenu As Long
Dim hwnd As Long
hwnd = Access.hWndAccessApp
If Enable Then
Call GetSystemMenu(hwnd, True)
Else
hMenu = GetSystemMenu(hwnd, False)
If hMenu Then
Call DeleteMenu(hMenu, SC_CLOSE, MF_BYCOMMAND)
End If
End If
Call DrawMenuBar(hwnd)
End Function
'---------------------------------------------------------
'---------------------------------------------------------
'
' ActivateMaximizeBox
'
' Activa/desactiva el botón maximizar [ ] de la barra de
' título de la ventana principal de Access (junto con la
' correspondiente opción en el menú)
'
Function ActivateMaximizeBox(Enable As Boolean)
Dim CurStyle As Long
Dim hwnd As Long
hwnd = Access.hWndAccessApp
CurStyle = GetWindowLong(hwnd, GWL_STYLE)
If Enable Then
If Not (CurStyle And WS_MAXIMIZEBOX) Then
CurStyle = CurStyle Or WS_MAXIMIZEBOX
End If
Else
If (CurStyle And WS_MAXIMIZEBOX) = WS_MAXIMIZEBOX Then
CurStyle = CurStyle - WS_MAXIMIZEBOX
End If
End If
Call SetWindowLong(hwnd, GWL_STYLE, CurStyle)
Call DrawMenuBar(hwnd)
End Function
'---------------------------------------------------------
'---------------------------------------------------------
'
' ActivateMinimizeBox
'
' Activa/desactiva el botón minimizar [_] de la barra de
' título de la ventana principal de Access (junto con la
' correspondiente opción en el menú)
'
Function ActivateMinimizeBox(Enable As Boolean)
Dim CurStyle As Long
Dim hwnd As Long
hwnd = Access.hWndAccessApp
CurStyle = GetWindowLong(hwnd, GWL_STYLE)
If Enable Then
If Not (CurStyle And WS_MINIMIZEBOX) Then
CurStyle = CurStyle Or WS_MINIMIZEBOX
End If
Else
If (CurStyle And WS_MINIMIZEBOX) = WS_MINIMIZEBOX Then
CurStyle = CurStyle - WS_MINIMIZEBOX
End If
End If
Call SetWindowLong(hwnd, GWL_STYLE, CurStyle)
Call DrawMenuBar(hwnd)
End Function
'---------------------------------------------------------
' StartUpProperties
'
' Código escrito originalmente por Juan M Afán de Ribera.
' Estás autorizado a utilizarlo dentro de una aplicación
' siempre que esta nota de autor permanezca inalterada.
' En el caso de querer publicarlo en una página Web,
' por favor, contactar con el autor en
'
' accessvbafaq@ya.com
'
' Este código se brinda por cortesía de
' Juan M. Afán de Ribera
'
Function StartUpProperties( _
PrpName As String, _
PrpValue As Variant, _
Optional DBPath As String) As Long
Dim db As Object 'DAO.Database
Dim prp As Object 'DAO.Property
Dim IconPath As Long
Err.Clear
On Error Resume Next
' si la propiedad a cambiar es AppIcon
' comprobamos que la ruta del icono sea válida
If PrpName = "AppIcon" Then
IconPath = Len(Dir(PrpValue))
If IconPath = 0 Then
'Nombre o número de archivo incorrecto
StartUpProperties = 52
Exit Function
End If
End If
On Error GoTo 0
On Error GoTo err_StartUpProperties
If DBPath = "" Then
Set db = CurrentDb
Else
Set db = DBEngine.OpenDatabase(DBPath)
End If
db.Properties(PrpName).Value = PrpValue
db.Properties.Refresh
Err.Clear
On Error Resume Next
' comprobamos que la ruta del icono asociado a la base de datos
' (si es que existe), sea válida. Si no fuera así provocaría que
' la propiedad que se ha cambiado/creado no se refrescara.
IconPath = Len(Dir(db.Properties("AppIcon"))) If IconPath = 0 Then
' borramos la propiedad
db.Properties.Delete "AppIcon"
End If
On Error GoTo 0
Application.RefreshTitleBar
StartUpProperties = -1
exit_StartUpProperties:
Set db = Nothing
Exit Function
err_StartUpProperties:
If Err.Number = 3270 Then 'la propiedad no existe
Select Case PrpName
' Se crea una propiedad tipo booleano
Case "StartUpShowDBWindow", _
"StartupShowStatusBar", _
"AllowShortcutMenus", _
"AllowFullMenus", _
"AllowBuiltInToolbars", _
"AllowToolbarChanges", _
"AllowSpecialKeys", _
"AllowBypassKey", _
"AllowBreakIntoCode", _
"HijriCalendar", _
"UseAppIconForFrmRpt"
Set prp = db.CreateProperty _
(PrpName, DB_BOOLEAN, PrpValue)
db.Properties.Append prp
Set prp = Nothing
' Se crea una propiedad tipo texto
Case "AppTitle", _
"StartUpForm", _
"AppIcon", _
"StartUpMenuBar", _
"StartUpShortcutMenuBar"
Set prp = db.CreateProperty _
(PrpName, DB_TEXT, PrpValue)
db.Properties.Append prp
Set prp = Nothing
Case Else
' la propiedad no existe
StartUpProperties = 3270
Resume exit_StartUpProperties
End Select
Resume Next
' error inesperado
Else
MsgBox "Error: " & Err.Number & vbCrLf & _
Err.Description
StartUpProperties = Err.Number
Resume exit_StartUpProperties
End If
End Function
