Shortcuts a tough / impossible one

You are right.......sorry, try this code !!

Dim ShortCutExists As Boolean
Dim F_LNK As String

Declare Function SHGetSpecialFolderLocation Lib "Shell32" _
(ByVal hwnd As Long, ByVal nFolder As Long, ppidl As Long) As Long

Declare Function SHGetPathFromIDList Lib "Shell32" _
(ByVal Pidl As Long, ByVal pszPath As String) As Long

Declare Function SetWindowPos Lib "User32" _
(ByVal hwnd As Long, ByVal hWndInsertAfter As Long, _
ByVal X As Long, ByVal Y As Long, ByVal cx As Long, _
ByVal cy As Long, ByVal uFlags As Long) As Long

Declare Function SetForegroundWindow Lib "User32" _
(ByVal hwnd As Long) As Long

Declare Function GetForegroundWindow Lib "User32" () As Long

Function ShortCut(Target As String) As Boolean

Dim hwnd As Long 'Handle of Window
Dim Pidl As Long
Dim DeskTopSysFile As String

'File exists
If Dir(Target) = "" Then Exit Function

'Get the windows desktop Pidl
SHGetSpecialFolderLocation 0, 0, Pidl

'assign spaces
DeskTopSysFile = Space(260)

'Get the path
SHGetPathFromIDList Pidl, DeskTopSysFile

'Now shorten
DeskTopSysFile = Left(DeskTopSysFile, InStr(1, DeskTopSysFile, vbNullChar) - 1)

'Does Shortcut exist
If Dir(DeskTopSysFile & "\" & F_LNK) <> "" Then ShortCutExists = True: Exit Function

hwnd = GetForegroundWindow
SetWindowPos hwnd, -1, 0, 0, 0, 0, 3

'Run RunDll32.exe - appWiz.Cpl = simulate Right click / Add shortcut
Shell "RunDLL32 AppWiz.Cpl,NewLinkHere " & DeskTopSysFile & "\"

'Use send keys to send to ACTIVE application window
SendKeys """" & Target & """~~", True
SetForegroundWindow hwnd

ShortCut = True

End Function

Sub Create_Shortcut()
Dim ThisFile As String

ThisFile = ThisWorkbook.Path & "\" & ThisWorkbook.Name
F_LNK = Left(ThisWorkbook.Name, Len(ThisWorkbook.Name)) & ".LNK"

' Creates a shortcut to your file ThisFile
MsgBox IIf(ShortCut(ThisFile), "Shortcut created for: " & ThisFile, _
IIf(ShortCutExists, "Shortcut Already created!", "Can't find the file!"))

End Sub

Ivan

Love it. Now how about if I want to check/put the shortcut somewhere else such as c:/my shortcuts

I plan to customize this code for an application but it will need to use a different folder for the shortcut location and get rid of the message box if the shrtcut exists. I only need to prompt when the shortcut is created. I believe I can do all I need except changing the default folder from desktop to somewhere else

Try something like this....my thanks to Tom Olgilvy....routine adapted/Altered & commented from his.

Declare Function SHGetSpecialFolderLocation Lib "Shell32" _
(ByVal hwnd As Long, ByVal nFolder As Long, ppidl As Long) As Long

Declare Function SHGetPathFromIDList Lib "Shell32" _
(ByVal Pidl As Long, ByVal pszPath As String) As Long

Declare Function SetWindowPos Lib "User32" _
(ByVal hwnd As Long, ByVal hWndInsertAfter As Long, _
ByVal X As Long, ByVal Y As Long, ByVal cx As Long, _
ByVal cy As Long, ByVal uFlags As Long) As Long

Declare Function SetForegroundWindow Lib "User32" _
(ByVal hwnd As Long) As Long

Declare Function GetForegroundWindow Lib "User32" () As Long

Function ShortCut(Target As String) As Boolean

Dim hwnd As Long 'Handle of Window
Dim Pidl As Long
Dim DeskTopSysFile As String

If Dir(Target & IIf(Target_Type = vbDirectory, "\", ""), _
Target_Type) = "" Then Exit Function
'Get the windows desktop Pidl
SHGetSpecialFolderLocation 0, 0, Pidl
'assign spaces
DeskTopSysFile = Space(260)
'Get the path
SHGetPathFromIDList Pidl, DeskTopSysFile
'Now shorten
DeskTopSysFile = Left(DeskTopSysFile, InStr(1, DeskTopSysFile, vbNullChar) - 1)

hwnd = GetForegroundWindow
SetWindowPos hwnd, -1, 0, 0, 0, 0, 3
'Run RunDll32.exe - appWiz.Cpl = simulate Right click / Add shortcut
Shell "RunDLL32 AppWiz.Cpl,NewLinkHere " & DeskTopSysFile & "\"
'Use send keys to send to ACTIVE application window
SendKeys """" & Target & """~~", True
SetForegroundWindow hwnd

ShortCut = True

End Function

Sub Check_Shortcut()
Dim ThisFile As String

ThisFile = ThisWorkbook.Path & "\" & ThisWorkbook.Name

' Creates a shortcut to your file ThisFile
MsgBox IIf(ShortCut(ThisFile), "Shortcut created for: " & ThisFile, "Can't find the file")

End Sub

Ivan

It looks like it should but I run it over and over and it keeps making new shortcuts.

That is just what I needed in the sense of creating the shortcut but what about checking to see if there is a shortcut first.

Nah

it is looking to see if the file exists not the shortcut.

Have a look @ the syntax, it checks first to see
if a shortcut for this file exists then creates it.
If the file doesn't exist it tells you.