[VBA]ファイル保存ダイアログの表示

[はじめに]
・最近、Excelマクロを使う機会が増えたので、
　備忘録としてサンプルを掲載します。
　VBAの関数が使いにくいので、クラスモジュールにまとめてみました。
　.NETのSaveFileDialogクラスを真似して実装しているので、
　.NET開発者にとっては、お馴染みのインタフェースで使いやすいかと思います。

[ソース]

コードのコピー

''' <summary> ''' クラスモジュール名：SaveFileDialog ''' ファイル保存ダイアログを制御するクラス ''' </summary> ''' <remarks></remarks> Option Explicit 'FileSystemPbject Private objFs As Object 'タイトル Public Title As String '初期ディレクトリ Public InitialDirectory As String '初期ファイル名 Public InitialFileName As String '[ファイルの種類]の選択肢 Public Filter As String '[ファイルの種類]の選択値 Public FilterIndex As Integer '選択したファイル名 Private m_FileName As String ''' <summary> ''' Initializeイベント（コンストラクタ） ''' </summary> ''' <remarks></remarks> Private Sub Class_Initialize()     Set objFs = CreateObject("Scripting.FileSystemObject")          Call Clear End Sub ''' <summary> ''' Terminateイベント（デストラクタ） ''' </summary> ''' <remarks></remarks> Private Sub Class_Terminate()     Set objFs = Nothing End Sub ''' <summary> ''' 初期化 ''' </summary> ''' <remarks></remarks> Public Sub Clear()          Me.InitialDirectory = Application.ThisWorkbook.path     Me.InitialFileName = ""     Me.Filter = "すべてのファイル(*.*),*.*"     Me.FilterIndex = 1     Me.Title = ""     m_FileName = "ファイル名を指定してください" End Sub ''' <summary> ''' フィルターを設定 ''' </summary> ''' <param name="filterArray">フィルター文字列</param> ''' <remarks></remarks> Public Sub SetFilterList(ParamArray filterArray() As Variant)     Filter = Join(filterArray, ",") End Sub ''' <summary> ''' 選択したファイル名を取得する。 ''' </summary> ''' <remarks></remarks> Public Function GetSelectedFileName() As String     GetSelectedFileName = m_FileName End Function ''' <summary> ''' パスとファイル名を結合する。 ''' </summary> ''' <param name="path">パス</param> ''' <param name="fileName">ファイル名</param> ''' <returns>結合後のフルパス</returns> ''' <remarks></remarks> Private Function BuildPath( _     ByVal path As String, _     ByVal fileName As String) As String          BuildPath = objFs.BuildPath(path, fileName) End Function ''' <summary> ''' ファイル保存ダイアログを開く ''' </summary> ''' <returns>vbOK：ファイル選択、vbCancel：キャンセル</returns> ''' <remarks></remarks> Public Function ShowDialog() As VbMsgBoxResult     Dim resDlg As Variant     Dim initDir As String          '初期ディレクトリの存在チェック     ' 存在しない場合は、Excelブックの配置ディレクトリに置き換える。     If objFs.FolderExists(Me.InitialDirectory) = False Then         Me.InitialDirectory = ThisWorkbook.path     End If          'ファイル選択ダイアログを開く     resDlg = _          Application.GetSaveAsFilename( _               InitialFileName:= _                 BuildPath( _                     Me.InitialDirectory, _                     Me.InitialFileName), _               FileFilter:=Me.Filter, _               FilterIndex:=Me.FilterIndex, _               Title:=Me.Title _              )     If resDlg = False Then         'キャンセルした場合         m_FileName = ""                  ShowDialog = vbCancel         Exit Function     End If          'ファイル選択した場合     m_FileName = resDlg          ShowDialog = vbOK     Exit Function      End Function

VBA]ファイル保存ダイアログ

[ソース]

コードのコピー

Private Sub CommandButton1_Click()     Dim sfd As New SaveFileDialog          With sfd         .InitialDirectory = "C:\Hoge"         .InitialFileName = "abc.csv"         .Title = "タイトル"         .FilterIndex = 1         .SetFilterList "CSV(*.csv),*.csv", "すべてのファイル(*.*),*.*"              End With          'ファイル保存ダイアログを開く。     If sfd.ShowDialog() = vbOK Then         MsgBox sfd.GetSelectedFileName()     Else         MsgBox "キャンセルしました"     End If          '終了処理     Set sfd = Nothing End Sub

VBA]使用例

タグ：ファイル保存ダイアログ VBA

[VBA]ファイル選択ダイアログの表示

[はじめに]
・最近、Excelマクロを使う機会が増えたので、
　備忘録としてサンプルを掲載します。
　VBAの関数が使いにくいので、クラスモジュールにまとめてみました。
　.NETのOpenFileDialogクラスを真似して実装しているので、
　.NET開発者にとっては、お馴染みのインタフェースで使いやすいかと思います。

[ソース]

コードのコピー

