How do I use fCreateShellLink in VB6?

[igowerf]

So far, all the examples that I have seen use STKIT432.dll or VB5STKIT.DLL. VB6STKIT.DLL, however, doesn't work the same as the older dll's.


Declare Function fCreateShellLink Lib "VB6STKIT.DLL" (byval lpstrFolderName as string, byval lpstrLinkName as string, byval lpstrLinkPath as string, byval lpstrLinkArgs as string) as Long




This code just causes the program to crash. In order to create a shortcut, I have to include the VB4 or VB5 dll in my project. Any suggestions?

[Cimperiali]

Private Declare Function fCreateShellLink Lib "VB5STKIT.DLL" (ByVal lpstrFolderName As String, ByVal lpstrLinkName As String, ByVal lpstrLinkPath As String, ByVal lpstrLinkArgs As String) As Long
Private Sub Form_Load()
'KPD-Team 1999
'URL: http://www.allapi.net/
'E-Mail: KPDTeam@Allapi.net
' -> code by Raist Lin
'Create a shell link on your desktop
lngresult = fCreateShellLink("..\..\Desktop", "LINK", "C:\myfile.exe", "")
End Sub

'-------------
'even this from api guide:
'explanations of parameters:
· lpstrFolderName
folder where to create the link

· lpstrLinkName
text caption for the link

· lpstrLinkPath
full path to the target of the link

· lpstrLinkArguments
command-line arguments for the link


Special thanks to Lothar "the Great" Haensler, Tom Archer, Chris Eastwood Bruno Paris and all the other wonderful people who made and make Codeguru a great place. Come back soon, you Gurus.

[igowerf]

That code works using VB5STKIT.DLL. I was wondering if there was a way to do it using the VB6STKIT.DLL.

[John G Duffy]

Here is a module I use that contains fCreateShellLink and fGetShellLinkInfo plus a few others I am to lazy to strip out.
YOu will need to obtain a copy of "Shelllnk.tlb" rom the VB CDROM. Register it using RegisterTLB.exe or this API

private Declare Function RegisterTLB Lib "vb6stkit.dll" _
(byval lpTLBName as string) as Integer
' Here is the Module
'
'
option Explicit

public Enum STGM
STGM_DIRECT = &H0&
STGM_TRANSACTED = &H10000
STGM_SIMPLE = &H8000000
STGM_READ = &H0&
STGM_WRITE = &H1&
STGM_READWRITE = &H2&
STGM_SHARE_DENY_NONE = &H40&
STGM_SHARE_DENY_READ = &H30&
STGM_SHARE_DENY_WRITE = &H20&
STGM_SHARE_EXCLUSIVE = &H10&
STGM_PRIORITY = &H40000
STGM_DELETEONRELEASE = &H4000000
STGM_CREATE = &H1000&
STGM_CONVERT = &H20000
STGM_FAILIFTHERE = &H0&
STGM_NOSCRATCH = &H100000
End Enum
'
' Shell Folder Path Constants...
'
' on NT:
' ..\WinNT\profiles\username
'
' on Windows 9x:
' ..\Windows
public Enum SHELLFOLDERS
CSIDL_DESKTOP = &H0& ' \Desktop
CSIDL_PROGRAMS = &H2& ' \Start Menu\Programs
CSIDL_CONTROLS = &H3& ' No Path
CSIDL_PRINTERS = &H4& ' No Path
CSIDL_PERSONAL = &H5& ' \Personal
CSIDL_FAVORITES = &H6& ' \Favorites
CSIDL_STARTUP = &H7& ' \Start Menu\Programs\Startup
CSIDL_RECENT = &H8& ' \Recent
CSIDL_SENDTO = &H9& ' \SendTo
CSIDL_BITBUCKET = &HA& ' No Path
CSIDL_STARTMENU = &HB& ' \Start Menu
CSIDL_DESKTOPDIRECTORY = &H10& ' \Desktop
CSIDL_DRIVES = &H11& ' No Path
CSIDL_NETWORK = &H12& ' No Path
CSIDL_NETHOOD = &H13& ' \NetHood
CSIDL_FONTS = &H14& ' \fonts
CSIDL_TEMPLATES = &H15& ' \ShellNew
CSIDL_COMMON_STARTMENU = &H16& ' ..\WinNT\profiles\All Users\Start Menu
CSIDL_COMMON_PROGRAMS = &H17& ' ..\WinNT\profiles\All Users\Start Menu\Programs
CSIDL_COMMON_STARTUP = &H18& ' ..\WinNT\profiles\All Users\Start Menu\Programs\Startup
CSIDL_COMMON_DESKTOPDIRECTORY = &H19& '..\WinNT\profiles\All Users\Desktop
CSIDL_APPDATA = &H1A& ' ..\WinNT\profiles\username\Application Data
CSIDL_PRINTHOOD = &H1B& ' ..\WinNT\profiles\username\PrintHood
End Enum

public Enum SHOWCMDFLAGS
SHOWNORMAL = 5
SHOWMAXIMIZE = 3
SHOWMINIMIZE = 7
End Enum

public Const MAX_PATH = 255

Declare Function SHGetSpecialFolderLocation Lib "Shell32" (byval hWndOwner as Long, byval nFolder as Integer, ppidl as Long) as Long
Declare Function SHGetPathFromIDList Lib "Shell32" Alias "SHGetPathFromIDListA" (byval pidl as Long, byval szPath as string) as Long

