MrExcel Publishing
Your One Stop for Excel Tips & Solutions

Shortcuts a tough / impossible one


Posted by DoughBoy on September 19, 2000 12:38 AM

Can your macro check to see if a shortcut exists and if not putone there for itself.
If my workbook is open it checks to see
1. if there is a shortcut to itself on the desktop
2. if that shortcut is correct
3. if not 1 or 2 then put a new shortcut there


Posted by Ivan Moala on September 21, 0100 2:07 AM

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

Posted by DoughBoy on September 21, 0100 2:35 AM

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

Posted by Ivan Moala on September 19, 0100 3:21 AM

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


Posted by DoughBoy on September 20, 0100 4:05 AM


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


Posted by DoughBoy on September 19, 0100 10:20 PM

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.

Posted by DoughBoy on September 20, 0100 11:46 PM

Nah

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

Posted by Ivan Moala on September 19, 0100 11:53 PM

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.