Skip to content

Instantly share code, notes, and snippets.

@furyutei
Last active August 28, 2024 09:30
Show Gist options
  • Save furyutei/c7ab9ef9ef5a2cd51e58551f465497e9 to your computer and use it in GitHub Desktop.
Save furyutei/c7ab9ef9ef5a2cd51e58551f465497e9 to your computer and use it in GitHub Desktop.
[Excel][VBA][PowerShell] Everythingを利用して、OneDriveのURLからローカルのPathを取得する試み

[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が最も確度が高いが、それでも変換に失敗するケースがある模様

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

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

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

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

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

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

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

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

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
Sign up for free to join this conversation on GitHub. Already have an account? Sign in to comment