Desktop Icon placed by VBA

[coasterfreak]

I have been trying to get a desktop Icon placed through the use of VBA. I have found and use code from http://www.vbaexpress.com/kb/getarticle.php?kb_id=584 . and it works with just a little change. my problem is the icon is a blank icon with no picture. I would like to be able to place a pic. or icon from list as the pic (The Excell look icon will work). Any help would be great. If you need more information please ask. Thanks in advance for help.<!-- / message -->

 

[BrianB]

This code uses the icon for the application as set up in windows :-
(you can see that it needs STKIT432.DLL to work. Seems to come with XP)

'==========================================================
'- SHORTCUT TO DESKTOP
'==========================================================
Declare Function fCreateShellLink Lib "STKIT432.DLL" _
(ByVal lpstrFolderName As String, ByVal lpstrLinkName _
As String, ByVal lpstrLinkPath As String, ByVal _
lpstrLinkArgs As String) As Long
'==========================================================
Sub ADD_SHORTCUT()
    Dim ProgPath As String
    Dim ProgName As String    ' shortcut caption
    Dim ProgFile As String
    Dim MyResult As Long
    '------------------------------------------------------
    ProgPath = "F:\"
    ProgFile = "book1.xls"
    ProgName = "My Excel Shortcut"
    '------------------------------------------------------
    MyResult = fCreateShellLink("..\..\Desktop", _
    ProgName, ProgPath & ProgFile, "")
    '------------------------------------------------------
    MsgBox (IIf(MyResult = 1, "Successful", "Unsuccessful"))
End Sub
'------------------------------------------------------------

 

[Joe Was]

The constants in this code let you define the Icon Name, currently the Icon file is in the active Folder!
It then places your shortCut on the DeskTop, you need to set the properties for the ShortCut:

Sub myCreateShortCut()
'Standard module code, like: Module1.
Dim objWinScript As Object, objShortCut As Object
Dim strPathSep$, strWBNm$, strFullWBNm$, strThisWBPath$, strDeskTop$, strShortCut$

On Error GoTo myErr

Const constTypeOfShortCut$ = ".lnk"
Const constShortCutWhere$ = "Desktop"
Const constIconNm$ = "\aroundWorld.ico" 'Must be in current folder!

strThisWBPath = ThisWorkbook.Path
strFullWBNm = ThisWorkbook.FullName
strPathSep = Application.PathSeparator
strWBNm = strPathSep & ThisWorkbook.Name

Set objWinScript = CreateObject("WScript.Shell")

strDeskTop = objWinScript.SpecialFolders(constShortCutWhere)
strShortCut = strDeskTop & strWBNm & constTypeOfShortCut

Set objShortCut = objWinScript.CreateShortCut(strShortCut)

With objShortCut
.TargetPath = strFullWBNm
.IconLocation = strThisWBPath & constIconNm
.Save
End With

MsgBox "Shortcut placed on:" & Space(3) & """" & constShortCutWhere & """" & _
Space(3) & "as a:" & Space(3) & """" & constTypeOfShortCut & ".""" & vbLf & vbLf & _
"ShortCut Icon Folder\Name:" & vbLf & strThisWBPath & constIconNm, _
vbInformation + vbOKOnly, _
"Build ShortCut Complete!"

Set objWinScript = Nothing

GoTo myEnd

myErr:
MsgBox "Your ""ShortCut"" failed to be created!", _
vbCritical + vbOKOnly, _
"Error!"

myEnd:
End Sub