Private Declare Function SHGetFolderPath Lib "shfolder" Alias "SHGetFolderPathA" ( ByVal hwndOwner As Long , _
ByVal nFolder As Long , ByVal hToken As Long , ByVal dwFlags As Long , ByVal pszPath As String ) As Long
Private Const CSIDL_FLAG_MASK = &HFF00 'mask For all possible flag values
Private Const SHGFP_Type_CURRENT = &H0 'current value For user, verify it exists
Private Const SHGFP_Type_DEFAULT = &H1
Private Const S_OK = 0
Private Const S_False = 1
Private Const E_INVALIDARG = &H80070057 ' Invalid CSIDL Value
Private Const CSIDL_ADMINTOOLS As Long = &H30 '{user}\Start Menu _ '\Programs\Administrative Tools
Private Const CSIDL_COMMON_ADMINTOOLS As Long = &H2F '(all users)\Start Menu\Programs\Administrative Tools
Private Const CSIDL_APPDATA As Long = &H1A '{user}\Application Data
Private Const CSIDL_COMMON_APPDATA As Long = &H23 '(all users)\Application Data
Private Const CSIDL_COMMON_DOCUMENTS As Long = &H2E '(all users)\Documents
Private Const CSIDL_COOKIES As Long = &H21
Private Const CSIDL_HISTORY As Long = &H22
Private Const CSIDL_INTERNET_CACHE As Long = &H20 'Internet Cache folder
Private Const CSIDL_LOCAL_APPDATA As Long = &H1C '{user}\Local Settings\Application Data (non roaming)
Private Const CSIDL_MYPICTURES As Long = &H27 'C:\Program Files\My Pictures
Private Const CSIDL_PERSONAL As Long = &H5 'My Documents
Private Const CSIDL_PROGRAM_FILES As Long = &H26 'Program Files folder
Private Const CSIDL_PROGRAM_FILES_COMMON As Long = &H2B 'Program Files\Common
Private Const CSIDL_SYSTEM As Long = &H25 'system folder
Private Const CSIDL_WINDOWS As Long = &H24 'Windows directory Or SYSROOT()
Private Const CSIDL_FLAG_CREATE = &H8000& 'combine With CSIDL_ value To force
Private Const MAX_PATH = 260
Other Special Folder CSIDLs Not supported by this API.
Private Const CSIDL_ALTSTARTUP As Long = &H1D 'non localized startup
Private Const CSIDL_BITBUCKET As Long = &HA '{desktop}\Recycle Bin
Private Const CSIDL_CONTROLS As Long = &H3 'My Computer\Control Panel
Private Const CSIDL_DESKTOP As Long = &H0 '{namespace root}
Private Const CSIDL_DESKTOPDIRECTORY As Long = &H10 '{user}\Desktop
Private Const CSIDL_FAVORITES As Long = &H6 '{user}\Favourites
Private Const CSIDL_FONTS As Long = &H14 'windows\fonts
Private Const CSIDL_INTERNET As Long = &H1 'Internet virtual folder
Private Const CSIDL_DRIVES As Long = &H11 'My Computer
Private Const CSIDL_NETHOOD As Long = &H13 '{user}\nethood
Private Const CSIDL_NETWORK As Long = &H12 'Network Neighbourhood
Private Const CSIDL_PRINTERS As Long = &H4 'My Computer\Printers
Private Const CSIDL_PRINTHOOD As Long = &H1B '{user}\PrintHood
Private Const CSIDL_PROGRAM_FILESX86 As Long = &H2A 'Program Files folder For x86 apps (Alpha)
Private Const CSIDL_PROGRAMS As Long = &H2 'Start Menu\Programs
Private Const CSIDL_PROGRAM_FILES_COMMONX86 As Long = &H2C 'x86 \Program Files\Common On RISC
Private Const CSIDL_RECENT As Long = &H8 '{user}\Recent
Private Const CSIDL_SENDTO As Long = &H9 '{user}\SendTo
Private Const CSIDL_STARTMENU As Long = &HB '{user}\Start Menu
Private Const CSIDL_STARTUP As Long = &H7 'Start Menu\Programs\Startup
Private Const CSIDL_SYSTEMX86 As Long = &H29 'system folder For x86 apps (Alpha)
Private Const CSIDL_TEMPLATES As Long = &H15
Private Const CSIDL_PROFILE As Long = &H28 'user's profile folder
Private Const CSIDL_COMMON_ALTSTARTUP As Long = &H1E 'non localized common startup
Private Const CSIDL_COMMON_DESKTOPDIRECTORY As Long = &H19 '(all users)\Desktop
Private Const CSIDL_COMMON_FAVORITES As Long = &H1F '(all users)\Favourites
Private Const CSIDL_COMMON_PROGRAMS As Long = &H17 '(all users)\Programs
Private Const CSIDL_COMMON_STARTMENU As Long = &H16 '(all users)\Start Menu
Private Const CSIDL_COMMON_STARTUP As Long = &H18 '(all users)\Startup
Private Const CSIDL_COMMON_TEMPLATES As Long = &H2D '(all users)\Templates
Dim lngReturn As Long
Print GetSpecialFolderPath(CSIDL_PROGRAM_FILES)
Function GetSpecialFolderPath(CSIDL As Long ) As String
Dim strPath As String
Dim iReturn As Long
strPath = String (MAX_PATH, 0)
iReturn = SHGetFolderPath(0, CSIDL, 0, SHGFP_Type_CURRENT, strPath)
Select Case iReturn
Case S_OK
GetSpecialFolderPath = Left$(strPath, InStr(1, strPath, Chr (0)) - 1)
Case S_False
GetSpecialFolderPath = "Folder Does Not Exist"
Case Else
GetSpecialFolderPath = "Folder Not Valid On this OS"
End Select
End Function
