Полезные VBS скрипты и программы по работе с ними

Dragokas · Регистрация: 25.12.2011

Author24 — интернет-сервис помощи студентам

В этой теме выкладываем скрипты, которые часто используются Вами
или на Ваш взгляд могут иметь большое практическое значение.

Также приветствуются скрипты высокой степени сложности, полезные с точки зрения
изучения принципа их работы.

Правила темы:

При выкладывании скрипта постарайтесь тщательно описывать принцип его работы и по-больше комментировать строки Вашего кода.
Если Ваш код очень большой, помещайте его под CUT. Также можно сделать 2 варианта: 1. Чистый код. 2. С комментариями.
Запрещаются любые обсуждения выложенных здесь работ;
если в этом есть необходимость, создайте отдельную тему в которой опишите замечание или проблему при работе с данным скриптом, указав ссылку на сообщение из этой темы (правый клик по слову "Permalink" вверху каждого сообщения).
Если Вы хотите внести исправление в выложенный Вами код - пишите мне в личку ссылку на Ваше старое сообщение и новый исправленный вариант. (полный вариант с тегами Вашего старого сообщения можно получить, нажав на него - кнопка "Цитата").
Допускается размещение обзора программ, помогающих редактировать/отлаживать код.

Схожая тема: Полезные макросы, надстройки и шаблоны (VBA)
Смежная тема: Полезные BAT/CMD скрипты

******************* Перечень полезных скриптов: *******************
Отправка файла на FTP (Drag & Drop) и копирование ссылки в буфер обмена ссылка
Получение времени сервера ссылка

greg zakharov · 10.11.2015, 10:16

Uptime (без использования WMI):

Javascript

(function() {
  var enc, arr, i, s = '', std,
      loc = {
        419 : ['019', '1251'],
        409 : ['009', '1252']
      };
  
  Array.prototype.to_s = function() {
    var s = '';
    
    for (var i = 0; i < this.length; i++) {
      s += i === 0 ? parseInt(this[i]) + '.'
        : (parseInt(this[i]) < 10 ? '0' + parseInt(this[i]) : parseInt(this[i])) + ':';
    }
    return s.replace(/\:$/, '');
  };
  
  with (new ActiveXObject('WScript.Shell')) {
    enc = Number(RegRead('HKCU\\Control Panel\\International\\Locale'));
    arr = RegRead(
      'HKLM\\SOFTWARE\\Microsoft\\Windows NT\\CurrentVersion\\' +
      'PerfLib\\' + loc[enc][0] + '\\Counter'
    ).toArray();
    
    for (i = 0; i < arr.length; i++) {
      if (parseInt(arr[i]) === 2 || parseInt(arr[i]) === 674) {
        s += '\\' + arr[i + 1];
      }
    }
    
    std = Exec('cmd /c chcp');
    i = std.StdOut.ReadAll().match(/\d+/);
    std = Exec('cmd /q /k echo off');
    std.StdIn.WriteLine('chcp ' + loc[enc][1]);
    std.StdIn.WriteLine('typeperf "' + s + '" -sc 1');
    std.StdIn.WriteLine('chcp ' + i + '&exit');
    s = parseInt(std.StdOut.ReadAll().match(/\d+\.\d+/g)[2]);
  };
  WScript.echo([s / 86400, s / 3600 % 24, s % 3600 / 60, s % 60].to_s());
}());

Генерация случайного файла (функция генерирует случайное имя со случайным расширением):

Javascript

(function(len) {
  if (isNaN(len) || (len > 32 || len < 1)) {
    WScript.echo('Should be a number ranging from 1 to 32.');
    WScript.Quit(1);
  }
  
  var getRandom = function(min, max) {
    return Math.floor(Math.random() * (max - min + 1)) + min;
  };
  
  var std, arr, i, ext = [];
  with (new ActiveXObject('WScript.Shell')) {
    std = Exec('cmd /q /k echo off');
    std.StdIn.WriteLine('assoc & exit');
    arr = std.StdOut.ReadAll().split('\n');
  }
  
  for (i = 0; i < arr.length; i++) {
    if (!arr[i].match(/.\d+\=/) && arr[i].match(/=\w+/)) {
      ext.push(arr[i].split('=')[0]);
    }
  }
  
  with (new ActiveXObject('Scriptlet.TypeLib')) {
    WScript.echo(GUID.substring(1, 37).replace(/-/g, '')
      .toLowerCase().slice(0, len) + ext[getRandom(0, ext.length - 1)]
    );
  }
}(
  WScript.Arguments.length !== 1
  ? WScript.Quit(1)
  : WScript.Arguments.Unnamed(0)
));

@xeon13 · 13.11.2015, 09:15

Uptime простейший.

Visual Basic

'Писал для себя по примерам в интернете. E}|{uk@RUSnet
Set objDT = CreateObject ("WbemScripting.SWbemDateTime") 
For Each objItem in GetObject ("winmgmts:root\cimv2").Get ("Win32_OperatingSystem").Instances_ 
       objDT.value = objItem.LastBootUpTime 
       nUp = DateDiff ("n", objDT.GetVarDate (TRUE), NOW) 
       wscript.echo "Up for", int (nUp/1440), "Day(s)", int (nUp/60) mod 24, "hour(s)", nUp mod 60, "minute(s)" 
Next

Добавлено через 38 минут
Скрипт получения имени пользователя и по имени локального компа по SIDу
Часто бывает необходим для выяснения кто стал причиной ошибки в журнале виндовс.

Visual Basic

'Скрипт получения имени пользователя и по имени локального компа по SIDу (VBScript)
'Просто в появившемся диалоговом окне вводим SID нужного юзверя ОК
'Автор E}|{uk@RUSnet (xeon) 2013г.
 
sSID = InputBox ("Введите SID пользователя:")
 
