获取系统各种文件夹路径

'使用方法
'调用函数GetSpecialPath(参数)
'例1：msgbox GetSpecialPath(CSIDL_font) & "\"              （返回系统字体的文件夹）
'例2：msgbox GetSpecialPath(CSIDL_Users_FAVORITES) & "\"   （返回当前用户收藏夹）
'例3：msgbox GetSpecialPath(CSIDL_Users_Pictures) & "\"    （返回当前用户-图片收藏）
'例4：msgbox GetSpecialPath(CSIDL_AllUsers_FAVORITES) & "\"（返回共享收藏夹）
'例5：msgbox GetSpecialPath(CSIDL_Users_MyDocuments) & "\" （返回当前用户-我的文档）
Option Explicit
Private Const NOERROR = 0
Private Const CSIDL_Users_FAVORITES = &H6 '当前用户\收藏夹
Private Const CSIDL_Users_DESKTOPDIRECTORY = &H10 '当前用户\桌面
Private Const CSIDL_Users_STARTMENU = &HB '当前用户\开始菜单
Private Const CSIDL_Users_STARTMENU_cx = &H2 '当前用户\开始-程序
Private Const CSIDL_Users_MyDocuments = &H5 '当前用户\我的文档
Private Const CSIDL_Users_STARTMENU_a = &H7 '当前用户\开始-程序-启动
Private Const CSIDL_Users_Recent = &H8 '当前用户\'Recent
Private Const CSIDL_Users_SendTo = &H9 '当前用户\SendTo
Private Const CSIDL_Users_MyMusic = &HD '当前用户\My Documents\My Music\
Private Const CSIDL_Users_NetHood = &H13 '当前用户\NetHood
Private Const CSIDL_Users_Templates = &H15 '当前用户\Templates
Private Const CSIDL_Users_AppData = &H1A '当前用户\Application Data\
Private Const CSIDL_Users_PrintHood = &H1B '当前用户\PrintHood\
Private Const CSIDL_Users_Local_AppData = &H1C '当前用户\Local Settings\Application Data\
Private Const CSIDL_Users_Temp = &H20 '当前用户\Local Settings\Temporary Internet Files\
Private Const CSIDL_Users_Cookies = &H21 '当前用户\Cookies\
Private Const CSIDL_Users_History = &H22 '当前用户\Local Settings\History\
Private Const CSIDL_Users_Pictures = &H27 '当前用户\My Documents\My Pictures\
Private Const CSIDL_Users = &H28 '当前用户\
Private Const CSIDL_Users_gl = &H30 '当前用户\「开始」菜单\程序\管理工具\
Private Const CSIDL_Users_CDBurning = &H3B '当前用户\Local Settings\Application Data\Microsoft\CD Burning\

Private Const CSIDL_AllUsers_STARTMENU = &H16 'All Users\「开始」菜单\
Private Const CSIDL_AllUsers_STARTMENU_cx = &H17 'All Users\「开始」菜单\程序\
Private Const CSIDL_AllUsers_STARTMENU_j = &H18 'All Users\「开始」菜单\程序\启动\
Private Const CSIDL_AllUsers_DESKTOPDIRECTORY = &H19 'All Users\桌面
Private Const CSIDL_AllUsers_FAVORITES = &H1F 'All Users\Favorites\(收藏夹)
Private Const CSIDL_AllUsers_Templates = &H2D 'All Users\Templates\
Private Const CSIDL_AllUsers_Documents = &H2E 'All Users\Documents\
Private Const CSIDL_AllUsers_gl = &H2F 'All Users\「开始」菜单\程序\管理工具\
Private Const CSIDL_AllUsers_Music = &H35 'All Users\Documents\My Music\
Private Const CSIDL_AllUsers_Pictures = &H36 'All Users\Documents\My Pictures\
Private Const CSIDL_AllUsers_Videos = &H37 'All Users\Documents\My Videos\
Private Const CSIDL_AllUsers_AppData = &H23 'All Users\Application Data\

