Create SendTo Shortcut

Category: Application Features

Date: 03-28-2012

Return to Index


 
'A shortcut is a *.lnk file which has a complex content. However, a URL shortcut
'(*.URL) has the same function as *.lnk, but its content is very simple.  Here's
'an example of a URL link, modified to point to a local file.
 
'Credit: Semen Matusovski
http://www.powerbasic.com/support/pbforums/showthread.php?t=23589
 
   [InternetShortcut]
   URL = C:\MyFolder\Test.Exe      'enclose in double-quotes if path has embedded spaces
   IconIndex=0
   IconFile=C:\MyFolder\Test.Exe
 
'An alternate format is:
 
   [InternetShortcut]
   URL = file:///c:\Data\xxx.Exe      'enclose in double-quotes if path has embedded spaces
   IconIndex = 0
   IconFile = c:\Data\xxx.Exe
 
'History of SendTo Folder
'The location of the SendTo folder has changed with each new release of Windows.
'    Win95/98
'    c:\Windows\sendto
 
'    XP
'    c:\Documents and Settings\username\SendTo
 
'    Vista/Win7
'    c:\users\gary\AppData\Roaming\Microsoft\Windows\SendTo
'    %userprofile%\AppData\Roaming\Microsoft\Windows\SendTo
'    %AppData%\Microsoft\Windows\SendTo
 
 
    'code modified from
    'http://www.vbforums.com/showthread.php?threadid=225479&highlight=shortcut+create
    Dim WshShell As New WshShell
    Dim oShellLink As WshShortcut
 
    'Create and save the shortcut
    'Here, it is important the the extension end by .lnk
    Set oShellLink = WshShell.CreateShortcut( "C:\TestLink.lnk" )
    With oShellLink
 
'Shortcut to which file (can be anything, .exe, .doc, ...)
        .TargetPath = "C:\WINNT\SYSTEM32\calc.exe"
        .WindowStyle = 1
        .IconLocation = "C:\WINNT\SYSTEM32\calc.exe, 0"
        .Arguments = ""
        .Save
    End With
 
    Set WshShell = Nothing
    Set oShellLink = Nothing
 
 
 