strComputer = "."
Set objWMIService = GetObject("winmgmts:" & strComputer & "\root\cimv2")
Set objAccount = objWMIService.Get _
("Win32_SID.SID='" & sSID & "'")
Wscript.Echo "ИмяПольз\ИмяКомпДомен: " & objAccount.AccountName & " \ " & objAccount.ReferencedDomainName

Добавлено через 20 минут

Visual Basic

'Скрпт синхронизирующий время с указанной рабочей станции. \\adms
'Автор E}|{uk@RUSnet (xeon)
set WshShell = WScript.CreateObject("WScript.Shell")  
WSHShell.Run "net time \\adms /set /yes", 0, True

greg zakharov · 16.11.2015, 11:05

Определяет физическое местоположение COM-модуля.

Javascript

(function(com) {
  try {
    with (new ActiveXObject('WScript.Shell')) {
      WScript.Echo(RegRead('HKLM\\SOFTWARE\\Classes\\CLSID\\' +
        RegRead('HKLM\\SOFTWARE\\Classes\\' + com + '\\CLSID\\') +
      '\\InProcServer32\\'));
    }
  }
  catch (e) {
    WScript.echo('Error (' + e.number + '): unknown COM on this system.');
  }
}(
  WScript.Arguments.length !== 1
  ? (function() {
    WScript.echo('Usage: ' + WScript.ScriptName + ' <COM>');
    WScript.echo('e.g.: ' + WScript.ScriptName + ' Scripting.FileSystemObject');
    WScript.Quit(1);
  }()) : WScript.Arguments.Unnamed(0)
));

@xeon13 · 20.11.2015, 16:03

Visual Basic

'####################################################
'#  Скрипт для автоматического изменения или добавления логотипа  Фирмы#
'#  в свойствах системы Win7. Можно использовать в доменных политиках      #
'# Необходимо, чтобы в папке со скриптом лежал сам логотип oemlogo.bmp
'# У мена размер логотипа был: 120 x 33 x 24 BPP
'#   Автор: E}|{uk@RUSnet 2015год                    #
'####################################################
 
'Копирование логотипа
 
strComputer = "."
Set objFSO = WScript.CreateObject("Scripting.FileSystemObject")
Set WshShell = CreateObject("WScript.Shell")
 
'#######добавил проверку наличия папки и её создание########
'переменная пути с папкой логотипа
strDirectory = "c:\Windows\System32\oobe\info"
 
'если переменная strDirectory есть то...
If objFSO.FolderExists(strDirectory) Then 
'попытка открытия папки.
Set objFolder = objFSO.GetFolder(strDirectory) 
'Для оповещения ниже строчку можно раскоментировать.
'WScript.Echo "Папка  ''"& strDirectory &"''  уже создана " 
Else
Set objFolder = objFSO.CreateFolder(strDirectory) 
'Для оповещения ниже строчку можно раскоментировать.
'WScript.Echo "Вновь созданная папка ''"& strDirectory &"''."
End If
 
'##########проверка окончена#################################
 
objFSO.CopyFile "oemlogo.bmp", "c:\Windows\System32\oobe\info\oemlogo.bmp", True
    If Err.Number <> 0 Then
set  mes = Err.Number & ": " & Err.Description
MsgBox mes, 0, " Внимание!!!"
'       WScript.Quit
    end if
 
'Удаление лишний инфы с реестра OEMINFO.
On error Resume Next
Set SHELL = CreateObject("WScript.Shell")
 
RegValue = "HKEY_LOCAL_MACHINE\SOFTWARE\Microsoft\Windows" & _
"CurrentVersion\OEMInformation\Manufacturer"
SHELL.RegWrite RegValue, "", "REG_SZ"
    If Err.Number <> 0 Then
        WScript.Echo "Не добавился ключ: " & RegValue
        WScript.Quit
    end if
 
RegValue = "HKEY_LOCAL_MACHINE\SOFTWARE\Microsoft\Windows" & _
"CurrentVersion\OEMInformation\Model"
SHELL.RegWrite RegValue, "", "REG_SZ"
    If Err.Number <> 0 Then
        WScript.Echo "Не добавился ключ: " & RegValue
        WScript.Quit
    end if
 
RegValue = "HKEY_LOCAL_MACHINE\SOFTWARE\Microsoft\Windows" & _
"CurrentVersion\OEMInformation\SupportHours"
SHELL.RegWrite RegValue, "", "REG_SZ"
    If Err.Number <> 0 Then
        WScript.Echo "Не добавился ключ: " & RegValue
        WScript.Quit
    end if
 
RegValue = "HKEY_LOCAL_MACHINE\SOFTWARE\Microsoft\Windows" & _
"CurrentVersion\OEMInformation\SupportPhone"
SHELL.RegWrite RegValue, "", "REG_SZ"
    If Err.Number <> 0 Then
        WScript.Echo "Не добавился ключ: " & RegValue
        WScript.Quit
    end if
 
RegValue = "HKEY_LOCAL_MACHINE\SOFTWARE\Microsoft\Windows" & _
"CurrentVersion\OEMInformation\SupportURL"
SHELL.RegWrite RegValue, "", "REG_SZ"
    If Err.Number <> 0 Then
        WScript.Echo "Не добавился ключ: " & RegValue
        WScript.Quit
    end if
 
RegValue = "HKEY_LOCAL_MACHINE\SOFTWARE\Microsoft\Windows" & _
"CurrentVersion\OEMInformation\Logo"
SHELL.RegWrite RegValue, "\Windows\System32\oobe\info\oemlogo.bmp", "REG_SZ"
    If Err.Number <> 0 Then
        WScript.Echo "Не добавился ключ: " & RegValue
        WScript.Quit
    end if
 
wscript.echo "Логотип добавлен, инфа oeminf стёрта."

Visual Basic

