[VBA覚書]関数サンプル １．Excel操作 その２

[]

今度は、別エクセルを開く処理。


一覧を作る処理なんかで、
他のファイルを開いてデータを取得したり、
他のファイルに出力したりするときに
同名のファイルが開かれているとエラーになりますが
それを回避するマクロです。





-------「サンプルソース」
「使い方」

Option Explicit

Public Sub openProc()

Const strFilePath As String = "c:\book1.xlsx"

Dim ret As Boolean
Dim opflg As Boolean
Dim objbook As Workbook

ret = BookOpenCheck(strFilePath)

If ret = True Then
''開かれている場合、開かれたブックを取得する
Set objbook = Workbooks(Dir(strFilePath))
Else
''開かれていない場合、開いてオブジェクトに取得する
Set objbook = getOpenBook(strFilePath, opflg, True)
End If

'''''''各種処理


''マクロで開いた場合は閉じる
If opflg Then
objbook.Close
End If

''オブジェクトを解放する
Set objbook = Nothing

End Sub

'***********************************************************************************
' 関数名　　　　　:BookOpenCheck
' 機能　　　　　　:ファイルが起動済みか確認する（大文字小文字を判別しない）
' 引数　　　　　　:ファイル名(またはパス)
' 戻り値　　　　　:true:起動済み、false:未起動
' 備考　　　　　　:自分で開いている場合のみ
'***********************************************************************************
Public Function BookOpenCheck(ByVal strPath As String) As Boolean

Dim strFilename As String
Dim iSheet As Long
Dim strTarget As String
Dim ret As Boolean

ret = False

''引数がパスの場合はファイル名のみを取得する
If InStr(strPath, "\") > 0 Then
strFilename = Dir(strPath)
Else
strFilename = strPath
End If

''ファイル名の前後の空白を削除する
strPath = Trim(strPath)
''ファイル名を全て大文字にする
strPath = Trim(UCase(strPath))

For iSheet = 1 To Workbooks.Count
strTarget = Trim(UCase(Workbooks(iSheet).Name))

If strPath = strTarget Then
''同名のファイルが開かれていた場合
ret = True
Exit For
End If

Next

BookOpenCheck = ret

End Function

'***********************************************************************************
' 関数名　　　　　:getOpenFile
' 機能　　　　　　:ブックを開く
' 引数　　　　　　:ファイルパス、マクロ起動フラグ（I/O）、（読込専用）
' 戻り値　　　　　:ブックオブジェクト
' 機能説明　　　　:既に開いている場合は開いているブックを取得する
'***********************************************************************************
Public Function getOpenBook(argPath As String, ByRef opflg As Boolean, Optional booRead As Boolean = True) As Workbook
Dim strName As String
Dim objbook As Workbook

Set objbook = Nothing

''ファイル名を取得する
strName = Dir(argPath)

If strName <> "" Then
''ファイルが存在する場合、開かれているか確認する
If BookOpenCheck(strName) = False Then
''開かれていない場合、ブックを開く
Application.EnableEvents = False
Set objbook = Workbooks.Open(Filename:=argPath, ReadOnly:=booRead, UpdateLinks:=False)
Application.EnableEvents = True
opflg = True

Else
''開かれていた場合、開かれているファイルを取得する
Set objbook = Workbooks(strName)
opflg = False

End If
End If

Set getOpenBook = objbook

End Function

-----[PR]-----

-----------【PR】-------------

タグ：VBA Vb Excel Microsoft プログラム 覚書 エクセル Visual Basic ビジュアルベーシック オフィス Office