FreeBasic

Пример того, как можно создать ярлык своей программы на рабочем столе.

Автор: v1ctor
Платформа: Windows

#INCLUDE Once "windows.bi"
#INCLUDE Once "win/shlobj.bi"

Declare Function hStripFilePath( Byval filename As Zstring Ptr ) As String
Declare Function hStripFileExt( Byval filename As Zstring Ptr ) As String

Declare Function createDestopShortcut( Byval TargetName As Zstring Ptr, _
Byval LinkName As Zstring Ptr ) As Integer


'' main
Randomize Timer

'' create a desktop shortcut to itself
createDestopShortcut( Exepath( ) & "\" & hStripFileExt( __FILE__ ) & ".exe", _
"FB Created Link #" & Cint( Rnd * 100 ) & ".lnk" )



'':::::
Function createDestopShortcut( Byval TargetName As Zstring Ptr, _
    Byval LinkName As Zstring Ptr ) As Integer
    Dim As IShellLink Ptr ISLink
    Dim As IPersistFile Ptr IPFile
    Dim As LPITEMIDLIST PIDL
    Dim As Zstring * MAX_PATH InFolder

    Function = FALSE

    ''
    CoInitialize( NULL )

    ''
    SHGetSpecialFolderLocation( 0, CSIDL_DESKTOPDIRECTORY, @PIDL )
    SHGetPathFromIDList( PIDL, InFolder )

    ''
    CoCreateInstance( @CLSID_ShellLink, NULL, CLSCTX_INPROC_SERVER, @IID_IShellLink, @ISLink )

    IShellLinkA_SetPath( ISLink, TargetName )
    IShellLinkA_SetWorkingDirectory( ISLink, hStripFilePath( TargetName ) )

    ''
    IShellLinkA_QueryInterface( ISLink, @IID_IPersistFile, @IPFile )

    IPersistFile_Save( IPFile, InFolder + "\" + *LinkName, 0 )

    ''
    IPersistFile_Release( IPFile )

    IShellLinkA_Release( ISLink )

    CoUninitialize( )

    Function = TRUE

End Function



'':::::
Private Function hStripFilePath( Byval filename As Zstring Ptr ) As String Static
    Dim As Integer lp, p

    lp = 0
    Do
        p = Instr( lp+1, *filename, "\" )
        If p=0 Then
            Exit Do
        End If
        lp = p
    Loop

    If( lp > 0 ) Then
        Function = Mid( *filename, lp+1 )
    Else
        Function = *filename
    End If

End Function

'':::::
Private Function hStripFileExt( Byval filename As Zstring Ptr ) As String Static
    Dim p As Integer, lp As Integer

    lp = 0
    Do
        p = Instr( lp+1, *filename, "." )
        If( p = 0 ) Then
            Exit Do
        End If
        lp = p
    Loop

    If( lp > 0 ) Then
        Function = Left( *filename, lp-1 )
    Else
        Function = *filename
    End If

End Function