【VBA】エクセルファイルを一旦閉じて開きなおすコード＆ファイルの存在するフォルダを開くコード

コード内容

• エクセルファイルを一旦閉じて開きなおすコード
• ファイルの存在するフォルダを開くコード

詳細

• PCに登録したネットワークドライブでファイルやフォルダを開きなおしたい場合が多いので、その機能を追加している。
• Subモジュール2つを個人用マクロに登録して使うと便利な人には便利。

Option Explicit

Sub ReopenActiveFileUsingNetworkDrive()
    Dim ConfirmationMessage As String
    ConfirmationMessage = _
        "Reopen active file using network drive?" & vbNewLine & _
        "If opened as ReadOnly, close without save and reopen as ReadOnly"
    Call confirmRun(ConfirmationMessage)
    
    Dim wb As Workbook
    Set wb = ActiveWorkbook
    Call EndProcedureIfFileHasNoPath(wb.Path)
    Dim targetFileFullName As String
    targetFileFullName = _
        makeFullPathUsingNetworkDrive(wb.Path, wb.Name)
    
    If wb.ReadOnly Then
        wb.Close saveChanges:=False
        Workbooks.Open targetFileFullName, ReadOnly:=True
    Else
        wb.Close
        Workbooks.Open targetFileFullName
    End If
End Sub

Sub OpenFolderOfActiveFileUsingNetworkDrive()
    Call confirmRun("Open foder of active file?")
    Call EndProcedureIfFileHasNoPath(ActiveWorkbook.Path)
    Dim targetFilePath As String
    targetFilePath = replaceWithNetworkDrive(ActiveWorkbook.Path)
    
    Dim strPath
    strPath = "explorer.exe /e,""" & targetFilePath & """"
    Dim objShell
    Set objShell = CreateObject("Wscript.Shell")
    objShell.Run strPath
End Sub

Private Sub EndProcedureIfFileHasNoPath(wb_path As String)
    If wb_path = "" Then
        MsgBox "This file has no path"
        End
    End If
End Sub

Private Sub confirmRun(confirmation_message As String)
    If MsgBox(confirmation_message, vbYesNo + vbQuestion) <> vbYes Then
        MsgBox "You have chosen not to run the macro"
        End
    End If
End Sub

Private Function makeFullPathUsingNetworkDrive(file_path As String, file_name As String) As String
    Dim targetFilePath As String
    Dim targetFileName As String
    targetFilePath = replaceWithNetworkDrive(file_path)
    targetFileName = file_name
    makeFullPathUsingNetworkDrive = targetFilePath & "\" & targetFileName
End Function

Private Function replaceWithNetworkDrive(file_path As String) As String
    'see: http://www.wmifun.net/sample/vb6/win32_mappedlogicaldisk.html
    Dim MldSet As Object 'SWbemObjectSet
    Dim Mld As Object 'SWbemObject
    Dim Locator As Object 'SWbem Locator
    Dim Service As Object 'SWbem Services
    Set Locator = CreateObject("WbemScripting.sWbemLocator") 'New Wbem Scripting.swbem Locator
    Set Service = Locator.ConnectServer
    Set MldSet = Service.ExecQuery("Select * From Win32_MappedLogicalDisk")
    For Each Mld In MldSet
        file_path = Replace(file_path, Mld.ProviderName, Mld.Name)
    Next
    replaceWithNetworkDrive = file_path
    Set MldSet = Nothing
    Set Mld = Nothing
    Set Locator = Nothing
    Set Service = Nothing
End Function