質問
2016年3月28日月曜日 10:33
Excel2013(32bit)で運用していた「フォルダ参照のダイアログ」を
Excel2013(64bit)で運用しようとしたら、下記の｢★★★｣示しヶ所でコンパイルエラー「型が一致しません」が発生します。
非力にて対処方法が解りません…ご教授よろしくお願いいたします。
'*******************************************************************************
'** フォルダ参照のダイアログ処理 **
'*******************************************************************************
Option Explicit
'フォルダ参照のダイアログの引数
Public Const GxWinMessage = "フォルダを指定して下さい" '…ウィンドウ内メッセージ
Public Const GxWinTitle = "フォルダ参照のダイアログ" '…ウィンドウタイトル
Public Const GxRootPath = "C:\" '…初回のルートフォルダ
Public Const GxRootSwitch = 3 '…3=キャンセル時に初期化する
Public Const GxIncludeSwitch = 9 '…1=フォルダ名のみ表示 1≠ファイルも表示する
'構造体:ダイアログ(SHBrowseForFolder)選択のインターフェース
Private Type BROWSEINFO
BxWinHandle As Long '…ダイアログの親ウィンドウのハンドル
BxRootFolder As Long '…ルートフォルダ
BxSelectFolder As String '…選択フォルダ名
BxWinMessage As String '…ダイアログに表示するメッセージ
BxOptionFlags As Long '…オプション
BxPointer As Long '…コールバック関数へのポインタ
BxParameter As String '…コールバック関数へのパラメータ
BxImage As Long '…フォルダーアイコンのシステムイメージリスト
End Type
'定数:ルートフォルダ(BxRootFolder)指定項目
Private Const RFzDESKTOP = &H0 '…デスクトップ(仮想)
'定数:オプションフラグ(BxOptionFlags)指定項目
Private Const OFzRETURNONLYFSDIRS = &H1 '…フォルダのみ(コンパネ,プリンタ等不可)
Private Const OFzNEWDIALOGSTYLE = &H40 '…新ダイアログ表示(v5.0)Win2000
Private Const OFzNONEWFOLDERBUTTON = &H200 '…新しいフォルダを表示しない(v6.0)WinXP
Private Const OFzBROWSEINCLUDEFILES = &H4000 '…ファイル名も表示(v4.71)
'定数:コールバック関数内(SendMessage)指定項目
Private Const SMzUSER = &H400 '…ウィンドウクラスが使用するメッセージ番号の先頭の値
Private Const SMzINITIALIZED = 1 '…ダイアログの初期化終了、BxParameterはNULL
Private Const SMzSELECTCHANGED = 2 '…選択が変更された。BxParameterは新しく選択されたフォルダのID
Private Const SMzENABLEOK = SMzUSER ; 101 '…OKボタンの有効/無効の設定
Private Const SMzSETSELECTION = SMzUSER ; 102 '…初期フォルダの設定
'定数:そのた指定項目
Private Const FNzMAXPATH = 260 '…パス名の最大バイト数
'API:フォルダ参照のダイアログを表示する
Private Declare PtrSafe Function SHBrowseForFolder Lib "SHELL32.dll" _
Alias "SHBrowseForFolderA" _
(lpBROWSEINFO As BROWSEINFO) As Long
'API:フォルダのパスを取得する
Private Declare PtrSafe Function SHGetPathFromIDList Lib "SHELL32.dll" _
Alias "SHGetPathFromIDListA" _
(ByVal lxDigital As Long, _
ByVal lxFolderPath As String) As Long
'API:メモリを開放する
Private Declare PtrSafe Function SHFree Lib "SHELL32.dll" _
Alias "#195" (ByVal lxDigital As Long) As Long
'API:ウィンドゥハンドルを返す
Private Declare PtrSafe Function FindWindow Lib "USER32.dll" _
Alias "FindWindowA" _
(ByVal lxClassName As Any, _
ByVal lxWindowName As Any) As Long
'API:前回選択したフォルダの記憶
Private Declare PtrSafe Function SendMessage Lib "USER32.dll" _
Alias "SendMessageA" _
(ByVal lxWinHandle As Long, _
ByVal lxSendMessage As Long, _
ByVal lxParameter As Long, _
BxParameter As Any) As Long
'API:ダイアログのタイトル変更
Private Declare PtrSafe Function SetWindowText Lib "USER32.dll" _
Alias "SetWindowTextA" _
(ByVal lxWinHandle As Long, _
ByVal lxString As String) As Long
'API:マウントしてるネットワークリソース名を取得
Private Declare PtrSafe Function WNetGetConnection Lib "MPR.dll" _
Alias "WNetGetConnectionA" _
(ByVal lxLocalName As String, _
ByVal lxRemoteName As String, _
lxRemoteName2 As Long) As Long
Private lxWinTitle As String
'*******************************************************************************
'* 1.フォルダ参照のダイアログを表示…選択したフォルダ名を返す
'*******************************************************************************
'* 引数1.Windowへのメッセージ
'* 2.ネットワークドライブシンボル(True)
'* 3.Application:ファイル名(Option)
'* 4.ルートフォルダ(Option)
'* 5.ルートフォルダのスイッチ(Option, 3=キャンセル時に初期化)
'* 6.ファイル表示のスイッチ(Option, 1=フォルダ名のみ 1≠ファイルも表示する)
'* 7.Windowへのタイトル(Option)
'* 戻値= フォルダ名(フルパスで右端\なし)
'*******************************************************************************
Public Function BrowseForFolder(sxWinMessage As String, _
blnNetGetConnection As Boolean, _
Optional sxAppName As String, _
Optional sxRootPath As String, _
Optional sxRootSwitch As Integer, _
Optional sxIncludeSwitch As Integer, _
Optional sxWinTitle As String) As String
Dim sxBROWSEINFO As BROWSEINFO
Dim sxClassName As String
Dim sxBuffer As String
Dim GxPathName As String
Dim wWinHandle As Long
Dim wFoldPointer As Long
Static AxPrivateDir As String
'キャンセルの場合はブランクが返ります
BrowseForFolder = ""
On Error GoTo BrowseForFolder_EXIT
lxWinTitle = sxWinTitle '…ウィンドウタイトル(Option)
sxClassName = "XLMAIN" '…ウィンドウハンドルを取得
wWinHandle = FindWindow(sxClassName, sxAppName)
With sxBROWSEINFO
.BxWinHandle = wWinHandle '…ウィンドウハンドル
.BxSelectFolder = String$(FNzMAXPATH ; 1, Chr(0))
.BxRootFolder = RFzDESKTOP '…オプション指定がない場合、デスクトップを設定(仮想)
If AxPrivateDir = "" Then
AxPrivateDir = sxRootPath '…ルートフォルダ(Option)
End If
.BxWinMessage = sxWinMessage '…タイトル(ウィンドウ内)
'※1.フォルダを表示 2.新ダイアログ表示 3.新しいフォルダを表示しない 4.ファイル名も表示
If sxIncludeSwitch = 1 Then
.BxOptionFlags = OFzRETURNONLYFSDIRS Or _
OFzNEWDIALOGSTYLE Or _
OFzNONEWFOLDERBUTTON '…フォルダ名のみ表示
Else
.BxOptionFlags = OFzRETURNONLYFSDIRS Or _
OFzNEWDIALOGSTYLE Or _
OFzNONEWFOLDERBUTTON Or _
OFzBROWSEINCLUDEFILES '…ファイル名も表示
End If
.BxPointer = FP_GetAddressOf(AddressOf FP_BrowseCallback) '←★★★コンパイルエラー
If Len(AxPrivateDir) > 0 Then
.BxParameter = AxPrivateDir
End If
End With
'フォルダ参照のダイアログを表示する
wFoldPointer = SHBrowseForFolder(sxBROWSEINFO)
If wFoldPointer <> 0 Then '…キャンセルの時[0]が返される
'予めNull文字をセット
sxBuffer = String$(FNzMAXPATH ; 1, Chr(0))
'SHBrowseForFolderで得られた値からフォルダのパスを取得
If SHGetPathFromIDList(wFoldPointer, sxBuffer) <> 0 Then
'Null文字以下を削除
sxBuffer = Left$(sxBuffer, InStr(1, sxBuffer, Chr(0), 1) - 1)
If ((blnNetGetConnection = True) And _
(Mid$(sxBuffer, 2, 1) = ":")) Then
GxPathName = FP_GetResourceNameFromLocalDrive(sxBuffer) & Mid$(sxBuffer, 3)
Else
GxPathName = sxBuffer
End If
BrowseForFolder = GxPathName
AxPrivateDir = GxPathName
End If
ElseIf sxRootSwitch = 2 Then
AxPrivateDir = GxRootPath '…キャンセル時:初回フォルダにする
ElseIf sxRootSwitch = 3 Then
AxPrivateDir = "" '…キャンセル時:システムのデフォルト･フォルダにする
End If
'
BrowseForFolder_EXIT:
'割り当てられたメモリを開放
If wFoldPointer <> 0 Then
Call SHFree(wFoldPointer)
End If
End Function
'*******************************************************************************
'* 2.SHBrowseForFolderのコールバック関数
'*******************************************************************************
Private Function FP_GetAddressOf(ByVal wProc As Long) As Long
FP_GetAddressOf = wProc
End Function
'*******************************************************************************
'* 3.SHBrowseForFolderのコールバック関数
'*******************************************************************************
Private Function FP_BrowseCallback(ByVal lxWinHandle As Long, _
ByVal wMsg As Long, _
ByVal BxParameter As Long, _
ByVal wData As Long) As Long
Select Case wMsg
'初期化時
Case SMzINITIALIZED
'初期フォルダを選択する
SendMessage lxWinHandle, SMzSETSELECTION, 1, ByVal wData
If Len(lxWinTitle) > 0 Then
Call SetWindowText(lxWinHandle, lxWinTitle) '…タイトルを表示
End If
'ツリー内の選択位置変更時
Case SMzSELECTCHANGED
'ボタンのEnabled切り換え(パス変換不可時OKボタンをグレーに)
SendMessage lxWinHandle, SMzENABLEOK, 0, ByVal SHGetPathFromIDList(BxParameter, Space$(FNzMAXPATH))
End Select
End Function
'*******************************************************************************
'* 4.ネットワークリソース取得
'*******************************************************************************
Private Function FP_GetResourceNameFromLocalDrive(sxDrive As String) As String
Dim wBuffer As String
Dim wDriveName As String
Dim wLen As Long
wDriveName = Left$(sxDrive, 1) & ":"
wBuffer = String$(FNzMAXPATH ; 1, vbNullChar)
WNetGetConnection wDriveName, wBuffer, FNzMAXPATH
'取得したパス名から必要な文字列だけを抽出
wLen = InStr(1, wBuffer, vbNullChar)
If wLen > 1 Then
FP_GetResourceNameFromLocalDrive = Left$(wBuffer, wLen - 1)
Else
FP_GetResourceNameFromLocalDrive = wDriveName
End If
Exit Function
End Function
'*******************************************************************************
'** ■実行:フォルダ参照のダイアログ処理(呼び出し部分)
'*******************************************************************************
'フォルダ参照のダイアログより選択したフォルダ名を取得する
Sub フォルダ参照()
Dim GxPathName As String
GxPathName = BrowseForFolder( _
GxWinMessage, _
True, _
Application.Caption, _
GxRootPath, _
GxRootSwitch, _
GxIncludeSwitch, _
GxWinTitle)
If GxPathName <> "" Then MsgBox GxPathName
Range("A1").Select
End Sub
'****** End of Source **********************************************************
sakuraxx
すべての返信 (4)
2016年3月28日月曜日 12:22 ✅回答済み | 2 票
64ビットOfficeの場合で、APIを呼び出すときはハンドルやポインタの型を変える必要があります。（例えばLong→LongPtr）
https://msdn.microsoft.com/ja-jp/library/office/ee691831(v=office.14).aspx
上記を参考にプログラムを64ビットでも32ビットでも動くように直してみました。
少々長いプログラムになってしまいましたが・・・
'*******************************************************************************
'** フォルダ参照のダイアログ処理 **
'*******************************************************************************
Option Explicit
'フォルダ参照のダイアログの引数
Public Const GxWinMessage = "フォルダを指定して下さい" '…ウィンドウ内メッセージ
Public Const GxWinTitle = "フォルダ参照のダイアログ" '…ウィンドウタイトル
Public Const GxRootPath = "C:\" '…初回のルートフォルダ
Public Const GxRootSwitch = 3 '…3=キャンセル時に初期化する
Public Const GxIncludeSwitch = 9 '…1=フォルダ名のみ表示 1≠ファイルも表示する
'定数:ルートフォルダ(BxRootFolder)指定項目
Private Const RFzDESKTOP = &H0 '…デスクトップ(仮想)
'定数:オプションフラグ(BxOptionFlags)指定項目
Private Const OFzRETURNONLYFSDIRS = &H1 '…フォルダのみ(コンパネ,プリンタ等不可)
Private Const OFzNEWDIALOGSTYLE = &H40 '…新ダイアログ表示(v5.0)Win2000
Private Const OFzNONEWFOLDERBUTTON = &H200 '…新しいフォルダを表示しない(v6.0)WinXP
Private Const OFzBROWSEINCLUDEFILES = &H4000 '…ファイル名も表示(v4.71)
'定数:コールバック関数内(SendMessage)指定項目
Private Const SMzUSER = &H400 '…ウィンドウクラスが使用するメッセージ番号の先頭の値
Private Const SMzINITIALIZED = 1 '…ダイアログの初期化終了、BxParameterはNULL
Private Const SMzSELECTCHANGED = 2 '…選択が変更された。BxParameterは新しく選択されたフォルダのID
Private Const SMzENABLEOK = SMzUSER ; 101 '…OKボタンの有効/無効の設定
Private Const SMzSETSELECTION = SMzUSER ; 103 '…初期フォルダの設定
'定数:そのた指定項目
Private Const FNzMAXPATH = 260 '…パス名の最大バイト数
Private lxWinTitle As String
'API:マウントしてるネットワークリソース名を取得
Private Declare PtrSafe Function WNetGetConnection Lib "MPR.dll" _
Alias "WNetGetConnectionA" _
(ByVal lxLocalName As String, _
ByVal lxRemoteName As String, _
lxRemoteName2 As Long) As Long
#If VBA7 Then ' VBA7
'API:フォルダ参照のダイアログを表示する
Declare PtrSafe Function SHBrowseForFolder Lib "shell32.dll" _
Alias "SHBrowseForFolderA" (lpBrowseInfo As BROWSEINFO) As LongPtr
'API:ウィンドゥハンドルを返す
Private Declare PtrSafe Function FindWindow Lib "USER32.dll" _
Alias "FindWindowA" _
(ByVal lxClassName As Any, _
ByVal lxWindowName As Any) As LongPtr
'API:前回選択したフォルダの記憶
Private Declare PtrSafe Function SendMessage Lib "USER32.dll" _
Alias "SendMessageA" _
(ByVal lxWinHandle As LongPtr, _
ByVal lxSendMessage As Long, _
ByVal lxParameter As LongPtr, _
BxParameter As Any) As LongPtr
'API:ダイアログのタイトル変更
Private Declare PtrSafe Function SetWindowText Lib "USER32.dll" _
Alias "SetWindowTextA" _
(ByVal lxWinHandle As LongPtr, _
ByVal lxString As String) As Long
'API:フォルダのパスを取得する
Private Declare PtrSafe Function SHGetPathFromIDList Lib "shell32.dll" _
Alias "SHGetPathFromIDListA" _
(ByVal lxDigital As LongPtr, _
ByVal lxFolderPath As String) As LongPtr
'API:メモリを開放する
Private Declare PtrSafe Function SHFree Lib "shell32.dll" _
Alias "#195" (ByVal lxDigital As LongPtr) As Long
'構造体:ダイアログ(SHBrowseForFolder)選択のインターフェース
Public Type BROWSEINFO
BxWinHandle As LongPtr '…ダイアログの親ウィンドウのハンドル
BxRootFolder As Long '…ルートフォルダ
BxSelectFolder As String '…選択フォルダ名
BxWinMessage As String '…ダイアログに表示するメッセージ
BxOptionFlags As Long '…オプション
BxPointer As LongPtr '…コールバック関数へのポインタ
BxParameter As LongPtr '…コールバック関数へのパラメータ
BxImage As Long '…フォルダーアイコンのシステムイメージリスト
End Type
'*******************************************************************************
'* 2.SHBrowseForFolderのコールバック関数
'*******************************************************************************
Private Function FP_GetAddressOf(ByVal wProc As LongPtr) As LongPtr
FP_GetAddressOf = wProc
End Function
'*******************************************************************************
'* 3.SHBrowseForFolderのコールバック関数
'*******************************************************************************
Private Function FP_BrowseCallback(ByVal lxWinHandle As LongPtr, _
ByVal wMsg As Long, _
ByVal BxParameter As LongPtr, _
ByVal wData As LongPtr) As LongPtr
Select Case wMsg
'初期化時
Case SMzINITIALIZED
'初期フォルダを選択する
SendMessage lxWinHandle, SMzSETSELECTION, 1, ByVal wData
If Len(lxWinTitle) > 0 Then
Call SetWindowText(lxWinHandle, lxWinTitle) '…タイトルを表示
End If
'ツリー内の選択位置変更時
Case SMzSELECTCHANGED
'ボタンのEnabled切り換え(パス変換不可時OKボタンをグレーに)
SendMessage lxWinHandle, SMzENABLEOK, 0, ByVal SHGetPathFromIDList(BxParameter, Space$(FNzMAXPATH))
End Select
End Function
#Else ' Downlevel when using previous version of VBA7
'API:フォルダ参照のダイアログを表示する
Declare Function SHBrowseForFolder Lib "shell32.dll" _
Alias "SHBrowseForFolderA" (lpBrowseInfo As BROWSEINFO) As Long
'API:ウィンドゥハンドルを返す
Private Declare PtrSafe Function FindWindow Lib "USER32.dll" _
Alias "FindWindowA" _
(ByVal lxClassName As Any, _
ByVal lxWindowName As Any) As Long
'API:前回選択したフォルダの記憶
Private Declare PtrSafe Function SendMessage Lib "USER32.dll" _
Alias "SendMessageA" _
(ByVal lxWinHandle As Long, _
ByVal lxSendMessage As Long, _
ByVal lxParameter As Long, _
BxParameter As Any) As Long
'API:ダイアログのタイトル変更
Private Declare PtrSafe Function SetWindowText Lib "USER32.dll" _
Alias "SetWindowTextA" _
(ByVal lxWinHandle As Long, _
ByVal lxString As String) As Long
'API:フォルダのパスを取得する
Private Declare PtrSafe Function SHGetPathFromIDList Lib "shell32.dll" _
Alias "SHGetPathFromIDListA" _
(ByVal lxDigital As Long, _
ByVal lxFolderPath As String) As Long
'API:メモリを開放する
Private Declare PtrSafe Function SHFree Lib "shell32.dll" _
Alias "#195" (ByVal lxDigital As Long) As Long
'構造体:ダイアログ(SHBrowseForFolder)選択のインターフェース
Public Type BROWSEINFO
BxWinHandle As Long '…ダイアログの親ウィンドウのハンドル
BxRootFolder As Long '…ルートフォルダ
BxSelectFolder As String '…選択フォルダ名
BxWinMessage As String '…ダイアログに表示するメッセージ
BxOptionFlags As Long '…オプション
BxPointer As Long '…コールバック関数へのポインタ
BxParameter As String '…コールバック関数へのパラメータ
BxImage As Long '…フォルダーアイコンのシステムイメージリスト
End Type
'*******************************************************************************
'* 2.SHBrowseForFolderのコールバック関数
'*******************************************************************************
Private Function FP_GetAddressOf(ByVal wProc As LongPtr) As LongPtr
FP_GetAddressOf = wProc
End Function
'*******************************************************************************
'* 3.SHBrowseForFolderのコールバック関数
'*******************************************************************************
Private Function FP_BrowseCallback(ByVal lxWinHandle As LongPtr, _
ByVal wMsg As Long, _
ByVal BxParameter As LongPtr, _
ByVal wData As Long) As LongPtr
Select Case wMsg
'初期化時
Case SMzINITIALIZED
'初期フォルダを選択する
SendMessage lxWinHandle, SMzSETSELECTION, 1, ByVal wData
If Len(lxWinTitle) > 0 Then
Call SetWindowText(lxWinHandle, lxWinTitle) '…タイトルを表示
End If
'ツリー内の選択位置変更時
Case SMzSELECTCHANGED
'ボタンのEnabled切り換え(パス変換不可時OKボタンをグレーに)
SendMessage lxWinHandle, SMzENABLEOK, 0, ByVal SHGetPathFromIDList(BxParameter, Space$(FNzMAXPATH))
End Select
End Function
#End If
'*******************************************************************************
'* 1.フォルダ参照のダイアログを表示…選択したフォルダ名を返す
'*******************************************************************************
'* 引数1.Windowへのメッセージ
'* 2.ネットワークドライブシンボル(True)
'* 3.Application:ファイル名(Option)
'* 4.ルートフォルダ(Option)
'* 5.ルートフォルダのスイッチ(Option, 3=キャンセル時に初期化)
'* 6.ファイル表示のスイッチ(Option, 1=フォルダ名のみ 1≠ファイルも表示する)
'* 7.Windowへのタイトル(Option)
'* 戻値= フォルダ名(フルパスで右端\なし)
'*******************************************************************************
Public Function BrowseForFolder(sxWinMessage As String, _
blnNetGetConnection As Boolean, _
Optional sxAppName As String, _
Optional sxRootPath As String, _
Optional sxRootSwitch As Integer, _
Optional sxIncludeSwitch As Integer, _
Optional sxWinTitle As String) As String
Dim sxBROWSEINFO As BROWSEINFO
Dim sxClassName As String
Dim sxBuffer As String
Dim GxPathName As String
#If VBA7 Then ' VBA7
Dim wWinHandle As LongPtr
Dim wFoldPointer As LongPtr
#Else
Dim wWinHandle As Long
Dim wFoldPointer As Long
#End If
Static AxPrivateDir As String
'キャンセルの場合はブランクが返ります
BrowseForFolder = ""
On Error GoTo BrowseForFolder_EXIT
lxWinTitle = sxWinTitle '…ウィンドウタイトル(Option)
sxClassName = "XLMAIN" '…ウィンドウハンドルを取得
wWinHandle = FindWindow(sxClassName, sxAppName)
With sxBROWSEINFO
.BxWinHandle = wWinHandle '…ウィンドウハンドル
.BxSelectFolder = String$(FNzMAXPATH ; 1, Chr(0))
.BxRootFolder = RFzDESKTOP '…オプション指定がない場合、デスクトップを設定(仮想)
If AxPrivateDir = "" Then
AxPrivateDir = sxRootPath '…ルートフォルダ(Option)
End If
.BxWinMessage = sxWinMessage '…タイトル(ウィンドウ内)
'※1.フォルダを表示 2.新ダイアログ表示 3.新しいフォルダを表示しない 4.ファイル名も表示
If sxIncludeSwitch = 1 Then
.BxOptionFlags = OFzRETURNONLYFSDIRS Or _
OFzNEWDIALOGSTYLE Or _
OFzNONEWFOLDERBUTTON '…フォルダ名のみ表示
Else
.BxOptionFlags = OFzRETURNONLYFSDIRS Or _
OFzNEWDIALOGSTYLE Or _
OFzNONEWFOLDERBUTTON Or _
OFzBROWSEINCLUDEFILES '…ファイル名も表示
End If
.BxPointer = FP_GetAddressOf(AddressOf FP_BrowseCallback) '←★★★コンパイルエラー
If Len(AxPrivateDir) > 0 Then
.BxParameter = StrPtr(AxPrivateDir)
End If
End With
'フォルダ参照のダイアログを表示する
wFoldPointer = SHBrowseForFolder(sxBROWSEINFO)
If wFoldPointer <> 0 Then '…キャンセルの時[0]が返される
'予めNull文字をセット
sxBuffer = String$(FNzMAXPATH ; 1, Chr(0))
'SHBrowseForFolderで得られた値からフォルダのパスを取得
If SHGetPathFromIDList(wFoldPointer, sxBuffer) <> 0 Then
'Null文字以下を削除
sxBuffer = Left$(sxBuffer, InStr(1, sxBuffer, Chr(0), 1) - 1)
If ((blnNetGetConnection = True) And _
(Mid$(sxBuffer, 2, 1) = ":")) Then
GxPathName = FP_GetResourceNameFromLocalDrive(sxBuffer) & Mid$(sxBuffer, 3)
Else
GxPathName = sxBuffer
End If
BrowseForFolder = GxPathName
AxPrivateDir = GxPathName
End If
ElseIf sxRootSwitch = 2 Then
AxPrivateDir = GxRootPath '…キャンセル時:初回フォルダにする
ElseIf sxRootSwitch = 3 Then
AxPrivateDir = "" '…キャンセル時:システムのデフォルト･フォルダにする
End If
'
BrowseForFolder_EXIT:
'割り当てられたメモリを開放
If wFoldPointer <> 0 Then
Call SHFree(wFoldPointer)
End If
End Function
'*******************************************************************************
'* 4.ネットワークリソース取得
'*******************************************************************************
Private Function FP_GetResourceNameFromLocalDrive(sxDrive As String) As String
Dim wBuffer As String
Dim wDriveName As String
Dim wLen As Long
wDriveName = Left$(sxDrive, 1) & ":"
wBuffer = String$(FNzMAXPATH ; 1, vbNullChar)
WNetGetConnection wDriveName, wBuffer, FNzMAXPATH
'取得したパス名から必要な文字列だけを抽出
wLen = InStr(1, wBuffer, vbNullChar)
If wLen > 1 Then
FP_GetResourceNameFromLocalDrive = Left$(wBuffer, wLen - 1)
Else
FP_GetResourceNameFromLocalDrive = wDriveName
End If
Exit Function
End Function
'*******************************************************************************
'** ■実行:フォルダ参照のダイアログ処理(呼び出し部分)
'*******************************************************************************
'フォルダ参照のダイアログより選択したフォルダ名を取得する
Sub フォルダ参照()
Dim GxPathName As String
GxPathName = BrowseForFolder( _
GxWinMessage, _
True, _
Application.Caption, _
GxRootPath, _
GxRootSwitch, _
GxIncludeSwitch, _
GxWinTitle)
If GxPathName <> "" Then MsgBox GxPathName
Range("A1").Select
End Sub
'****** End of Source **********************************************************
以上。参考になりましたら幸いです。
2016年3月30日水曜日 9:48 ✅回答済み | 1 票
すみません。パスを覚えてませんでした。上記プログラムを修正しましたのでご確認ください。
2016年3月31日木曜日 3:42 ✅回答済み
Excel-64bit環境に運用を変更したもののコンパイルエラー等の不具合の連続で困っていた課題の一つがお陰様で解決しました。
この度は大変お世話になり感謝しております。
kenjinoteさんご教授本当にありがとうございました。
sakuraxx
2016年3月29日火曜日 7:46
kenjinoteさん早速のご回答ありがとうございます。
非力な私には「APIを呼び出すときはハンドルやポインタの型を変える必要があります」とは言うものの簡単ではありません…サンプルコードには本当に感謝しています。
コピペにて試行…フォルダ参照のダイアログが表示されました。
動作確認を行っていて気が付いたのですが、旧バージョンでは、2回目以降は前回選択したフォルダがアクティブ(展開)になっていたのですが、今回は常に初回と同じフォルダがアクティブになります。
Static AxPrivateDir As String には前回選択したパスが記録されてはいるのですが非力にて解決方法が解りません。
尚、デバッグ時に「Private Function FP_BrowseCallback()」で「VBA オートメーションエラー(強制終了)」が発生するなどにてギブアップです。
何とぞ「前回選択フォルダへ展開させる」解決方法をご教授よろしくお願いいたします。
sakuraxx