Образцы кода VBScript

Тема в разделе "Банк полезных кодов", создана пользователем Dragokas, 5 мар 2014.

  1. Dragokas
    Оффлайн

    Dragokas Very kind Developer Команда форума Супер-Модератор Разработчик Клуб переводчиков

    Сообщения:
    4.493
    Симпатии:
    4.310
    Структура

    Права и безопасность
    Получение повышенных привилегий Администратора (с сохранением аргументов запуска)
    Проверка, запущен ли скрипт от имени Администратора

    Консольное окно
    Перезапуск скрипта в консольном режиме, если запущен через WScript
    Процентный прогрессбар в консоле

    Путь
    Получить путь к запущенному скрипту

    Буфер обмена
    Получить текст из буфера обмена
    Скопировать текст в буфер обмена

    Диалог
    Диалоговое окно выбора файла

    Массивы
    Преобразование байтового массива в строку
    Преобразование строки в байтовый массив
     

    Вложения:

    Последнее редактирование: 5 мар 2014
    machito и Kиpилл нравится это.
  2. Dragokas
    Оффлайн

    Dragokas Very kind Developer Команда форума Супер-Модератор Разработчик Клуб переводчиков

    Сообщения:
    4.493
    Симпатии:
    4.310
    Получение повышенных привилегий Администратора (перезапуск скрипта с сохранением исходных аргументов)
    Код (vb.net):
    Sub Elevate(msg)
        Const DQ = """"
        if msgbox(msg & vblf & "Запустить с Административными привилегиями ?", vbQuestion + vbYesNo,"Подтверждение") = vbNo then WScript.Quit 5
        Dim oShellApp: Set oShellApp = CreateObject("Shell.Application")
        ' Конкатенация аргументов
        Dim args, i: For i = 1 to WScript.Arguments.Count
            args = args & DQ & WScript.Arguments(i - 1) & DQ & " "
        Next
        oShellApp.ShellExecute WScript.FullName, DQ & WScript.ScriptFullName & DQ & " " & args, "", "runas", 1
        set oShellApp = Nothing
    End Sub

    Проверка, запущен ли скрипт от имени Администратора
    Код (vb.net):
    Function isAdminRights()
        Const KQV = &H1, KSV = &H2, HKCU = &H80000001, HKLM = &H80000002
        Set oReg = GetObject("winmgmts:root\default:StdRegProv")
        strKey = "System\CurrentControlSet\Control\Session Manager"
        intErrNum = oReg.CheckAccess(HKLM, strKey, KQV + KSV, flagAccess)
        isAdminRights = flagAccess
        Set oReg = Nothing
    End Function

    Перезапуск скрипта в консольном режиме, если запущен через WScript
    Код (vb.net):
    const vbT = 1 'vbTextCompare
    const QT = """"

    Set oFSO   = CreateObject("Scripting.FileSystemObject")
    Set oShell = CreateObject("WScript.Shell")

    ' Запущен ли из консоли
    vbHost = oFSO.GetBaseName(Wscript.FullName)
    if strcomp(vbHost, "cscript", vbT) <> 0 then
        oShell.Run """c:\windows\system32\cscript.exe""" & " //nologo " & QT & WScript.ScriptFullName & QT, 1, false
        WScript.Quit
    end if

    WScript.Echo vbHost
    WScript.StdIn.ReadLine()

    Процентный прогрессбар в консоли
    Код (vb.net):
    WScript.StdOut.Write "ProgressBar = "
    n = 0
    Do
        WScript.StdOut.Write String(3 - len(cstr(n)), " ") & n & " %"
        n = n + 1
        WScript.Sleep 20
        WScript.StdOut.Write String(5, chr(8))
    Loop While n <= 100

    Получить путь к запущенному скрипту
    Код (vb.net):

    Set oFSO = CreateObject("Scripting.FileSystemObject")
    cur = oFSO.GetParentFolderName(WScript.ScriptFullName)
    Получить текст из буфера обмена
    Код (vb.net):
    GetFromClipBoard = CreateObject("htmlfile").ParentWindow.ClipboardData.GetData("text")
    Скопировать текст в буфер обмена (используется временный файл HTA)
    Код (vb.net):
    Sub CopyToClipBoard(Data)
        Const QT = """"
        Dim oShell: set oShell = CreateObject("WScript.Shell")
        Dim oFSO:   set oFSO   = CreateObject("Scripting.FileSystemObject")
        Dim cur:  cur = oFSO.GetParentFolderName(WScript.ScriptFullName)
        Dim BuferServer: BuferServer = oFSO.BuildPath(cur, "SetClipBoard.hta")
        if not oFSO.FileExists(BuferServer) then
            on error resume next
            Dim oTS: set oTS = oFSO.OpenTextFile(BuferServer,2,true)
            if Err.Number <> 0 then ' не хватает прав для распаковки ресурса в папку со скриптом - распаковую в папку %temp%
                Err.Clear
                Dim temp: temp = oShell.ExpandEnvironmentStrings("%temp%")
                BuferServer = oFSO.BuildPath(temp, "SetClipBoard.hta")
                set oTS = oFSO.OpenTextFile(BuferServer,2,true)
            end if
            oTS.WriteLine "<html><head><HTA:APPLICATION ID=""objHTA"" WindowState=""minimize"" ShowInTaskbar=""yes""/></head>"
            oTS.WriteLine "<script language=""VBScript"">Sub Window_onLoad(): comm = objHTA.CommandLine"
            oTS.WriteLine "document.parentwindow.clipboardData.SetData ""text"", mid(comm, instr(2, comm, chr(34)) + 2)"
            oTS.WriteLine "window.close(): End Sub </script></html>"
            oTS.Close: set oTS = Nothing
            on error goto 0
        end if
        if oFSO.FileExists(BuferServer) then
            Dim windir: windir = oShell.ExpandEnvironmentStrings("%windir%") 'Получаем путь к серверу HTA
            oShell.Run windir & "\system32\mshta.exe " & QT & BuferServer & QT & " " & QT & Data & QT, 0, false
        end if
        Set oFSO = Nothing: set oShell = Nothing
    End Sub
    Упрощенный вариант:

    Код (vb.net):
    Sub CopyToClipBoard(Data)
        Dim oShell: set oShell = CreateObject("WScript.Shell")
        Dim mshta: mshta = oShell.ExpandEnvironmentStrings("%windir%") & "\system32\mshta.exe" 'Получаем путь к серверу HTA
        oShell.Run mshta & " ""vbscript:document.parentwindow.clipboardData.SetData(""text"",replace(""" & replace(Data," ","$#@!~%") & """,""$#@!~%"",chr(32)))&close()""",0,false
    End Sub

    Диалоговое окно выбора файла
    Код (vb.net):
    Function OpenFileDialogue(StartFolder)
        on error resume next
        Dim oFolder: Set oFolder = CreateObject("Shell.Application").BrowseForFolder(0, "Выбор папки с архивом или файлом XML лога AVZ", 16 + 16384, StartFolder)
        If not (oFolder is Nothing) Then OpenFileDialogue = oFolder.Self.Path
        if Err.Number <> 0 or len(OpenFileDialogue) = 0 then msgbox "Выбирать можно только папки !",,"ALF": WScript.Quit 1
        set oFolder = Nothing
    end Function

    Преобразование байтового массива в строку
    Код (vb.net):
    Function ByteArrayToString(varByteArray)
        Dim rs: Set rs = CreateObject("ADODB.Recordset")
        rs.Fields.Append "temp", 201, LenB(varByteArray) 'adLongVarChar
        rs.Open: rs.AddNew: rs("temp").AppendChunk varByteArray: rs.Update
        ByteArrayToString = rs("temp"): rs.Close: Set rs = Nothing
    End Function

    Преобразование строки в байтовый массив
    Код (vb.net):
    Function StringToByteArray(sText)
        Dim BS: Set BS = CreateObject("ADODB.Stream")
        BS.Type = 1 'adTypeBinary
        BS.Open
        Dim TS: Set TS = CreateObject("ADODB.Stream")
        With TS
            .Type = 2: .Open: .Charset = "windows-1251": .WriteText sText: .Position = 0: .CopyTo BS: .Close
        End With
        BS.Position = 0: StringToByteArray = BS.Read()
        BS.Close: Set BS = Nothing: Set TS = Nothing
    End Function

    Получить номер версии операционной системы
    Код (Visual Basic):

    ver = CreateObject("WScript.Shell").RegRead("HKEY_LOCAL_MACHINE\SOFTWARE\Microsoft\Windows NT\CurrentVersion\CurrentVersion")
    msgbox ver
     

    Определить разрядность операционной системы
    Код (vb.net):
    Function GetOSBitness()
        On Error Resume Next
        GetOSBitness = "x64"
        If oShell.ExpandEnvironmentStrings("%PROCESSOR_ARCHITECTURE%") = "x86" and oShell.ExpandEnvironmentStrings("%PROCESSOR_ARCHITEW6432%") = "%PROCESSOR_ARCHITEW6432%" then GetOSBitness = "x32"
    End Function

    Определить семейство ОС (NT или Vista).
    NT - XP, 2003; Vista - собственно Vista и выше.
    Код (vb.net):
    Function GetOSFamily()
        On Error Resume Next
        Dim ver: ver = CreateObject("WScript.Shell").RegRead("HKEY_LOCAL_MACHINE\SOFTWARE\Microsoft\Windows NT\CurrentVersion\CurrentVersion")
        GetOSFamily = "Vista": if Left(ver,1) = "5" then GetOSFamily = "NT"
    End Function
     
    Последнее редактирование: 9 апр 2015
    machito, Гимаев Наиль и Kиpилл нравится это.
  3. Dragokas
    Оффлайн

    Dragokas Very kind Developer Команда форума Супер-Модератор Разработчик Клуб переводчиков

    Сообщения:
    4.493
    Симпатии:
    4.310
    Класс для создания и распаковки архивов ZIP.
    - позволяет обходить ошибку при добавлении пустых папок*
    - позволяет добавлять файлы с атрибутом "скрытый"
    - правильно рассчитывает задержку при распаковке в папку, где уже есть другие файлы

    * за исключением уникальных случаев, когда в корне папки для упаковки попадутся:
    объект (файл или папка) со знаком ; и пустая папка с таким же именем, где на месте ; стоит любой другой знак.


    Код (vb.net):
    Option Explicit

    ' ========= Пример архивирования папки ========
    Dim Zip, ArcPath, FolderPath
    ' Где создаем архив
    ArcPath      = "h:\_VBS, WSH\Архивация\My_Class\test.zip"
    ' Какую папку архивируем
    FolderPath   = "h:\_VBS, WSH\Архивация\My_Class\ToArc"

    Set Zip = New ZipClass
    if (Zip.CreateArchive (ArcPath)) then ' старый архив затирается
        Zip.CopyFolderToArchive FolderPath
    end if
    msgbox "Папка " & FolderPath & " заархивирована."


    ' ========= Пример добавления файла в уже созданный архив ========
    Dim FilePath
    ' Какой файл архивировать
    FilePath     = "h:\_VBS, WSH\Архивация\My_Class\ZipClass.xls"

    Zip.CopyFileToArchive FilePath
    msgbox "Файл " & FilePath & " добавлен к архиву " & ArcPath


    ' ================== Распаковка архива ===================
    Dim UnpackPath
    ' Путь, куда распаковуем
    UnpackPath   = "h:\_VBS, WSH\Архивация\My_Class\Unpack"

    Zip.UnpackArchive ArcPath, UnpackPath
    msgbox "Архив распакован в папку: " & UnpackPath

    ' --------------------------------------------------------------------------------------
    ' Класс создания архивов ZIP. Maded by Dragokas
    '
    ' - позволяет обходить ошибку при добавлении пустых папок
    ' - позволяет добавлять файлы с атрибутом "скрытый"
    ' - правильно рассчитывает задержку при распаковке в папку, где уже есть другие файлы
    ' --------------------------------------------------------------------------------------
    Class ZipClass
            Private oShApp, oFSO, oArchive, ArcItemsNewCount, oFolderItems, oFolderItem, oArchiveItems, oTarget, oTargetItems, ZipHeader, isEmptyFolder, SHCONTF_FILES_AND_FOLDERS
            Private Sub Class_Initialize() 'Инициализация объектов
                'FolderItems3.Filter method ' http://msdn.microsoft.com/en-us/library/windows/desktop/bb787787(v=vs.85).aspx
                Const SHCONTF_FOLDERS               = &H20
                Const SHCONTF_NONFOLDERS            = &H40
                Const SHCONTF_INCLUDEHIDDEN         = &H80
                Const SHCONTF_INCLUDESUPERHIDDEN    = &H10000 ' Windows 7 and Later
                SHCONTF_FILES_AND_FOLDERS = SHCONTF_FOLDERS Or SHCONTF_NONFOLDERS Or SHCONTF_INCLUDEHIDDEN Or SHCONTF_INCLUDESUPERHIDDEN
                Set oShApp = CreateObject("Shell.Application")
                set oFSO = CreateObject("Scripting.FileSystemObject")
            End Sub
            Function UnpackArchive(SourceArchive, DestPath) 'Распаковка архива
                Set oArchiveItems = oShApp.NameSpace(SourceArchive).Items
                on error resume next
                if not oFSO.FolderExists(DestPath) then oFSO.CreateFolder(DestPath)
                if Err.Number <> 0 then WScript.Echo("Не хватает прав для создания временной папки распаковки!"): UnpackArchive = false: Exit Function
                on error goto 0
                Set oTarget = oShApp.NameSpace(DestPath)
                set oTargetItems = oTarget.Items
                Dim oSCR: set oSCR = CreateObject("Scripting.Dictionary"): oSCR.CompareMode = 1
                for each oFolderItem in oTargetItems: oSCR.Add oFolderItem.Name, "": Next ' подсчет кол-ва уникальных файлов
                for each oFolderItem in oArchiveItems
                    if not oSCR.Exists(oFolderItem.Name) then oSCR.Add oFolderItem.Name, ""
                Next
                'CopyHere option ENUM: http://msdn.microsoft.com/en-us/library/windows/desktop/bb787866(v=vs.85).aspx
                oTarget.CopyHere oArchiveItems, 4+16 '(4 - no ProgressBar, 16 - Yes to all, 1024 - suppress all errors)
                Do: Wscript.Sleep 200: oTargetItems.Filter SHCONTF_FILES_AND_FOLDERS, "*": Loop Until oTargetItems.Count => oSCR.Count
                UnpackArchive = true: set oArchiveItems = Nothing: set oTarget = Nothing
            End Function
            Function CreateArchive(ZipArchivePath) 'Подготовка ZIP-архива
                If lcase(oFSO.GetExtensionName(ZipArchivePath)) <> "zip" Then WScript.Echo("Указано неверное расширение для архива!"): Exit Function
                ZipHeader = "PK" & Chr(5) & Chr(6) & String(18, vbNullChar)
                on error resume next
                with oFSO.OpenTextFile(ZipArchivePath, 2, True)
                    if Err.Number <> 0 then WScript.Echo("Не хватает прав для создания архива!"): CreateArchive = False: Exit function
                .Write ZipHeader: .Close: end with
                on error goto 0
                Do: WScript.Sleep(100): Loop until oFSO.FileExists(ZipArchivePath): WScript.Sleep(200) 'выжидаем время, пока ZIP-архив не будет создан
                Set oArchive = oShApp.NameSpace(ZipArchivePath): if Not (oArchive is Nothing) Then CreateArchive = True
            End Function
            Function CopyFileToArchive(srcFilePath) 'Копируем файл в ZIP-архив
                ArcItemsNewCount = oArchive.Items.Count + 1
                Dim srcFileName: srcFileName = oFSO.GetBaseName(srcFilePath)
                for each oFolderItem in oArchive.Items ' Проверяем, существует ли уже такой файл в архиве
                    if strcomp(oFolderItem.name, srcFileName) = 0 then ArcItemsNewCount = oArchive.Items.Count - 1: exit for
                next
                oArchive.CopyHere srcFilePath ', 4 + 16 + 1024 'these options works only with unzipped folder
                Do: Wscript.Sleep 200: Loop Until oArchive.Items.Count => ArcItemsNewCount 'Выжидаем пока кол-во объектов в ZIP-архиве станет >= копируемым в него
            End Function
            Function CopyFolderToArchive(srcFolderPath) 'Копируем содержимое папки в ZIP-архив
                Dim sFilter: set oFolderItems = oShApp.NameSpace(srcFolderPath).Items
                oFolderItems.Filter SHCONTF_FILES_AND_FOLDERS, "*" 'включаем в архив скрытые файлы
                For each oFolderItem in oFolderItems ' поиск пустых папок
                    isEmptyFolder = false
                    if oFolderItem.IsFolder then if oFolderItem.GetFolder.Items.Count = 0 then isEmptyFolder = true
                    if not isEmptyFolder then sFilter = sFilter & ";" & replace(oFolderItem.Name, ";", "?") ' белый список объектов для фильтра
                Next
                oFolderItems.Filter SHCONTF_FILES_AND_FOLDERS, mid(sFilter, 1)
                ArcItemsNewCount = oArchive.Items.Count + oFolderItems.Count
                oArchive.CopyHere oFolderItems
                Do: Wscript.Sleep 200: Loop Until oArchive.Items.Count => ArcItemsNewCount 'Выжидаем пока кол-во объектов в ZIP-архиве станет >= копируемым в него
            End Function
    End Class

    Реестр Windows. Работа с ключами и параметрами.
    Код (vb.net):
    Option Explicit

    Dim oShell, sr, hive, key, subkey, value, data

    ' Список доступных сокращений разделов:
    ' HKCU - HKEY_CURRENT_USER
    ' HKLM - HKEY_LOCAL_MACHINE
    ' HKCR - HKEY_CLASSES_ROOT
    ' HKEY_USERS (не поддерживает сокращения)
    ' HKEY_CURRENT_CONFIG (не поддерживает сокращения)

    ' Типы данных:
    ' REG_SZ
    ' REG_EXPAND_SZ
    ' REG_DWORD
    ' REG_BINARY

    ' раздел
    hive = "HKCU"
    ' ключ (подраздел)
    subkey = hive & "\Environment\my subkey"
    ' параметр
    value = "my value"
    ' значение
    data = "my data"

    set oShell = CreateObject("WScript.Shell")

    ' создание в подразделе subkey параметра value со значением data
    oShell.RegWrite subkey & "\" & value, data, "REG_SZ"

    ' запись в параметр по-умолчанию значения "my Default"
    oShell.RegWrite subkey & "\", "My Default", "REG_SZ"

    ' чтение значения из параметра по-умолчанию
    ' обработка любых ошибок
    on error resume next
    ' очистка каода ошибки
    err.Clear
    sr = oShell.RegRead(subkey & "\")
    ' если не было ошибок, выводим на экран значение переменной
    if err = 0 then WScript.Echo sr

    ' чтение значения из параметра value
    err.Clear
    sr = oShell.RegRead(subkey & "\" & value)
    WScript.Echo sr
    if err <> 0 then WScript.Echo sr
    ' прекращаем обработку ошибок
    on error goto 0

    ' точно такие же проверки желательно делать и во время записи/удаления ключей/параметров

    ' удаление параметра value
    oShell.RegDelete subkey & "\" & value

    ' удаление параметра по-умолчанию - не поддерживается
    ' можно попробовать через WMI,
    ' либо вызовом командной строки с ожиданием завершения отработки команды
    oShell.Run "reg delete """ & subkey & """ /ve /f", 1, true
    ' если хочешь сделать вызов скрытым, поставь вместо 1, цифру 0
    ' будь внимателен, т.к. при скрытом вызове не работает режим ожидания завершения работы этой команды
    ' (это баг в методе Run)

    'удаление ключа subkey
    oShell.RegDelete subkey & "\"

    Реестр. Работа через WMI - Класс default:StdRegProv
     
    Последнее редактирование: 19 июл 2014
    machito, vavun и Kиpилл нравится это.
  4. лис.хвост
    Оффлайн

    лис.хвост VIP Разработчик

    Сообщения:
    630
    Симпатии:
    983
    Диалоговое окно выбора папки
    Код (vb.net):
            dim objShell
            dim objFolder
         
            set objShell = CreateObject("shell.application")
                set objFolder = objShell.BrowseForFolder(&H0, "Example",&H4000, "c:\\")
                    if (not objFolder is nothing) then
                    objShell.ShellExecute objFolder.ParentFolder.ParseName(objFolder.title).Path, "", "", "open", 1
                    end if
                set objFolder = nothing
            set objShell = nothing
     
    Последнее редактирование модератором: 4 авг 2015
    machito и Kиpилл нравится это.
  5. лис.хвост
    Оффлайн

    лис.хвост VIP Разработчик

    Сообщения:
    630
    Симпатии:
    983
    и открытие файла MS Office
     
  6. Dragokas
    Оффлайн

    Dragokas Very kind Developer Команда форума Супер-Модератор Разработчик Клуб переводчиков

    Сообщения:
    4.493
    Симпатии:
    4.310
    Вы наверное говорите по формат .xlsx, .docx (zip-контейнер). Но под MS Office следует предполагать любые его форматы, а .doc, .xls и пр. этой функцией не откроются.

    На счет универсального диалогового окна:
    Если, делать это под VBA, то там есть встроенный объект либо функции WinApi.
    Если из-под VBS, то других вариантов нет, кроме как аналогично - воспользоваться библиотекой-оберткой DynWrapX, чтобы можно было задействовать WinAPI.
     
    Последнее редактирование: 4 авг 2015
    лис.хвост и Kиpилл нравится это.
  7. лис.хвост
    Оффлайн

    лис.хвост VIP Разработчик

    Сообщения:
    630
    Симпатии:
    983
    можно пример?
    --- Объединённое сообщение, 5 авг 2015 ---
    можно еще как-то так попробовать
    Код (vb.net):
    '-----------------------------------------------------------------------------------------------------------------------------------------------
    Dim fso, file, name
    '-----------------------------------------------------------------------------------------------------------------------------------------------
    Set fso = CreateObject("Scripting.FileSystemObject")
    name = "c:\1\test.html"
    If fso.FileExists(name) Then
    fso.DeleteFile name, True
    End If
        fso.CreateTextFile(name)
    Set Log_file = fso.OpenTextFile(name, 2, True)

    Log_file.writeLine "<!DOCTYPE>"
    Log_file.writeLine "<html>"
    Log_file.writeLine "<head>"
    Log_file.writeLine "<meta http-equiv=" & Chr(34) & "Content-Type" & Chr(34) & "content=" & Chr(34) & "text/html; charset=windows-1251" & Chr(34) & " />"
    Log_file.writeLine "<title>...</title>"
    Log_file.writeLine "</head>"
    Log_file.writeLine "<body>"
    Log_file.writeLine "<form id=" & Chr(34) & "fileload" & Chr(34) & " action=" & Chr(34) & "#" & Chr(34) & " method=" & Chr(34) & "post" & Chr(34) & " enctype=" & Chr(34) & "multipart/form-data" & Chr(34) & "><input type=" & Chr(34) & "file" & Chr(34) & " onchange=" & Chr(34) & "TestValue(this)" & Chr(34) & " name=" & Chr(34) & "anyfile" & Chr(34) & " id=" & Chr(34) & "inpField" & Chr(34) & "/></form>"
    Log_file.writeLine "<script type=" & Chr(34) & "text/javascript" & Chr(34) & ">"
    Log_file.writeLine "function TestValue(a){"
    Log_file.writeLine "alert(a.value);"
    Log_file.writeLine "}"
    Log_file.writeLine "</script>"
    Log_file.writeLine "</body>"
    Log_file.writeLine "</html>"
    Log_file.Close

      Set objIE = CreateObject("InternetExplorer.Application")
        objIE.Navigate(name)
        Do While objIE.Busy : Wscript.Sleep 700 : Loop

      objIE.Top = 350
      objIE.Left = 100
      objIE.Height = 400
      objIE.Width  = 750
     
  8. Dragokas
    Оффлайн

    Dragokas Very kind Developer Команда форума Супер-Модератор Разработчик Клуб переводчиков

    Сообщения:
    4.493
    Симпатии:
    4.310
    tisha, в основном на VBS все делают по этим двум предложенным Вами примерам.
    Хотя, чтобы не грузить ослика (а он иногда бывает весьма упрямым), используют HTA. Думаю, слышали о таком...

    Пример, обертки на WinAPI можно посмотреть в этой теме: DinamicWrapperX
    Качаете. Запускаете калькулятор Windows, запускаете скрипт. А на счет диалогового окна может быть я погорячился.
    Функцией GetOpenFileName легко воспользоваться из под C++, VB6, VB.NET..., а в VBS нет возможности нативно создать произвольную структуру (пользовательский тип), получить адрес переменной. Конечно, чисто ради интереса, могу попробовать поколдовать.
     

Поделиться этой страницей