Ru-Board.club
← Вернуться в раздел «Прикладное программирование»

» Программирование "удобняшек" на VBScript

Автор: Hugo121
Дата сообщения: 11.05.2010 10:07
obbnd, [more=Код без скачивания]Такой вариант, (без скачивания), переделал вероятно уже пробегавший здесь код (пути поменяйте):

Код:     ' FSO Constants
    t = timer
    Const ForReading = 1
    Const ForAppending    = 8
    Const TristateUseDefault= -2
    
    ' Variables
    Dim objFSO, objTS, objOTS, objfile, tempStr

    ' Instantiate the object
    Set objFSO = CreateObject("Scripting.FileSystemObject")

    ' open the text file read only
    Set objTS = objFSO.OpenTextFile("C:\temp\obbnd\Tor_ip_list_ALL.csv", ForReading, False, TristateUseDefault)
    ' We now open the file to write it out
    If objFSO.FileExists("C:\temp\obbnd\Tor_ip_list_ALL.txt") Then
        Set objOTS = objFSO.OpenTextFile("C:\temp\obbnd\Tor_ip_list_ALL.txt", ForAppending) 'открываем итоговый файл для добавления записей
    Else
        Set objfile = objFSO.CreateTextFile("C:\temp\obbnd\Tor_ip_list_ALL.txt")
        Set objfile = Nothing
        Set objOTS = objFSO.OpenTextFile("C:\temp\obbnd\Tor_ip_list_ALL.txt", ForAppending)
    End if

    Do While objTS.AtEndOfStream <> True
    tempStr = objTS.ReadLine()
        objOTS.Write Replace(tempStr,".","-") & "/" & tempStr & vbCrLf
    Loop
    
    ' Close all files after we read it in.
    objTS.Close
    Set objTS = Nothing
    objOTS.Close
    Set objOTS = Nothing
    Set objFSO = Nothing
t=timer-t
msgbox "OK! Run in " & t
Автор: seforsource
Дата сообщения: 11.05.2010 10:15
to obbnd


Код: Option Explicit
rem Описание констант
rem Описание переменных
Dim result
result = PerformMutation("E:\Tor_ip_list_ALL.csv")
rem Функции и процедуры
Function PerformMutation(ByVal file_) 'Ни чего не возвращает, но может
    On Error Resume Next
        Const delim = "."
        Const delimer = "-"
        Const divider = "/"
        Const IomodeRead = 1
        Const IomodeWrite = 2
        Dim FSO, StreamRead, StreamWrite, TextLine
        Set FSO = CreateObject("Scripting.FileSystemObject")
        Set StreamRead = FSO.OpenTextFile(file_, IomodeRead)
        Set StreamWrite = FSO.CreateTextFile(file_ & ".txt", IomodeWrite)
        If Err.Number = 0 Then
            While Not StreamRead.AtEndOfStream
                TextLine = StreamRead.ReadLine
                TextLine = Join(Split(TextLine, delim), delimer) & divider & TextLine
                StreamWrite.WriteLine TextLine
            Wend
        End If
        StreamRead.Close
        StreamWrite.Close
    Err.Clear
    rem возврат значения функции PerformMutation = true
End Function
Автор: igor_andreev
Дата сообщения: 11.05.2010 10:40

Цитата:
Код без скачивания

А скачивание вот например:
http://forum.ru-board.com/topic.cgi?forum=5&topic=4582&start=247&limit=1&m=1#1
Автор: Hugo121
Дата сообщения: 11.05.2010 11:00
Да, собрал на другом примере из этой ветки - работает. Позже на этом примере опробую...

Добавлено:
Вполне неплохо работает:
[more=заготовка]

Код:     t = timer
    ' FSO Constants
    Const ForReading = 1
    Const ForAppending    = 8
    Const TristateUseDefault= -2
    
    ' Variables
    Dim objFSO, objTS, objOTS, objfile, tempStr

    Set objFSO = CreateObject("Scripting.FileSystemObject")

    
    'сохранить как...
strFile = "C:\temp\obbnd\Tor_ip_list_ALL.csv"

'адрес страницы в инете
strURL = "http://torstat.xenobite.eu/ip_list_all.php/Tor_ip_list_ALL.csv"

On Error Resume Next

Set objHTTP = CreateObject("MSXML2.XMLHTTP")
Call objHTTP.Open("GET", strURL, False)
objHTTP.Send
Set flink = objFSO.OpenTextFile(strFile, 2, True)
flink.Write objHTTP.ResponseText
flink.Close

If Err<>0 Then WScript.Quit

Set objHTTP = Nothing

    ' open the text file read only
    Set objTS = objFSO.OpenTextFile("C:\temp\obbnd\Tor_ip_list_ALL.csv", ForReading, False, TristateUseDefault)
    ' We now open the file to write it out
    If objFSO.FileExists("C:\temp\obbnd\Tor_ip_list_ALL.txt") Then
        Set objOTS = objFSO.OpenTextFile("C:\temp\obbnd\Tor_ip_list_ALL.txt", ForAppending) 'открываем итоговый файл для добавления записей
    Else
        Set objfile = objFSO.CreateTextFile("C:\temp\obbnd\Tor_ip_list_ALL.txt")
        Set objfile = Nothing
        Set objOTS = objFSO.OpenTextFile("C:\temp\obbnd\Tor_ip_list_ALL.txt", ForAppending)
    End if

    Do While objTS.AtEndOfStream <> True
    tempStr = objTS.ReadLine()
        objOTS.Write Replace(tempStr,".","-") & "/" & tempStr & vbCrLf
    Loop
    
    ' Close all files after we read it in.
    objTS.Close
    Set objTS = Nothing
    objOTS.Close
    Set objOTS = Nothing
    Set objFSO = Nothing
