'-------------------------------------------------------------------------------------------------
' Routines to create a Windows shortcut
'-------------------------------------------------------------------------------------------------
DECLARE FUNCTION IShellLink_Call0(BYVAL pUnk AS LONG) AS LONG
DECLARE FUNCTION IShellLink_Call1(BYVAL pUnk AS LONG, BYVAL p1 AS LONG) AS LONG
DECLARE FUNCTION IShellLink_Call2(BYVAL pUnk AS LONG, BYVAL p1 AS LONG, BYVAL p2 AS LONG) AS LONG
DECLARE FUNCTION CoInitialize LIB "ole32.dll" ALIAS "CoInitialize" (pvReserved AS ANY) AS LONG
DECLARE SUB      CoUninitialize LIB "ole32.dll" ALIAS "CoUninitialize" ()
DECLARE FUNCTION CoCreateInstance LIB "ole32.dll" ALIAS "CoCreateInstance" (rclsid AS GUIDAPI, pUnkOuter AS ANY, BYVAL dwClsContext AS DWORD, riid AS GUIDAPI, ppv AS DWORD) AS LONG
'-------------------------------------------------------------------------------------------------
FUNCTION CreateShortcut( _
      BYVAL sTargetLinkName AS STRING _
    , BYVAL sSourceFileName AS STRING _
    , BYVAL sArguments      AS STRING _
    , BYVAL sWorkDir        AS STRING _
    , BYVAL nShowCmd        AS LONG _
    , BYVAL sIconFile       AS STRING _
    , BYVAL nIconIndex      AS LONG _
    , BYVAL sComment        AS STRING _
    ) AS LONG

    LOCAL CLSID_ShellLink AS STRING * 16
    LOCAL IID_IShellLink  AS STRING * 16
    LOCAL IID_Persist     AS STRING * 16
    LOCAL nResult         AS LONG
    LOCAL pShellLnk       AS DWORD PTR
    LOCAL pPersist        AS DWORD PTR

    ' IShellLink interface
    ' IID = 000214EE-0000-0000-C000-000000000046
    ' Inherited interface = IUnknown

    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)
    sTargetLinkName = UCODE$(sTargetLinkName)

    CALL 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 IShellLink_Call1(pShellLnk, STRPTR(sSourceFileName))
        ' IShellLink::SetsArguments
        CALL DWORD @@pShellLnk[11] USING IShellLink_Call1(pShellLnk, STRPTR(sArguments))
        ' IShellLink::SetWorkingDirectory
        CALL DWORD @@pShellLnk[9] USING IShellLink_Call1(pShellLnk, STRPTR(sWorkDir))
        ' IShellLink::SetnShowCmd
        CALL DWORD @@pShellLnk[15] USING IShellLink_Call1(pShellLnk, nShowCmd)
        ' IShellLink::SetDescription
        CALL DWORD @@pShellLnk[7] USING IShellLink_Call1(pShellLnk, STRPTR(sComment))
        ' Obtain persist interface (QueryInterface)
        CALL DWORD @@pShellLnk[0] USING IShellLink_Call2(pShellLnk, VARPTR(IID_Persist), VARPTR(pPersist))
         ' IShellLink::SetIconLocation
        CALL DWORD @@pShellLnk[17] USING IShellLink_Call2(pShellLnk, STRPTR(sIconFile), 0)

        IF nResult = 0 THEN
            ' Convert to unicode
            ' IPersistFile::Save
            CALL DWORD @@pPersist[6] USING IShellLink_Call2(pPersist, STRPTR(sTargetLinkName), 1)
            ' Release
            CALL DWORD @@pPersist[2] USING IShellLink_Call0(pPersist)
        END IF

        ' Release
        CALL DWORD @@pShellLnk[2] USING IShellLink_Call0(pShellLnk)
        FUNCTION = -1
    END IF

    CALL CoUninitialize()
END FUNCTION
'-------------------------------------------------------------------------------------------------