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

Dragokas

Angry & Scary Developer
Команда форума
Супер-Модератор
Разработчик
Клуб переводчиков
Сообщения
7,814
Реакции
6,593
Структура

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

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

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

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

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

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

Вложения

  • WHS и некоторые объекты OLE Automation.rar
    131.7 KB · Просмотры: 31
Последнее редактирование:
Получение повышенных привилегий Администратора (перезапуск скрипта с сохранением исходных аргументов)
VB.NET / VBA:
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 / VBA:
Function isAdminRights()
    Const KQV = 1, KSV = 2, HKLM = &H80000002
    Dim oReg, strKey, intErrNum, flagAccess
    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 / VBA:
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 QT & oShell.ExpandEnvironmentStrings("%SystemRoot%") & "\system32\cscript.exe" & QT & " //nologo " & QT & WScript.ScriptFullName & QT, 1, false
    WScript.Quit
end if

WScript.Echo vbHost
WScript.StdIn.ReadLine()

Процентный прогрессбар в консоли
VB.NET / VBA:
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 / VBA:
Set oFSO = CreateObject("Scripting.FileSystemObject")
cur = oFSO.GetParentFolderName(WScript.ScriptFullName)

Получить текст из буфера обмена
VB.NET / VBA:
GetFromClipBoard = CreateObject("htmlfile").ParentWindow.ClipboardData.GetData("text")

Скопировать текст в буфер обмена (используется временный файл HTA)
VB.NET / VBA:
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 / VBA:
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 / VBA:
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 / VBA:
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 / VBA:
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

Получить номер версии операционной системы
Код:
ver = CreateObject("WScript.Shell").RegRead("HKEY_LOCAL_MACHINE\SOFTWARE\Microsoft\Windows NT\CurrentVersion\CurrentVersion")
msgbox ver

Определить разрядность операционной системы
VB.NET / VBA:
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 / VBA:
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
 
Последнее редактирование:
Класс для создания и распаковки архивов ZIP.
- позволяет обходить ошибку при добавлении пустых папок*
- позволяет добавлять файлы с атрибутом "скрытый"
- правильно рассчитывает задержку при распаковке в папку, где уже есть другие файлы

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


VB.NET / VBA:
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 / VBA:
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

Преобразовать длинный Hex (8 байт) в Decimal и обратно
VB.NET / VBA:
Function HexToDec(strHex)
    Dim i
    Dim size
    Dim ret
    size = Len(strHex) - 1
    ret = CDbl(0)
    For i = 0 To size
        ret = ret + CDbl("&H" & Mid(strHex, size - i + 1, 1)) * (CDbl(16) ^ CDbl(i))
    Next
    HexToDec = ret
End Function
Function DecToHex(dblNumber)
    Dim Q
    Dim ret

    ret = ""
    Q = CDbl(Fix(dblNumber))
    While Q > 0
        ret = Hex(Q - Fix(Q / 16) * 16) & ret
        Q = Fix(Q / CDbl(16))
    Wend
    DecToHex = ret
End Function
 
Последнее редактирование:
Диалоговое окно выбора папки
VB.NET / VBA:
        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
 
Последнее редактирование модератором:
Вы наверное говорите по формат .xlsx, .docx (zip-контейнер). Но под MS Office следует предполагать любые его форматы, а .doc, .xls и пр. этой функцией не откроются.

На счет универсального диалогового окна:
Если, делать это под VBA, то там есть встроенный объект либо функции WinApi.
Если из-под VBS, то других вариантов нет, кроме как аналогично - воспользоваться библиотекой-оберткой DynWrapX, чтобы можно было задействовать WinAPI.
 
Последнее редактирование:
кроме как аналогично - воспользоваться библиотекой-оберткой DynWrapX, чтобы можно было задействовать WinAPI.
можно пример?
можно еще как-то так попробовать
VB.NET / VBA:
'-----------------------------------------------------------------------------------------------------------------------------------------------
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
 
tisha, в основном на VBS все делают по этим двум предложенным Вами примерам.
Хотя, чтобы не грузить ослика (а он иногда бывает весьма упрямым), используют HTA. Думаю, слышали о таком...

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

UPD. Такая возможность на самом деле есть. См. 关于DynamicWrapper请教 - 高级功能研发区 - 金字塔客服中心 - 专业程序化交易软件提供商 - 0
 
Последнее редактирование:
Назад
Сверху Снизу