Question

我无法在网上找到有关此问题的任何有用信息。有人能指出我正确的方向吗？以下是我到目前为止的情况：

Option Explicit


'Const CSIDL_COMMON_PROGRAMS = &H17
Dim ShellApp, FSO, Desktop
Set ShellApp = CreateObject("Shell.Application")
Set FSO = CreateObject("Scripting.FileSystemObject")

'Set StartMenuFolder = ShellApp.NameSpace(CSIDL_COMMON_PROGRAMS)
Set Desktop =  ShellApp.NameSpace("C:\Users\myUser\Desktop")

Dim LnkFile
LnkFile = Desktop.Self.Path & "\myTest.lnk"

If(FSO.FileExists(LnkFile)) Then
    Dim tmp, verb
    'For Each verb in Desktop.ParseName("myTest.lnk").Verbs
        'tmp = tmp&verb&chr(13)
    'Next
    'MsgBox(tmp)

    Dim desktopImtes, item
    Set desktopImtes = Desktop.Items()

    For Each item in desktopImtes
        If (item.Name = "myTest") Then
            'MsgBox(item.Name)
            For Each verb in item.Verbs
                If (verb.Name = "Pin to Tas&kbar") Then
                    verb.DoIt
                End If
            Next
        End If
    Next

End If

Set FSO = Nothing
Set ShellApp = Nothing

当我浏览每个verb.name时，"Pin to Tas&kbar"永远不会出现。这是一个已知的问题吗？

编辑：这是我的第二次尝试：

Dim objShell, objAllUsersProgramsFolder, strAllUsersProgramsPath, objFolder, objFolderItem, colVerbs, objVerb
Const CSIDL_COMMON_PROGRAMS = &H17
Set objShell = CreateObject("Shell.Application")
Set objAllUsersProgramsFolder = objShell.Namespace("C:\Users\myUser\Desktop")
strAllUsersProgramsPath = objAllUsersProgramsFolder.Self.Path
Set objFolder = objShell.Namespace(strAllUsersProgramsPath)
Set objFolderItem = objFolder.ParseName("myTest.lnk")
Set objVerb = objFolderItem.Verbs '''!! this line is where it fails !!'''
For Each objVerb In colVerbs
    If Replace(objVerb.Name, "&", "") = "Pin to Taskbar" Then objVerb.DoIt
Next

标记的行显示错误所在的位置。错误说明：

Object variable or With block variable not set.

可能有助于注意该链接指向访问数据库。

Answer 1

我认为主要问题是一个常见的问题 - 代码是从Google搜索结果中复制/粘贴的，而不是试图理解它 - 甚至做基本的麻烦以确定它是否有效 - 或者它是如何产生的工作。

您所做的就是直接从this codeproject url或其他复制/粘贴此代码的网站进行复制。注释掉的代码仍然完好无损。

看起来你在第二次尝试时也做了同样的事情，但是我甚至不会看那个，因为它有半个尝试同样的基本错误

两个代码示例的最大问题是：

变量被变暗为变体 - 当重要变量时对象。

尝试的最大问题是：

您没有使用调试语句进行调试或故障排除。

我已使用变量声明和调试代码清理此子目录，以确定代码可能失败的位置。更改顶部的常量以匹配您的用户和文件名 - 确保右键单击快捷方式并查看属性以确保路径正确。

试试这个，希望msgbox和debug语句能指出你的问题。我认为这将是一个简单的路径或文件名错误。

Option Explicit

Public Sub PinApp()

    Const DESKTOP_USER      As String = "Public" ' username shown in file properties
    Const SHORTCUT_FILE     As String = "My Shortcut"

    Dim objShellApp         As Object ' Shell Application
    Dim objFSO              As Object ' FileSystemObject
    Dim objDesktop          As Object ' Folder
    Dim objDesktopItems     As Object

    Dim varVerb             As Variant
    Dim varItem             As Variant

    Dim strShortcut         As String

    Dim blFound             As Boolean
    Dim blPinned            As Boolean

    Set objShellApp = CreateObject("Shell.Application")
    Set objFSO = CreateObject("Scripting.FileSystemObject")

    Set objDesktop = objShellApp.NameSpace("C:\Users\" & DESKTOP_USER & "\Desktop")

    strShortcut = objDesktop.Self.Path & "\" & SHORTCUT_FILE & ".lnk"

    blFound = False
    blPinned = False

    ' Check first to see if Shortcut File exists
    If (objFSO.FileExists(strShortcut)) Then

        Set objDesktopItems = objDesktop.Items()

        For Each varItem In objDesktopItems

            If (varItem.Name = SHORTCUT_FILE) Then
Debug.Print "Found Shortcut"
                blFound = True
                For Each varVerb In varItem.Verbs
Debug.Print varVerb.Name
                    If (varVerb.Name = "Pin to Tas&kbar") Then
                        varVerb.DoIt
                        blPinned = True
                        ' no sense continuing - we found what we're looking for
                        MsgBox "Shortcut File Pinned"
                        Exit For
                    End If
                Next
                ' no sense continuing - we found what we're looking for
                Exit For
            End If
        Next

        If Not blFound Then
            MsgBox "Shortcut File Not Found in Desktop Items: " & strShortcut
        ElseIf Not blPinned Then
            MsgBox "Failed to find Pin To Taskbar"
        End If
    Else
        MsgBox "Missing Shortcut File: " & strShortcut
    End If

    Set objFSO = Nothing
    Set objShellApp = Nothing
End Sub

如何将访问数据库文件固定到用户的任务栏？

1 个答案: