This page describes two functions,  GetUserProfileFolder and GetSpecialFolder, that can be
used to retrieve the specific folders for the current user.

The function GetUserProfileFolder returns the current user's UserProfileDirectory. This folder contains
subfolders like My Documents and Application Data.

The function GetSpecialFolder returns a specific directory such as My Documents. You pass in a predefined
numeric value that indicates the folder you wish to retrieve.  These values are in the constants beginning with CSIDL_ listed below. Note that not all the listed CSIDL constants listed refer to valid folders.

The complete VBA module code follows.  It will work on Windows NT 4, Windows 2000, and Windows XP. The code will also
work without modification in Visual Basic 6.

You can download a bas module containing the code here. The functions on this page use the TrimToNull function and
the GetSystemErrorMessageText function. These functions are included in the downloadable bas file, but are not included in the code listing below.

Option Explicit
Option Compare Text
'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
' modGetUserDirectory
' By Chip Pearson, chip@cpearson.com , www.cpearson.com
'
' This module contains two procedures,
'   GetUserProfileFolder        which returns the folder in which the user's special folders (e.g.,
'                                   "My Documents" or "Recent") are stored.
'
'   GetSpecialFolder            which returns a specific folder for the current user (e.g.,
'                                   "My Documents" or "Recent).
'
' These functions are used to retrieve folder names that are specific the current user.
'
'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''

Private Declare Function CloseHandle Lib "kernel32" _
   (ByVal hObject As Long) As Long

Private Declare Function OpenProcess Lib "kernel32" ( _
    ByVal dwDesiredAccess As Long, _
    ByVal bInheritHandle As Long, _
    ByVal dwProcessId As Long) As Long

Private Declare Function GetCurrentThread Lib "kernel32" () As Long

Private Declare Function GetCurrentProcess Lib "kernel32" () As Long

Private Declare Function OpenProcessToken Lib "advapi32.dll" ( _
    ByVal ProcessHandle As Long, _
    ByVal DesiredAccess As Long, _
    ByRef TokenHandle As Long) As Long

Private Declare Function SHGetFolderPath Lib "shell32.dll" Alias "SHGetFolderPathA" ( _
    ByVal HWnd As Long, _
    ByVal csidl As Long, _
    ByVal hToken As Long, _
    ByVal dwFlags As Long, _
    ByVal pszPath As String) As Long

Private Declare Function GetUserProfileDirectory Lib "userenv.dll" Alias "GetUserProfileDirectoryA" ( _
    ByVal hToken As Long, _
    ByVal lpProfileDir As String, _
    ByRef lpcchSize As Long) As Long

Private Declare Function FormatMessage Lib "kernel32" _
    Alias "FormatMessageA" ( _
    ByVal dwFlags As Long, _
    ByVal lpSource As Any, _
    ByVal dwMessageId As Long, _
    ByVal dwLanguageId As Long, _
    ByVal lpBuffer As String, _
    ByVal nSize As Long, _
    ByRef Arguments As Long) As Long




'''''''''''''''''''''''''''''''''''''''''''''''''''''''
' Misc Constants
'''''''''''''''''''''''''''''''''''''''''''''''''''''''
Private Const MAX_PATH = 260&
Private Const S_OK = 0&
Private Const E_INVALIDARG As Long = &H80070057
Private Const S_FALSE As Long = &H1 ' odd but true that S_FALSE would be 1.


'''''''''''''''''''''''''''''''''''''''''''''''''''''''''
' Used By OpenProcessToken and OpenProcess
'''''''''''''''''''''''''''''''''''''''''''''''''''''''''
Private Const TOKEN_QUERY As Long = &H8
Private Const TOKEN_QUERY_SOURCE As Long = &H10
Private Const READ_CONTROL As Long = &H20000
Private Const STANDARD_RIGHTS_READ As Long = (READ_CONTROL)
Private Const TOKEN_READ As Long = (STANDARD_RIGHTS_READ Or TOKEN_QUERY)
Private Const SYNCHRONIZE = &H100000
Private Const PROCESS_VM_READ As Long = (&H10)
Private Const PROCESS_QUERY_INFORMATION As Long = (&H400)



''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
' used by FormatMessage
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
Private Const FORMAT_MESSAGE_ALLOCATE_BUFFER = &H100
Private Const FORMAT_MESSAGE_ARGUMENT_ARRAY = &H2000
Private Const FORMAT_MESSAGE_FROM_HMODULE = &H800
Private Const FORMAT_MESSAGE_FROM_STRING = &H400
Private Const FORMAT_MESSAGE_FROM_SYSTEM = &H1000
Private Const FORMAT_MESSAGE_IGNORE_INSERTS = &H200
Private Const FORMAT_MESSAGE_MAX_WIDTH_MASK = &HFF
Private Const FORMAT_MESSAGE_TEXT_LEN = &HA0


''''''''''''''''''''''''''''''''''''''''''''''''''''''''
' CSIDL Constants of various folder names.
''''''''''''''''''''''''''''''''''''''''''''''''''''''''
Public Const CSIDL_ADMINTOOLS As Long = &H30
Public Const CSIDL_ALTSTARTUP As Long = &H1D
Public Const CSIDL_APPDATA As Long = &H1A
Public Const CSIDL_BITBUCKET As Long = &HA
Public Const CSIDL_COMMON_ADMINTOOLS As Long = &H2F
Public Const CSIDL_COMMON_ALTSTARTUP As Long = &H1E
Public Const CSIDL_COMMON_APPDATA As Long = &H23
Public Const CSIDL_COMMON_DESKTOPDIRECTORY As Long = &H19
Public Const CSIDL_COMMON_DOCUMENTS As Long = &H2E
Public Const CSIDL_COMMON_FAVORITES As Long = &H1F
Public Const CSIDL_COMMON_PROGRAMS As Long = &H17
Public Const CSIDL_COMMON_STARTMENU As Long = &H16
Public Const CSIDL_COMMON_STARTUP As Long = &H18
Public Const CSIDL_COMMON_TEMPLATES As Long = &H2D
Public Const CSIDL_CONNECTIONS As Long = &H31
Public Const CSIDL_CONTROLS As Long = &H3
Public Const CSIDL_COOKIES As Long = &H21
Public Const CSIDL_DESKTOP As Long = &H0
Public Const CSIDL_DESKTOPDIRECTORY As Long = &H10
Public Const CSIDL_DRIVES As Long = &H11
Public Const CSIDL_FAVORITES As Long = &H6
Public Const CSIDL_FLAG_CREATE As Long = &H8000
Public Const CSIDL_FLAG_DONT_VERIFY As Long = &H4000
Public Const CSIDL_FLAG_MASK As Long = &HFF00&
Public Const CSIDL_FLAG_PFTI_TRACKTARGET As Long = CSIDL_FLAG_DONT_VERIFY
Public Const CSIDL_FONTS As Long = &H14
Public Const CSIDL_HISTORY As Long = &H22
Public Const CSIDL_INTERNET As Long = &H1
Public Const CSIDL_INTERNET_CACHE As Long = &H20
Public Const CSIDL_LOCAL_APPDATA As Long = &H1C
Public Const CSIDL_MYPICTURES As Long = &H27
Public Const CSIDL_NETHOOD As Long = &H13
Public Const CSIDL_NETWORK As Long = &H12
Public Const CSIDL_PERSONAL As Long = &H5   ' My Documents
Public Const CSIDL_MY_DOCUMENTS As Long = &H5
Public Const CSIDL_PRINTERS As Long = &H4
Public Const CSIDL_PRINTHOOD As Long = &H1B
Public Const CSIDL_PROFILE As Long = &H28
Public Const CSIDL_PROGRAM_FILES As Long = &H26
Public Const CSIDL_PROGRAM_FILES_COMMON As Long = &H2B
Public Const CSIDL_PROGRAM_FILES_COMMONX86 As Long = &H2C
Public Const CSIDL_PROGRAM_FILESX86 As Long = &H2A
Public Const CSIDL_PROGRAMS As Long = &H2
Public Const CSIDL_RECENT As Long = &H8
Public Const CSIDL_SENDTO As Long = &H9
Public Const CSIDL_STARTMENU As Long = &HB
Public Const CSIDL_STARTUP As Long = &H7
Public Const CSIDL_SYSTEM As Long = &H25
Public Const CSIDL_SYSTEMX86 As Long = &H29
Public Const CSIDL_TEMPLATES As Long = &H15
Public Const CSIDL_WINDOWS As Long = &H24
Public Const PRIV_PAL_FUNC As Long = &H0
Public Const CSIR_FUNC As Long = (PRIV_PAL_FUNC Or &HD)


Public Function GetSpecialFolder(FolderCSIDL As Long) As String
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
' F_7_AB_1_GetSpecialFolder
' This returns the requisted folder name from the user's profile directory. A_7_AB_1_FolderCSIDL must be
' one of the constants beginning with CSIDL listed above. Otherwise, and INVALID ARGUMENT error will
' occur.
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''

Dim HWnd As Long
Dim Path As String
Dim Res As Long
Dim ErrNumber As Long
Dim ErrText As String

''''''''''''''''''''''''''''''''''''''''''''
' initialize the path variable
''''''''''''''''''''''''''''''''''''''''''''
Path = String$(MAX_PATH, vbNullChar)

''''''''''''''''''''''''''''''''''''''''''''
' get the folder name
''''''''''''''''''''''''''''''''''''''''''''
Res = SHGetFolderPath(HWnd:=0&, _
                        csidl:=FolderCSIDL, _
                        hToken:=0&, _
                        dwFlags:=0&, _
                        pszPath:=Path)
Select Case Res
    Case S_OK
        Path = TrimToNull(Text:=Path)
        GetSpecialFolder = Path
    Case S_FALSE
        MsgBox "The folder code is valid but the folder does not exist."
        GetSpecialFolder = vbNullString
    Case E_INVALIDARG
        MsgBox "The value of FolderCSIDL is not valid."
        GetSpecialFolder = vbNullString
    Case Else
        ErrNumber = Err.LastDllError
        ErrText = GetSystemErrorMessageText(Res)
        MsgBox "An error occurred." & vbCrLf & _
            "System Error: " & CStr(ErrNumber) & vbCrLf & _
            "Description:  " & ErrText
End Select

End Function


Public Function GetUserProfileFolder() As String
'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
' GetUserDirectory
' Return the root directory of the current user's profile. Subfolder of this folder include
'       Application Data
'       Cookies
'       Desktop
'       Favorites
'       Local Settings
'       My Documents
'       NetHood
'       PrintHood
'       Recent
'       SendTo
'       Start Menu
'       Templates
'       UserData
'       Windows
'
' Use GetSpecialFolder above to retrieve the full path name of these folders.
'
' Note: This folder name can also be retrieved with the Environ function:
'
'     Dim UserProfileFolderAs String
'     UserProfileFolder = Environ("UserProfile")
'
' However, I have encountered situations in which an existing Environment variable
' is not accessible by name, which would cause an invalid result in the code above.
' Using the API code will always work.
'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''

Dim Res As Long
Dim CurrentProcessHandle As Long
Dim TokenHandle As Long
Dim UserProfileDirectory As String
Dim LLen As Long
Dim Pos As Integer

''''''''''''''''''''''''''''''''''''''''''''''''''''
' Initialize the string to receive the folder name
''''''''''''''''''''''''''''''''''''''''''''''''''''
UserProfileDirectory = String(MAX_PATH, " ")
LLen = Len(UserProfileDirectory)

''''''''''''''''''''''''''''''''''''''''''''''''''''
' Get the pseudo-handle of the current process
''''''''''''''''''''''''''''''''''''''''''''''''''''
CurrentProcessHandle = GetCurrentProcess()

''''''''''''''''''''''''''''''''''''''''''''''''''''
' Open the access token of the process
''''''''''''''''''''''''''''''''''''''''''''''''''''
Res = OpenProcessToken(CurrentProcessHandle, TOKEN_READ, TokenHandle)
If Res = 0 Then
    MsgBox "ERROR OpenProcessToken   " & CStr(Err.LastDllError) & " " & GetSystemErrorMessageText(Err.LastDllError)
    Exit Function
End If

''''''''''''''''''''''''''''''''''''''''''''''''''''
' Get the user's directory
''''''''''''''''''''''''''''''''''''''''''''''''''''
Res = GetUserProfileDirectory(TokenHandle, UserProfileDirectory, LLen)
If Res = 0 Then
    CloseHandle CurrentProcessHandle
    CloseHandle TokenHandle
    MsgBox "ERROR GetUserProfileDirectory   " & CStr(Err.LastDllError) & " " & GetSystemErrorMessageText(Err.LastDllError)
    Exit Function
End If

''''''''''''''''''''''''''''''''''''''''''''''''''''
' Trim to null char
''''''''''''''''''''''''''''''''''''''''''''''''''''
UserProfileDirectory = TrimToNull(Text:=UserProfileDirectory)


''''''''''''''''''''''''''''''''''''''''''''''''''''
'Close handles
''''''''''''''''''''''''''''''''''''''''''''''''''''
CloseHandle CurrentProcessHandle
CloseHandle TokenHandle

''''''''''''''''''''''''''''''''''''''''''''''''''''
' Return the result
''''''''''''''''''''''''''''''''''''''''''''''''''''
GetUserProfileFolder = UserProfileDirectory

End Function