'####################################################
'# Скрипт на изменение добавление логотипа Фирмы   #
'# В свойствах системы WinXP   Можно использовать в доменных политиках  #
'# Необходимо, чтобы в папке со скриптом лежал сам логотип oemlogo.bmp
'# и файл oeminfo.ini с содержанием:
'# [General]
'# Manufacturer=СуперКомпьютер:
'# Model=
'# 
'# [Support Information]
'# Line1=
'# Line2=
'# У мена размер логотипа был: 120 x 33 x 16бит. при 24Битах - отображается белый фон.
'#   Автор: E}|{uk@RUSnet 2010год                    #
'####################################################
 
'Копирование логотипа
 
strComputer = "."
Set objFSO = WScript.CreateObject("Scripting.FileSystemObject")
Set WshShell = CreateObject("WScript.Shell")
 
objFSO.CopyFile "oemlogo.bmp", "c:\Windows\System32\oemlogo.bmp", True
    If Err.Number <> 0 Then
set  mes = Err.Number & ": " & Err.Description
MsgBox mes, 0, " Внимание!!!"
'       WScript.Quit
    end if
 
objFSO.CopyFile "oeminfo.ini", "c:\Windows\System32\oeminfo.ini", True
    If Err.Number <> 0 Then
set  mes = Err.Number & ": " & Err.Description
MsgBox mes, 0, " Внимание!!!"
'       WScript.Quit
    end if
 
wscript.echo "Логотип добавлен"

greg zakharov · 30.11.2015, 13:22

Crc32 файла
Суть идеи - запихать файл в zip и уже оттуда получить Crc32 файла (смещение 14 байт от начала архива, само поле crc32 - 4 байта). Концепт расчитан прежде не на шибко большие файлы.

Visual Basic

On Error Resume Next
 
If WScript.Arguments.Count <> 1 Then
  WScript.Echo "Usage: " & WScript.ScriptName & " <file>"
  WScript.Echo ".e.g.: " & WScript.ScriptName & " E:\sandbox\app.exe"
  WScript.Quit(1)
End If
 
Dim strFile
Dim strTemp
Dim objFile
Dim objDump
Dim strDump
 
strFile = WScript.Arguments.Unnamed(0)
 
With CreateObject("Scripting.FileSystemObject")
  If Not .FileExists(strFile) Then
    WScript.Echo "Could not locate specified file."
    WScript.Quit(1)
  End If
  
  strFile = .GetAbsolutePathName(strFile)
  strTemp = .BuildPath(.GetSpecialFolder(2), "~crc32.zip")
  
  Set objFile = .CreateTextFile(strTemp)
  objFile.Write "PK" & Chr(5) & Chr(6) & String(18, 0)
  objFile.Close
  
  With CreateObject("Shell.Application")
    .NameSpace(strTemp).CopyHere strFile
    WScript.Sleep 500
  End With
  
  With CreateObject("SAPI.SpFileStream")
    .Open strTemp, 0
    .Seek 14, 1
    .Read objDump, 4
    .Close
  End With
  
  With CreateObject("Microsoft.XMLDOM")
    Set strDump = .createElement("Binary")
    strDump.dataType = "bin.hex"
    strDump.nodeTypedValue = objDump
  End With
  
  strDump = strDump.text
  WScript.StdOut.Write "0x"
  For i = Len(strDump) - 1 To 0 Step -2
    WScript.StdOut.Write UCase(Mid(strDump, i, 2))
  Next
  WScript.Echo
  .GetFile(strTemp).Delete
End With

@xeon13 · 11.12.2015, 15:04

Скрипт получения полного имени пользователя и его описание из домена
возникла необходимость узнавать, кто открыл файл ексель.
Автор E}|{uk@RUSnet 2015г.

Visual Basic

'#####################################################
'# Скрипт получения полного имени пользователя и его описание из домена
'# возникла необходимость узнавать, кто открыл файл ексель.
'# Автор E}|{uk@RUSnet 2015г.
'#####################################################
 
set nw = WScript.CreateObject("WScript.Network")
username=InputBox ("Введите логин пользователя:")
 
'Вместо DOMEN меняем на свой домен в сети.
set objuser = GetObject("WinNT://DOMEN/" & username)
 
wscript.Echo (username) & " => " & (objuser.fullname) & " (" & (objuser.description) &")"

@Oleg_cyber · 15.03.2016, 13:53

Доброго времени суток!
Предлагаю вашему вниманию небольшой vbскриптик с помощью которого можно создать ярлык для программы в меню программ кнопки Пуск

Visual Basic

Dim FSO, file, oFile, objArgs, n, p, pf, WshShell, link
Set objArgs = WScript.Arguments
If objArgs.Count > 0 Then file = objArgs(0)
Set FSO = WScript.CreateObject("Scripting.FileSystemObject")
Set oFile = FSO.GetFile(file)
p = oFile.Path
n = FSO.GetBaseName(p)
pf = oFile.ParentFolder
Set WshShell = WScript.CreateObject("WScript.Shell")
Set link = WshShell.CreateShortcut("C:\Users\имя_пользователя\AppData\Roaming\Microsoft\Windows\Start Menu\Programs" & n & ".lnk")
link.TargetPath = p
link.WindowStyle = 1
link.Description = "Shortcut Script"
link.WorkingDirectory = pf
link.Save
MsgBox "     Ярлык создан!"

Скопируйте код в блокнот и сохраните с расширением .vbs (в 10-й строке замените имя_пользователя на ваше имя)
Затем нажмите win+R и введите shell:sendto и ОК
Перетащите файл в эту папку. Далее просто: ПКМ на нужном файле > Отправить > Ваш скрипт--Готово!

@xeon13 · 15.04.2016, 15:25

NetCompNameMAIN+Timer.vbs Скрипт вывода сообщения Имени Компьютера и Юзера по таймеру. (Можно засунуть в доменные политики)

Несколько лет бился с тем что юзеры не желают знать сетевого имени своего компа и имени юзера.
Написал поначалу скрипт вывода сообщения при включении и всунул в политики домена. Юзеры стали тупо нажимать ОК и не читали, а потом при звонке в ИТ отдел только бе и ме, "придите сами посмотрите". Бегать неохота, проще подключиться удалённо, но без опознавательных координат это сложно. Вобщем вот сегодня прикрутил таймер к этому скрипту, чтобы ленивый юзер задолбался нажимать ОК, так как сообщение будет выскакивать снова поверх окон и заставит его вчитаться и запомнить. Вобщем собрал по интернетам из кусков скриптег и добавил свои вкусности

. Думаю мою работу оценять многие начинающие админы ))).

