Date: 02-16-2022
Return to Index
created by gbSnippets
'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
%Unicode=1
#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: (Jose Includes)
#Compiler PBWin 9, PBWin 10
#Compile EXE
#Dim All
%Unicode=1
#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 DWord) As DWord
Declare Function VTbl (ByVal p1 As DWord, Optional ByVal p2 As DWord, ByVal p3 As DWord) As 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 String) As 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
http://www.garybeene.com/sw/gbsnippets.htm