t=timer-t
msgbox "OK! Run in " & t
Автор: Black_Lung
Дата сообщения: 12.05.2010 16:51
Как без "if then' обработать много неизвестных параметров которые могут иметь 1 из 10 разных значений и для каждого значения своя процедура.

C 10 "if then" тоже работает но как-то некрасиво оно, а еще количество значений если увеличится например до 100.
Автор: Rush
Дата сообщения: 12.05.2010 17:39
Black_Lung
Можно select case использовать.
Что-то типа:
Код:
num = 2
msgbox MyVal(num)

function MyVal(value)
select case value
case 1 MyVal = "выбран 1-й пункт"
case 2 MyVal = "выбран 2-й пункт"
case 3 MyVal = "выбран 3-й пункт"
case 4 MyVal = "выбран 4-й пункт"
end select
end function
Автор: Mark_Titov
Дата сообщения: 12.05.2010 23:14
Доброе время суток всем...
Подскажите пож-ста как можно реализовать отправку почты по именно в локалке при помощи скрипта?
Желательно с использованием уч записи MS Exchange 2003/2007...
Думю что должны быть варианты ведь, весь инет перелопатил, так и не нашел ничего...
Система ХР, есть домен, права админа...

Очень нужно, помогите плиззз...
Заранее благодарю...
Автор: obbnd
Дата сообщения: 13.05.2010 01:10
seforsource
igor_andreev
Hugo121

Большое спасибо!
Автор: Mark_Titov
Дата сообщения: 13.05.2010 12:56
...Други поможите пож-ста, в скриптах я никак.
Есть 3 скрипта, типа инвентаризация компов в локалке.
Все рабочие, первый все в txt записывает - а вот остальные два выводят просто на экран всю инфу!

Нужно их все 3 объединить и что бы все выводилось в файл, задача вроде не трудная для вас, а для меня темный лес...


Код: on error resume Next

Set oShell = CreateObject("wscript.Shell")
Set env = oShell.environment("Process")
strComputer = env.Item("Computername")
Const HKEY_LOCAL_MACHINE = &H80000002
Const UnInstPath = "SOFTWARE\Microsoft\Windows\CurrentVersion\Uninstall\"
Set oReg=GetObject("winmgmts:{impersonationLevel=impersonate}!\\" &_
".\root\default:StdRegProv")


report = strComputer & " Computer Inventory" & vbCrLf & "******************************************" & vbCrLf & vbCrLf
Set objWMIService = GetObject("winmgmts:\\" & strComputer & "\root\cimv2")
Set colItems = objWMIService.ExecQuery("Select * from Win32_OperatingSystem",,48)

report = report & vbCrLf & "******************************************" & vbCrLf
report = report & "OS Information" & vbCrLf & "******************************************" & vbCrLf & vbCrLf
For Each objItem in colItems
report = report & strComputer & vbCrLf & "OS Details"& vbCrlf
report = report & "Caption: " & objItem.Caption & vbCrLf
report = report & "Description: " & objItem.Description & vbCrLf
report = report & "EncryptionLevel: " & objItem.EncryptionLevel & vbCrLf
report = report & "InstallDate: " & objItem.InstallDate & vbCrLf
report = report & "Manufacturer: " & objItem.Manufacturer & vbCrLf
report = report & "MaxNumberOfProcesses: " & objItem.MaxNumberOfProcesses & vbCrLf
report = report & "Name: " & objItem.Name & vbCrLf
report = report & "Organization: " & objItem.Organization & vbCrLf
report = report & "OSProductSuite: " & objItem.OSProductSuite & vbCrLf
report = report & "RegisteredUser: " & objItem.RegisteredUser & vbCrLf
report = report & "SerialNumber: " & objItem.SerialNumber & vbCrLf
report = report & "ServicePackMajorVersion: " & objItem.ServicePackMajorVersion & vbCrLf
report = report & "ServicePackMinorVersion: " & objItem.ServicePackMinorVersion & vbCrLf
report = report & "Version: " & objItem.Version & vbCrLf
report = report & "WindowsDirectory: " & objItem.WindowsDirectory & vbCrLf
Next

Set colSettings = objWMIService.ExecQuery _
("Select * from Win32_ComputerSystem")
report = report & vbCrLf & "******************************************" & vbCrLf
report = report & "Memory and Processor Information" & vbCrLf & "******************************************" & vbCrLf & vbCrLf
For Each objComputer in colSettings
'report = report & objComputer.Name & vbcrlf
report = report & objComputer.TotalPhysicalMemory /1024\1024+1 & "MB Total memory" & vbcrlf
Next
Set colSettings = objWMIService.ExecQuery _
("Select * from Win32_Processor")
For Each objProcessor in colSettings
report = report & objProcessor.Description & " Processor" & vbCrLf
Next

report = report & vbCrLf & "******************************************" & vbCrLf
report = report & "Disk Drive Information" & vbCrLf & "******************************************" & vbCrLf & vbCrLf

Set objWMIService = GetObject("winmgmts:")
Set objLogicalDisk = objWMIService.Get("Win32_LogicalDisk.DeviceID='c:'")
report = report & objLogicalDisk.FreeSpace /1024\1024+1 & "MB Free Disk Space" & vbCrLf
report = report & objLogicalDisk.Size /1024\1024+1 & "MB Total Disk Space" & vbCrLf

