'--------------------------- 標準モジュール ------------------------------------------------------
Option Explicit

'ルートフォルダ定数
'WindowsXPでは3Dまで値が指定できる
Private Const CSIDL_DESKTOP = &H0            '仮想デスクトップ
Private Const CSIDL_PROGRAMS = &H2           'プログラムグループ
Private Const CSIDL_CONTROLS = &H3           'コントロールパネル
Private Const CSIDL_PRINTERS = &H4           'プリンタ
Private Const CSIDL_PERSONAL = &H5           'My Documents
Private Const CSIDL_FAVORITES = &H6          'お気に入り
Private Const CSIDL_STARTUP = &H7            'スタートアップ
Private Const CSIDL_RECENT = &H8             '最近使ったファイル
Private Const CSIDL_SENDTO = &H9             '送る
Private Const CSIDL_BITBUCKET = &HA          'ごみ箱
Private Const CSIDL_STARTMENU = &HB          'スタートメニュー
Private Const CSIDL_DESKTOPDIRECTORY = &H10  'デスクトップフォルダ
Private Const CSIDL_DRIVES = &H11            'ドライブ
Private Const CSIDL_NETWORK = &H12           'ネットワーク
Private Const CSIDL_NETHOOD = &H13           'NetHood
Private Const CSIDL_FONTS = &H14             'フォント
Private Const CSIDL_TEMPLATES = &H15         'テンプレート

'オプション定数
'コントロールパネル、プリンタ等の選択不可
Private Const BIF_RETURNONLYFSDIRS = &H1
'ネットワークコンピュータ内のリソースを非表示
Private Const BIF_DONTGOBELOWDOMAIN = &H2
'全リソースの選択可
Private Const BIF_BROWSEINCLUDEFILES = &H4000

Public Const WM_USER = &H400 'ユーザーが定義できるメッセージの使用領域を表すだけでこれ自体に意味はない
Public Const BFFM_INITIALIZED = 1
Public Const BFFM_SETSELECTIONA = (WM_USER + 102)

Type BROWSEINFO
    hwndOwner As Long        'ダイアログボックスの親ウインドウのハンドル
    pidlRoot As Long         'ルート フォルダ(CSIDL_xxx)
    pszDisplayName As String '(戻り値)フォルダ名
    lpszTitle As String      'ダイアログの解説文
    ulFlags As Long          'フォルダのタイプを示すオプション定数(BIF_xxx)
    lpfn As Long             'コールバック関数のエントリーポイント(0 可能)
    lParam As Long           '同、パラメータ
    iImage As Long           'フォルダ用アイコンのシステムイメージリストのID
End Type
    
'フォルダ参照ダイアログ表示
Private Declare Function SHBrowseForFolder Lib "shell32.dll" Alias "SHBrowseForFolderA" (lpBROWSEINFO As BROWSEINFO) As Long

'フォルダパスを取得
'成功=1
'失敗=0
Private Declare Function SHGetPathFromIDList Lib "shell32.dll" Alias "SHGetPathFromIDListA" (ByVal pIDL As Long, ByVal pszPath As String) As Long

'メモリを開放
Private Declare Sub CoTaskMemFree Lib "ole32" (ByVal pv As Long)

Declare Function SendMessageStr Lib "USER32" Alias "SendMessageA" (ByVal hWnd&, ByVal wMsg&, ByVal wParam&, ByVal lParam$) As Long

Declare Sub MoveMemory Lib "kernel32" Alias "RtlMoveMemory" (Dest As Any, Source As Any, ByVal length&)

'OSのバージョンを取得
Type OSVERSIONINFO
    dwOSVersionInfoSize As Long     '構造体のバイト数
    dwMajorVersion As Long          'メジャーバージョン番号(Windows98/95とも &H4)
    dwMinorVersion As Long          'マイナーバージョン番号(Windows95 = &H0  Windows98 = &HA)
    dwBuildNumber As Long           'ビルド番号
    dwPlatformId As Long            'プラットフォームのIDを示す定数
    szCSDVersion As String * 128    'OSに関する付加情報を示す文字列
End Type

'プラットフォームのIDを示す定数
Public Const VER_PLATFORM_WIN32_NT = 2
Public Const VER_PLATFORM_WIN32_WINDOWS = 1 '(Windows98/95とも 1)
Public Const VER_PLATFORM_WIN32s = 0

Declare Function GetVersionEx Lib "kernel32" Alias "GetVersionExA" (lpVersionInformation As OSVERSIONINFO) As Long

Public Const MAX_PATH = 260
Dim f As Integer

