Простые примеры работы со скриптами

'Проверка доступности сетевой станции путём "пингования".
'Функция пригодна для использования и в консольном, и в графическом режимах
'(режимом по умолчанию является графический).
 
Function Available(strName, blnIsCon)
If blnIsCon Then
    Dim objExec, objOutStream, strTemp
    Set objExec = CreateObject("WScript.Shell").Exec("ping -n 1 -w 130 " & strName)
    Set objOutStream = objExec.StdOut
    While Not objOutStream.AtEndOfStream
        strTemp = strTemp & Trim(objOutStream.ReadLine())
    Wend
    Set objOutStream = Nothing
    Set objExec = Nothing
    If InStr(1, strTemp, "TTL", vbTextCompare) > 0 Then
        Available = True
    Else
        Available = False
    End If
Else
    Dim objWMI, objItem
    Set objWMI = GetObject("winmgmts:{impersonationLevel=impersonate}").ExecQuery("SELECT StatusCode FROM Win32_PingStatus WHERE Address='" & strName & "'")
    For Each objItem In objWMI
        If IsNull(objItem.StatusCode) Then
            Available = False
        Else
            Available = (objItem.StatusCode = 0)
        End If
    Next
    Set objItem = Nothing
    Set objWMI = Nothing
End If
End Function

'Определение того, подключен ли в качестве сетевого тома заданный UNC-путь.
 
Function Find_NetworkDrive(ByVal strPath)
'strPath - искомый UNC-путь, например "\\Server\MyFolder"
Dim strNames
 
strPath = Replace(strPath, "\", "\\")
On Error Resume Next
Set objWMI = GetObject("winmgmts:\\.\root\cimv2")
Set objCollection = objWMI.ExecQuery("SELECT DeviceID FROM Win32_LogicalDisk WHERE DriveType=4 AND ProviderName='" & strPath & "'")
If Err.Number = 0 Then
    If objCollection.Count > 0 Then
        For Each objItem In objCollection
            If Len(objItem.DeviceID) > 0 Then
                strNames = strNames & objItem.DeviceID
                Exit For
            End If
        Next
        Set objItem = Nothing
        Find_NetworkDrive = strNames
    End If
Else
    Err.Clear
End If
Set objCollection = Nothing
Set objWMI = Nothing
On Error GoTo 0
End Function

'Поиск свободной литеры для назначения подключаемому сетевому тому.
 
Function Free_Letter()
Dim objWMI, objCollection, objItem
Dim arrTemp(22), intShift, intTemp, i, blnHasLetter
 
intShift = Asc("D")
Set objWMI = GetObject("winmgmts:\\.\root\cimv2")
Set objCollection = objWMI.ExecQuery("SELECT DeviceID FROM Win32_LogicalDisk")
For Each objItem In objCollection
    intTemp = Asc(UCase(objItem.DeviceID)) - intShift
    If intTemp >= 0 And intTemp <= UBound(arrTemp) Then arrTemp(intTemp) = True
Next
Set objItem = Nothing
Set objCollection = Nothing
Set objWMI = Nothing
For i = 0 To UBound(arrTemp)
    If Not arrTemp(i) Then
        blnHasLetter = True
        Exit For
    End If
Next
If blnHasLetter Then
    Free_Letter = Chr(i + intShift)
Else
    Free_Letter = vbNullString
End If
Erase arrTemp
End Function

'Определение владельца заданного объекта файловой системы.
 
Function Get_Owner_FSO(strPath, strWS)
Dim objWMI, objSecSettings, objSD, objFS
Dim strPathWMI, strResult, strTemp
strPathWMI = Replace(strPath, "\", "\\", 1, -1, vbTextCompare)
On Error Resume Next
Set objFS = CreateObject("Scripting.FileSystemObject")
Set objWMI = GetObject("winmgmts:{impersonationLevel=impersonate}!\\" & strWS & "\root\CIMV2")
If Err.Number = 0 Then
    Set objFS = CreateObject("Scripting.FileSystemObject")
    strTemp = objFS.GetDrive(Left(strPath, 2)).FileSystem
    Set objFS = Nothing
    If Err.Number = 0 Then
        If StrComp(strTemp, "NTFS", vbTextCompare) = 0 Then
            Set objSecSettings = objWMI.Get("Win32_LogicalFileSecuritySetting.Path='" & strPathWMI & "'")
            If Err.Number = 0 Then
                If objSecSettings.GetSecurityDescriptor(objSD) = 0 Then
                    strResult = objSD.Owner.Domain & "\" & objSD.Owner.Name
                Else
                    strResult = "Не удалось прочитать дескриптор безопасности объекта."
                End If
                Set objSD = Nothing
            Else
                strResult = "Ошибка " & Err.Number & " при обращении к объекту." & vbNewLine & Err.Description
                Err.Clear
            End If
            Set objSecSettings = Nothing
        Else
            strResult = "Файловая система " & UCase(strTemp) & " не поддерживается."
        End If
    Else
        strResult = "Ошибка " & Err.Number & " при определении типа файловой системы." & vbNewLine & Err.Description
        Err.Clear
    End If
Else
    strResult = "Ошибка " & Err.Number & " при подключении к WMI-пространству." & vbNewLine & Err.Description
    Err.Clear
End If
Set objWMI = Nothing
On Error GoTo 0
Get_Owner_FSO = strResult
End Function

'Сортировка одномерного массива методом "пузырька" (оптимизированная).
 
Function Sorting_Array_Buble(arrData)
Dim xItem, i, j, blnFlag
 
For i = 0 To UBound(arrData) - 1
    blnFlag = False
    For j = 0 To UBound(arrData) - 1
        If arrData(j) > arrData(j + 1) Then
            xItem = arrData(j)
            arrData(j) = arrData(j + 1)
            arrData(j + 1) = xItem
            blnFlag = True
        End If
        intCounter2 = intCounter2 + 1
    Next
    If Not blnFlag Then Exit For
Next
End Function

'Сортировка одномерного массива методом вставок.
 
Function Sorting_ByInserts(arrTemp)
Dim i, j, xItem
For i = 1 To UBound(arrTemp)
    For j = i To 1 Step -1
        If arrTemp(j) < arrTemp(j - 1) Then
            xItem = arrTemp(j)
            arrTemp(j) = arrTemp(j - 1)
            arrTemp(j - 1) = xItem
        Else
            Exit For
        End If
    Next
Next
End Function

'Определение хозяина FSMO-роли "Эмулятор PDC".
 
Function Get_PDC()
Dim objRoot, objNtds, strPDC
On Error Resume Next
Set objRoot = GetObject("LDAP://rootDSE")
Set objNtds = GetObject("LDAP://" & GetObject("LDAP://" & objRoot.Get("defaultNamingContext")).Get("fSMORoleOwner"))
strPDC = Mid(GetObject(objNtds.Parent).Name, 4)
Set objNtds = Nothing: Set objRoot = Nothing
If Err.Number <> 0 Then Err.Clear
On Error GoTo 0
Get_PDC = strPDC
End Function

'Определение того, является ли текущий компьютер контроллером домена
 
Function IsDC()
Dim objWMI, objCollection, objItem
Set objWMI = GetObject("winmgmts:{impersonationLevel=impersonate}!\\.\root\cimv2")
Set objCollection = objWMI.ExecQuery("SELECT DomainRole FROM Win32_ComputerSystem")
For Each objItem In objCollection
    IsDC = (objItem.DomainRole > 3)
Next
Set objItem = Nothing: Set objCollection = Nothing: Set objWMI = Nothing
End Function

Set objHTML = CreateObject("htmlfile")
ClipboardText = objHTML.ParentWindow.ClipboardData.GetData("text")

Function AddSlash(fString)
  AddSlash = fString
  If Len(fString) <> InStrRev(fString, "\") Then
    AddSlash = fString & "\"
  End If
End Function

Function AddChr34(fString)
  AddChr34 = fString
  If InStr(fString, Chr(34)) <> 1 and _
     InStrRev(fString, Chr(34)) <> Len(fString) Then
    AddChr34 = Chr(34) & fString & Chr(34)
  End If
End Function

Function GetScriptBaseName()
  Dim posStr
  Dim tmpStr
  tmpStr = WScript.ScriptFullName
  posStr = InStrRev(tmpStr, "\")
  tmpStr = Mid(tmpStr, posStr + 1)
  posStr = InStrRev(tmpStr, ".")
  If posStr > 0 Then
    GetScriptBaseName = Left(tmpStr, posStr - 1)
  Else 
    GetScriptBaseName = posStr
  End If
  posStr = Empty
  tmpStr = Empty
End Function

Function GetScriptBaseExt()
  Dim posStr
  Dim tmpStr
  tmpStr = WScript.ScriptFullName
  posStr = InStrRev(tmpStr, "\")
  tmpStr = Mid(tmpStr, posStr + 1)
  posStr = InStrRev(tmpStr, ".")
  If posStr > 0 Then
    GetScriptBaseExt = Right(tmpStr, Len(tmpStr) - posStr)
  Else
    GetScriptBaseExt = ""
  End If
  posStr = Empty
  tmpStr = Empty
End Function

Function GetScriptBaseDir()
  Dim tmpStr
  tmpStr = WScript.ScriptFullName
  GetScriptBaseDir = Left(tmpStr, InStrRev(tmpStr, "\") - 1)
  tmpStr = Empty
End Function

Function GetScriptHostName()
  Dim tmpStr
  tmpStr = WScript.FullName
  GetScriptHostName = Mid(tmpStr, InStrRev(tmpStr, "\") + 1)
  tmpStr = Empty
End Function

Function DeleteSlash(fString)
  DeleteSlash = fString
  If Len(fString) = InStrRev(fString, "\") Then
    DeleteSlash = Mid(fString, 1, Len(fString) - 1)
  End If
End Function

Function DeleteChr34(fString)
  DeleteChr34 = fString
  If InStr(fString, Chr(34)) = 1 and _
     InStrRev(fString, Chr(34)) = Len(fString) Then
    DeleteChr34 = Mid(fString, 1 + 1, Len(fString) - 1)
  End If
End Function