oReg.EnumKey HKEY_LOCAL_MACHINE, UnInstPath, arrSubKeys
software = vbCrLf & "******************************************" & vbCrLf
software = software & vbCrLf & "Installed Software" & vbCrLf & "******************************************" & vbCrLf & vbCrLf
For Each subkey In arrSubKeys
'MsgBox subkey
If Left (subkey, 1) <> "{" Then
software = software & subkey & vbCrLf
End If
Next

Set fso = CreateObject("Scripting.FileSystemObject")
Set ts = fso.CreateTextFile (strComputer & ".txt", ForWriting)
ts.write report
ts.write software
'MsgBox Report
MsgBox "Done"
Автор: DanCap
Дата сообщения: 13.05.2010 17:19
Добрый день!
помогите Excel выдает ошибку #ИМЯ?
вот листинг скрипта )
Set objExcel = CreateObject("Excel.Application")
objExcel.Visible = True
Set objWorkBook = objExcel.Workbooks.Open("D:\12.xls")
objExcel.Cells(9, 14) = "=ПСТР(ЯЧЕЙКА(""имяфайла""),ПОИСК(""["",ЯЧЕЙКА(""имяфайла""))+1,ПОИСК(""]"",ЯЧЕЙКА(""имяфайла""))-ПОИСК(""["",ЯЧЕЙКА(""имяфайла""))-5)"


необходимо из имени файла взять данные и занести их в ячейку, после запуска скрипта появляется ошибка, но если начать редактировать ячейку и сразу выйти функция срабатывает.
В чем может быть проблема??
Автор: Hugo121
Дата сообщения: 13.05.2010 17:29
Пишите формулу на английском или используйте типа
Range("A1").FormulaLocal = "=ТДАТА()"
Автор: Black_Lung
Дата сообщения: 14.05.2010 14:21
Mark_Titov
Все скопировать в один файл и заменить wscript.echo xxx на ts.write xxx
DanCap
Перед начинанием редактирования включить запись макроса потом то что оно делает внести в скрипт.

И у меня вопрос:
отркрываю файл set db = FSO.OpenTextFile("xxx")
читаю db.ReadLine
Есть ли функция возврата на начало файла на 1ю строку?





Автор: magiogre
Дата сообщения: 14.05.2010 15:40
//Serv01/Pub/Название_папки1[до14.05.2010]
//Serv01/Pub/Название_папки2[до15.06.2010]


Необходим скрипт, который будет удалять все папки (и вложенные в них подпапки и файлы) из /Pub/, у которых дата, которая указана в названии, меньше или равна текущей дате.

Папки без даты в названии не трогать.

Помогите решить задачу)
Автор: Mark_Titov
Дата сообщения: 14.05.2010 15:52

Цитата:
Mark_Titov
Все скопировать в один файл и заменить wscript.echo xxx на ts.write xxx

...Неа, не идет. Но все равно спасибо.

P.s
Нужно что бы все писалось в файл который создается 1 скриптом.
Автор: johnrzn
Дата сообщения: 14.05.2010 15:56
Как скопировать текст в буфер обмена?
Автор: Black_Lung
Дата сообщения: 14.05.2010 17:05
Mark_Titov
Это Идеть:
[more]

Код:
Dim WshShell
Set WshShell = WScript.CreateObject("WScript.Shell")
Dim strComputer, message

Dim intMonitorCount
Dim oRegistry, sBaseKey, sBaseKey2, sBaseKey3, skey, skey2, skey3
Dim sValue
dim i, iRC, iRC2, iRC3
Dim arSubKeys, arSubKeys2, arSubKeys3, arrintEDID
Dim strRawEDID
Dim ByteValue, strSerFind, strMdlFind
Dim intSerFoundAt, intMdlFoundAt, findit
Dim tmp, tmpser, tmpmdl, tmpctr
Dim batch, bHeader
batch = False

If WScript.Arguments.Count = 1 Then
strComputer = WScript.Arguments(0)
batch = True
Else
strComputer = wshShell.ExpandEnvironmentStrings("%COMPUTERNAME%")
strComputer = InputBox("Check Monitor info for what PC","PC Name?",strComputer)
End If

If strcomputer = "" Then WScript.Quit
strComputer = UCase(strComputer)



Set oShell = CreateObject("wscript.Shell")
Set env = oShell.environment("Process")
strComputer = env.Item("Computername")
Const HKEY_LOCAL_MACHINE = &H80000002
Const UnInstPath = "SOFTWARE\Microsoft\Windows\CurrentVersion\Uninstall\"
Set oReg=GetObject("winmgmts:{impersonationLevel=impersonate}!\\" &_
".\root\default:StdRegProv")


report = strComputer & " Computer Inventory" & vbCrLf & "******************************************" & vbCrLf & vbCrLf
Set objWMIService = GetObject("winmgmts:\\" & strComputer & "\root\cimv2")
Set colItems = objWMIService.ExecQuery("Select * from Win32_OperatingSystem",,48)

