XProfan

' PRFellow-Presentation
' Author: Thomas Hölzer - any rights vorbehalten
' IShellLink-interface and IPersistFile-interface
' here: Link-Files lay out
' needs Profan 7.0
' The Fehlerbehandlung watts the better Overview
' because of with Return-Sprüngen implementiert
' in the Fehlerfall becomes -1 zurückgegeben,
' with success whom OLE-Konventionen properly 0 (= NO_ERROR)
' The Parameter for CreateLinkFile are very(!) einzuhalten:
' 1: name with way the desired Linkdatei (*.lnk)
' 2: Dateiname with way, the verlinkt go should
' 3: Arbeitsverzeichnis or Leerstring
' 3: Start-Parameter or Leerstring
' 4: Optional: way the File, The the anzuzeigende Icon contains or Leerstring
' 5: Nullbasierter index the desired Icons
' 6: HotKey-worth or 0
' further Help: Suchwort IShellLink in OLE32.HLP
' or in the MSDN https://msdn.microsoft.com/default.asp
' with Search mind: IShellLink writes itself with 3 L!
Def CoInitialize(1) !"OLE32","CoInitialize"
Def CoUnInitialize(0) !"OLE32","CoUninitialize"
Def CoCreateInstance(5) !"OLE32","CoCreateInstance"
Def CLSIDFromString(2) !"OLE32","CLSIDFromString"
Def IIDFromString(2) !"OLE32","IIDFromString"
Def MultiByteToWideChar(6) !"KERNEL32","MultiByteToWideChar"
Def WideCharToMultiByte(8) !"KERNEL32","WideCharToMultiByte"
Def Succeeded(1) Gt(&(1),-1)
Declare CLSID_ShellLink$
CLSID_ShellLink$ = "{00021401-0000-0000-C000-000000000046}"
Declare SID_IShellLinkA$
SID_IShellLinkA$= "{000214EE-0000-0000-C000-000000000046}"
Declare IPersistFile$
IPersistFile$="{0000010B-0000-0000-C000-000000000046}"
Declare olestr#,clsid#,iid#
Declare pshellink#,ppersistfile#,ipersistfile#
Declare pislmethods#,pipfmethods#

Proc CleanupIShL

    Dispose olestr#
    Dispose pislmethods#
    Dispose pipfmethods#
    Dispose ppersistfile#
    Dispose ipersistfile#
    Dispose pshellink#
    Dispose clsid#
    Dispose iid#
    CoUnInitialize()

ENDPROC

Proc CreateLinkFile

    Parameters linkfile$,file$,workdir$,params$,icofile$,icoidx&,hotkey&
    Declare result%
    ' COM initialisieren
    Casenote Succeeded(CoInitialize(0)): Return -1
    Dim olestr#,261' must for IPersistFile so big his (MAX_PATH+1)
    Dim clsid#,16
    Dim iid#,16
    Dim pshellink#,4
    Dim ipersistfile#,4
    Dim ppersistfile#,16
    Dim pislmethods#,84
    Dim pipfmethods#,36
    ' ClassID and IID for IShellLink fetch
    Clear olestr#
    MultiByteToWideChar(1,1,Addr(CLSID_ShellLink$),Len(CLSID_ShellLink$),olestr#,261)

    Ifnot Succeeded(CLSIDFromString(olestr#,* Has#))

        CleanupIShL
        Return -1

    EndIf

    Clear olestr#
    MultiByteToWideChar(1,1,Addr(SID_IShellLinkA$),Len(SID_IShellLinkA$),olestr#,261)

    Ifnot Succeeded(IIDFromString(olestr#,IID#))

        CleanupIShL
        Return -1

    EndIf

    ' COM-Objekt produce and Zeiger on IShellLink-modes-scheduler

    Ifnot Succeeded(CoCreateInstance(* Has#,0,1,IID#,Addr(pshellink#)))

        CleanupIShL
        Return -1

    EndIf

    Let pislmethods# =Long(pshellink#,0)
    ' ClassID for IPersistFile fetch
    Clear olestr#
    MultiByteToWideChar(1,1,Addr(IPersistFile$),Len(IPersistFile$),olestr#,261)

    Ifnot Succeeded(IIDFromString(olestr#,ppersistfile#))

        CleanupIShL
        Return -1

    EndIf

    ' QueryInterface: IPersistFile-Zeiger fetch and Zeiger on modes

    Ifnot Succeeded(Call(Long(pislmethods#,0),pshellink#,ppersistfile#,Addr(ipersistfile#)))

        CleanupIShL
        Return -1

    EndIf

    pipfmethods#=Long(ipersistfile#,0)
    ' Dateiname the Linkdatei in WideString konvertieren
    Clear olestr#

    Ifnot Equ(MultiByteToWideChar(1,1,Addr(linkfile$),Len(linkfile$),olestr#,261),

        Len(LinkFile$))
        CleanupIShL
        Return -1

    EndIf

    ' the IShellLink-modes Call
    '.SetWorkDir
    Call(Long(pislmethods#,36),pshellink#,Addr(workdir$))
    '.SetArguments
    Call(Long(pislmethods#,44),pshellink#,Addr(params$))
    '.SetHotKey
    Call(Long(pislmethods#,52),pshellink#,hotkey&)
    '.SetIconLocation
    Call(Long(pislmethods#,68),pshellink#,Addr(icofile$),icoidx&)
    '.SetPath
    Call(Long(pislmethods#,80),pshellink#,Addr(file$))
    ' IPersistFile.Save
    Call(Long(pipfmethods#,24),ipersistfile#,olestr#,1)
    ' straighten up
    Call(Long(pipfmethods#,8),ipersistfile#)
    result%=Succeeded(Call(Long(pislmethods#,8),pshellink#))
    CleanupIShL
    Return hardship(result%)

ENDPROC

' example
Cls
CreateLinkFile "C:PRFTEST.LNK",Add$($WinPath,"EXPLORER.EXE"),"C:","","SHELL32.DLL",41,0

If Equ(%(0),0)

    Print "OK"

Else

    Print "Fehler"

EndIf

WaitInput