で、ダイアログの使い方の例と、ファイルのフルパスを指定してブックを開く関数です。
ダイアログ
まず、ダイアログの書き方です。
FileDialog(msoFileDialogOpen)
Sub Bookを開く() With Application.FileDialog(msoFileDialogOpen) With .Filters .Clear .Add "Excelブック", "*.xls; *.xlsx; *.xlsm", 1 .Add "すべてのファイル", "*.*", 2 End With .InitialFileName = ThisWorkbook.FullName .Title = "ファイルを開く" If .Show = True Then .Execute Else ''キャンセルボタンが押された End If End With End Sub
FileDialog(msoFileDialogFilePicker)
Sub 指定したファイルを配列にセット() Dim i As Integer Dim arrFiles() As String With Application.FileDialog(msoFileDialogFilePicker) .AllowMultiSelect = True With .Filters .Clear .Add "Excelブック", "*.xls; *.xlsx; *.xlsm", 1 .Add "すべてのファイル", "*.*", 2 End With .InitialFileName = ThisWorkbook.FullName If .Show = True Then For i = 1 To .SelectedItems.Count ReDim Preserve arrFiles(1 To i) arrFiles(i) = .SelectedItems(i) Next Else ''キャンセルボタンが押された End If End With End Sub
FileDialog(msoFileDialogFolderPicker)
Sub フォルダの取得() Dim sPath As String With Application.FileDialog(msoFileDialogFolderPicker) .InitialFileName = ThisWorkbook.Path .Title = "フォルダの選択" If .Show = True Then sPath = .SelectedItems(1) Else ''キャンセルボタンが押された End If End With End Sub
GetOpenFilename:1ファイル
Sub ファイル名を取得() Dim FileToOpen As Variant FileToOpen = Application.GetOpenFilename( _ "Excelブック(*.xls?), *.xls?,すべてのファイル(*.*),*.*", _ 1, _ "ファイル名を取得") If FileToOpen = False Then Exit Sub End Sub
GetOpenFilename:複数ファイル名を取得
Sub 複数ファイル名を取得() Dim FileToOpen As Variant FileToOpen = Application.GetOpenFilename( _ "Excelブック(*.xls?),*.xls?,すべてのファイル(*.*),*.*", _ 2, _ "ファイル名を取得", , True) If VarType(FileToOpen) = vbBoolean Then If FileToOpen = False Then Exit Sub Else ''FileToOpen(配列、インデックス:1ベース)でFullNameを取得できる End If End Sub
関数サンプル
ファイルのフルパスを渡して開いて、ワークブックオブジェクトを戻すようにしました。
Sub OpenBookの呼び出し() Dim sfile Dim wb As Workbook On Error GoTo AbEnd sfile = "ファイルのフルパス" Set wb = OpenBook(sfile) Exit Sub AbEnd: MsgBox Err.Description End Sub
'=========================================================================' Function OpenBook( _ ByVal pBookFullNameToOpen As String _ ) As Workbook '=========================================================================' Dim home As Workbook Dim ScrUpdStatus As Boolean Dim Buff As String Dim wb As Workbook ''初期化 Set OpenBook = Nothing Set home = ActiveWorkbook ScrUpdStatus = Application.ScreenUpdating Buff = Dir(pBookFullNameToOpen) If Buff = "" Then Err.Raise 800, "OpenBook", "指定したBookはありません" Exit Function End If For Each wb In Workbooks If wb.Name = Buff Then Err.Raise 800, "OpenBook", "指定したBookは既に開いています" Exit Function End If Next wb Application.ScreenUpdating = False Workbooks.Open pBookFullNameToOpen Set OpenBook = ActiveWorkbook home.Activate Application.ScreenUpdating = ScrUpdStatus End Function
0 件のコメント:
コメントを投稿