report = report & vbCrLf & "******************************************" & vbCrLf
report = report & "OS Information" & vbCrLf & "******************************************" & vbCrLf & vbCrLf
For Each objItem in colItems
report = report & strComputer & vbCrLf & "OS Details"& vbCrlf
report = report & "Caption: " & objItem.Caption & vbCrLf
report = report & "Description: " & objItem.Description & vbCrLf
report = report & "EncryptionLevel: " & objItem.EncryptionLevel & vbCrLf
report = report & "InstallDate: " & objItem.InstallDate & vbCrLf
report = report & "Manufacturer: " & objItem.Manufacturer & vbCrLf
report = report & "MaxNumberOfProcesses: " & objItem.MaxNumberOfProcesses & vbCrLf
report = report & "Name: " & objItem.Name & vbCrLf
report = report & "Organization: " & objItem.Organization & vbCrLf
report = report & "OSProductSuite: " & objItem.OSProductSuite & vbCrLf
report = report & "RegisteredUser: " & objItem.RegisteredUser & vbCrLf
report = report & "SerialNumber: " & objItem.SerialNumber & vbCrLf
report = report & "ServicePackMajorVersion: " & objItem.ServicePackMajorVersion & vbCrLf
report = report & "ServicePackMinorVersion: " & objItem.ServicePackMinorVersion & vbCrLf
report = report & "Version: " & objItem.Version & vbCrLf
report = report & "WindowsDirectory: " & objItem.WindowsDirectory & vbCrLf
Next

Set colSettings = objWMIService.ExecQuery _
("Select * from Win32_ComputerSystem")
report = report & vbCrLf & "******************************************" & vbCrLf
report = report & "Memory and Processor Information" & vbCrLf & "******************************************" & vbCrLf & vbCrLf
For Each objComputer in colSettings
'report = report & objComputer.Name & vbcrlf
report = report & objComputer.TotalPhysicalMemory /1024\1024+1 & "MB Total memory" & vbcrlf
Next
Set colSettings = objWMIService.ExecQuery _
("Select * from Win32_Processor")
For Each objProcessor in colSettings
report = report & objProcessor.Description & " Processor" & vbCrLf
Next

report = report & vbCrLf & "******************************************" & vbCrLf
report = report & "Disk Drive Information" & vbCrLf & "******************************************" & vbCrLf & vbCrLf

Set objWMIService = GetObject("winmgmts:")
Set objLogicalDisk = objWMIService.Get("Win32_LogicalDisk.DeviceID='c:'")
report = report & objLogicalDisk.FreeSpace /1024\1024+1 & "MB Free Disk Space" & vbCrLf
report = report & objLogicalDisk.Size /1024\1024+1 & "MB Total Disk Space" & vbCrLf

oReg.EnumKey HKEY_LOCAL_MACHINE, UnInstPath, arrSubKeys
software = vbCrLf & "******************************************" & vbCrLf
software = software & vbCrLf & "Installed Software" & vbCrLf & "******************************************" & vbCrLf & vbCrLf
For Each subkey In arrSubKeys
'MsgBox subkey
If Left (subkey, 1) <> "{" Then
software = software & subkey & vbCrLf
End If
Next

Set fso = CreateObject("Scripting.FileSystemObject")
Set ts = fso.CreateTextFile (strComputer & ".txt", ForWriting)
ts.write report
ts.write software
'MsgBox Report
MsgBox "Done"


'MonitorInfo.vbs

'this code is based on the EEDID spec found at http://www.vesa.org
'and by my hacking around in the windows registry
'the code was tested on WINXP,WIN2K and WIN2K3
'it should work on WINME and WIN98SE
'It should work with multiple monitors, but that hasn't been tested either.
'*****************************************************************************************
'
'*****************************************************************************************
'It should be noted that this is not 100% reliable
'I have witnessed occasions where for one reason or another windows
'can't or doesn't read the EDID info at boot (example would be someone
'booting with the monitor turned off) and so windows changes the active
'monitor to "Default_Monitor"
'Another reason for reliability problems is that there is no
'requirement in the EDID spec that a manufacture include the
'serial number in the EDID data AND only EDIDv1.2 and beyond
'have a requirement that the EDID contain a descriptive
'model name
'That being said, here goes....
'*****************************************************************************************
'
'*****************************************************************************************
'Monitors are stored in HKLM\SYSTEM\CurrentControlSet\Enum\DISPLAY\
'
'Unfortunately, not only monitors are stored here Video Chipsets and maybe some other stuff
'is also here.
'
'Monitors in "HKLM\SYSTEM\CurrentControlSet\Enum\DISPLAY\" are organized like this:
' HKLM\SYSTEM\CurrentControlSet\Enum\DISPLAY\<VESA_Monitor_ID>\<PNP_ID>\
'Since not only monitors will be found under DISPLAY sub key you need to find out which
'devices are monitors.
'This can be deterimined by looking at the value "HardwareID" located
'at HKLM\SYSTEM\CurrentControlSet\Enum\DISPLAY\<VESA_Monitor_ID\<PNP_ID>\
'If the device is a monitor then the "HardwareID" value will contain the data "Monitor\<VESA_Monitor_ID>"
'
'The Next difficulty is that all monitors are stored here not just the one curently plugged in.
'So, If you ever switched monitors the old one(s) will still be in the registry.
'You can tell which monitor(s) are active because they will have a sub-key named "Control"
'*****************************************************************************************
'

If batch Then
Dim fso,logfile, appendout
logfile = wshShell.ExpandEnvironmentStrings("%userprofile%") & "\desktop\MonitorInfo.csv"

'setup Log
Const ForAppend = 8
Set fso = CreateObject("Scripting.FileSystemObject")
If Not fso.FileExists(logfile) Then bHeader = True
set appendout = fso.OpenTextFile(logfile, ForAppend, True)

