使用MS Access 2016 VBA修改Windows快捷方式路径问题求助

问题背景 #

尝试编写VBA程序修改用户桌面快捷方式的目标路径，调用语句如下：

ChangeShortcut "Test.lnk", "C:/users/environ$("username") & "/" & OneDrive-Personal/DBFolder/PMD_FE.accdb"

程序执行时在objfolder.ParseName(strNameOfShortCut)处卡住，无法找到目标快捷方式。原程序代码如下：

Public Sub ChangeShortcut(strNameOfShortCut As String, strNewShortcutTarget As String)

    Const ALL_USERS_DESKTOP = &H19&

    Dim objShell As Object 'shell As Shell32.shell
    Dim objfolder As Object 'Shell32.folder
    Dim objfolderItem As Object 'Shell32.folderItem
    Dim objShortcut As Object 'Shell32.ShellLinkObject
    Dim objShellLink As Object
     
   
    Set objShell = CreateObject("Shell.Application")
   
    Set objfolder = objShell.Namespace(ALL_USERS_DESKTOP)
    If Not objfolder Is Nothing Then
        Set objfolderItem = objfolder.ParseName(strNameOfShortCut)
        If Not objfolderItem Is Nothing Then
            Set objShortcut = objfolderItem.GetLink
            If Not objShortcut Is Nothing Then
                objShortcut.Path = strNewShortcutTarget    'To Change
                objShortcut.Save
                MsgBox "Shortcut changed"
            Else
                MsgBox "Shortcut link within file not found"
            End If
        Else
            MsgBox "Shortcut file not found"
        End If
    Else
        MsgBox "Desktop folder not found"
    End If
   
End Sub

故障排查与修复方案 #

1. 桌面路径指向错误 #

原代码使用ALL_USERS_DESKTOP（公共桌面，常量&H19&），但你明确说明快捷方式在当前用户桌面，导致程序去错误的目录查找文件。

• 修复：将常量替换为当前用户桌面的Shell命名空间常量USER_DESKTOP = &H10&，或者直接通过环境变量获取路径：Environ("USERPROFILE") & "\Desktop"

2. 调用语句的路径语法错误 #

你的调用参数中，目标路径的写法完全不符合VBA语法规范：

• VBA中获取用户名需用Environ("USERNAME")，而非嵌在字符串中的environ$("username")（会被当成普通文本）
• Windows路径分隔符应使用反斜杠\，而非正斜杠/
• OneDrive路径写法错误，需正确拼接完整路径
• 正确调用示例：

  ChangeShortcut "Test.lnk", Environ("USERPROFILE") & "\OneDrive - Personal\DBFolder\PMD_FE.accdb"
  

3. ParseName方法的有效性验证 #

若桌面路径包含特殊字符、快捷方式名称大小写不匹配或后缀名错误，都会导致ParseName返回Nothing。可添加调试代码确认路径：

Debug.Print "当前用户桌面路径：" & objfolder.Self.Path

检查该路径下是否确实存在Test.lnk文件。

4. 优化后的完整代码 #

Public Sub ChangeShortcut(strNameOfShortCut As String, strNewShortcutTarget As String)
    Const USER_DESKTOP = &H10& ' 当前用户桌面常量

    Dim objShell As Object
    Dim objfolder As Object
    Dim objfolderItem As Object
    Dim objShortcut As Object
     
    Set objShell = CreateObject("Shell.Application")
    Set objfolder = objShell.Namespace(USER_DESKTOP)
    
    If Not objfolder Is Nothing Then
        ' 调试输出当前桌面路径，确认目录正确性
        Debug.Print "当前用户桌面路径：" & objfolder.Self.Path
        
        Set objfolderItem = objfolder.ParseName(strNameOfShortCut)
        If Not objfolderItem Is Nothing Then
            Set objShortcut = objfolderItem.GetLink
            If Not objShortcut Is Nothing Then
                ' 先验证目标文件是否存在，避免无效路径
                If Dir(strNewShortcutTarget) <> "" Then
                    objShortcut.Path = strNewShortcutTarget
                    objShortcut.Save
                    MsgBox "快捷方式已修改"
                Else
                    MsgBox "目标文件不存在：" & strNewShortcutTarget
                End If
            Else
                MsgBox "无法获取快捷方式链接对象"
            End If
        Else
            MsgBox "未找到快捷方式文件：" & strNameOfShortCut & vbCrLf & "查找路径：" & objfolder.Self.Path
        End If
    Else
        MsgBox "无法访问用户桌面文件夹"
    End If
   
End Sub

内容的提问来源于stack exchange，提问作者plateriot