投稿日 | : 2003/04/23(Wed) 17:00 |
投稿者 | : さおとめ |
Eメール | : |
URL | : |
タイトル | : ソースです! |
'★☆★☆★☆★☆★☆★☆★☆★☆★☆★☆★☆★☆★☆★☆★☆★☆★☆★☆★☆★
' フォルダ選択ダイアログ表示関数の宣言
'★☆★☆★☆★☆★☆★☆★☆★☆★☆★☆★☆★☆★☆★☆★☆★☆★☆★☆★☆★
' フォルダ選択ダイアログで使用する構造体の宣言
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