What are shortcuts?

Well, what are they? I mean, the windows things. lnk files eh? Wossat then? Would some kind person please enlighten me? I should be awfully grateful... Oh yeah, and I'd like to be able to generate/edit them from VBA (Excel again, I'm afraid). That's what I'd really like...

Well those *lnk's are real bastards....
There binaries wich make them hard to generate...

There is a way to generate them though:

Code:

---

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

---

As you can see it requires Vb5stkit.dll.
I tried doin it with Vb6stkit.dll but that doesn't work.
Also put the dll in your app.path...

Hope this helps

Hi you inhuman-oid you, cheers for that but my prob is that I don't have dear old vb5 (or 6) here at work, just VBA. So I guess there's nothing I can do eh? Drat and double-drat. Now THAT kind of language will get you kicked off a forum, eh? How does Windaes (Scottish version) generate them then?

Shell links, also known as shortcuts, are a convenient way to reference objects within the shell name space (the hierarchical structure of objects in the Microsoft Windows 95 and Windows 98 shell) without having to keep track of the name and location of the original object. Shell links are referred to as shortcuts in the Context menu (that appears when you right- click an object) of shell objects. They are implemented internally via the IShellLink interface.

Because they are implemented internally I think it would be very hard (if not impossible) to generate them from VBA.
As far as editing goes there binaries so that's out of the question unless you like to do some hex-ing

I have a program which tricks the system somehow - so that it doesn't need any setup kit DLLs, and creates a shortcut anywhere without using IShellLink (well, actually the APIs it calls are using it but that's a different story). I'll try to "translate" it to VBA...

------------------
Yonatan
Teenage Programmer
E-Mail: [email protected]
ICQ: 19552879
AIM: RYoni69

If you feel like it, post the vb-code as well.

cheers

If you feel like it, post the vb-code as well.

cheers

If you feel like it, post the vb-code as well.

cheers

If you feel like it, post the vb-code as well.

cheers

Sounds great, Yonatan. I think Inhumanoid is fairly keen to see the code too (judging by the way he posted his request 4 times)...
Thanks in advance

[This message has been edited by coox (edited 11-17-1999).]

F&*K, something went totally wrong...

realy sorry.. I hate it when people do this....

Again sorry

Yeah, it happens... You can delete three of the four messages, you know.

Ok, I translated it.
You have two functions to choose from:
GenerateShortcut and GenerateShortcutByDirName.

With GenerateShortcut - you can choose a default directory to create the shortcut in.
With GenerateShortcutByDirName - you can choose a system directory. The parameter sDirName needs to be one of the following:

Desktop (Virtual)
Programs
Controls
Printers
Personal
Favorites
Startup
Recent
Send To
Recycle Bin
Start Menu
Desktop Directory
My Computer
Network
Nethood
Fonts
Templates
Start Menu (Common)
Programs (Common)
Startup (Common)
Desktop Directory (Common)
Application Data
PrintHood

Don't ask me what each one means... This is really old code... Speaking of which, here's the code: (Put it in a module)
[code]
Option Explicit
Option Compare Text


Private Declare Sub Sleep Lib "Kernel32" (ByVal dwMilliseconds As Long)


Private Declare Function SHGetSpecialFolderLocation Lib "Shell32" (ByVal hWndOwner As Long, ByVal nFolder As Long, ByVal ppidl As Long) As Long
Private Declare Function SHGetPathFromIDList Lib "Shell32" Alias "SHGetPathFromIDListA" (ByVal pidl As Long, ByVal pszPath As String) As Long
Private Declare Function SHAddToRecentDocs Lib "Shell32" (ByVal uFlags As Long, pv As Any) As Long
Private Declare Function SHFileOperation Lib "Shell32" Alias "SHFileOperationA" (lpFileOp As SHFILEOPSTRUCT) As Long


Private Const FO_MOVE = &H1
Private Const FO_RENAME = &H4
Private Const FOF_SILENT = &H4
Private Const FOF_RENAMEONCOLLISION = &H8
Private Const MAX_PATH As Integer = 260
Private Const SHARD_PATH = &H2&


Private Const CSIDL_DESKTOP = &H0
Private Const CSIDL_PROGRAMS = &H2
Private Const CSIDL_CONTROLS = &H3
Private Const CSIDL_PRINTERS = &H4
Private Const CSIDL_PERSONAL = &H5
Private Const CSIDL_FAVORITES = &H6
Private Const CSIDL_STARTUP = &H7
Private Const CSIDL_RECENT = &H8
Private Const CSIDL_SENDTO = &H9
Private Const CSIDL_BITBUCKET = &HA
Private Const CSIDL_STARTMENU = &HB
Private Const CSIDL_DESKTOPDIRECTORY = &H10
Private Const CSIDL_DRIVES = &H11
Private Const CSIDL_NETWORK = &H12
Private Const CSIDL_NETHOOD = &H13
Private Const CSIDL_FONTS = &H14
Private Const CSIDL_TEMPLATES = &H15
Private Const CSIDL_COMMON_STARTMENU = &H16
Private Const CSIDL_COMMON_PROGRAMS = &H17
Private Const CSIDL_COMMON_STARTUP = &H18
Private Const CSIDL_COMMON_DESKTOPDIRECTORY = &H19
Private Const CSIDL_APPDATA = &H1A
Private Const CSIDL_PRINTHOOD = &H1B


Private Type SHFILEOPSTRUCT
hwnd As Long
wFunc As Long
pFrom As String
pTo As String
fFlags As Integer
fAnyOperationsAborted As Long
hNameMappings As Long
lpszProgressTitle As String ' only used if FOF_SIMPLEPROGRESS
End Type