Private Const CSIDL_WinDows = &H24 '系统安装路径 C:\WINDOWS\
Private Const CSIDL_WinSystem = &H25 '系统文件夹 C:\WINDOWS\system32\
Private Const CSIDL_ProgramFiles = &H26 '应用程序安装文件夹 C:\Program Files\
Private Const CSIDL__ProgramFiles_CommonFiles = &H2B 'C:\Program Files\Common Files\
Private Const CSIDL_WIN_Resources = &H38 'C:\WINDOWS\Resources\
Private Const CSIDL_font = &H14 '字体文件夹C:\WINDOWS\Fonts\
' 声明API函数
Private Declare Function SHGetPathFromIDList Lib "shell32.dll" Alias "SHGetPathFromIDListA" (ByVal pidl As Long, ByVal pszPath As String) As Long
Private Declare Function SHGetSpecialFolderLocation Lib "shell32.dll" (ByVal hwndOwner As Long, ByVal nFolder As Long, pidl As Long) As Long

Private Function GetSpecialPath(CSIDL As Long) As String
    Dim s As Long
    Dim path As String
    Dim pidl As Long
    '根据指定的文件夹获得pidl
    s = SHGetSpecialFolderLocation(Me.hWnd, CSIDL, pidl)
    If s = NOERROR Then ' 根据r的返回值判断是否有错误发生，如果没有错误就获取文件夹路径
        path = Space$(512)
        s = SHGetPathFromIDList(ByVal pidl, ByVal path)
        GetSpecialPath = Left$(path, InStr(path, Chr$(0)) - 1)
        Exit Function
    End If
    GetSpecialPath = ""
End Function
------------------------------------------------------------------------

Private Declare Function SHGetSpecialFolderLocation Lib "Shell32" (ByVal hwndOwner As Long, ByVal nFolder As Integer, ppidl As Long) As Long
Private Declare Function SHGetPathFromIDList Lib "Shell32" Alias "SHGetPathFromIDListA" (ByVal pidl As Long, ByVal szPath As String) As Long
Private Declare Function GetWindowsDirectory Lib "kernel32" Alias "GetWindowsDirectoryA" (ByVal lpBuffer As String, ByVal nSize As Long) As Long
Private Declare Function GetSystemDirectory Lib "kernel32" Alias "GetSystemDirectoryA" (ByVal lpBuffer As String, ByVal nSize As Long) As Long
Private Declare Function GetTempPath Lib "kernel32" Alias "GetTempPathA" (ByVal nBufferLength As Long, ByVal lpBuffer As String) As Long
Const MAX_LEN = 200              '字符串最大长度
Const DESKTOP = &H0&             '桌面
Const PROGRAMS = &H2&            '程序集
Const MYDOCUMENTS = &H5&         '我的文档
Const MYFAVORITES = &H6&         '收藏夹
Const STARTUP = &H7&             '启动
Const RECENT = &H8&              '最近打开的文件
Const SENDTO = &H9&              '发送
Const STARTMENU = &HB&           '开始菜单
Const NETHOOD = &H13&            '网上邻居
Const FONTS = &H14&              '字体
Const SHELLNEW = &H15&           'ShellNew
Const APPDATA = &H1A&            'Application Data
Const PRINTHOOD = &H1B&          'PrintHood
Const PAGETMP = &H20&            '网页临时文件
Const COOKIES = &H21&            'Cookies目录
Const HISTORY = &H22&            '历史

Private Sub Command2_Click()
    End
End Sub

Private Sub Form_Load()
    Dim sTmp As String * MAX_LEN '存放结果的固定长度的字符串
    Dim nLength As Long          '字符串的实际长度
    Dim pidl As Long             '某特殊目录在特殊目录列表中的位置
    '*************************获得Windows目录**********************************
    Length = GetWindowsDirectory(sTmp, MAX_LEN)
    txtWin.Text = Left(sTmp, Length)
    '*************************获得System目录***********************************
    Length = GetSystemDirectory(sTmp, MAX_LEN)
    txtSystem.Text = Left(sTmp, Length)
    '*************************获得Temp目录***********************************
    Length = GetTempPath(MAX_LEN, sTmp)
    txtTemp.Text = Left(sTmp, Length)
    '*************************获得DeskTop目录**********************************
    SHGetSpecialFolderLocation 0, DESKTOP, pidl
    SHGetPathFromIDList pidl, sTmp
    txtDesktop.Text = Left(sTmp, InStr(sTmp, Chr(0)) - 1)
    '*************************获得发送到目录**********************************
    SHGetSpecialFolderLocation 0, SENDTO, pidl
    SHGetPathFromIDList pidl, sTmp
    txtSendTo.Text = Left(sTmp, InStr(sTmp, Chr(0)) - 1)
    '*************************获得我的文档目录*********************************
    SHGetSpecialFolderLocation 0, MYDOCUMENTS, pidl
    SHGetPathFromIDList pidl, sTmp
    txtDocument.Text = Left(sTmp, InStr(sTmp, Chr(0)) - 1)
    '*************************获得程序集目录***********************************
    SHGetSpecialFolderLocation 0, PROGRAMS, pidl
    SHGetPathFromIDList pidl, sTmp
    txtProgram.Text = Left(sTmp, InStr(sTmp, Chr(0)) - 1)
    '*************************获得启动目录*************************************
    SHGetSpecialFolderLocation 0, STARTUP, pidl
    SHGetPathFromIDList pidl, sTmp
    txtStart.Text = Left(sTmp, InStr(sTmp, Chr(0)) - 1)
    '*************************获得开始菜单目录*********************************
    SHGetSpecialFolderLocation 0, STARTMENU, pidl
    SHGetPathFromIDList pidl, sTmp
    txtStartMenu.Text = Left(sTmp, InStr(sTmp, Chr(0)) - 1)
    '*************************获得收藏夹目录***********************************
    SHGetSpecialFolderLocation 0, MYFAVORITES, pidl
    SHGetPathFromIDList pidl, sTmp
    txtFavorites.Text = Left(sTmp, InStr(sTmp, Chr(0)) - 1)
    '**********************获得最后打开的文件目录*******************************
    SHGetSpecialFolderLocation 0, RECENT, pidl
    SHGetPathFromIDList pidl, sTmp
    txtRecent.Text = Left(sTmp, InStr(sTmp, Chr(0)) - 1)
    '*************************获得网上邻居目录*********************************
    SHGetSpecialFolderLocation 0, NETHOOD, pidl
    SHGetPathFromIDList pidl, sTmp
    txtNetHood.Text = Left(sTmp, InStr(sTmp, Chr(0)) - 1)
    '*************************获得字体目录**********************************
    SHGetSpecialFolderLocation 0, FONTS, pidl
    SHGetPathFromIDList pidl, sTmp
    txtFonts.Text = Left(sTmp, InStr(sTmp, Chr(0)) - 1)
    '*************************获得Cookies目录**********************************
    SHGetSpecialFolderLocation 0, COOKIES, pidl
    SHGetPathFromIDList pidl, sTmp
    txtCookies.Text = Left(sTmp, InStr(sTmp, Chr(0)) - 1)
    '*************************获得历史目录**********************************
    SHGetSpecialFolderLocation 0, HISTORY, pidl
    SHGetPathFromIDList pidl, sTmp
    txtHistory.Text = Left(sTmp, InStr(sTmp, Chr(0)) - 1)
    '***********************获得网页临时文件目录*******************************
    SHGetSpecialFolderLocation 0, PAGETMP, pidl
    SHGetPathFromIDList pidl, sTmp
    txtPageTmp.Text = Left(sTmp, InStr(sTmp, Chr(0)) - 1)
    '*************************获得ShellNew目录*********************************
    SHGetSpecialFolderLocation 0, SHELLNEW, pidl
    SHGetPathFromIDList pidl, sTmp
    txtShellNew.Text = Left(sTmp, InStr(sTmp, Chr(0)) - 1)
    '***********************获得Application Data目录*****************************
    SHGetSpecialFolderLocation 0, APPDATA, pidl
    SHGetPathFromIDList pidl, sTmp
    txtAppData.Text = Left(sTmp, InStr(sTmp, Chr(0)) - 1)
    '*************************获得PrintHood目录*********************************
    SHGetSpecialFolderLocation 0, PRINTHOOD, pidl
    SHGetPathFromIDList pidl, sTmp
    txtPrintHood.Text = Left(sTmp, InStr(sTmp, Chr(0)) - 1)
End Sub