Visual Basic

'Скрипт вывода Имени Компьютера и имени пользователя
'Сообщение нельзя закрыть по истечению времени
' Автор: E}|{uk@RUSnet #Dimitrovgrad 2016г.
' Спасибо "гуру" из интернета создавшему вывод сообщения по таймеру...
 
 
rem Option Explicit
 
Dim WshShell
 
Dim intTime4Show                  ' Заданное (оно же максимально возможное) время показа сообщения
Dim intMinimumTime                ' Минимальное время показа сообщения
Dim intTimeStartShowing           ' Время начала показа сообщения
Dim intRetValue                   ' Возвращаемое значение метода .Popup
Dim WshSysEnv, SysInfo, COMPUTERNAME, USERNAME 
 
Set WshShell = WScript.CreateObject("WScript.Shell")
 
intTime4Show    = 60              ' Заданное    время показа сообщения — 1 минута
intMinimumTime  = 10              ' Минимальное время показа сообщения — 10 секунд
 
intTimeStartShowing = Timer       ' Засекаем время
 
 
Function Server()
    Set objWMIService = GetObject("winmgmts:{impersonationLevel=impersonate}!\\.\root\cimv2")
    If Err.Number <> 0 Then
        rem WScript.Echo Err.Number & Err.Description
        WScript.Quit
    End If
    Set colOperatingSystems = objWMIService.ExecQuery("Select * from Win32_OperatingSystem")
    strInfo = vbNullString
    For Each objOperatingSystem in colOperatingSystems
        strInfo=objOperatingSystem.Caption & " __ " & objOperatingSystem.Version
        Exit For
    Next
    Server = 0
    If InStr(LCase(strInfo),LCase("server"))>0 Then 
        Server = 1
    End If
End Function
 
 
If Server()=0 Then
    'создаем объект WshShell: 
    Set WshShell = WScript.CreateObject("WScript.Shell") 
 
    'создаем объект Environment со значением SYSTEM: 
    COMPUTERNAME = WshShell.Environment("PROCESS").Item("COMPUTERNAME")
    USERNAME = WshShell.Environment("PROCESS").Item("USERNAME")
 
    SysInfo = "Для обращения в отдел ИТ Запомните!     " & vbCrLf & vbCrLf & _
    "Ваш  ""КОМПЬЮТЕР"" —  " & COMPUTERNAME & "          "  & vbCrLf & vbCrLf & _
    "Ваш  ""ПОЛЬЗОВАТЕЛЬ"" —  "  & USERNAME & vbCrLf _
 
End If
 
Do
 
'   Код 262144 - поверх всех окон, а 64 значёк информативного сообщения.
    MsgBox SysInfo, 262144 + 64, " Внимание!!!"
 
    ' Повторяем вывод сообщения, пока не будет выполнено одно из условий:
    ' 1. Истечёт отведённое время и сообщение будет закрыто по таймауту [intRetValue = -1]
    ' 2. Сообщение будет закрыто вручную и с момента первого показа
    '    сообщения до текущего момента пройдёт не менее минимального [intMinimumTime]
    '    времени [(Timer - intTimeStartShowing) > intMinimumTime]
 
Loop Until intRetValue = -1 Or (Timer - intTimeStartShowing) > intMinimumTime
 
Set WshShell = Nothing
 
WScript.Quit 0

Dragokas · 15.05.2017, 20:11 **[ТС]**

Registry Time Decoder

Консольный VBS скрипт.

Позволяет увидеть в привычном формате DD.MM.YYYY hh:mm:ss даты, которые указаны в реестре в бинарном формате или в виде 16-ричного значения.

Можно указывать на выбор:

бинарную строку
16-ричное число
путь к параметру реестра

Поддерживаемые форматы:

Unix-Time (4 байта)
FILETIME (8 байт)
SYSTEMTIME (16 байт)

Фейс и доп. инфа

Полезные VBS скрипты и программы по работе с ними

Примечание:
Скрипт поддерживает задание конвертируемой строки через аргументы, например:

Код

cscript путь\RegTimeDecoder.vbs 00,80,8c,a3,c5,94,c6,01

Скрипт может попросить повышения привилегий, если ему их не хватит, чтобы прочитать параметр реестра.

Буфер обмена
Чтобы вставить содержимое буфера обмена в окно консоли CSCRIPT, нажмите правой кнопкой мыши по заголовку окна => Свойства => Общие => Поставьте галочку на "Выделение мышью" => ОК.
Теперь вы сможете вставлять буфер правой кнопкой мышки.

Последнюю версию можно найти здесь: https://www.safezone.cc/resour... coder.205/

@buggydancer · 01.06.2017, 09:18

Календарь к 100 летию "нового стиля" для применения в издательском/полиграфическом деле а также для SOHO/ИЧП, фрилансеров и просто хороших людей

; данный пост есть ссылка на соотв. тред в котором (в том треде) планируется возможные (надеюсь) доработки, обсуждения и более новый версии
HTA: Вечный календарь к 100 летию "нового стиля"

greg zakharov · 20.10.2017, 23:10

Декодер активационного ключа Windows (CD-Key)

Javascript