Sub Create_ShortCut(ByVal TargetPath As String, ByVal ShortCutPath As String, ByVal ShortCutname As String, Optional ByVal WorkPath As String, Optional ByVal Window_Style As Integer, Optional ByVal IconNum As Integer)
Dim VbsObj As Object
Set VbsObj = CreateObject("WScript.Shell")
Dim MyShortcut As Object
   ShortCutPath = VbsObj.SpecialFolders(ShortCutPath)
   MyShortcut = VbsObj.CreateShortcut(ShortCutPath & "\" & ShortCutname & ".lnk")
   MyShortcut.TargetPath = TargetPath
   MyShortcut.WorkingDirectory = WorkPath
   MyShortcut.WindowStyle = Window_Style
   MyShortcut.IconLocation = TargetPath & "," & IconNum
   MyShortcut.Save
End Sub
 
   #Compile EXE
   #Dim All
   #Register None
   #Include "Win32Api.Inc"
 
   Function PBMain
      MsgBox "Done"
   End Function
 
            'set *.lnk properties before sendign to SendTo folder
            LnkName = sPath + "\" + Exe.Name$ + ".lnk"
            LnkExePath = Exe.Full$
            LnkCmdLine = ""            'arguments, if any
            LnkWorkDir = Exe.Path$
            LnkIconPath = Exe.Full$
            LnkIconIdx = 0
            LnkShowCmd = %SW_ShowNormal
            LnkComment = ""            'comments, if any
 
            CreateLink LnkName, LnkExePath, LnkCmdLine, LnkWorkDir, LnkIconPath, LnkIconIdx, LnkShowCmd, LnkComment
 
 
'Compilable Example:
#Compiler PBWin 9, PBWin 10
#Compile EXE
#Dim All
#Include "Win32API.inc"
#Resource "gbsnippets.pbr"
 
Declare Function CoCreateInstanceS Lib "ole32.dll" Alias "CoCreateInstance" _
   (rclsid As GUID, ByVal pUnkOuter As DWord, ByVal dwClsContext As DWord, riid As GUID, ppv As DWordAs DWord
Declare Function VTbl (ByVal p1 As DWord, Optional ByVal p2 As DWord, ByVal p3 As DWordAs DWord
 
%CLSCTX_INPROC_SERVER = 1
Global hDlg As DWord
Global FileList() As String
 
Function PBMain() As Long
   Dialog New Pixels, 0, "Convert",300,300,450,240, %WS_OverlappedWindow To hDlg
   Dialog Set Icon hDlg, "aainfo"
   Control Add Button, hDlg, 100,"Create SendTo Shortcut", 20,10,150,20
   Control Add Button, hDlg, 300,"Convert To Lower Case", 20,40,150,20
   Control Add Button, hDlg, 400,"Convert To Upper Case", 190,40,150,20
   Control Add TextBox, hDlg, 200, "Command$ was empty!", 20,70,410,150, %ES_MultiLine Or %WS_Border
   Dialog Show Modal hDlg Call DlgProc
End Function
 
CallBack Function DlgProc() As Long
   Local sPath As Asciiz * %MAX_PATH, temp, DL As String, i, LnkIconIdx, LnkShowCmd As Long
   Local LnkName, LnkTitle, LnkExePath, LnkCmdLine, LnkWorkDir, LnkIconPath, LnkComment As String
   Select Case CB.Msg
      Case %WM_InitDialog
         If Command$ <> "Then
            temp = LCase$(Command$)                                     'work with lower case
            Replace $Dq With "" In temp                                 'remove " characters
            DL =  Mid$(temp,Instr(temp,":")-1,1) + ":"                  'figure out drive letter
            ReDim FileList(ParseCount(temp,DL))                         'will contain list of files
            Parse temp, FileList(),DL                                   'fill array using Command$
            For i = 1 To UBound(FileList) : FileList(i) = DL + FileList(i) : Next   'restore "c:" to each Item
               Array Delete FileList(UBound(FileList)) : Array Delete FileList(0)      'remove artifacts of Parse
               Control Set Text hDlg, 200, "Command$ Content (lower case): " + $CrLf + $CrLf + Join$(FileList(),$CrLf)
         End If
      Case %WM_Command
         Select Case CB.Ctl
            Case 100
               SHGetFolderPath(0, %CSIDL_SendTo, 0, 0, sPath)           'get SendTo folder
               CreateLink sPath+"\"+Exe.Name$+".lnk",Exe.Full$,"",Exe.Path$,Exe.Full$,0,%SW_ShowNormal,""  'create shortcut
            Case 300
               If UBound(FileList) = -1 Then Exit Function    'no entries
               If MsgBox("Rename as lower case?", %MB_OkCancel, "Lower Case") = %IDOK Then
                  For i = 0 to UBound(FileList) : Name FileList(i) As LCase$(FileList(i)) : Next i
               End If
            Case 400
               If UBound(FileList) = -1 Then Exit Function    'no entries
               If MsgBox("Rename as upper case?", %MB_OkCancel, "Upper Case") = %IDOK Then
                  For i = 0 to UBound(FileList) : Name FileList(i) As UCase$(FileList(i)) : Next i
               End If
         End Select
   End Select
End Function
 
Function CreateLink (szLnkPath As String, szExePath As String, szCmdLine As String, szWorkDir As String, _
      szIconPath As String, ByVal iIcon As DWord, ByVal ShowCmd As DWord, Comment As StringAs DWord
 
   Local TmpWide As String
   Local pidl, lResult  As DWord
   Local psl, ppf, pp As DWord Ptr       'IShellLink interface, IPersistFile interface, VTbl function address
   Local CLSID_ShellLink, IID_IShellLink, IID_Persist As GUID
 
   CLSID_ShellLink = Guid$("{00021401-0000-0000-C000-000000000046}")
   IID_IShellLink  = Guid$("{000214EE-0000-0000-C000-000000000046}")
   IID_Persist     = Guid$("{0000010B-0000-0000-C000-000000000046}")
 
   ' Get a pointer to the IShellLink interface
   If IsFalse(CoCreateInstanceS (CLSID_ShellLink, %Null, %CLSCTX_INPROC_SERVER, IID_IShellLink, psl)) Then
      CoInitialize ByVal 0
 
      ' Set the path to the shortcut target and fill some other fields
      pp = @psl + 80: Call DWord @pp Using VTbl (psl, StrPTR(szExePath))         ' psl->SetPath
      pp = @psl + 44: Call DWord @pp Using VTbl (psl, StrPTR(szCmdLine))         ' psl->SetArguments
      pp = @psl + 36: Call DWord @pp Using VTbl (psl, StrPTR(szWorkDir))         ' psl->SetWorkingDirectory
      pp = @psl + 60: Call DWord @pp Using VTbl (psl, ShowCmd)                   ' psl->SetShowCmd
      pp = @psl + 28: Call DWord @pp Using VTbl (psl, StrPTR(Comment))           ' psl->SetDescription
      pp = @psl + 68: Call DWord @pp Using VTbl (psl, StrPTR(szIconPath), iIcon) ' psl->SetSetIconLocation
 
      ' Query IShellLink for the IPersistFile interface for saving the shortcut in persistent storage.
      pp = @psl     : Call DWord @pp Using VTbl (psl, ByRef IID_PERSIST, ByRef ppf) To lResult
      If lResult = 0 Then
         ' Ensure that the string is Unicode
         lResult = Len(szLnkPath): TmpWide = String$(lResult + lResult + 1, 0)
         MultiByteToWideChar %CP_ACP, 0, ByVal StrPTR(szLnkPath), lResult, ByVal StrPTR(TmpWide), %MAX_PATH
         ' Save the link by calling IPersistFile::Save
         pp = @ppf + 24: Call DWord @pp Using VTbl (ppf, ByVal StrPTR(TmpWide), 1) To lResult: If lResult = %S_OK Then Function = 1
         pp = @ppf + 8: Call DWord @pp Using VTbl (ppf) ' ppf->Release()
      End If
      pp = @psl + 8: Call DWord @pp Using VTbl (psl)    ' psl->Release()
 
      SHChangeNotify %SHCNE_ALLEVENTS, %SHCNF_FLUSH, ByVal 0, ByVal 0
      CoUninitialize
 
   End If
End Function
 
'gbs_00566


created by gbSnippets
http://www.garybeene.com/sw/gbsnippets.htm