Determine current project path Ms Access

'
' Declares for Shell Items
'
Private Type SHITEMID
    cb As Long
    abID As Byte
End Type
'
Private Type ITEMIDLIST
    MKID As SHITEMID
End Type
'
' Enumerations of Folders - useful for providing access
' to the GetSpecialFolder Path routine
'
Public Enum fldrIDs
    fldrPrograms = &H2
    fldrControls = &H3
    fldrPrinters = &H4
    fldrPersonal = &H5
    fldrFavorites = &H6
    fldrStartup = &H7
    fldrRecent = &H8
    fldrSendTo = &H9
    fldrBitBucket = &HA
    fldrStartMenu = &HB
    fldrDeskTopDir = &H10
    fldrDrives = &H11
    fldrNetWork = &H12
    fldrNetHood = &H13
    fldrFonts = &H14
    fldrTemplates = &H15
    fldrCommonStartMenu = &H16
    fldrCommonPrograms = &H17
    fldrCommonStartup = &H18
    fldrCommonDeskTopDir = &H19
    fldrCommonAppData = &H1A
End Enum
'
' API Declares
'
Private Declare Function SHGetSpecialFolderLocation _
        Lib "shell32.dll" (ByVal hwndOwner As Long, _
        ByVal nFolder As Long, pidl As ITEMIDLIST) As Long

Public Function GetSpecialFolder(ByVal CsIdl As fldrIDs) As String
'
' This routine returns the fully qualified path to the
' required folder.
'
' Obviously this can change depending on the logged in
' user
'

    Dim lRet As Long
    Dim sPath As String
    Dim sTemp As String
    Dim IDL As ITEMIDLIST
'
On Error GoTo vbErrorHandler
'
' Get the location into our ITEMIDLIST
'
    lRet = SHGetSpecialFolderLocation(0, CsIdl, IDL)
'
    If lRet = 0 Then ' no error !
'
' Build a buffer string to handle the returned value
'
        sPath = Space$(255)
        lRet = SHGetPathFromIDList(ByVal IDL.MKID.cb, ByVal sPath)
        If lRet <> 0 Then
'
' Make sure we append a '\' to the path
'
            sTemp = TrimNull(sPath)
            sTemp = sTemp & IIf(right$(sTemp, 1) = "\", "", "\")
            GetSpecialFolder = sTemp
        End If
    End If
'
'
    Exit Function
'
' Something strange happened - raise an error !
'
vbErrorHandler:
    Err.Raise Err.Number, "cSpecialFolders::GetSpecialFolder", Err.Description
'
End Function

Select all Open in new window