Place shortcut icon to active workbook on desctop

mnmhenry

Board Regular
Joined
Mar 28, 2002
Messages
169
Hi everyone. Can I put a shortcut icon from the active workbook to my desctop ? Aswell an On Error Resume Next if it allready exists ?

Thanks.
Mark Henry
 

Excel Facts

Test for Multiple Conditions in IF?
Use AND(test, test, test, test) or OR(test, test, test, ...) as the logical_test argument of IF.
On 2002-04-01 02:01, mnmhenry wrote:
Hi everyone. Can I put a shortcut icon from the active workbook to my desctop ? Aswell an On Error Resume Next if it allready exists ?

Thanks.
Mark Henry

<pre/>
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 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

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

</pre>
 
Upvote 0
Wow what do you guys do all day. How can you grasp all this stuff. This is super. Thank you very much. I'll get onto it right away....
 
Upvote 0

Forum statistics

Threads
1,213,494
Messages
6,113,974
Members
448,537
Latest member
Et_Cetera

We've detected that you are using an adblocker.

We have a great community of people providing Excel help here, but the hosting costs are enormous. You can help keep this site running by allowing ads on MrExcel.com.
Allow Ads at MrExcel

Which adblocker are you using?

Disable AdBlock

Follow these easy steps to disable AdBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the icon in the browser’s toolbar.
2)Click on the "Pause on this site" option.
Go back

Disable AdBlock Plus

Follow these easy steps to disable AdBlock Plus

1)Click on the icon in the browser’s toolbar.
2)Click on the toggle to disable it for "mrexcel.com".
Go back

Disable uBlock Origin

Follow these easy steps to disable uBlock Origin

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back

Disable uBlock

Follow these easy steps to disable uBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back
Back
Top