[VBA][PowerShell] FileSystemWatcherを利用して、OneDriveフォルダのURLからローカルのPathを取得する試み

0.README.md

[VBA][PowerShell] FileSystemWatcherを利用して、OneDriveフォルダのURLからローカルのPathを取得する試み

こちらではEverything/PSEverythingを利用したが、ファイルが作成されたことを検知するならFileSystemWatcherで行けるかな？と試してみたもの。

大まかには

1. ユニークな一時ファイル名とWorkbook(xlsxファイル)ファイル名を作成し、一時ファイルには最初は適当な文字列（"?NOT FOUND YET?"）を書き込み
2. WScript.Shell経由でPowerShellを非同期で起動、FileSystemWatcherにてOneDrive配下のxlsxファイルの"Created"イベント監視設定＆準備ができたら一時ファイルのサイズを0に
3. VBA側で、一時ファイルのサイズが0になったら、指定されたOneDriveのフォルダURLの場所にユニークなWorkbook(xlsxファイル)を作成
4. PowerShell側で、FileSystemWatcherの"Created"イベントが発生するので、一時ファイルにFullPathを記録し、PowerShell終了
5. VBA側で、ファイルサイズが0より大きくなったら、一時ファイルからFullPath(=ローカルPath)を取得

のような処理を行っている。

これなら、Everythingを使っていない環境でもPowerShellさえ入っていればなんとかなる。
……速度が遅いのはいかんともしがたいけれども。

Mod_ConvertToLocalPath.vba

Option Explicit

' ■ FileSystemWatcherを利用して、OneDriveのURLからローカルのPathを取得する試み
'
' - 参照設定:「Microsoft Scripting Runtime」

Private Const DebugFlag As Boolean = False

Private Declare PtrSafe Sub Sleep Lib "kernel32" (ByVal ms As LongPtr)

Public Function ConvertToLocalPath(Optional ByVal TargetURL = "", Optional ByVal OneDriveRootPath = "")
' TargetURL: ローカルPathに変換したいOneDriveのURL（省略時はThisWorkbook.Path）
' 【注意】 TargetURLがファイルを指す場合、Workbooks.Openで開けるものに限る
    TargetURL = Trim(TargetURL)
    If TargetURL = "" Then TargetURL = ThisWorkbook.Path
    Dim LocalPath: LocalPath = TargetURL
    If Not (TargetURL Like "https://*") Then GoTo CLEANUP
    Do While TargetURL Like "*/"
        TargetURL = Left(TargetURL, Len(TargetURL) - 1)
    Loop
    If OneDriveRootPath = "" Then OneDriveRootPath = Environ("OneDrive")
    LocalPath = SearchFilePath(TargetURL, OneDriveRootPath)
CLEANUP:
    ConvertToLocalPath = LocalPath
End Function

