トップ回答者
64bit フォルダ参照

質問
-
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 IfSub GetFolderName()
Dim buf As String
buf = GetDirectory("フォルダを選択してください", "E:\Develop")
If buf = "" Then
Exit Sub
Else
MsgBox buf
End If
End SubFunction 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 ' VBA7Public 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 FunctionPublic 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 FunctionPublic Function FARPROC(pfn As Long) As Long ''AddressOf演算子の戻り値を戻す関数
FARPROC = pfn
End Function
#End If