Sub BrowseFolderTest()
    Dim pidlRoot As Long
    Dim WinXP As Boolean
    Dim ToVal As Integer
    Dim wFile As String
    
    WinXP = (InStr("XP", UCase(LsGetWinOS())) > 0)
    '95, 98, Me では定数どおりです。それ以外の値は異常終了します。NTではテストしていません。
    If WinXP Then
        ToVal = &H3D
    Else
        ToVal = &H15
    End If
    
    wFile = ThisWorkbook.Path & "\SHBrowseForFolder.txt"
    
    f = FreeFile
    Open wFile For Output As f
    
    For pidlRoot = 0 To ToVal
        If WinXP = True Or WinXP = False And InStr("1 C D E F", Hex$(pidlRoot)) < 1 Then
            BrowseFolderRoot pidlRoot
        End If
    Next pidlRoot
    
    Close f
    MsgBox "BrowseFolderに指定できるフォルダ定数を次のファイルに出力しました。" & vbCr & wFile, vbInformation
End Sub

Sub BrowseFolderRoot(pidlRoot As Long)
    'ルート フォルダ(CSIDL_xxx)を指定する場合
    Dim rc As Long
    Dim pIDL As Long
    Dim wFolderName As String
    Dim wPath As String
    Dim lpbi As BROWSEINFO
    
    Debug.Print Hex$(pidlRoot);
    'ダイアログボックスの項目を設定
    With lpbi
        'ダイアログボックスの親ウインドウのハンドル
        '   正式にはExcelのウインドウのハンドルを渡すべきですが、めんどいのでゼロ^_^;
        .hwndOwner = 0
        'ルート フォルダ(CSIDL_xxx)
        .pidlRoot = pidlRoot 'CSIDL_DRIVES
        '(戻り値)フォルダ名
        .pszDisplayName = String(MAX_PATH, vbNullChar)
        'ダイアログに表示するコメント
        .lpszTitle = "フォルダを選択してください"
        'フォルダのタイプを示すオプション定数(BIF_xxx)
        .ulFlags = BIF_BROWSEINCLUDEFILES 'BIF_DONTGOBELOWDOMAIN Or BIF_RETURNONLYFSDIRS
        
        .lpfn = 0
        .lParam = 0
        .iImage = 0
    End With
    
    'ダイアログボックスを表示
    pIDL = SHBrowseForFolder(lpbi)
    
    If pIDL = 0 Then Exit Sub
    
    'パス名を受け取るバッファを確保
    wPath = String(MAX_PATH, vbNullChar)
    
    'パス名を取得
    rc = SHGetPathFromIDList(pIDL, wPath)
    
    'ITEMID リストを開放
    Call CoTaskMemFree(pIDL)
    
    'バッファ内の最初の vbNullChar までの文字列を取り出す
    'gGetStrFromBuffer 関数は、Visual Basic コードのプロシージャ（GENERAL.BAS に含まれる）
    wFolderName = gGetStrFromBuffer(lpbi.pszDisplayName)
    wPath = gGetStrFromBuffer(wPath)
    
    Print #f, Hex$(pidlRoot) & "  " & wFolderName & vbCrLf & wPath
    Debug.Print "  " & wFolderName & vbCr & wPath;
    Debug.Print
End Sub

Sub BrowseFolderAny(wRootPath As String)
    '任意のフォルダを指定する場合
    'Excel2000より前のExcelでは AddressOf 演算子がサポートされていないので任意のフォルダ指定はできません。
    Dim lpbi As BROWSEINFO
    Dim pIDL As Long
    Dim wPath As String
    Dim hHeap As Long, lpMem As Long
    
    'wRootPath = "C:\Program Files\Microsoft Office"
    'wRootPath = "C:\Documents and Settings\Loadsystem"
    
    'WindowsXPでは、Windowsフォルダを指定するとマイコンピュータが指定される。
    'wRootPath = "C:\Windows"
    
    With lpbi
        'ダイアログボックスの親ウインドウのハンドル
        '   正式にはExcelのウインドウのハンドルを渡すべきですが、めんどいのでゼロ^_^;
        .hwndOwner = 0
        'ルート フォルダ(CSIDL_xxx)
        .pidlRoot = 0
        'ダイアログに表示するコメント
        .lpszTitle = "フォルダを選択してください"
        '(戻り値)フォルダ名は指定しない
        '.pszDisplayName = String(MAX_PATH, vbNullChar)
        
        'コールバック関数のエントリーポイント
        .lpfn = gGetPointerOfProcedure(AddressOf BrowseCallbackProc)
        'コールバック関数のパラメータ
        .lParam = StrPtr(StrConv(wRootPath, vbFromUnicode))
        .iImage = 0
    End With
    
    'ITEMID リストのハンドルを取得する
    '実際にダイアログを表示するのは BrowseCallbackProc
    pIDL = SHBrowseForFolder(lpbi)
    
    If pIDL Then
       'パス名を受け取るバッファを確保
       wPath = String(MAX_PATH, vbNullChar)
       'フォルダパスを取得
       If SHGetPathFromIDList(pIDL, wPath) Then
           MsgBox Left(wPath, InStr(wPath, vbNullChar) - 1)
       End If
       Call CoTaskMemFree(pIDL)
    End If