Private Function SearchFilePath(TargetURL, OneDriveRootPath)
    Static URL_PathMap As Object
    If URL_PathMap Is Nothing Then Set URL_PathMap = CreateObject("Scripting.Dictionary")
    If URL_PathMap.Exists(TargetURL) Then
        SearchFilePath = URL_PathMap(TargetURL)
        Exit Function
    End If
    Dim ResultSearchFilePath
    Dim TargetFolderPathURL: TargetFolderPathURL = TargetURL
    Dim TargetFileName: TargetFileName = ""
    Dim SearchFileName
    Dim SavingResultFileName
    Dim BaseName
    Dim TempFolderName
    Dim TempWorkbookName
    Dim TempWorkbook As Workbook
    Dim LastSlashPosition As Long
    On Error Resume Next
    For Each TempWorkbook In Application.Workbooks
        If TempWorkbook.FullName = TargetFolderPathURL Then
            GoSub SPLIT_TARGET_PATH
            Exit For
        End If
    Next
    Dim ExcelApp As New Excel.Application
    ExcelApp.DisplayAlerts = False
    If TargetFileName = "" Then
        Set TempWorkbook = ExcelApp.Workbooks.Open(TargetFolderPathURL, ReadOnly:=True)
        If Err.Number = 0 Then
            TempWorkbook.Close SaveChanges:=False
            GoSub SPLIT_TARGET_PATH
        End If
    End If
    On Error GoTo 0
    With Fso
        TempFolderName = .GetSpecialFolder(Scripting.TemporaryFolder)
        On Error Resume Next
        Do
            Do
                BaseName = .GetTempName
                SavingResultFileName = TempFolderName & "\" & BaseName
            Loop While .FileExists(SavingResultFileName)
            With .CreateTextFile(SavingResultFileName, Overwrite:=True)
                .WriteLine "?NOT FOUND YET?"
                .Close
            End With
            SearchFileName = BaseName & ".xlsx"
            TempWorkbookName = TargetFolderPathURL & "/" & SearchFileName
            Set TempWorkbook = ExcelApp.Workbooks.Open(TempWorkbookName, ReadOnly:=True)
            If Err.Number <> 0 Then
                Exit Do
            End If
            TempWorkbook.Close SaveChanges:=False
            .DeleteFile SavingResultFileName
        Loop
        On Error GoTo 0
    End With
    If DebugFlag Then
        Debug.Print "[SearchFileName] " & SearchFileName
        Debug.Print "[TempWorkbookName] " & TempWorkbookName
        Debug.Print "[SavingResultFileName] " & SavingResultFileName
    End If
    Dim PSCommand: PSCommand = Join(Array( _
        "$ResultFile = '" & SavingResultFileName & "'", _
        "$Watcher = New-Object System.IO.FileSystemWatcher", _
        "$Watcher.NotifyFilter = [System.IO.NotifyFilters]::LastWrite -bor [System.IO.NotifyFilters]::FileName -bor [System.IO.NotifyFilters]::DirectoryName", _
        "$Watcher.IncludeSubdirectories = $true", _
        "$Watcher.Path = '" & OneDriveRootPath & "'", _
        "$Watcher.Filter = '" & SearchFileName & "'", _
        "$Global:WatchFlag = $true", _
        "$Action = {Write-Output $Event.SourceEventArgs.FullPath > $ResultFile; $Global:WatchFlag = $false;}", _
        "Register-ObjectEvent $Watcher 'Created' -Action $Action", _
        "$Watcher.EnableRaisingEvents = $true; New-Item -ItemType file $ResultFile -Force", _
        "While ($Global:WatchFlag) {Sleep 0.1;}", _
        "$Watcher.EnableRaisingEvents = $false", _
        "Get-Job | ForEach-Object {Remove-Job -ID $_.id -Force}" _
    ), vbCrLf)
    If DebugFlag Then Debug.Print "[PowerShell Command]" & vbCrLf & PSCommand
    Dim Wsh As Object: Set Wsh = CreateObject("WScript.Shell")
    Dim WshResult: WshResult = Wsh.Run("powershell -NoLogo -NoProfile -ExecutionPolicy Unrestricted -Command %{" & PSCommand & "}", IIf(DebugFlag, 1, 0), False)
    If DebugFlag Then Debug.Print "[WshResult] ", WshResult
    Debug.Assert WshResult = 0 ' WScript.Shell(PowerShell)でエラー発生時はここで停止
    Do While Fso.GetFile(SavingResultFileName).Size > 0
        Sleep 0.1
    Loop
    With ExcelApp
        With .Workbooks.Add
            .SaveAs TempWorkbookName
            .Close
        End With
        .DisplayAlerts = True
    End With
    Do While Fso.GetFile(SavingResultFileName).Size = 0
        Sleep 0.1
    Loop
    Dim LocalFilePath
    With CreateObject("ADODB.Stream")
        .Charset = "Unicode"
        .Open
        On Error Resume Next
        Do
            .LoadFromFile SavingResultFileName
            If Err.Number = 0 Then Exit Do
            If DebugFlag Then Debug.Print Err.Number, Err.Description
            Err.Clear
            Sleep 0.1
        Loop
        On Error GoTo 0
        LocalFilePath = Trim(Replace(Replace(.ReadText, vbLf, ""), vbCr, ""))
        .Close
    End With
    Debug.Assert LocalFilePath <> "" ' LocalFilePathが正常に取得できない場合はここで停止
    Fso.DeleteFile SavingResultFileName
    Fso.DeleteFile LocalFilePath
'    LastSlashPosition = InStrRev(LocalFilePath, "\")
'    ResultSearchFilePath = Left(LocalFilePath, IIf(LastSlashPosition < 1, Len(LocalFilePath), LastSlashPosition - 1))
    ResultSearchFilePath = Left(LocalFilePath, Len(LocalFilePath) - Len(SearchFileName) - 1)
    URL_PathMap(TargetFolderPathURL) = ResultSearchFilePath
    GoTo CLEANUP

SPLIT_TARGET_PATH:
    LastSlashPosition = InStrRev(TargetFolderPathURL, "/")
    TargetFileName = Right(TargetFolderPathURL, Len(TargetFolderPathURL) - LastSlashPosition)
    TargetFolderPathURL = Left(TargetFolderPathURL, LastSlashPosition - 1)
    Do While TargetFolderPathURL Like "*/"
        TargetFolderPathURL = Left(TargetFolderPathURL, Len(TargetFolderPathURL) - 1)
    Loop
    If URL_PathMap.Exists(TargetFolderPathURL) Then
        ResultSearchFilePath = URL_PathMap(TargetFolderPathURL)
        GoTo CLEANUP
    End If
    Return

CLEANUP:
    If TargetFileName <> "" Then
        ResultSearchFilePath = ResultSearchFilePath & "\" & TargetFileName
        URL_PathMap(TargetURL) = ResultSearchFilePath
    End If
    SearchFilePath = ResultSearchFilePath
End Function

Private Property Get Fso() As FileSystemObject
    Static FsoObject As FileSystemObject
    If FsoObject Is Nothing Then Set FsoObject = New FileSystemObject
    Set Fso = FsoObject
End Property

Sub TestConvertToLocalPath()
    Dim StartTime
    StartTime = Timer: Debug.Print ConvertToLocalPath(): Debug.Print "[経過時間]" & Format(Timer - StartTime, "00:00:00.0")
    StartTime = Timer: Debug.Print ConvertToLocalPath(ThisWorkbook.FullName): Debug.Print "[経過時間]" & Format(Timer - StartTime, "00:00:00.0")
End Sub