'***************************************************************************************************
' フォルダ参照のダイアログ処理(シートからの呼び出し部分)
'
' 作成者:井上治 URL:https://www.ne.jp/asahi/excel/inoue/ [Excelでお仕事!]
'***************************************************************************************************
'変更日付 Rev 変更履歴内容------------------------------------------------------------------------>
'14/04/14(1.00)新規作成
'19/10/28(1.10)Declare記述の変更(64ビット版Excel対応)
'19/12/18(1.20)カレントパス取得をWshShellに変更、Option Private Module追加
'***************************************************************************************************
Option Explicit
Option Private Module
'===================================================================================================
Public Const g_cnsTitle As String = "フォルダを指定して下さい"
Private Const g_cnsTitle2 As String = "ファイルを指定して下さい"
Private Const g_cnsFileFilter As String = _
"Excelワークブック (*.xlsx;*.xlsm;*.xls;*.xlsb),*.xlsx;*.xlsm;*.xls;*.xlsb,全てのファイル (*.*),*.*"
Private Const g_cnsFileFilter2 As String = _
"Excelブック (*.xlsx),*.xlsx,Excelマクロ有効ブック (*.xlsm),*.xlsm" & _
",Excel97-2003ブック (*.xls),*.xls,Excelバイナリブック (*.xlsb),*.xlsb,全てのファイル (*.*),*.*"
'***************************************************************************************************
' ■■■ ワークシートからの呼び出し処理 ■■■
'***************************************************************************************************
'* 処理名 :Button1_Click
'* 機能 :「フォルダの参照」ボタンクリック
'---------------------------------------------------------------------------------------------------
'* 返り値 :(なし)
'* 引数 :(なし)
'---------------------------------------------------------------------------------------------------
'* 作成日 :2014年04月14日
'* 作成者 :井上 治
'* 更新日 :2019年12月18日
'* 更新者 :井上 治
'* 機能説明:
'* 注意事項:
'***************************************************************************************************
Public Sub Button1_Click()
'-----------------------------------------------------------------------------------------------
Dim strPathname As String ' フォルダ名
' 「フォルダの参照」ダイアログよりフォルダ名の取得(引数は呼び先記述を参照)
' ※2つ目以降の引数は省略が可能です。
strPathname = modFolderPicker2.FolderDialog(g_cnsTitle, _
True, _
ThisWorkbook.Path, _
"選択")
'-----------------------------------------------------------------------------------------------
' 結果の表示(キャンセル時はブランクが返る)
If strPathname <> "" Then MsgBox strPathname
End Sub
'***************************************************************************************************
'* 処理名 :Button2_Click
'* 機能 :「フォルダの参照(UserFormから起動)」ボタンクリック
'---------------------------------------------------------------------------------------------------
'* 返り値 :(なし)
'* 引数 :(なし)
'---------------------------------------------------------------------------------------------------
'* 作成日 :2014年04月14日
'* 作成者 :井上 治
'* 更新日 :2019年12月18日
'* 更新者 :井上 治
'* 機能説明:
'* 注意事項:
'***************************************************************************************************
Public Sub Button2_Click()
'-----------------------------------------------------------------------------------------------
' UserFormを表示
UserForm1.Show
End Sub
'***************************************************************************************************
'* 処理名 :Button3_Click
'* 機能 :「ファイルを開く(旧)」ボタンクリック
'---------------------------------------------------------------------------------------------------
'* 返り値 :(なし)
'* 引数 :(なし)
'---------------------------------------------------------------------------------------------------
'* 作成日 :2014年04月14日
'* 作成者 :井上 治
'* 更新日 :2019年12月18日
'* 更新者 :井上 治
'* 機能説明:
'* 注意事項:
'***************************************************************************************************
Public Sub Button3_Click()
'-----------------------------------------------------------------------------------------------
Dim strFilename As String ' ファイル名
Dim vntFilename As Variant ' ファイル名(受け取り)
' カレントフォルダ変更(自ブックフォルダ)
Call modFolderPicker2.ChangeCurrentPath(ThisWorkbook.Path)
' ファイルを開くダイアログ表示(旧)
vntFilename = Application.GetOpenFilename(g_cnsFileFilter, , g_cnsTitle2)
' カレントフォルダ復旧
Call modFolderPicker2.ResetCurrentPath
' キャンセルは終了
If VarType(vntFilename) = vbBoolean Then Exit Sub
strFilename = vntFilename
'-----------------------------------------------------------------------------------------------
' 結果の表示
MsgBox strFilename
End Sub
'***************************************************************************************************
'* 処理名 :Button4_Click
'* 機能 :「ファイルを開く(新)」ボタンクリック
'---------------------------------------------------------------------------------------------------
'* 返り値 :(なし)
'* 引数 :(なし)
'---------------------------------------------------------------------------------------------------
'* 作成日 :2014年04月14日
'* 作成者 :井上 治
'* 更新日 :2019年12月18日
'* 更新者 :井上 治
'* 機能説明:
'* 注意事項:
'***************************************************************************************************
Public Sub Button4_Click()
'-----------------------------------------------------------------------------------------------
Dim strFilename As String ' ファイル名
Dim tblFilter(2, 1) As String ' ファイルフィルタ
' ファイルフィルタの設定
tblFilter(0, 0) = "Excelワークブック"
tblFilter(0, 1) = "*.xlsx;*.xlsm;*.xls;*.xlsb"
tblFilter(1, 0) = "Excelテンプレート"
tblFilter(1, 1) = "*.xlt;*.xltx;*.xltm"
tblFilter(2, 0) = "全てのファイル"
tblFilter(2, 1) = "*.*"
' 「ファイルを開く」ダイアログよりファイル名の取得(引数は呼び先記述を参照)
' ※2つ目以降の引数は省略が可能です。
strFilename = modFolderPicker2.OpenDialog(g_cnsTitle2, _
tblFilter, _
True, _
ThisWorkbook.Path, _
"選択")
'-----------------------------------------------------------------------------------------------
' 結果の表示(キャンセル時はブランクが返る)
If strFilename <> "" Then MsgBox strFilename
End Sub
'***************************************************************************************************
'* 処理名 :Button5_Click
'* 機能 :「名前を付けて保存(旧)」ボタンクリック
'---------------------------------------------------------------------------------------------------
'* 返り値 :(なし)
'* 引数 :(なし)
'---------------------------------------------------------------------------------------------------
'* 作成日 :2014年04月14日
'* 作成者 :井上 治
'* 更新日 :2019年12月18日
'* 更新者 :井上 治
'* 機能説明:
'* 注意事項:
'***************************************************************************************************
Public Sub Button5_Click()
'-----------------------------------------------------------------------------------------------
Const cnsFilename As String = "SAMPLE.xlsx"
Dim strFilename As String ' ファイル名
Dim vntFilename As Variant ' ファイル名(受け取り)
' カレントフォルダ変更(自ブックフォルダ)
Call modFolderPicker2.ChangeCurrentPath(ThisWorkbook.Path)
' 名前を付けて保存ダイアログ表示(旧)
vntFilename = Application.GetSaveAsFilename(cnsFilename, g_cnsFileFilter2, , g_cnsTitle2)
' カレントフォルダ復旧
Call modFolderPicker2.ResetCurrentPath
' キャンセルは終了
If VarType(vntFilename) = vbBoolean Then Exit Sub
strFilename = vntFilename
'-----------------------------------------------------------------------------------------------
' 結果の表示
MsgBox strFilename
End Sub
'***************************************************************************************************
'* 処理名 :Button6_Click
'* 機能 :「名前を付けて保存(新)」ボタンクリック
'---------------------------------------------------------------------------------------------------
'* 返り値 :(なし)
'* 引数 :(なし)
'---------------------------------------------------------------------------------------------------
'* 作成日 :2014年04月14日
'* 作成者 :井上 治
'* 更新日 :2019年12月18日
'* 更新者 :井上 治
'* 機能説明:
'* 注意事項:
'***************************************************************************************************
Sub Button6_Click()
'-----------------------------------------------------------------------------------------------
Const cnsFilename As String = "SAMPLE.xlsx"
Dim strFilename As String ' ファイル名
' 「名前を付けて保存」ダイアログよりファイル名の取得(引数は呼び先記述を参照)
' ※2つ目以降の引数は省略が可能です。
strFilename = modFolderPicker2.SaveDialog(g_cnsTitle2, _
cnsFilename, _
True, _
ThisWorkbook.Path, _
"登録")
'-----------------------------------------------------------------------------------------------
' 結果の表示(キャンセル時はブランクが返る)
If strFilename <> "" Then MsgBox strFilename
End Sub
'***************************************************************************************************
'* 処理名 :Button7_Click
'* 機能 :「カレントフォルダ表示」ボタンクリック
'---------------------------------------------------------------------------------------------------
'* 返り値 :(なし)
'* 引数 :(なし)
'---------------------------------------------------------------------------------------------------
'* 作成日 :2019年12月18日
'* 作成者 :井上 治
'* 更新日 :2019年12月18日
'* 更新者 :井上 治
'* 機能説明:
'* 注意事項:
'***************************************************************************************************
Sub Button7_Click()
'-----------------------------------------------------------------------------------------------
' カレントフォルダを取得して表示
MsgBox modFolderPicker2.GetCurrentPath
End Sub
'----------------------------------------<< End of Source >>----------------------------------------
プロシージャ | 説明 |
---|---|
Button1_Click | 「フォルダの参照」ボタンのクリック処理です。 デフォルトではカレントフォルダは移動しないようになっており、処理で他フォルダを選択しても元に戻ります。 起動時の初期フォルダは本ブックのフォルダになります。 繰り返し呼び出すケースで、前回選択したフォルダを次回の初期フォルダにしたい場合は「modFolderPicker2.FolderDialog」を呼び出す際の引数に 第5引数を「True」で追加して下さい。 |
Button2_Click | 「フォルダの参照(UserFormから起動)」ボタンのクリック処理です。 内容的には「Button1_Click」と同じですが、ユーザーフォーム上に「フォルダの参照」ボタンがあり、 参照結果がユーザーフォーム上のテキストボックスに表示されるというものです。 |
Button3_Click | 「ファイルを開く(旧)」ボタンのクリック処理です。 従来からある「GetOpenFilename」メソッドでの「ファイルを開く」ダイアログの表示です。 「Application.FileDialog」は「InitialFileName」プロパティで フォルダのフルパスを受け取ることで初期表示フォルダが指定できますが、「GetOpenFilename」メソッドの方は カレントフォルダを移動させて初期表示フォルダを指定するので、その処理と後で戻す処理を前後に挟んでいます。 |
Button4_Click | 「ファイルを開く(新)」ボタンのクリック処理です。 「Application.FileDialog」で「GetOpenFilename」メソッドと同様のことを行なっています。 「ファイルを開く」ダイアログとしてはほとんど見かけは変わりません。 |
Button5_Click | 「名前を付けて保存(旧)」ボタンのクリック処理です。 従来からある「GetSaveAsFilename」メソッドでの「名前を付けて保存」ダイアログの表示です。 最近のバージョンから「初期ファイル名」を指定してもダイアログに表示されないという事象があって、 これは指定したファイル名の拡張子と先頭で指定したファイルフィルタが合っていないと表示されないということが報告されていました。 このため、このサンプルでは「GetOpenFilename」メソッドとはファイルフィルタを区別して、 単一拡張子のものを用意して対応しています。 |
Button6_Click | 「名前を付けて保存(新)」ボタンのクリック処理です。 「Application.FileDialog」で「GetSaveAsFilename」メソッドと同様のことを行なっています。 仕様上で異なるのはファイルフィルタが指定できないことです。 「初期ファイル名」を指定すればその拡張子が初期ファイルフィルタとして表示されます。 「初期ファイル名」は「InitialFileName」プロパティで指定するのですが、これは同時に初期フォルダの指定にもなるので 呼び出された「modFolderPicker2.SaveDialog」の方でフルパス編集を行なっています。 |
Button7_Click | 「カレントフォルダ表示」ボタンのクリック処理です。 これはカレントフォルダが移動したかどうかを確認するための表示のみの処理です。 |
項目 | 説明 |
---|---|
①タイトル | 表示ダイアログのタイトルです |
②UNCパス変換 | (OPTION)ネットワークドライブから指定された時に、該当のネットワークリソース名に変換する場合は、True、変換せずそのままにする場合はFalseを指定します。 |
③ルートフォルダ | (OPTION)選択状態にするフォルダがある場合はここで指定します。ブランクの場合は直前のカレントフォルダのままになります。 |
④ボタン表示名 | (OPTION)デフォルトで「OK」となるボタンの表示名を指定することができます。 |
⑤ルートフォルダ固定スイッチ | (OPTION)繰り返し呼び出すような処理で、前回選択したフォルダを初期表示させたい場合は「True」をセットします。 デフォルトは「False」なので、毎回設定した初期フォルダに戻ります。 |
'***************************************************************************************************
' ファイル、フォルダ参照のダイアログ処理(Application.FileDialog) modFolderPicker2(Module)
'
' 作成者:井上治 URL:https://www.ne.jp/asahi/excel/inoue/ [Excelでお仕事!]
'***************************************************************************************************
' [参照設定]
' ・Microsoft Scripting Runtime
' ・Windows Script Host Object Model
'***************************************************************************************************
'変更日付 Rev 変更履歴内容------------------------------------------------------------------------>
'14/04/14(1.00)新規作成
'19/10/28(1.10)Declare記述の変更(64ビット版Excel対応)
'19/12/18(1.20)カレントパス取得・復旧を追加、Option Private Module追加、他記述整理
'***************************************************************************************************
Option Explicit
Option Private Module
'===================================================================================================
Private Const MAX_PATH As Long = 260
Private Const g_cnsYen As String = "\"
Private Const g_cnsCol As String = ":"
#If VBA7 Then
' ■ローカルドライブからマウントされているネットワークリソース名を取得する
Private Declare PtrSafe Function WNetGetConnection Lib "MPR.dll" _
Alias "WNetGetConnectionA" _
(ByVal lpszLocalName As String, _
ByVal lpszRemoteName As String, _
cbRemoteName As Long) As Long
#Else
' ■ローカルドライブからマウントされているネットワークリソース名を取得する
Private Declare Function WNetGetConnection Lib "MPR.dll" _
Alias "WNetGetConnectionA" _
(ByVal lpszLocalName As String, _
ByVal lpszRemoteName As String, _
cbRemoteName As Long) As Long
#End If
'---------------------------------------------------------------------------------------------------
' 設定退避変数
Private g_strCurrPathSV As String ' 処理前のカレントフォルダ
Private g_strPrevPathSV As String ' 直前選択フォルダ
'***************************************************************************************************
' ■■■ 公開プロシージャ ■■■
'***************************************************************************************************
'* 処理名 :FolderDialog
'* 機能 :「フォルダの参照」ダイアログ表示
'---------------------------------------------------------------------------------------------------
'* 返り値 :フォルダ名(フルパスで右\なし、未選択時はブランク)(String)
'* 引数 :Arg1 = ウィンドウタイトル(String)
'* Arg2 = ネットワークドライブ→ネットワークリソースの置換区分(Boolean,Option)
'* Arg3 = ルートフォルダ(String,Option)
'* Arg4 = ボタン表示名(String,Option)
'* Arg5 = ルートフォルダ固定スイッチ(Boolean,Option)
'* (True=固定する, False=元のカレントフォルダに戻す)
'---------------------------------------------------------------------------------------------------
'* 作成日 :2014年04月14日
'* 作成者 :井上 治
'* 更新日 :2019年12月18日
'* 更新者 :井上 治
'* 機能説明:「フォルダの参照」ダイアログを表示させ、選択したフォルダ名を返す
'* 注意事項:
'***************************************************************************************************
Public Function FolderDialog(ByVal strTitle As String, _
Optional ByVal blnNetGetConnection As Boolean = False, _
Optional ByVal strRootPath As String = "", _
Optional ByVal strButtonName As String = "OK", _
Optional ByVal swFixRootPath As Boolean = False) As String
'-----------------------------------------------------------------------------------------------
FolderDialog = ""
' ファイルダイアログの表示(FolderPicker)
With Application.FileDialog(msoFileDialogFolderPicker)
.Title = strTitle
' ボタン名の設定
If Len(strButtonName) > 0 Then
.ButtonName = strButtonName
End If
.InitialFileName = FP_EditInitFileNm(swFixRootPath, strRootPath)
.InitialView = msoFileDialogViewDetails
.AllowMultiSelect = False
' ダイアログの表示
If .Show Then
FolderDialog = FP_GetUcnPath(.SelectedItems(1), blnNetGetConnection, swFixRootPath)
End If
End With
' ルートフォルダ固定スイッチがFalseならカレントフォルダ復旧
If Not swFixRootPath Then Call ResetCurrentPath
End Function
'***************************************************************************************************
'* 処理名 :OpenDialog
'* 機能 :「ファイルを開く」ダイアログ表示
'---------------------------------------------------------------------------------------------------
'* 返り値 :ファイル名(フルパス、未選択時はブランク)(String)
'* 引数 :Arg1 = ウィンドウタイトル(String)
'* Arg2 = ファイルフィルタ(2次配列String,Option)
'* Arg3 = ネットワークドライブ→ネットワークリソースの置換区分(Boolean,Option)
'* Arg4 = ルートフォルダ(String,Option)
'* Arg5 = ボタン表示名(String,Option)
'* Arg6 = ルートフォルダ固定スイッチ(Boolean,Option)
'* (True=固定する, False=元のカレントフォルダに戻す)
'---------------------------------------------------------------------------------------------------
'* 作成日 :2014年04月14日
'* 作成者 :井上 治
'* 更新日 :2019年12月18日
'* 更新者 :井上 治
'* 機能説明:「ファイルを開く」ダイアログを表示させ、選択したファイル名を返す
'* 注意事項:単一ファイル専用
'***************************************************************************************************
Public Function OpenDialog(ByVal strTitle As String, _
Optional ByRef tblFilter As Variant, _
Optional ByVal blnNetGetConnection As Boolean = False, _
Optional ByVal strRootPath As String = "", _
Optional ByVal strButtonName As String = "開く", _
Optional ByVal swFixRootPath As Boolean = False) As String
'-----------------------------------------------------------------------------------------------
Dim intIx As Integer ' テーブルINDEX
OpenDialog = ""
' ファイルダイアログの表示(FileDialogOpen)
With Application.FileDialog(msoFileDialogOpen)
.Title = strTitle
' ボタン名の設定
If Len(strButtonName) > 0 Then
.ButtonName = strButtonName
End If
' ファイルフィルタの設定
If IsArray(tblFilter) Then
With .Filters
.Clear
intIx = 0
Do While intIx <= UBound(tblFilter)
.Add tblFilter(intIx, 0), tblFilter(intIx, 1), intIx + 1
intIx = intIx + 1
Loop
End With
End If
.InitialFileName = FP_EditInitFileNm(swFixRootPath, strRootPath)
.InitialView = msoFileDialogViewDetails
.AllowMultiSelect = False
' ダイアログの表示
If .Show Then
OpenDialog = FP_GetUcnPath(.SelectedItems(1), blnNetGetConnection, swFixRootPath)
End If
End With
' ルートフォルダ固定スイッチがFalseならカレントフォルダ復旧
If Not swFixRootPath Then Call ResetCurrentPath
End Function
'***************************************************************************************************
'* 処理名 :SaveDialog
'* 機能 :「名前を付けて保存」ダイアログ表示
'---------------------------------------------------------------------------------------------------
'* 返り値 :ファイル名(フルパス、未選択時はブランク)(String)
'* 引数 :Arg1 = ウィンドウタイトル(String)
'* Arg2 = デフォルトファイル名(String,Option)
'* Arg3 = ネットワークドライブ→ネットワークリソースの置換区分(Boolean,Option)
'* Arg4 = ルートフォルダ(String,Option)
'* Arg5 = ボタン表示名(String,Option)
'* Arg6 = ルートフォルダ固定スイッチ(Boolean,Option)
'* (True=固定する, False=元のカレントフォルダに戻す)
'---------------------------------------------------------------------------------------------------
'* 作成日 :2014年04月14日
'* 作成者 :井上 治
'* 更新日 :2019年12月18日
'* 更新者 :井上 治
'* 機能説明:「名前を付けて保存」ダイアログを表示させ、選択したファイル名を返す
'* 注意事項:
'***************************************************************************************************
Public Function SaveDialog(ByVal strTitle As String, _
Optional ByVal strInitFilename As String = "", _
Optional ByVal blnNetGetConnection As Boolean = False, _
Optional ByVal strRootPath As String = "", _
Optional ByVal strButtonName As String = "保存", _
Optional ByVal swFixRootPath As Boolean = False) As String
'-----------------------------------------------------------------------------------------------
SaveDialog = ""
' ファイルダイアログの表示(FileDialogSaveAs)
' この方法ではファイルフィルタの指定ができません
With Application.FileDialog(msoFileDialogSaveAs)
.Title = strTitle
' デフォルトファイル名
.InitialFileName = FP_EditInitFileNm(swFixRootPath, strRootPath, strInitFilename)
' ボタン名の設定
If Len(strButtonName) > 0 Then
.ButtonName = strButtonName
End If
.InitialView = msoFileDialogViewDetails
.AllowMultiSelect = False
' ダイアログの表示
If .Show Then
SaveDialog = FP_GetUcnPath(.SelectedItems(1), blnNetGetConnection, swFixRootPath)
End If
End With
' ルートフォルダ固定スイッチがFalseならカレントフォルダ復旧
If Not swFixRootPath Then Call ResetCurrentPath
End Function
'***************************************************************************************************
'* 処理名 :GetResourceNameFromLocalDrive
'* 機能 :ネットワークドライブシンボルからネットワークリソースを取得
'---------------------------------------------------------------------------------------------------
'* 返り値 :パス名(String)
'* 引数 :Arg1 = パス名(String)
'---------------------------------------------------------------------------------------------------
'* 作成日 :2014年04月14日
'* 作成者 :井上 治
'* 更新日 :2019年12月18日
'* 更新者 :井上 治
'* 機能説明:
'* 注意事項:
'***************************************************************************************************
Public Function GetResourceNameFromLocalDrive(strDrv As String) As String
'-----------------------------------------------------------------------------------------------
Dim strBuf As String ' 文字列バッファ
Dim strDriveName As String ' ドライブシンボル
Dim lngLen As Long ' 文字列長
strDriveName = Left$(strDrv, 1) & g_cnsCol
On Error GoTo GetResourceNameFromLocalDrive_ERROR
strBuf = String$(MAX_PATH + 1, vbNullChar)
WNetGetConnection strDriveName, strBuf, MAX_PATH
'取得したパス名から必要な文字列だけを抽出
lngLen = InStr(1, strBuf, vbNullChar)
If lngLen > 1 Then
GetResourceNameFromLocalDrive = Left$(strBuf, lngLen - 1)
Else
GetResourceNameFromLocalDrive = strDriveName
End If
GoTo GetResourceNameFromLocalDrive_EXIT
'===================================================================================================
' エラー処理
GetResourceNameFromLocalDrive_ERROR:
GetResourceNameFromLocalDrive = strDriveName
'===================================================================================================
' 終了
GetResourceNameFromLocalDrive_EXIT:
On Error GoTo 0
End Function
'***************************************************************************************************
'* 処理名 :ChangeCurrentPath
'* 機能 :カレントフォルダ変更
'---------------------------------------------------------------------------------------------------
'* 返り値 :(なし)
'* 引数 :Arg1 = フォルダ名(String)
'---------------------------------------------------------------------------------------------------
'* 作成日 :2019年12月18日
'* 作成者 :井上 治
'* 更新日 :2019年12月18日
'* 更新者 :井上 治
'* 機能説明:
'* 注意事項:
'***************************************************************************************************
Public Sub ChangeCurrentPath(strPathname As String)
'-----------------------------------------------------------------------------------------------
Dim objShell As WshShell ' WshShell
' フォルダの指定があるか
If strPathname <> "" Then
' 直前のカレントフォルダ退避
Set objShell = New WshShell
' カレントフォルダが指定フォルダと異なるか
If objShell.CurrentDirectory <> strPathname Then
g_strCurrPathSV = objShell.CurrentDirectory
' カレントフォルダを変更
objShell.CurrentDirectory = strPathname
End If
Set objShell = Nothing
End If
End Sub
'***************************************************************************************************
'* 処理名 :ResetCurrentPath
'* 機能 :カレントフォルダ復旧
'---------------------------------------------------------------------------------------------------
'* 返り値 :(なし)
'* 引数 :(なし)
'---------------------------------------------------------------------------------------------------
'* 作成日 :2019年12月18日
'* 作成者 :井上 治
'* 更新日 :2019年12月18日
'* 更新者 :井上 治
'* 機能説明:
'* 注意事項:
'***************************************************************************************************
Public Sub ResetCurrentPath()
'-----------------------------------------------------------------------------------------------
Dim objShell As WshShell ' WshShell
' 直前のカレントフォルダが退避されているか
If g_strCurrPathSV <> "" Then
Set objShell = New WshShell
' カレントフォルダを変更
objShell.CurrentDirectory = g_strCurrPathSV
Set objShell = Nothing
End If
End Sub
'***************************************************************************************************
'* 処理名 :GetCurrentPath
'* 機能 :カレントフォルダ取得
'---------------------------------------------------------------------------------------------------
'* 返り値 :パス名(String)
'* 引数 :(なし)
'---------------------------------------------------------------------------------------------------
'* 作成日 :2019年12月18日
'* 作成者 :井上 治
'* 更新日 :2019年12月18日
'* 更新者 :井上 治
'* 機能説明:
'* 注意事項:
'***************************************************************************************************
Public Function GetCurrentPath() As String
'-----------------------------------------------------------------------------------------------
Dim objShell As WshShell ' WshShell
Set objShell = New WshShell
' カレントフォルダを取得
GetCurrentPath = objShell.CurrentDirectory
Set objShell = Nothing
End Function
'***************************************************************************************************
' ■■■ サブプロシージャ(Private) ■■■
'***************************************************************************************************
'* 処理名 :FP_EditInitFileNm
'* 機能 :デフォルトファイル名の編集
'---------------------------------------------------------------------------------------------------
'* 返り値 :デフォルトファイル名(String)
'* 引数 :Arg1 = ルートフォルダ固定スイッチ(Boolean)
'* Arg2 = ルートフォルダ(String)
'* Arg3 = デフォルトファイル名(String,Option)
'---------------------------------------------------------------------------------------------------
'* 作成日 :2019年12月18日
'* 作成者 :井上 治
'* 更新日 :2019年12月18日
'* 更新者 :井上 治
'* 機能説明:
'* 注意事項:
'***************************************************************************************************
Private Function FP_EditInitFileNm(ByVal swFixRootPath As Boolean, _
ByVal strRootPath As String, _
Optional ByVal strInitFilename As String = "") As String
'-----------------------------------------------------------------------------------------------
Dim objFso As FileSystemObject ' FileSystemObject
Dim strInitFilename2 As String ' デフォルトファイル名(フルパス)
' カレントフォルダ退避が初回の時は退避する
If g_strCurrPathSV = "" Then
' カレントフォルダ退避
Call GP_SaveCurrentPath
End If
' ルートフォルダ指定無しの時はカレントフォルダを適用
If strRootPath = "" Then strRootPath = g_strCurrPathSV
'-----------------------------------------------------------------------------------------------
' ルートフォルダ固定の場合は前回のフォルダをルートフォルダとする
If swFixRootPath And g_strPrevPathSV <> "" Then
strRootPath = g_strPrevPathSV
End If
' ファイル名があるか
If strInitFilename <> "" Then
Set objFso = New FileSystemObject
strInitFilename2 = objFso.BuildPath(strRootPath, strInitFilename)
Set objFso = Nothing
Else
strInitFilename2 = FP_ApendYenSign(strRootPath)
End If
' ルートフォルダ固定でなければ現フォルダを退避
If Not swFixRootPath Then g_strPrevPathSV = strRootPath
FP_EditInitFileNm = strInitFilename2
End Function
'***************************************************************************************************
'* 処理名 :GP_SaveCurrentPath
'* 機能 :カレントフォルダ退避
'---------------------------------------------------------------------------------------------------
'* 返り値 :(なし)
'* 引数 :(なし)
'---------------------------------------------------------------------------------------------------
'* 作成日 :2019年12月18日
'* 作成者 :井上 治
'* 更新日 :2019年12月18日
'* 更新者 :井上 治
'* 機能説明:
'* 注意事項:
'***************************************************************************************************
Private Sub GP_SaveCurrentPath()
'-----------------------------------------------------------------------------------------------
Dim objShell As WshShell ' WshShell
Set objShell = New WshShell
g_strCurrPathSV = objShell.CurrentDirectory
Set objShell = Nothing
End Sub
'***************************************************************************************************
'* 処理名 :FP_GetUcnPath
'* 機能 :ローカルドライブからネットワークリソース名を取得
'---------------------------------------------------------------------------------------------------
'* 返り値 :UCNパス名(String)
'* 引数 :Arg1 = 選択フォルダ名(String)
'* Arg2 = ネットワークドライブ→ネットワークリソースの置換区分(Boolean)
'* Arg3 = ルートフォルダ固定スイッチ(Boolean)
'---------------------------------------------------------------------------------------------------
'* 作成日 :2019年12月18日
'* 作成者 :井上 治
'* 更新日 :2019年12月18日
'* 更新者 :井上 治
'* 機能説明:ローカルドライブ(ネットワークドライブ)からネットワークリソース名を取得する
'* 注意事項:
'***************************************************************************************************
Private Function FP_GetUcnPath(ByVal strPathname As String, _
ByVal blnNetGetConnection As Boolean, _
ByVal swFixRootPath As Boolean) As String
'-----------------------------------------------------------------------------------------------
Dim objFso As FileSystemObject ' FileSystemObject
Dim strPathname2 As String ' フォルダ名(Work)
' ルートフォルダ固定の場合は選択フォルダ名を退避
If swFixRootPath Then
strPathname2 = strPathname
Set objFso = New FileSystemObject
' フルパス名の場合はフォルダ部分のみに変更
If Not objFso.FolderExists(strPathname2) Then
strPathname2 = objFso.GetParentFolderName(strPathname2)
End If
Set objFso = Nothing
g_strPrevPathSV = strPathname2
End If
' ローカルドライブ(ネットワークドライブ)から
' マウントされているネットワークリソース名を取得する
If (blnNetGetConnection And (Mid$(strPathname, 2, 1) = g_cnsCol)) Then
strPathname2 = GetResourceNameFromLocalDrive(strPathname)
If Left(strPathname2, 2) = g_cnsYen & g_cnsYen Then
strPathname = strPathname2 & Mid(strPathname, 3)
End If
End If
FP_GetUcnPath = strPathname
End Function
'***************************************************************************************************
'* 処理名 :FP_ApendYenSign
'* 機能 :右\付加
'---------------------------------------------------------------------------------------------------
'* 返り値 :編集後文字列(String)
'* 引数 :Arg1 = 編集前文字列(String)
'---------------------------------------------------------------------------------------------------
'* 作成日 :2019年12月18日
'* 作成者 :井上 治
'* 更新日 :2019年12月18日
'* 更新者 :井上 治
'* 機能説明:
'* 注意事項:
'***************************************************************************************************
Private Function FP_ApendYenSign(ByVal strInText As String) As String
'-----------------------------------------------------------------------------------------------
If Right(strInText, 1) = g_cnsYen Then
FP_ApendYenSign = strInText
Else
FP_ApendYenSign = strInText & g_cnsYen
End If
End Function
'----------------------------------------<< End of Source >>----------------------------------------
![]() |
←MsoFolderPicker2.zip (49KB) |
![]() |
←modSHBrowseForFolder.zip (46KB) |