Spezialordner, Systemordner, Windowsordner

Option Compare Database
Option Explicit

'Define Special Folder Constants
Public Const CSIDL_PROGRAMS = 2 'Program Groups Folder
Public Const CSIDL_PERSONAL = 5 'Personal Documents Folder
Public Const CSIDL_FAVORITES = 6 'Favorites Folder
Public Const CSIDL_STARTUP = 7 'Startup Group Folder
Public Const CSIDL_RECENT = 8 'Recently Used Documents Folder
Public Const CSIDL_SENDTO = 9 'Send To Folder
Public Const CSIDL_STARTMENU = 11 'Start Menu Folder
Public Const CSIDL_DESKTOPDIRECTORY = 16 'Desktop Folder
Public Const CSIDL_NETHOOD = 19 'Network Neighborhood Folder
Public Const CSIDL_TEMPLATES = 21 'Document Templates Folder
Public Const CSIDL_COMMON_STARTMENU = 22 'Common Start Menu Folder
Public Const CSIDL_COMMON_PROGRAMS = 23 'Common Program Groups Folder
Public Const CSIDL_COMMON_STARTUP = 24 'Common Startup Group Folder
Public Const CSIDL_COMMON_DESKTOPDIRECTORY = 25 'Common Desktop Folder
Public Const CSIDL_APPDATA = 26 'Application Data Folder
Public Const CSIDL_PRINTHOOD = 27 'Printers Folder
Public Const CSIDL_COMMON_FAVORITES = 31 'Common Favorites Folder
Public Const CSIDL_INTERNET_CACHE = 32 'Temp. Internet Files Folder
Public Const CSIDL_COOKIES = 33 'Cookies Folder
Public Const CSIDL_HISTORY = 34 'History Folder

'Die Deklaration der API-Funktion (auch teils ohne das Schluß-A)
Declare Function SHGetSpecialFolderPathA Lib "SHELL32.DLL" ( _
ByVal hwnd As Long, _
ByVal lpszPath As String, _
ByVal nFolder As Long, _
ByVal fCreate As Long) As Long

'Liiefere den Pfad
Public Function GetSysPath(PType As Long) As String
On Error GoTo Er
Dim Pfadname As String ' API String Variable
Pfadname = Space(260)
If SHGetSpecialFolderPathA(0, Pfadname, PType, 0) <> 0 Then
Pfadname = Mid(Pfadname, 1, InStr(Pfadname, vbNullChar) - 1)
If Right(Pfadname, 1) <> "\" Then Pfadname = Pfadname + "\"
GetSysPath = Pfadname
End If
Ex:
Exit Function
Er: MsgBox "Fehler " & Err.Number & " in GetSysPath" _
& vbCrLf & Err.Description
Resume Ex
End Function