If bHeader Then
appendout.writeline "Computer,Model,Serial #,Vendor ID,Manufacture Date,Messages"
End If
End If

Dim strarrRawEDID()
intMonitorCount=0
Const HKLM = &H80000002 'HKEY_LOCAL_MACHINE
'get a handle to the WMI registry object
On Error Resume Next
Set oRegistry = GetObject("winmgmts:{impersonationLevel=impersonate}!\\" & strComputer & "/root/default:StdRegProv")

If Err <> 0 Then
If batch Then
EchoAndLog strComputer & ",,,,," & Err.Description
Else
MsgBox "Failed. " & Err.Description,vbCritical + vbOKOnly,strComputer
WScript.Quit
End If
End If


sBaseKey = "SYSTEM\CurrentControlSet\Enum\DISPLAY\"
'enumerate all the keys HKLM\SYSTEM\CurrentControlSet\Enum\DISPLAY\
iRC = oRegistry.EnumKey(HKLM, sBaseKey, arSubKeys)
For Each sKey In arSubKeys
'we are now in the registry at the level of:
'HKLM\SYSTEM\CurrentControlSet\Enum\DISPLAY\<VESA_Monitor_ID\
'we need to dive in one more level and check the data of the "HardwareID" value
sBaseKey2 = sBaseKey & sKey & "\"
iRC2 = oRegistry.EnumKey(HKLM, sBaseKey2, arSubKeys2)
For Each sKey2 In arSubKeys2
'now we are at the level of:
'HKLM\SYSTEM\CurrentControlSet\Enum\DISPLAY\<VESA_Monitor_ID\<PNP_ID>\
'so we can check the "HardwareID" value
oRegistry.GetMultiStringValue HKLM, sBaseKey2 & sKey2 & "\", "HardwareID", sValue
for tmpctr=0 to ubound(svalue)
If lcase(left(svalue(tmpctr),8))="monitor\" then
'If it is a monitor we will check for the existance of a control subkey
'that way we know it is an active monitor
sBaseKey3 = sBaseKey2 & sKey2 & "\"
iRC3 = oRegistry.EnumKey(HKLM, sBaseKey3, arSubKeys3)
For Each sKey3 In arSubKeys3
'Kaplan edit
strRawEDID = ""
If skey3="Control" Then
'If the Control sub-key exists then we should read the edid info
oRegistry.GetBinaryValue HKLM, sbasekey3 & "Device Parameters\", "EDID", arrintEDID
If vartype(arrintedid) <> 8204 then 'and If we don't find it...
strRawEDID="EDID Not Available" 'store an "unavailable message
else
for each bytevalue in arrintedid 'otherwise conver the byte array from the registry into a string (for easier processing later)
strRawEDID=strRawEDID & chr(bytevalue)
Next
End If
'now take the string and store it in an array, that way we can support multiple monitors
redim preserve strarrRawEDID(intMonitorCount)
strarrRawEDID(intMonitorCount)=strRawEDID
intMonitorCount=intMonitorCount+1
End If
Next
End If
Next
Next
Next
'*****************************************************************************************
'now the EDID info for each active monitor is stored in an array of strings called strarrRawEDID
'so we can process it to get the good stuff out of it which we will store in a 5 dimensional array
'called arrMonitorInfo, the dimensions are as follows:
'0=VESA Mfg ID, 1=VESA Device ID, 2=MFG Date (M/YYYY),3=Serial Num (If available),4=Model Descriptor
'5=EDID Version
'*****************************************************************************************
On Error Resume Next
dim arrMonitorInfo()
redim arrMonitorInfo(intMonitorCount-1,5)
dim location(3)
for tmpctr=0 to intMonitorCount-1
If strarrRawEDID(tmpctr) <> "EDID Not Available" then
'*********************************************************************
'first get the model and serial numbers from the vesa descriptor
'blocks in the edid. the model number is required to be present
'according to the spec. (v1.2 and beyond)but serial number is not
'required. There are 4 descriptor blocks in edid at offset locations
'&H36 &H48 &H5a and &H6c each block is 18 bytes long
'*********************************************************************
location(0)=mid(strarrRawEDID(tmpctr),&H36+1,18)
location(1)=mid(strarrRawEDID(tmpctr),&H48+1,18)
location(2)=mid(strarrRawEDID(tmpctr),&H5a+1,18)
location(3)=mid(strarrRawEDID(tmpctr),&H6c+1,18)

'you can tell If the location contains a serial number If it starts with &H00 00 00 ff
strSerFind=chr(&H00) & chr(&H00) & chr(&H00) & chr(&Hff)
'or a model description If it starts with &H00 00 00 fc
strMdlFind=chr(&H00) & chr(&H00) & chr(&H00) & chr(&Hfc)

intSerFoundAt=-1
intMdlFoundAt=-1
for findit = 0 to 3
If instr(location(findit),strSerFind)>0 then
intSerFoundAt=findit
End If
If instr(location(findit),strMdlFind)>0 then
intMdlFoundAt=findit
End If
Next

'If a location containing a serial number block was found then store it
If intSerFoundAt<>-1 then
tmp=right(location(intSerFoundAt),14)
If instr(tmp,chr(&H0a))>0 then
tmpser=trim(left(tmp,instr(tmp,chr(&H0a))-1))
Else
tmpser=trim(tmp)
End If
'although it is not part of the edid spec it seems as though the
'serial number will frequently be preceeded by &H00, this
'compensates for that
If left(tmpser,1)=chr(0) then tmpser=right(tmpser,len(tmpser)-1)
else
tmpser="Not Found"
End If

