趣味プログラミングblog

元ソースについては以下の記事を参照。

「ショートカットファイルのリンク先を置換するマクロ」

対象のファイルをローカルにコピーして情報取得も考えたけど、、、それの方が良いか。。。

ショートカットファイルのサイズは小さいもんね。別途やってみることにして、今回はファイルパスをショートパスで取得する方法をやってみた話。

今までDir関数でやっていたファイル存在チェックもFSOへ変更。
速度が遅いのは嫌なので、文字数が250バイトを超えたらショートパスを使ってリンク先を取得する。

ショートパスは以下の方法で取る。

CreateObject("Scripting.FileSystemObject").GetFile(LnkFileName).shortPath

以下ソース

Sub ショートカットファイルからリンク先を取得()
        
    Dim WSH: Set WSH = CreateObject("WScript.Shell")
    Dim objFS As Object:  Set objFS = CreateObject("Scripting.FileSystemObject")
    Dim objFile As Object
    
        
    Dim LnkFile, DeskTopPath As String, LnkFileName As String
    Dim Gyo As Long, GyoSt As Long, GyoEnd As Long
    GyoSt = 8
    GyoEnd = Cells(Rows.Count, "B").End(xlUp).Row
    
    For Gyo = GyoSt To GyoEnd
        DoEvents
        Application.StatusBar = Gyo & "/" & GyoEnd & "件目を処理中"
        Cells(Gyo, "A") = Gyo - GyoSt + 1
        LnkFileName = Cells(Gyo, "B").Value
        If Right(LnkFileName, 4) = ".lnk" Then           '
            
            If objFS.FileExists(LnkFileName) = True Then
                If LenB(LnkFileName) > 250 Then
                    Set objFile = objFS.GetFile(LnkFileName)    'FSOを使ってショートネームを取得する
                    Set LnkFile = WSH.CreateShortcut(objFile.shortPath)   'lenb 256を超えるとエラーになるのでショートネームに
                Else
                    Set LnkFile = WSH.CreateShortcut(LnkFileName)   'lenb 256を超えるとエラーになる
                End If
                Cells(Gyo, "C") = LnkFile.TargetPath
            Else
                Cells(Gyo, "E").Value = "No File"
                Call 黄色網掛け(Gyo, "B")
            End If
        Else
            Cells(Gyo, "E").Value = "Link Error"
            Call 黄色網掛け(Gyo, "C")
        End If  'If Right(LnkFileName, 4) = ".lnk" Then
    Next Gyo
    
    Set LnkFile = Nothing
    Set WSH = Nothing
    Application.StatusBar = ""
    
End Sub