VB shortcut creator - Translate to PB?

[James Matt]

Can someone translate this VB shortcut creation code into PB. It works great in VB and would be nice to have for PB. I haven't gotten around to working with objects in PB yet.

Private Sub Command1_Click()
Dim wshShell As Object, lnkSendTo As Object
Set wshShell = CreateObject("WScript.Shell")
Set lnkSendTo = wshShell.CreateShortcut(wshShell.SpecialFolders("SendTo") & "\MyProg.lnk")
With lnkSendTo
.Description = "MyProg"
.TargetPath = "C:\Program Files\MyProg\MyProg.exe"
.WorkingDirectory = "C:\Program Files\MyProg"
.Save
End With
Set lnkSendTo = Nothing
Set wshShell = Nothing
End Sub

[José Roca]

The following example posted in my forum is very similar:

http://www.jose.it-berater.org/smfforum/index.php?topic=2180.msg6962#msg6962

Before you ask where you can find "WSHOM.INC", it is part of my Windows API headers package:

http://www.jose.it-berater.org/smfforum/index.php?board=344.0

If you don't want to use my headers, then you will have to generate your own include file with the PB COM Browser: choose the "Windows Script Host Object Model" type library (wshom.ocx).

Hope this helps!

[James Matt]

Jose,

Works like a charm. Thanks.

Jim

[Knuth Konrad]

There's also Semen's version, using direct API calls: http://www.powerbasic.com/support/pb...ad.php?t=23589

[Gösta H. Lovgren-2]

Here's Shortcut code I've been using for several years. Nowhere as neat and clean as Jose's but it works right now in PB (no special includes needed).

'****************************************************************************
'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'
==========================================================