Shortcut

[Bugs]

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

 

[Calypso]

Hi Bugs,

Have added a couple more API calls and made a couple of changes to the sendkeys area but this works for me.


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

Declare Function FindWindow Lib "user32" Alias "FindWindowA" ( _
ByVal lpClassName As String, _
ByVal lpWindowName As String) As Long

Declare Function GetWindowText Lib "user32" Alias "GetWindowTextA" ( _
ByVal hwnd As Long, _
ByVal lpString As String, _
ByVal cch As Long) 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 & "" & ""


AppActivate "Create Shortcut"
SendKeys "" & Target & "{ENTER}" & "", True

'loop around until the shortcut creation window has moved on a screen
Do While IsWindowThere
DoEvents
Loop

'then send the final commands to complete the shortcut creation
AppActivate "Select a Title for the Program"
SendKeys "" & ThisWorkbook.Name & "{ENTER}" & "", True


CreateShortCut = True

End Function


Function IsWindowThere() As Boolean
Dim lwHnd As Long
Dim lwTxt As Long
Dim StrBuf As String * 100
Dim Title As String

IsWindowThere = False

lwHnd = FindWindow(vbNullString, "Select a Title for the Program")

lwTxt = GetWindowText(lwHnd, StrBuf, 100)

Title = Left$(StrBuf, lwTxt)
If Title = "Select a Title for the Program" Then
IsWindowThere = True
Else
IsWindowThere = False
End If
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


HTH

------------------
Edit...
Have just come back to the above code and when I try and run it now on this machine it failes due to Thisworkbook.name returning shortened file/directory names i.e. c:Docume~1...

However another machine runs it fine due to "normal" dir and file name lengths being returned.

I've seen this prob before where machines switch between short and normal file name lengths - any ideas as to why this happens.

Would *greatly* appreciate a clue on this one.
_________________

No sooner does man discover intelligence than he tries to involve it in his own stupidity - Jacques Cousteau
This message was edited by Calypso on 2002-08-24 03:01
This message was edited by Calypso on 2002-08-28 11:15

 

[Rcam]

Ivan Maola has som code on this