Home  Fees/Services  Microsoft Access Templates  Tutorials  Tutorial Download  Articles  Search  Contact  Privacy  Links
Current Directory Current Directory Current Path VBA  
 





Current Database Folder & Path - VBA Example

This current directory 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 Current Path 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 current folder 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 current direction 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

 







Microsoft Office VBA :
  MS Access 2003
  Access 2007
  Access 2010
  Access 2013




A Blue Claw Database Design Article:

MS Access Versus Other Systems
 





Blue Claw Database Design Downloadable Tutorial:
Multi Select List Box Query Parameters  




A Blue Claw Database Design Template:

Subscription Order Control Database
 




Contact Information

Copyright 2000-2014 Blue Claw Database Design