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
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
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()
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
Set oFSO = CreateObject("Scripting.FileSystemObject")
cur = oFSO.GetParentFolderName(WScript.ScriptFullName)
GetFromClipBoard = CreateObject("htmlfile").ParentWindow.ClipboardData.GetData("text")
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
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
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
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
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
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
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
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
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 & "\"
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
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
и открытие файла MS OfficeДиалоговое окно выбора папки
можно пример?кроме как аналогично - воспользоваться библиотекой-оберткой DynWrapX, чтобы можно было задействовать WinAPI.
'-----------------------------------------------------------------------------------------------------------------------------------------------
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
We use cookies and similar technologies for the following purposes:
Do you accept cookies and these technologies?
We use cookies and similar technologies for the following purposes:
Do you accept cookies and these technologies?