で、ダイアログの使い方の例と、ファイルのフルパスを指定してブックを開く関数です。
ダイアログ
まず、ダイアログの書き方です。
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 件のコメント:
コメントを投稿