(function() {
  var map = ('BCDFGHJKMPQRTVWXY2346789').split(''),
      key = [], i, j, k, dpi, ver;
 
  with (new ActiveXObject('WScript.Shell')) {
    ver = Exec('cmd /c ver').StdOut.ReadAll().match(/\d+\.\d+/);
    dpi = RegRead('HKLM\\SOFTWARE\\Microsoft\\Windows NT\\' +
                  'CurrentVersion\\DigitalProductId').toArray();
  }
 
  ver = Boolean(6.1 <= parseFloat(ver));
  if (ver) {
    var nb = (dpi[66] / 6) & 1;
    dpi[66] = (dpi[66] & 0xF7) || ((nb & 2) * 4);
  }
 
  dpi = dpi.slice(52, 67);
  for (i = 24; i >= 0; i--) {
    k = 0;
    for (j = 14; j >= 0; j--) {
      k = (k * 256) ^ dpi[j];
      dpi[j] = Math.floor(k / 24);
      k %= 24;
    }
    key = map[k] + key;
 
    if ((i % 5) === 0 && i !== 0) key = '-' + key;
  }
 
  if (ver) {
    var part = key.substring(1, k + 1);
        real = k === 0 ? 'N' + part : part + 'N';
    key = key.substring(1, key.length).replace(part, real);
  }
  WScript.echo(key);
}());

@MegaBatcher2000 · 15.02.2018, 19:37

Мой скрипт.
Заранее предупрежу, может быть код не правильный, не тестил полностью.

Вот:

Visual Basic

a=msgbox("Cкрипт написан DirectRussianBeer.",100,"INFO")
Set st = CreateObject("Wscript.Shell")
do
st.sendkeys"{numlock}"
WScript.sleep 90
st.sendkeys"{capslock}"
WScript.sleep 90
st.sendkeys"{scrolllock}"
WScript.sleep 90
loop
Dim off
off=msgbox("Выключить?",4,"Переливающаяся клавиатура")
if off = vbYes then
Set cmd = CreateObject("WScript.Shell")
cmd.Run chr(34) & "@taskkill /f /im wscript.exe >nul" & Chr(34), 0, True
Set cmd = Nothing
Set st = Nothing
else
do
st.sendkeys"{numlock}"
WScript.sleep 90
st.sendkeys"{capslock}"
WScript.sleep 90
st.sendkeys"{scrolllock}"
WScript.sleep 90
loop
end if

Довольно простой, но реально у кого нет клавиатуры переливающийся, пусть пользуется.

@Homarty · 11.04.2018, 21:33

Всем доброго здоровья!
Как-то ко мне обратился один из участников форума с просьбой написать небольшой скрипт, который бы читал теги ID3V1 MP3-файлов в указанной пользователем папке и затем бы создавал в ней подкаталоги по музыкальным жанрам, в тех опять создавать вложенные подпапки с артистами, и т.д. по годам альбома->по названиям альбомов, и в итоге, все mp3-файлы должны быть аккуратненько рассортированы по всем этим многочисленным подпапкам.
Скажу честно, я не смог сразу выполнить это, руки не доходили, но тут выкроил немного времени и вот что получилось.
Написал за пару дней, много не тестировал, но вроде бы, работает нормально, если будут замечания сообщайте, учту.

@MegaBatcher2000 · 30.05.2019, 14:03

Сообщение от Смолевич

Как VBS упаковать в EXE?

Наваял простенький, очень простенький упаковщик VBS в EXE.
Упаковщик BAT/CMD/JS/VBS в EXE "Script2Bin 1.0.0.0"
Получается EXE весом от 7 КБ.
Пусть пока и не сравнится с серьезными аналогами вроде http://www.vbsedit.com/ зато очень простой, легкий и с интерфейсом по-русски.

Добровольцы могут протестировать и, если понравится, пользоваться...
Может со временем добавлю новых фич, если будет, скажем так, пользоваться спросом...

Редактор BAT/CMD/JS/VBS/PowerShell с функцией упаковки в EXE "Script2Binary 3.0.0.0"*

@АЕ · 23.04.2020, 17:41