Private Function GetFolderDir(ByVal CSIDL As Long) As String
Dim sPath As String
Dim IDL As Long
GetFolderDir = ""
If SHGetSpecialFolderLocation(0, CSIDL, IDL) = 0 Then
sPath = Space(MAX_PATH)
If SHGetPathFromIDList(IDL, sPath) Then GetFolderDir = Left(sPath, InStr(sPath, vbNullChar) - 1) & "\"
End If
End Function


Private Function GetCSIDLFromText(ByVal CSIDL As String) As Long
Select Case CSIDL
Case "Desktop (Virtual)"
GetCSIDLFromText = CSIDL_DESKTOP
Case "Programs"
GetCSIDLFromText = CSIDL_PROGRAMS
Case "Controls"
GetCSIDLFromText = CSIDL_CONTROLS
Case "Printers"
GetCSIDLFromText = CSIDL_PRINTERS
Case "Personal"
GetCSIDLFromText = CSIDL_PERSONAL
Case "Favorites"
GetCSIDLFromText = CSIDL_FAVORITES
Case "Startup"
GetCSIDLFromText = CSIDL_STARTUP
Case "Recent"
GetCSIDLFromText = CSIDL_RECENT
Case "Send To"
GetCSIDLFromText = CSIDL_SENDTO
Case "Recycle Bin"
GetCSIDLFromText = CSIDL_BITBUCKET
Case "Start Menu"
GetCSIDLFromText = CSIDL_STARTMENU
Case "Desktop Directory"
GetCSIDLFromText = CSIDL_DESKTOPDIRECTORY
Case "My Computer"
GetCSIDLFromText = CSIDL_DRIVES
Case "Network"
GetCSIDLFromText = CSIDL_NETWORK
Case "NetHood"
GetCSIDLFromText = CSIDL_NETHOOD
Case "Fonts"
GetCSIDLFromText = CSIDL_FONTS
Case "Templates"
GetCSIDLFromText = CSIDL_TEMPLATES
Case "Start Menu (Common)"
GetCSIDLFromText = CSIDL_COMMON_STARTMENU
Case "Programs (Common)"
GetCSIDLFromText = CSIDL_COMMON_PROGRAMS
Case "Startup (Common)"
GetCSIDLFromText = CSIDL_COMMON_STARTUP
Case "Desktop Directory (Common)"
GetCSIDLFromText = CSIDL_COMMON_DESKTOPDIRECTORY
Case "Application Data"
GetCSIDLFromText = CSIDL_APPDATA
Case "PrintHood"
GetCSIDLFromText = CSIDL_PRINTHOOD
Case Else
Call Err.Raise(Number:=380, Description:="Invalid Directory Name.")
End Select
End Function


Public Sub GenerateShortcut(Optional ByVal sDefaultDirPath As String = vbNullString)
Dim sPath As String
Dim lRet As Long
sPath = InputBox("Enter directory to make shortcut in:", "Enter Directory", IIf(sDefaultDirPath = vbNullString, Empty, sDefaultDirPath))
If sPath = "" Then Exit Sub
Call HandleCreateShortcutError(CreateShortcut(sPath))
End Sub


Public Sub GenerateShortcutByDirName(ByVal sDirName As String)
Call HandleCreateShortcutError(CreateShortcut(GetFolderDir(GetCSIDLFromText(sDirName))))
End Sub


Private Sub HandleCreateShortcutError(ByVal lErr As Long)
If lErr = 0 Then Exit Sub
If lErr <> -1 Then
Call MsgBox("Error " & lErr & ": " & Error(lErr), vbCritical Or vbSystemModal, App.Title & " - Error")
Else
Call MsgBox("Shortcut successfully created!", vbExclamation, App.Title & App.Title & " - Success")
End If
End Sub


Private Function CreateShortcut(ByVal sPath As String) As Long
Dim I As Integer
Dim sFilePath As String
Dim sFileName As String
Dim sShortcutName As String
Dim sRecentPath As String
Dim lResult As Long
Dim SHFileOp As SHFILEOPSTRUCT
On Error GoTo ErrorHandler
If Dir(sPath) = "" Then Call MkDir(sPath)
sFilePath = InputBox("Enter file name to create a shortcut to:", "Enter File Name", "C:\Windows\Explorer.Exe")
If sFilePath = "" Then Exit Function
sShortcutName = InputBox("Enter file name of the shortcut to create in " & sPath & ":", "Enter File Name", "Shortcut.Lnk")
If sShortcutName = "" Then Exit Function
If Not Right(LCase(sShortcutName), 4) = ".lnk" Then
sShortcutName = sShortcutName & ".Lnk"
Call MsgBox("The file name didn't have the .Lnk extension. It has been added." & vbNewLine & _
"The file name is now " & sShortcutName & ".", vbExclamation, App.Title & " - Wrong Or No Extension")
End If
Screen.MousePointer = vbHourglass
DoEvents ' For Screen.MousePointer
If Not GetFolderDir(CSIDL_RECENT) = "" Then
lResult = SHAddToRecentDocs(SHARD_PATH, ByVal sFilePath)
Call Sleep(100)
If lResult Then
I = 1
sFileName = sFilePath
Do While I
I = InStr(1, sFileName, "\")
If I Then sFileName = Mid(sFileName, I + 1)
Loop
With SHFileOp
.wFunc = FO_MOVE
.pFrom = GetF

Thanks Yonatan, only prob I have is with a little thing App.Title - App doesn't seem to exist in my ver of VBA. Any thoughts?

It's not important... Remove it.

For example, change:

App.Title & " - Success"

To:

"Success"

------------------
Yonatan
Teenage Programmer
E-Mail: [email protected]
ICQ: 19552879
AIM: RYoni69