Install link or copy to SendTo folder VBS

main Sub Main() Dim answer answer = MsgBox("YES To copy target, NO to Create link, or cancel to stop.", vbYesNoCancel, "YES=Copy, No=Shortcut, Cancel=Cancel") If answer = 6 Then CopyToSendTo elseIf answer = 7 Then InstallShortcutSendTo else MsgBox "Nothing done - exiting" end if End Sub Sub CopyToSendTo() Dim WSH 'As WshShell Dim strSendTo ''send to file path Dim FSO 'As FileSystemObject Dim oFile ''As File 'fp = wscript.Arguments.Item(0) fp = "C:\Users\ron.allen\Documents\CODING\VBS\TempMapFolderDrive\TempMapThisFolderToX.vbs" Set FSO = CreateObject("Scripting.FileSystemObject") Set oFile = FSO.GetFile(fp) Set WSH = CreateObject("WScript.Shell") strSendTo = WSH.SpecialFolders("SendTo") oFile.Copy strSendTo & "\" & oFile.Name, True if fso.fileexists (strSendTo & "\" & oFile.Name) then msgbox "Success installing " & strSendTo & "\" & oFile.Name else Msgox "Error installing " & strSendTo & "\" & oFile.Name end if End Sub Sub InstallShortcutSendTo() Dim WSH ''As WshShell Dim strSendTo ''send to file path Dim FSO ''As FileSystemObject Dim fp ''as string Dim fn ''as String Dim lnk ' Dim oUrlLink '' Dim oFile ''As File 'fp = wscript.Arguments.Item(0) fp = "C:\Users\ron.allen\Documents\CODING\VBS\TempMapFolderDrive\TempMapThisFolderToX.vbs" Set FSO = CreateObject("Scripting.FileSystemObject") Set oFile = FSO.GetFile(fp) Set WSH = CreateObject("WScript.Shell") strSendTo = WSH.SpecialFolders("SendTo") fn = oFile.Name If InStr(1, fn, ".") = 0 Then MsgBox "Malformed file name- no extension - existing", vbCritical, "Error" Exit Sub End If Dim i i = Len(fn) Do While Mid(fn, i, 1) <> "." i = i - 1 Loop fn = Left(fn, i - 1) Set lnk = WSH.CreateShortcut(strSendTo + "\" & oFile.Name & ".lnk") lnk.TargetPath = oFile.Path lnk.WindowStyle = 1 lnk.Hotkey = "" 'lnk.IconLocation = "notepad.exe, 0" lnk.Description = "Original path : " & oFile.Path lnk.WorkingDirectory = strSendTo lnk.Save if fso.fileexists (strSendTo + "\" & oFile.Name & ".lnk") then msgbox "Success installing " & strSendTo + "\" & oFile.Name & ".lnk" else Msgox "Error installing " & strSendTo + "\" & oFile.Name & ".lnk" end if End Sub

Comments

Popular posts from this blog

Revit area plans adding new types and references (Gross and rentable)

Powerpoint countdown and current time in slides VBA

Revit Python in Visual Studio Revit Stubs 2022 for Python Revit Intellisense