Intervalo de fechas de una semana del año

La siguiente función devuleve una cadena de texto en la que se indica el día inicial y final de una semana determinada del año, que hay que aportar a la función:

Function IntervaloSemana(NSemana As Integer) As String
On Error GoTo Err_IntervaloSemana
Dim NSem As Integer
Dim DPSYear, PDIntervalo, UDIntervalo As Date
If NSemana < 1 Or NSemana > 52 Then MsgBox “La semana debe estar comprendida entre 1 y 52″, vbCritical + vbOKOnly: Exit Function
If Weekday(“01/01/” & Year(Date), vbMonday) > 1 Then NSem = NSemana – 2 Else NSem = NSemana – 1
DPSYear = DateAdd(“d”, 8 – Weekday(“01/01/” & Year(Date), vbMonday), “01/01/” & Year(Date))
PDIntervalo = DateAdd(“d”, NSem * 7, DPSYear)
UDIntervalo = DateAdd(“d”, 6, PDIntervalo)
IntervaloSemana = “Semana: ” & NSemana & “, desde el ” & PDIntervalo & ” al ” & UDIntervalo
Exit_IntervaloSemana:
Exit Function
Err_IntervaloSemana:
MsgBox Err.Description
Resume Exit_IntervaloSemana
End Function

Otra forma de llamar a un cuadro de diálogo OpenFile de Windows

Private Declare Function GetOpenFileName Lib “comdlg32.dll” Alias “GetOpenFileNameA” (pOpenfilename As OPENFILENAME) As Long

Public CDCaption, CDSearchString, CDInitDir As String

Public Type OPENFILENAME
lStructSize As Long
hwndOwner As Long
hInstance As Long
lpstrFilter As String
lpstrCustomFilter As String
nMaxCustFilter As Long
nFilterIndex As Long
lpstrFile As String
nMaxFile As Long
lpstrFileTitle As String
nMaxFileTitle As Long
lpstrInitialDir As String
lpstrTitle As String
Flags As Long
nFileOffset As Integer
nFileExtension As Integer
lpstrDefExt As String
lCustData As Long
lpfnHook As Long
lpTemplateName As String
End Type

Propiedades personalizadas de un base de datos

Las siguientes líneas de código permiten crear, añadir y eliminar propiedades personalizadas para la base de datos de access que estemos utilizando. Para modificar los datos de la propiedad antes ha que eliminarla y luego crearla con el nuevo dato.

Borrar la propiedad.
CurrentDb.Containers!Databases.Documents!UserDefined.Properties.Delete (“nombre de la propiedad“)

Crea la propiedad.
CurrentDb.Containers!Databases.Documents!UserDefined.Properties.Append CurrentDb.Containers!Databases.Documents!UserDefined.CreateProperty (“nombre de la propiedad”, tipo de valor, “valor de la propiedad“)

Lee el valor dado a la propiedad CurrentDb.Containers!Databases.Documents!UserDefined.Properties(“nombre de la propiedad“)

Obtener el número de serie del disco duro

Utilizando el FSO:

Dim FileWsh As Object
Set FileWsh = CreateObject(“Scripting.FileSystemObject”)
MsgBox “Número de Serie del Volumen en Hexadecimal: ” & Hex$(FileWsh.Drives(“C”).SerialNumber)
MsgBox “Número de Serie del Volumen en decimal: ” & FileWsh.Drives(“C”).SerialNumber
Set FileWsh = Nothing

Determinar si un archivo está protegido por contraseña

El siguiente código muestra como conocer si una base de datos está protegida por una contraseña. No sé si existirá algun método mejor, pero no se me ha ocurrido otro. Si conoces alguna mejor házmela saber.

Private Sub btnComprobar_Click()
On Error GoTo Err_btnComprobar_Click

Dim db As DAO.Database
Set db = DBEngine.Workspaces(0).OpenDatabase (“ruta.mdb”)

Exit_btnComprobar_Click:
Exit Sub

Err_btnComprobar_Click:
Select Case Err.Number
Case 3031
MsgBox “Archivo protegido por contraseña”
Resume Exit_btnComprobar_Click
Case Else
MsgBox Err.Number & ” ” & Err.Description
Resume Exit_btnComprobar_Click
End Select

End Sub

Utilizar el cuadro de diálogo OpenFile de Windows

Type tagOPENFILENAME
lStructSize As Long
hwndOwner As Integer
hInstance As Integer
lpstrFilter As Long
lpstrCustomFilter As Long
nMaxCustFilter As Long
nFilterIndex As Long
lpstrFile As Long
nMaxFile As Long
lpstrFileTitle As Long
nMaxFileTitle As Long
lpstrInitialDir As Long
lpstrTitle As Long
Flags As Long
nFileOffset As Integer
nFileExtension As Integer
lpstrDefExt As Long
lCustData As Long
lpfnHook As Long
lpTemplateName As Long
End Type

Activar/desactivar barras de menú

Las siguientes funciones permiten interactuar con las barras de menú de access, activando o desactivando las distintas barras o elementos de éstas.

Con el código se manipula el objeto CommandBar que es la parte de la Microsoft Office 8.0 Objeto Biblioteca. Por lo tanto, la Microsoft Office 8.0 Objeto Biblioteca debe estar disponible en su equipo; también establecer una referencia a esta biblioteca en la base de datos en la que desea habilitar o deshabilitar elementos de menú de su barra de comandos personalizada.

