Announcement

Collapse
No announcement yet.

Need Help to Modify Pinning Shortcut VBScript

Collapse
X
  • Filter
  • Time
  • Show
Clear All
new posts

  • Need Help to Modify Pinning Shortcut VBScript

    Hi,

    Rems resolved an issue for me by using this code below. You can read the thread by clicking the link below.

    http://forums.petri.com/showthread.php?t=65971

    Code:
    Set WshShell = CreateObject("WScript.Shell")
    Set objShell = CreateObject("Shell.Application")
    
    strTartgetFile = "\\files\DATA\HR\Phone List\PhoneList\PHONELST.pdf"
    
    ShortcutName   = "PHONELST"
    ShortcutFolder = WshShell.SpecialFolders.Item("Desktop")
    ShortcutFile = ShortcutName & ".lnk"
    
    call PinToTaskbar("unpin")
    
    FilePath = ShortcutFolder & "\" & ShortcutFile
    
    With WshShell.CreateShortcut(FilePath)
       .TargetPath = GetProgramAssocWith("PDF")
       .Arguments = """" & strTartgetFile & """"
       .WorkingDirectory = "."
       .IconLocation = "imageres.dll, 124"
       .Description = "..."
       .Save
    End With
    
    call PinToTaskbar("pin") : WScript.Sleep 950
    
    Set objFSO = CreateObject("Scripting.FileSystemObject")
    objFSO.DeleteFile(FilePath), true
    
    wscript.quit
    
    Function GetProgramAssocWith(strExt)
       Const HKCR=&H80000000
       Const HKCU=&H80000001
       Set objReg = GetObject("winmgmts:\\.\root\default:StdRegProv")
    
       strExt = Replace(strExt,"*","")
       If Left(strExt,1) <> "." Then strExt = "." & strExt
    
       strPath = "Software\Microsoft\Windows\CurrentVersion\Explorer\FileExts\" & strExt & "\UserChoice"
       objReg.GetExpandedStringValue HKCU, strPath, "Progid", strValue
       If IsNull(strValue) Then
         objReg.GetExpandedStringValue HKCR, strExt, strEntry, strValue
       End If
       If IsNull(strValue) Then wscript.quit
    
       strPath = strValue & "\shell\open\command"
       objReg.GetExpandedStringValue HKCR, strPath, strEntry, strValue
       strValue = Replace(strValue, """", "")
    
     ' http://www.akaplan.com/blog/2010/12/...ile-extension/
       If InStr(strValue,"rundll") Then
        Dim tArray
        tArray = split(strValue,",")
        GetProgramAssocWith = replace(tArray(0),"rundll32.exe","")
       Else
        strValue = LCase(strValue)
        GetProgramAssocWith = Left(strValue,instrrev(strValue,".exe")+3)
       End If
    End Function
    
    Sub PinToTaskbar(choice)
    
       On Error Resume Next
    
       If Lcase(choice) = "unpin" then
    
         LnkFolder = WshShell.SpecialFolders.Item("AppData")
         LnkFolder = LnkFolder & "\Microsoft\Internet Explorer\Quick Launch\User Pinned\TaskBar"
         LnkFile = ShortcutName & ".lnk"
    
         Set objFolder = objShell.Namespace(LnkFolder)
         Set objFolderItem = objFolder.ParseName(LnkFile)
         Set colVerbs = objFolderItem.Verbs 
         For Each objVerb in colVerbs
           Select Case Replace(objVerb.name, "&", "")
             case "Unpin from Taskbar" objVerb.DoIt
             case "other language ..." objVerb.DoIt
             case "other language ..." objVerb.DoIt
             case "other language ..." objVerb.DoIt
           End Select
         Next
    
       ElseIf Lcase(choice) = "pin" then
    
         Set objFolder = objShell.Namespace(ShortcutFolder)
         Set objFolderItem = objFolder.ParseName(ShortcutFile)
         Set colVerbs = objFolderItem.Verbs
         For Each objVerb in colVerbs
           Select Case Replace(objVerb.name, "&", "")
             case "Pin to Taskbar" objVerb.DoIt
             case "Ajouter au menu Démarrer" objVerb.DoIt
             case "Aggiungi a menu Start" objVerb.DoIt
             case "An Startmenü anheften" objVerb.DoIt
             case "Aan het menu Start vastmaken" objVerb.DoIt
             case "Associar ao Menu Iniciar" objVerb.DoIt
             case "Anclar al menú Inicio" objVerb.DoIt
           End Select
         Next
    
       End If
    End Sub

    This works very well but I would like if someone can just modify the code just a bit. Currently to open up pdf files on the user's computer it uses the defaulted Adobe Acrobat program, so the code uses the defaulted pdf program and create a shortcut on the users taskbar. Can the code be modify to use the Adobe Reader application instead, if NOT found, then use the Adobe Acrobat application.

    Adobe Reader:

    C:\Program Files (x86)\Adobe\Reader 10.0\Reader\AcroRd32.exe

    Adobe Acrobat:
    C:\Program Files (x86)\Adobe\Acrobat 11.0\Acrobat\Acrobat.exe

    Any help?
    Attached Files
    Last edited by Rems; 16th February 2015, 10:19. Reason: replaced [Quote]-tags w/ [Code]-tags

  • #2
    Re: Need Help to Modify Pinning Shortcut VBScript

    See the part in Orange from the example below. You can adjust this part as you want.
    • The first orange line is where the path to the executable is hard coded (the path you provided).
    • The second line is where it retrieves the actual program path of AcroRd32.exe from registry, in cases were the OS is 32-bit instead of 64 or when a new or older version of the reader was installed.
    • The third checks if AcroRd32.exe really exists at the provided/retrieved program path. If not exist then the user's default program voor opening PDFs will be used instead of AcroRd32.exe.



    Code:
    Set WshShell = CreateObject("WScript.Shell")
    Set objShell = CreateObject("Shell.Application")
    Set objFSO = CreateObject("Scripting.FileSystemObject")
    
    strTartgetFile = "\\files\DATA\HR\Phone List\PhoneList\PHONELST.pdf"
    
    ShortcutName   = "PHONELST"
    ShortcutFolder = WshShell.SpecialFolders.Item("Desktop")
    ShortcutFile = ShortcutName & ".lnk"
    
    On Error Resume Next
    AppPath = "C:\Program Files (x86)\Adobe\Reader 11.0\Reader\AcroRd32.exe"
    AppPath = WshShell.Regread("HKLM\SOFTWARE\Microsoft\Windows\CurrentVersion\App Paths\AcroRd32.exe\")
    If (objFSO.FileExists(AppPath)=False) Then AppPath = GetProgramAssocWith("PDF")
    On Error Goto 0
    
    call PinToTaskbar("unpin")
    
    FilePath = ShortcutFolder & "\" & ShortcutFile
    
    With WshShell.CreateShortcut(FilePath)
       .TargetPath = AppPath
       .Arguments = """" & strTartgetFile & """"
       .WorkingDirectory = "."
       .IconLocation = "imageres.dll, 124"
       .Description = "..."
       .Save
    End With
    
    call PinToTaskbar("pin") : WScript.Sleep 950
    
    objFSO.DeleteFile(FilePath), true
    
    wscript.quit
    
    Function GetProgramAssocWith(strExt)
       Const HKCR=&H80000000
       Const HKCU=&H80000001
       Set objReg = GetObject("winmgmts:\\.\root\default:StdRegProv")
    
       strExt = Replace(strExt,"*","")
       If Left(strExt,1) <> "." Then strExt = "." & strExt
    
       strPath = "Software\Microsoft\Windows\CurrentVersion\Explorer\FileExts\" & strExt & "\UserChoice"
       objReg.GetExpandedStringValue HKCU, strPath, "Progid", strValue
       If IsNull(strValue) Then
         objReg.GetExpandedStringValue HKCR, strExt, strEntry, strValue
       End If
       If IsNull(strValue) Then wscript.quit
    
       strPath = strValue & "\shell\open\command"
       objReg.GetExpandedStringValue HKCR, strPath, strEntry, strValue
       strValue = Replace(strValue, """", "")
    
     ' http://www.akaplan.com/blog/2010/12/...ile-extension/
       If InStr(strValue,"rundll") Then
        Dim tArray
        tArray = split(strValue,",")
        GetProgramAssocWith = replace(tArray(0),"rundll32.exe","")
       Else
        strValue = LCase(strValue)
        GetProgramAssocWith = Left(strValue,instrrev(strValue,".exe")+3)
       End If
    End Function
    
    Sub PinToTaskbar(choice)
    
       On Error Resume Next
    
       If Lcase(choice) = "unpin" then
    
         LnkFolder = WshShell.SpecialFolders.Item("AppData")
         LnkFolder = LnkFolder & "\Microsoft\Internet Explorer\Quick Launch\User Pinned\TaskBar"
         LnkFile = ShortcutName & ".lnk"
    
         Set objFolder = objShell.Namespace(LnkFolder)
         Set objFolderItem = objFolder.ParseName(LnkFile)
         Set colVerbs = objFolderItem.Verbs 
         For Each objVerb in colVerbs
           Select Case Replace(objVerb.name, "&", "")
             case "Unpin from Taskbar" objVerb.DoIt
             case "other language ..." objVerb.DoIt
             case "other language ..." objVerb.DoIt
             case "other language ..." objVerb.DoIt
           End Select
         Next
    
       ElseIf Lcase(choice) = "pin" then
    
         Set objFolder = objShell.Namespace(ShortcutFolder)
         Set objFolderItem = objFolder.ParseName(ShortcutFile)
         Set colVerbs = objFolderItem.Verbs
         For Each objVerb in colVerbs
           Select Case Replace(objVerb.name, "&", "")
             case "Pin to Taskbar" objVerb.DoIt
             case "Ajouter au menu Démarrer" objVerb.DoIt
             case "Aggiungi a menu Start" objVerb.DoIt
             case "An Startmenü anheften" objVerb.DoIt
             case "Aan het menu Start vastmaken" objVerb.DoIt
             case "Associar ao Menu Iniciar" objVerb.DoIt
             case "Anclar al menú Inicio" objVerb.DoIt
           End Select
         Next
    
       End If
    End Sub
    Last edited by Rems; 16th February 2015, 11:56.

    This posting is provided "AS IS" with no warranties, and confers no rights.

    __________________

    ** Remember to give credit where credit's due **
    and leave Reputation Points for meaningful posts

    Comment


    • #3
      Re: Need Help to Modify Pinning Shortcut VBScript

      Thank you Rems. It works great.

      One other thing some users have Adobe Reader 10.0 or 11.0. Look at the program path below.

      Adobe Reader:
      C:\Program Files (x86)\Adobe\Reader 10.0\Reader\AcroRd32.exe

      Or

      C:\Program Files (x86)\Adobe\Reader 11.0\Reader\AcroRd32.exe

      So I change one thing in your code to act as a wildcard. using "*" .I ran the VBSafter adding the asterisk and it ran just fine, but is that the proper way of doing it?

      Code:
      AppPath = "C:\Program Files (x86)\Adobe\Reader*\Reader\AcroRd32.exe"

      Comment


      • #4
        Re: Need Help to Modify Pinning Shortcut VBScript

        Originally posted by Shazam View Post
        So I change one thing in your code to act as a wildcard. using "*" .I ran the VBSafter adding the asterisk and it ran just fine, but is that the proper way of doing it?

        Code:
        AppPath = "C:\Program Files (x86)\Adobe\Reader*\Reader\AcroRd32.exe"
        Wildcards in the string is not supported. With the * the file path has become unvalid.

        The AppPath variable is actually defined for a second time by the second orange line is where it retrieves the program path of AcroRd32.exe from registry.

        Basically the the first orange line is in most cases fully redundant.


        /Rems

        This posting is provided "AS IS" with no warranties, and confers no rights.

        __________________

        ** Remember to give credit where credit's due **
        and leave Reputation Points for meaningful posts

        Comment


        • #5
          Re: Need Help to Modify Pinning Shortcut VBScript

          Originally posted by Rems View Post
          Wildcards in the string is not supported. With the * the file path has become unvalid.

          The AppPath variable is actually defined for a second time by the second orange line is where it retrieves the program path of AcroRd32.exe from registry.

          Basically the the first orange line is in most cases fully redundant.


          /Rems
          Thanks!

          Once again thank you so much for your help.

          Comment


          • #6
            Hi,
            Can the code be modified to work with Windows 10?

            Any help?

            Comment


            • #7
              Have you tried running it on a Windows 10 PC??

              What happens??

              Comment


              • #8
                Originally posted by wullieb1 View Post
                Have you tried running it on a Windows 10 PC??

                What happens??
                Yes. I ran it and nothing happens. I've been researching online and it seems other scripts like powershell is also having this problem.

                Comment

                Working...
                X