Private Type SHELLEXECUTEINFO
      cbSize       As Long
      fMask        As Long
      hWnd         As Long
      lpVerb       As String
      lpFile       As String
      lpParameters As String
      lpDirectory  As String
      nShow        As Long
      hInstApp     As Long
      lpIDList     As Long
      lpClass      As String
      hkeyClass    As Long
      dwHotKey     As Long
      hIcon        As Long
      hProcess     As Long
End Type

Private Declare Function ShellExecuteEx Lib "shell32.dll" (udtSHELLEXECUTEINFO As SHELLEXECUTEINFO) As Long

Private Declare Function SHGetSpecialFolderLocation Lib "shell32" (ByVal hwndOwner As Long, ByVal nFolder As Long, ppidl As Long) As Long

Private Declare Sub CoTaskMemFree Lib "ole32" (ByVal pv As Long)

Private Const SEE_MASK_INVOKEIDLIST = &HC

'特殊フォルダID
Public Enum SPECIAL_FOLDER_ID
    CSIDL_DESKTOP = &H0   'デスクトップフォルダ
    CSIDL_PROGRAMS = &H2  'プログラムフォルダ
    CSIDL_CONTROLS = &H3
    CSIDL_PRINTERS = &H4
    CSIDL_PERSONAL = &H5  'My Documentsフォルダ
    CSIDL_FAVORITES = &H6 'favoriteフォルダ
    CSIDL_STARTUP = &H7   'スタートアップフォルダ
    CSIDL_RECENT = &H8    'Recent フォルダ
    CSIDL_SENDTO = &H9    'Send Toフォルダ
    CSIDL_BITBUCKET = &HA 'ごみ箱フォルダ
    CSIDL_STARTMENU = &HB 'スタートメニューフォルダ
    CSIDL_DESKTOPDIRECTORY = &H10 'デスクトップフォルダ
    CSIDL_DRIVES = &H11   'マイコンピュータフォルダ
    CSIDL_NETWORK = &H12
    CSIDL_NETHOOD = &H13
    CSIDL_FONTS = &H14     'fontsフォルダ
    CSIDL_TEMPLATES = &H15 'ShellNewフォルダ
End Enum

'---------------------------------------------------------------------------
' 関数名： OpenSpecialFolder
' 機能 ： 特殊フォルダを開く
' 引数 ： (in) hWnd … 呼び出し側のウインドウハンドル
'         (in) CSpID … 特殊フォルダID
' 返り値： 正常：1   パラメータエラー：-1  その他のエラー：0
'---------------------------------------------------------------------------
Public Function OpenSpecialFolder(ByVal hWnd As Long, ByVal CSpID As SPECIAL_FOLDER_ID) As Long

    Dim udtSHELLEXECUTEINFO As SHELLEXECUTEINFO
    Dim pIDspFolderID As Long
    Dim spFolderID As Long

    '特別なフォルダのIDを取得する
    If SHGetSpecialFolderLocation(hWnd, CSpID, pIDspFolderID) >= 0 Then
        If pIDspFolderID Then
            With udtSHELLEXECUTEINFO
                .cbSize = Len(udtSHELLEXECUTEINFO)
                .fMask = SEE_MASK_INVOKEIDLIST
                .hWnd = hWnd
                .nShow = vbNormalFocus
                .lpIDList = pIDspFolderID
            End With

            '特殊フォルダーを開く
            OpenSpecialFolder = ShellExecuteEx(udtSHELLEXECUTEINFO)

            'メモリ解放
            Call CoTaskMemFree(pIDspFolderID)
        End If
    End If

End Function