投稿日	： 2003/04/23(Wed) 17:00
投稿者	： さおとめ
Ｅメール	：
ＵＲＬ	：
タイトル	： ソースです！

'★☆★☆★☆★☆★☆★☆★☆★☆★☆★☆★☆★☆★☆★☆★☆★☆★☆★☆★☆★
'   フォルダ選択ダイアログ表示関数の宣言
'★☆★☆★☆★☆★☆★☆★☆★☆★☆★☆★☆★☆★☆★☆★☆★☆★☆★☆★☆★
' フォルダ選択ダイアログで使用する構造体の宣言
Private Type BROWSEINFO
    hwndOwner      As Long
    pIDLRoot       As Long
    pszDisplayName As Long
    lpszTitle      As Long
    ulFlags        As Long
    lpfnCallback   As Long
    lParam         As Long
    iImage         As Long
End Type
' フォルダ選択ダイアログを表示する関数の宣言
Private Declare Function SHBrowseForFolder Lib "shell32.dll" _
   (lpbi As BROWSEINFO) As Long
' pidlをファイルシステムパスに変換する関数の宣言
Private Declare Function SHGetPathFromIDList Lib "shell32.dll" _
   (ByVal pidl As Long, _
    ByVal pszPath As String) As Long
' COMでアロケートしたメモリ領域を解放する関数の宣言
Private Declare Sub CoTaskMemFree Lib "ole32.dll" _
   (ByVal pv As Long)


'★☆
'   フォルダ選択ダイアログを表示
'★☆
Public Function MK_GetFolder(ByVal DammyForm As Form, Ini_Folder As String) As String
    
    Dim strSelectFolder           As String
    Dim udtBrowseInfo             As BROWSEINFO
    Dim bytDispName(260 - 1) As Byte
    Dim strDispName               As String
    Dim lngPidl                   As Long
    Dim strFilePath               As String
    Dim ReValue                 As Boolean

    ' 選択状態にするフォルダ名を指定
    strSelectFolder = Ini_Folder
    ' 構造体に情報を指定
    With udtBrowseInfo
        'オーナーウィンドウのハンドルを指定
        .hwndOwner = DammyForm.hwnd
        ' 表示タイトルを指定
        .lpszTitle = _
            StrPtr(StrConv("フォルダを選択してください。", vbFromUnicode))
        ' 先頭に表示するルートパスを指定
        .pIDLRoot = &H0 'CSIDL_DESKTOP
        ' 選択フォルダの表示名を受けるバッファを指定
        .pszDisplayName = VarPtr(bytDispName(0))
        ' 表示パラメータを指定
        .ulFlags = &H1
        ' コールバック関数のアドレスを指定
        .lpfnCallback = GetSubProcAddress(AddressOf BrowseCallbackProc)　←ここでエラー発生
        ' 選択状態にするフォルダを示すアドレスを指定
        .lParam = StrPtr(strSelectFolder)
    End With
    ' フォルダ選択ダイアログを表示
    lngPidl = SHBrowseForFolder(udtBrowseInfo)
    ' pidlが取得できたときは
    If lngPidl <> 0 Then
        ' pidlをフルパスに変換
        strFilePath = Space(260)
        ReValue = SHGetPathFromIDList(lngPidl, strFilePath)
        MK_GetFolder = Left(strFilePath, InStr(strFilePath, vbNullChar) - 1)
        ' メモリを解放
        CoTaskMemFree lngPidl
    End If
End Function
Private Function GetSubProcAddress _
       (lngProcAddress As Long) As Long
    GetSubProcAddress = lngProcAddress
End Function
Private Function BrowseCallbackProc(ByVal hwnd As Long, _
                                    ByVal uMsg As Long, _
                                    ByVal lParam As Long, _
                                    ByVal lpData As Long) As Long
    Dim strFolderName   As String * 1024
    Dim strSelectFolder As String
    Dim ReValue       As Boolean

    ' メッセージにより処理を分岐
    Select Case uMsg
        ' BFFM_INITIALIZED(=1)のときは
        Case 1
            ' lpDataの値を文字列バッファへ移動
            MoveMemory ByVal strFolderName, ByVal lpData, Len(strFolderName)
            ' 選択するフォルダを指定
            strSelectFolder = StrConv(strFolderName, vbFromUnicode)
            strSelectFolder = Mid(strSelectFolder, 1, InStr(strSelectFolder, vbNullChar) - 1)
            ' 指定したフォルダを選択状態に設定
            ReValue = SendMessage(hwnd, &H400 + 102, 1, ByVal strSelectFolder)
        ' その他のときは
        Case Else
            ' 処理なし
    End Select
    ' 戻り値を設定
    BrowseCallbackProc = 0
End Function

★ - AddressOf について - さおとめ 04/23-16:53No.3698
• ソースです！ - さおとめ 04/23-17:00 No.3699
• Re: AddressOf について - nanashi 04/23-17:28 No.3701
  • Re^2: AddressOf について - さおとめ 04/24-12:35 No.3711