|
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 |