El siguiente código habilitar o deshabilitar todos los elementos del menú la barra de comandos, para ello hay que pasarle el nombre de la barra de herramientas (CmdBarName), y si quiermos activarla o no (CmdbarEnabled):

Public Function AllowMenus(CmdBarName As String, CmdbarEnabled As Boolean)
On Error GoTo Err_AllowMenus
Dim Cmdbar As CommandBar, Cbct As CommandBarControl
Set Cmdbar = CommandBars(CmdBarName)
If Cmdbar.Visible = False Then Cmdbar.Visible = True
For Each Cbct In Cmdbar.Controls
Cbct.Enabled = CmdbarEnabled
Next Cbct
Exit_AllowMenus
Exit Function
Err_AllowMenus:
MsgBox "Error " & CStr(Err) & " " & Err.Description & " has occurred in the AllowMenus Function", vbOKOnly, "Error Detected"
Resume Exit_AllowMenus
End Function

Ejemplo: AllowMenus(“NombreDeLaBarra”,False)

Esta otra función permite activar o desactivar un elemento puntual de la barra de herramientas, ya sea un menú de la barra o el elemento el menú. Para ello, al igual que en el caso anterior, se le pasa el nombre de la barra, la activación de la misma, el menú (TopLevel) y submenú ( Sublevel) a activar o desactivar:

Public Function CommandbarEnable(Cmdbar As CommandBar, CmdbarEnabled As Boolean, TopLevel As Integer, Optional Sublevel As Integer)
On Error GoTo Err_CommandBarEnable
Dim SubCommandbar
If Cmdbar.Visible = False Then Cmdbar.Visible = True
If IsMissing(Sublevel) Or Sublevel = 0 Then
Cmdbar.Controls(TopLevel).Enabled = CmdbarEnabled
Else
Set SubCommandbar = Cmdbar.Controls(TopLevel)
SubCommandbar.Controls(Sublevel).Enabled = CmdbarEnabled
End If
Exit_CommandBarEnable:
Exit Function
Err_CommandBarEnable:
MsgBox "Error " & CStr(Err) & " " & Err.Description & " has occurred in the CommandBarEnable Function", vbOKOnly, "Error Detected"
Resume Exit_CommandBarEnable
End Function

Ejemplo: CommandbarEnable(Commandbars(“NombreDeLaBarra”),False,1,3)

Fuente: support.microsoft.com

Activar/desactivar la tecla shift

La siguiente función activa  o desactiva la tecla shift al iniciar una aplicación. Para ello se le pasa la ruta del archivo sobre el que se actúa (T),  el valor para activarla o desactivarla (Activar – true o false):

Function ap_QuitaShift(T As String, Activar As Boolean) As Boolean
On Error GoTo errQuitaShift
Dim db As Database, wks As Workspace
Dim prop As Property
Const conPropNotFound = 3270
Set wks = Workspaces(0)
Set db = wks.OpenDatabase(T)
db.Properties("AllowByPassKey") = Activar
db.Close
Set db = Nothing
Exit Function
errQuitaShift:
Set prop = db.CreateProperty("AllowByPassKey", dbBoolean, False)
db.Properties.Append prop
Resume Next
End Function

Esta función nos informa sobre el estado de la propiedad Shift de la base de datos que se le pasa (T), devolviendo true o false según corresponda:

Public Function ShiftActivado(T As String) As Boolean
On Error GoTo ShiftActivado_err
Dim db As Database, wks As Workspace
Dim prop As Property
Const conPropNotFound = 3270
Set wks = Workspaces(0)
Set db = wks.OpenDatabase(T)
ShiftActivado = db.Properties("AllowByPassKey")
sal_de_ShiftActivado:
Exit Function
ShiftActivado_err:
ShiftActivado = True
Resume sal_de_ShiftActivado
End Function

Fuente: DelucchiMDB 

Ocultar/mostrar las tablas

Las siguientes funciones muestran y ocultan todas las tablas de una base de datos.

Public Function OcultaTodasTablas(Ruta As String)
Dim Tb As TableDef
Dim db As Database
Set db = OpenDatabase(Ruta)
For Each Tb In db.TableDefs
If Not Tb.Attributes And dbHiddenObject Then
Tb.Attributes = Tb.Attributes Or dbHiddenObject
End If
Next
End Function

Para mostrar las tablas:

Public Function MuestraTodasTablas(Ruta As String)
Dim Tb As TableDef
Dim appAccess As Access.Application
Dim db As Database
Set db = OpenDatabase(Ruta)
For Each Tb In db.TableDefs
If Tb.Attributes And dbHiddenObject Then
Tb.Attributes = Tb.Attributes Xor dbHiddenObject
End If
Next
End Function

Fuente: Chea

Inutilizar un archivo de Access

La siguiente función manipula el archivo de Access a bajo nivel, inutilizándola o no a nuestra voluntad.

Function Habilitado(StrRutaCompleta As String) As Boolean
Dim f As Integer, CadenaVieja As String, CadenaNueva As String
f = FreeFile
Open StrRutaCompleta For Binary Access Read Write As #f
CadenaVieja = Mid(Input(6, #f), 6, 1)
‘Close #f
If CadenaVieja = “1″ Then
‘en este caso está inhabilitado, lo habilito
CadenaNueva = “t”
Put #f, 6, CadenaNueva
Habilitado = True
Else
‘en este caso está habilitado, lo deshabilito
CadenaNueva = “1″
Put #f, 6, CadenaNueva
Habilitado = False
End If
Close #f
End Function

Fuente: Buho