'If a location containing a model number block was found then store it
If intMdlFoundAt<>-1 then
tmp=right(location(intMdlFoundAt),14)
If instr(tmp,chr(&H0a))>0 then
tmpmdl=trim(left(tmp,instr(tmp,chr(&H0a))-1))
else
tmpmdl=trim(tmp)
End If
'although it is not part of the edid spec it seems as though the
'serial number will frequently be preceeded by &H00, this
'compensates for that
If left(tmpmdl,1)=chr(0) then tmpmdl=right(tmpmdl,len(tmpmdl)-1)
else
tmpmdl="Not Found"
End If

'**************************************************************
'Next get the mfg date
'**************************************************************
Dim tmpmfgweek,tmpmfgyear,tmpmdt
'the week of manufacture is stored at EDID offset &H10
tmpmfgweek=asc(mid(strarrRawEDID(tmpctr),&H10+1,1))

'the year of manufacture is stored at EDID offset &H11
'and is the current year -1990
tmpmfgyear=(asc(mid(strarrRawEDID(tmpctr),&H11+1,1)))+1990

'store it in month/year format
tmpmdt=month(dateadd("ww",tmpmfgweek,datevalue("1/1/" & tmpmfgyear))) & "/" & tmpmfgyear

'**************************************************************
'Next get the edid version
'**************************************************************
'the version is at EDID offset &H12
Dim tmpEDIDMajorVer, tmpEDIDRev, tmpVer
tmpEDIDMajorVer=asc(mid(strarrRawEDID(tmpctr),&H12+1,1))

'the revision level is at EDID offset &H13
tmpEDIDRev=asc(mid(strarrRawEDID(tmpctr),&H13+1,1))

'store it in month/year format
tmpver=chr(48+tmpEDIDMajorVer) & "." & chr(48+tmpEDIDRev)

'**************************************************************
'Next get the mfg id
'**************************************************************
'the mfg id is 2 bytes starting at EDID offset &H08
'the id is three characters long. using 5 bits to represent
'each character. the bits are used so that 1=A 2=B etc..
'
'get the data
Dim tmpEDIDMfg, tmpMfg
dim Char1, Char2, Char3
Dim Byte1, Byte2
tmpEDIDMfg=mid(strarrRawEDID(tmpctr),&H08+1,2)
Char1=0 : Char2=0 : Char3=0
Byte1=asc(left(tmpEDIDMfg,1)) 'get the first half of the string
Byte2=asc(right(tmpEDIDMfg,1)) 'get the first half of the string
'now shift the bits
'shift the 64 bit to the 16 bit
If (Byte1 and 64) > 0 then Char1=Char1+16
'shift the 32 bit to the 8 bit
If (Byte1 and 32) > 0 then Char1=Char1+8
'etc....
If (Byte1 and 16) > 0 then Char1=Char1+4
If (Byte1 and 8) > 0 then Char1=Char1+2
If (Byte1 and 4) > 0 then Char1=Char1+1

'the 2nd character uses the 2 bit and the 1 bit of the 1st byte
If (Byte1 and 2) > 0 then Char2=Char2+16
If (Byte1 and 1) > 0 then Char2=Char2+8
'and the 128,64 and 32 bits of the 2nd byte
If (Byte2 and 128) > 0 then Char2=Char2+4
If (Byte2 and 64) > 0 then Char2=Char2+2
If (Byte2 and 32) > 0 then Char2=Char2+1

'the bits for the 3rd character don't need shifting
'we can use them as they are
Char3=Char3+(Byte2 and 16)
Char3=Char3+(Byte2 and 8)
Char3=Char3+(Byte2 and 4)
Char3=Char3+(Byte2 and 2)
Char3=Char3+(Byte2 and 1)
tmpmfg=chr(Char1+64) & chr(Char2+64) & chr(Char3+64)

'**************************************************************
'Next get the device id
'**************************************************************
'the device id is 2bytes starting at EDID offset &H0a
'the bytes are in reverse order.
'this code is not text. it is just a 2 byte code assigned
'by the manufacturer. they should be unique to a model
Dim tmpEDIDDev1, tmpEDIDDev2, tmpDev

tmpEDIDDev1=hex(asc(mid(strarrRawEDID(tmpctr),&H0a+1,1)))
tmpEDIDDev2=hex(asc(mid(strarrRawEDID(tmpctr),&H0b+1,1)))
If len(tmpEDIDDev1)=1 then tmpEDIDDev1="0" & tmpEDIDDev1
If len(tmpEDIDDev2)=1 then tmpEDIDDev2="0" & tmpEDIDDev2
tmpdev=tmpEDIDDev2 & tmpEDIDDev1

'**************************************************************
'finally store all the values into the array
'**************************************************************
'Kaplan adds code to avoid duplication...

If Not InArray(tmpser,arrMonitorInfo,3) Then
arrMonitorInfo(tmpctr,0)=tmpmfg
arrMonitorInfo(tmpctr,1)=tmpdev
arrMonitorInfo(tmpctr,2)=tmpmdt
arrMonitorInfo(tmpctr,3)=tmpser
arrMonitorInfo(tmpctr,4)=tmpmdl
arrMonitorInfo(tmpctr,5)=tmpVer
End If
End If
Next

