Can anyone help with this code it works ok
but if there is a shortcut created it keeps on creating
Option Explicit
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
Dim ShortCutExists As Boolean
Dim F_Lnk As String
Function CreateShortCut(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 parse
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
CreateShortCut = True
End Function
Sub Create_Shortcut()
Dim ThisFile As String
'// ThisFile = ActiveWorkbook.Path & "\" & ActiveWorkbook.Name
ThisFile = ThisWorkbook.Path & "" & ThisWorkbook.Name
'// F_Lnk = Left(ActiveWorkbook.Name, Len(ActiveWorkbook.Name)) & ".LNK"
F_Lnk = Left(ThisWorkbook.Name, Len(ThisWorkbook.Name)) & ".LNK"
'// Creates a shortcut to your file ThisFile
MsgBox IIf(CreateShortCut(ThisFile), "CreateShortCut created for: " & ThisFile, _
IIf(ShortCutExists, "Shortcut Already created!", "Can't find the file!"))
End Sub
but if there is a shortcut created it keeps on creating
Option Explicit
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
Dim ShortCutExists As Boolean
Dim F_Lnk As String
Function CreateShortCut(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 parse
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
CreateShortCut = True
End Function
Sub Create_Shortcut()
Dim ThisFile As String
'// ThisFile = ActiveWorkbook.Path & "\" & ActiveWorkbook.Name
ThisFile = ThisWorkbook.Path & "" & ThisWorkbook.Name
'// F_Lnk = Left(ActiveWorkbook.Name, Len(ActiveWorkbook.Name)) & ".LNK"
F_Lnk = Left(ThisWorkbook.Name, Len(ThisWorkbook.Name)) & ".LNK"
'// Creates a shortcut to your file ThisFile
MsgBox IIf(CreateShortCut(ThisFile), "CreateShortCut created for: " & ThisFile, _
IIf(ShortCutExists, "Shortcut Already created!", "Can't find the file!"))
End Sub