XProfan

' PRFellow-Vorlage
' Autor: Thomas Hölzer - Alle Rechte vorbehalten
' IShellLink-Interface und IPersistFile-Interface
' Hier: Link-Files anlegen
' Benötigt Profan 7.0
' Die Fehlerbehandlung wurde der besseren Panoramica
' wegen mit Return-Sprüngen implementiert
' Im Fehlerfall wird -1 zurückgegeben,
' bei Erfolg den OLE-Konventionen entsprechend 0 (= NO_ERROR)
' Die Parameter per CreateLinkFile sind genau(!) einzuhalten:
' 1: Name mit Pfad der gewünschten Linkdatei (*.lnk)
' 2: Dateiname mit Pfad, der verlinkt werden soll
' 3: Arbeitsverzeichnis oder Leerstring
' 3: Start-Parameter oder Leerstring
' 4: Optional: Pfad der File, die das anzuzeigende Icon enthält oder Leerstring
' 5: Nullbasierter Index des gewünschten Icons
' 6: HotKey-Wert oder 0
' Weitere Aiuto: Suchwort IShellLink in OLE32.HLP
' oder im MSDN https://msdn.microsoft.com/default.asp
' Bei Cerca beachten: IShellLink schreibt sich mit 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
    CaseNot Succeeded(CoInitialize(0)): Return -1
    Dim olestr#,261' muß per IPersistFile so grande sein (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 und IID per IShellLink holen
    Clear olestr#
    MultiByteToWideChar(1,1,Addr(CLSID_ShellLink$),Len(CLSID_ShellLink$),olestr#,261)

    IfNot Succeeded(CLSIDFromString(olestr#,CLSID#))

        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 erzeugen und Zeiger auf IShellLink-Methoden-Tabelle

    IfNot Succeeded(CoCreateInstance(CLSID#,0,1,IID#,Addr(pshellink#)))

        CleanupIShL
        Return -1

    EndIf

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

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

        CleanupIShL
        Return -1

    EndIf

    ' QueryInterface: IPersistFile-Zeiger holen und Zeiger auf Methoden

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

        CleanupIShL
        Return -1

    EndIf

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

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

        Len(LinkFile$))
        CleanupIShL
        Return -1

    EndIf

    ' Das IShellLink-Methoden aufrufen
    '.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)
    ' Aufräumen
    Call(Long(pipfmethods#,8),ipersistfile#)
    result%=Succeeded(Call(Long(pislmethods#,8),pshellink#))
    CleanupIShL
    Return Not(result%)

EndProc

' Beispiel
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