Как увидеть IP адрес VPN подключения
Не совсем моя ветка форума, однако жизнь заставила ваять код на VBS, поскольку все найденное в сети упорно его не показывало (только CMD)
В коде есть маска "192.168.90" - это то что я искал.... моя удаленная сеть. Вы можете вместо ее поставить свои значения.
Ложу в первоначальном виде (для себя я ее еще допиливал, поскольку мне нужна была только "хвостовая" часть адреса.

Кликните здесь для просмотра всего текста

Visual Basic

function fVPN()
Const wbemFlagReturnImmediately = &h10
Const wbemFlagForwardOnly = &h20
strComputer = "."
Set objWMIService = GetObject("winmgmts:\\" & strComputer & "\root\CIMV2")
Set colItems = objWMIService.ExecQuery("SELECT * FROM Win32_IP4RouteTable", "WQL", _
                                          wbemFlagReturnImmediately + wbemFlagForwardOnly)
 
   For Each objItem In colItems
     if instr(objItem.Caption,"192.168.90") then
      'WScript.Echo "Caption: " & objItem.Caption      
      fVPN = objItem.Name
     end if
   Next
end function
WScript.Echo fVPN

Dragokas · 05.10.2020, 14:47 **[ТС]**

Двоичное сравнение файлов на идентичность

Visual Basic

function CompareFiles(sFileA, sFileB) 'by Michael Harri (fork by Dragokas)
    Dim oFSO
    set oFSO = CreateObject("Scripting.FileSystemObject")
    if oFSO.GetFile(sFileA).size <> oFSO.GetFile(sFileB).size then exit function
    Dim streamA, streamB, bufA, bufB, lengthA, lengthB, nSize, bMatched
    set streamA = CreateObject("adodb.stream")
    set streamB = CreateObject("adodb.stream")
    streamA.type = 1 'adTypeBinary
    streamB.type = 1 'adTypeBinary
    streamA.open
    streamB.open
    on error resume next
    streamA.loadfromfile sFileA
    if err then exit function
    streamB.loadfromfile sFileB
    if err then exit function
    on error goto 0
    bMatched = true
    nSize = 2^15 '32K
    do until streamA.eos or streamB.eos
        bufA = streamA.read(nSize)
        bufb = streamB.read(nSize)
        lengthA = lenB(bufA)
        lengthB = lenB(bufB)
        if lengthA <> lengthB then
            bMatched = false
            exit do
        elseif MidB(bufA,1,lengthA) <> MidB(bufB,1,lengthB) then
            bMatched = false
            exit do
        end if
    loop
    if not (streamA.eos and streamB.eos) then
        bMatched = false
    end if
    streamA.close
    streamB.close
    CompareFiles = bMatched
end function

FlasherX · 16.12.2020, 19:08

Сообщение от FlasherX

P.S.: Лично у меня скрипт сделан по схеме Вкл/Выкл.

Очередная тема навеяла выложить.

Назначение в шапке. Умолчание подразумевает первичное/стандартное наименование подключения.

Visual Basic

'———————————————————————————————————————————————
' Включить/отключить локальную сеть по умолчанию
'  https://www.cyberforum.ru/post15105239.html
'         Автор — FlasherX (15.07.2012)
'———————————————————————————————————————————————
Option Explicit: Dim Shell, T, Conn, i, Verb
Set Shell = CreateObject("Shell.Application")
If Not Shell.IsServiceRunning("Netman") Then
   If Not Shell.CanStartStopService("Netman") Then
      MsgBox "Запустите вручную службу ""Сетевые подключения""!", 4144
      Set Shell = Nothing: WSH.Quit
   End If
   T = 1: Shell.ServiceStart "Netman", False
End If
With CreateObject("CDO.Message")
   With .AddAttachment("res://dot3dlg.dll/6/7").GetDecodedContentStream
      .Type = 1: .Read(14): Conn = Replace(CStr(.Read(AscB(.Read(2)) * 2)), Chr(0), "")
   End With
   With .AddAttachment("res://netshell.dll/6/102").GetDecodedContentStream
      .Type = 1
      For Each i in Split("Enable Disable")
         Execute i & " = Replace(.Read(AscB(.Read(2)) * 2), Chr(0), """")"
      Next
   End With
End With
For Each i in Shell.NameSpace(49).Items
   If i = Conn Then
      If N(i) = Enable Then Verb = Enable Else Verb = Disable
      N(i).DoIt: Do: WSH.Sleep 100: Loop Until N(i) = Verb
      Exit For
   End If
Next
Function N(It): Set N = It.Verbs.Item(0): End Function
If T Then Shell.ServiceStop "Netman", False
Set Shell = Nothing

FlasherX · 30.06.2021, 08:37

Пару раз спрашивали про передел даты съёмки JPEG под дату правки. Прикреплю тут, пожалуй:

Visual Basic

'—————————————————————————————————————————————————————————————————————————
' Назначение: установить дату съёмки эквивалентной дате правки файлов JPEG
' Примечание: в качестве аргумента можно указать путь к каталогу с *.jpg и
'             *.jpeg, иначе будет рассматриваться рабочий каталог
' Публикация: https://www.cyberforum.ru/post15597059.html
'  Авторство: FlasherX (29.06.2021)
'—————————————————————————————————————————————————————————————————————————
Option Explicit: Dim oFSO, oIPr, oImg, Dir, oItems, F, D, FP
Set oFSO = CreateObject("Scripting.FileSystemObject")
Set oIPr = CreateObject("WIA.ImageProcess")
Set oImg = CreateObject("WIA.ImageFile")
oIPr.Filters.Add oIPr.FilterInfos("Exif").FilterID
oIPr.Filters(1).Properties("Type") = 1002
oIPr.Filters(1).Properties("ID") = 36867
If WSH.Arguments.Count Then
   Dir = WSH.Arguments(0): If Not oFSO.FolderExists(Dir) Then _
   Msg "Укажите реальный путь в качестве параметра!", 262192
Else Dir = oFSO.GetAbsolutePathName("") End If
Set oItems = CreateObject("Shell.Application").NameSpace(Dir).Items
oItems.Filter 8256, "*.jpg;*.jpeg": Setlocale 1100
If oItems.Count = 0 Then Msg "Файлы JPEG отсутствуют в папке """ & Dir & """!", 262192
For Each F in oItems
   D = F.ExtendedProperty("Write")
   oIPr.Filters(1).Properties.Item("Value") = Year(D) & ":" & Right("0" &_
   Month(D), 2) & ":" & Right("0" & Day(D), 2) & " " & Replace(TimeValue(D), ".", ":")
   FP = F.Path: oImg.LoadFile FP: oIPr.Apply(oImg).SaveFile FP & "_"
   oFSO.GetFile(FP).Delete: oFSO.GetFile(FP & "_").Name = oFSO.GetFileName(FP)
   F.ModifyDate = D
Next
Set oItems = Nothing: Set oIPr = Nothing: Set oImg = Nothing: Set oFSO = Nothing
Msg Space(13) & "Выполнено!", 262208
 
Sub Msg(Text, i)
   MsgBox Text, i, "  JPEG:  дата модификации " & ChrW(10142) & " дата съёмки": WSH.Quit
End Sub

Ну и обратный (для меня более полезный) вариант:

Visual Basic

'————————————————————————————————————————————————————————————————
' Назначение: установка даты правки файлов,
'             эквивалентной дате съёмки/оцифровки/кодирования
' Примечание: в качестве аргумента можно указать путь к каталогу,
'             иначе будет рассматриваться рабочий каталог
' Публикация: https://www.cyberforum.ru/post15597059.html
'  Авторство: FlasherX (31.10.2020)
'——————————————————————————————————
Option Explicit
'—— Маска рассматриваемых файлов ————————————
Const Mask = "*.avi;*.mkv;*.mp4;*.jpg;*.jpeg"
'————————————————————————————————————————————————————————————————
Dim oFSO, Dir, oItems, oImg, F, DT
Set oFSO = CreateObject("Scripting.FileSystemObject")
If WSH.Arguments.Count Then
   Dir = WSH.Arguments(0): If Not oFSO.FolderExists(Dir) Then _
   Msg "Укажите реальный путь в качестве параметра!", 262192
Else Dir = oFSO.GetAbsolutePathName("") End If
Set oItems = CreateObject("Shell.Application").NameSpace(Dir).Items
oItems.Filter 73920, Mask: Setlocale 1049
If oItems.Count = 0 Then Msg "Подходящие файлы отсутствуют в папке """ & Dir & """!", 262192
Set oImg = CreateObject("WIA.ImageFile")
For Each F in oItems
    If InStr(1, "|jpg|jpeg|", "|" & oFSO.GetExtensionName(F) & "|", 1) Then
       oImg.LoadFile F.Path: DT = Empty
       With oImg.Properties
          If .Exists("ExifDTOrig") Then DT = .Item("ExifDTOrig") Else _
          If .Exists("ExifDTDigitized") Then DT = .Item("ExifDTDigitized")
          If Len(DT) Then DT = CDate(Replace(Split(DT)(0), ":", ".") & " " & Split(DT)(1))
       End With
    Else DT = F.ExtendedProperty("System.Media.DateEncoded") End If
    If Len(DT) Then If oFSO.GetFile(F.Path).DateLastModified <> DT Then F.ModifyDate = DT
Next
Set oItems = Nothing: Set oImg = Nothing: Set oFSO = Nothing
Msg "       Выполнено!", 262208
 
Sub Msg(Text, i)
   MsgBox Text, i, "  Дата записи " & ChrW(10142) & " дата модификации": WSH.Quit
End Sub

FlasherX · 05.09.2021, 06:14

Такой запрос на простую мозайку дал повод подразмять мозги:

Visual Basic

'—————————————————————————————————————————————————————————————————————————————————————————
' Назначение: Создать мозайку из изображений одинакового размера по указанной маске файлов
 
' Параметры:  [расширение файла] [маска файлов] [/dir:ПУТЬ] [/i0] [/sq] [/ssq] [/sqn] [/o]
 
' для расширения мозайки допустимы следующие значения: bmp, gif, png, jpg, jpeg, tif, tiff
' маска файлов допускает: имена, постановочные знаки и перечисление через ";" без пробелов
' /dir — путь источника с файлами после : (без ключа используется текущий рабочий каталог)
' /sq  — не собирать мозайку, если квадратный корень числа файлов не является целым числом
' /ssq — режим "строгий квадрат" с выполнением /sq и запретом на прямоугольные изображения
' /sqn — не добавлять прозрачный или чёрный ряд без изображений (действует без /sq и /sqq)
' /o   — открывать файл-мозайку в программе, связанной по умолчанию с заданным расширением
 
' Публикация:  https://www.cyberforum.ru/post15695936.html
' Авторство:   FlasherX (03.09.2021)
'—————————————————————————————————————————————————————————————————————————————————————————
Option Explicit: Const Title = "  Создание мозайки из изображений"
Dim A, oKey, Ext, oFSO, Dir, oShell, oItems, C, D, Sq, Clms, Rows,_
F, BN, iSize, xSize, oRgx, Er, oImg, v, oIP, x, oPic, i, Xi, Yi, FN
Set A = WSH.Arguments: Set oKey = A.Named: Ext = LCase(A(0))
If A.UnNamed.Count < 2 Then Msg "Укажите расширение и маску файлов в качестве параметров!"
If InStr("|bmp|gif|png|jpg|jpeg|tif|tiff|", "|" & Ext & "|") = 0 Then _
Msg "Заданный тип файла (" & A(0) & ") не поддерживается!"
Set oFSO = CreateObject("Scripting.FileSystemObject")
If Not oKey.Exists("dir") Then Dir = FSO.GetAbsolutePathName("") Else Dir = oKey("dir") :_
If IsEmpty(Dir) Or Not oFSO.FolderExists(Dir) Then Msg "Укажите существующий путь каталога к /dir: !"
Set oShell = CreateObject("Shell.Application")
Set oItems = oShell.NameSpace(Dir).Items
oItems.Filter 8256, A(1): C = oItems.Count: Sq = Sqr(C)
D = oItems.Item(0).ExtendedProperty("Dimensions")
If IsEmpty(D) Then Msg "Некоторые файлы не являются изображениями!"
D = Split(Mid(D, 2, Len(D) - 2), " x ")
If Sq = Fix(Sq) Then Clms = Sq: Rows = Sq Else If oKey.Exists("sq") + oKey.Exists("ssq") Then _
Msg "Число файлов не соответствует квадратной мозайке!" Else Clms = Fix(Sq + 1): Rows = Clms :_
If oKey.Exists("sqn") Then If C <= Clms^2 - Clms Then Rows = Clms - 1
If oKey.Exists("ssq") Then If D(0) <> D(1) Then Msg "Присутствуют прямоугольные изображения!"
For Each F In oItems
   If F.Size = 0 Then Msg "Присутствуют файлы нулевого размера!"
   iSize = F.ExtendedProperty("Dimensions")
   If IsEmpty(iSize) Then Msg "Некоторые файлы не являются изображениями!"
   If Not IsEmpty(xSize) Then If iSize <> xSize Then Msg "Размеры изображений не совпадают!"
   xSize = iSize
Next
 
Set oRgx = New RegExp: oRgx.Pattern = "[""/*\\:|?<>]"
While oRgx.Test(BN) Or IsEmpty(BN)
   If Not IsEmpty(BN) Then Er = Space(38) & "Некорректное имя!"
   BN = RTrim(InputBox(String(3, vbCr) & Er & vbCr & vbCr & "Введите базовое имя файла:", Title, BN))
   If BN = "" Then Set oRgx = Nothing: Msg ""
Wend: Set oRgx = Nothing
While oFSO.FileExists(oFSO.BuildPath(Dir, BN & "." & A(0)))
   i = i + 1: BN = BN & "_" & i
Wend
Set oRgx = Nothing: i = 0
 
With CreateObject("WIA.Vector")
   .Add &h030000: Set oImg = .ImageFile(1, 1)
End With
If Ext <> "bmp" Then Set v = oImg.ARGBData: v(1) = &h00000000
Set oIP = CreateObject("WIA.ImageProcess")
If Ext <> "bmp" Then oIP.Filters.Add oIP.FilterInfos("ARGB").FilterID
oIP.Filters.Add oIP.FilterInfos("Scale").FilterID
If Ext <> "bmp" Then x = 1: oIP.Filters(x).Properties("ARGBData") = v
oIP.Filters(x+1).Properties("MaximumWidth")  = D(0) * Clms
oIP.Filters(x+1).Properties("MaximumHeight") = D(1) * Rows
If Not oKey.Exists("ssq") Then _
oIP.Filters(x+1).Properties("PreserveAspectRatio") = False
 
For Each F In oItems
   Set oPic = CreateObject("WIA.ImageFile")
   oPic.LoadFile F.Path
   oIP.Filters.Add oIP.FilterInfos("Stamp").FilterID
   oIP.Filters(x+i+2).Properties("ImageFile") = oPic
   oIP.Filters(x+i+2).Properties("Left") = CInt(Xi)
   oIP.Filters(x+i+2).Properties("Top")  = CInt(Yi)
   i = i + 1: If i < C Then Xi = Xi + oPic.Width :_
   If Xi = D(0) * Clms Then Xi = 0: Yi = Yi + oPic.Height
   Set oPic = Nothing
Next
 
If Ext <> "bmp" Then oIP.Filters.Add oIP.FilterInfos("Convert").FilterID
If Ext <> "bmp" Then oIP.Filters(x+i+2).Properties("FormatID").Value = "{B96B3C" & Split("B0 AE AE AF B1 B1")_
((InStr(" gif| jpg|jpeg| png| tif|tiff|", Right(" " & Ext & "|", 5)) - 1)/5) & "-0728-11D3-9D7B-0000F81EF32E}"
FN = oFSO.BuildPath(Dir, BN & "." & A(0)): oIP.Apply(oImg).SaveFile FN
If oKey.Exists("o") Then oShell.ShellExecute FN End If: Msg ""
 
Sub Msg(Text)
   Set oIP = Nothing: Set oImg = Nothing: Set oFSO = Nothing: Set oShell = Nothing
   If Len(Text) Then MsgBox Text, 262192, Title End If: WSH.Quit
End Sub

@HACKER KAY · 19.09.2021, 18:30

Очищаем консоль от текста (cscript)

Visual Basic

Function clear()
    Const WshRunning  = 0
    Const WshFinished = 1
    Const WshFailed   = 2 
    With WScript.CreateObject("WScript.Shell").Exec("mode.com con: lines=0")
        If .Status <> WshFailed Then
            If .Status = WshRunning Then
                Do Until .Status = WshFinished
                    .StdOut.ReadAll
                    .StdErr.ReadAll
                    WScript.Sleep 100
                Loop
            End If
        End If
    End With
    clear = 1
End Function

Dragokas 17996 / 7697 / 892 Регистрация: 25.12.2011 Сообщений: 11,470 Записей в блоге: 16
		1
	Полезные VBS скрипты и программы по работе с ними 15.10.2012, 00:41. Показов 206014. Ответов 46 Метки нет (Все метки) В этой теме выкладываем скрипты, которые часто используются Вами или на Ваш взгляд могут иметь большое практическое значение. Также приветствуются скрипты высокой степени сложности, полезные с точки зрения изучения принципа их работы. Правила темы: При выкладывании скрипта постарайтесь тщательно описывать принцип его работы и по-больше комментировать строки Вашего кода. Если Ваш код очень большой, помещайте его под CUT. Также можно сделать 2 варианта: 1. Чистый код. 2. С комментариями. Запрещаются любые обсуждения выложенных здесь работ; если в этом есть необходимость, создайте отдельную тему в которой опишите замечание или проблему при работе с данным скриптом, указав ссылку на сообщение из этой темы (правый клик по слову "Permalink" вверху каждого сообщения). Если Вы хотите внести исправление в выложенный Вами код - пишите мне в личку ссылку на Ваше старое сообщение и новый исправленный вариант. (полный вариант с тегами Вашего старого сообщения можно получить, нажав на него - кнопка "Цитата"). Допускается размещение обзора программ, помогающих редактировать/отлаживать код. Схожая тема: Полезные макросы, надстройки и шаблоны (VBA) Смежная тема: Полезные BAT/CMD скрипты ***************** Перечень полезных скриптов: ***************** Отправка файла на FTP (Drag & Drop) и копирование ссылки в буфер обмена ссылка Получение времени сервера ссылка 7

@buggydancer 251 / 239 / 16 Регистрация: 31.12.2009 Сообщений: 324
	01.06.2017, 09:18	30
	Календарь к 100 летию "нового стиля" для применения в издательском/полиграфическом деле а также для SOHO/ИЧП, фрилансеров и просто хороших людей ; данный пост есть ссылка на соотв. тред в котором (в том треде) планируется возможные (надеюсь) доработки, обсуждения и более новый версии HTA: Вечный календарь к 100 летию "нового стиля" 1

@MegaBatcher2000 4 / 3 / 2 Регистрация: 20.01.2018 Сообщений: 71
	30.05.2019, 14:03	34
	Сообщение от Смолевич Как VBS упаковать в EXE? Наваял простенький, очень простенький упаковщик VBS в EXE. Упаковщик BAT/CMD/JS/VBS в EXE "Script2Bin 1.0.0.0" Получается EXE весом от 7 КБ. Пусть пока и не сравнится с серьезными аналогами вроде http://www.vbsedit.com/ зато очень простой, легкий и с интерфейсом по-русски. Добровольцы могут протестировать и, если понравится, пользоваться... Может со временем добавлю новых фич, если будет, скажем так, пользоваться спросом... Редактор BAT/CMD/JS/VBS/PowerShell с функцией упаковки в EXE "Script2Binary 3.0.0.0"* 0