Aug 05

DirMirror.vbs

Posted on August 5, 2014 by admin

Option Explicit
'=========================================================================
' DirMirror.vbs
' VERSION: 1.0
' AUTHOR: Brian Steinmeyer
' EMAIL: sigkill@sigkillit.com
' WEB: http://sigkillit.com
' DATE: 9/26/2013
' REQUIREMENTS:
' - robocopy.exe (Built in to Server2008+, Windows 7+)
' - blat.exe, blat.dll. blat.lib in the same directory as the script (http://www.blat.net)
' - Blat profile installed to email results
' - Recommended to use Stunnel to Encrypt Email Sessions, Especially If the Email Server
' is not on your subnet ex: Gmail
' COMMENTS: Requires robocopy for the backup and blat to email results. Define
' the Directory Source(what you need to backup), the Directory Destination
' (where you need to backup to), path to blat, blat profile, email subject,
' and email body
'=========================================================================

' ------ SCRIPT CONFIGURATION ------
Const WindowStyle = 0  '0=Hide Robocopy Console, 1=Show Robocopy Console
Dim DirSource: DirSource = "\\server\share\directory"
Dim DirDestination: DirDestination = Left(WScript.ScriptFullName,InstrRev(WScript.ScriptFullName,"\")) & "backup"
Dim intReturn 'Generic Return
Dim logErrors: logErrors = Replace(WScript.ScriptFullName,".vbs","_log.txt")
Dim emailBlatExe: emailBlatExe = "C:\blat\blat.exe" 'Custom Path to Blat.exe Default is Same Folder as Script
Dim emailProfile: emailProfile = "gmail" 'Blat Profile Name See (http://www.blat.net) For Info
Dim emailRecipient: emailRecipient = "email@domain.com" 'Email to Receive Backup Result
Dim eSubject: eSubject = "Server1 Backup"
Dim eBody: eBody = "Server1 Backup"
' ------ END CONFIGURATION ------

'MAIN CALLS
Call Logger(logErrors, "[" & Now() & "] " & vbCrLf & Wscript.ScriptName & vbCrLf & "Server: Spiceworks", True)
Call AllowSingleInstance(".",logErrors, emailBlatExe, emailProfile, emailRecipient, eSubject, eBody)
Call ConfirmDirectories(logErrors, DirSource, DirDestination, emailBlatExe, emailProfile, emailRecipient, eSubject, eBody)
Call RoboDirMirror(logErrors, DirSource, DirDestination, emailBlatExe, emailProfile, emailRecipient, eSubject, eBody)



' ***************************************************************************************************
' Function RoboDirMirror - Mirrors a Source Directory to a Mirror Directory Using Robocopy
' ***************************************************************************************************
Private Sub RoboDirMirror(logName, strSource, strDestination, emailBlatExe, emailProfile, emailRecipient, emailSubject, emailBody)

	'On Error Resume Next
	
	Call Logger(logName, vbCrLf & "[" & Now() & "] " & vbCrLf & "Run Robocopy to Mirror Directory", False)
	'Ensure Directories Don't End with Slash or Robocopy Will Error
	If Mid(strSource,Len(strSource),1) = "\" Then
		strSource = Mid(strSource,1,Len(strSource) - 1)
	End If
	If Mid(strDestination,Len(strDestination),1) = "\" Then
		strDestination = Mid(strDestination,1,Len(strDestination) - 1)
	End If
	
	Dim objShell: Set objShell = WScript.CreateObject("WScript.Shell")
	Dim strCommand: strCommand = "robocopy"
	Dim cmdOptions: cmdOptions = "/MIR /FFT /Z /XA:H /W:5 /log+:" & chr(34) & logName & chr(34)
	'Robocopy \\SourceServer\Share \\DestinationServer\Share /MIR /FFT /Z /XA:H /W:5
	Dim intReturn: intReturn = objShell.Run(strCommand & " " & chr(34) & strSource & chr(34) & " " & chr(34) & strDestination & chr(34) & " " & cmdOptions, WindowStyle, True)
	Select Case intReturn
	Case 0
		'No Files Copied
		Call Logger(logName, "RESULT: Success - No Files Copied", False)
		emailSubject = emailSubject & " Success"
		emailBody = emailBody & " Success - No Files Copied"
	Case 1
		'Files Copied
		Call Logger(logName, "RESULT: Success - Files Copied", False)
		emailSubject = emailSubject & " Success"
		emailBody = emailBody & " Success - Files Copied"
	Case 2
		'File on Source Does Not Exist on Destination
		Call Logger(logName, "RESULT: Success - New Files Found in Source that are Not in Destination", False)
		emailSubject = emailSubject & " Success"
		emailBody = emailBody & " Success - New Files Found in Source that are Not in Destination"
	Case 3
		'Combination of Case1 and Case2
		Call Logger(logName, "RESULT: Success - Files Copied (New Files Found in Source that are Not in Destination)", False)
		emailSubject = emailSubject & " Success"
		emailBody = emailBody & " Success - Files Copied (New Files Found in Source that are Not in Destination)"
	Case Else
		'Error
		Call Logger(logName, "RESULT: !~ERROR~! - Error Occurred on Robocopy", False)
		emailSubject = emailSubject & " FAILED"
		emailBody = emailBody & " FAILED - Error Occurred on Robocopy"
	End Select
	
	If Err.Number <> 0 Then
		Err.Clear
		Call Logger(logName, "!~ERROR~! - Unknown Error Occurred in RoboDirMirror Sub", False)
		emailSubject = emailSubject & " FAILED"
		emailBody = emailBody & " FAILED - Unknown Error Occurred in RoboDirMirror Sub"
	End If
	
	Call SendBlatEmail(emailBlatExe, emailProfile, emailRecipient, emailSubject, emailBody, logName)
	
End Sub



' ***************************************************************************************************
' Function ConfirmDirectories - Confirm Source and Destination Directories Exist
' ***************************************************************************************************
Private Sub ConfirmDirectories(logName, strSource, strDestination, emailBlatExe, emailProfile, emailRecipient, emailSubject, emailBody)

	'On Error Resume Next
	
	Call Logger(logName, vbCrLf & "[" & Now() & "] " & vbCrLf & "Confirm Source/Destination Directories Exist", False)
	' Create Objects
	Dim objFSO: Set objFSO = CreateObject("Scripting.FileSystemObject")
	Call Logger(logName, "SOURCE: " & strSource, False)
	Call Logger(logName, "DESTINATION: " & strDestination, False)
	If Not objFSO.FolderExists(strSource) Then
		'Source Not Exist
		Call Logger(logName, "!~ERROR~! - Source Directory Does Not Exist, Quitting Script!", False)
		emailSubject = emailSubject & " FAILED"
		emailBody = emailBody & " Failed - Source Directory Does Not Exist"
		Call SendBlatEmail(emailBlatExe, emailProfile, emailRecipient, emailSubject, emailBody, logName)
		Wscript.Quit
	Else
		Call Logger(logName, "Success - Source Directory Exists", False)
	End If
	
	If Not objFSO.FolderExists(strDestination) Then
		'Destination Not Exist
		Call Logger(logName, "Warning - Destination Directory Does Not Exist, Attempting to Create It", False)
		'Attempt to Create
		Call CreateFileOrDir(strDestination)
		If Not objFSO.FolderExists(strDestination) Then
			Call Logger(logName, "!~ERROR~! - Failed to Create Destination Directory, Quitting Script!", False)
			emailSubject = emailSubject & " FAILED"
			emailBody = emailBody & " Failed - Destination Directory Does Not Exist and Failed to Create It"
			Call SendBlatEmail(emailBlatExe, emailProfile, emailRecipient, emailSubject, emailBody, logName)
			Wscript.Quit
		Else
			Call Logger(logName, "Success - Created Destination Directory", False)
		End If
	Else
		Call Logger(logName, "Success - Destination Directory Exists", False)
	End If
	
	If Err.Number <> 0 Then
		Err.Clear
		Call Logger(logName, "!~ERROR~! - Unknown Error in ConfirmDirectories Sub, Quitting Script", False)
		emailSubject = emailSubject & " FAILED"
		emailBody = emailBody & " Failed - Unknown Error in ConfirmDirectories Sub"
		Call SendBlatEmail(emailBlatExe, emailProfile, emailRecipient, emailSubject, emailBody, logName)
		Wscript.Quit
	End If
	
End Sub



' ***************************************************************************************************
' Function AllowSingleInstance - Checks if only a single instance of the script is running - useful 
'                                for repetitive scheduled tasks
' ***************************************************************************************************
Private Sub AllowSingleInstance(strComputer, logName, emailBlatExe, emailProfile, emailRecipient, emailSubject, emailBody)
	
	On Error Resume Next
	
	Call Logger(logName, vbCrLf & "[" & Now() & "] " & vbCrLf & "Confirm Single Instance of " & Wscript.ScriptName, False)
	Dim intReturn: intReturn = 0  '0=Success, 1=Error, 2=Warning
	Dim objWMIService: Set objWMIService = GetObject("winmgmts:" & "{impersonationLevel=impersonate}!\\" & strComputer & "\root\cimv2")
	Dim colItems: Set colItems = objWMIService.ExecQuery("Select * from Win32_Process Where Name = 'cscript.exe'" & " OR Name = 'wscript.exe'")
	Dim intCount: intCount = 0
	Dim objItem, strTemp

	For Each objItem in colItems
		If Not IsNull(objItem.CommandLine) Then
			strTemp = Right(objItem.CommandLine, Len(objItem.CommandLine) - InStrRev(objItem.CommandLine, chr(34) & " " & chr(34)))
			strTemp = Trim(Replace(strTemp, chr(34), ""))
			If StrComp(Wscript.ScriptFullName, strTemp, 1) = 0 Then
				intCount = intCount + 1
			End If
		End If
	Next	
	
	Call Logger(logName, "Detected Instances: " & intCount, False)
	If intCount > 1 Then
		'Kill It
		Call Logger(logName, "!~ERROR~! - Only 1 instance is allowed, Quitting Script!", False)
		emailSubject = emailSubject & " FAILED"
		emailBody = emailBody & " Backup FAILED - Detected " & intCount & " running instances"
		Call SendBlatEmail(emailBlatExe, emailProfile, emailRecipient, emailSubject, emailBody, logName)
		Wscript.Quit
	End If
	
	If Err.Number <> 0 Then
		Err.Clear
		Call Logger(logName, "!~ERROR~! - Unknown Error in AllowSingleInstance Sub, Quitting Script!", False)
		emailSubject = emailSubject & " FAILED"
		emailBody = emailBody & " Backup FAILED - Unknown Error in AllowSingleInstance Sub"
		Call SendBlatEmail(emailBlatExe, emailProfile, emailRecipient, emailSubject, emailBody, logName)
		Wscript.Quit
	End If
	
	On Error Goto 0
	
End Sub



' ***************************************************************************************************
' Function CreateFileOrDir
' ***************************************************************************************************
Private Sub CreateFileOrDir(strPath)

    On Error Resume Next

    Dim objFSO: Set objFSO = CreateObject("Scripting.FileSystemObject")
    If objFSO.DriveExists(objFSO.GetDriveName(strPath)) Then
        If StrComp(objFSO.GetExtensionName(strPath), "", 1) = 0 Then
            If Not objFSO.FolderExists(strPath) Then
                If objFSO.FolderExists(objFSO.GetParentFolderName(strPath)) Then
                    objFSO.CreateFolder strPath 'Create Folder In Current Path
                Else
                    CreateFileOrDir(objFSO.GetParentFolderName(strPath)) 'Recurse Creating Parent Folder
                    CreateFileOrDir(strPath) 'Recurse Creating Current Folder
                End If
            End If
        Else
            If Not objFSO.FileExists(strPath) Then
                If objFSO.FolderExists(objFSO.GetParentFolderName(strPath)) Then
                    objFSO.CreateTextFile strPath, True  'Create File In Current Path
                Else
                    CreateFileOrDir(objFSO.GetParentFolderName(strPath))  'Recurse Creating Parent Folder
                    CreateFileOrDir(strPath)  'Recurse Creating Current Folder
                End If
            End If
        End If
    End If
   
    On Error Goto 0
   
End Sub



' ***************************************************************************************************
' Function SendBlatEmail - Sends Email Using Blat
' ***************************************************************************************************
Private Sub SendBlatEmail(blatPath, blatProfile, strRecipients, strSubject, strBody, strAttachment)

    'Need blat.exe, blat.dll, blat.lib
    On Error Resume Next
   
    Dim objFSO: Set objFSO = CreateObject("Scripting.FileSystemObject")
    Dim objShell: Set objShell = WScript.CreateObject("WScript.Shell")
    Dim scriptPath: scriptPath = Left(WScript.ScriptFullName,InstrRev(WScript.ScriptFullName,"\"))

    'Ensure Blat Exists
    If Not objFSO.FileExists(blatPath) Then
        If Not objFSO.FileExists(scriptPath & "blat.exe") Then
            Exit Sub
        Else
            blatPath = scriptPath & "blat.exe"
        End If
    End If
   
    'Set Blat Email Command
    Dim commandText: commandText = chr(34) & blatPath & chr(34)
    commandText = commandText & " -p " & chr(34) & blatProfile & chr(34)
    commandText = commandText & " -to " & strRecipients
    commandText = commandText & " -subject " & chr(34) & strSubject & " " & chr(34) 'Keep Space to Prevent Escaping the Quote
    commandText = commandText & " -body " & chr(34) & strBody & " " & chr(34) 'Keep Space to Prevent Escaping the Quote

    'Append Attachment(s)
    If objFSO.FileExists(strAttachment) Then
        commandText = commandText & " -attach " & chr(34) & strAttachment & chr(34)
    Else
        If objFSO.FileExists(scriptPath & strAttachment) Then
            commandText = commandText & " -attach " & chr(34) & scriptPath & strAttachment & chr(34)
        End If
    End If
   
    'Send Blat Email
    objShell.run commandText, True
   
    Set objFSO = Nothing
    Set objShell = Nothing
   
    If Err.Number <> 0 Then
        Err.Clear
    End If

    On Error Goto 0
   
End Sub



' ***************************************************************************************************
' Function Logger 
' ***************************************************************************************************
Private Sub Logger(fileName, logMessage, blnNewLog)

    On Error Resume Next
   
    Const ForReading = 1, ForWriting = 2, ForAppending = 8
    Dim objFSO: Set objFSO = CreateObject("Scripting.FileSystemObject")
    Dim scriptPath: scriptPath = Left(WScript.ScriptFullName,InstrRev(WScript.ScriptFullName,"\"))
    Dim logName
    If InStr(1,fileName,"\",1) > 0 Then
        logName = fileName
        If objFSO.DriveExists(objFSO.GetDriveName(logName)) Then
            If StrComp(objFSO.GetExtensionName(logName), "", 1) = 0 Then
                If Not objFSO.FolderExists(logName) Then
                    If objFSO.FolderExists(objFSO.GetParentFolderName(logName)) Then
                        objFSO.CreateFolder logName 'Create Folder In Current Path
                        Exit Sub
                    Else
                        Call Logger(objFSO.GetParentFolderName(logName), logMessage, blnNewLog) 'Recurse Creating Parent Folder
                        Call Logger(logName, logMessage, blnNewLog) 'Recurse Creating Current Folder
                        Exit Sub
                    End If
                End If
            Else
                If Not objFSO.FileExists(logName) Then
                    If Not objFSO.FolderExists(objFSO.GetParentFolderName(logName)) Then
                        Call Logger(objFSO.GetParentFolderName(logName), logMessage, blnNewLog)  'Recurse Creating Parent Folder
                        Call Logger(logName, logMessage, blnNewLog)  'Recurse Creating Current Folder
                    End If
                End If
            End If
        End If
    Else
        logName = scriptPath & fileName
    End If
    Dim logFile
    If blnNewLog = True Then
        Set logFile = objFSO.CreateTextFile(logName, True)
    Else
        If objFSO.FileExists(logName) Then
            Set logFile = objFSO.OpenTextFile(logName, ForAppending, True)
        Else
            Set logFile = objFSO.CreateTextFile(logName, True)
        End If
    End If
    logFile.WriteLine logMessage
    logFile.Close
    Set objFSO = Nothing
   
    On Error Goto 0

End Sub

Apr 22

DeleteOldUsers.vbs

Posted on April 22, 2014 by admin

'=========================================================================
' DeleteOldUsers.vbs
' VERSION: 1.0
' AUTHOR: Brian Steinmeyer
' EMAIL: sigkill@sigkillit.com
' WEB: http://sigkillit.com
' DATE: 4/22/2014
' USER TERMINATION POLICY:
' - Reset PW
' - Set description to termination date
' - Optionally forward email
' - Move terminated users to specified OU
' COMMENTS: This script works in conjunction with the above user termination
' policy. Specify the OU containing old users and set the number of retention
' days to keep an AD user account after the termination date. You can schedule
' the script to run daily to delete any old users.  to permanently delete
' those users after X amount of days.
'=========================================================================
Option Explicit

' ------ SCRIPT CONFIGURATION ------
Dim oldUserOU: oldUserOU = "OU=Old Users,OU=User,DC=domain,DC=local"
Dim oldUserRetentionDays: oldUserRetentionDays = 30
Dim logResults: logResults = Replace(WScript.ScriptFullName,".vbs","_logs\") & Replace(WScript.ScriptName,".vbs","_") & FixDate(Date()) & Replace(FormatDateTime(Time,4), ":", "") & ".txt"
Dim logRetentionDays: logRetentionDays = 30
Dim emailBlatExe: emailBlatExe = "c:\blat\blat.exe" 'Custom Path to Blat.exe Default is Same Folder as Script
Dim emailProfile: emailProfile = "alert" 'Blat Profile Name See (http://www.blat.net) For Info
Dim emailRecipient: emailRecipient = "alert.admin@domain.com" 'Email to Receive Backup Result
Dim blnEmailOnlyOnDelete: blnEmailOnlyOnDelete = true 'True = Only email results when at least 1 user is deleted
' ------ END CONFIGURATION ------

'MAIN CALLS
Call TerminateOldUsers(oldUserRetentionDays,oldUserOU,logResults)
Call SendResults(logResults,blnEmailOnlyOnDelete,emailBlatExe,emailProfile,emailRecipient)
Call PurgeLogs(Replace(WScript.ScriptFullName,".vbs","_logs\"),logRetentionDays,".txt")

' ***************************************************************************************************
' Sub TerminateOldUsers - Parse Old Users and Delete after X days
' ***************************************************************************************************
Private Sub TerminateOldUsers(intDays,strOU,logName)

    On Error Resume Next    'Start Error Handling

    'Create Log File
    Call Logger(logName, "DATE:" & Now() & vbCrLf & "USER_OU:" & strOU & vbCrLf & "RETENTION_DAYS:" & intDays, True)

    'Search OU For Users
    Dim objConnection: Set objConnection = CreateObject("ADODB.Connection")
    Dim objCommand: Set objCommand =   CreateObject("ADODB.Command")
    objConnection.Provider = "ADsDSOObject"
    objConnection.Open "Active Directory Provider"
    Set objCommand.ActiveConnection = objConnection
    objCommand.Properties("Page Size") = 1000   'Override the Return 1000 Results Default
    Const ADS_SCOPE_SUBTREE = 2
    objCommand.Properties("Searchscope") = ADS_SCOPE_SUBTREE    'Include Sub OU's
    objCommand.CommandText = "SELECT ADsPath, cn FROM 'LDAP://" & strOU & "' WHERE objectCategory='person' AND objectClass='user'"
    Dim objRecordSet: Set objRecordSet = objCommand.Execute
    'Parse Users
    If objRecordSet.RecordCount > 0 Then
        objRecordSet.MoveFirst
        Dim objUser, objParent, strDescription
        Dim strResult: strResult = ""
        Do Until objRecordSet.EOF
            Set objUser = GetObject(objRecordSet.Fields("ADsPath").Value)
            strDescription = objUser.description
            If strDescription = "" Then
                strDescription = "BLANK"
            End If
            'Only Evaluate Users with Date for Description
            If IsDate(objUser.Description) Then
                If DateDiff("d",objUser.Description,Date) > intDays Then
                    'Delete User Past Retention Date
                    strResult = "DELETE"
                    Set objParent = GetObject(objUser.Parent)
                    objParent.Delete "user", "CN=" & objRecordSet.Fields("cn").Value                   
                Else
                    strResult = "IGNORE"
                End If
            Else
                strResult = "IGNORE"
            End If         
            'Log Results
            If Err.Number <> 0 Then
                Err.Clear
                strResult = "!~ERROR!~"
            End If
            Call Logger(logName, strResult & ":(" & strDescription & "):" & objRecordSet.Fields("ADsPath").Value, False)
            objRecordSet.MoveNext
        Loop
    Else
        Call Logger(logName, "NOUSERS:" & strOU, False)
    End If

    On Error Goto 0 'End Error Handling

End Sub

' *****************************************************************
' Sub SendResults - Parse Log File and Send Results
' *****************************************************************
Private Sub SendResults(logName, blnEmail, emailBlatExe, emailProfile, emailRecipient)

    On Error Resume Next

    ' Create Objects
    Dim objFSO: Set objFSO = CreateObject("Scripting.FileSystemObject")

    'Parse Log File
    Dim intDelete: intDelete = 0
    Dim intTotal: intTotal = 0
    Dim intError: intError = 0
    Dim strLine
    Dim logFile: Set logFile = objFSO.OpenTextFile(logName, 1)
    Do Until logFile.AtEndOfStream
        strLine = logFile.ReadLine
        If InStr(1, strLine, "IGNORE:", 1) Then
            intTotal = intTotal + 1
        End If
        If InStr(1, strLine, "DELETE:", 1) Then
            intTotal = intTotal + 1
            intDelete = intDelete + 1
        End If
        If InStr(1, strLine, "!~ERROR~!:", 1) Then
            intTotal = intTotal + 1
            intError = intError + 1
        End If
        If InStr(1, strLine, "NOUSERS:", 1) Then
            'No Users
        End If
    Loop
    logFile.Close

    'Set Email Subject
    Dim emailSubject: emailSubject = Replace(WScript.ScriptName,".vbs","")
    If intError > 0 Then
        emailSubject =  emailSubject & " - Error"
    Else
        emailSubject = emailSubject & " - Deleted "  & intDelete & " Users"
    End If

    'Set Email Body
    Dim emailBody: emailBody = "TOTAL USERS: " & intTotal & vbCrLf & _
        "ERRORS: " & intError & vbCrLf & _
        "DELETED: " & intDelete

    'Email Results
    If blnEmail = true Then
        If intDelete > 0 Then
            Call SendBlatEmail(emailBlatExe, emailProfile, emailRecipient, emailSubject, emailBody, logName)
        End If
    Else
        Call SendBlatEmail(emailBlatExe, emailProfile, emailRecipient, emailSubject, emailBody, logName)
    End If

    'Cleanup Objects
    Set objFSO = Nothing

    On Error Goto 0

End Sub

' ***************************************************************************************************
' Function SendBlatEmail - Sends Email Using Blat
' ***************************************************************************************************
Private Sub SendBlatEmail(blatPath, blatProfile, strRecipients, strSubject, strBody, strAttachment)

    'Need blat.exe, blat.dll, blat.lib
   On Error Resume Next

    Dim objFSO: Set objFSO = CreateObject("Scripting.FileSystemObject")
    Dim objShell: Set objShell = WScript.CreateObject("WScript.Shell")
    Dim scriptPath: scriptPath = Left(WScript.ScriptFullName,InstrRev(WScript.ScriptFullName,"\"))

    'Ensure Blat Exists
   If Not objFSO.FileExists(blatPath) Then
        If Not objFSO.FileExists(scriptPath & "blat.exe") Then
            Exit Sub
        Else
            blatPath = scriptPath & "blat.exe"
        End If
    End If

    'Set Blat Email Command
   Dim commandText: commandText = chr(34) & blatPath & chr(34)
    commandText = commandText & " -p " & chr(34) & blatProfile & chr(34)
    commandText = commandText & " -to " & strRecipients
    commandText = commandText & " -subject " & chr(34) & strSubject & " " & chr(34) 'Keep Space to Prevent Escaping the Quote
   commandText = commandText & " -body " & chr(34) & strBody & " " & chr(34) 'Keep Space to Prevent Escaping the Quote

    'Append Attachment(s)
   If objFSO.FileExists(strAttachment) Then
        commandText = commandText & " -attach " & chr(34) & strAttachment & chr(34)
    Else
        If objFSO.FileExists(scriptPath & strAttachment) Then
            commandText = commandText & " -attach " & chr(34) & scriptPath & strAttachment & chr(34)
        End If
    End If

    'Send Blat Email
   objShell.run commandText, True

    Set objFSO = Nothing
    Set objShell = Nothing

    If Err.Number <> 0 Then
        Err.Clear
    End If

    On Error Goto 0

End Sub

' ***************************************************************************************************
' Sub PurgeLogs - Deletes Old Log FIles
' ***************************************************************************************************
Private Sub PurgeLogs(logFolder,intDays,strExtension)

    On Error Resume Next

    Dim objFSO: Set objFSO = CreateObject("Scripting.FileSystemObject")
    Dim objFolder: Set objFolder = objFSO.GetFolder(logFolder)
    Dim file
    For Each file In objFolder.Files
        If StrComp(Right(file.Name, Len(strExtension)),strExtension) = 0 Then
            If DateDiff("d", file.DateLastModified, Now) > intDays Then
                objFSO.DeleteFile(file), True
            End If
        End If
    Next

    Set objFSO = Nothing

    If Err.Number <> 0 Then
        Err.Clear
    End If

    On Error Goto 0

End Sub

' ***************************************************************************************************
' Function FixDate - Ensures Single Digit Numbers Have 0 In Front
' ***************************************************************************************************
Function FixDate(strDate)
    Dim arrTemp
    Dim M, D, Y
    arrTemp = Split(strDate, "/")
    M = arrTemp(0)
    D = arrTemp(1)
    Y = arrTemp(2)
    If (M>=0) And (M<10) Then M = "0" & M
    If (D>=0) And (D<10) Then D = "0" & D
    'If (Y>=0) And (Y<10) Then Y = "0" & Y
    FixDate = M & D & Y
End Function

' ***************************************************************************************************
' Function Logger
' ***************************************************************************************************
Private Sub Logger(fileName, logMessage, blnNewLog)

    On Error Resume Next

    Const ForReading = 1, ForWriting = 2, ForAppending = 8
    Dim objFSO: Set objFSO = CreateObject("Scripting.FileSystemObject")
    Dim scriptPath: scriptPath = Left(WScript.ScriptFullName,InstrRev(WScript.ScriptFullName,"\"))
    Dim logName
    If InStr(1,fileName,"\",1) > 0 Then
        logName = fileName
        If objFSO.DriveExists(objFSO.GetDriveName(logName)) Then
            If StrComp(objFSO.GetExtensionName(logName), "", 1) = 0 Then
                If Not objFSO.FolderExists(logName) Then
                    If objFSO.FolderExists(objFSO.GetParentFolderName(logName)) Then
                        objFSO.CreateFolder logName 'Create Folder In Current Path
                       Exit Sub
                    Else
                        Call Logger(objFSO.GetParentFolderName(logName), logMessage, blnNewLog) 'Recurse Creating Parent Folder
                       Call Logger(logName, logMessage, blnNewLog) 'Recurse Creating Current Folder
                       Exit Sub
                    End If
                End If
            Else
                If Not objFSO.FileExists(logName) Then
                    If Not objFSO.FolderExists(objFSO.GetParentFolderName(logName)) Then
                        Call Logger(objFSO.GetParentFolderName(logName), logMessage, blnNewLog)  'Recurse Creating Parent Folder
                       Call Logger(logName, logMessage, blnNewLog)  'Recurse Creating Current Folder
                   End If
                End If
            End If
        End If
    Else
        logName = scriptPath & fileName
    End If
    Dim logFile
    If blnNewLog = True Then
        Set logFile = objFSO.CreateTextFile(logName, True)
    Else
        If objFSO.FileExists(logName) Then
            Set logFile = objFSO.OpenTextFile(logName, ForAppending, True)
        Else
            Set logFile = objFSO.CreateTextFile(logName, True)
        End If
    End If
    logFile.WriteLine logMessage
    logFile.Close
    Set objFSO = Nothing

    On Error Goto 0

End Sub

Mar 20

SyncToy21.vbs

Posted on March 20, 2014 by admin

'=========================================================================
' SyncToy21.vbs
' VERSION: 1.0
' AUTHOR: Brian Steinmeyer
' EMAIL: sigkill@sigkillit.com
' WEB: http://sigkillit.com
' DATE: 3/20/20114
' REQUIREMENTS: You must install SyncToy on the Workstation and manually run it to click on
' the agreement statement, otherwise this script will lock up and NEVER back up!!!
'=========================================================================
Option Explicit

' ------ SCRIPT CONFIGURATION ------
Const strContact = "backup@domain.com"
Dim syncToyExe: syncToyExe = ExpandEnv("%PROGRAMFILES%\SyncToy 2.1\SyncToy.exe")
Dim syncToyExeX86: syncToyExeX86 = ExpandEnv("%PROGRAMFILES(X86)%\SyncToy 2.1\SyncToy.exe")
Dim syncToyCmdExe: syncToyCmdExe = ExpandEnv("%PROGRAMFILES%\SyncToy 2.1\SyncToyCmd.exe")
Dim syncToyCmdExeX86: syncToyCmdExeX86 = ExpandEnv("%PROGRAMFILES(X86)%\SyncToy 2.1\SyncToyCmd.exe")
Dim blnAutoRun: blnAutoRun = True
Dim syncOperation: syncOperation = "echo"
Dim strBackupPath: strBackupPath = ExpandEnv("\\server\backups\%USERNAME%\")
Dim objFSO: Set objFSO = CreateObject("Scripting.FileSystemObject")
' ------ END CONFIGURATION ------

Call Main()

Private Sub Main()

    ' Create Objects
    Dim objFSO: Set objFSO = CreateObject("Scripting.FileSystemObject")
    Dim objShell: Set objShell = CreateObject( "WScript.Shell" )

    ' Set Folders for Backups
    Dim strDocuments: strDocuments = objShell.SpecialFolders("MyDocuments")
    Dim strMusic: strMusic = objShell.RegRead("HKCU\Software\Microsoft\Windows\CurrentVersion\Explorer\Shell Folders\My Music")
    Dim strPictures: strPictures = objShell.RegRead("HKCU\Software\Microsoft\Windows\CurrentVersion\Explorer\Shell Folders\My Pictures")
    Dim strVideos: strVideos = objShell.RegRead("HKCU\Software\Microsoft\Windows\CurrentVersion\Explorer\Shell Folders\My Video")

    ' Ensure Backup Path Ends with Slash
    If Right(strBackupPath,1) <> "\" Then
        strBackupPath = strBackupPath & "\"
    End If

    ' Validate Folders for Backup
    Dim strResult: strResult = ""
    If Not objFSO.FolderExists(strDocuments) Then
        strResult = strResult & "- Missing Documents Folder" & vbCrLf
    End If
    If Not objFSO.FolderExists(strMusic) Then
        strResult = strResult & "- Missing Music Folder" & vbCrLf
    End If
    If Not objFSO.FolderExists(strPictures) Then
        strResult = strResult & "- Missing Pictures Folder" & vbCrLf
    End If
    If Not objFSO.FolderExists(strBackupPath) Then
        strResult = strResult & "- Missing Backup Folder" & vbCrLf
    End If

    ' Validate SyncToy Path
    If Not objFSO.FileExists(syncToyExe) Then
        If Not objFSO.FileExists(syncToyExeX86) Then
            strResult = strResult & "- Missing SyncToy.exe" & vbCrLf
        Else
            syncToyExe = syncToyExeX86
        End If
    End If
    If Not objFSO.FileExists(syncToyCmdExe) Then
        If Not objFSO.FileExists(syncToyCmdExeX86) Then
            strResult = strResult & "- Missing SyncToyCmd.exe" & vbCrLf
        Else
            syncToyCmdExe = syncToyCmdExeX86
        End If
    End If

    ' Ensure Everything Validated
    If strResult <> "" Then
        objShell.Popup "An ERROR occurred backing up your files" & vbCrLf & _
            strResult & vbCrLf & _
            "Please contact " & strContact _
            , 30, "ERROR Backing Up Documents!", vbOkOnly + vbCritical
        Wscript.Quit
    End If

    ' Determine Which Folders To Backup and Prompt to Backup
    Dim intAnswer
    Dim blnDocuments: blnDocuments = True
    Dim blnMusic: blnMusic = False
    Dim blnPictures: blnPictures = False
    Dim blnVideos: blnVideos = False
    If InStr(1,strMusic,strDocuments,1) > 0 AND InStr(1,strPictures,strDocuments,1) > 0 AND InStr(1,strVideos,strDocuments,1) > 0 Then
        ' Backup Documents
        intAnswer = objShell.Popup("Do you want to Backup your documents now? This may take several minutes...", 30, "Backup Files?", vbYesNo + vbQuestion)
        If intAnswer = vbNo Then
            blnDocuments = False
        End If
    Elseif InStr(1,strMusic,strDocuments,1) > 0 AND InStr(1,strPictures,strDocuments,1) > 0 Then
        ' Backup Documents
        intAnswer = objShell.Popup("Do you want to Backup your documents now? This may take several minutes...", 30, "Backup Files?", vbYesNo + vbQuestion)
        If intAnswer = vbNo Then
            blnDocuments = False
        End If
        ' Backup Videos
        intAnswer = objShell.Popup("Do you want to Backup your videos now? This may take several minutes...", 30, "Backup Files?", vbYesNo + vbQuestion)
        If intAnswer = vbNo Then
            blnVideos = False
        End If
    Elseif InStr(1,strMusic,strDocuments,1) > 0 AND InStr(1,strVideos,strDocuments,1) > 0 Then
        ' Backup Documents
        intAnswer = objShell.Popup("Do you want to Backup your documents now? This may take several minutes...", 30, "Backup Files?", vbYesNo + vbQuestion)
        If intAnswer = vbNo Then
            blnDocuments = False
        End If
        ' Backup Pictures
        intAnswer = objShell.Popup("Do you want to Backup your pictures now? This may take several minutes...", 30, "Backup Files?", vbYesNo + vbQuestion)
        If intAnswer = vbNo Then
            blnPictures = False
        End If
    Elseif InStr(1,strPictures,strDocuments,1) > 0 AND InStr(1,strVideos,strDocuments,1) > 0 Then
        ' Backup Documents
        intAnswer = objShell.Popup("Do you want to Backup your documents now? This may take several minutes...", 30, "Backup Files?", vbYesNo + vbQuestion)
        If intAnswer = vbNo Then
            blnDocuments = False
        End If
        ' Backup Music
        intAnswer = objShell.Popup("Do you want to Backup your music now? This may take several minutes...", 30, "Backup Files?", vbYesNo + vbQuestion)
        If intAnswer = vbNo Then
            blnMusic = False
        End If
    Elseif InStr(1,strMusic,strDocuments,1) > 0 Then
        ' Backup Documents
        intAnswer = objShell.Popup("Do you want to Backup your documents now? This may take several minutes...", 30, "Backup Files?", vbYesNo + vbQuestion)
        If intAnswer = vbNo Then
            blnDocuments = False
        End If
        ' Backup Pictures
        intAnswer = objShell.Popup("Do you want to Backup your pictures now? This may take several minutes...", 30, "Backup Files?", vbYesNo + vbQuestion)
        If intAnswer = vbNo Then
            blnPictures = False
        End If
         Backup Videos
        intAnswer = objShell.Popup("Do you want to Backup your videos now? This may take several minutes...", 30, "Backup Files?", vbYesNo + vbQuestion)
        If intAnswer = vbNo Then
            blnVideos = False
        End If
    Elseif InStr(1,strPictures,strDocuments,1) > 0 Then
        ' Backup Documents
        intAnswer = objShell.Popup("Do you want to Backup your documents now? This may take several minutes...", 30, "Backup Files?", vbYesNo + vbQuestion)
        If intAnswer = vbNo Then
            blnDocuments = False
        End If
        ' Backup Music
        intAnswer = objShell.Popup("Do you want to Backup your music now? This may take several minutes...", 30, "Backup Files?", vbYesNo + vbQuestion)
        If intAnswer = vbNo Then
            blnMusic = False
        End If
        ' Backup Videos
        intAnswer = objShell.Popup("Do you want to Backup your videos now? This may take several minutes...", 30, "Backup Files?", vbYesNo + vbQuestion)
        If intAnswer = vbNo Then
            blnVideos = False
        End If
    Elseif InStr(1,strVideos,strDocuments,1) > 0 Then
        ' Backup Documents
        intAnswer = objShell.Popup("Do you want to Backup your documents now? This may take several minutes...", 30, "Backup Files?", vbYesNo + vbQuestion)
        If intAnswer = vbNo Then
            blnDocuments = False
        End If
        ' Backup Music
        intAnswer = objShell.Popup("Do you want to Backup your music now? This may take several minutes...", 30, "Backup Files?", vbYesNo + vbQuestion)
        If intAnswer = vbNo Then
            blnMusic = False
        End If
        ' Backup Pictures
        intAnswer = objShell.Popup("Do you want to Backup your pictures now? This may take several minutes...", 30, "Backup Files?", vbYesNo + vbQuestion)
        If intAnswer = vbNo Then
            blnPictures = False
        End If
    Else
        ' Backup Documents
        intAnswer = objShell.Popup("Do you want to Backup your documents now? This may take several minutes...", 30, "Backup Files?", vbYesNo + vbQuestion)
        If intAnswer = vbNo Then
            blnDocuments = False
        End If
        ' Backup Music
        intAnswer = objShell.Popup("Do you want to Backup your music now? This may take several minutes...", 30, "Backup Files?", vbYesNo + vbQuestion)
        If intAnswer = vbNo Then
            blnMusic = False
        End If
        ' Backup Pictures
        intAnswer = objShell.Popup("Do you want to Backup your pictures now? This may take several minutes...", 30, "Backup Files?", vbYesNo + vbQuestion)
        If intAnswer = vbNo Then
            blnPictures = False
        End If
        ' Backup Videos
        intAnswer = objShell.Popup("Do you want to Backup your videos now? This may take several minutes...", 30, "Backup Files?", vbYesNo + vbQuestion)
        If intAnswer = vbNo Then
            blnVideos = False
        End If
    End If

    'Validate Backup Folder Exists Or Try to Create Them
    strResult = ""
    If blnDocuments = True Then
        If ValidateFolder(strBackupPath & "Documents") = False Then
            strResult = strResult & "- Missing " & strBackupPath & "Documents" & vbCrLf
        End If
    End If
    If blnMusic = True Then
        If ValidateFolder(strBackupPath & "Music") = False Then
            strResult = strResult & "- Missing " & strBackupPath & "Music" & vbCrLf
        End If 
    End If
    If blnPictures = True Then
        If ValidateFolder(strBackupPath & "Pictures") = False Then
            strResult = strResult & "- Missing " & strBackupPath & "Pictures" & vbCrLf
        End If
    End If
    If blnVideos = True Then
        If ValidateFolder(strBackupPath & "Videos") = False Then
            strResult = strResult & "- Missing " & strBackupPath & "Videos" & vbCrLf
        End If
    End If

    ' Ensure Everything Validated
    If strResult <> "" Then
        objShell.Popup "An ERROR occurred backing up your files" & vbCrLf & _
            strResult & vbCrLf & _
            "Please contact " & strContact _
            , 30, "ERROR Backing Up Documents!", vbOkOnly + vbCritical
        Wscript.Quit
    End If

    ' Create Folder Pairs
    Call CreateSyncToyPairs(blnDocuments, strDocuments, blnMusic, strMusic, blnPictures, strPictures, blnVideos, strVideos)

    ' Run SyncToy Backup
    If blnDocuments = True Then
        Call RunSyncToy("Documents")
    End If
    If blnMusic = True Then
        Call RunSyncToy("Music")
    End If
    If blnPictures = True Then
        Call RunSyncToy("Pictures")
    End If
    If blnVideos = True Then
        Call RunSyncToy("Videos")
    End If

    ' Cleanup
    Set objFSO = Nothing
    Set objShell = Nothing

End Sub

Private Function ValidateFolder(ByVal strFolder)

    Dim objFSO: Set objFSO = CreateObject("Scripting.FileSystemObject")
    Dim blnResult: blnResult = True
    On Error Resume Next
    If Not objFSO.FolderExists(strFolder) Then
        objFSO.CreateFolder(strFolder)
    End If
    If Err.Number <> 0 Then
        Err.Clear
        blnResult = False
    End If
    On Error Goto 0

    ValidateFolder = blnResult

End Function

Private Sub CreateSyncToyPairs(ByVal bDoc, ByVal sDoc, ByVal bMus, ByVal sMus, ByVal bPic, ByVal sPic, ByVal bVid, ByVal sVid)

    ' Create Objects
    Dim objShell: Set objShell = CreateObject( "WScript.Shell" )

    ' Attempt to Delete Folder Pairs
    Call DeleteSyncToyPair(sDoc,"Documents")
    Call DeleteSyncToyPair(sMus,"Music")
    Call deleteSyncToyPair(sPic,"Pictures")
    Call deleteSyncToyPair(sVid,"Videos")

    ' Create Folder Pairs
    If bDoc = True Then
        objShell.Run chr(34) & syncToyExe & Chr(34) & _
        " -d(left=" & chr(34) & sDoc & chr(34) & _
        ",right=" & chr(34) & strBackupPath & "Documents" & chr(34) & _
        ",name=Documents" & _
        ",operation=" & syncOperation & _
        ",excluded=*.jpg;*.jpeg;*.gif;*.bmp;*.png;*.mp3;*.m4a;*.mid;*.mpg;*.mpeg;*.divx;*.mov" & ")", 0, true  
    End If
    If bMus = True Then
        objShell.Run chr(34) & syncToyExe & Chr(34) & _
        " -d(left=" & chr(34) & sMus & chr(34) & _
        ",right=" & chr(34) & strBackupPath & "Music" & chr(34) & _
        ",name=Music" & _
        ",operation=" & syncOperation & _
        ",excluded=*.jpg;*.jpeg;*.gif;*.bmp;*.png;*.mp3;*.m4a;*.mid;*.mpg;*.mpeg;*.divx;*.mov" & ")", 0, true
    End If
    If bPic = True Then
        objShell.Run chr(34) & syncToyExe & Chr(34) & _
        " -d(left=" & chr(34) & sPic & chr(34) & _
        ",right=" & chr(34) & strBackupPath & "Pictures" & chr(34) & _
        ",name=Pictures" & _
        ",operation=" & syncOperation & _
        ",excluded=*.jpg;*.jpeg;*.gif;*.bmp;*.png;*.mp3;*.m4a;*.mid;*.mpg;*.mpeg;*.divx;*.mov" & ")", 0, true
    End If
    If bVid = True Then
        objShell.Run chr(34) & syncToyExe & Chr(34) & _
        " -d(left=" & chr(34) & sVid & chr(34) & _
        ",right=" & chr(34) & strBackupPath & "Videos" & chr(34) & _
        ",name=Videos" & _
        ",operation=" & syncOperation & _
        ",excluded=*.jpg;*.jpeg;*.gif;*.bmp;*.png;*.mp3;*.m4a;*.mid;*.mpg;*.mpeg;*.divx;*.mov" & ")", 0, true
    End If

    Set objShell = Nothing

End Sub

Private Sub DeleteSyncToyPair(ByVal strPath, ByVal strPair)

    ' Detect if a Config File Exists in the leftFolder and try to Delete Folder Pair
    ' This will ensure all Left Folder Files Write to the Right Folder and Will Skip
    ' Duplicates.  Otherwise Files on the left will not write to the right if they are
    ' deleted from the right
    Dim objFSO: Set objFSO = CreateObject("Scripting.FileSystemObject")
    Dim objShell: Set objShell = CreateObject( "WScript.Shell" )
    Dim colFiles: Set colFiles = objFSO.GetFolder(strPath).Files
    Dim File, strErr
    For Each File in colFiles
        If InStr(1,File.Name,"SyncToy",1) > 0 AND StrComp(objFSO.GetExtensionName(File.Name),"dat",1) = 0 Then
            'SyncToy File Exists, Try to Delete Pair
            Call KillProcess("SyncToy.exe") 'Terminate SyncToy Processes Else a Delete Fails
            Call KillProcess("SyncToyCmd.exe")
            strErr = objShell.Run(chr(34) & syncToyExe & Chr(34) & " -u" & strPair, 0, false)
            'Cheap hack if it errors because the pair doesnt exist to kill the window
            Wscript.Sleep 10000
            Call KillProcess("SyncToy.exe")
            Call KillProcess("SyncToyCmd.exe")
        End If
    Next

    Set objFSO = Nothing
    Set objShell = Nothing

End Sub

Private Sub RunSyncToy(ByVal folderPair)

    ' Create Objects
    Dim objFSO: Set objFSO = CreateObject("Scripting.FileSystemObject")
    Dim objShell: Set objShell = CreateObject( "WScript.Shell" )

    ' Run SyncToy as Manual or Automated
    If blnAutoRun = False Then
        objShell.Run chr(34) & syncToyExe & chr(34)
    Else
        ' Set Path to SyncToyLog and Clear Log
        Dim syncToyLog: syncToyLog = ExpandEnv("%LOCALAPPDATA%\Microsoft\SyncToy\2.0\SyncToyLog.log")
        If InStr(1,syncToyLog,"%",1) > 0 Then
            syncToyLog = ExpandEnv("%USERPROFILE%\Local Settings\Application Data\Microsoft\SyncToy\2.0\SyncToyLog.log")
        End If
        If InStr(1,syncToyLog,"%",1) > 0 Then
            syncToyLog = "!~ERROR~!"
        End If
        If objFSO.FileExists(syncToyLog) Then
            Call Logger(syncToyLog, "", True)
        End If 

        ' Run Automated SyncToy Backup
        objShell.Run chr(34) & syncToyCmdExe & Chr(34) & " -R " & chr(34) & folderPair & chr(34), 1, true

        ' Parse SyncToyLog to Ensure It Successfully Ran
        Dim strError: strError = ""
        If objFSO.FileExists(syncToyLog) Then
            strError = ParseSyncToyLog(syncToyLog)
            If strError <> "" Then
                ' Error Detected in Sync
                objShell.Popup "An ERROR occurred backing up folder pair: " & folderPair & vbCrLf & _
                strError & vbCrLf & _
                "Please contact " & strContact _
                , 30, "ERROR Backing Up Files!", vbOkOnly + vbCritical
            End If
        Else
            ' Error Getting Log to Parse
            objShell.Popup "An ERROR occurred obtaining log file to check for errors after backing up folder pair: " & folderPair & vbCrLf & _
            "Please contact " & strContact _
            , 30, "ERROR Backing Up Files!", vbOkOnly + vbCritical
        End If

        'Copy SyncToy Log to Backup Path
        If objFSO.FIleExists(syncToyLog) Then
            objFSO.CopyFile syncToyLog, strBackupPath, True
        End If
    End If

    ' Cleanup
    Set objFSO = Nothing
    Set objShell = Nothing

End Sub

Private Function ParseSyncToyLog(ByVal strLog)

    Dim objFSO: Set objFSO = CreateObject("Scripting.FileSystemObject")
    Const ForReading = 1
    Dim objFile: Set objFile = objFSO.OpenTextFile(strLog, ForReading)
    Dim strLine
    Dim strResult: strResult = ""
    Dim blnAction: blnAction = True
    Dim blnWarning: blnWarning = False
    Dim blnError: blnError = False
    Do Until objFile.AtEndOfStream
        strLine = objFile.ReadLine
        If Len(strLine) > 0 Then
            ' Backup SyncToyLog for Archiving
            Call Logger(Replace(strLog,"SyncToyLog.log","SyncToyLog_Full.txt",1,1,1),strLine,False)

            ' Check If Actions Were Performed
            If InStr(1,strLine,"Found 0 actions to perform",1) > 0 Then
                blnAction = False
            End If

            ' Check If Warning Was Logged
            If InStr(1,strLine,"Warning:",1) > 0 Then
                blnWarning = True
                If strResult = "" Then
                    strResult = strLine
                Else
                    strResult = strResult & vbcrlf & strLine
                End If
            End If

            ' Check If Error Was Logged
            If InStr(1,strLine,"Error:",1) > 0 Then
                blnError = True
                If strResult = "" Then
                    strResult = strLine
                Else
                    strResult = strResult & vbcrlf & strLine
                End If
            End If
        End If
    Loop
    objFile.Close

    Set objFSO = Nothing

    ParseSyncToyLog = strResult

End Function

Private Sub KillProcess(ByVal strProcess)
    Dim strComputer: strComputer = "."
    Dim objWMIService: Set objWMIService = GetObject("winmgmts:\\" & strComputer & "\root\cimv2")
    Dim colItems: Set colItems = objWMIService.ExecQuery("Select * From Win32_Process")
    Dim objItem
    For Each objItem in colItems
        If StrComp(objItem.Name, strProcess, 1) = 0 Then
            objItem.Terminate()
        End If
    Next
End Sub

Private Function ExpandEnv(ByVal strPath)

    Dim objShell: Set objShell = CreateObject( "WScript.Shell" )
    ExpandEnv = objShell.ExpandEnvironmentStrings(strPath)
    Set objShell = Nothing

End Function

Private Sub Logger(fileName, logMessage, blnNewLog)

    Const ForReading = 1, ForWriting = 2, ForAppending = 8
    Dim objFSO: Set objFSO = CreateObject("Scripting.FileSystemObject")
    Dim scriptPath: scriptPath = Left(WScript.ScriptFullName,InstrRev(WScript.ScriptFullName,"\"))
    Dim logName
    If InStr(1,fileName,"\",1) > 0 Then
        logName = fileName
        If objFSO.DriveExists(objFSO.GetDriveName(logName)) Then
            If StrComp(objFSO.GetExtensionName(logName), "", 1) = 0 Then
                If Not objFSO.FolderExists(logName) Then
                    If objFSO.FolderExists(objFSO.GetParentFolderName(logName)) Then
                        objFSO.CreateFolder logName 'Create Folder In Current Path
                        Exit Sub
                    Else
                        Call Logger(objFSO.GetParentFolderName(logName), logMessage, blnNewLog) 'Recurse Creating Parent Folder
                        Call Logger(logName, logMessage, blnNewLog) 'Recurse Creating Current Folder
                        Exit Sub
                    End If
                End If
            Else
                If Not objFSO.FileExists(logName) Then
                    If Not objFSO.FolderExists(objFSO.GetParentFolderName(logName)) Then
                        Call Logger(objFSO.GetParentFolderName(logName), logMessage, blnNewLog)  'Recurse Creating Parent Folder
                        Call Logger(logName, logMessage, blnNewLog)  'Recurse Creating Current Folder
                    End If
                End If
            End If
        End If
    Else
        logName = scriptPath & fileName
    End If
    Dim logFile
    If blnNewLog = True Then
        Set logFile = objFSO.CreateTextFile(logName, True)
    Else
        If objFSO.FileExists(logName) Then
            Set logFile = objFSO.OpenTextFile(logName, ForAppending, True)
        Else
            Set logFile = objFSO.CreateTextFile(logName, True)
        End If
    End If
    logFile.WriteLine logMessage
    logFile.Close
    Set objFSO = Nothing

End Sub

Feb 09

ConvertOutlookContactsToAD.vbs

Posted on February 9, 2013 by admin

'=========================================================================
' ConvertOutlookContactsToAD.vbs
' VERSION: 1.0
' AUTHOR: Brian Steinmeyer
' EMAIL: sigkill@sigkillit.com
' WEB: http://sigkillit.com
' DATE: 2/9/2013
' REQUIREMENTS: Requires Exchange Tools or CDOEXM.DLL on the computer running
' the script to create Email enabled contacts. The script also uses OLEDB,
' which requires running it with %systemroot%\SysWow64\wscript.exe,
' %systemroot%\SysWow64\cscript.exe, or a 64-bit OLEDB Provider.
' COMMENTS: The script is designed to take an Outlook CSV(DOS) Exported list of
' contacts which is used to create AD contacts. However, not all attributes directly
' translate or have an equivelent. For example, AD only has attributes for a single
' address where Outlook contacts can have business, home, and other addresses. The
' strUserType variable was created to allow you to pick 1 of those 3 options to use
' on the import.
' To use the script export your Outlook contacts to a CSV(DOS) file. Then set the
' variables for the log file (Default is in the same directory as the script), the
' DN of the container you want to create the AD Contacts in, the location of the
' Outlook Exported Contacts CSV file, and the UserType(Business, Home, Other)
' EXAMPLE: Create Contacts with CSV file in the same folder as the script
'          Dim strLogFile: strLogFile = Replace(WScript.ScriptName,".vbs",".txt")
'          Dim contactsDN: contactsDN = "OU=Contacts, DC=domain, DC=com"
'          Dim contactsExport: contactsExport = "export.csv"
'          Dim strUserType: strUserType = "Business"
' EXAMPLE: Create Contacts Using the Home Address in the CSV
'          Dim strLogFile: strLogFile = Replace(WScript.ScriptName,".vbs",".txt")
'          Dim contactsDN: contactsDN = "OU=Contacts, DC=domain, DC=com"
'          Dim contactsExport: contactsExport = "export.csv"
'          Dim strUserType: strUserType = "Home"
' EXAMPLE: Create Contacts with CSV file in a different folder as the script
'          Dim strLogFile: strLogFile = Replace(WScript.ScriptName,".vbs",".txt")
'          Dim contactsDN: contactsDN = "OU=Contacts, DC=domain, DC=com"
'          Dim contactsExport: contactsExport = "C:\scripts\export.csv"
'          Dim strUserType: strUserType = "Business"
'=========================================================================
Option Explicit
' ------ START CONFIGURATION ------
Dim strLogFile: strLogFile = Replace(WScript.ScriptName,".vbs",".txt")
Dim contactsDN: contactsDN = "OU=Contacts, DC=domain, DC=com"
Dim contactsExport: contactsExport = "export.csv"
Dim strUserType: strUserType = "Business" 'Business, Home, Other
' ------ END CONFIGURATION ------

Call Logger(strLogFile, "USER:GENERAL, EMAIL, ORGANIZATION, ADDRESS, TELEPHONE", True)
Call CreateContacts(contactsExport, contactsDN, strUserType, strLogFile)
Wscript.Echo "Finished"

Private Sub CreateContacts(strContactsFile, strContactsDN, UserType, strLogFile)

    On Error Resume Next  'Start Error Handling

    'Ensure DN not ADS Path
    strContactsDN = Replace(strContactsDN,"LDAP://","",1,1,1)  

    'Grab Contacts With OLEDB - If Using a 64-bit OS you Must Use
    ' - C:\Windows\SysWow64\wscript.exe OR C:\Windows\SysWow64\cscript.exe
    ' - Alternatively, use a 64-bit OLEDB Provider (http://www.microsoft.com/en-us/download/details.aspx?id=20065)
    Dim objFSO: Set objFSO = CreateObject("Scripting.FileSystemObject")
    Dim objFile: Set objFile = objFSO.GetFile(strContactsFile)
    Const adOpenStatic = 3
    Const adLockOptimistic = 3
    Const adCmdText = &H0001
    Dim objConnection: Set objConnection = CreateObject("ADODB.Connection")
    Dim objRecordSet: Set objRecordSet = CreateObject("ADODB.Recordset")
    objConnection.Open "Provider=Microsoft.Jet.OLEDB.4.0;" & _
        "Data Source=" & objFile.ParentFolder & "\;" & _
        "Extended Properties=""text;HDR=YES;FMT=Delimited"""
    objRecordset.Open "SELECT * FROM [" & objFile.Name & "]", objConnection, adOpenStatic, adLockOptimistic, adCmdText
    If Err.Number <> 0 Then
        Err.Clear
        Call Logger(strLogFile, "Error Contacts File Is Already Opened, Quitting Script!", False)
    End If

    'Connect to AD and Get Contacts Container
    Const ADS_SCOPE_SUBTREE = 2
    Dim objConnection2: Set objConnection2 = CreateObject("ADODB.Connection")
    Dim objCommand: Set objCommand = CreateObject("ADODB.Command")
    objConnection2.Provider = "ADsDSOObject"
    objConnection2.Open "Active Directory Provider"
    Set objCommand.ActiveConnection = objConnection2
    objCommand.Properties("Page Size") = 1000   'Override the Return 1000 Results Default      
    objCommand.Properties("Searchscope") = ADS_SCOPE_SUBTREE    'Include Sub OU's
    objCommand.CommandText = "SELECT ADsPath FROM 'LDAP://" & strContactsDN & "'"
    Dim objRecordset2: Set objRecordSet2 = objCommand.Execute
    If Not objRecordSet2.RecordCount > 0 Then
        Call Logger(strLogFile, "Error Contacts Container Doesn't Exist, Quitting Script!", False)
        Exit Sub
    End If
    Dim objContainer: Set objContainer = GetObject(objRecordSet2.Fields("AdsPath").Value)
    Dim strResult
    Dim blnAttributeFound
    Dim objContact, cFName, cLName, cInitials, cOffice, cWebpage
    Dim cEmail, cEmailAlias
    Dim cJobTitle, cDepartment, cCompany
    Dim cStreet, cCity, cState, cZip, cCountry, cPOBox
    Dim cHomePhone, cOtherHomePhone, cPager, cMobile, cFax, cOtherFax, cIPPhone, cOtherIPPhone, cTelephone, cOtherTelephone, cNotes
    Do Until objRecordset.EOF
        'Set Contact CN
        strResult = objRecordset.Fields.Item("First Name") & " " & objRecordset.Fields.Item("Last Name") & ":"
        Set objContact = objContainer.Create("Contact","CN=" & objRecordset.Fields.Item("First Name") & " " & objRecordset.Fields.Item("Last Name"))

        'General Attributes (Telephone/Other Telephone Under Telephones Attributes and E-mail Under Email Attributes
        If Not IsNull(objRecordset.Fields.Item("First Name")) AND Not IsNull(objRecordset.Fields.Item("Last Name")) Then
            cFName = objRecordset.Fields.Item("First Name")
            cLName = objRecordset.Fields.Item("Last Name")
            objContact.Put "givenName", cFName
            objContact.Put "SN", cLName
            objContact.Put "displayname", cFName & " " & cLName
        Elseif Not IsNull(objRecordset.Fields.Item("First Name")) AND IsNull(objRecordset.Fields.Item("Last Name")) Then
            cFName = objRecordset.Fields.Item("First Name")
            objContact.Put "givenName", cFName
            objContact.Put "displayname", cFName
        Elseif IsNull(objRecordset.Fields.Item("First Name")) AND Not IsNull(objRecordset.Fields.Item("Last Name")) Then
            cLName = objRecordset.Fields.Item("Last Name")
            objContact.Put "SN", cLName
            objContact.Put "displayname", cLName           
        End If
        If Not IsNull(objRecordset.Fields.Item("Initials")) Then
            cInitials = objRecordset.Fields.Item("Initials")
            objContact.Put "initials", cInitials
        End If
        If Not IsNull(objRecordset.Fields.Item("Office Location")) Then
            cOffice = objRecordset.Fields.Item("Office Location")
            objContact.Put "physicalDeliveryOfficeName", cOffice
        End If
        If Not IsNull(objRecordset.Fields.Item("Web Page")) Then
            cWebpage = objRecordset.Fields.Item("Web Page")
            objContact.Put "wWWHomePage", cWebpage
        End If
        objContact.SetInfo
        If Err.Number <> 0 Then
            Err.Clear
            strResult = strResult & "ERROR,ERROR,ERROR,ERROR,ERROR"
        Else
            strResult = strResult & "SUCCESS,"

            'Email Attributes (Assumes First Email)
            blnAttributeFound = False
            If Not IsNull(objRecordset.Fields.Item("E-mail Address")) Then
                blnAttributeFound = True
                cEmail = objRecordset.Fields.Item("E-mail Address")
                objContact.Put "Mail", cEmail
                objContact.MailEnable cEmail
            End If
            If Not IsNull(objRecordset.Fields.Item("E-mail Display Name")) Then
                blnAttributeFound = True
                cEmailAlias = objRecordset.Fields.Item("E-mail Display Name")
                objContact.Put "mailNickname", cEmailAlias
                objContact.MailEnable cEmail
            End If
            If blnAttributeFound = True Then
                objContact.SetInfo
            End If
            If Err.Number <> 0 Then
                Err.Clear
                strResult = strResult & "ERROR,"
            Else
                strResult = strResult & "SUCCESS,"
            End If

            'Organization Attributes
            blnAttributeFound = False
            If Not IsNull(objRecordset.Fields.Item("Job Title")) Then
                blnAttributeFound = True
                cJobTitle = objRecordset.Fields.Item("Job Title")
                objContact.Put "title", cJobTitle
            End If
            If Not IsNull(objRecordset.Fields.Item("Department")) Then
                blnAttributeFound = True
                cDepartment = objRecordset.Fields.Item("Department")
                objContact.Put "department", cDepartment
            End If
            If Not IsNull(objRecordset.Fields.Item("Company")) Then
                blnAttributeFound = True
                cCompany = objRecordset.Fields.Item("Company")
                objContact.Put "company", cCompany
            End If
            If blnAttributeFound = True Then
                objContact.SetInfo
            End If
            If Err.Number <> 0 Then
                Err.Clear
                strResult = strResult & "ERROR,"
            Else
                strResult = strResult & "SUCCESS,"
            End If

            'Address Attributes (Add Variable to choose business, home, or other)
            blnAttributeFound = False
            Select Case UCase(UserType)
            Case "BUSINESS"
                If Not IsNull(objRecordset.Fields.Item("Business Street")) Then
                    blnAttributeFound = True
                    cStreet = objRecordset.Fields.Item("Business Street")
                    If Not IsNull(objRecordset.Fields.Item("Business Street 2")) Then
                        cStreet = cStreet & vbCrLf & objRecordset.Fields.Item("Business Street 2")
                    End If
                    If Not IsNull(objRecordset.Fields.Item("Business Street 3")) Then
                        cStreet = cStreet & vbCrLf & objRecordset.Fields.Item("Business Street 3")
                    End If
                    objContact.Put "streetAddress", cStreet
                End If
                If Not IsNull(objRecordset.Fields.Item("Business City")) Then
                    blnAttributeFound = True
                    cCity = objRecordset.Fields.Item("Business City")
                    objContact.Put "l", cCity
                End If
                If Not IsNull(objRecordset.Fields.Item("Business State")) Then
                    blnAttributeFound = True
                    cState = objRecordset.Fields.Item("Business State")
                    objContact.Put "st", cState
                End If
                If Not IsNull(objRecordset.Fields.Item("Business Postal Code")) Then
                    blnAttributeFound = True
                    cZip = objRecordset.Fields.Item("Business Postal Code")
                    objContact.Put "postalCode", cZip
                End If
                If Not IsNull(objRecordset.Fields.Item("Business Country/Region")) Then
                    blnAttributeFound = True
                    cCountry = objRecordset.Fields.Item("Business Country/Region")
                    objContact.Put "co", cCountry  'Note: use co to choose Country Name in ISO3166
                End If
                If Not IsNull(objRecordset.Fields.Item("Business Address PO Box")) Then
                    blnAttributeFound = True
                    cPOBox = objRecordset.Fields.Item("Business Address PO Box")
                    objContact.Put "postOfficeBox", cPOBox
                End If
            Case "HOME"
                If Not IsNull(objRecordset.Fields.Item("Home Street")) Then
                    blnAttributeFound = True
                    cStreet = objRecordset.Fields.Item("Home Street")
                    If Not IsNull(objRecordset.Fields.Item("Home Street 2")) Then
                        cStreet = cStreet & vbCrLf & objRecordset.Fields.Item("Home Street 2")
                    End If
                    If Not IsNull(objRecordset.Fields.Item("Home Street 3")) Then
                        cStreet = cStreet & vbCrLf & objRecordset.Fields.Item("Home Street 3")
                    End If
                    objContact.Put "streetAddress", cStreet
                End If
                If Not IsNull(objRecordset.Fields.Item("Home City")) Then
                    blnAttributeFound = True
                    cCity = objRecordset.Fields.Item("Home City")
                    objContact.Put "l", cCity
                End If
                If Not IsNull(objRecordset.Fields.Item("Home State")) Then
                    blnAttributeFound = True
                    cState = objRecordset.Fields.Item("Home State")
                    objContact.Put "st", cState
                End If
                If Not IsNull(objRecordset.Fields.Item("Home Postal Code")) Then
                    blnAttributeFound = True
                    cZip = objRecordset.Fields.Item("Home Postal Code")
                    objContact.Put "postalCode", cZip
                End If
                If Not IsNull(objRecordset.Fields.Item("Home Country/Region")) Then
                    blnAttributeFound = True
                    cCountry = objRecordset.Fields.Item("Home Country/Region")
                    objContact.Put "co", cCountry  'Note: use co to choose Country Name in ISO3166
                End If
                If Not IsNull(objRecordset.Fields.Item("Home Address PO Box")) Then
                    blnAttributeFound = True
                    cPOBox = objRecordset.Fields.Item("Home Address PO Box")
                    objContact.Put "postOfficeBox", cPOBox
                End If
            Case "OTHER"
                If Not IsNull(objRecordset.Fields.Item("Other Street")) Then
                    blnAttributeFound = True
                    cStreet = objRecordset.Fields.Item("Other Street")
                    If Not IsNull(objRecordset.Fields.Item("Other Street 2")) Then
                        cStreet = cStreet & vbCrLf & objRecordset.Fields.Item("Other Street 2")
                    End If
                    If Not IsNull(objRecordset.Fields.Item("Other Street 3")) Then
                        cStreet = cStreet & vbCrLf & objRecordset.Fields.Item("Other Street 3")
                    End If
                    objContact.Put "streetAddress", cStreet
                End If
                If Not IsNull(objRecordset.Fields.Item("Other City")) Then
                    blnAttributeFound = True
                    cCity = objRecordset.Fields.Item("Other City")
                    objContact.Put "l", cCity
                End If
                If Not IsNull(objRecordset.Fields.Item("Other State")) Then
                    blnAttributeFound = True
                    cState = objRecordset.Fields.Item("Other State")
                    objContact.Put "st", cState
                End If
                If Not IsNull(objRecordset.Fields.Item("Other Postal Code")) Then
                    blnAttributeFound = True
                    cZip = objRecordset.Fields.Item("Other Postal Code")
                    objContact.Put "postalCode", cZip
                End If
                If Not IsNull(objRecordset.Fields.Item("Other Country/Region")) Then
                    blnAttributeFound = True
                    cCountry = objRecordset.Fields.Item("Other Country/Region")
                    objContact.Put "co", cCountry  'Note: use co to choose Country Name in ISO3166
                End If
                If Not IsNull(objRecordset.Fields.Item("Other Address PO Box")) Then
                    blnAttributeFound = True
                    cPOBox = objRecordset.Fields.Item("Other Address PO Box")
                    objContact.Put "postOfficeBox", cPOBox
                End If
            End Select
            If blnAttributeFound = True Then
                objContact.SetInfo
            End If
            If Err.Number <> 0 Then
                Err.Clear
                strResult = strResult & "ERROR,"
            Else
                strResult = strResult & "SUCCESS,"
            End If

            'Telephone Attributes (Add Variable to choose business, home or other)
            blnAttributeFound = False
            If Not IsNull(objRecordset.Fields.Item("Home Phone")) Then
                blnAttributeFound = True
                cHomePhone = objRecordset.Fields.Item("Home Phone")
                objContact.Put "homePhone", cHomePhone
            End If
            If Not IsNull(objRecordset.Fields.Item("Home Phone 2")) Then
                blnAttributeFound = True
                cOtherHomePhone = objRecordset.Fields.Item("Home Phone 2")
                objContact.PutEx 3, "otherHomePhone", Array(cOtherHomePhone)
            End If
            If Not IsNull(objRecordset.Fields.Item("Pager")) Then
                blnAttributeFound = True
                cPager = objRecordset.Fields.Item("Pager")
                objContact.Put "pager", cPager
            End If
            If Not IsNull(objRecordset.Fields.Item("Mobile Phone")) Then
                blnAttributeFound = True
                cMobile = objRecordset.Fields.Item("Mobile Phone")
                objContact.Put "mobile", cMobile
            End If
            If Not IsNull(objRecordset.Fields.Item("Business Fax")) Then
                blnAttributeFound = True
                cFax = objRecordset.Fields.Item("Business Fax")
                objContact.Put "facsimileTelephoneNumber", cFax
            End If
            If Not IsNull(objRecordset.Fields.Item("Home Fax")) Then
                blnAttributeFound = True
                cOtherFax = objRecordset.Fields.Item("Home Fax")
                objContact.PutEx 3, "otherFacsimileTelephoneNumber", Array(cOtherFax)
            End If
            If Not IsNull(objRecordset.Fields.Item("Other Fax")) Then
                blnAttributeFound = True
                cOtherFax = objRecordset.Fields.Item("Other Fax")
                objContact.PutEx 3, "otherFacsimileTelephoneNumber", Array(cOtherFax)
            End If
            If Not IsNull(objRecordset.Fields.Item("Business Phone")) Then
                blnAttributeFound = True
                cIPPhone = objRecordset.Fields.Item("Business Phone")
                objContact.Put "ipPhone", cIPPhone
            End If
            If Not IsNull(objRecordset.Fields.Item("Business Phone 2")) Then
                blnAttributeFound = True
                cOtherIPPhone = objRecordset.Fields.Item("Business Phone 2")
                objContact.PutEx 3, "otherIpPhone", Array(cOtherIPPhone)
            End If
            If Not IsNull(objRecordset.Fields.Item("Company Main Phone")) Then
                blnAttributeFound = True
                cOtherIPPhone = objRecordset.Fields.Item("Company Main Phone")
                objContact.PutEx 3, "otherIpPhone", Array(cOtherIPPhone)
            End If
            If Not IsNull(objRecordset.Fields.Item("Primary Phone")) Then
                blnAttributeFound = True
                cTelephone = objRecordset.Fields.Item("Primary Phone")
                objContact.Put "telephoneNumber", cTelephone
            End If
            If Not IsNull(objRecordset.Fields.Item("Other Phone")) Then
                blnAttributeFound = True
                cOtherTelephone = objRecordset.Fields.Item("Other Phone")
                objContact.Put "otherTelephone", cOtherTelephone
            End If
            If Not IsNull(objRecordset.Fields.Item("Notes")) Then
                blnAttributeFound = True
                cNotes = objRecordset.Fields.Item("Notes")
                objContact.Put "info", cNotes
            End If
            If blnAttributeFound = True Then
                objContact.SetInfo
            End If
            If Err.Number <> 0 Then
                Err.Clear
                strResult = strResult & "ERROR"
            Else
                strResult = strResult & "SUCCESS"
            End If
        End If

        'Log Results
        Call Logger(strLogFile, strResult, False)      
        objRecordset.MoveNext
    Loop

    objRecordset.Close
    objRecordset2.Close

    On Error Goto 0  'End Error Handling

End Sub

Private Sub Logger(fileName, logMessage, blnNewLog)

    On Error Resume Next

    Const ForReading = 1, ForWriting = 2, ForAppending = 8
    Dim objFSO: Set objFSO = CreateObject("Scripting.FileSystemObject")
    Dim scriptPath: scriptPath = Left(WScript.ScriptFullName,InstrRev(WScript.ScriptFullName,"\"))
    Dim logName
    If InStr(1,fileName,"\",1) > 0 Then
        logName = fileName
        If objFSO.DriveExists(objFSO.GetDriveName(logName)) Then
            If StrComp(objFSO.GetExtensionName(logName), "", 1) = 0 Then
                If Not objFSO.FolderExists(logName) Then
                    If objFSO.FolderExists(objFSO.GetParentFolderName(logName)) Then
                        objFSO.CreateFolder logName 'Create Folder In Current Path
                        Exit Sub
                    Else
                        Call Logger(objFSO.GetParentFolderName(logName), logMessage, blnNewLog) 'Recurse Creating Parent Folder
                        Call Logger(logName, logMessage, blnNewLog) 'Recurse Creating Current Folder
                        Exit Sub
                    End If
                End If
            Else
                If Not objFSO.FileExists(logName) Then
                    If Not objFSO.FolderExists(objFSO.GetParentFolderName(logName)) Then
                        Call Logger(objFSO.GetParentFolderName(logName), logMessage, blnNewLog)  'Recurse Creating Parent Folder
                        Call Logger(logName, logMessage, blnNewLog)  'Recurse Creating Current Folder
                    End If
                End If
            End If
        End If
    Else
        logName = scriptPath & fileName
    End If
    Dim logFile
    If blnNewLog = True Then
        Set logFile = objFSO.CreateTextFile(logName, True)
    Else
        If objFSO.FileExists(logName) Then
            Set logFile = objFSO.OpenTextFile(logName, ForAppending, True)
        Else
            Set logFile = objFSO.CreateTextFile(logName, True)
        End If
    End If
    logFile.WriteLine logMessage
    logFile.Close
    Set objFSO = Nothing

    On Error Goto 0

End Sub

Jan 26

Running VBScripts with UAC Elevation

Posted on January 26, 2013 by admin

Overview

Since the introduction of User Account Control (UAC), scripts do not run with administrator privileges despite being a local administrator. You must elevate your script to run with administrator privileges. I’ll start by showing you a simple example. The script below will list all of the processes on the local computer as well as the WIN32_Process CommandLine property. If you run the script on a computer with UAC without elevating it, you will only see CommandLine values for processes created by your account; if any other processes were created by another account, the CommandLine property will be NULL.

strComputer = "."
Set objWMIService = GetObject("winmgmts:\\" & strComputer & "\root\CIMV2")
Set colItems = objWMIService.ExecQuery("SELECT * FROM Win32_Process",,48)
For Each objItem in colItems
Wscript.Echo "Process: " & objItem.Name & vbCrLf & _
"Startup: " & objItem.CommandLine
Next

On a test machine, I was logged on as User1, opened notepad, and launched a vbscript as the local administrator account using RunAs. I ran the script above and compared the results to task manager with the following results:

As you can see, the script successfully showed the CommandLine property for the currently logged on user

However, the test script failed to show the CommandLine property for the wscript.exe process running as administrator:

By re-running the test script with elevated privileges, the script now successfully shows the CommandLine property for the wscript process running as Administrator.

Now that I have successfully demonstrated the need to run a script elevated on a local machine, you might be wondering what happens when you the test script on a remote machine. If you run the script on a remote machine that you have administrator rights on, it will successfully display the CommandLine property for all users. Now, you might be confused as to why it works remotely? The answer is quite simple, the script is elevated by RPC. Now that you have a good understanding of running vbscripts with UAC elevation, here are some methods on how to elevate them.

Method 1 – Elevating Using the Command Prompt

Click Start, All Programs, Click Accessories
Right-click Command Prompt and click Run as administrator
Click Yes
Any script you launch using wscript.exe or cscript.exe will launch elevated

Method 2 – RunAs Script

This method uses a wrapper script to run an elevated VBScript using the runas verb with the ShellExecute method of Shell.Application. When it launches the elevated script, click Yes

http://sigkillit.com/2013/01/25/elevatewscript-vbs/

Method 3 – Add ‘Run as administrator’ to the .vbs File Context Menu

The ‘Run as administrator’ option on a File Context Menu is only available on certain file types by default, and .vbs files are not one of them. However, by doing a quick registry modification we can enable the ‘Run as administrator’ option o the file context menu. Download and run the following registry to merge it into your registry, or you can copy the below text and save it to a .reg file:

Add Run as administrator to VBS File Context Menu

Windows Registry Editor Version 5.00

[HKEY_LOCAL_MACHINE\SOFTWARE\Classes\VBSFile\Shell\runas]
"HasLUAShield"=""

[HKEY_LOCAL_MACHINE\SOFTWARE\Classes\VBSFile\Shell\runas\Command]
@=hex(2):22,00,25,00,53,00,79,00,73,00,74,00,65,00,6d,00,52,00,6f,00,6f,00,74,\
00,25,00,5c,00,53,00,79,00,73,00,74,00,65,00,6d,00,33,00,32,00,5c,00,57,00,\
53,00,63,00,72,00,69,00,70,00,74,00,2e,00,65,00,78,00,65,00,22,00,20,00,22,\
00,25,00,31,00,22,00,20,00,25,00,2a,00,00,00

Jan 25

ElevateWscript.vbs

Posted on January 25, 2013 by admin

'=========================================================================
' ElevateWscript.vbs
' VERSION: 1.0
' AUTHOR: Brian Steinmeyer
' EMAIL: sigkill@sigkillit.com
' WEB: http://sigkillit.com
' DATE: 1/25/2012
' COMPATIBLE: Windows Vista, Server 2008, and Above
' COMMENTS: Since the introduction of UAC in Windows, despite being an
' administrator you may still need to run a script with elevated
' privileges. For example the CommandLine property of the WIN32_Process class
' requires a script to be elevated in order to return valid data when the process
' is running as another user. Unfortunately, Windows does not provide Run As
' Administrator on the context of a .vbs file, which is why I made this.
' To use the script, pass the full path to a .vbs file to the Sub and it
' will prompt you to run the script elevated. If the script you need to elevate
' in located in the same directory as this script, you can just pass the script
' name. Alternatively, you can always launch your vbscript from an elevated
' command prompt which will use wscript or cscript elevated as well.
' EXAMPLE: Elevate a script using the full path
'          Call ElevateWscript("C:\scripts\test.vbs")
' EXAMPLE: Elevate a script in the same directory as ElevateWscript.vbs
'          Call ElevateWscript("test.vbs")
'=========================================================================
Option Explicit
Call ElevateWscript("test.vbs")

Private Sub ElevateWscript(scriptName)
    Dim objShell: Set objShell = CreateObject("Shell.Application")
    Dim objFSO: Set objFSO = CreateObject("Scripting.FileSystemObject")
    If objFSO.FileExists(scriptName) Then
        Dim objFile: Set objFile = objFSO.GetFile(scriptName)
         objShell.ShellExecute "wscript.exe", Chr(34) & objFile.Path & Chr(34), "", "runas", 1
    Else
         Wscript.Echo "Script Does Not Exist!" & vbCrLf & scriptName
    End If
End Sub

Jan 22

ComputerInventory.vbs

Posted on January 22, 2013 by admin

'=========================================================================
' ComputerInventory.vbs
' VERSION: 1.0
' AUTHOR: Brian Steinmeyer
' EMAIL: sigkill@sigkillit.com
' WEB: http://sigkillit.com
' DATE: 1/21/2013
' COMPATIBLE: Windows XP+, Server 2003+. If you are using on Windows 2003,
'  to get correct CPU Physical and Core Counts make sure you have the following
'  hotfix installed: http://support.microsoft.com/kb/932370
' COMMENTS: Loops through a line delineated list of servers and reports back
'  the Manufacturer, Model #, Serial #, Windows OS, OS Architecture (32vs64),
'  RAM(MB), CPU Description, CPU Speed(GHz), CPU Physical Count, CPU Core Count,
'  Local Volumes with Total and Used Space in GB.
'  Edit the configuration to point to a text file containing the names of
'  the computers to inventory. By default, it will search the same directory
'  of the script, otherwise you can provide the full path. Also, set the max
'  number of Disk Volumes you want to return. By default, this is set to 5 but,
'  you may need to increase this number if your computers use a lot of volumes.
' EXAMPLE: Inventory Servers.txt in the Current Directory with a max of 5 volumes
'  Dim computerList: computerList = "servers.txt"
'  Dim maxVolumes: maxVolumes = 5
' EXAMPLE: Inventory Servers.txt using a full path with a max of 8 volumes
'  Dim computerList: computerList = "C:\servers.txt"
'  Dim maxVolumes: maxVolumes = 8
'=========================================================================
Option Explicit
' ------ SCRIPT CONFIGURATION ------
Dim computerList: computerList = "servers.txt"
Dim maxVolumes: maxVolumes = 5
' ------ END CONFIGURATION ------

'Ensure Computer List Exists
Dim objFSO: Set objFSO = CreateObject("Scripting.FileSystemObject")
If Not objFSO.FileExists(computerList) Then
    Wscript.Echo "ERROR - Input File Does Not Exist!" & vbCrLf & vbCrLf & "Quitting Script!"
    Wscript.Quit
End If

'Create Log File
Dim strLogFile: strLogFile = Replace(Wscript.ScriptName, ".vbs", ".txt")
Dim strHeadings: strHeadings = "COMPUTER" & vbTab & _
    "MAKE" & vbTab & _
    "MODEL" & vbTab & _
    "SERIAL" & vbTab & _
    "OS" & vbTab & _
    "ARCHITECTURE" & vbTab & _
    "RAM(MB)" & vbTab & _
    "CPU" & vbTab & _
    "SPEED(GHz)" & vbTab & _
    "PHYSICAL" & vbTab & _
    "CORE"
Dim i
Dim strVolumes: strVolumes = ""
If maxVolumes > 0 Then
    For i = 1 to maxVolumes
        strVolumes = strVolumes & vbTab & "HDD(Used/Total)"
    Next
Else
    'Default to Single Volume If an Invalid # Was Assigned
    maxVolumes = 1
End If
strHeadings = strHeadings & strVolumes
Call Logger(strLogFile, strHeadings, True)

'Get Server Info
Const ForReading = 1
Dim objTextFile: Set objTextFile = objFSO.OpenTextFile(computerList, ForReading)
Dim strComp, strManufacturer, strModel, strSerial, strOS, strOSArchitecture, strRAM, strProcessor, strVolume, strTemp
Do Until objTextFile.AtEndOfStream
    strComp = Trim(objTextFile.Readline)
    If strComp <> "" Then
        If ServerUpTime(strComp) = "!~ERROR~!" Then
            strTemp = strComp & "(Offline)" & vbTab & _
                "!~ERROR~!" & vbTab & _
                "!~ERROR~!" & vbTab & _
                "!~ERROR~!" & vbTab & _
                "!~ERROR~!" & vbTab & _
                "!~ERROR~!" & vbTab & _
                "!~ERROR~!" & vbTab & _
                "!~ERROR~!" & vbTab & _
                "!~ERROR~!" & vbTab & _
                "!~ERROR~!" & vbTab & _
                "!~ERROR~!" & Replace(strVolumes, "HDD(Used/Total)", "!~ERROR~!")
            Call Logger(strLogFile, strTemp, False)
        Else   
            strManufacturer = GetManufacturer(strComp)
            strModel = GetModel(strComp)
            strSerial = GetSerial(strComp)
            strOS = GetOS(strComp)
            strOSArchitecture = GetOSArchitecture(strComp)
            strRAM = GetRAM(strComp)
            strProcessor = GetProcessor(strComp)
            strVolume = GetVolume(strComp, maxVolumes)
            Call Logger(strLogFile, strComp & vbTab & strManufacturer & vbTab & strModel & vbTab & strSerial & vbTab & strOS & vbTab & strOSArchitecture & vbTab & strRAM & vbTab & strProcessor & vbTab & strVolume, False)
        End If
    End If
Loop           
Wscript.Echo "Finished"

Private Function ServerUpTime(strComputer)

    On Error Resume Next

    Dim objWMISettings: Set objWMISettings = GetObject("winmgmts:\\" & strComputer & "\root\cimv2")
    Dim colItems: Set colItems = objWMISettings.ExecQuery("Select * from Win32_OperatingSystem")
    Dim strResult
    Dim objItem, dtmBootup, dtmLastBootupTime, dtmSystemUptime
    For Each objItem in colItems
        dtmBootup = objItem.LastBootUpTime
        dtmLastBootupTime = CDate(Mid(dtmBootup, 5, 2) & "/" & Mid(dtmBootup, 7, 2) & "/" & Left(dtmBootup, 4) & " " & Mid (dtmBootup, 9, 2) & ":" & Mid(dtmBootup, 11, 2) & ":" & Mid(dtmBootup, 13, 2))
        dtmSystemUptime = DateDiff("h", dtmLastBootUpTime, Now)
    Next

    'Return Results
    If Err.Number <> 0 Then
        Err.Clear
        strResult = "!~ERROR~!"
    Else
        strResult = dtmSystemUptime
    End If 
    ServerUpTime = strResult

    'Kill Objects
    Set objWMISettings = Nothing

    On Error GoTo 0  ' End Error Handling

End Function

Private Function GetManufacturer(strComputer)

    On Error Resume Next

    Dim objWMIService: Set objWMIService = GetObject("winmgmts:\\" & strComputer & "\root\cimv2")
    Dim colItems: Set colItems = objWMIService.ExecQuery("Select * from Win32_ComputerSystem")
    Dim strResult
    Dim objItem
    For Each objItem in colItems
        strResult = Trim(objItem.Manufacturer)
    Next

    'Return Results
    If Err.Number <> 0 Then
        Err.Clear
        strResult = "!~ERROR~!"
    End If
    GetManufacturer = strResult

    'Kill Objects
    Set objWMIService = Nothing

    On Error Goto 0

End Function

Private Function GetModel(strComputer)

    On Error Resume Next

    Dim objWMIService: Set objWMIService = GetObject("winmgmts:\\" & strComputer & "\root\cimv2")
    Dim colItems: Set colItems = objWMIService.ExecQuery("Select * from Win32_ComputerSystem")
    Dim strResult
    Dim objItem
    For Each objItem in colItems
        strResult = Trim(objItem.Model)
    Next

    'Return Results
    If Err.Number <> 0 Then
        Err.Clear
        strResult = "!~ERROR~!"
    End If
    GetModel = strResult

    'Kill Objects
    Set objWMIService = Nothing

    On Error Goto 0

End Function

Private Function GetSerial(strComputer)

    On Error Resume Next

    Dim objWMIService: Set objWMIService = GetObject("winmgmts:\\" & strComputer & "\root\cimv2")
    Dim colItems: Set colItems = objWMIService.ExecQuery("Select * from Win32_BIOS")
    Dim strResult
    Dim objItem
    For Each objItem in colItems
        strResult = Trim(objItem.SerialNumber)
    Next

    'Return Results
    If Err.Number <> 0 Then
        Err.Clear
        strResult = "!~ERROR~!"
    End If
    GetSerial = strResult

    'Kill Objects
    Set objWMIService = Nothing

    On Error Goto 0

End Function

Private Function GetOS(strComputer)

    On Error Resume Next

    Dim objWMIService: Set objWMIService = GetObject("winmgmts:\\" & strComputer & "\root\cimv2")
    Dim colItems: Set colItems = objWMIService.ExecQuery("Select * from Win32_OperatingSystem")
    Dim strResult
    Dim objItem
    For Each objItem in colItems
        strResult = Trim(objItem.Caption)
    Next

    'Return Results
    If Err.Number <> 0 Then
        Err.Clear
        strResult = "!~ERROR~!"
    End If
    GetOS = strResult

    'Kill Objects
    Set objWMIService = Nothing

    On Error Goto 0

End Function

Private Function GetOSArchitecture(strComputer)

    On Error Resume Next

    Dim objWMIService: Set objWMIService = GetObject("winmgmts:{impersonationLevel=impersonate,authenticationLevel=Pkt}!\\" & strComputer & "\root\cimv2")
    Dim colItems: Set colItems = objWMIService.ExecQuery("SELECT * FROM Win32_Processor")
    Dim strResult
    Dim objItem
    For Each objItem In colItems
        Select Case objItem.Architecture
            Case 0
                strResult = "32-bit"
            Case 9
                strResult = "64-bit"           
        End Select
    Next

    'Return Results
    If Err.Number <> 0 Then
        Err.Clear
        strResult = "!~ERROR~!"
    End If 
    GetOSArchitecture = strResult

    'Kill Ovjects
    Set objWMIService = Nothing

    On Error Goto 0

End Function

Private Function GetRAM(strComputer)

    On Error Resume Next

    Dim objWMIService: Set objWMIService = GetObject("winmgmts:\\" & strComputer & "\root\cimv2")
    Dim colItems: Set colItems = objWMIService.ExecQuery("Select * from Win32_ComputerSystem")
    Dim strResult
    Dim objItem
    For Each objItem in colItems
        strResult = Round(objItem.TotalPhysicalMemory/1024/1024,0)
    Next

    'Return Results
    If Err.Number <> 0 Then
        Err.Clear
        strResult = "!~ERROR~!"
    End If 
    GetRAM = strResult

    'Kill Objects
    Set objWMIService = Nothing

    On Error Goto 0

End Function

Private Function GetProcessor(strComputer)

    'If Using Server 2003 Install the Following Hotfix to Get Correct Physical and Core CPU Counts
    'http://support.microsoft.com/kb/932370

    On Error Resume Next

    Dim objWMIService: Set objWMIService = GetObject("winmgmts:\\" & strComputer & "\root\CIMV2")
    Dim colItems: Set colItems = objWMIService.ExecQuery("SELECT * FROM Win32_Processor")
    Dim strResult
    Dim objItem
    Dim strCPU: strCPU = ""
    Dim strSpeed: strSpeed = ""
    Dim intPhysical: intPhysical = 0
    Dim intCores: intCores = 0
    For Each objItem in colItems
        strCPU = objItem.Description
        strSpeed = Round(objItem.CurrentClockSpeed/1000,2)
        intPhysical = colItems.Count
        intCores = objItem.NumberOfCores
    Next

    'Return Results
    If Err.Number <> 0 Then
        Err.clear
        strResult = "!~ERROR~!" & vbTab & "!~ERROR~!" & vbTab & "!~ERROR~!" & vbTab & "!~ERROR~!"
    Else
        strResult = strCPU & vbTab & strSpeed & vbTab & intPhysical & vbTab & intCores
    End If     
    GetProcessor = strResult

    'Kill Objects
    Set objWMIService = Nothing

    On Error Goto 0

End Function

Private Function GetVolume(strComputer, maxVolCount)

    On Error Resume Next

    Dim objWMIService: Set objWMIService = GetObject("winmgmts:{impersonationLevel=impersonate}!\\" & strComputer & "\root\cimv2")
    Dim colItems: Set colItems = objWMIService.ExecQuery("Select * from Win32_LogicalDisk WHERE DriveType='3'")
    Dim strResult: strResult = ""
    Dim objItem, totalSpace, usedSpace
    Dim i: i = 0
    For Each objItem in colItems
        totalSpace = FormatNumber(objItem.Size/1024/1024/1024)
        usedSpace = FormatNumber((objItem.Size - objItem.FreeSpace)/1024/1024/1024)
        i = i + 1
        If i = 1 Then
            strResult = objItem.DeviceID & "(" & usedSpace & "/" & totalSpace & ")"
        Elseif i > maxVolCount Then
            'Skip
        Else
            strResult = strResult & vbTab & objItem.DeviceID & "(" & usedSpace & "/" & totalSpace & ")"
        End If
    Next
    If colItems.Count < maxVolCount Then
        For i = 1 to maxVolCount - colItems.Count
            strResult = strResult & vbTab & "N/A"
        Next
    End If

    'Return Results
    If Err.Number <> 0 Then
        Err.Clear
        If maxVolCount > 0 Then
            For i = 1 to maxVolCount
                If i = 1 Then
                    strResult = "!~ERROR~!"
                Else
                    strResult = strResult & vbTab & "!~ERROR~!"
                End If
            Next
        Else
            strResult = "!~ERROR~!"
        End If
    End If 
    GetVolume = strResult

    'Kill Objects
    Set objWMIService = Nothing

    On Error Goto 0

End Function

Private Sub Logger(fileName, logMessage, blnNewLog)

    On Error Resume Next

    Const ForReading = 1, ForWriting = 2, ForAppending = 8
    Dim objFSO: Set objFSO = CreateObject("Scripting.FileSystemObject")
    Dim scriptPath: scriptPath = Left(WScript.ScriptFullName,InstrRev(WScript.ScriptFullName,"\"))
    Dim logName
    If InStr(1,fileName,"\",1) > 0 Then
        logName = fileName
        If objFSO.DriveExists(objFSO.GetDriveName(logName)) Then
            If StrComp(objFSO.GetExtensionName(logName), "", 1) = 0 Then
                If Not objFSO.FolderExists(logName) Then
                    If objFSO.FolderExists(objFSO.GetParentFolderName(logName)) Then
                        objFSO.CreateFolder logName 'Create Folder In Current Path
                        Exit Sub
                    Else
                        Call Logger(objFSO.GetParentFolderName(logName), logMessage, blnNewLog) 'Recurse Creating Parent Folder
                        Call Logger(logName, logMessage, blnNewLog) 'Recurse Creating Current Folder
                        Exit Sub
                    End If
                End If
            Else
                If Not objFSO.FileExists(logName) Then
                    If Not objFSO.FolderExists(objFSO.GetParentFolderName(logName)) Then
                        Call Logger(objFSO.GetParentFolderName(logName), logMessage, blnNewLog)  'Recurse Creating Parent Folder
                        Call Logger(logName, logMessage, blnNewLog)  'Recurse Creating Current Folder
                    End If
                End If
            End If
        End If
    Else
        logName = scriptPath & fileName
    End If
    Dim logFile
    If blnNewLog = True Then
        Set logFile = objFSO.CreateTextFile(logName, True)
    Else
        If objFSO.FileExists(logName) Then
            Set logFile = objFSO.OpenTextFile(logName, ForAppending, True)
        Else
            Set logFile = objFSO.CreateTextFile(logName, True)
        End If
    End If
    logFile.WriteLine logMessage
    logFile.Close
    Set objFSO = Nothing

    On Error Goto 0

End Sub

Jan 18

PingHost.vbs

Posted on January 18, 2013 by admin

'=========================================================================
' PingHost.vbs
' VERSION: 1.0
' AUTHOR: Brian Steinmeyer
' EMAIL: sigkill@sigkillit.com
' WEB: http://sigkillit.com
' DATE: 1/17/2013
' COMMENTS: Pass a hostname or IP to the function and the number of times
' you wish to ping the host/IP, and it will return whether it is succesful
' or not.
' EXAMPLE: Ping by Hostname
' Dim strHost: strHost = "Server"
' Dim intCount: intCount = 4
' EXAMPLE: Ping by IP
' Dim strHost: strHost = "192.168.1.1"
' Dim intCount: intCount = 4
'=========================================================================
Option Explicit
' ------ SCRIPT CONFIGURATION ------
Dim strHost: strHost = "Server"
Dim intCount: intCount = 4
' ------ END CONFIGURATION ------

Wscript.Echo PingHost(strHost, intCount)

Private Function PingHost(strHostOrIP, count)

	On Error Resume Next ' Start Error Handling

	'Set Variables
	Dim objPing, objRetStatus, i, strResult: strResult = ""

	For i = 1 to count
		Set objPing = GetObject("winmgmts:{impersonationLevel=impersonate}").ExecQuery("select * from Win32_PingStatus where address = '" & strHostOrIP & "'")
		For Each objRetStatus in objPing
			If IsNull(objRetStatus.StatusCode) or objRetStatus.StatusCode<>0 Then
				strResult = "!~ERROR~!" & objRetStatus.StatusCode
				'WScript.Echo "Status code is " & objRetStatus.StatusCode
			Else
				strResult = "OK"
				'Wscript.Echo "Bytes = " & vbTab & objRetStatus.BufferSize
				'Wscript.Echo "Time (ms) = " & vbTab & objRetStatus.ResponseTime
				'Wscript.Echo "TTL (s) = " & vbTab & objRetStatus.ResponseTimeToLive
			End If
		Next

		' Error Check
		If Err.Number <> 0 Then
		strResult = "!~ERROR~!"
		End If

		'Check For Success
		If strResult = "OK" Then
			Exit For
		End If
		count = count -1
	Next

	'Return Result
	PingHost = strResult

	On Error GoTo 0 ' End Error Handling

End Function

Jan 18

CheckHTTPStatus.vbs

Posted on January 18, 2013 by admin

'=========================================================================
' CheckHTTPStatus.vbs
' VERSION: 1.0
' AUTHOR: Brian Steinmeyer
' EMAIL: sigkill@sigkillit.com
' WEB: http://sigkillit.com
' DATE: 1/17/2013
' COMMENTS: Pass the URL and optionally a username/password to the Function
' and it will check the HTTP return status code.
' EXAMPLE: Check If Website is Running
'          Dim strURL: strURL = "http://www.domain.com"
'          Dim strUsername: strUsername = ""
'          Dim strPassword: strPassword = ""
'=========================================================================
Option Explicit
' ------ SCRIPT CONFIGURATION ------
Dim strURL: strURL = "http://www.domain.com"
Dim strUsername: strUsername = ""
Dim strPassword: strPassword = ""
' ------ END CONFIGURATION ------

Wscript.Echo CheckHTTPStatus(strURL, strUsername, strPassword)

Function CheckHTTPStatus(url, uname, password)

    On Error Resume Next  ' Start Error Handling

    Dim strResult
    ' Create Objects
    'Dim objHTTP: Set objHTTP = createobject("msxml2.xmlhttp")
    Dim objHTTP: Set objHTTP = WScript.CreateObject("MSXML2.ServerXMLHTTP.6.0")
    objHTTP.SetOption 2, 13056  ' Ignore all SSL errors

    ' Open Web Page
    objHTTP.open "GET", url, false, uname, password
    objHTTP.send

    ' Error Check and Get Results
    If Err.Number <> 0 Then
        strResult = "!~ERROR~!"
        If isnull(objHttp.Status) Then
            strResult = strResult & "UNKNOWN_STATUS"
        Else
            strResult = strResult & objHTTP.Status & " " & objHTTP.StatusText
        End If
    Else
        If isnull(objHTTP.status) Then
            strResult = "!~ERROR~!UNKNOWN_STATUS"
        Else
            If objHTTP.status < 200 or objHTTP.status >= 300 Then
                strResult = "!~ERROR~!"
            End If
            strResult = strResult & objHTTP.Status & " " & objHTTP.StatusText
        End If
    End If

    Set objHTTP = Nothing

    CheckHTTPStatus = strResult

    On Error Goto 0  ' End Error Handling

End Function

Jan 18

CheckServiceRunning.vbs

Posted on January 18, 2013 by admin

'=========================================================================
' CheckServiceRunning.vbs
' VERSION: 1.0
' AUTHOR: Brian Steinmeyer
' EMAIL: sigkill@sigkillit.com
' WEB: http://sigkillit.com
' DATE: 1/17/2013
' COMMENTS: Pass the computer/servername to the function and the Service name
' and it will return whether the service is running.
' EXAMPLE: Check if the Print Spooler is Running
'		   strComputer = "Server"
'          strService = "Spooler"
'=========================================================================
Option Explicit
' ------ SCRIPT CONFIGURATION ------
Dim strComputer: strComputer = "Server"
Dim strService: strService = "Spooler"
' ------ END CONFIGURATION ------

Wscript.Echo CheckServiceRunning(strComputer, strService)

Private Function CheckServiceRunning(strComputer, strService)

	On Error Resume Next  ' Start Services Info Error Handling

	' Set Variables
	Dim objService, strResult: strResult = "!~ERROR~!"

    Dim objWMIService: Set objWMIService = GetObject("winmgmts:\\" & strComputer & "\root\cimv2")
    Dim colServiceList: Set colServiceList = objWMIService.ExecQuery("Select * from Win32_Service WHERE Name = '" & strService & "'")
    If colServiceList.Count = 1 Then
		For Each objService in colServiceList
			If objService.State = "Running" Then
				strResult = "Running"
			Else
				'Attempt to Start Sesrvice if Not Running
				strResult = StartService(strComputer, strService)
			End If
		Next
    End If

	' Error Check
	If Err.Number <> 0 Then
		'Wscript.Echo Err.Number & vbCrLf & Err.Source & vbCrLf & Err.Description
		Err.Clear
		strResult = "!~ERROR~!"
	End If

	' Return Result
	CheckServiceRunning = "(" & strService & ")" & strResult

	On Error GoTo 0  ' End Services  Info Error Handling

End Function

Page 1 of 412 3 4

Sigkill IT

Code and IT Knowledge

Category Archives: VBScript

DirMirror.vbs

DeleteOldUsers.vbs

SyncToy21.vbs

ConvertOutlookContactsToAD.vbs

Running VBScripts with UAC Elevation

Overview

Method 1 – Elevating Using the Command Prompt

Method 2 – RunAs Script

Method 3 – Add ‘Run as administrator’ to the .vbs File Context Menu

ElevateWscript.vbs

ComputerInventory.vbs

PingHost.vbs

CheckHTTPStatus.vbs

CheckServiceRunning.vbs