Cambiar/Extraer Nombre de la Base de Datos Activa

Function NombreBD() As String

On Error GoTo err_NombreBD

'***************************************************************

'& &*

'& &*

'& &*

'& &*

'& Jefferson Jimenez (JJJT) &*

'& Cabimas - Venezuela &*

'& Agosto - 2009 &*

'& &*

'& &*

'& &*

'& &*

'& &*

'***************************************************************

'Funcion que devuelve el Nombre de la Base de datos sin la extension

Dim Ext2003, Ext2007 As Long

Dim db As Object 'DAO.Database

Ext = Right(CurrentProject.Name, _

Len(CurrentProject.Name) - _

InStrRev(CurrentProject.Name, ".")) 'Primero busco la extension

' del fichero

If Ext = "accdb" Or Ext = "accde" Then ' La Condicion si es A2007

Ext2007 = Len(CurrentProject.Name) - 6 'Extraigo el nombre y le quito la extension

NombreBD = Mid(CurrentProject.Name, 1, Ext2007) 'Le paso el nombre a la

'funcion sin la extension

Set db = CurrentDb '=

db.Properties("AppTitle").value = NombreBD '= Ya con esta funcion

db.Properties.Refresh '= Por aqui le paso el nombre

Application.RefreshTitleBar '= de la base de datos, al

Set db = Nothing '= titulo de la aplicacion

Set db = CurrentDb '=

Else

'De no ser A2007.., Hago lo mismo

Ext2003 = Len(CurrentProject.Name) - 4

NombreBD = Mid(CurrentProject.Name, 1, Ext2003)

Set db = CurrentDb

db.Properties("AppTitle").value = NombreBD

db.Properties.Refresh

Application.RefreshTitleBar

Set db = Nothing

Set db = CurrentDb

End If

'El tratamiento de errores de no existir el nombre en el titulo de la aplicacion

err_NombreBD:

If Err.Number = 3270 Then 'Numero de error cuando la propiedad no existe

Set vacio = db.CreateProperty("AppTitle", DB_TEXT, NombreBD)

db.Properties.Append vacio

Set vacio = Nothing

End If

Resume Next

'Fin de la funcion

End Function