#057 My Documentsフォルダのパスを取得するには? VBA、API

AccessやWord、Excelなどのファイルを保存する際のデフォルトのフォルダである My Documentsフォルダのパスを取得するには、"SHELL32.DLL"にあるWindowsAPIの「SHGetSpecialFolderLocation」関数および「SHGetPathFromIDList」関数を使用します。

まず標準モジュールに次のコードを記述します。"Declare"の前に"Private"を付けることによってフォームのモジュールにも記述できます。
'特殊フォルダのIDを取得するAPI関数
Declare Function SHGetSpecialFolderLocation Lib "SHELL32.DLL" _
        (ByVal hWndOwner As Long, ByVal nFolder As Long, ppidl As Long) As Long
'特殊フォルダのIDからフォルダのパスを取得するAPI関数
Declare Function SHGetPathFromIDList Lib "SHELL32.DLL" Alias _
      "SHGetPathFromIDListA" (ByVal pidl As Long, ByVal pszPath As String) As Long

サンプルプロシージャ:
Function GetMyDocPath() As String
  Const CSIDL_PERSONAL = &H5  'My Documents フォルダの定数
  Const MAX_PATH = 260  'フォルダ名の長さの最大値
  Dim strBuffer  As String * MAX_PATH 'フォルダ名を受け取るバッファ
  Dim lngSpFolderLocation As Long 'フォルダのID
  Dim lngRet As Long

  'API関数を呼び出して My Doucutents フォルダのIDを取得
  lngRet = SHGetSpecialFolderLocation(Application.hWndAccessApp, _
                                      CSIDL_PERSONAL, lngSpFolderLocation)

  If lngSpFolderLocation <> 0 Then
    '特殊フォルダのIDが取得できたら、API関数を呼び出して
    'フォルダIDに対応したフォルダのパスを取り出します
    lngRet = SHGetPathFromIDList(lngSpFolderLocation, strBuffer)
    '返り値の後続の Null を取り除いて返します
    '("C:\My Documents" などが返る.....必要なら最後に¥を付けます)
    GetMyDocPath = Left(strBuffer, InStr(strBuffer, vbNullChar) - 1)
  Else
    '取得できなければ長さゼロの文字列を返します
    GetMyDocPath = ""
  End If

End Function

ここでは My Documents フォルダに特化したサンプルコードとしましたが、「Const CSIDL_PERSONAL = &H5」の部分を次のような定数定義に変えることによって、その他の特殊なフォルダのパスを取得することもできます。もちろんその場合には上記のコードのFunctionプロシージャ名を変えた方がよいでしょう。また、これを定数ではなくFunctionプロシージャの引数とすることによって、さまざまな特殊フォルダのパスを返す関数に作り上げることもできます。

※その他の特殊フォルダIDの定数(一例)
Const CSIDL_PROGRAMS = &H2  'スタート メニュー\プログラム
Const CSIDL_FAVORITES = &H6  'お気に入り
Const CSIDL_STARTUP = &H7  'スタート メニュー\プログラム\スタートアップ
Const CSIDL_RECENT = &H8  '最近使ったファイル(Recent)
Const CSIDL_SENDTO = &H9  '送る(SendTo)
Const CSIDL_STARTMENU = &HB  'スタート メニュー

| Index | Prev | Next |

この情報は参考になりましたか?、問題は解決しましたか?、もしまだなら......
T'sWareのワンポイトテクニカルアドバイスをご利用ください。3000円/件〜でご支援します。
スタンドアロンからSQL Server対応まで、オーダーメイドのシステムを短納期・安価でお届けします


Copyright © T'sWare All rights reserved