'For now just a simple screen print will suffice for output.
'But you could take this output and write it to a database or a file
'and in that way use it for asset management.
i = 0
for tmpctr = 0 to intMonitorCount-1
If arrMonitorInfo(tmpctr,1) <> "" And arrMonitorInfo(tmpctr,0) <> "PNP" Then
ts.write message & "Monitor " & chr(i+65) & ")" & VbCrLf & _
"Model Name: " & arrMonitorInfo(tmpctr,4) & VbCrLf & _
"Serial Number: " & arrMonitorInfo(tmpctr,3)& VbCrLf & _
"VESA Manufacturer ID: " & arrMonitorInfo(tmpctr,0) & VbCrLf & _
"Manufacture Date: " & arrMonitorInfo(tmpctr,2) & VbCrLf & VbCrLf
'ts.write ".........." & "Device ID: " & arrMonitorInfo(tmpctr,1)
'ts.write ".........." & "EDID Version: " & arrMonitorInfo(tmpctr,5)
i = i + 1
End If
Next

strComputer = "."
Set objWMIService = GetObject("winmgmts:" _
& "{impersonationLevel=impersonate}!\\" & strComputer & "\root\cimv2")
Set colBIOS = objWMIService.ExecQuery _
("Select * from Win32_BIOS")
For each objBIOS in colBIOS
ts.writeline "Manufacturer: " & objBIOS.Manufacturer
ts.writeline "Serial Number: " & objBIOS.SerialNumber
ts.writeline "Name: " & objBIOS.Name
Next


Function InArray(strValue,List,Col)
Dim i
For i = 0 to UBound(List)
If List(i,col) = cstr(strValue) Then
InArray = True
Exit Function
End If
Next
InArray = False
End Function
Автор: Mark_Titov
Дата сообщения: 14.05.2010 17:19
Black_Lung - Спасибо тебе большое, выручил!
Автор: vlth
Дата сообщения: 14.05.2010 18:28
magiogre
похожая задача
Автор: Realgeek
Дата сообщения: 15.05.2010 01:46
Есть скрипт вида
Dim WSHShell, WinDir, Value, wshProcEnv, fso, Spath

Set WSHShell = CreateObject("WScript.Shell")


Dim objFSO, objFileCopy
Dim strFilePath, strDestination

Const OverwriteExisting = True
Set objFSO = CreateObject("Scripting.FileSystemObject")
Set windir = objFSO.getspecialfolder(0)
objFSO.CopyFile "\\dv.rt.ru\SYSVOL\DV.RT.RU\scripts\shutdown.vbs", windir&"\", OverwriteExisting

strComputer = "."
Set objWMIService = GetObject("winmgmts:" _
& "{impersonationLevel=impersonate}!\\" _
& strComputer & "\root\cimv2")
JobID = "1"

Set colScheduledJobs = objWMIService.ExecQuery _
("Select * from Win32_ScheduledJob")
For Each objJob in colScheduledJobs
objJob.Delete
Next

Set objNewJob = objWMIService.Get("Win32_ScheduledJob")
errJobCreate = objNewJob.Create _
(windir & "\shutdown.vbs", "********093000.000000+660", _
True, 1 OR 2 OR 4 OR 8 OR 16 OR 32 OR 64, ,True, JobId)

Как в нем указать чтобы он запускался не единожды в 9:30, А каждый час с 9:30 до 12:00
Заранее спасибо

Добавлено:
Доброго времени суток.
Помогите пожалуйста.
Есть пример скрипта вот здесь
http://www.script-coding.info/WMI_ServMon.html
Мне необходимо его модифицировать таким образом, чтобы если службы на компьютере нет вообще он выводил, что на данном компьютере данная служба не установлена.
Автор: Mark_Titov
Дата сообщения: 16.05.2010 08:03
...Подскажите пож-ста -
Есть скрипт (Водшебник Мерлин из MS Office)-


Код: strCharacter = "merlin"

Set objMicrosoftAgent = CreateObject("Agent.Control.1")
objMicrosoftAgent.Connected = True
objMicrosoftAgent.Characters.Load strCharacter, strCharacter & ".acs"
Set objCharacter = objMicrosoftAgent.Characters(strCharacter)
With objCharacter
.Top = 200
.Left = 600
.LanguageID = &h409
.Show
'Здороваемся с пользователем.
.Play "Greet"
.Play "RestPose"
.Think "Привет!"
'Завершаем чтение информации
.Play "ReadReturn"
'Прощаемся с пользователем.
.Play "Wave"
End With

' Синхронизируем анимацию со скриптом и завершаемся.
Set objCharacterRequest = objCharacter.Hide

Do Until objCharacterRequest.Status = 0 ' Complete = 0
Wscript.Sleep 100
Loop
Set objCharacter = Nothing

objMicrosoftAgent.Characters.Unload strCharacter
Автор: magiogre
Дата сообщения: 16.05.2010 19:14
vlth

Цитата:
magiogre
похожая задача


Black_Lung

Цитата:
magiogre
Попробуй из этого собрать:
Подробнее...



Спасибо, но я в vbs не шарю.

Еще раз прошу, помогите, плиз.

Задача следующая:

В сети на сервере имеется папка для публичного файлообмена //Serv01/Pub/
Пользователи постоянно копируют сюда свои папки и указывают в названии дату, до которой папка должна существовать на сервере. Руками чистить очень муторно, т.к. пользователей данным ресурсом в сети море.

Нужен скрипт, который будет:
-запускаться на Serv01 1 раз в сутки (средствами windows), работать в теневом режиме, т.е. без вопросов;
-проверять папку /Pub/ на наличие папок с датой в названии (например: Папка_Иванова[до16.05.2010], Папка_Петрова[до17.06.2011] и т.д.);
-если срок пришел, т.е. текущая дата больше или равна дате, указанная в названии, то эту папку скрипт должен без вопросов удалить;
-все остальные папки скрипт не трогает.

