• >home
• 1
• 2
• 3
• 4
• 5
• 6
• 7
• 8
• 9
• 10

Excel VBA Sample 10

▼ThisWorkbook.Path が OneDriveのURLを返す環境で、ローカルパスに変換する関数

Public Function OneDrivePath(S_Url As String) As String

    Const Cns_OneDrive法人パターン As String = "my.sharepoint.com"
    '法人向けOneDriveのURLか否かを判定するためのLike右辺値

    Static S_path区切り As String
    Static S_OneDrive法人Path As String
    Static S_OneDrive個人Path As String

    Dim S_パス位置 As Long

    '引数がURLでない場合、引数はローカルパスと判断してそのまま返す。
    If Not (S_Url Like "https://*") Then
        OneDrivePath = S_Url
        Exit Function
    End If

    If (S_path区切り = "") Then
        S_path区切り = Application.PathSeparator

        '法人向けOneDrive(OneDrive for Business)のパス
        S_OneDrive法人Path = Environ("OneDriveCommercial")
        If (S_OneDrive法人Path = "") Then
            S_OneDrive法人Path = Environ("OneDrive")
        End If

        '個人向けOneDriveのパス
        S_OneDrive個人Path = Environ("OneDriveConsumer")
        If (S_OneDrive個人Path = "") Then
            S_OneDrive個人Path = Environ("OneDrive")
        End If

    End If

    '法人向けOneDrive:S_Url="https://会社名-my.sharepoint.com/personal/ユーザー名_domain_com/Documentsファイルパス")
    If (S_Url Like "*" & Cns_OneDrive法人パターン & "*") Then

        S_パス位置 = InStr(1, S_Url, "/Documents") + 10                         '10 = Len("/Documents")
        OneDrivePath = S_OneDrive法人Path & Replace(Mid(S_Url, S_パス位置), "/", S_path区切り)

    '個人向けOneDrive:S_Url="https://d.docs.live.net/CID番号/ファイルパス"
    Else


        S_パス位置 = InStr(9, S_Url, "/")                                       '9 = Len("https://") + 1
        S_パス位置 = InStr(S_パス位置 + 1, S_Url, "/")
        OneDrivePath = S_OneDrive個人Path & Replace(Mid(S_Url, S_パス位置), "/", S_path区切り)

    End If

End Function

▼VBAエディタ上で文字をCP932として扱う

' Windows APIのGetACP関数を宣言
Private Declare PtrSafe Function GetACP Lib "kernel32" () As LongPtr

Sub バイト数で2バイト文字交じりの文字列を分割()

    Const JAPANESE_CODEPAGE As Long = 932 ' Shift-JISのコードページ
    
    ' システムのコードページをチェック
    If GetACP() <> JAPANESE_CODEPAGE Then
        MsgBox "このプロシージャは日本語環境（Shift-JIS、コードページ 932）でのみ動作します。" & vbCrLf & _
               "現在のコードページ: " & GetACP() & " では正しく動作しません。", vbExclamation, "コードページエラー"
        Exit Sub
    End If

    Dim tgtData As String
    tgtData = [a1].Value
    Dim strJis As String
    
    '"a"を1バイトとする文字体系に変換
    'vbFromUnicode:128　文字列をUnicodeからシステムの既定のコードページに変換
    strJis = StrConv(tgtData, vbFromUnicode)
    
    Dim arrStr(1 To 1, 1 To 3) As String
    
    'バイト数で分割した値を再度UNICODE文字列に戻す
    arrStr(1, 1) = StrConv(MidB(strJis, 1, 3), vbUnicode) ' 1バイト目から3バイト分抽出
    arrStr(1, 2) = StrConv(MidB(strJis, 4, 4), vbUnicode) ' 4バイト目から4バイト分抽出
    arrStr(1, 3) = StrConv(MidB(strJis, 8, 6), vbUnicode) ' 8バイト目から6バイト分抽出
    
    [b1:d1].Value = arrStr
    
End Sub

---

yamaV1.02β