Single Post - Как создать ярлык для URL?

Вариант с поддержкой длинного пути:

Code:

'============================== VBS ===============================
' Cоздать URL-ярлык в активном каталоге со ссылкой из буфера обмена
' Параметр: "%P"
'==================================================================
If WScript.Arguments.Count = 0 Then WScript.Quit
Dim WSH : Set WSH = CreateObject("WScript.Shell")
R = "HKCU\Software\Microsoft\Windows\CurrentVersion\Internet Settings\Zones\3\1407"
On Error Resume Next
A = WSH.RegRead(R): If A > 0 Or Err.Number <> 0 Then WSH.RegWrite R, 0, "REG_DWORD"
URL = Trim(CreateObject("htmlfile").ParentWindow.ClipboardData.GetData("text"))
If A > 0 Then WSH.RegWrite R, A, "REG_DWORD"
On Error Goto 0 : Test = Left(URL, 4)
If Test = "" Or (Test <> "www." And Test <> "http") Then MsgBox "Буфер " &_
"обмена не содержит гиперссылки!", 4144, " Создание URL-ярлыка" : WScript.Quit
S = Split(": ? * "" ; \ / | < >")
R = Array(-230,-225,-246,698,894,-24,-24,-24,706,707)
With WScript.CreateObject("InternetExplorer.Application", "IE_")
.Visible = 0 : .Silent = 1 : .AddressBar = 0
.MenuBar = 0 : .ToolBar = 0 : .StatusBar = 0 : .Navigate(URL)
While IsEmpty(Title) Or Left(Title, 4) = "http" WScript.Sleep 20 :Wend
.Stop : .ExecWB 45, 2 : FN = Title & ".url"
End With : Sub IE_TitleChange(T) Title = Trim(T) :End Sub
For i = 0 To 9 : FN = Replace(FN, S(i), ChrW(R(i))) :Next
Dir = WScript.Arguments(0) : FP = Dir & FN
If Len(FP) > 259 Then Pr = "\\?\" : If Len(Dir) < 260 Then _
M = MsgBox("Путь к ярлыку слишком длинный!" & vbCr & vbCr & "Да -" &_
" оставить. Нет - обрезать справа.", 4132, " Создание URL-ярлыка") :_
If M = 7 Then FP = Left(Left(FP, Len(FP) - 4), 255) & ".url"
With CreateObject("Scripting.FileSystemObject").CreateTextFile(Pr & FP, 1, 1)
.Write "[InternetShortcut]" & vbCrLf & "URL=" & URL : .Close
End With : WSH.SendKeys "^r"