Прошу помощи у знающих людей. Буду очень благодарен.
Автор: Hugo121
Дата сообщения: 16.05.2010 23:30
magiogre, вот скрипт, который проверяет все подпапки в папке скрипта (т.е. его надо запускать из //Serv01/Pub/, из папки, в которой надо удалять папки) на наличие в названии в любом месте текущей даты именно в виде 16.06.2010:

Код: Option Explicit

Dim fso, oFolder, oSubFolder
Dim MyPath, MyPathShort, vremja, prefix

vremja = Split((Replace((Date() & "." & Time()), ":", ".")), ".")
'msgbox vremja(0) 'date
'msgbox vremja(1) 'month
'msgbox vremja(2) 'year
'msgbox vremja(3) 'hour
'msgbox vremja(4) 'min
'msgbox vremja(5) 'sec

prefix = vremja(0) & "." & vremja(1) & "." & vremja(2)

MyPath = left (WScript.ScriptFullName, (Len(WScript.ScriptFullName))-(Len(WScript.ScriptName)))
MyPathShort = Left(MyPath, Len(MyPath)-1)

Set fso = wsh.CreateObject("Scripting.FileSystemObject")
Set oFolder = fso.GetFolder(MyPathShort)

For Each oSubFolder in oFolder.SubFolders
if instr(1,oSubFolder.name, prefix) then fso.DeleteFolder oSubFolder, true
Next
Автор: magiogre
Дата сообщения: 17.05.2010 06:50
Hugo121
Такие папки будут, т.к. присутствует человеческий фактор. Пользователи сами ставят дату в названии, могут переименовывать, ошибаться и т.д. и т.п.
И еще момент. Хотелось бы чтобы пользователи не видели сам скрипт, чтобы он не находился в /Pub/ , а запускался, скажем, из D:\Scripts\ вместе со всеми другими скриптами на сервере. Было бы очень удобно.
Автор: Hugo121
Дата сообщения: 17.05.2010 08:11
Но дата в названии формируется програмно, или её вводят пользователи - т.е. дата вида 2010,06,16 вдруг не может появится?
И вот это: "[до14" - можно искать по символам "[до" и брать следующий символ как начало даты или это тоже вводит именно пользователь?
Автор: magiogre
Дата сообщения: 17.05.2010 09:20
Название обговорю с пользователями. Ошибаться не будут. Можно смело работать с синтаксисом из названия.

До и после "[до" еще пробелы сказали сделать. Вот так должно быть:
Название папки [до DD.MM.YYYY]
Автор: Hugo121
Дата сообщения: 17.05.2010 09:40
Я предполагал, что например название вводится через форму, и тогда далее текст формируется програмно - т.е. гарантированно синтаксис такой. Если это только устная договорённость - имхо всё равно возможны ошибки ввода.
Позже попробую накодить "и меньше", если vlth не опередит
Автор: magiogre
Дата сообщения: 17.05.2010 10:06
Спасибо!
Если будут ошибаться - приму санкции
Автор: Hugo121
Дата сообщения: 17.05.2010 14:02
Ну вот так например, потестите в сети - поменяйте путь в MyPath на сетевой (в конце нет слэша!):

Код: Option Explicit

Dim fso, oFolder, oSubFolder
Dim MyPath, vremja, prefix

vremja = Split((Replace((Date() & "." & Time()), ":", ".")), ".")
'msgbox vremja(0) 'date
'msgbox vremja(1) 'month
'msgbox vremja(2) 'year
'msgbox vremja(3) 'hour
'msgbox vremja(4) 'min
'msgbox vremja(5) 'sec

prefix = vremja(0) & "." & vremja(1) & "." & vremja(2)

MyPath = "C:\temp\Magiogre"
Set fso = wsh.CreateObject("Scripting.FileSystemObject")
Set oFolder = fso.GetFolder(MyPath)

For Each oSubFolder in oFolder.SubFolders
if cdate(mid(oSubFolder.name, instr(1,oSubFolder.name, "[до")+4, 10)) <= cdate(prefix) then fso.DeleteFolder oSubFolder, true
Next
Автор: magiogre
Дата сообщения: 17.05.2010 14:43
Работает! Спасибо!
Автор: Hugo121
Дата сообщения: 17.05.2010 14:49
Ну а пробел добавили после "[до"?
Эта ошибка означает, что выделенные 10 символов не дата.
Принимайте санкции
А вообще-то надо в код добавить "On Error resume next", а то будет ругаться на каждую такую ошибку.
Блин, не добавляйте!!! Удалит всё неспросясь... Счас...

Вот, вроде так - внизу замените блок именно удаления:

Код:
On Error Resume Next
For Each oSubFolder in oFolder.SubFolders
if cdate(mid(oSubFolder.name, instr(1,oSubFolder.name, "[до")+4, 10)) <= cdate(prefix) then
    If err.number = 0 then fso.DeleteFolder oSubFolder, true
    err.clear
End If
Next

Страницы: 123456789101112131415161718192021222324252627282930313233343536373839404142434445464748495051525354555657585960616263646566676869707172737475

Предыдущая тема: Работа в Delphi c CryptoApi


Форум Ru-Board.club — поднят 15-09-2016 числа. Цель - сохранить наследие старого Ru-Board, истории становления российского интернета. Сделано для людей.