【VBA】スニペット集

' ── OneDrive URL → ローカルパス変換 ──
Private Function GetLocalPath() As String
    Dim p As String
    p = ThisWorkbook.Path

    ' URLでなければそのまま返す
    If Left(p, 4) <> "http" Then
        GetLocalPath = p & "\"
        Exit Function
    End If

    ' OneDrive環境変数からローカルパスを推定
    Dim envKeys As Variant
    envKeys = Array("OneDriveConsumer", "OneDriveCommercial", "OneDrive")

    Dim ws As Object
    Set ws = CreateObject("WScript.Shell")

    Dim envPath As String, i As Long
    For i = 0 To UBound(envKeys)
        On Error Resume Next
        envPath = ws.Environment("Process")(CStr(envKeys(i)))
        On Error GoTo 0
        If envPath <> "" Then
            Dim urlPath As String
            urlPath = p

            ' URLベース部分を除去 (https://domain/id/ の4番目の/以降)
            Dim slashPos As Long, cnt As Long
            slashPos = 0
            For cnt = 1 To 4
                slashPos = InStr(slashPos + 1, urlPath, "/")
                If slashPos = 0 Then Exit For
            Next
            If slashPos > 0 Then
                urlPath = Mid(urlPath, slashPos + 1)
            End If

            ' %XX をデコード
            urlPath = URLDecode(urlPath)

            ' / → \ に置換
            urlPath = Replace(urlPath, "/", "\")

            ' ローカルパス候補を生成して存在確認
            Dim localCandidate As String
            localCandidate = envPath & "\" & urlPath & "\"

            Dim fso As Object
            Set fso = CreateObject("Scripting.FileSystemObject")
            If fso.FolderExists(localCandidate) Then
                GetLocalPath = localCandidate
                Exit Function
            End If

            ' 最初のサブフォルダを除いた候補も試す (OneDriveの階層ズレ対策)
            Dim firstSlash As Long
            firstSlash = InStr(urlPath, "\")
            If firstSlash > 0 Then
                localCandidate = envPath & "\" & Mid(urlPath, firstSlash + 1) & "\"
                If fso.FolderExists(localCandidate) Then
                    GetLocalPath = localCandidate
                    Exit Function
                End If
            End If
        End If
    Next

    ' 自動解決失敗時: フォルダ選択ダイアログ
    With Application.FileDialog(4)
        .Title = "Select dwglist folder"
        If .Show = -1 Then
            GetLocalPath = .SelectedItems(1) & "\"
        Else
            GetLocalPath = ""
        End If
    End With
End Function

' ── URLデコード (%XX → 文字) ──
Private Function URLDecode(ByVal s As String) As String
    Dim result As String, i As Long
    i = 1
    Do While i <= Len(s)
        If Mid(s, i, 1) = "%" And i + 2 <= Len(s) Then
            result = result & Chr(Val("&H" & Mid(s, i + 1, 2)))
            i = i + 3
        Else
            result = result & Mid(s, i, 1)
            i = i + 1
        End If
    Loop
    URLDecode = result
End Function

' ── OneDrive URL → ローカルパス変換 ──
Private Function GetLocalPath() As String
    Dim p As String
    p = ThisWorkbook.Path

    ' URLでなければそのまま返す
    If Left(p, 4) <> "http" Then
        GetLocalPath = p & "\"
        Exit Function
    End If

    ' OneDrive環境変数からローカルパスを推定
    Dim envKeys As Variant
    envKeys = Array("OneDriveConsumer", "OneDriveCommercial", "OneDrive")

    Dim ws As Object
    Set ws = CreateObject("WScript.Shell")

    Dim envPath As String, i As Long
    For i = 0 To UBound(envKeys)
        On Error Resume Next
        envPath = ws.Environment("Process")(CStr(envKeys(i)))
        On Error GoTo 0
        If envPath <> "" Then
            Dim urlPath As String
            urlPath = p

            ' URLベース部分を除去 (https://domain/id/ の4番目の/以降)
            Dim slashPos As Long, cnt As Long
            slashPos = 0
            For cnt = 1 To 4
                slashPos = InStr(slashPos + 1, urlPath, "/")
                If slashPos = 0 Then Exit For
            Next
            If slashPos > 0 Then
                urlPath = Mid(urlPath, slashPos + 1)
            End If

            ' %XX をデコード
            urlPath = URLDecode(urlPath)

            ' / → \ に置換
            urlPath = Replace(urlPath, "/", "\")

            ' ローカルパス候補を生成して存在確認
            Dim localCandidate As String
            localCandidate = envPath & "\" & urlPath & "\"

            Dim fso As Object
            Set fso = CreateObject("Scripting.FileSystemObject")
            If fso.FolderExists(localCandidate) Then
                GetLocalPath = localCandidate
                Exit Function
            End If

            ' 最初のサブフォルダを除いた候補も試す (OneDriveの階層ズレ対策)
            Dim firstSlash As Long
            firstSlash = InStr(urlPath, "\")
            If firstSlash > 0 Then
                localCandidate = envPath & "\" & Mid(urlPath, firstSlash + 1) & "\"
                If fso.FolderExists(localCandidate) Then
                    GetLocalPath = localCandidate
                    Exit Function
                End If
            End If
        End If
    Next

    ' 自動解決失敗時: フォルダ選択ダイアログ
    With Application.FileDialog(4)
        .Title = "Select dwglist folder"
        If .Show = -1 Then
            GetLocalPath = .SelectedItems(1) & "\"
        Else
            GetLocalPath = ""
        End If
    End With
End Function

' ── URLデコード (%XX → 文字) ──
Private Function URLDecode(ByVal s As String) As String
    Dim result As String, i As Long
    i = 1
    Do While i <= Len(s)
        If Mid(s, i, 1) = "%" And i + 2 <= Len(s) Then
            result = result & Chr(Val("&H" & Mid(s, i + 1, 2)))
            i = i + 3
        Else
            result = result & Mid(s, i, 1)
            i = i + 1
        End If
    Loop
    URLDecode = result
End Function

Cleanup:
    ' 画面更新・再計算・イベントを復元
    Application.ScreenUpdating = True
    Application.Calculation = xlCalculationAutomatic
    Application.EnableEvents = True
    Exit Sub

ErrHandler:
    MsgBox "Error: " & Err.Description & vbCrLf & _
           "Path: " & folderPath, vbCritical
    Resume Cleanup
End Sub

Cleanup:
    ' 画面更新・再計算・イベントを復元
    Application.ScreenUpdating = True
    Application.Calculation = xlCalculationAutomatic
    Application.EnableEvents = True
    Exit Sub

ErrHandler:
    MsgBox "Error: " & Err.Description & vbCrLf & _
           "Path: " & folderPath, vbCritical
    Resume Cleanup
End Sub