デスクトップのショートカットのリンク先を取込む関数

'********************************************
'* デスクトップのショートカットのリンク先を取込。180427
'* rng：このセルから下にリンク先を取り込む
Private Sub ShortCutFromDesktop(ByVal rng As Range)
    Dim buf As String, cnt As Long
    Dim WSH As Object, LnkFile As Object
    Dim DeskTopPath As String, LnkFileName As String
    
    Set WSH = CreateObject("WScript.Shell")
    DeskTopPath = WSH.SpecialFolders("Desktop")
    
    cnt = 0
    buf = Dir(DeskTopPath & "\*.lnk")
    Do While buf <> ""
        
      LnkFileName = DeskTopPath & "\" & buf
      ' ショートカットへのオブジェクト参照を作成
      Set LnkFile = WSH.CreateShortcut(LnkFileName)
      ' ショートカット先を、セルに書込み
      rng.Offset(cnt, 0) = LnkFile.TargetPath
        
      cnt = cnt + 1
      buf = Dir()       ' 次のファイル
    Loop
    
    Set LnkFile = Nothing
    Set WSH = Nothing
 
End Sub

' デスクトップのショートカットのリンク先を、アクティブセル以下に書込み
Sub ShortCutFromDeskTop使用例()
    Call ShortCutFromDesktop(ActiveCell)
End Sub