Read Current Database Folder & Path - VBA Example
This example contains a series of subroutines and functions which locates and returns the path to where the
database is on the drive.
It also determines the database name it’s name. This path can be used to find other databases in the
same folder and then to automatically refresh links or to create temporary Access databases to store temporary objects.
The VB Script module follows for each of the functions:
Option Compare Database
Option Explicit
Global InitDBase%
Global Dbase As Database
Global dbCommPath$ ' Full path to this database and stored in this value
Global ReturnVal
Global DbaseDir$ ' Path to this database without database name
Global Const Where_is_the_database = 6
Global dbFindDrivePath$ ' Full path to rate card database
Global dbFindDrive As Database
Global InitFind% ' Status of Comm Initialization {0, DMA, or DMB}
Global Source As String ' the database utility is looking for
Global Title As String
Global Name As String
Global Const NameOfDatabase = "DatabaseName." ' the name of databas
'*****************************************************************************
'Module: InitializeCommVars
'Written by: Your Name
'Purpose: this initalizes and looks for the path on the drive
'
'Date:August, 2002
'*****************************************************************************
Public Sub InitializeCommVars()
On Error GoTo error_InitializeCommVars
Dim Drive$, Directory$, Root$, ext$
Dim rst As Recordset
'figures out the name of the database running this program
'returns the path and stores it in dbCommpath$
If InitDBase = False Then InitDBase = InitializeDBVars()
dbCommPath$ = Dbase.Name
ReturnVal = BreakApart%(dbCommPath$, Drive$, Directory$, Root$, ext$)
If ReturnVal = True Then
DbaseDir$ = Drive$ & ":" & Directory$ & "\"
'the line below is the hold to keep from upgrading
'the number has to be changed if upgrading to access 2000 9.0 or 10.0
dbFindDrivePath$ = DbaseDir$ & "DatabaseName" & ".mdb"
Set dbFindDrive = DBEngine.Workspaces(0).OpenDatabase(dbFindDrivePath$, False, False)
'End If
End If
'InitFind% = which
exit_InitializeCommVars:
Exit Sub
error_InitializeCommVars:
Call DisplayError(Source, "Check the name of the database and try again.")
Err.Clear
Resume exit_InitializeCommVars
End Sub
'*****************************************************************************
'Module: INitalizeDBvars
'Written by: Your Name
'Purpose: Sets the database
'
'Date:August, 2002
'*****************************************************************************
'step 2
Function InitializeDBVars() As Integer
Set Dbase = CurrentDb()
InitializeDBVars = True
End Function
'*****************************************************************************
'Module: BreakApart
'Written by: Your Name
'Purpose: TO get the complete path to the database
'
'Date:August, 2002
'*****************************************************************************
'step 3
' Break path into drive, directory, root, and extension.
' Return TRUE if successful, FALSE otherwise
Function BreakApart%(ByVal Path$, Drive$, Directory$, Root$, ext$)
Dim ThisDir$, NumTokens%
Dim i%
' Is there a drive indicator? If so, strip it off
Drive$ = ""
If Len(Path$) >= 2 Then
If Mid$(Path$, 2, 1) = ":" Then
Drive$ = Left$(Path$, 1)
Path$ = Mid$(Path$, 3)
End If
End If
' Is this a relative or an absolute path?
' If absolute, strip off leading backslash
Directory$ = ""
If Len(Path$) >= 1 Then
If Left$(Path$, 1) = "\" Then
Directory$ = "\"
Path$ = Mid$(Path$, 2)
End If
End If
' Step thru all path directories, adding them to Directory$
If Len(Path$) >= 1 Then
' Get list of all items delimited by "\"
NumTokens% = Delimit%(Path$, "\") + 1
ReDim Tokens$(NumTokens%)
ParseString Path$, "\", Tokens$()
' The first N-1 are directories
For i% = 0 To NumTokens% - 2
If Directory$ = "\" Then
Directory$ = "\" + Tokens$(i%)
Else
Directory$ = Directory$ + "\" + Tokens$(i%)
End If
Next i%
' Now break apart the last item, which must be a filename.
' (NOTE: This fails if extension is null!)
Root$ = Tokens$(NumTokens% - 1)
If InStr(Root$, ".") Then
Root$ = Left$(Root$, InStr(Root$, ".") - 1)
ext$ = Mid$(Tokens$(NumTokens% - 1), InStr(Tokens$(NumTokens% - 1), ".") + 1)
Else
ext$ = ""
End If
BreakApart% = True
Else
' Have to have a directory or filename
BreakApart% = False
End If
End Function
'*****************************************************************************
' Visual Basic Module:
'Written by: Your Name
'Purpose:
'
'Date:August, 2002
'*****************************************************************************
'step 4
Static Function Delimit%(Work$, Delim$)
Dim Counter%, X%
Counter% = 0
For X% = 1 To Len(Delim$)
Counter% = Counter% + InCount%(Work$, Mid$(Delim$, X%, 1))
Next X%
Delimit% = Counter%
End Function
'*****************************************************************************
' VBA Module:
'Written by: Your Name
'Purpose:
'
'Date:August, 2002
'*****************************************************************************
'step 5
' Returns number of times one string appears in another
'
Function InCount%(Work$, Delimit$)
Dim i%, Counter%
Counter% = 0
For i% = 1 To Len(Work$)
If Mid$(Work$, i%, 1) = Delimit$ Then Counter% = Counter% + 1
Next i%
InCount% = Counter%
End Function
'*****************************************************************************
' VB Module:
'Written by: Your Name
'Purpose:
'
'Date:August, 2002
'*****************************************************************************
'step 6
Sub ParseString(Work$, Delim$, WorkArray$())
Dim BeginPtr%, Element%, EndPtr%
BeginPtr% = 1
Element% = 0
For EndPtr% = 1 To Len(Work$)
If InStr(Delim$, Mid$(Work$, EndPtr%, 1)) Then
WorkArray$(Element%) = Mid$(Work$, BeginPtr%, EndPtr% - BeginPtr%)
Element% = Element% + 1
BeginPtr% = EndPtr% + 1
End If
Next
WorkArray$(Element%) = Mid$(Work$, BeginPtr%)
End Sub
'*****************************************************************************
'Module:
'Written by: Your Name
'Purpose:
'
'Date:August, 2002
'*****************************************************************************
Public Sub DisplayError(ByVal Title, ByVal Name)
Dim Msg$
Msg$ = "An unexpected error has occurred in this program." & vbCrLf
Msg$ = Msg$ & "There is a problem with finding the database." & vbCrLf
'msg$ = msg$ & "If the database has been upgraded it needs to be closed and renamed." & vbCrLf
Msg$ = Msg$ & " Make sure the database is called: DatabaseName.mdb Thanks " & vbCrLf
msgbox Msg$, vbInformation, Title
End Sub
Submitted by Mary Roberge
