VBSCRIPT: Add New Domain's Admins to Local Administrators Programmatically
In order for Active Directory Migration Tool (ADMT) to install its Agent on a newly migrated computer, the user running the ADMT tool must have local Administrator access. Otherwise, the error log shows something similar to the following:
WRN1:7290 Processor architecture for machine \NT4MACHINE is unknown, Error accessing registry key SYSTEM\CurrentControlSet\Control\Session Manager\Environment rc=5 Access is denied.
Failed to install agent on \NT4MACHINE, rc=5 Access is denied. Unable to access ADMIN$ share on the machine 'NT4MACHINE'. Make sure the share exists and the account running ADMT is a member of local administrators group on the machine 'NT4MACHINE'. hr=0x80070005. Access is denied.
Here is a basic script that will go through each of the Windows workstations on the old domain and add the new domain's "Domain Admins" group to the workstation's local Administrators group. If the machine is a Windows Server OS, it will be ignored. Change the newDomain and oldDomain variables to match your network.
newDomain = "NEW2K3"
oldDomain = "OLDNT4"
Set objADGroup = GetObject("WinNT://" & newDomain & "/Domain Admins,group")
Set objOldDomain = GetObject("WinNT://" & oldDomain)
objOldDomain.Filter = Array("Computer")
For Each Computer In objOldDomain
strComputer = Computer.Name
Set objWMIService = GetObject("winmgmts:" & strComputer & "\root\cimv2")
Set colSettings = objWMIService.ExecQuery ("SELECT * FROM Win32_OperatingSystem")
For Each objOperatingSystem in colSettings
If InStr(UCase(objOperatingSystem.Name),"SERVER") = 0 Then
Set objLocalGroup = GetObject("WinNT://" & strComputer & "/Administrators,group")
objLocalGroup.Add(objADGroup.AdsPath)
Set objLocalGroup = Nothing
End If
Next
Set colSettings = Nothing
Set objWMIService = Nothing
Next
Set objADGroup = NothingAlso, if you do not have the workstation's primary DNS server set to the new domain's DNS servers, ADMT will quit with the following error: ERR3:7075 Failed to change domain affilation, hr=8007054b The specified domain either does not exist or could not be contacted.
Use this code to change DNS servers domain-wide
oldDomain = "OLDNT4"
DNSServerArray = "192.168.1.1,192.168.1.2"
Set objOldDomain = GetObject("WinNT://" & oldDomain)
objOldDomain.Filter = Array("Computer")
For Each Computer In objOldDomain
strComputer = Computer.Name
Set objWMIService = GetObject("winmgmts:" & strComputer & "\root\cimv2")
Set colSettings = objWMIService.ExecQuery ("SELECT * FROM Win32_OperatingSystem")
For Each objOperatingSystem in colSettings
If InStr(UCase(objOperatingSystem.Name),"SERVER") = 0 Then
arrNewDNSServerSearchOrder = Array(DNSServerArray)
Set colNicConfigs = objWMIService.ExecQuery("SELECT * FROM Win32_NetworkAdapterConfiguration WHERE IPEnabled = True")
For Each objNicConfig In colNicConfigs
intSetDNSServers = objNicConfig.SetDNSServerSearchOrder(arrNewDNSServerSearchOrder)
If intSetDNSServers = 0 Then Wscript.Echo "Oops, problem on " & strComputer
Next
End If
Next
Set colSettings = Nothing
Set objWMIService = Nothing
NextAlso, that probably won't be effective on machines set to accept DNS servers via DHCP, though I haven't tested. Be sure you reboot after resetting the DNS, otherwise, you'll run into the following error: The ADSI property cannot be found in the property cache ErrCode=8000500d Go ahead and reboot the workstation, it should solve the problem.
VBScript: Sort Array
Found this code and wanted to bookmark it... from VisualBasicScript.com's Forums
Function fSortArray(aSortThisArray)
Set oArrayList = CreateObject("System.Collections.ArrayList" )
For iElement = 0 To UBound(aSortThisArray)
oArrayList.Add aSortThisArray(iElement)
Next
oArrayList.Sort
set fSortArray = oArrayList
Set oArrayList = Nothing
End FunctionVBScript: Traverse Directories & Subdirectories Snippet
This snippet has come in handy quite a few times for me...
Call ListFolderContents("C:\Windows\System32\Drivers")
Sub ListFolderContents(path)
set fs = CreateObject("Scripting.FileSystemObject")
set folder = fs.GetFolder(path)
Msgbox folder.path
For each item in folder.SubFolders
ListFolderContents(item.Path)
Next
set folder = Nothing
set fs = Nothing
End SubIIS: Instantly Ban IPs Attempting to Login to MS-FTP as Administrator
UPDATE 12/18/06: The startup script has been modified slightly (cscript.exe was changed to wscript.exe). Now, console users will no longer encounter a blank black box upon login.
UPDATE 11/21/06: Now that banning at the IP level has been added to the script, offending users are completely banned before they can even attempt a second login on Windows 2003 machines. Windows 2000 machines still have a slight delay.
UPDATE 1/18/07: I updated the code so that it does not throw out an "unknown" error on line 48 for Win2k users. Thanks to the commenters for figuring that out. Also, check the comments for some really great script modification and ideas posted by blog visitors. Thanks to everyone who has posted!
Recently while reviewing my Windows Events, I noticed over 2800 failed login attempts to my Microsoft FTP server. Apparently, a bot was trying to brute force the Administrator password. Thankfully, I soon determined that there were only two IPs I needed to ban. The FTP server needs to be accessed by my employer's clients so I couldn't just change the port (as I did when I found 30,000+ SSH login attempts to my Linux box). Thus, I decided to instantly ban any IPs attempting to login as Administrator. I did this using a VBScript file (saved as: C:\Scripts\Startup\banftpips.vbs) that is set to execute upon boot-up. This can be done like so.
'****************************************************************************
' This script created by Chrissy LeMaire (clemaire@gmail.com)
' Website: http://netnerds.net/
'
' NO WARRANTIES, etc.
'
' This script instantly bans IP addresses trying to login to FTP
' using the NT account "Administrator"
'
' Run this script on the FTP server. It sits in the back and waits for an
' event viewer "push" that lets it know someone failed FTP authentication.
'
' This script has only been tested on Windows Server 2003. It assumes, as it
' should, that there are no legitimate Administrator account FTP logins.
'
' "What it does"
' 1. Sets an Async Event Sink to notify the script when someone fails MS-FTP auth
' 2. When alerted, the script parses the last day's FTP logs for all FTP sites (this
' is because the Event Viewer doesn't tell you which FTP site, if you have more than
' one, is the one getting hit)
' 3. Compiles the list of IPs to be banned and then bans them using IIS /and/
' IP level banning (thanks Spencer @ netortech.com for the idea)
'*****************************************************************************
' Push Event Viewer Alert
Set objWMIService = GetObject("winmgmts:{(security)}!root/cimv2")
Set eventSink = wscript.CreateObject("WbemScripting.SWbemSink", "EVSINK_")
strWQL = "Select * from __InstanceCreationEvent where TargetInstance isa 'Win32_NTLogEvent' and TargetInstance.SourceName = 'MSFTPSVC' and TargetInstance.EventCode = 100"
objWMIService.ExecNotificationQueryAsync eventSink,strWQL
' Keep it going forever
While (True)
Wscript.Sleep(1000)
Wend
Sub EVSINK_OnObjectReady(objObject, objAsyncContext)
If InStr(LCase(objObject.TargetInstance.Message),"administrator") > 0 Then
Set objFTPSVC = GetObject("IIS://localhost/MSFTPSVC")
Set WshShell = CreateObject("WScript.Shell")
Set objFSO = CreateObject("Scripting.FileSystemObject")
Set objLog = CreateObject("MSWC.IISLog")
Set objDictionary = CreateObject("Scripting.Dictionary")
Set objFTPIPSec = objFTPSVC.IPSecurity
'Get IP address of server so we can use it later to give the offending IP a bad route
Set IPConfigSet = GetObject("winmgmts:\\.\root\cimv2").ExecQuery("SELECT * FROM Win32_NetworkAdapterConfiguration WHERE IPEnabled=TRUE")
for each IPConfig in IPConfigSet
if Not IsNull(IPConfig.DefaultIPGateway) then serverIP = IPConfig.IPAddress(0)
Next
Set IPConfigSet = Nothing
'Iterate through each FTP site. See #2 up above.
For Each objSITE in objFTPSVC
If lcase(objSITE.class) = "iisftpserver" Then
ftpLogFilePath = WshShell.ExpandEnvironmentStrings(objSITE.LogFileDirectory) & "\msftpsvc" & objSITE.Name
Set objFolder = objFSO.GetFolder(ftpLogFilePath)
Set objFiles = objFolder.Files
For Each fileName In objFiles
lastFile = fileName
Next
strLogFile = lastFile
Set file = Nothing
Set objFolder = Nothing
'Use the IIS log file parser provided by MSFT
objLog.OpenLogFile strLogFile, 1, "MSFTPSVC", 1, 0
'(FileName,IOMode,ServiceName,ServiceInstance,OutputLogFileFormat)
' 0 = NotApplicable, 1 = ForReading
While NOT objLog.AtEndOfLog
objLog.ReadLogRecord
If LCase(objLog.URIStem) = "administrator" Then
ClientIP = objLog.ClientIP
If objDictionary.Exists(ClientIP) = False Then
'Kill the route to the machine then add it to the array of banned IPs.
Set WshShell = WScript.CreateObject("WScript.Shell")
WshShell.Run "ROUTE ADD " & clientIP & " MASK 255.255.255.255 " & serverIP, 1, True
Set WshShell = Nothing
objDictionary.Add ClientIP, "255.255.255.255" '255 is just there for padding.
End If
End If
Wend
objLog.CloseLogFiles 1
End If
Next
'Append the newly banned IPs to the currently banned IPs
If objDictionary.Count > 0 And objFTPIPSec.GrantByDefault = True Then
bannedIPArray = objFTPIPSec.IPDeny
For i = 0 to ubound(bannedIPArray)
clientIP = Left(bannedIPArray(i),InStr(bannedIPArray(i),",")-1)
If objDictionary.Exists(ClientIP) = False Then
objDictionary.Add bannedIPArray(i), "255.255.255.255"
End If
Next
objFTPIPSec.IPDeny = objDictionary.Keys
objFTPSVC.IPSecurity = objFTPIPSec
objFTPSVC.SetInfo
End If
Set objFTPIPSec = Nothing
Set objDictionary = Nothing
Set objLog = Nothing
Set objFSO = Nothing
Set objFTPSVC = Nothing
End If
End SubOnce the IP has been added to the ban list, the user will no longer be able to connect to the machine via TCP/IP as it has been given a bad route. If the server reboots, it will lose the route but the IP will still be banned in IIS. The offending user will then see the following message:
Connected to ftpserver
530 Connection refused, unknown IP address.
421 Service not available, closing control connection.
Connection closed by remote host.
Note that this bans the IPs on a global FTP level. You will find the banned IPs listed under Windows 2003 @ IIS -> FTP -> Properties and under Windows 2000 @ IIS -> Hostname -> Properties -> FTP Service -> Edit -> Directory Security. This means you will not find it on the properties of the Default FTP Site. This pro-actively bans the IPs from hitting other FTP sites in an IIS setup with multiple FTP sites. In addition, with the new ban at the IP level, the machine can't even contact your server until your Windows server has been rebooted and the manual routes have thus been reset.
VBScript: Track Outbound E-mail Addresses in Exchange
I use the code below to extract e-mail addresses from outbound e-mails and insert them into a SQL table. This is useful when using custom Exchange/SQL Server solutions to put a lid on spam ;D
<script LANGUAGE="VBScript">
Sub ISMTPOnArrival_OnArrival(ByVal Msg, EventStatus )
On Error Resume Next
EventStatus = 0 'Run the next sink by default.
Connstring = "Driver={SQL Server}; Server=servername; Database=dbname; UID=username; PWD=mypass"
Set envfields = Msg.EnvelopeFields
Set fields = Msg.Fields
RecipList = LCase(envfields("http://schemas.microsoft.com/cdo/smtpenvelope/recipientlist"))
IpAddr = LCase(envfields("http://schemas.microsoft.com/cdo/smtpenvelope/clientipaddress"))
Sender = LCase(fields.Item("urn:schemas:mailheader:from"))
recipList = replace(LCase(RecipList),"smtp:","")
recipArray = split(RecipList,";")
For aa = LBound(recipArray) To UBound(recipArray)
If Len(recipArray(aa)) > 0 and Len(ipaddr) = 0 and Sender = """chrissy lemaire"" <chrissy@netnerds.net>" Then
Set rs = CreateObject("adodb.recordset")
strSQL = "select whiteline from whitelist where whiteline = '" & recipArray(aa) & "'"
rs.Open strSQL,Connstring,1,2
If rs.eof and rs.bof Then
rs.Addnew
rs("whiteline") = recipArray(aa)
rs.Update
End If
rs.close
Set rs = nothing
End If
Next
Msg.DataSource.Save
EventStatus = 0 'cdoRunNextSink
End Sub
</script>ASP: Sustain Remote Cookie Sessions in an ASP/VBScript
I dug up this cold from my old netnerds blog. For Googlers wondering if sustaining a remote session is possible, the answer is yes; I've sustained remote cookie sessions using both ASP & VBScript. I've provided simplified code below. It should be self explanatory. If not, drop me a comment and I'll explain it.
<%
url1 = "http://www.netnerds.net/session/login.asp"
url2 = "http://www.netnerds.net/session/controlPanel.asp"
data1 = "username=bobby&pass=thepass&submit=Login"
theCookie = httpSessionRequest(1, "POST", url1, data1, noCookie, noViewState)
finalHTML = httpSessionRequest(2, "GET", url2, nodata, theCookie, noViewState)
response.write finalHTML
'---------------------------------------------------------
'THE FUNCTION
'---------------------------------------------------------
Function httpSessionRequest(theStep, method, url, data, cookie, viewState)
'FYI, viewstate code has been ripped out.
'Previously, I screenscraped to get the viewstate hidden field for aspx pages.
baseURL = "http://www.netnerds.net/" 'This is to fix any broken images in the output.
if len(cookie) = 0 then cookie = "dummy=dummy;"
HTTPReferrer = Trim(url)
postVars = Trim(data)
Set XMLHTTP = server.CreateObject("MSXML2.serverXMLHttp")
XMLHTTP.open method, Trim(url), false
if UCASE(method) = "POST" Then
XMLHTTP.SetRequestHeader "Content-Type", "application/x-www-form-urlencoded"
End If
XMLHTTP.SetRequestHeader "Referer", HTTPReferrer 'just in case the server cares
XMLHTTP.setRequestHeader "Cookie", "excuse the Microsoft bug"
XMLHTTP.setRequestHeader "Cookie", cookie
XMLHTTP.send postVars
'wait for response
While XMLHTTP.readyState <> 4
XMLHTTP.waitForResponse 1000
Wend
strHeaders = XMLHTTP.getAllResponseHeaders()
hArr = split(strHeaders,"Set-Cookie: ")
for kk = 1 to ubound(hArr)
theCookie = left(hArr(kk),instr(hArr(kk),"path=/")-2)
myCookie = myCookie & " " & theCookie
next
if len(myCookie) = 0 then mycookie = cookie
sReturn = replace(XMLHTTP.responsetext,"../",baseURL)
if cint(theStep) = 1 then
httpSessionRequest = mycookie
elseif cint(theStep) = 2 then
httpSessionRequest = sReturn
elseif cint(theStep) = 3 then
'You can add stuff here to debug
httpSessionRequest = mycookie
response.write theCookie & "<p>" & mycookie & "<p>" & sReturn & "<hr /><p>"
end if
set XMLHTTP = nothing
END FUNCTION
%>VBScript: Ban IPs in IIS Programatically
I used the following code a while back as part of a solution to automate the banning of spammers via their IP address.
'Here, we will pretend this is an imported list
Dim XMLarr(1)
XMLarr(0) = "65.19.238.21"
XMLarr(1) = "198.31.175.100"
Set objIIS = GetObject("IIS://localhost/w3svc") 'careful, this sets IPDENY on every child web
Set IISipsec = objIIS.IPSecurity
If (IISipsec.GrantByDefault = True) Then
arrIP = IISipsec.IPDeny
arrIPSize = ubound(arrIP)
For i = 0 to arrIPSize
arrIPstring = arrIPstring & "," & arrIP(i) 'going to use for dupes later.
Next
ReDim preserve arrIP(arrIPSize + UBound(XMLarr)+1)
for i = 0 to UBound(XMLarr)
myNum = arrIPSize + i+1
If InStr(arrIPstring,XMLarr(i)) = 0 Then
arrIP(myNum) = XMLarr(i)
End If
Next
IISipsec.IPDeny = arrIP
objIIS.IPSecurity = IISipsec
objIIS.SetInfo
End If
Set IISipsec = nothing
Set objIIS = nothingVBScript: Delete ALL E-mails from the Exchange 2003 Queue
Recently my Exchange server got pounded by spammers that were attacking my NDR (non delivery report) capabilities. Turning off NDRs helped 75% and I explored Exchange quite a bit along the way to figure out that last 25%.
It seems that I had 180 emails stuck in my queue. I was looking at my logs and ethereal and it seemed that my mail server would go to several other servers, say "Hello" and then "Goodbye". No message in the middle. It didn't even ask if a recipient was valid. Twenty-four hours later, my queue was still churning at 180 emails constant and Exchange was still being silly.
I took a closer look at the queue. Why was it 180 constant? Then I noticed the date they started their retry -- December 5th 2005. That was the day that installed Exchange (and presumably SP1) on my new server. I restored some PSTs and that's about it. Those emails had been stuck in the queue for well over 2 months! Why didn't they expire? I have no idea.
So I began to try to empty my queue. It was such a manual process. Click on the envelope, click "Find Messages", Delete with No NDR, confirm Yes. I'd have to do this 180 times? No way. So I wrote a script to do it for me: (NOTE! This script empties your ENTIRE queue! There are very few circumstances that you will need to use this script.)
Edit: As noted in the comments below, please close Exchange System Manager before running this script.
' Author: Chrissy LeMaire
' Copyright 2003 NetNerds Consulting Group
' Script is provided AS IS with no warranties or guarantees and assumes no liabilities.
' Website: http://www.netnerds.net
' Description: This scripts empties out the entire Exchange queue. USE WITH CAUTION.
Set objWMIExch = GetObject("winmgmts://./root/MicrosoftExchangeV2")
Set objLinksList = objWMIExch.ExecQuery ("Select * from Exchange_SMTPLink")
For each objLinkInst in objLinksList
strSQL = "Select * from Exchange_SMTPQueue where "
strSQL = strSQL & "LinkID='" & objLinkInst.LinkID
strSQL = strSQL & "' and LinkName='" & objLinkInst.LinkName
strSQL = strSQL & "' and ProtocolName='" & objLinkInst.ProtocolName
strSQL = strSQL & "' and VirtualMachine='" & objLinkInst.VirtualMachine
strSQL = strSQL & "' and VirtualServerName='" & objLinkInst.VirtualServerName & "'"
Set objQueuesList = objWMIExch.ExecQuery (strsql)
For each objQueueInst in objQueuesList
i = i +1
If i > 7 And InStr(objQueueInst.QueueName,".") > 0 Then 'make sure its not the built in stuff
strSQL = "Select * from Exchange_QueuedSMTPMessage where " '<-- This class requires that you pass ALL the variables below in the where clause
strSQL = strSQL & "LinkID='" & objLinkInst.LinkID
strSQL = strSQL & "' and LinkName='" & objLinkInst.LinkName
strSQL = strSQL & "' and ProtocolName='" & objLinkInst.ProtocolName
strSQL = strSQL & "' and QueueID='" & objQueueInst.QueueID
strSQL = strSQL & "' and QueueName='" & objQueueInst.QueueName
strSQL = strSQL & "' and VirtualMachine='" & objLinkInst.VirtualMachine
strSQL = strSQL & "' and VirtualServerName='" & objLinkInst.VirtualServerName & "'"
Set objQueuesList1 = objWMIExch.ExecQuery (strsql)
For each objQueueInst1 in objQueuesList1
If i > 7 And InStr(objQueueInst1.QueueName,".") > 0 Then
objQueueInst1.DeleteNoNDR
End If
Next
End If
Next
Next
MsgBox iThis script emptied my queue in about 25 seconds and Exchange is no longer going out and saying Hello & Goodbye. Traffic is back to normal. I'm assuming that was an Exchange bug.
VBScript: Monitor Processes and Restart if Necessary
This may only be useful for wscript.exe so it may not have universal appeal but I'll list it anyway. The first script is to be inserted at the top of the wscript file you'd like to monitor. The second file is to be run as a scheduled task. SQL Server is used to keep track of the PIDs. SQL Server Express is free so you have no excuses! 
' Author: Chrissy LeMaire
' Copyright 2003 NetNerds Consulting Group
' Script is provided AS IS with no warranties or guarantees and assumes no liabilities.
' Website: http://www.netnerds.net
'create table WscriptPID (PID int,timestamp smalldatetime default getdate())
'''''''''''''''''''''''''''''''''''''''''''''''''''''
' GET PID FOR MONITORING
'''''''''''''''''''''''''''''''''''''''''''''''''''''
Set objWMIService = GetObject("winmgmts:\.\root\cimv2")
strWQL = "Select * from Win32_Process where name = 'wscript.exe'"
Set colProcesses = objWMIService.ExecQuery(strWQL)
For Each objProcess in colProcesses
If objProcess.ProcessID > MaxPID Then MaxPID = objProcess.ProcessID 'No MAX in WQL 
Next
Set colProcesses = Nothing
Set objWMIService = Nothing
Set Conn = CreateObject("adodb.connection")
Conn.Open ConnString
strSQL = "insert into WscriptPID (PID) values (" & MaxPID & ")"
Conn.execute strSQL
Conn.Close
Set Conn = Nothing' Author: Chrissy LeMaire
' Copyright 2003 NetNerds Consulting Group
' Script is provided AS IS with no warranties or guarantees and assumes no liabilities.
' Website: http://www.netnerds.net
'create table WscriptPID (PID int,timestamp smalldatetime default getdate())
ConnString = "Provider=SQLOLEDB; Data Source=LELAND; Initial catalog=WindowsEvents; Trusted_Connection=yes;"
strComputer = "LELAND" 'Enter your monitoring server name
Set rs = CreateObject("adodb.recordset")
strSQL = "select top 1 PID from WscriptPID order by timestamp desc"
rs.Open strSQL,ConnString,1,1
PID = rs("PID")
rs.Close
Set rs = Nothing
Set objWMIService = GetObject("winmgmts:\.\root\cimv2")
Set colProcesses = objWMIService.ExecQuery("Select * from Win32_Process where ProcessID = " & PID)
If colProcesses.Count = 0 Then
Set objWMIProcess = GetObject("winmgmts:" & strComputer & "\root\cimv2:Win32_Process")
errReturn = objWMIProcess.Create ("wscript.exe C:\scripts\push2servers.vbs", Null, Null, intProcessID)
Set objWMIProcess = Nothing
End If
Set colProcesses = Nothing
Set objWMIService = NothingVBScript: Check for Low Disk Space and Report to Event Viewer
This code is part of a bigger project I'm working on. It checks the disk space for each logical drive and, if the space is below one gigabyte, reports it to Event Viewer at a max of once per day.
'****************************************************************************
' This script created by Chrissy LeMaire (clemaire@gmail.com)
' Website: http://netnerds.net/
'
' NO WARRANTIES, etc.
'
' This script checks hard drives for less than 1GB of space.
'
' Requirements -- ability to read WinNT://, create events and read WMI
'
' This script has only been tested on Windows Server 2003.
'
' "What it does"
' 1. Gets a list of computers on a domain
' 2. Checks for disk space
' 3. If disk space < 1 GB, add to Event Viewer but not more than once a day.
'*****************************************************************************
On Error Resume Next 'Ignore errors
Set objAdRootDSE = GetObject("LDAP://RootDSE")
Set objRS = CreateObject("adodb.recordset")
varConfigNC = objAdRootDSE.Get("defaultNamingContext")
strConnstring = "Provider=ADsDSOObject"
strWQL = "SELECT * FROM 'LDAP://" & varConfigNC & "' WHERE objectCategory= 'Computer' and OperatingSystem = 'Windows*Server*'"
objRS.Open strWQL, strConnstring
Do until objRS.eof
Set objServer = GetObject(objRS.Fields.Item(0))
strServerName = objServer.CN
Call GetDiskSpaceAddEvent(strServerName)
objRS.movenext
Set objServer = Nothing
Loop
objRS.close
Set objRS = Nothing
Set objAdRootDSE = Nothing
'-----------------------------------------------------------------------
'
' Do the Dirty Work
'
'-----------------------------------------------------------------------
Sub GetDiskSpaceAddEvent(strComputer)
myDate = date2String(strComputer,"-24")
Set objWMIService = GetObject("winmgmts:" & strComputer & "\root\cimv2")
Set colItems = objWMIService.ExecQuery ("Select DeviceID, FreeSpace from Win32_LogicalDisk where DriveType = 3") 'Grab the name and the free space for fixed drives
For Each objItem in colItems
MBFree = formatnumber((objItem.FreeSpace/1048576),2)
If MBFree > 1000 Then 'Convert to MB then check for < 1GB
theQuery = "SELECT * FROM Win32_NTLogEvent WHERE Eventcode = '1000' and Type = 'Error' and LogFile='System' and SourceName = 'Low Disk Space' and TimeWritten >= '" & myDate & "' and Message like '%" & objItem.DeviceID & "%" & strComputer & "%'"
Set colLoggedEvents = objWMIService.ExecQuery (theQuery)
If colLoggedEvents.Count = 0 Then
runThis = "%COMSPEC% /c eventcreate /s " & strComputer & " /so ""Low Disk Space"" /T Error /ID 1000 /L System /D ""The size of disk " & objItem.DeviceID & " on " & StrComputer & " has dropped below 1 Gigabyte (" & MBFree & " MB free)."""
WindowStyle = 0 'Do not pop up a dos box
Set WshShell = WScript.CreateObject("WScript.Shell") 'generate the object
Call WshShell.Run (runThis, WindowStyle, false) 'execute the dos command listed above (COMSPEC = cmd.exe)
Set WshShell = Nothing
End If
Set colLoggedEvents = Nothing
End If
Next
End Sub
'-----------------------------------------------------------------------
'
' Supporting Date Functions to convert WMI date to human readable dates
'
'-----------------------------------------------------------------------
'The function listed below only works in 2k3 and XP. So we use the manual ones below.
'Function date2WMI(theHourDiff)
'Set WMIDate = CreateObject("WbemScripting.SWbemDateTime")
'WMIDate.SetVarDate DateAdd("hh", theHourDiff, Now())
'Date2WMI = WMIDate.Value
'End Function
Function string2Date(dtmInstallDate)
WMIDateStringToDate = CDate(Mid(dtmInstallDate, 5, 2) & "/" & _
Mid(dtmInstallDate, 7, 2) & "/" & Left(dtmInstallDate, 4) _
& " " & Mid (dtmInstallDate, 9, 2) & ":" & _
Mid(dtmInstallDate, 11, 2) & ":" & Mid(dtmInstallDate, _
13, 2))
string2Date = WMIDateStringToDate
End Function
Function date2String(strComputer,theOffset)
Set objSWbemServices = GetObject("winmgmts:\.\root\cimv2")
Set colTimeZone = objSWbemServices.ExecQuery ("SELECT * FROM Win32_TimeZone")
For Each objTimeZone in colTimeZone
strBias = objTimeZone.Bias
Next
dtmCurrentDate = date + theOffset
'response.write dtmCurrentDate
dtmTargetDate = Year(dtmCurrentDate)
dtmMonth = Month(dtmCurrentDate)
If Len(dtmMonth) = 1 Then
dtmMonth = "0" & dtmMonth
End If
dtmTargetDate = dtmTargetDate & dtmMonth
dtmDay = Day(dtmCurrentDate)
If Len(dtmDay) = 1 Then
dtmDay = "0" & dtmDay
End If
dtmTargetDate = dtmTargetDate & dtmDay & "000000.000000"
dtmTargetDate = dtmTargetDate & Cstr(strBias)
date2String = dtmTargetDate
End Function
WScript.QuitAbout
-
We are IT consultants
who grew up living and loving life
in Cajun Country.
Authors
Categories
- Oracle
- OS X & iDevices
- PowerShell
- Security
- SharePoint
- SQL Server
- VBScript
- Virtualization
- Windows
- Wordpress