End Sub

Public Function gGetPointerOfProcedure(pProcedure As Long) As Long
    'AddressOf関数は、関数内のパラメータとしてでないと使えないのでこのプロシージャでLong値に変換する
    gGetPointerOfProcedure = pProcedure
End Function

Public Function gGetStrFromBuffer(sString As String) As String
    '文字列の最初の vbNullChar までを抜き出す
    If InStr(sString, vbNullChar) Then
      gGetStrFromBuffer = Left$(sString, InStr(sString, vbNullChar) - 1)
    Else
      gGetStrFromBuffer = sString
    End If
End Function

Public Function BrowseCallbackProc(ByVal hWnd As Long, ByVal uMsg As Long, ByVal lParam As Long, ByVal lpData As Long) As Long
    'SHBrowseForFolder 関数のコールバック関数
    'ダイアログの初期化が完了したとき
    'lpData で戻ったルートディレクトリを設定
    If uMsg = BFFM_INITIALIZED Then
        Call SendMessageStr(hWnd, BFFM_SETSELECTIONA, True, gGetStrFromPtr(lpData, MAX_PATH))
    End If
End Function

Public Function gGetStrFromPtr(pString As Long, nBytes As Long) As String
    ReDim BufArray(nBytes) As Byte
    
    Call MoveMemory(BufArray(0), ByVal pString, nBytes)
    gGetStrFromPtr = gGetStrFromBuffer(StrConv(BufArray(), vbUnicode))
End Function

Public Function LsGetWinOS() As String
    Dim rc As Long, lpVersionInformation As OSVERSIONINFO
    
    lpVersionInformation.dwOSVersionInfoSize = Len(lpVersionInformation)
    rc = GetVersionEx(lpVersionInformation)
    With lpVersionInformation
    
        Select Case .dwPlatformId              'プラットフォームのIDを示す定数
        Case VER_PLATFORM_WIN32_NT
            If .dwMajorVersion = 5 And .dwMinorVersion = 1 Then
                LsGetWinOS = "XP"
            ElseIf .dwMajorVersion = 5 And .dwMinorVersion = 0 Then
                LsGetWinOS = "2000"
            ElseIf .dwMajorVersion = 4 And .dwMinorVersion = 0 Then
                LsGetWinOS = "NT4.0"
            ElseIf .dwMajorVersion = 3 And .dwMinorVersion = 51 Then
                LsGetWinOS = "NT3.51"
            Else
                LsGetWinOS = "??"
            End If
        Case VER_PLATFORM_WIN32_WINDOWS
            If .dwMajorVersion = 4 And .dwMinorVersion = 90 Then
                LsGetWinOS = "Me"
            ElseIf .dwMajorVersion = 4 And .dwMinorVersion = 10 Then
                LsGetWinOS = "98"
            ElseIf .dwMajorVersion = 4 And .dwMinorVersion = 0 Then
                LsGetWinOS = "95"
            Else
                LsGetWinOS = "??"
            End If
        Case VER_PLATFORM_WIN32s
            LsGetWinOS = "Win32s"
        Case Else
            LsGetWinOS = "??"
        End Select
    End With
End Function

'--------------------------- ThisWorkbookクラスモジュール ---------------------------------------
Option Explicit

Private Sub Workbook_Open()
    Dim flg As Boolean
    Dim w As String
    
    With ThisWorkbook.Worksheets(1)
        .Range("b2").Value = "このマシンのOSは Windows " & LsGetWinOS() & " です"
        flg = (Application.Version >= "9.0")
        If flg = False Then
            w = "Excel2000より前のExcelでは AddressOf 演算子がサポートされていないので任意のフォルダ指定はできません。"
        End If
        .Range("b8").Value = w
        .CommandButton2.Enabled = flg
    End With
    ThisWorkbook.Saved = True
End Sub

'--------------------------- Sheet1クラスモジュール ---------------------------------------
Option Explicit

Private Sub CommandButton1_Click()
    BrowseFolderTest
End Sub

Private Sub CommandButton2_Click()
    Dim wFolder As String
    
    wFolder = InputBox("BrowseFolderを実行する任意のフォルダを指定してください。", "BrowseFolderフォルダ指定", "C:\Program Files\Microsoft Office")

    If wFolder > "" Then BrowseFolderAny wFolder
End Sub