Тема: VBS: Создание URL-ярлыка по ссылке с записью скачиваемого favicon.ico
В аналогичной теме AHK просили откомментировать скрипт под спойлером с некоторой правкой:
'================================== VBS ===================================
' Назначение: создание URL-ярлыка со ссылкой из параметра или буфера обмена
' Параметры (необязательные): <гиперссылка> "<путь к каталогу назначения>"
' Примеры: 1) https://ya.ru | 2) "" C:\MyURLs
' Если ссылка не задана, то берётся из буфера.
' При отсутствии 2-го параметра местом сохранения будет рабочий каталог.
'==========================================================================
Option Explicit: Dim nConv
'======================== Путь у утилите NConvert =========================
nConv = "%ProgramFiles%\nConvert\nconvert.exe"
'==========================================================================
Dim WSH, FSO, Dir, URL, R, A, Test, S, Title, FN, i
' Создание объектов FSO и WSH:
Set FSO = CreateObject("Scripting.FileSystemObject")
Set WSH = CreateObject("WScript.Shell")
' Вывод сообщения и выход, если задан ложный путь к nConvert:
If Not FSO.FileExists(WSH.ExpandEnvironmentStrings(nConv)) Then _
MsgBox "Укажите верный путь к nConvert!", 4144, " Создание URL-ярлыка" : WScript.Quit
' Работа с параметрами
With WScript.Arguments
Select Case .Count ' сопоставление кол-ва
Case 0 Dir = WSH.CurrentDirectory ' если ничего, то каталог назначения - рабочий
Case 1 URL = .Item(0) ' если есть первый, то используется как URL
Case 2 Dir = .Item(1) ' если есть второй, то используется как каталог назначения
End Select
End With
If IsEmpty(URL) Then ' если URL пуст или не задан
' Передаём переменной URL текст из буфера с отсеканием концевых пробелов:
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
End If
' Проверка пуст ли буфер, а также первые 4 символа на http/www.
' Если их нет, то вывод окна с указанным текстом и завершение скрипта:
Test = Left(URL, 4)
If Test = "" Or (Test <> "www." And Test <> "http") Then MsgBox "Буфер " &_
"обмена не содержит гиперссылки!", 4144, " Создание URL-ярлыка" : WScript.Quit
' Запись в переменную S заменяемых символов, а в R - номеров юникодных аналогов для ChrW:
S = Split(": ? * "" ; \ / | < >")
R = Array(-230,-225,-246,698,894,-24,-24,-24,706,707)
' Создание объекта IE с параметром для событий:
With WScript.CreateObject("InternetExplorer.Application", "IE_")
' Скрытие его окна, устанавка тихого режима, убор адресной строки,
' гл. меню, панели инструментов, строки состояния:
.Visible = 0 : .Silent = 1 : .AddressBar = 0
.MenuBar = 0 : .ToolBar = 0 : .StatusBar = 0
' Открытие URL без записи в историю и сохранения в кэш:
.Navigate URL, 10
' Проверка в цикле по событию появления заголовка (не в виде ссылки):
While IsEmpty(Title) Or Left(Title, 4) = "http" WScript.Sleep 20 :Wend
' С появлением останавливаем загрузку страницы, закрываем IE
.Stop : .ExecWB 45, 2
End With
' Процедура, возвращающая в T, а после в Title заголовок без концевых пробелов:
Sub IE_TitleChange(T) Title = Trim(T) : End Sub
' Запись в FN заголовка с добавками и расширением:
FN = Title & " @ + .url"
' 10-кратный проход циклом с заменой в заголовке запрещённых в именах символов:
For i = 0 To 9 : FN = Replace(FN, S(i), ChrW(R(i))) : Next
Dim HTTP, Reg, URL1, Domain, FP, Pr, M, SCode, Icon, IName, FIcon
'Создание объектов WinHttpRequest, RegExp:
Set HTTP = CreateObject("WinHttp.WinHttpRequest.5.1")
Set Reg = New RegExp : Reg.IgnoreCase = True
' Установка опций для правильного соединения:
HTTP.Option(4) = 13056 : HTTP.Option(6) = True
HTTP.Option(12) = True : HTTP.Option(14) = 5
' Вычленение с пом. рег. выраж. URL c доменом (URL1) и самого домена (Domain):
Reg.Pattern = "^((https?://www\.|https?://|www\.)([^/]+))/?.*"
With Reg.Execute(URL)(0)
URL1 = .Submatches(0) : Domain = .Submatches(2)
End With
' Запись в FP полного пути к url-ярлыку:
FP = FSO.BuildPath(Dir, Year(Date) & "." & Right("0" & Month(Date),_
2) & "." & Right("0" & Day(Date), 2) & " " & Domain & " " & FN)
' Если длина этого пути больше 259, то:
If Len(FP) > 259 Then
Pr = "\\?\" ' в Pr заносится префикс \\?\
' если длина пути назначения меньше 260-ти, показываем сообщение с выбором обрезать/оставлять:
If Len(Dir) < 260 Then
M = MsgBox("Путь к ярлыку слишком длинный!" & vbCr & vbCr & "Да -" &_
" оставить. Нет - обрезать справа.", 4132, " Создание URL-ярлыка")
' Если нажата кн. "Нет", то обрезаем до 259 символов:
If M = 7 Then FP = Left(FSO.GetBaseName(FP), 255) & ".url"
End If
End If
Connect URL1 ' соединение с сайтом:
' Вытащить из исходного кода страницы адрес иконки:
Reg.Pattern = ".* ?href=""?\.?\.?((|https?://)" &_
"[^ ]*?/?favicon[^\s""]*?\.ico(|\?v=[\w]+))[\s""]"
SCode = HTTP.ResponseText ' запись исходного кода в SCode
HTTP.Abort ' обрыв соединения
If Reg.Test(SCode) Then ' если в нём есть favicon.ico
' Запись адреса иконки:
Icon = Reg.Execute(SCode)(0).Submatches(0)
If Left(Icon, 4) <> "http" Then ' если в нём нет http спереди
' Если слева у адреса //, то у URL1 остаётся только протокол:
If Left(Icon, 2) = "//" Then URL1 = Left(URL1, InStr(URL1, "//") - 1)
Icon = FSO.BuildPath(URL1 & "/", Icon) ' Запись полного URL иконки
End If
' если нет, то запись URL favicon.ico из корня сайта в переменную Icon:
Else Icon = URL1 & "/favicon.ico" End If
' Если это иконка (и она существует по данному адресу), то:
If Connect(Icon) Then
' Запись в переменную полного имени иконки
IName = Domain & " @favicon.ico"
' Запись в переменную полного локального пути для сохранения:
Icon = Pr & FSO.BuildPath(Dir, IName)
' Если иконки с заданным именем в папке нет, то:
If Not FSO.FileExists(Icon) Then
' происходит запись на диск в бинарном виде:
With CreateObject("SAPI.SpFileStream")
.Format.Type = 1 : .Open Icon, 3 : .Write HTTP.ResponseBody : .Close
End With
End If : HTTP.Abort ' обрыв соединения
With CreateObject("WIA.ImageFile")
' Если настоящий тип - не ico, то выполняется конвертация в него:
.LoadFile Icon : If LCase(.FileExtension) <> "ico" Then WSH.Run """" & nConv _
& """ -quiet -out ico -overwrite -transparent 100 """ & Icon & """", 0, True
End With
' Запись недостающей части в редакции url-файла, включая путь к иконке:
FIcon = vbCrLf & "IconFile=%FaviconFolder%\" & IName & vbCrLf & "IconIndex=0"
End If
' Создание url-файла:
With FSO.CreateTextFile(Pr & FP, 1, 1)
' запись в него URL и ключей для иконки, если она была найдена:
.Write "[InternetShortcut]" & vbCrLf & "URL=" & URL & FIcon : .Close
End With : WSH.SendKeys "^r" ' Обновляем окно для отображения новых файлов
Function Connect(URI)
' Открытие соединения с адресом иконки:
HTTP.Open "GET", URI, false
' Отключение кэшируемых данных:
HTTP.SetRequestHeader "Pragma", "no-cache"
HTTP.SetRequestHeader "Cache-Control", "no-cache"
' Посылка пакетов:
HTTP.Send
' Ожидание ответа в теч. макс. 5 сек:
HTTP.WaitForResponse 5, True
' Запись типа файла потенциальной иконки
Dim FT : FT = HTTP.GetResponseHeader("Content-Type")
' Передача функции булева значения соответствия типу иконки:
Connect = Eval(Left(FT, 6) = "image/" And Right(FT, 4) = "icon")
End Function