開いているファイルのショートカットをデスクトップに作る VBA マクロ

' 開いているファイルのショートカットをデスクトップに作る
Sub CreateShortCut()
    
    Dim WSH As Object
    Dim objShortCut As Object
    
    ' ファイルが開かれているかどうか
    If Documents.Count = 0 Then
        MsgBox "ファイルが開かれていません。", vbExclamation
        Exit Sub
    End If
    
    ' ファイルが一回でも保存されているかどうか
    If Len(ActiveDocument.FullName) = 0 Then
        MsgBox "ファイルが保存されていません。ファイルを保存してください。", vbExclamation
    End If
    
    Set WSH = CreateObject("WScript.Shell")
    
    ' デスクトップにショートカットを作成
    Set objShortCut = WSH.CreateShortCut(WSH.SpecialFolders("Desktop") & "\" & ActiveDocument.Name & ".lnk")
    With objShortCut
        .TargetPath = ActiveDocument.FullName
        .WorkingDirectory = ActiveDocument.Path
        .Save
    End With
    
End Sub