''' <summary> ''' クラスモジュール名：OpenFileDialog ''' ファイル選択ダイアログを制御するクラス ''' </summary> ''' <remarks></remarks> Option Explicit 'FileSystemPbject Private objFs As Object 'WScript.Shell Private objWs As Object 'タイトル Public Title As String '初期ディレクトリ Public InitialDirectory As String '[ファイルの種類]の選択肢 Public Filter As String '[ファイルの種類]の選択値 Public FilterIndex As Integer '複数選択の可否 Public MultiSelect As Boolean '選択したファイル名 Private m_FileNames() As String ''' <summary> ''' Initializeイベント（コンストラクタ） ''' </summary> ''' <remarks></remarks> Private Sub Class_Initialize()     Set objFs = CreateObject("Scripting.FileSystemObject")     Set objWs = CreateObject("WScript.Shell")          Call Clear End Sub ''' <summary> ''' Terminateイベント（デストラクタ） ''' </summary> ''' <remarks></remarks> Private Sub Class_Terminate()     Set objFs = Nothing     Set objWs = Nothing End Sub ''' <summary> ''' 初期化 ''' </summary> ''' <remarks></remarks> Public Sub Clear()          Me.InitialDirectory = Application.ThisWorkbook.path     Me.Filter = "すべてのファイル(*.*),*.*"     Me.FilterIndex = 1     Me.Title = "ファイルを選択してください"     Me.MultiSelect = True     ReDim m_FileNames(0) End Sub ''' <summary> ''' フィルターを設定 ''' </summary> ''' <param name="filterArray">フィルター文字列</param> ''' <remarks></remarks> Public Sub SetFilterList(ParamArray filterArray() As Variant)     Filter = Join(filterArray, ",") End Sub ''' <summary> ''' 選択したファイル名を取得する。 ''' </summary> ''' <remarks></remarks> Public Function GetSelectedFileNames() As String()     GetSelectedFileNames = m_FileNames End Function ''' <summary> ''' ファイル選択ダイアログを開く ''' </summary> ''' <returns>vbOK：ファイル選択、vbCancel：キャンセル</returns> ''' <remarks></remarks> Public Function ShowDialog() As VbMsgBoxResult     Dim resDlg As Variant     'カレントディレクトリを設定     objWs.CurrentDirectory = Me.InitialDirectory           'ファイル選択ダイアログを開く     resDlg = _          Application.GetOpenFilename( _               FileFilter:=Me.Filter, _               FilterIndex:=Me.FilterIndex, _               Title:=Me.Title, _               MultiSelect:=Me.MultiSelect _              )     If IsArray(resDlg) = False Then         If resDlg = False Then             'キャンセルした場合             ReDim m_FileNames(0)                          ShowDialog = vbCancel             Exit Function         End If     End If          ReDim m_FileNames(0)          'ファイル選択した場合     If IsArray(resDlg) = True Then         '複数選択の場合         Dim cnt_i As Integer                  For cnt_i = 1 To UBound(resDlg)             ReDim Preserve m_FileNames(cnt_i - 1)             m_FileNames(cnt_i - 1) = resDlg(cnt_i)         Next                  ShowDialog = vbOK         Exit Function     Else         '単一選択の場合         ReDim m_FileNames(0)         m_FileNames(0) = resDlg              ShowDialog = vbOK         Exit Function     End If      End Function

[VBA]ファイル選択ダイアログ

[ソース]

コードのコピー

Private Sub CommandButton1_Click()          Dim ofd As New OpenFileDialog          With ofd         .Title = "ファイル選択ダイアログ（単一選択）"         .FilterIndex = 1         .MultiSelect = False         .SetFilterList "CSV(*.csv),*.csv", "すべてのファイル(*.*),*.*"              End With          'ファイル選択ダイアログを開く。     If ofd.ShowDialog() = vbOK Then                  Dim cntI As Integer         Dim fList() As String                  fList = ofd.GetSelectedFileNames()                  For cntI = 0 To UBound(fList)             MsgBox fList(cntI)         Next     Else         MsgBox "キャンセルしました"     End If     '終了処理     Set ofd = Nothing End Sub

[VBA]使用例

タグ：VBA ファイル選択ダイアログ

[VBA]指定したブック内のシート検索

[はじめに]
・最近、Excelマクロを使う機会が増えたので、備忘録としてサンプルを掲載します。
　指定したブック内のシートを検索する処理です。

[ソース]

コードのコピー

Option Explicit ''' <summary> ''' 指定したブック検索する。 ''' </summary> ''' <param name="bookName">ブック名</param> ''' <returns>対象のWorkBook。（存在しない場合はNothing）</returns> ''' <remarks></remarks> Public Function FindBook( _     ByVal bookName As String) As Workbook     Dim bk As Workbook          For Each bk In Workbooks         If bk.name = bookName Then             Set FindBook = Workbooks(bk.name)             Exit Function         End If     Next End Function ''' <summary> ''' 指定したブック内のシートを検索する。 ''' </summary> ''' <param name="sheetName">シート名</param> ''' <param name="bookName">ブック名（※省略時はThisWorkbook.Name）</param> ''' <returns>対象のWorkSheet。（存在しない場合はNothing）</returns> ''' <remarks></remarks> Public Function FindSheet( _     ByVal sheetName As String, _     Optional ByVal bookName As String = "") As Worksheet     Dim bk As Workbook     Dim sht As Worksheet     If bookName = "" Then         'ブック名を省略した場合は、         '自分自身のブックを対象とする。         Set bk = ThisWorkbook     Else         Set bk = FindBook(bookName)                  If bk Is Nothing Then             '指定したブック名が存在しない場合は、Nothingを返す。             Set FindSheet = Nothing             Exit Function         End If              End If          For Each sht In bk.Sheets         If sht.name = sheetName Then             Set FindSheet = bk.Worksheets(sht.name)             Exit Function         End If     Next     'シートが存在しない場合、Nothingを返す。     Set FindSheet = Nothing End Function

[VBA]指定したブック内のシートを検索

タグ：シートの存在チェック シートの検索 VBA