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

0.README.md

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

※考え方は同じだけれど、Everything不要のやり方はこちら→[VBA][PowerShell] FileSystemWatcherを利用して、OneDriveフォルダのURLからローカルのPathを取得する試み

---

OneDriveに割り当てられたフォルダ下では、ExcelのVBAでWorkbook.Path等を参照すると、通常のフォルダのPathではなく、URLになってしまう。 これをローカルフォルダのPathに変換する手段として、知る限りでは[VBA Function to get the local path of a OneDrive/SharePoint synchronized Microsoft Office file](https://gist.github.com/guwidoe/038398b6be1b16c458365716a921814d)が最も確度が高いが、それでも[変換に失敗するケースがある模様](https://twitter.com/KotorinChunChun/status/1781695979101819031)。

SharePointで「OneDriveへのショートカットの追加」したときのトップレベルフォルダーが取得できなくなっている気配

ふと思いついて、Everythingがインストールされていれば、そのAPIを利用して

1. 指定されたPathの場所にユニークなWorkbook(xlsxファイル)を作成
2. そのファイルをEverythingで検索（PSEverything（PowerShellのモジュール）経由）し、ローカルのPathを取得

で行けるのではないか？　と試してみた。

一応、自分の環境ではローカルのPathが取得はできたが……

• EverythingやPowerShellのモジュールをインストールして動作させておく必要があるため、ハードルが高い
• 実行にとても時間がかかる（数秒～数十秒）

ということで、残念ながら実用にはなりそうにない。
※時間がかかるのは、新規Workbookの作成・保存とPowerShellの呼び出しのオーバーヘッドを解消する手段があれば縮められると思うが、方法が思いつかない。

試してみようと思うもの好き奇特な方は、上記の点をご承知の上、あくまでネタとして扱うよう、お願いしておく。

Mod_ConvertToLocalPath.vba

Option Explicit

' ■ Everythingを利用して、OneDriveのURLからローカルのPathを取得する試み
'
' - 前準備:
'   - Everythingを([voidtools](https://www.voidtools.com/)から)インストールした上で、OneDriveのフォルダを検索対象に含めておくこと
'   - 管理者権限で起動したPowerShellにて[powercode/PSEverything: PowerShell commandlets for the local search engine Everything](https://github.com/powercode/PSEverything)をインストールしておくこと
'     > Install-Module PSEverything
'
' - 参照設定:「Microsoft Scripting Runtime」

Private Const DebugFlag As Boolean = False

Public Function ConvertToLocalPath(Optional ByVal TargetFolderURL = "")
' TargetFolderURL: ローカルPathに変換したいOneDriveのフォルダーのURL（省略時はThisWorkbook.Path）
' 【注意】 TargetFolderURLにはファイル名を含めないこと
    TargetFolderURL = Trim(TargetFolderURL)
    If TargetFolderURL = "" Then TargetFolderURL = ThisWorkbook.Path
    Dim LocalPath: LocalPath = TargetFolderURL
    If Not (TargetFolderURL Like "https://*") Then GoTo CLEANUP
    Do While TargetFolderURL Like "*/"
        TargetFolderURL = Left(TargetFolderURL, Len(TargetFolderURL) - 1)
    Loop
    Dim TempFiles As Collection: Set TempFiles = GetTempFiles(TargetFolderURL)
    Dim SearchFileName: SearchFileName = TempFiles("SearchFileName")
    Dim SavingResultFileName: SavingResultFileName = TempFiles("SavingResultFileName")
    If DebugFlag Then Debug.Print "[SearchFileName] " & SearchFileName & vbCrLf & "[SavingResultFileName] " & SavingResultFileName
    LocalPath = SearchFilePath(SearchFileName, SavingResultFileName)
CLEANUP:
    ConvertToLocalPath = LocalPath
End Function

Private Function SearchFilePath(SearchFileName, SavingResultFileName)
    Dim PSCommand: PSCommand = "Search-Everything -Global -Include """ & SearchFileName & """ | Sort-Object Lastwritetime -Descending | Select-Object -First 1 > '" & SavingResultFileName & "'"
#If Not Win64 Then
    ' [備忘]
    '   32bit版からWScript.Shell経由でPowerShellを呼び出した場合、PSModulePathに"C:\Program Files\WindowsPowerShell\Modules"が含まれていない
    '   このため、以下のようなエラーが発生し、Search-Everythingが実行できない
    '
    '   | Search -Everything: 用語 'Search-Everything' は、コマンドレット、関数、スクリプト ファイル、または操作可能なプログラムの名前として認識されません｡
    '   | （中略）
    '   | + Search-Everything -Global -Include ...
    '   | + ~~~~~~~~~~~~~~~~~
    '   |     + CategoryInfo          : ObjectNotFound: (Search-Everything:String) [], CommandNotFoundException
    '   |     + FullyQualifiedErrorId : CommandNotFoundException
    '
    '   → $env:PSModulePathに"C:\Program Files\WindowsPowerShell\Modules"を追加してやることで対処
    PSCommand = "$env:PSModulePath=$env:ProgramW6432+'\WindowsPowerShell\Modules;'+$env:PSModulePath; " & PSCommand
#End If
    If DebugFlag Then Debug.Print "[PowerShell Command] " & PSCommand
    Dim Wsh As Object: Set Wsh = CreateObject("WScript.Shell")
    Dim WshResult: WshResult = Wsh.Run("powershell -NoLogo -NoProfile -ExecutionPolicy Unrestricted -Command " & PSCommand, 0, True)
    If DebugFlag Then Debug.Print "[WshResult] ", WshResult
    Debug.Assert WshResult = 0 ' WScript.Shell(PowerShell)でエラー発生時はここで停止（PSEverythingがインストールされているか要確認）
    Dim LocalFilePath
    With CreateObject("ADODB.Stream")
        .Charset = "Unicode"
        .Open
        .LoadFromFile SavingResultFileName
        LocalFilePath = Trim(Replace(Replace(.ReadText, vbLf, ""), vbCr, ""))
        .Close
    End With
    Debug.Assert LocalFilePath <> "" ' LocalFilePathが正常に取得できない場合はここで停止
    Fso.DeleteFile SavingResultFileName
    Fso.DeleteFile LocalFilePath
'    Dim LastSlashPosition As Long: LastSlashPosition = InStrRev(LocalFilePath, "\")
'    SearchFilePath = Left(LocalFilePath, IIf(LastSlashPosition < 1, Len(LocalFilePath), LastSlashPosition - 1))
    SearchFilePath = Left(LocalFilePath, Len(LocalFilePath) - Len(SearchFileName) - 1)
End Function

Private Function GetTempFiles(TargetFolderURL) As Collection
    Dim Result As New Collection
    Dim SearchFileName
    Dim SavingResultFileName
    Dim BaseName
    Dim TempFolderName
    Dim TempWorkbookName
    Dim TempWorkbook As Workbook
    Dim ExcelApp As New Excel.Application
    ExcelApp.DisplayAlerts = False
    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)
                .Close
            End With
            SearchFileName = BaseName & ".xlsx"
            TempWorkbookName = TargetFolderURL & "/" & 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
        Set TempWorkbook = ExcelApp.Workbooks.Add
        TempWorkbook.SaveAs TempWorkbookName
        TempWorkbook.Close
    End With
    ExcelApp.DisplayAlerts = True
    Result.Add SearchFileName, "SearchFileName"
    Result.Add SavingResultFileName, "SavingResultFileName"
    Set GetTempFiles = Result
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")
End Sub