public Function fCreateShellLink(sLnkFile as string, sExeFile as string, sWorkDir as string, _
sExeArgs as string, sIconFile as string, lIconIdx as Long, _
ShowCmd as SHOWCMDFLAGS, sDescription as string) as Long

Dim cShellLink as ShellLinkA ' An explorer IShellLinkA(Win 9x/Win NT) instance
Dim cPersistFile as IPersistFile ' An explorer IPersistFile instance

If (sLnkFile = "") Or (sExeFile = "") then Exit Function

on error GoTo fCreateShellLinkError
set cShellLink = new ShellLinkA 'Create new IShellLink interface
set cPersistFile = cShellLink 'Implement cShellLink's IPersistFile interface
Dim Z
With cShellLink
'set command line exe name & path to new ShortCut.
.SetPath sExeFile
'set working directory in shortcut
If sWorkDir <> "" then .SetWorkingDirectory sWorkDir
'Add arguments to command line
If sExeArgs <> "" then .SetArguments sExeArgs
'set shortcut description
.SetDescription sDescription
' If (LnkDesc <> "") then .SetDescription pszName
'set shortcut icon location & index
If sIconFile <> "" then .SetIconLocation sIconFile, lIconIdx

'set shortcut's startup mode (min,max,normal)
.SetShowCmd ShowCmd

End With
' Const SLR_UPDATE = 0 since Const doesn't exist, Update mode must be assumed jgd

cShellLink.Resolve 0, SLR_UPDATE
cPersistFile.Save StrConv(sLnkFile, vbUnicode), 0 'Unicode conversion that must be done!
fCreateShellLink = 0 'Return Success
set cPersistFile = nothing
set cShellLink = nothing
Exit Function

fCreateShellLinkError:
fCreateShellLink = Err.Number ' return error to user
set cPersistFile = nothing
set cShellLink = nothing
End Function
public Function fGetSystemFolderPath(byval hwnd as Long, byval Id as Integer, sfPath as string) as Long
Dim lReturn as Long
Dim lPidl as Long
Dim lPath as Long
Dim sPath as string

sPath = Space$(MAX_PATH)
lReturn = SHGetSpecialFolderLocation(hwnd, Id, lPidl) ' get lPidl for Id...
If lReturn = 0 then ' If success is 0
lReturn = SHGetPathFromIDList(lPidl, sPath) ' get Path from Item Id List
If lReturn = 1 then ' If success is 1
sPath = Trim$(sPath) ' Fix path string
lPath = len(sPath) ' get length of path
If Asc(Right$(sPath, 1)) = 0 then lPath = lPath - 1 'Adjust path length
If lPath > 0 then sfPath = Left$(sPath, lPath) ' Adjust path string variable
fGetSystemFolderPath = true ' Return success
End If
End If
End Function

public Function fGetShellLinkInfo _
(sLnkFile as string, sExeFile as string, sWorkDir as string, _
sExeArgs as string, sIconFile as string, sDescription as string, _
lIconIdx as Long, lShowCmd as Long, lPidl as Long, _
lHotKey as Long) as Long
Dim lBuffLen as Long
Dim sTemp as string
Dim cShellLink as ShellLinkA ' An explorer IShellLink instance
Dim cPersistFile as IPersistFile ' An explorer IPersistFile instance
Dim fd as WIN32_FIND_DATA
Dim X as Long
If sLnkFile = "" then Exit Function

set cShellLink = new ShellLinkA ' Create new IShellLink interface
set cPersistFile = cShellLink ' Implement cShellLink's IPersistFile interface

'Load Shortcut file...(must do this UNICODE hack!)
on error GoTo fGetShellLinkInfoError
cPersistFile.Load StrConv(sLnkFile, vbUnicode), STGM_DIRECT

With cShellLink
'get command line exe name & path of shortcut
sExeFile = Space$(MAX_PATH)
lBuffLen = len(sExeFile)
.GetPath sExeFile, lBuffLen, fd, SLGP_UNCPRIORITY
StripNulls sExeFile
sTemp = fd.cFileName ' Not returned to calling function

'get working directory of shortcut
sWorkDir = Space$(MAX_PATH)
lBuffLen = len(sWorkDir)
.GetWorkingDirectory sWorkDir, lBuffLen
StripNulls sWorkDir
'get command line arguments of shortcut
sExeArgs = Space$(MAX_PATH)
lBuffLen = len(sExeArgs)
.GetArguments sExeArgs, lBuffLen
StripNulls sExeArgs
'get description of shortcut
sDescription = Space$(MAX_PATH)
lBuffLen = len(sDescription)
.GetDescription sDescription, lBuffLen
StripNulls sDescription
'get the HotKey for shortcut
.GetHotkey lHotKey '

'get shortcut icon location & index
sIconFile = Space$(MAX_PATH)
lBuffLen = len(sIconFile)
.GetIconLocation sIconFile, lBuffLen, lIconIdx
StripNulls sIconFile
'get Item ID List...
.GetIDList lPidl '

'set shortcut's startup mode (min,max,normal)
.GetShowCmd lShowCmd
End With
fGetShellLinkInfo = true

fGetShellLinkInfoError:
set cPersistFile = nothing
set cShellLink = nothing
End Function



public Sub StripNulls(byref S)
Dim X
X = InStr(S, Chr(0))
If X > 0 then S = Left(S, X - 1)
End Sub




John G