Code:
'****************************************************************************
'Shortcut code below here
' all C&P'ed from POFFS - dunno who to credit
'-Note shortcut related functions begin with "z_sc_" to group together
' =======================================================================================
' IIDs for shortcut creator
' =======================================================================================
$CLSID_ShellLink = Guid$("{00021401-0000-0000-C000-000000000046}")
$IID_IShellLink = Guid$("{000214EE-0000-0000-C000-000000000046}")
$IID_IPersistFile = Guid$("{0000010B-0000-0000-C000-000000000046}")
%CLSCTX_INPROC_SERVER = &H1 ' Component is allowed in the same process space.
' =======================================================================================
' =======================================================================================
' Returns a pointer to a specified interface on an object to which a client currently
' holds an interface pointer.
' =======================================================================================
Function z_sc_IUnknown_QueryInterface _
(ByVal pthis As Dword Ptr, ByRef riid As Guid, ByRef ppvObj As Dword) As Long
Local HRESULT As Long
Call Dword @@pthis[0] Using z_sc_IUnknown_QueryInterface (pthis, riid, ppvObj) To HRESULT
Function = HRESULT
End Function
' =======================================================================================
' =======================================================================================
' Decrements the reference count for the calling interface on a object. If the reference
' count on the object falls to 0, the object is freed from memory.
' =======================================================================================
Function z_sc_IUnknown_Release _
(ByVal pthis As Dword Ptr) As Dword
Local DWRESULT As Dword
Call Dword @@pthis[2] Using z_sc_IUnknown_Release (pthis) To DWRESULT
Function = DWRESULT
End Function
' =======================================================================================
' =======================================================================================
' Retrieves the description string for a Shell link object.
' =======================================================================================
Function z_sc_IShellLink_SetDescription _
(ByVal pthis As Dword Ptr, ByRef pszName As Asciiz) As Long
Local HRESULT As Long
Call Dword @@pthis[7] Using z_sc_IShellLink_SetDescription (pthis, pszName) _
To HRESULT
Function = HRESULT
End Function
' =======================================================================================
' =======================================================================================
' Sets the name of the working directory for a Shell link object.
' =======================================================================================
Function z_sc_IShellLink_SetWorkingDirectory (ByVal pthis As Dword Ptr, ByRef pszDir As Asciiz) As Long
Local HRESULT As Long
Call Dword @@pthis[9] Using z_sc_IShellLink_SetWorkingDirectory (pthis, pszDir)_
To HRESULT
Function = HRESULT
End Function
' =======================================================================================
' =======================================================================================
' Sets the command-line arguments for a Shell link object.
' =======================================================================================
Function z_sc_IShellLink_SetArguments _
(ByVal pthis As Dword Ptr, ByRef pszArgs As Asciiz) As Long
Local HRESULT As Long
Call Dword @@pthis[11] Using z_sc_IShellLink_SetArguments (pthis, pszArgs) _
To HRESULT
Function = HRESULT
End Function
' =======================================================================================
' =======================================================================================
' Sets the show command for a Shell link object. The show command sets the initial show
' state of the window.
' =======================================================================================
Function z_sc_IShellLink_SetShowCmd _
(ByVal pthis As Dword Ptr, ByVal iShowCmd As Long) As Long
Local HRESULT As Long
Call Dword @@pthis[15] Using z_sc_IShellLink_SetShowCmd (pthis, iShowCmd) _
To HRESULT
Function = HRESULT
End Function
' =======================================================================================
' =======================================================================================
' Sets the path and file name of a Shell link object.
' =======================================================================================
Function z_sc_IShellLink_SetPath (ByVal pthis As Dword Ptr, ByRef pszFile As Asciiz) _
As Long
Local HRESULT As Long
Call Dword @@pthis[20] Using z_sc_IShellLink_SetPath (pthis, pszFile) _
To HRESULT
Function = HRESULT
End Function
' =======================================================================================
' =======================================================================================
' Saves the object into the specified file.
' =======================================================================================
Declare Function z_sc_Proto_IPersistFile_Save _
(ByVal pthis As Dword Ptr, _
ByVal pszFileName As Dword, _
ByVal fRemember As Long) As Long
' =======================================================================================
Function z_sc_IPersistFile_Save _
(ByVal pthis As Dword Ptr, _
ByVal strFileName As String, _
ByVal fRemember As Long) As Long
Local HRESULT As Long
Local pszFileName As Dword
If Len(strFileName) Then
strFileName = UCode$(strFileName) & $Nul
pszFileName = StrPtr(strFileName)
End If
Call Dword @@pthis[6] Using z_sc_Proto_IPersistFile_Save _
(pthis, pszFileName, fRemember) To HRESULT
Function = HRESULT
End Function
' =======================================================================================
'// Prototypes
Declare Function z_sc_IShellLink_Call0( ByVal pUnk As Long ) As Long
Declare Function z_sc_IShellLink_Call1( ByVal pUnk As Long, ByVal p1 As Long ) As Long
Declare Function z_sc_IShellLink_Call2( ByVal pUnk As Long, ByVal p1 As Long, ByVal p2 As Long ) As Long
Function z_sc_SpecialFolder(pidl As Dword) As String
' by Wayne Diamond 12-03-01
' [URL]http://www.powerbasic.com/support/forums/Forum7/HTML/001233.html[/URL]
Local TmpAsciiz As Asciiz * %MAX_PATH
CoInitialize ByVal 0
If IsFalse(SHGetSpecialFolderLocation(ByVal %HWND_DESKTOP, ByVal pidl, ByVal VarPtr(pidl))) Then
SHGetPathFromIDList ByVal pidl, TmpAsciiz
CoTaskMemFree ByVal pidl
End If
CoUninitialize
Function = TmpAsciiz
End Function
Function z_sc_createShortcut(CSIDL As Dword, link As String, source As String, workDir As String) As Long
' adapted from Edwin Knoppert's code 07-10-03
' [URL]http://www.powerbasic.com/support/forums/Forum7/HTML/001980.html[/URL]
'CSIDL - CSIDL_DESKTOP, CSIDL_PROGRAMS, CSIDL_STARTUP, etc
'link - link file to be created like "My calc.lnk"
'source - file/document where the shortcut should point to like "c:\windows\calc.exe".
'workDir - folder where the executable document/file should start in, best not to leave empty.
Local CLSID_ShellLink As String * 16
Local IID_IShellLink As String * 16
Local IID_Persist As String * 16
Local nResult As Long, pShellLnk As Dword Ptr, pPersist As Dword Ptr
Local sTarget As String, szUniLnkName As Asciiz * (2 * %MAX_PATH)
Local sArguments As String, sComment As String
CLSID_ShellLink = Mkl$(&H00021401) & Chr$(0, 0, 0, 0, &HC0, 0, 0, 0, 0, 0, 0, &H46)
IID_IShellLink = Mkl$(&H000214EE) & Chr$(0, 0, 0, 0, &HC0, 0, 0, 0, 0, 0, 0, &H46)
IID_Persist = Mkl$(&H0000010B) & Chr$(0, 0, 0, 0, &HC0, 0, 0, 0, 0, 0, 0, &H46)
sArguments = "": sComment = ""
CoInitialize ByVal 0&
If CoCreateInstance(ByVal VarPtr(CLSID_ShellLink), ByVal 0&, 1, ByVal VarPtr(IID_IShellLink), pShellLnk) = 0 Then
'// IShellLink::SetPath
Call Dword @@pShellLnk[20] Using z_sc_IShellLink_Call1(pShellLnk, StrPtr(source))
'// IShellLink::SetsArguments
Call Dword @@pShellLnk[11] Using z_sc_IShellLink_Call1(pShellLnk, StrPtr(sArguments))
'// IShellLink::SetWorkingDirectory
Call Dword @@pShellLnk[9] Using z_sc_IShellLink_Call1(pShellLnk, StrPtr(workDir))
'// IShellLink::SetnShowCmd
Call Dword @@pShellLnk[15] Using z_sc_IShellLink_Call1(pShellLnk, %SW_SHOW)
'// IShellLink::SetDescription
Call Dword @@pShellLnk[7] Using z_sc_IShellLink_Call1(pShellLnk, StrPtr(sComment))
'// Obtain persist interface (QueryInterface)
Call Dword @@pShellLnk[0] Using z_sc_IShellLink_Call2(pShellLnk, VarPtr(IID_Persist), VarPtr(pPersist))
If nResult = %S_OK Then
'// Convert to unicode
sTarget = z_sc_SpecialFolder(CSIDL) + "\" + link
MultiByteToWideChar %CP_ACP, 0, ByVal StrPtr(sTarget), Len(sTarget), ByVal VarPtr(szUniLnkName), %MAX_PATH * 2
'// IPersistFile::Save
Call Dword @@pPersist[6] Using z_sc_IShellLink_Call2(pPersist, VarPtr(szUniLnkName), 1)
'// Release
Call Dword @@pPersist[2] Using z_sc_IShellLink_Call0(pPersist)
End If
'// Release
Call Dword @@pShellLnk[2] Using z_sc_IShellLink_Call0(pShellLnk)
Function = -1
End If
CoUninitialize
End Function
'
' =======================================================================================
' Creates a shortcut
' =======================================================================================
Function z_sc_CreateLink ( _
ByVal csidl As Long _ ' // Value specifying the folder for which to retrieve the location.
, szLinkName As Asciiz _ ' // Name of the shortcut
, szExePath As Asciiz _ ' // Path of the executable file
, szArguments As Asciiz _ ' // Arguments
, szWorkingDir As Asciiz _ ' // Working directory
, ByVal nShowCmd As Dword _ ' // Show command flag
, szComment As Asciiz _ ' // Comment
) As Long
Local hr As Long ' // HRESULT
Local psl As Dword ' // IShellLink interface reference
Local ppf As Dword ' // IPersistFile interrace reference
Local CLSID_ShellLink As Guid ' // ShellLink class identifier
Local IID_IShellLink As Guid ' // IShellLink interface identifier
Local IID_IPersistFile As Guid ' // IPersistFile interface identifier
Local pidl As Dword ' // Item identifier list specifying the folder location
Local szFileName As Asciiz * %MAX_PATH ' // Name of the .LNK file
' // Fills the guids
CLSID_ShellLink = $CLSID_ShellLink
IID_IShellLink = $IID_IShellLink
IID_IPersistFile = $IID_IPersistFile
' // Creates an instance of the IShellLink interface
hr = CoCreateInstance(CLSID_ShellLink, ByVal %Null, %CLSCTX_INPROC_SERVER, IID_IShellLink, psl)
If hr <> %S_OK Then Exit Function
' // Sets the properties of the shortcut
hr = z_sc_IShellLink_SetPath(psl, szExePath)
hr = z_sc_IShellLink_SetArguments(psl, szArguments)
hr = z_sc_IShellLink_SetWorkingDirectory(psl, szWorkingDir)
hr = z_sc_IShellLink_SetShowCmd(psl, nShowCmd)
hr = z_sc_IShellLink_SetDescription(psl, szComment)
' // Retrieves a pointer to the IPersistFile interface
hr = z_sc_IUnknown_QueryInterface(psl, IID_IPersistFile, ppf)
If hr = %S_OK Then
' // Retrieves an item identifier list specifying the desktop folder location
hr = SHGetSpecialFolderLocation(%HWND_DESKTOP, csidl, pidl)
If hr = %NOERROR Then
' // Retrieves the path from the item identifier list
hr = SHGetPathFromIDList(ByVal pidl, szFileName)
' // Frees the memory allocated for the item identifier list
CoTaskMemFree pidl
If IsTrue(hr) Then
' // Full path
szFileName = szFileName & "\" & szLinkName & ".LNK"
' // Saves the shortcut file
hr = z_sc_IPersistFile_Save(ppf, szFileName, %TRUE)
End If
Function = %TRUE
End If
' // Releases the IPersistFile interface
z_sc_IUnknown_Release(ppf)
End If
' // Releases the IShellLink interface
z_sc_IUnknown_Release psl
End Function
' =======================================================================================
'-Note shortcut functions begin with "z_sc_"
'
Sub Create_Shortcut
Local hr As Long, _
csidl As Long , _
szLinkName As Asciiz * %Max_Path, _ ' // Name of the shortcut
szExePath As Asciiz * %Max_Path, _ ' // Path of the executable file
szArguments As Asciiz * %Max_Path, _ ' // Arguments
szWorkingDir As Asciiz * %Max_Path, _ ' // Working directory
nShowCmd As Dword , _ ' // Show command flag
szComment As Asciiz * %Max_Path ' // Comment
csidl = %CSIDL_DESKTOP
szLinkName = "Swede's Swiss Knife"
szExePath = CurDir$ & "\Z-Post.exe"
szArguments = ""
szWorkingDir = CurDir$
szComment = "Wonderful Program"
hr = z_sc_CreateLink(csidl, szLinkName, szExePath, _
szArguments, szWorkingDir, %SW_MAXIMIZE, szComment)
If IsTrue (hr)Then
? "See Desktop", %top, "Shortcut Created"
Else
MsgBox "CreateLink failed"
End If
End Sub
'End shortcut code
'****************************************************************************
'****************************************************************************
'****************************************************************************
"It's the repetition of affirmations that leads to belief.
And once that belief becomes a deep conviction,
things begin to happen."
Claude M. Bristol (1891-1951), 'The Magic of Believing'
==========================================================
Leave a comment: