| ■136 / 親記事) |
Access：フォルダ参照ダイアログの記述
|
□投稿者/ 管理者 投稿数：少(2回)-(2018/04/25(Wed) 15:52:43)
| [標準モジュール]
'------------------------------------------------------------
' 関数名：GetBrowseFolder
'フォルダ参照ダイアログを表示し選択されたフォルダ名を返します。
'引数 strMsg : ダイアログに表示するメッセージ(例:"フォルダを指定して下さい")
'[キャンセル]ボタンやESCキーが押された場合は長さゼロ("")の文字列を返します。
'------------------------------------------------------------
'Option Explicit
'Option Compare Database
Type BROWSEINFO
hWndOwner 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
Declare Function SHBrowseForFolder Lib "SHELL32" (lpbi As BROWSEINFO) As Long
Declare Function SHGetPathFromIDList Lib "SHELL32" _
(ByVal pIDL As Long, ByVal pszPath As String) As Long
Public Function GetBrowseFolder(strMsg As String) As String
'フォルダ参照ダイアログを表示し選択されたフォルダ名を返します。
'引数 strMsg : ダイアログに表示するメッセージ(例:"フォルダを指定して下さい")
'[キャンセル]ボタンやESCキーが押された場合は長さゼロ("")の文字列を返します。
Dim udtBrowseInfo As BROWSEINFO
Const cMaxPathLen = 256
Dim strBuffer As String * cMaxPathLen
Dim strPathBuffer As String * cMaxPathLen
Dim strRetPath As String
Dim lngRet As Long
'BROWSEINFO構造体を定義します
With udtBrowseInfo
.hWndOwner = Application.hWndAccessApp
.pidlRoot = 0
.pszDisplayName = strBuffer
.lpszTitle = strMsg & vbNullChar
.ulFlags = 1
.lpfn = 0
.lParam = 0
.iImage = 0
End With
GetBrowseFolder = "" '返り値の初期設定を行います
lngRet = SHBrowseForFolder(udtBrowseInfo) 'フォルダ参照ダイアログを表示します
If lngRet <> 0 Then 'API関数の返り値をチェックします
If SHGetPathFromIDList(lngRet, strPathBuffer) <> 0 Then
'返り値にフォルダ名をセットします
GetBrowseFolder = Left(strPathBuffer, InStr(strPathBuffer, vbNullChar) - 1)
End If
End If
End Function
'------------------------------------------------------------
' 関数名：GetTransfer
'フォルダ参照ダイアログを表示し選択されたフォルダ名を返します。
'------------------------------------------------------------
Function GetTransfer()
Dim strFolder As String
'フォルダの参照ダイアログを表示します
strFolder = GetBrowseFolder("エクスポートを行うフォルダを指定して下さい。")
If Len(strFolder) > 0 Then
If Right$(strFolder, 1) <> "\" Then 'フォルダが選択された場合
strFolder = strFolder & "\"
End If
GetTransfer = strFolder
Else
MsgBox "キャンセルされました。", , "管理者"
End 'キャンセルされたときはアクションなし
End If
End Function
[フォーム内のコード]
Dim sfina As String
'ファイル選択ダイアログ
sfina = GetTransfer & "〜.txt"
で、sfinaにフルパスのファイル名が入る
|
|
で表示されます。
で表示されます。
Microsoft Officeのプロダクトキーを確認・削除(0)