none
64bit フォルダ参照 RRS feed

  • 質問

  • OSの環境によってVBA7か以外で使い分けをしようとしています。

    64bit環境で以下のソースを実行すると★★★'の部分で型が違います'エラー

    が発生してしまいます。

    ご教授いただけないでしょうか。

    Option Compare Database
    Option Explicit

    #If VBA7 Then    ' VBA7
     Private Declare PtrSafe Function SHGetPathFromIDList Lib "shell32.dll" Alias "SHGetPathFromIDListA" (ByVal pidl As Long, ByVal pszPath As String) As Long
     Private Declare PtrSafe Function SHBrowseForFolder Lib "shell32.dll" Alias "SHBrowseForFolderA" (lpBrowseInfo As BROWSEINFO) As Long
     Private Declare PtrSafe Sub CoTaskMemFree Lib "ole32.dll" (ByVal pv As Long)
     Private Declare PtrSafe Function SendMessage Lib "user32" Alias "SendMessageA" (ByVal hWnd As Long, ByVal wMsg As Long, ByVal wParam As Long, lParam As Any) As Long
     
     Public Const WM_USER = &H400
     Public Const BFFM_SETSELECTIONA = (WM_USER + 102)
     Public Const BFFM_INITIALIZED = 1
     
     Public Type BROWSEINFO
       hOwner As LongPtr
       pidlRoot As Long
       pszDisplayName As String
       lpszTitle As String
       ulFlags As Long
       lpfn As LongPtr
       lParam As LongPtr
       iImage As Long
     End Type
     
    #Else    ' Downlevel when using previous version of VBA7
     Private Declare Function SHGetPathFromIDList Lib "shell32.dll" Alias "SHGetPathFromIDListA"  (ByVal pidl As Long, ByVal pszPath As String) As Long
     Private Declare Function SHBrowseForFolder Lib "shell32.dll"  Alias "SHBrowseForFolderA" (lpBrowseInfo As BROWSEINFO) As Long
     Private Declare Sub CoTaskMemFree Lib "ole32.dll" (ByVal pv As Long)
     Private Declare Function SendMessage Lib "user32" Alias "SendMessageA"  (ByVal hWnd As Long, ByVal wMsg As Long,  ByVal wParam As Long, lParam As Any) As Long
     
     Public Const WM_USER = &H400
     Public Const BFFM_SETSELECTIONA = (WM_USER + 102)
     Public Const BFFM_INITIALIZED = 1
     
     Public Type BROWSEINFO
       hOwner As Long
       pidlRoot As Long
       pszDisplayName As String
       lpszTitle As String
       ulFlags As Long
       lpfn As Long
       lParam As Long
       iImage As Long
     End Type
     
    #End If

    Sub GetFolderName()
        Dim buf As String
        buf = GetDirectory("フォルダを選択してください", "E:\Develop")
        If buf = "" Then
            Exit Sub
        Else
            MsgBox buf
        End If
    End Sub

    Function GetDirectory(Optional Msg, Optional UserPath) As String
        Dim bInfo As BROWSEINFO, pPath As String
        Dim R As Long, X As Long, pos As Integer
        With bInfo
            .pidlRoot = &H0
            If IsMissing(Msg) Then
                .lpszTitle = "フォルダの選択..."
            Else
                .lpszTitle = Msg
            End If
            .ulFlags = &H40
            .lpfn = FARPROC(AddressOf BrowseCallbackProc)
            If IsMissing(UserPath) Then
                .lParam = CurDir & Chr(0)   ''またはvbNullChar
            Else
                .lParam = UserPath & Chr(0) ★★★'型が違います'エラー
            End If
        End With
        X = SHBrowseForFolder(bInfo)
        pPath = Space$(512)
        R = SHGetPathFromIDList(ByVal X, ByVal pPath)
        CoTaskMemFree X
        If R Then
            pos = InStr(pPath, Chr(0))
            GetDirectory = Left(pPath, pos - 1)
        Else
            GetDirectory = ""
        End If
    End Function


    #If VBA7 Then    ' VBA7

    Public Function BrowseCallbackProc(ByVal hWnd As LongPtr, ByVal uMsg As Long, ByVal lParam As LongPtr, ByVal lpData As Long) As Long  ''コールバック関数
        If uMsg = BFFM_INITIALIZED Then
              SendMessage hWnd, BFFM_SETSELECTIONA, 1, ByVal lpData
        End If
    End Function

    Public Function FARPROC(pfn As LongPtr) As LongPtr    ''AddressOf演算子の戻り値を戻す関数
        FARPROC = pfn
    End Function

    #Else    ' Downlevel when using previous version of VBA7

    Public Function BrowseCallbackProc(ByVal hWnd As Long, ByVal uMsg As Long, ByVal lParam As Long, ByVal lpData As Long) As Long  ''コールバック関数
        If uMsg = BFFM_INITIALIZED Then
              SendMessage hWnd, BFFM_SETSELECTIONA, 1, ByVal lpData
        End If
    End Function

    Public Function FARPROC(pfn As Long) As Long    ''AddressOf演算子の戻り値を戻す関数
        FARPROC = pfn
    End Function


    #End If

    2013年5月30日 6:16

回答

  • 多分メッセージ通りじゃないかな

    lParam の型を見直してみてください。
    • 回答の候補に設定 星 睦美 2013年6月19日 1:14
    • 回答としてマーク xxxxxyz 2013年6月27日 0:44
    • 回答としてマークされていない xxxxxyz 2013年6月27日 2:47
    • 回答としてマーク xxxxxyz 2013年6月27日 4:48
    2013年5月30日 9:27