Remove From My Forums

Domain login VBS Script

Question
0

Sign in to vote

I need a vbs script that will run when a user logs in that will detect if the user plugs in an unauthorized device, such as a thumb drive, external hard or any other storage device. I need it to gather the username, computer name and the device guid or serial. I would like for it to pop up a message with beeps (or some kind of sound) I also want it to email this information to me. Also, would like to be able to add authorized devices to this so that once its added to the script it wont do this popup, sound and email anymore. I know this is alot to ask and I know that this exist, I had one that someone created and the network admin before me used it for a while and now he is gone and he deleted this script and i can't find another. Any help in this matter is greatly appreciated!! Thanks in advance for your help and cooperation.

Thanks,

Ron
Thanks,

Tuesday, January 18, 2011 7:56 AM

Answers

Hi Ron,

Although i've included plenty of code comments, I just wanted to clarify the setup of these scripts for you and include some instructions to ensure you can configure the setup in your environment...

The solution i've coded relies on the "deveject.exe" utility existing in system folder.
The solution requires the use of two group polices, one for computer startup to apply the "Deploy.vbs" script which copies the "deveject.exe" executable from the group polices location in sysvol to the system folder on your client workstations, the other for user logon to apply the "RestrictUSBStorageDevice.vbs" script at logon which monitors USB devices and relies on the "deveject.exe" utility existing within the system folder to execute a command that automatically ejects unapproved devices.
The "Deploy.vbs" script should be applied using a computer startup script. It ensures the "deveject.exe" utility is copied from sysvol to the system folder on all client workstations. You can choose to use this script or any another deployment method (SCCM for example.)
Exclusions to the script can be easily added by user, computer or USB device model name by editing variables within the "RestrictUSBStorageDevice.vbs" script.

Please be aware this solution has the following caveats:

As the "RestrictUSBStorageDevice.vbs" script is executed by the user at logon, it runs under their securtiy context and therefore the user has permissions to terminate the WScript.exe process. Unless you write an application to install a Windows Service that monitors USB storage devices, i'm not aware of another option that ensures the user recieves the popup message.
It relies on a third party executable to be deployed to the system directory of you client workstations.
Updating Exclusions requires your client systems to logoff\logon.

Adding functionality to have the script email you results is easy. For example:

'-------------------------------------------------------------------------------
Function ProcessScript
  Dim sender, recipient, subject, content, smtpServer, portNumber, fileSpecs
  '----------------------------------------------------------------------------
  'The rest of the code will be merged here. Once the unapproved devices is detected, send the email.
  '----------------------------------------------------------------------------
  fileSpecs = Array("")
  sender   = "alert@domain.com"
  recipient = "admin@domain.com"
  subject  = "USB Storage Device Report"
  content  = ipAddress & "," & macAddress & "," & userInfo & "," & hostName & "," & model
  smtpServer = "mailServer.domain.com"
  portNumber = 25
  '----------------------------------------------------------------------------
  'Send the email report to the administrator.
  '----------------------------------------------------------------------------
  If Not SendEmail(sender, recipient, subject, content, fileSpecs, smtpServer, portNumber) Then
   Exit Function
  End If
End Function
'-------------------------------------------------------------------------------
'Name    : SendEmail -> Sends an Email. Requires an SMTP Relay Server.
'Parameters : sender   -> String containing the senders email address.
'      : recipient -> String containing the recipients email address.
'      : subject  -> String containing the email subject line.
'      : content  -> String containing the body of the email message.
'      : fileSpecs -> Array containing the Folder Paths and file names of the email attachments to send.
'      : smtpServer -> String containing the SMTP Server's FQDN.
'      : portNumber -> Integer containing the SMTP Server's Port Number.
'Return   : SendEmail -> Returns True if the email was succesfully send otherwise returns False.
'-------------------------------------------------------------------------------
Function SendEmail(sender, recipient, subject, content, fileSpecs, smtpServer, portNumber)
  Dim objEmail, errorCount, emailAddresses, i
  SendEmail = False
  errorCount = 0
  '----------------------------------------------------------------------------
  'Ensure the fileSpecs parameter is a valid array.
  '----------------------------------------------------------------------------
  If Not IsArray(fileSpecs) Then
   fileSpecs = Array(fileSpecs)
  End If
  '----------------------------------------------------------------------------
  'Create the Email and set the properties.
  '----------------------------------------------------------------------------
  On Error Resume Next
   Set objEmail = CreateObject("CDO.Message")
   If Err.Number <> 0 Then
     Exit Function
   End If
   objEmail.From   = sender
   objEmail.To    = recipient
   objEmail.Subject = subject
   objEmail.Textbody = content
   '-------------------------------------------------------------------------
   'Add each attachment in the array of attachments to the email.
   '-------------------------------------------------------------------------
   For i = 0 To UBound(fileSpecs)
     Do
      objEmail.AddAttachment fileSpecs(i)
      If Err.Number <> 0 Then
        errorCount = errorCount + 1
        Exit Do
      End If
     Loop Until True
   Next
   '-------------------------------------------------------------------------
   'Configure the email properties.
   '-------------------------------------------------------------------------
   objEmail.Configuration.Fields.Item("http://schemas.microsoft.com/cdo/configuration/sendusing")   = 2
   objEmail.Configuration.Fields.Item("http://schemas.microsoft.com/cdo/configuration/smtpserver")   = smtpServer
   objEmail.Configuration.Fields.Item("http://schemas.microsoft.com/cdo/configuration/smtpserverport") = portNumber
   objEmail.Configuration.Fields.Update
   objEmail.Send
   '-------------------------------------------------------------------------
   'Send the Email.
   '-------------------------------------------------------------------------
   If Err.Number <> 0 Then
     Exit Function
   End If
  On Error Goto 0
  '----------------------------------------------------------------------------
  'Ensure the function returns False if their were any errors were encountered.
  '----------------------------------------------------------------------------
  If errorCount <> 0 Then
   Exit Function
  End If
  SendEmail = True
End Function
'-------------------------------------------------------------------------------

Cheers Matt :)

Marked as answer by IamMred Thursday, January 27, 2011 12:28 AM

Monday, January 24, 2011 11:30 AM

Hi Ron,

Whilst this thread has already been marked as the answer, your additional request is very easy to implement. Here are instructions on how to set up the logging:

Create a share on several of your domain controllers or member servers (as long as you pick atleast 2 servers for logging redundancy in your infrastructure)
Name the share "Logs$" to prevent people browsing
Grant the "Everyone" security principal at minimum the "Change" permission on the share
Grant the "Authenticated Users" security principal "Modify" permissions on the folder
Change the "shareNames" variable in the script below to indicate your server names.

Here is the modified version of the "RestrictUSBStorageDevices.vbs" to include centralised logging. Hope this helps

Cheers Matt :)

P.S...I think you owe me a beer by now :)

'-------------------------------------------------------------------------------
'Script Name : RestrictUSBStorageDevice.vbs
'Author   : Matthew Beattie
'Created   : 21/10/11
'Description : This script monitors for the addition of USB Storage Devices to the system. If the device is not approved
'      : the user will be notified and device will be ejected. It is "assumed" the "deveject.exe" utility available 
'      : from the link below has been deployed to the system32 directory on all systems. For further documentation:
'      :
'      : http://www.microsoft.com/technet/scriptcenter/resources/scriptshop/shop0805.mspx
'      : http://www.withopf.com/tools/deveject/
'-------------------------------------------------------------------------------
'Initialization Section 
'-------------------------------------------------------------------------------
Option Explicit
Const ForAppending = 8
Dim objFSO, objSink, objWMI, sysInfo, wshShell, wshNetwork, systemPath
Dim scriptBaseName, scriptPath, scriptLogPath, localLogPath, ipAddress, macAddress
Dim userExclusions, computerExclusions, deviceExclusions
Dim hostName, userName, userInfo, model, fileName
On Error Resume Next
  Set wshShell  = CreateObject("WScript.Shell")
  Set wshNetwork = CreateObject("WScript.Network")
  Set objFSO   = CreateObject("Scripting.FileSystemObject")
  Set sysInfo  = CreateObject("ADSystemInfo")
  hostName    = wshNetwork.ComputerName
  Set objWMI   = GetObject("winmgmts:\\" & hostName & "\root\cimv2")
  Set objSink  = WScript.CreateObject("WbemScripting.SWbemSink", "Sink_")
  localLogPath  = wshShell.ExpandEnvironmentStrings("%temp%")
  scriptBaseName = objFSO.GetBaseName(Wscript.ScriptFullName)
  scriptPath   = objFSO.GetFile(Wscript.ScriptFullName).ParentFolder.Path
  systemPath   = objFSO.GetSpecialFolder(1)
  fileName    = "deveject.exe"
  '----------------------------------------------------------------------------
  'Configure the user, computer and USB Storage device exclusions here.
  '----------------------------------------------------------------------------
  deviceExclusions  = Array("Kingston DT Elite HS 2.0 USB Device")
  userExclusions   = Array("User1","User2")
  computerExclusions = Array("Computer1","Computer2")
  '----------------------------------------------------------------------------
  'Execute the scripts primary Function.
  '----------------------------------------------------------------------------
  ProcessScript
  If Err.Number <> 0 Then
   Wscript.Quit
  End If
On Error Goto 0
'-------------------------------------------------------------------------------
'Sub Rountine Processing Section
'-------------------------------------------------------------------------------
Sub Sink_OnObjectReady(objEvent, objContext)
  Dim model, i
  '----------------------------------------------------------------------------
  'Attempt to enumerate the Model of the USB device up to 3 times. Windows may not have installed the driver yet!
  '----------------------------------------------------------------------------
  For i = 1 To 3
   model = GetUSBModel
   If model <> "" Then
     Exit For
   Else
     WScript.Sleep 10000
   End If
  Next
  CheckUSBDevice model
End Sub
'-------------------------------------------------------------------------------
'Functions Processing Section
'-------------------------------------------------------------------------------
'Name    : ProcessScript -> Primary Function that controls all other script processing.
'Parameters : None     ->
'Return   : None     ->
'-------------------------------------------------------------------------------
Function ProcessScript
  Dim query, logonName, shareNames, shareName, i
  shareNames = Array("\\testdc01\Logs$")
  query   = "Select * From __InstanceCreationEvent Within 5 Where " & _
        "TargetInstance Isa 'Win32_DiskDrive' And " & _
        "TargetInstance.InterfaceType = 'USB'"
  '----------------------------------------------------------------------------
  'Enusure the script's network log path exist otherwise define a local path.
  '----------------------------------------------------------------------------
  If Not SetLogPath(shareNames, scriptLogPath) Then
   scriptLogPath = localLogPath
  End If
  '----------------------------------------------------------------------------
  'Ensure the script's Base Name folder exists within the Logs$ share.
  '----------------------------------------------------------------------------
  scriptLogPath = scriptLogPath & "\" & scriptBaseName
  If Not objFSO.FolderExists(scriptLogPath) Then
   If Not CreateFolder(scriptLogPath) Then
    Exit Function
   End If
  End If
  scriptLogPath = scriptLogPath & "\" & IsoDateString(Now)
  '----------------------------------------------------------------------------
  'Enumerate the systems IP and MAC address for logging.
  '----------------------------------------------------------------------------
  If Not GetIPConfig(hostName, ipAddress, macAddress) Then
   ipAddress = "0.0.0.0"
   macAddress = "00:00:00:00:00:00"
  End If
  '----------------------------------------------------------------------------
  'Ensure the "devEject.exe" file exist within the scripts working directory.
  '----------------------------------------------------------------------------
  If Not objFSO.FileExists(systemPath & "\" & fileName) Then
   LogMessage 2, DQ(systemPath & "\" & fileName) & " does not exist"
   Exit Function
  End If
  '----------------------------------------------------------------------------
  'Enumerate the User's LogonName, FirstName and LastName for logging.
  '----------------------------------------------------------------------------
  userInfo = GetUserInfo
  On Error Resume Next
   logonName = Split(userInfo, ",")(0)
   If Err.Number <> 0 Then
     logonName = ""
   End If
  On Error Goto 0
  '----------------------------------------------------------------------------
  'Ensure USB storage devices which have already been inserted before script execution are enumerated.
  '----------------------------------------------------------------------------
  model = GetUSBModel
  If model <> "" Then
   CheckUSBDevice model
  End If
  '----------------------------------------------------------------------------
  'Ensure exclued users are not processed.
  '----------------------------------------------------------------------------
  For i = 0 To UBound(userExclusions)
   If StrComp(logonName, userExclusions(i), vbTextCompare) = 0 Then
     Exit Function
   End If
  Next
  '----------------------------------------------------------------------------
  'Ensure exclued computers are not processed.
  '----------------------------------------------------------------------------
  For i = 0 To UBound(computerExclusions)
   If StrComp(hostName, computerExclusions(i), vbTextCompare) = 0 Then
     Exit Function
   End If
  Next
  '----------------------------------------------------------------------------
  'Execute WMI Query to monitor USB devices. Creates "Sink_OnObjectReady" Sub Routine
  '----------------------------------------------------------------------------
  On Error Resume Next
   objWMI.ExecNotificationQueryAsync objSink, query
   If Err.Number <> 0 Then
     LogMessage 1, "Executing WMI Query " & DQ(query)
     Exit Function
   End If
  On Error Goto 0
  '----------------------------------------------------------------------------
  'Process script indefinately waiting for USB Storage Device events.
  '----------------------------------------------------------------------------
  Do
   WScript.Sleep 5000
  Loop
End Function
'-------------------------------------------------------------------------------
'Name    : SetLogPath -> Checks an Array of sharenames and sets one to the scripts log path if the default is unavailable.
'Parameters : shareNames -> A share name or array of shares names.
'      : logPath  -> Input/Output : Variable assigned to a valid share name that exists and is online.
'Return   : SetLogPath -> Function returns True and a valid log path otherwise returns False.
'-------------------------------------------------------------------------------
Function SetLogPath(shareNames, logPath)
  Dim shareName
  SetLogPath = True
  If Not IsArray(shareNames) Then
   shareNames = Array(shareNames)
  End If
  If objFSO.FolderExists(logPath) Then
   Exit Function
  End If
  For Each shareName In shareNames
   If objFSO.FolderExists(shareName) Then
     logPath = shareName
     Exit Function
   End If
  Next
  SetLogPath = False
End Function
'-------------------------------------------------------------------------------
'Name    : CreateFolder -> Recursive Function to Create a directory structure or single folder.
'Parameters : folderSpec  -> Path of folder\folders to create.
'Return   : CreateFolder -> Returns True if the directory structure was successfully created otherwise returns False.
'-------------------------------------------------------------------------------
Function CreateFolder(folderSpec)
  CreateFolder = False
  If Not objFSO.FolderExists(folderSpec) Then
   If InStrRev(folderSpec, "\") <> 0 Then
     If Not CreateFolder(Left(folderSpec, InStrRev(folderSpec, "\") - 1)) Then
      Exit Function
     End If
   End If
   On Error Resume Next
     objFSO.CreateFolder folderSpec
     If Err.Number <> 0 Then
      LogMessage 1, "Creating folder " & DQ(folderSpec)
      Exit Function
     End If
   On Error Goto 0
  End If
  CreateFolder = True
End Function
'-------------------------------------------------------------------------------
'Name    : GetIPConfig -> Enumerates the IP & MAC Address of the system via WMI
'Parameters : hostName  -> String containing the hostname of the computer to enumerate the IP configuration for.
'      : ipAddress  -> Input/Output : Variable assigned to the IP Address of the system.
'Parameters : macAddress -> Input/Output : Variable assigned to the MAC Address of the system.
'Return   : GetIPConfig -> Returns True and the systems IP & MAC Address if successful otherwise returns False.
'-------------------------------------------------------------------------------
Function GetIPConfig(hostName, ipAddress, macAddress)
  Dim wmi, ipConfig, query
  GetIPConfig = False
  ipAddress  = ""
  macAddress = ""
  query    = "Select * From Win32_NetworkAdapterConfiguration Where IPEnabled = True"
  On Error Resume Next
   Set wmi = GetObject("winmgmts:{impersonationLevel=impersonate}!\\" & hostName & "\root\cimv2")
   If Err.Number <> 0 Then
     LogMessage 1, "Creating WMI Object"
     Exit Function
   End If
   For Each ipConfig in wmi.ExecQuery(query)
     If Err.Number <> 0 Then
      LogMessage 1, "Executing WMI query " & DQ(query)
      Exit Function
     End If
     ipAddress = ipConfig.IPAddress(0)
     macAddress = ipConfig.MACAddress(0)
     If ipAddress <> "" And ipAddress <> "0.0.0.0" And MACAddress <> "" Then
      Exit For
     End If
   Next
  On Error Goto 0
  GetIPConfig = True
End Function
'-------------------------------------------------------------------------------
'Name    : GetUserInfo -> Attempts to Enumerate the user's LogonName, FirstName, Surname.
'Parameters : None    -> 
'Return   : GetUserInfo -> Returns a comma seperate string containing the users LogonName, FirstName And Surname.
'-------------------------------------------------------------------------------
Function GetUserInfo
  Dim objUser, userName, logonServer, firstName, lastName
  FirstName = ""
  Lastname = ""
  On Error Resume Next
   userName  = wshNetwork.UserName
   logonServer = wshShell.ExpandEnvironmentStrings("%logonserver%")
   '-------------------------------------------------------------------------
   'As the logonserver and hostname are identical the user must be logged on locally so don't get the properties from AD.
   '-------------------------------------------------------------------------
   If StrComp(logonServer, hostName, vbTextCompare) = 0 Then
     userInfo = userName & "," & firstName & "," & lastName
     Exit Function
   End If
   '-------------------------------------------------------------------------
   'As the user's logon server is a domain controller, enumerate their user properties from AD.
   '-------------------------------------------------------------------------
   Set objUser = GetObject("LDAP://" & sysInfo.userName)
   If Err.Number <> 0 Then
     LogMessage 1, "Binding to user object"
   Else
     firstName = ProperCase(objUser.givenName)
     LastName = ProperCase(objUser.sn)
   End If
  On Error Goto 0
  GetUserInfo = UserName & "," & firstName & "," & lastName  
End Function
'-------------------------------------------------------------------------------
'Name    : ProperCase -> Converts a string to "Proper" case.
'Parameters : text    -> String text to be converted.
'Return   : ProperCase -> Returns the converted String in Proper case.
'-------------------------------------------------------------------------------
Function ProperCase(text)
  Dim wordArray, i
  On Error Resume Next
   wordArray = Split(text, " ")
   For i = 0 To Ubound(wordArray)
     wordArray(i) = UCase(Left(wordArray(i), 1)) & Lcase(Mid(wordArray(i), 2))
   Next
   ProperCase = Join(wordArray, " ")
  On Error Goto 0
End Function
'-------------------------------------------------------------------------------
'Name    : GetUSBModel -> Enumerates the USB Storage Device Model Name.
'Parameters : None    -> 
'Return   : GetUSBModel -> Returns the the USB Storage Device Model Name.
'-------------------------------------------------------------------------------
Function GetUSBModel
  Dim query, model, results, result
  model   = ""
  query   = "Select Model From Win32_DiskDrive Where InterfaceType = 'USB'"
  On Error Resume Next
   Set results = objWMI.ExecQuery(query)
   If Err.Number <> 0 Then
     LogMessage 1, "Executing query " & DQ(query)
     Exit Function
   End If
   For Each result In results
     model = result.model
     If Err.Number <> 0 Then
      model = ""
      Exit For
     End If
   Next
  On Error Goto 0
  GetUSBModel = model
End Function
'-------------------------------------------------------------------------------
'Name    : EjectUSBDevice -> Prompts the User and Executes a command to eject the USB device.
'Parameters : model     -> String containing the USB Device model to eject. 
'Return   : None      -> 
'-------------------------------------------------------------------------------
Function EjectUSBDevice(model)
  Dim command
  '----------------------------------------------------------------------------
  'Prompt the user then automatically eject the USB device.
  '----------------------------------------------------------------------------
  On Error Resume Next
   wshShell.Popup "Using an unapproved USB storage devices is a voilation of security policy. " & vbCrLf & _
           "Your actions are being audited. Your Administrator has been notified." & vbCrLf & vbCrLf & _
           hostName & "," & ipAddress & "," & macAddress & "," & userInfo & "," & model, 7, scriptBaseName, 48
   command = "cmd /c " & fileName & " -EjectName:" & DQ(model)
   wshShell.Run command, 0, False
   LogMessage 0, userInfo & "," & model
  On Error Goto 0
End Function
'-------------------------------------------------------------------------------
'Name    : CheckUSBDevice -> Prompts the User and Executes a command to eject the USB device.
'Parameters : model     -> String containing the USB Device model to eject. 
'Return   : CheckUSBDevice -> 
'-------------------------------------------------------------------------------
Function CheckUSBDevice(model)
  Dim approved, i
  approved = False
  '----------------------------------------------------------------------------
  'Ensure USB devices that have been approved for corporate use are not ejected.
  '----------------------------------------------------------------------------
  For i = 0 To UBound(deviceExclusions)
   If StrComp(model, deviceExclusions(i), vbTextCompare) = 0 Then
     approved = True
     Exit For
   End If
  Next
  '----------------------------------------------------------------------------
  'The device has not been approved so Eject it.
  '----------------------------------------------------------------------------
  If Not approved Then
   EjectUSBDevice model
  End If
End Function
'-------------------------------------------------------------------------------
'Name    : DQ     -> Place double quotes around a string and replace double quotes  
'      :       -> within the string with pairs of double quotes.  
'Parameters : stringValue -> String value to be double quoted  
'Return   : DQ     -> Double quoted string.  
'------------------------------------------------------------------------------- 
Function DQ (ByVal stringValue)  
  If stringValue <> "" Then 
   DQ = """" & Replace (stringValue, """", """""") & """"  
  Else 
   DQ = """""" 
  End If 
End Function
'-------------------------------------------------------------------------------
'Name    : IsoDateTimeString -> Generate an ISO date and time string from a date/time value.
'Parameters : dateValue     -> Input date/time value.
'Return   : IsoDateTimeString -> Date and time parts of the input value in "yyyy-mm-dd hh:mm:ss" format.
'-------------------------------------------------------------------------------
Function IsoDateTimeString(dateValue)
  IsoDateTimeString = IsoDateString (dateValue) & " " & IsoTimeString (dateValue)
End Function
'-------------------------------------------------------------------------------
'Name    : IsoDateString -> Generate an ISO date string from a date/time value.
'Parameters : dateValue   -> Input date/time value.
'Return   : IsoDateString -> Date part of the input value in "yyyy-mm-dd" format.
'-------------------------------------------------------------------------------
Function IsoDateString(dateValue)
  If IsDate(dateValue) Then
   IsoDateString = Right ("000" & Year (dateValue), 4) & "-" & _
           Right ( "0" & Month (dateValue), 2) & "-" & _
           Right ( "0" &  Day (dateValue), 2)
  Else
   IsoDateString = "0000-00-00"
  End If
End Function
'-------------------------------------------------------------------------------
'Name    : IsoTimeString -> Generate an ISO time string from a date/time value.
'Parameters : dateValue   -> Input date/time value.
'Return   : IsoTimeString -> Time part of the input value in "hh:mm:ss" format.
'-------------------------------------------------------------------------------
Function IsoTimeString(dateValue)
  If IsDate(dateValue) Then
   IsoTimeString = Right ("0" &  Hour (dateValue), 2) & ":" & _
           Right ("0" & Minute (dateValue), 2) & ":" & _
           Right ("0" & Second (dateValue), 2)
  Else
   IsoTimeString = "00:00:00"
  End If
End Function
'-------------------------------------------------------------------------------
'Name    : LogMessage -> Parses a message to the log file based on the messageType.  
'Parameters : messageType -> Integer representing the messageType.
'      :       -> 0 = message    (writes to a ".log" file)
'      :       -> 1 = error,    (writes to a ".err" file including information relating to the error object.)
'      :       -> 2 = error message (writes to a ".err" file without information relating to the error object.)
'      : message   -> String containing the message to write to the log file.
'Return   : None    -> 
'-------------------------------------------------------------------------------
Function LogMessage(messageType, message)
  Dim prefix, logType
  prefix = IsoDateTimeString(Now) & "," & hostName & "," & ipAddress & "," & macAddress
  Select Case messageType
   Case 0
     logType = "log"
   Case 1
     logType = "err"
     message = "Error " & Err.Number & " (Hex " & Hex(Err.Number) & ") " & message & ". " & Err.Description
   Case Else
     LogType = "err"
  End Select
  If Not LogToCentralFile(scriptLogPath & "." & logType, prefix & "," & message) Then 
   Exit Function 
  End If
End Function
'-------------------------------------------------------------------------------
'Name    : LogToCentralFile -> Attempts to Appends information to a central file.
'Parameters : logSpec     -> Folder path, file name and extension of the central log file to append to.
'      : message     -> String to include in the central log file
'Return   : LogToCentralFile -> Returns True if Successfull otherwise False.
'-------------------------------------------------------------------------------
Function LogToCentralFile(logSpec, message)
  Dim attempts, objLogFile
  LogToCentralFile = False
  '----------------------------------------------------------------------------
  'Attempt to append to the central log file up to 10 times, as it may be locked by some other system.
  '----------------------------------------------------------------------------
  attempts = 0
  On Error Resume Next
   Do
     Set objLogFile = objFSO.OpenTextFile(logSpec, ForAppending, True)
     If Err.Number = 0 Then
      objLogFile.WriteLine message
      objLogFile.Close
      LogToCentralFile = True
      Exit Function
     End If
     Randomize
     Wscript.sleep 1000 + Rnd * 100
     attempts = attempts + 1
   Loop Until attempts >= 10
  On Error Goto 0
End Function
'-------------------------------------------------------------------------------

Marked as answer by MatthewBeattie Thursday, January 27, 2011 12:02 PM

Thursday, January 27, 2011 12:01 PM

All replies

0

Sign in to vote

Hi Ron,

Assuming your on Windows Server 2003 infrastructure with XP clients? If not use bitlocker and group policy to control removable storage device encryption. Do users in your environment have administrative privileges? If so there is nothing stopping them from terminating wscript.exe and plugging in their USB storage device without your knowledge. Let me know if my assumptions are correct and i'll see what i can come up with.

Cheers Matt :)

Tuesday, January 18, 2011 8:37 AM
0

Sign in to vote

Thanks Matt for the reply, I apologize for not giving more information.

I am running 2 windows 2003 DC's with about 600 clients, about 500 are vista enterprise with sp2 and the remaining are windows 7 enterprise. I'm running active directory and my users do not have admin priviledges. We were running a script that did all this and ran without a problem. What happened was our network admin tried to modify the script and jacked it up so it wont work at all now. It worked on both Vista and 7 without a problem, until he messed with it. I'm also in the process of moving all my cleints to 7 over the next few months. Thanks for your help.

Thanks,

Tuesday, January 18, 2011 1:53 PM

Hi Ron

Hmmm, then I'm also assuming you don't have a valid backup of your group policies to restore the previous script from then? Personally, I'd be more worried about that than what types of USB devices your users have. See this to prevent the situation in future:

http://technet.microsoft.com/en-us/library/cc782589(WS.10).aspx

As for the script, here is something to get you started testing with. Just change the "deviceNames" array to include the model names of all USB devices that you've approved. This won't do everything you require (logging, email etc) but it's best to keep it simple and expand on it. Just want to make sure the basis of the script meets your requirements before adding the extra's. The Message Box alone is probably enough to strike fear into the hearts of your users :)

Hope this helps

Cheers Matt :)

'----------------------------------------------------------------------------------------------------------------------------
'Script Name : DetectUSBStorageDevice.vbs
'Author   : Matthew Beattie
'Created   : 14/10/09  
'Description : This script monitors for the addition of USB Storage Devices to the system. For further documentation read:
'      : http://www.microsoft.com/technet/scriptcenter/resources/scriptshop/shop0805.mspx
'----------------------------------------------------------------------------------------------------------------------------
'Initialization Section  
'----------------------------------------------------------------------------------------------------------------------------
Option Explicit
Dim objFSO, objSink, objWMI, scriptBaseName
Dim hostName, model, deviceNames, deviceName
hostName = "."
On Error Resume Next
  Set objFSO   = CreateObject("Scripting.FileSystemObject")
  Set objSink  = WScript.CreateObject("WbemScripting.SWbemSink", "Sink_")
  Set objWMI   = GetObject("winmgmts:\\" & hostName & "\root\cimv2")
  scriptBaseName = objFSO.GetBaseName(Wscript.ScriptFullName)
  deviceNames  = Array("Kingston DT Elite HS 2.0 USB Device")
  If Err.Number <> 0 Then
   Wscript.Quit
  End If
  objWMI.ExecNotificationQueryAsync objSink, "Select * From __InstanceCreationEvent Within 1 Where " & _
                       "TargetInstance Isa 'Win32_DiskDrive' And TargetInstance.InterfaceType = 'USB'"
  '-------------------------------------------------------------------------------------------------------------------------
  'Process indefinately waiting for USB Storage Device events.
  '-------------------------------------------------------------------------------------------------------------------------
  Do
   WScript.Sleep 1000
  Loop
On Error Goto 0
'----------------------------------------------------------------------------------------------------------------------------
Sub Sink_OnObjectReady(objEvent, objContext)
  Dim results, result, approved
  approved = False
  On Error Resume Next
   Set results = objWMI.ExecQuery("Select Model From Win32_DiskDrive Where InterfaceType = 'USB'")
   If Err.Number <> 0 Then
     Exit Sub
   End If
  On Error Goto 0
  For Each result In results
   model = result.model
  Next
  For Each deviceName In deviceNames
   If StrComp(deviceName, model, vbTextCompare) = 0 Then
     approved = True
     Exit For
   End If
  Next
  If Not approved Then
   MsgBox "Using unapproved USB storage devices is a voilation of security policy. " & _
       "Your actions are being audited and your Administrator has been notified", vbExclamation, scriptBaseName
  End If
End Sub
'----------------------------------------------------------------------------------------------------------------------------

Wednesday, January 19, 2011 1:44 AM

0

Sign in to vote

You may also want to look into the Device Installation Restrictions in the group policy (under the Administrative Templates\System\Device Installation\Device Installation Restrictions tree).

http://technet.microsoft.com/pt-pt/library/dd701203(WS.10).aspx
Regards,
Salvador Manaois III MCSE MCSA CEH MCITP | Enterprise/Server Admin
Bytes & Badz : http://badzmanaois.blogspot.com
Scripting, the SysAdmin Way : http://sgwindowsgroup.org/blogs/badz

Wednesday, January 19, 2011 1:58 AM
0

Sign in to vote

Thanks Matt, actually i found a copy of the old vbs script today in one of the old script folders on the backup server, its one what was modified and quit working. I can put it on here tomorrow if you don't mind looking at it for me and see if you notice a problem. We do have a back up solution on our GPO's but this was a vbs script that was being called from another vbs script at login and he deleted them out of the sysvol and the login script and said he did it because it wasn't working and that was a few couple months ago. I kinda picking up and starting over, i have made all new GPO's and things are looking and working much better. If i get this script working then all will be awesome!

Salvador, actually i'm using that in login gpo but it doesn't work as well as intended. If the drivers are already on the system you actually have to uninstall them and once approved and added to the gpo they can be reinstalled. The problem i have found this week is windows 7 has alot of these drivers already built in and therefore they would work even with them being specifically blocked, until they were uninstalled. thanks for your help.

I'll post the vbs i have tomorrow and any help to make it work is greatly appreciated.

Thanks,

Ron
Thanks,

Wednesday, January 19, 2011 3:37 AM
0

Sign in to vote

Ok, below is the script that we used to use. Some how it got modified and it doesn't work any more. I will highlight the areas that i changed just for this post but other than that i don't know what was changed. I took the job over and this is what i found and I have no idea how to make it work. Any help with this is greatly appreciated! I have no idea where this script came from, but i do know what it worked like a champ until a few weeks ago and no one at work knows how to edit it and put the approved items in there. Thanks in advance for the help!

'******* IMPORTANT NOTES ********************************
'Email will fail if firewall blocks scripts
'EX: McAfee Mass Mailing Script Blocking port 25 must be disabled!
'
'This should be called by the logon script. Here is an example of lines to add to your
'(Place the USBMonitor script in the NetLogon share with the logon script)

':ServerTest
'VER | find "XP" > nul
'IF %errorlevel% EQU 0 cscript %0\..\USBMonitor.VBS
'
'Alternativly, you can place it in the in all users startup folder.
' **** YOU MUST EDIT BELOW FOR THIS TO WORK, beginning around line 40. Also note debug at line 42
Option Explicit
'Dim variables and use Option Explicit. This is a best practice,
'and makes debugging misspelled variables much, much easier..

Dim bDebug, bNotify, bCSV, bVerbose, bAnnoy
Dim strSubject, strBody, strTo, strFrom
Dim strTestEmail, aIgnoreList, message
Set objNet = CreateObject("Wscript.Network")
strComputer = objNet.Computername
Dim strDrive
dim fso
Set fso = CreateObject("Scripting.FileSystemObject")
Dim dExceptions                   ' Create a dictionary.
Set dExceptions = CreateObject("Scripting.Dictionary")
dim ExcludeNames, PNPIDs
Const TextCompare = 1
dExceptions.CompareMode = TextCompare
Dim dLastTime: dLastTime= "3/10/2010 12:32" 'arbitrary time in the past

' ****** ======== EDITING REQUIRED HERE ====== ******
'if bDebug True messages echo showing postion in code.
'Debug is for testing, DO NOT DEPLOY WITH THIS SET TO TRUE!
bDebug = False

'SMTP Mail server
Const strMailServer = "insert email IP address"

'Or Single name to get messages, or more than one separated by semi-colon ";"
strTo = "firstname.lastname@youremail.com"

'Who gets mail when bDebug testing
strTestEmail = "firstname.lastname@youremail.com"

'Verbose adds Device IDs to email. Good for creating exclusion list.
bVerbose = True

'List of USB Storage devices that will not cause message to be sent
'Compared against all or part of the the Device ID. No spaces!
'These will be ignored for all users and all workstations

aIgnoreList =Array '"FLOPPY","CDROM","LASERJET","DVR","ONETOUCH"
'"PHOTOSMART","OFFICEJET","ST25062", "WD"

'Special list of exceptions paired to Computer netbios name or NT4 style UserName
'These must be an EXACT match on the first element, including case
'dExceptions.Add "ComputerName1", "PHOTOSMART"
'dExceptions.Add "ComputerName2", "KODAK"
'dExceptions.Add "HITACHI_&PROD_DK23EA-40&REV"
'dExceptions.Add "VEN_WD&PROD_2500JS"

ExcludeNames = dExceptions.Keys
PNPIDs = dExceptions.items

'From line.
strFrom = "supply email "

'Default computername@domain.com
strFrom = strComputer & "@your domain"

'If true, user gets popup msgbox with warning below
bNotify = True

'If True, computer beeps until drive removed, annoying user
'bAnnoy = False
bAnnoy = True

'If true then CSV info is added to message to cut and paste into spreadsheet.
bCSV = True

'New Pop message of due not use Thumbdrives
'Popup warning message
message = "NOTICE! " & VbCrLf & VbCrLf & _
"Effective immediately we are prohibited from using thumbdrives" & _
"from one pc to another, regardless of the network. " & VbCrLf & VbCrLf & _
"The USB device you have inserted is in violation of Policy. " & VbCrLf & VbCrLf & _
"If you have any questions please direct them to the helpdesk at ext. xxxx. " & VbCrLf & VbCrLf & "Network security officer has been notified."

'Below was commented out due to TCNO when resended uncomment out.
'~ 'Popup warning message
'~ message = "NOTICE! " & VbCrLf & VbCrLf & "The USB device you have inserted is in violation of policy. " & _
'~ "Only approved MXP USB Drives are permitted on the Network, see your CSA if you need to apply for an approved device. For immediate assistance contact the " & _
'~ "NCC help desk at ext. xxxx. " & VbCrLf & VbCrLf & "The network security officer has been notified."

' ========== End Edits =======
'Email Constants do not change
Const cdoSendUsingMethod = "http://schemas.microsoft.com/cdo/configuration/sendusing"
Const cdoSMTPServer = "http://schemas.microsoft.com/cdo/configuration/smtpserver"
Const cdoSendUsingPort = 25
Const cdoSMTPServerPort = "http://schemas.microsoft.com/cdo/configuration/smtpserverport"
Const cdoSMTPConnectionTimeout = "http://schemas.microsoft.com/cdo/configuration/smtpconnectiontimeout"
'RS Constants do not change
Const adVarChar = 200
Const MaxCharacters = 255
Const adFldIsNullable = 32
Const adDouble = 5

Dim strComputer, wshShell,objNet
Dim oWMI, colMonitoredEvents, objLatestEvent, strNTName, strMyName,strMyCSVName, strDescription
Dim oSI, oRS, strSite
Dim Fields, i
Set wshShell = WScript.CreateObject("wscript.shell")

Dim m_objCDO, m_objCDOcon

Dim colitems, USBItem
Dim strUSBName, strUSBID, strConnected, iUSBSize, USBNames, USBPNPIDs
Dim quote
quote=chr(34)

'only ignore Floppy and CDrom when testing. You can comment this out
'if bDebug then aIgnoreList = Array("FLOPPY","CDROM")

'ref http://www.devguru.com/Technologies/ado/quickref/record_fieldscollection.html

'create disconnected recordset -- note the ADOR
Set oRS = CreateObject("ADOR.Recordset")
oRS.Fields.Append "Model", adVarChar, MaxCharacters, adFldIsNullable
oRS.Fields.Append "PNPID", adVarChar, MaxCharacters, adFldIsNullable
oRS.Fields.Append "Size", adDouble, adFldIsNullable
oRS.Open

If Not IsCScript() and bDebug = True Then   'debug in CScript
WshShell.Run "CScript.exe " & quote & WScript.ScriptFullName & quote
    WScript.Quit                '...and stop running as Wscript
End If

If IsCScript() and bDebug = False Then   'If CScript and not debugging re-run with wscript...
WshShell.Run "WScript.exe " & quote & WScript.ScriptFullName & quote
    WScript.Quit                '...and stop running as WScript
End If

strNTName = objNet.UserName
GetName

'NEW!
If dExceptions.Exists(strComputer) Or dExceptions.Exists(strNTName) Then
AddExclude strComputer
End If

'Disable error messages...
If not bdebug then On Error Resume Next
If bDebug Then WScript.Echo "Debug mode"

'Connect to WMI
Set oWMI = GetObject("winmgmts:\\"& strComputer & "\root\cimv2")
'Bail if you can't connect to WMI
If Err <> 0 Then WScript.Quit

CheckNow True
CreateSink

Sub CheckNow(bStartup)
strConnected = ""
strUSBID = ""
strUSBName = ""

'This runs to pickup devices connected before script started

Set colitems = oWMI.ExecQuery("Select model, size, pnpdeviceID from Win32_diskdrive where interfacetype = 'USB' and size > 1")

For Each USBItem In colitems

  If USBItem.pnpdeviceID = strUSBID Then 'Ignore duplicate entries in same detection
   strUSBName = ""
  Else
   strUSBName = USBItem.model
   strUSBID = USBItem.pnpdeviceID
   iUSBSize = round(USBItem.Size /1024 /1024)

   For i = 0 To UBound(aIgnoreList)
    If InStr(ucase(strUSBID),uCase(aIgnoreList(i))) > 0 Then 'avoids type mismatch of binary compare
     If bDebug Then WScript.Echo "Skipping " & strUSBID & " which contains " & aIgnoreList(i)
     strUSBName = ""
    End If
  Next

  End If

  If len(strUSBName) > 1 Then
   oRS.AddNew
      oRS("Model") = strUSBName
      oRS("Size") = iUSBSize
      oRS("PNPID") = strUSBID
      oRS.Update
  End If

Next

If oRS.RecordCount> 0 Then Notifier strConnected, bStartup
End Sub

Sub CreateSink()
'This runs to look for new insertions of devices. "Within 5", below is a 5 second check interval

Dim strWQL 'Query that creates the sink
strWQL = "SELECT * FROM __InstanceCreationEvent WITHIN 5 WHERE Targetinstance ISA 'Win32_PNPEntity'" & _
" and TargetInstance.DeviceId like '%USBSTOR%'"

If bDebug Then Wscript.echo "Created WMI sink"

Set colMonitoredEvents = oWMI.ExecNotificationQuery(strWQL)
Do
  Set objLatestEvent = colMonitoredEvents.NextEvent
  CheckNow False
Loop
End Sub

Sub Notifier(strUSBType,bStartup)

If DateDiff("s",dLastTime,Now) <5 Then
  if bdebug then WScript.Echo "Skipping notification within 5 seconds of previous"
  Exit Sub
End If

if bDebug then Wscript.echo "USB insertion event detected"
Dim i
Dim strTime
strTime = Time

oRS.Sort = "Model"
oRS.MoveFirst
Do Until oRS.EOF
  If bVerbose Then
   strConnected = strConnected & oRS.Fields.Item("Model") & ", " & oRS.Fields.Item("size") &" MB," & " (" & oRS.Fields.Item("PNPID") & ")" & VbCrLf
  Else
   strConnected = strConnected & oRS.Fields.Item("Model") & ", " & oRS.Fields.Item("size") &" MB," & VbCrLf
  End If
oRS.MoveNext
Loop

If bStartUp = True Then ' initial event
  strSubject = "USB storage detected at logon onto " & strComputer
  strBody = "User " & objNet.Username & strMyName & ", had the following " & oRS.RecordCount& " USB storage device"
  If oRS.RecordCount> 1 Then strBody = strBody & "s"
  strBody= strBody & " found connected when monitoring began of " & strComputer & _
  " at " & strTime & " on " & Date & ":" & VbCrLf & VbCrLf
Else
  strSubject = "USB storage detected on " & strComputer
  strBody = "User " & objNet.Username & strMyName & " at " & strTime & " on " & Date & _
  ", connected to " & strComputer & " the following USB storage device:" & VbCrLf
End If

strBody = strBody & strConnected

If bCSV Then
  Dim CsvText
  oRS.MoveFirst
  Do Until oRS.EOF
  ' Iterate the dict. again for CSV data
   csvtext =CsvText & _
   Date & "," & strTime & "," & quote & objNet.Username & quote & "," & quote & strMyCSVName &_
   quote & "," & strComputer & "," & quote & oRS.Fields.Item("Model") & quote & "," & oRS.Fields.Item("size") & "," & quote & oRS.Fields.Item("PNPID") & quote & VbCrLf
  oRS.MoveNext
  Loop
   strBody = strBody & VbCrLf & VbCrLf & String(10,"=") & " CSV DATA " & String(10,"=") & VbCrLf & CsvText
End If

If bDebug Then strBody = strBody & VbCrLf & VbCrLf & "******* TEST MESSAGE ONLY ********"

Set m_objCDO = CreateObject("CDO.Message")
Set m_objCDOcon = CreateObject("CDO.Configuration")
'Setting up Mail
'Note that I am relying on a server that does not require authentication
'this is because the username/pw would be in plaintext, available to the
'user. You can use authentication -- see CDO docs

Set Fields = m_objCDOcon.Fields
With Fields
    .Item(cdoSendUsingMethod)       = 2
    .Item(cdoSMTPServer)            = strMailServer
    .Item(cdoSMTPServerPort)        = cdoSendUsingPort
    .Item(cdoSMTPConnectionTimeout) = 100
    .Update
End With

'Passing parameters to message object
Set m_objCDO.Configuration = m_objCDOcon

If bDebug Then strTo = strTestEmail

With m_objCDO
     .To       = strTo
     .From     = strFrom
End With

m_objCDO.TextBody = strBody
m_objCDO.Subject = strSubject

i = 0

'Retry if fails to send
    Do
  If bDebug Then Wscript.echo "Waiting to send mail loop"
    Err.Clear
    m_objCDO.Send
  WScript.Sleep 6000    'Wait a minute
  i = i + 1
    Loop Until Err.Number = 0 Or i = 10 'after 10 times bail

If bDebug then Wscript.echo "Mail sent"
Set m_objCDO = Nothing
Set m_objCDOcon = Nothing

If bNotify Then
  WShshell.popup message,60,"Security Violation",vbcritical + vbOKOnly + vbSystemModal
End If

If bAnnoy Then
  AnnoyUser()
End If

'empty
oRS.MoveFirst
Do While Not oRS.EOF
     oRS.Delete
     oRS.MoveNext
Loop

dLastTime = Now()
End Sub

Sub AnnoyUser()
Dim iAnnoy
iAnnoy = 0
strDrive = GetDriveLetter

For iAnnoy = 0 To 10
  If bDebug Then WScript.Echo "Beep...."
  if fso.DriveExists(strDrive) Then
   beep
  Else
   Exit Sub
  End If

  If iAnnoy = 10 Then
   wshShell.Popup "Beeps will continue until you remove this illegal device!",10,"VIOLATION! Remove the Drive Now!",vbCritical+vbOKOnly
   iAnnoy =0
  End If
Next

End Sub

Sub beep()
wshShell.run "cmd /C " & chr(34) & "@echo " & String(7,chr(7)) & chr(34),0,True
End Sub

Function GetDriveLetter()
If bDebug Then WScript.Echo "Getting drive letter of USB drive"
Dim colDiskDrives, oDiskDrive, colDrives, colLDrives, oLDrive
Dim strModel, strWQL, colPartitions, oPartition
Dim i

Set colDiskDrives = oWMI.ExecQuery("SELECT * FROM Win32_DiskDrive where InterfaceType='USB' and size > 0",,48)

    For Each oDiskDrive In colDiskDrives 'Get USB Drives. DeviceID looks like \\.\PHYSICALDRIVE1
      strModel = oDiskDrive.Caption
    strWQL = "ASSOCIATORS OF {Win32_DiskDrive.DeviceID='" & oDiskDrive.deviceID & _
   "'} WHERE AssocClass = Win32_DiskDriveToDiskPartition"
    Set colPartitions = oWMI.ExecQuery(strWQL,,48)
    For Each oPartition In colPartitions
    i = i + 1
    'WScript.Echo "Partition: " & oPartition.DeviceID 'Device ID looks like Disk #1, Partition #0
   strWQL = "ASSOCIATORS OF {Win32_DiskPartition.DeviceID='" & oPartition.DeviceID & _
   "'} WHERE AssocClass = Win32_LogicalDiskToPartition"

   Set colLDrives = oWMI.ExecQuery(strWQL,,48)
   For Each oLDrive In colLDrives
      GetDriveLetter = oLDrive.DeviceID 'Device ID looks like E:
   Next
    Next
   Next
End Function

Sub GetName 'Gets user's first and last from AD
If wshShell.ExpandEnvironmentStrings("%LOGONSERVER%") = strComputer Then
  strMyName =""
  Exit Sub
End If

'I could bind directly using the CN from oSI, but this was already written...
Dim objConnection, oRS, objCommand, root, sDomain
Const ADS_SCOPE_SUBTREE = 2
Set objConnection = CreateObject("ADODB.Connection")
Set objCommand = CreateObject("ADODB.Command")
objConnection.Provider = ("ADsDSOObject")
objConnection.Open "Active Directory Provider"
objCommand.ActiveConnection = objConnection

'Get the ADsPath for the domain to search.
Set root = GetObject("LDAP://rootDSE")
sDomain = root.Get("defaultNamingContext")

objCommand.CommandText = "SELECT samAccountName,description, givenname, sn FROM " & _
     "'LDAP://" & sdomain & "' WHERE samAccountName = '" & strNTName & "'"

objCommand.Properties("SearchScope") = ADS_SCOPE_SUBTREE
Set oRS = objCommand.Execute

'new version 2.2
If oRS.RecordCount = 0 Then
    strMyName = ""
Else

     strMyName = " (" & oRS("givenName").value & space(1) & oRS("sn").value

     If IsArray(oRS("Description")) Then
     Dim tArray
     tArray = oRS("Description")
     strDescription = tArray(0)
     Else
   If Len(oRS("Description"))>0 Then
    strDescription = oRS("Description")
   End If
  End If
End If

If Len(strDescription) > 0 Then
  strMyName = strMyName & ", " & strDescription & ")"
Else
  strMyName = strMyName & ")"
End If

strMyCSVName = Mid(strMyName,3,Len(strMyName)-3)

Set root = Nothing
Set oRS = Nothing
Set objCommand = Nothing
Set objConnection = Nothing

End Sub

Sub AddExclude(strComputer)
For i = 0 To dExceptions.Count -1 ' Iterate the array.
  If (lcase(ExcludeNames(i)) = LCase(strComputer)) Or (lcase(ExcludeNames(i)) = LCase(strNTName)) Then
   ReDim Preserve aIgnoreList(UBound(aIgnoreList)+1)
     aIgnoreList(UBound(aIgnoreList)) = PNPIDs(i)
     If bDebug Then WScript.echo StrComputer & " is excluded from detecting " & PNPIDs(i)
     Exit For
     End If
Next
End Sub

Function IsCScript()
    If (InStr(UCase(WScript.FullName), "CSCRIPT") <> 0) Then
        IsCScript = True
    Else
        IsCScript = False
    End If
End Function
Thanks,

Thursday, January 20, 2011 1:33 AM
0

Sign in to vote

Hi Ron,

Wow, what an absolute mess that is, no wonder your having trouble! There is one major security concern with the logic of the script, that is that as it runs at logon, the cscript process is owned by the user that executes it, therefore any user intelligent enough to terminate that process (which they will have permissions to do being the process owner) will completely bypass your security policy (that's what i'd do :)...very simple command:

C:>taskkill /f /im cscript.exe

To enforce your policy (once the script works) i'd recommend it is applied at computer startup. This ensures that the script is owned by local system which users will not have permission to terminate unless they have local admin rights, it also removes the need for certain sub routines in your script to check if devices were inserted before logon.

I think you would be better off starting again with this script than attempting to fix it's obvious security flaws. I can expand on the code i've already provided to produce the same functionality and ensure it is easier to under and update as required. Let me know

Cheers Matt :)

Thursday, January 20, 2011 7:42 AM
0

Sign in to vote

I would really appreciate if you could expand the script you sent me. I did try it today and it seemed to work. I didn't try to add a device to see if it still popped the banner up or not. I am just at a loss here, I dont know really what to do?

Thanks,

Ron
Thanks,

Thursday, January 20, 2011 7:57 AM
0

Sign in to vote

I think it would be a better idea to focus your efforts locking down the computer so it isn't possible for someone to plug in any unauthorized USB device in the first place... Epoxy, and strict software policies...

Thursday, January 20, 2011 6:17 PM
0

Sign in to vote

I would love to lock the machines down, but I can't I have about 600 Pc's and alot of them use external drives for various reason. I only want approved one to be used and i can't find another solution to help besides a vbs script. Thanks for the advice though. I'll keep looking

Thanks,

Ron
Thanks,

Friday, January 21, 2011 2:29 AM
0

Sign in to vote

Hi Ron,

No worries, working on a more elegant solution for you where if a user inserts an unapproved device into the system the user will recieve a popup message, and thier computername, logonname, firstname, lastname, ipaddress, macaddress will be logged centrally and the device will be automagically ejected (That's probably more annoying for them and less annoying for everyone else than a beeping message!). See this, Nice utility!

http://www.withopf.com/tools/deveject/

http://social.msdn.microsoft.com/Forums/en-US/csharpgeneral/thread/d2e5d16e-e7c9-48ef-88b8-3abf6e638384

I'll get back to you when I have some code together for you to test.

Cheers Matt :)

Friday, January 21, 2011 8:34 AM
0

Sign in to vote

Thanks Matt, I really appreciate this alot. I been working with your script that you sent me so far and it seems to be working except i'm not sure what its looking for as for what name do you put in as the device name?

deviceNames = Array("Kingston DT Elite HS 2.0 USB Device")

no matter what i use, it still pops up as an unapproved device.

Thanks again for all your help.

Thanks,
Ron
Thanks,

Friday, January 21, 2011 3:52 PM
0

Sign in to vote
Hi Ron

The deviceNames variable is an array of device models to exclude. To see the exact model name of your USB devices you can always get a copy of scriptomatic here:

http://www.microsoft.com/downloads/en/details.aspx?FamilyID=09dfc342-648b-4119-b7eb-783b0f7d1178&displaylang=en

Plug in your USB device, open scriptomatic as an admin user, select "Win32_DiskDrive", Run the script and look for "model" in the results...or you could just run this command in powershell assuming you have it installed.

PS C:>Get-WMIObject -query "Select Model From 'Win32_DiskDrive' Where InterfaceType = 'USB'" | Format-List -property Model

I've got a secured solution for you working that automatically ejects unapproved USB storage devices...however running it at computer startup using local system creates two problems.

As the script runs under the local system, not within the user's security context, they don't see the popup message and won't know why their USB device doesn't work.
It needs to be deployed as a scheduled task via a startup script, rather than running directly using a startup script otherwise it run's in an infinate loop significantly delaying the startup process (it will eventually time out after 10 minutes.)

So i'll post some code for you that works when run at logon that i've tested and got working for you. Once your happy with that it should be difficult to get it to email you the results of the popup message.

Cheers Matt :)
Saturday, January 22, 2011 5:56 AM

Hi Ron,

Here is some code for you to test. Read the code comments and the hyperlinks, download the "deveject.exe" utility and copy it to the system32 directory. Search for the string "Testing code block" then change "testdc01" to the name of the computer you want to test this on. Once you happy it works then you can remove lines 37-42 (testing code block). You will also need to change lines 34-36 to ensure you USB storage devices models are included in the "deviceExclusions" array...same goes for user's or computer you want excluded.

deviceExclusions = Array("Kingston DT Elite HS 2.0 USB Device")
userExclusions = Array("User1","User2")
computerExclusions = Array("Computer1","Computer2")

Let me know how that works for you, will be easy to add the email function to it.

Cheers Matt :)

'-------------------------------------------------------------------------------
'Script Name : RestrictUSBStorageDevice.vbs
'Author   : Matthew Beattie
'Created   : 21/10/11
'Description : This script monitors for the addition of USB Storage Devices to the system. If the device is not approved
'      : the user will be notified and device will be ejected. It is "assumed" the "deveject.exe" utility available 
'      : from the link below has been deployed to the system32 directory on all systems. For further documentation:
'      :
'      : http://www.microsoft.com/technet/scriptcenter/resources/scriptshop/shop0805.mspx
'      : http://www.withopf.com/tools/deveject/
'-------------------------------------------------------------------------------
'Initialization Section 
'-------------------------------------------------------------------------------
Option Explicit
Dim objFSO, objSink, objWMI, sysInfo, wshShell, wshNetwork, systemPath
Dim scriptBaseName, scriptPath, ipAddress, macAddress
Dim userExclusions, computerExclusions, deviceExclusions
Dim hostName, userName, userInfo, model, fileName
On Error Resume Next
  Set wshShell  = CreateObject("WScript.Shell")
  Set wshNetwork = CreateObject("WScript.Network")
  Set objFSO   = CreateObject("Scripting.FileSystemObject")
  Set sysInfo  = CreateObject("ADSystemInfo")
  hostName    = wshNetwork.ComputerName
  Set objWMI   = GetObject("winmgmts:\\" & hostName & "\root\cimv2")
  Set objSink  = WScript.CreateObject("WbemScripting.SWbemSink", "Sink_")
  scriptBaseName = objFSO.GetBaseName(Wscript.ScriptFullName)
  scriptPath   = objFSO.GetFile(Wscript.ScriptFullName).ParentFolder.Path
  systemPath   = objFSO.GetSpecialFolder(1)
  fileName    = "deveject.exe"
  '----------------------------------------------------------------------------
  'Configure the user, computer and USB Storage device exclusions here.
  '----------------------------------------------------------------------------
  deviceExclusions  = Array("Kingston DT Elite HS 2.0 USB Device")
  userExclusions   = Array("User1","User2")
  computerExclusions = Array("Computer1","Computer2")
  '----------------------------------------------------------------------------
  'Testing code block. This limits script processing to a single system only.
  '----------------------------------------------------------------------------
  If StrComp(hostName, "testdc01", vbTextCompare) <> 0 Then
   WScript.Quit
  End If
  '----------------------------------------------------------------------------
  'Execute the scripts primary Function.
  '----------------------------------------------------------------------------
  ProcessScript
  If Err.Number <> 0 Then
   Wscript.Quit
  End If
On Error Goto 0
'-------------------------------------------------------------------------------
'Sub Rountine Processing Section
'-------------------------------------------------------------------------------
Sub Sink_OnObjectReady(objEvent, objContext)
  Dim model, i
  '----------------------------------------------------------------------------
  'Attempt to enumerate the Model of the USB device up to 3 times as
  'Windows may not have installed the driver yet!
  '----------------------------------------------------------------------------
  For i = 1 To 3
   model = GetUSBModel
   If model <> "" Then
     Exit For
   Else
     WScript.Sleep 10000
   End If
  Next
  CheckUSBDevice model
End Sub
'-------------------------------------------------------------------------------
'Functions Processing Section
'-------------------------------------------------------------------------------
'Name    : ProcessScript -> Primary Function that controls all other script processing.
'Parameters : None     ->
'Return   : None     ->
'-------------------------------------------------------------------------------
Function ProcessScript
  Dim query, logonName, i
  query = "Select * From __InstanceCreationEvent Within 5 Where " & _
      "TargetInstance Isa 'Win32_DiskDrive' And " & _
      "TargetInstance.InterfaceType = 'USB'"
  '----------------------------------------------------------------------------
  'Ensure the "devEject.exe" file exist within the scripts working directory.
  '----------------------------------------------------------------------------
  If Not objFSO.FileExists(systemPath & "\" & fileName) Then
   Exit Function
  End If
  '----------------------------------------------------------------------------
  'Enumerate the systems IP and MAC address for logging.
  '----------------------------------------------------------------------------
  If Not GetIPConfig(hostName, ipAddress, macAddress) Then
   ipAddress = "0.0.0.0"
   macAddress = "00:00:00:00:00:00"
  End If
  '----------------------------------------------------------------------------
  'Enumerate the User's LogonName, FirstName and LastName for logging.
  '----------------------------------------------------------------------------
  userInfo = GetUserInfo
  On Error Resume Next
   logonName = Split(userInfo, ",")(0)
   If Err.Number <> 0 Then
     logonName = ""
   End If
  On Error Goto 0
  '----------------------------------------------------------------------------
  'Ensure USB storage devices already inserted are enumerated.
  '----------------------------------------------------------------------------
  model = GetUSBModel
  If model <> "" Then
   CheckUSBDevice model
  End If
  '----------------------------------------------------------------------------
  'Ensure exclued users are not processed.
  '----------------------------------------------------------------------------
  For i = 0 To UBound(userExclusions)
   If StrComp(logonName, userExclusions(i), vbTextCompare) = 0 Then
     Exit Function
   End If
  Next
  '----------------------------------------------------------------------------
  'Ensure exclued computers are not processed.
  '----------------------------------------------------------------------------
  For i = 0 To UBound(computerExclusions)
   If StrComp(hostName, computerExclusions(i), vbTextCompare) = 0 Then
     Exit Function
   End If
  Next
  '----------------------------------------------------------------------------
  'Execute WMI Query to monitor USB devices.
  '----------------------------------------------------------------------------
  On Error Resume Next
   objWMI.ExecNotificationQueryAsync objSink, query
   If Err.Number <> 0 Then
     Exit Function
   End If
  On Error Goto 0
  '----------------------------------------------------------------------------
  'Process script indefinately waiting for USB Storage Device events.
  '----------------------------------------------------------------------------
  Do
   WScript.Sleep 5000
  Loop
End Function
'-------------------------------------------------------------------------------
'Name    : GetIPConfig -> Enumerates the IP & MAC Address of the system via WMI
'Parameters : hostName  -> String containing the hostname of the computer to enumerate the IP configuration for.
'      : ipAddress  -> Input/Output : Variable assigned to the IP Address of the system.
'Parameters : macAddress -> Input/Output : Variable assigned to the MAC Address of the system.
'Return   : GetIPConfig -> Returns True and the systems IP & MAC Address if successful otherwise returns False.
'-------------------------------------------------------------------------------
Function GetIPConfig(hostName, ipAddress, macAddress)
  Dim wmi, ipConfig, query
  GetIPConfig = False
  ipAddress  = ""
  macAddress = ""
  query    = "Select * From Win32_NetworkAdapterConfiguration Where IPEnabled = True"
  On Error Resume Next
   Set wmi = GetObject("winmgmts:{impersonationLevel=impersonate}!\\" & hostName & "\root\cimv2")
   If Err.Number <> 0 Then
     Exit Function
   End If
   For Each ipConfig in wmi.ExecQuery(query)
     If Err.Number <> 0 Then
      LogMessage 1, "Executing WMI query " & DQ(query)
      Exit Function
     End If
     ipAddress = ipConfig.IPAddress(0)
     macAddress = ipConfig.MACAddress(0)
     If ipAddress <> "" And ipAddress <> "0.0.0.0" And MACAddress <> "" Then
      Exit For
     End If
   Next
  On Error Goto 0
  GetIPConfig = True
End Function
'-------------------------------------------------------------------------------
'Name    : GetUserInfo -> Attempts to Enumerate the user's LogonName, FirstName, Surname.
'Parameters : None    -> 
'Return   : GetUserInfo -> Returns a comma seperate string containing the users LogonName, FirstName And Surname.
'-------------------------------------------------------------------------------
Function GetUserInfo
  Dim objUser, userName, logonServer, firstName, lastName
  FirstName = ""
  Lastname = ""
  On Error Resume Next
   userName  = wshNetwork.UserName
   logonServer = wshShell.ExpandEnvironmentStrings("%logonserver%")
   '-------------------------------------------------------------------------
   'The user must be logged on locally so don't get the properties from AD.
   '-------------------------------------------------------------------------
   If StrComp(logonServer, hostName, vbTextCompare) = 0 Then
     userInfo = userName & "," & firstName & "," & lastName
     Exit Function
   End If
   '-------------------------------------------------------------------------
   'As the user's logon server is a domain controller, enumerate their user properties from AD.
   '-------------------------------------------------------------------------
   Set objUser = GetObject("LDAP://" & sysInfo.userName)
   firstName  = ProperCase(objUser.givenName)
   LastName  = ProperCase(objUser.sn)
  On Error Goto 0
  GetUserInfo = UserName & "," & firstName & "," & lastName  
End Function
'-------------------------------------------------------------------------------
'Name    : ProperCase -> Converts a string to "Proper" case.
'Parameters : text    -> String text to be converted.
'Return   : ProperCase -> Returns the converted String in Proper case.
'-------------------------------------------------------------------------------
Function ProperCase(text)
  Dim wordArray, i
  On Error Resume Next
   wordArray = Split(text, " ")
   For i = 0 To Ubound(wordArray)
     wordArray(i) = UCase(Left(wordArray(i), 1)) & Lcase(Mid(wordArray(i), 2))
   Next
   ProperCase = Join(wordArray, " ")
  On Error Goto 0
End Function
'-------------------------------------------------------------------------------
'Name    : DQ     -> Place double quotes around a string and replace double quotes  
'      :       -> within the string with pairs of double quotes.  
'Parameters : stringValue -> String value to be double quoted  
'Return   : DQ     -> Double quoted string.  
'------------------------------------------------------------------------------- 
Function DQ (ByVal stringValue)  
  If stringValue <> "" Then 
   DQ = """" & Replace (stringValue, """", """""") & """"  
  Else 
   DQ = """""" 
  End If 
End Function
'-------------------------------------------------------------------------------
'Name    : GetUSBModel -> Enumerates the USB Storage Device Model Name.
'Parameters : None    -> 
'Return   : GetUSBModel -> Returns the the USB Storage Device Model Name.
'-------------------------------------------------------------------------------
Function GetUSBModel
  Dim query, model, results, result
  model   = ""
  query   = "Select Model From Win32_DiskDrive Where InterfaceType = 'USB'"
  On Error Resume Next
   Set results = objWMI.ExecQuery(query)
   If Err.Number <> 0 Then
     Exit Function
   End If
   For Each result In results
     model = result.model
     If Err.Number <> 0 Then
      model = ""
      Exit For
     End If
   Next
  On Error Goto 0
  GetUSBModel = model
End Function
'-------------------------------------------------------------------------------
'Name    : EjectUSBDevice -> Prompts the User and Executes a command to eject the USB device.
'Parameters : model     -> String containing the USB Device model to eject. 
'Return   : None      -> 
'-------------------------------------------------------------------------------
Function EjectUSBDevice(model)
  Dim command
  '----------------------------------------------------------------------------
  'Prompt the user then automatically eject the USB device.
  '----------------------------------------------------------------------------
  On Error Resume Next
   wshShell.Popup "Using an unapproved USB storage devices is a voilation of security policy. " & vbCrLf & _
           "Your actions are being audited. Your Administrator has been notified." & vbCrLf & vbCrLf & _
           ipAddress & "," & macAddress & "," & userInfo & "," & hostName & "," & model, 7, scriptBaseName, 48
   command = "cmd /c " & fileName & " -EjectName:" & DQ(model)
   wshShell.Run command, 0, False
  On Error Goto 0
End Function
'-------------------------------------------------------------------------------
'Name    : CheckUSBDevice -> Prompts the User and Executes a command to eject the USB device.
'Parameters : model     -> String containing the USB Device model to eject. 
'Return   : CheckUSBDevice -> 
'-------------------------------------------------------------------------------
Function CheckUSBDevice(model)
  Dim approved, i
  approved = False
  '----------------------------------------------------------------------------
  'Ensure USB devices that have been approved for corporate use are not ejected.
  '----------------------------------------------------------------------------
  For i = 0 To UBound(deviceExclusions)
   If StrComp(model, deviceExclusions(i), vbTextCompare) = 0 Then
     approved = True
     Exit For
   End If
  Next
  '----------------------------------------------------------------------------
  'The device has not been approved so Eject it.
  '----------------------------------------------------------------------------
  If Not approved Then
   EjectUSBDevice model
  End If
End Function
'-------------------------------------------------------------------------------

Proposed as answer by Richard MuellerMVP Saturday, January 22, 2011 6:51 PM

Saturday, January 22, 2011 6:39 AM

0

Sign in to vote

Thank You so much Matt. I will be testing this out in the next couple days. I will let you know how it works.

Thanks again,

Ron
Thanks,

Saturday, January 22, 2011 3:21 PM

Hi Ron,

No worries, also here is another script that you can apply to a computer startup script to deploy the "deveject.exe" utility to the system folder on your workstations.

Instructions:

Create a new group policy or add a startup script to an existing group policy to the OU containing you client systems.
Create a folder in the startup scripts folder Named "SystemFiles". EG:
\\%domainName%\SYSVOL\%domainName%\Policies\{%gpoguid%}\Machine\Scripts\Startup\SystemFiles
Copy any useful executable files in the "SystemFiles" folder. For Example, deveject.exe, psexec.exe, robocopy.exe
Cut and Paste the code and save it as "Deploy.vbs" within the Startup scripts folder. EG
\\%domainName%\SYSVOL\%domainName%\Policies\{%gpoguid%}\Machine\Scripts\Startup\Deploy.vbs
Add the "Deploy.vbs" to the GPO startup.

The next time your computers reboot, they will compare copies of the executables in their system directory with the copies in the Group Policies "SystemFiles" folder and ensure the most recent version is copied\updated to their local system directory...This is the "poor man's" method of deployment for those that don't have SCCM

Here is the code. Hope this helps

Cheers Matt :)

'-------------------------------------------------------------------------------
'Script Name : Deploy.vbs
'Author   : Matthew Beattie
'Created   : 22/10/11
'Description : This script deploys all files in the "SystemFiles" folder in the scripts working directory in sysvol to the 
'      : local system directory.
'-------------------------------------------------------------------------------
'Initialization Section 
'-------------------------------------------------------------------------------
Option Explicit
Dim objFSO, scriptPath, systemPath
On Error Resume Next
  Set objFSO   = CreateObject("Scripting.FileSystemObject")
  scriptPath   = objFSO.GetFile(Wscript.ScriptFullName).ParentFolder.Path
  systemPath   = objFSO.GetSpecialFolder(1)
  ProcessScript
  If Err.Number <> 0 Then
   WScript.Quit
  End If
On Error Goto 0
'-------------------------------------------------------------------------------
'Functions Processing Section
'-------------------------------------------------------------------------------
'Name    : ProcessScript -> Primary Function that controls all other script processing.
'Parameters : None     ->
'Return   : None     ->
'-------------------------------------------------------------------------------
Function ProcessScript
  Dim folderSpec, fileName
  folderSpec = scriptPath & "\SystemFiles"
  If Not objFSO.FolderExists(folderSpec) Then
   Exit Function
  End If
  '----------------------------------------------------------------------------
  'Ensure all files in the "SystemFiles" folder in the group policy in Sysvol are deployed to the local system directory.
  '----------------------------------------------------------------------------
  If Not UpdateFiles(folderSpec, systemPath) Then
   Exit Function
  End If
End Function
'-------------------------------------------------------------------------------
'Name    : UpdateFiles -> Copies or updates all files from a specified folder if required.
'Parameters : folderSpec -> String containing the Source Folder specification containing the files to update.
'Return   : UpdateFiles -> Returns True if all files were copied or are up to date otherwise returns False.
'-------------------------------------------------------------------------------
Function UpdateFiles(sourceFolder, targetFolder)
  Dim files, file, result
  UpdateFiles = False
  On Error Resume Next
   Set files = objFSO.GetFolder(sourceFolder).Files
   If Err.Number <> 0 Then
     Exit Function
   End If
  On Error Goto 0
  For Each file In files
   Do
     result = UpdateFile(file.Path, targetFolder & "\" & file.Name)
     If result <> 0 Then
      Exit Function
     End If
   Loop Until True
  Next
  UpdateFiles = True
End Function
'-------------------------------------------------------------------------------
'Name    : UpdateFile -> Copy or update a file if required.
'Parameters : sourceFile -> String containing the Source file specification.
'      : targetFile -> String containing the target file specification.
'Return   : UpdateFile -> 0 If file already up-to-date or copied successfully. Error code otherwise.
'-------------------------------------------------------------------------------
Function UpdateFile(sourceFile, targetFile)
  Dim objSource, objTarget
  On Error Resume Next
   If objFSO.FileExists(targetFile) Then
     Set objSource = objFSO.GetFile(sourceFile)
     Set objTarget = objFSO.GetFile(targetFile)
     If Err.Number = 0 Then
      If objSource.Size <> objTarget.Size Or objSource.DateLastModified <> objTarget.DateLastModified Then
        objTarget.Attributes = 0
        objSource.Copy targetFile, True
        objFSO.GetFile(targetFile).Attributes = 32 'ensure the target file is not read-only.
      End If
     End If
   Else
     objFSO.CopyFile sourceFile, targetFile
     objFSO.GetFile(targetFile).Attributes = 32    'ensure the target file is not read-only.
   End If
   If Err.Number <> 0 Then
     LogMessage 1, "Copying " & DQ(sourceFile) & " to " & DQ(targetFile)
   End If
   UpdateFile = Err.Number
  On Error Goto 0
End Function
'-------------------------------------------------------------------------------
'Name    : DQ     -> Place double quotes around a string and replace double quotes  
'      :       -> within the string with pairs of double quotes.  
'Parameters : stringValue -> String value to be double quoted  
'Return   : DQ     -> Double quoted string.  
'-------------------------------------------------------------------------------
Function DQ (ByVal stringValue)  
  If stringValue <> "" Then 
   DQ = """" & Replace (stringValue, """", """""") & """"  
  Else 
   DQ = """""" 
  End If 
End Function
'-------------------------------------------------------------------------------

Saturday, January 22, 2011 11:37 PM

0

Sign in to vote

Hey Matt, I been working with the script today, I ran into one problem.... I can't get the script to run? all I did was change the testdc01 to the name of the PC i was on and nothing happened. Any help on what i'm doing wrong? I put the script on the desktop and just manually ran it from there or tried.

Thanks,

Ron
Thanks,

Monday, January 24, 2011 4:58 AM

Hi Ron

Your probably not doing anything wrong. The script won't give you any visual indication that it is running in the background waiting for the insertion of an unapproved USB device. Check task manager and look for the WScript.exe process. To simulate this see the code below, if you run it nothing will happen but you will see WScript.exe in task manager as it's running in an infinate loop (which is what you want for the duration of the user's logon session). You can kill the process using this command:

taskkill /f /im wscript.exe

Let me know if you still need help. You can safely take out the testing code block altogether.

Option Explicit
Dim wshNetwork, hostName
On Error Resume Next
  Set wshNetwork = CreateObject("WScript.Network")
  hostName    = wshNetwork.ComputerName
  '----------------------------------------------------------------------------
  'Testing code block. This limits script processing to a single system only.
  '----------------------------------------------------------------------------
  If StrComp(hostName, "testdc01", vbTextCompare) <> 0 Then
   WScript.Quit
  End If
  '----------------------------------------------------------------------------
  'Process an infinate loop. You must kill the WScript.exe process in Task Manager.
  '----------------------------------------------------------------------------
  Do
   WScript.Sleep 5000
  Loop
On Error Goto 0

Monday, January 24, 2011 5:29 AM

0

Sign in to vote

I was looking for the wscript.exe in task manager. It wasn't there. I'll take out the testing part and see what happens next.

Thanks,

Ron
Thanks,

Monday, January 24, 2011 5:33 AM
0

Sign in to vote

Ok, took the testing part out and it still will not start. I get no errors or anything, just no go.
Thanks,

Monday, January 24, 2011 5:41 AM
0

Sign in to vote

Hi Ron

The reason it is not working for you is the following code in the ProcessScript Function:

If Not objFSO.FileExists(systemPath & "\" & fileName) Then
Exit Function
End If

...in other words if the "deveject.exe" file does not exist within "C:\Windows\System32" Then the script Exits the function which also exits script processing.

Download the "deveject.exe" utility from:

http://www.withopf.com/tools/deveject/deveject-11.zip

Copy that to the system32 folder on the system you are testing it on and let me know if you still need help

Cheers Matt :)

Monday, January 24, 2011 6:59 AM

Hi Ron,

Although i've included plenty of code comments, I just wanted to clarify the setup of these scripts for you and include some instructions to ensure you can configure the setup in your environment...

The solution i've coded relies on the "deveject.exe" utility existing in system folder.
The solution requires the use of two group polices, one for computer startup to apply the "Deploy.vbs" script which copies the "deveject.exe" executable from the group polices location in sysvol to the system folder on your client workstations, the other for user logon to apply the "RestrictUSBStorageDevice.vbs" script at logon which monitors USB devices and relies on the "deveject.exe" utility existing within the system folder to execute a command that automatically ejects unapproved devices.
The "Deploy.vbs" script should be applied using a computer startup script. It ensures the "deveject.exe" utility is copied from sysvol to the system folder on all client workstations. You can choose to use this script or any another deployment method (SCCM for example.)
Exclusions to the script can be easily added by user, computer or USB device model name by editing variables within the "RestrictUSBStorageDevice.vbs" script.

Please be aware this solution has the following caveats:

As the "RestrictUSBStorageDevice.vbs" script is executed by the user at logon, it runs under their securtiy context and therefore the user has permissions to terminate the WScript.exe process. Unless you write an application to install a Windows Service that monitors USB storage devices, i'm not aware of another option that ensures the user recieves the popup message.
It relies on a third party executable to be deployed to the system directory of you client workstations.
Updating Exclusions requires your client systems to logoff\logon.

Adding functionality to have the script email you results is easy. For example:

'-------------------------------------------------------------------------------
Function ProcessScript
  Dim sender, recipient, subject, content, smtpServer, portNumber, fileSpecs
  '----------------------------------------------------------------------------
  'The rest of the code will be merged here. Once the unapproved devices is detected, send the email.
  '----------------------------------------------------------------------------
  fileSpecs = Array("")
  sender   = "alert@domain.com"
  recipient = "admin@domain.com"
  subject  = "USB Storage Device Report"
  content  = ipAddress & "," & macAddress & "," & userInfo & "," & hostName & "," & model
  smtpServer = "mailServer.domain.com"
  portNumber = 25
  '----------------------------------------------------------------------------
  'Send the email report to the administrator.
  '----------------------------------------------------------------------------
  If Not SendEmail(sender, recipient, subject, content, fileSpecs, smtpServer, portNumber) Then
   Exit Function
  End If
End Function
'-------------------------------------------------------------------------------
'Name    : SendEmail -> Sends an Email. Requires an SMTP Relay Server.
'Parameters : sender   -> String containing the senders email address.
'      : recipient -> String containing the recipients email address.
'      : subject  -> String containing the email subject line.
'      : content  -> String containing the body of the email message.
'      : fileSpecs -> Array containing the Folder Paths and file names of the email attachments to send.
'      : smtpServer -> String containing the SMTP Server's FQDN.
'      : portNumber -> Integer containing the SMTP Server's Port Number.
'Return   : SendEmail -> Returns True if the email was succesfully send otherwise returns False.
'-------------------------------------------------------------------------------
Function SendEmail(sender, recipient, subject, content, fileSpecs, smtpServer, portNumber)
  Dim objEmail, errorCount, emailAddresses, i
  SendEmail = False
  errorCount = 0
  '----------------------------------------------------------------------------
  'Ensure the fileSpecs parameter is a valid array.
  '----------------------------------------------------------------------------
  If Not IsArray(fileSpecs) Then
   fileSpecs = Array(fileSpecs)
  End If
  '----------------------------------------------------------------------------
  'Create the Email and set the properties.
  '----------------------------------------------------------------------------
  On Error Resume Next
   Set objEmail = CreateObject("CDO.Message")
   If Err.Number <> 0 Then
     Exit Function
   End If
   objEmail.From   = sender
   objEmail.To    = recipient
   objEmail.Subject = subject
   objEmail.Textbody = content
   '-------------------------------------------------------------------------
   'Add each attachment in the array of attachments to the email.
   '-------------------------------------------------------------------------
   For i = 0 To UBound(fileSpecs)
     Do
      objEmail.AddAttachment fileSpecs(i)
      If Err.Number <> 0 Then
        errorCount = errorCount + 1
        Exit Do
      End If
     Loop Until True
   Next
   '-------------------------------------------------------------------------
   'Configure the email properties.
   '-------------------------------------------------------------------------
   objEmail.Configuration.Fields.Item("http://schemas.microsoft.com/cdo/configuration/sendusing")   = 2
   objEmail.Configuration.Fields.Item("http://schemas.microsoft.com/cdo/configuration/smtpserver")   = smtpServer
   objEmail.Configuration.Fields.Item("http://schemas.microsoft.com/cdo/configuration/smtpserverport") = portNumber
   objEmail.Configuration.Fields.Update
   objEmail.Send
   '-------------------------------------------------------------------------
   'Send the Email.
   '-------------------------------------------------------------------------
   If Err.Number <> 0 Then
     Exit Function
   End If
  On Error Goto 0
  '----------------------------------------------------------------------------
  'Ensure the function returns False if their were any errors were encountered.
  '----------------------------------------------------------------------------
  If errorCount <> 0 Then
   Exit Function
  End If
  SendEmail = True
End Function
'-------------------------------------------------------------------------------

Cheers Matt :)

Monday, January 24, 2011 11:30 AM

Hi Ron,

Although i've included plenty of code comments, I just wanted to clarify the setup of these scripts for you and include some instructions to ensure you can configure the setup in your environment...

The solution i've coded relies on the "deveject.exe" utility existing in system folder.
The solution requires the use of two group polices, one for computer startup to apply the "Deploy.vbs" script which copies the "deveject.exe" executable from the group polices location in sysvol to the system folder on your client workstations, the other for user logon to apply the "RestrictUSBStorageDevice.vbs" script at logon which monitors USB devices and relies on the "deveject.exe" utility existing within the system folder to execute a command that automatically ejects unapproved devices.
The "Deploy.vbs" script should be applied using a computer startup script. It ensures the "deveject.exe" utility is copied from sysvol to the system folder on all client workstations. You can choose to use this script or any another deployment method (SCCM for example.)
Exclusions to the script can be easily added by user, computer or USB device model name by editing variables within the "RestrictUSBStorageDevice.vbs" script.

Please be aware this solution has the following caveats:

As the "RestrictUSBStorageDevice.vbs" script is executed by the user at logon, it runs under their securtiy context and therefore the user has permissions to terminate the WScript.exe process. Unless you write an application to install a Windows Service that monitors USB storage devices, i'm not aware of another option that ensures the user recieves the popup message.
It relies on a third party executable to be deployed to the system directory of you client workstations.
Updating Exclusions requires your client systems to logoff\logon.

Adding functionality to have the script email you results is easy. For example:

'-------------------------------------------------------------------------------
Function ProcessScript
  Dim sender, recipient, subject, content, smtpServer, portNumber, fileSpecs
  '----------------------------------------------------------------------------
  'The rest of the code will be merged here. Once the unapproved devices is detected, send the email.
  '----------------------------------------------------------------------------
  fileSpecs = Array("")
  sender   = "alert@domain.com"
  recipient = "admin@domain.com"
  subject  = "USB Storage Device Report"
  content  = ipAddress & "," & macAddress & "," & userInfo & "," & hostName & "," & model
  smtpServer = "mailServer.domain.com"
  portNumber = 25
  '----------------------------------------------------------------------------
  'Send the email report to the administrator.
  '----------------------------------------------------------------------------
  If Not SendEmail(sender, recipient, subject, content, fileSpecs, smtpServer, portNumber) Then
   Exit Function
  End If
End Function
'-------------------------------------------------------------------------------
'Name    : SendEmail -> Sends an Email. Requires an SMTP Relay Server.
'Parameters : sender   -> String containing the senders email address.
'      : recipient -> String containing the recipients email address.
'      : subject  -> String containing the email subject line.
'      : content  -> String containing the body of the email message.
'      : fileSpecs -> Array containing the Folder Paths and file names of the email attachments to send.
'      : smtpServer -> String containing the SMTP Server's FQDN.
'      : portNumber -> Integer containing the SMTP Server's Port Number.
'Return   : SendEmail -> Returns True if the email was succesfully send otherwise returns False.
'-------------------------------------------------------------------------------
Function SendEmail(sender, recipient, subject, content, fileSpecs, smtpServer, portNumber)
  Dim objEmail, errorCount, emailAddresses, i
  SendEmail = False
  errorCount = 0
  '----------------------------------------------------------------------------
  'Ensure the fileSpecs parameter is a valid array.
  '----------------------------------------------------------------------------
  If Not IsArray(fileSpecs) Then
   fileSpecs = Array(fileSpecs)
  End If
  '----------------------------------------------------------------------------
  'Create the Email and set the properties.
  '----------------------------------------------------------------------------
  On Error Resume Next
   Set objEmail = CreateObject("CDO.Message")
   If Err.Number <> 0 Then
     Exit Function
   End If
   objEmail.From   = sender
   objEmail.To    = recipient
   objEmail.Subject = subject
   objEmail.Textbody = content
   '-------------------------------------------------------------------------
   'Add each attachment in the array of attachments to the email.
   '-------------------------------------------------------------------------
   For i = 0 To UBound(fileSpecs)
     Do
      objEmail.AddAttachment fileSpecs(i)
      If Err.Number <> 0 Then
        errorCount = errorCount + 1
        Exit Do
      End If
     Loop Until True
   Next
   '-------------------------------------------------------------------------
   'Configure the email properties.
   '-------------------------------------------------------------------------
   objEmail.Configuration.Fields.Item("http://schemas.microsoft.com/cdo/configuration/sendusing")   = 2
   objEmail.Configuration.Fields.Item("http://schemas.microsoft.com/cdo/configuration/smtpserver")   = smtpServer
   objEmail.Configuration.Fields.Item("http://schemas.microsoft.com/cdo/configuration/smtpserverport") = portNumber
   objEmail.Configuration.Fields.Update
   objEmail.Send
   '-------------------------------------------------------------------------
   'Send the Email.
   '-------------------------------------------------------------------------
   If Err.Number <> 0 Then
     Exit Function
   End If
  On Error Goto 0
  '----------------------------------------------------------------------------
  'Ensure the function returns False if their were any errors were encountered.
  '----------------------------------------------------------------------------
  If errorCount <> 0 Then
   Exit Function
  End If
  SendEmail = True
End Function
'-------------------------------------------------------------------------------

Cheers Matt :)

Marked as answer by IamMred Thursday, January 27, 2011 12:28 AM

Monday, January 24, 2011 11:30 AM

0

Sign in to vote

Matt, Thanks man so much for the script. I got it working great today. I do have one question though, where do i put this last script about email? When i add it to the bottom of the script, it bombs out? If i remove the script it continues to run in a cycle and does exactly what its supposed to do. This is going to be a great help and I cant stress enough my thanks to you on this.

Thanks,

Ron
Thanks,

Tuesday, January 25, 2011 2:36 AM
0

Sign in to vote

Instead of email, could i just have it log all that info to a certain file? That may even be better? how difficult would that be to add instead of emailing ?

Thanks again,

Ron
Thanks,

Tuesday, January 25, 2011 2:37 AM

Hi Ron,

Whilst this thread has already been marked as the answer, your additional request is very easy to implement. Here are instructions on how to set up the logging:

Create a share on several of your domain controllers or member servers (as long as you pick atleast 2 servers for logging redundancy in your infrastructure)
Name the share "Logs$" to prevent people browsing
Grant the "Everyone" security principal at minimum the "Change" permission on the share
Grant the "Authenticated Users" security principal "Modify" permissions on the folder
Change the "shareNames" variable in the script below to indicate your server names.

Here is the modified version of the "RestrictUSBStorageDevices.vbs" to include centralised logging. Hope this helps

Cheers Matt :)

P.S...I think you owe me a beer by now :)

'-------------------------------------------------------------------------------
'Script Name : RestrictUSBStorageDevice.vbs
'Author   : Matthew Beattie
'Created   : 21/10/11
'Description : This script monitors for the addition of USB Storage Devices to the system. If the device is not approved
'      : the user will be notified and device will be ejected. It is "assumed" the "deveject.exe" utility available 
'      : from the link below has been deployed to the system32 directory on all systems. For further documentation:
'      :
'      : http://www.microsoft.com/technet/scriptcenter/resources/scriptshop/shop0805.mspx
'      : http://www.withopf.com/tools/deveject/
'-------------------------------------------------------------------------------
'Initialization Section 
'-------------------------------------------------------------------------------
Option Explicit
Const ForAppending = 8
Dim objFSO, objSink, objWMI, sysInfo, wshShell, wshNetwork, systemPath
Dim scriptBaseName, scriptPath, scriptLogPath, localLogPath, ipAddress, macAddress
Dim userExclusions, computerExclusions, deviceExclusions
Dim hostName, userName, userInfo, model, fileName
On Error Resume Next
  Set wshShell  = CreateObject("WScript.Shell")
  Set wshNetwork = CreateObject("WScript.Network")
  Set objFSO   = CreateObject("Scripting.FileSystemObject")
  Set sysInfo  = CreateObject("ADSystemInfo")
  hostName    = wshNetwork.ComputerName
  Set objWMI   = GetObject("winmgmts:\\" & hostName & "\root\cimv2")
  Set objSink  = WScript.CreateObject("WbemScripting.SWbemSink", "Sink_")
  localLogPath  = wshShell.ExpandEnvironmentStrings("%temp%")
  scriptBaseName = objFSO.GetBaseName(Wscript.ScriptFullName)
  scriptPath   = objFSO.GetFile(Wscript.ScriptFullName).ParentFolder.Path
  systemPath   = objFSO.GetSpecialFolder(1)
  fileName    = "deveject.exe"
  '----------------------------------------------------------------------------
  'Configure the user, computer and USB Storage device exclusions here.
  '----------------------------------------------------------------------------
  deviceExclusions  = Array("Kingston DT Elite HS 2.0 USB Device")
  userExclusions   = Array("User1","User2")
  computerExclusions = Array("Computer1","Computer2")
  '----------------------------------------------------------------------------
  'Execute the scripts primary Function.
  '----------------------------------------------------------------------------
  ProcessScript
  If Err.Number <> 0 Then
   Wscript.Quit
  End If
On Error Goto 0
'-------------------------------------------------------------------------------
'Sub Rountine Processing Section
'-------------------------------------------------------------------------------
Sub Sink_OnObjectReady(objEvent, objContext)
  Dim model, i
  '----------------------------------------------------------------------------
  'Attempt to enumerate the Model of the USB device up to 3 times. Windows may not have installed the driver yet!
  '----------------------------------------------------------------------------
  For i = 1 To 3
   model = GetUSBModel
   If model <> "" Then
     Exit For
   Else
     WScript.Sleep 10000
   End If
  Next
  CheckUSBDevice model
End Sub
'-------------------------------------------------------------------------------
'Functions Processing Section
'-------------------------------------------------------------------------------
'Name    : ProcessScript -> Primary Function that controls all other script processing.
'Parameters : None     ->
'Return   : None     ->
'-------------------------------------------------------------------------------
Function ProcessScript
  Dim query, logonName, shareNames, shareName, i
  shareNames = Array("\\testdc01\Logs$")
  query   = "Select * From __InstanceCreationEvent Within 5 Where " & _
        "TargetInstance Isa 'Win32_DiskDrive' And " & _
        "TargetInstance.InterfaceType = 'USB'"
  '----------------------------------------------------------------------------
  'Enusure the script's network log path exist otherwise define a local path.
  '----------------------------------------------------------------------------
  If Not SetLogPath(shareNames, scriptLogPath) Then
   scriptLogPath = localLogPath
  End If
  '----------------------------------------------------------------------------
  'Ensure the script's Base Name folder exists within the Logs$ share.
  '----------------------------------------------------------------------------
  scriptLogPath = scriptLogPath & "\" & scriptBaseName
  If Not objFSO.FolderExists(scriptLogPath) Then
   If Not CreateFolder(scriptLogPath) Then
    Exit Function
   End If
  End If
  scriptLogPath = scriptLogPath & "\" & IsoDateString(Now)
  '----------------------------------------------------------------------------
  'Enumerate the systems IP and MAC address for logging.
  '----------------------------------------------------------------------------
  If Not GetIPConfig(hostName, ipAddress, macAddress) Then
   ipAddress = "0.0.0.0"
   macAddress = "00:00:00:00:00:00"
  End If
  '----------------------------------------------------------------------------
  'Ensure the "devEject.exe" file exist within the scripts working directory.
  '----------------------------------------------------------------------------
  If Not objFSO.FileExists(systemPath & "\" & fileName) Then
   LogMessage 2, DQ(systemPath & "\" & fileName) & " does not exist"
   Exit Function
  End If
  '----------------------------------------------------------------------------
  'Enumerate the User's LogonName, FirstName and LastName for logging.
  '----------------------------------------------------------------------------
  userInfo = GetUserInfo
  On Error Resume Next
   logonName = Split(userInfo, ",")(0)
   If Err.Number <> 0 Then
     logonName = ""
   End If
  On Error Goto 0
  '----------------------------------------------------------------------------
  'Ensure USB storage devices which have already been inserted before script execution are enumerated.
  '----------------------------------------------------------------------------
  model = GetUSBModel
  If model <> "" Then
   CheckUSBDevice model
  End If
  '----------------------------------------------------------------------------
  'Ensure exclued users are not processed.
  '----------------------------------------------------------------------------
  For i = 0 To UBound(userExclusions)
   If StrComp(logonName, userExclusions(i), vbTextCompare) = 0 Then
     Exit Function
   End If
  Next
  '----------------------------------------------------------------------------
  'Ensure exclued computers are not processed.
  '----------------------------------------------------------------------------
  For i = 0 To UBound(computerExclusions)
   If StrComp(hostName, computerExclusions(i), vbTextCompare) = 0 Then
     Exit Function
   End If
  Next
  '----------------------------------------------------------------------------
  'Execute WMI Query to monitor USB devices. Creates "Sink_OnObjectReady" Sub Routine
  '----------------------------------------------------------------------------
  On Error Resume Next
   objWMI.ExecNotificationQueryAsync objSink, query
   If Err.Number <> 0 Then
     LogMessage 1, "Executing WMI Query " & DQ(query)
     Exit Function
   End If
  On Error Goto 0
  '----------------------------------------------------------------------------
  'Process script indefinately waiting for USB Storage Device events.
  '----------------------------------------------------------------------------
  Do
   WScript.Sleep 5000
  Loop
End Function
'-------------------------------------------------------------------------------
'Name    : SetLogPath -> Checks an Array of sharenames and sets one to the scripts log path if the default is unavailable.
'Parameters : shareNames -> A share name or array of shares names.
'      : logPath  -> Input/Output : Variable assigned to a valid share name that exists and is online.
'Return   : SetLogPath -> Function returns True and a valid log path otherwise returns False.
'-------------------------------------------------------------------------------
Function SetLogPath(shareNames, logPath)
  Dim shareName
  SetLogPath = True
  If Not IsArray(shareNames) Then
   shareNames = Array(shareNames)
  End If
  If objFSO.FolderExists(logPath) Then
   Exit Function
  End If
  For Each shareName In shareNames
   If objFSO.FolderExists(shareName) Then
     logPath = shareName
     Exit Function
   End If
  Next
  SetLogPath = False
End Function
'-------------------------------------------------------------------------------
'Name    : CreateFolder -> Recursive Function to Create a directory structure or single folder.
'Parameters : folderSpec  -> Path of folder\folders to create.
'Return   : CreateFolder -> Returns True if the directory structure was successfully created otherwise returns False.
'-------------------------------------------------------------------------------
Function CreateFolder(folderSpec)
  CreateFolder = False
  If Not objFSO.FolderExists(folderSpec) Then
   If InStrRev(folderSpec, "\") <> 0 Then
     If Not CreateFolder(Left(folderSpec, InStrRev(folderSpec, "\") - 1)) Then
      Exit Function
     End If
   End If
   On Error Resume Next
     objFSO.CreateFolder folderSpec
     If Err.Number <> 0 Then
      LogMessage 1, "Creating folder " & DQ(folderSpec)
      Exit Function
     End If
   On Error Goto 0
  End If
  CreateFolder = True
End Function
'-------------------------------------------------------------------------------
'Name    : GetIPConfig -> Enumerates the IP & MAC Address of the system via WMI
'Parameters : hostName  -> String containing the hostname of the computer to enumerate the IP configuration for.
'      : ipAddress  -> Input/Output : Variable assigned to the IP Address of the system.
'Parameters : macAddress -> Input/Output : Variable assigned to the MAC Address of the system.
'Return   : GetIPConfig -> Returns True and the systems IP & MAC Address if successful otherwise returns False.
'-------------------------------------------------------------------------------
Function GetIPConfig(hostName, ipAddress, macAddress)
  Dim wmi, ipConfig, query
  GetIPConfig = False
  ipAddress  = ""
  macAddress = ""
  query    = "Select * From Win32_NetworkAdapterConfiguration Where IPEnabled = True"
  On Error Resume Next
   Set wmi = GetObject("winmgmts:{impersonationLevel=impersonate}!\\" & hostName & "\root\cimv2")
   If Err.Number <> 0 Then
     LogMessage 1, "Creating WMI Object"
     Exit Function
   End If
   For Each ipConfig in wmi.ExecQuery(query)
     If Err.Number <> 0 Then
      LogMessage 1, "Executing WMI query " & DQ(query)
      Exit Function
     End If
     ipAddress = ipConfig.IPAddress(0)
     macAddress = ipConfig.MACAddress(0)
     If ipAddress <> "" And ipAddress <> "0.0.0.0" And MACAddress <> "" Then
      Exit For
     End If
   Next
  On Error Goto 0
  GetIPConfig = True
End Function
'-------------------------------------------------------------------------------
'Name    : GetUserInfo -> Attempts to Enumerate the user's LogonName, FirstName, Surname.
'Parameters : None    -> 
'Return   : GetUserInfo -> Returns a comma seperate string containing the users LogonName, FirstName And Surname.
'-------------------------------------------------------------------------------
Function GetUserInfo
  Dim objUser, userName, logonServer, firstName, lastName
  FirstName = ""
  Lastname = ""
  On Error Resume Next
   userName  = wshNetwork.UserName
   logonServer = wshShell.ExpandEnvironmentStrings("%logonserver%")
   '-------------------------------------------------------------------------
   'As the logonserver and hostname are identical the user must be logged on locally so don't get the properties from AD.
   '-------------------------------------------------------------------------
   If StrComp(logonServer, hostName, vbTextCompare) = 0 Then
     userInfo = userName & "," & firstName & "," & lastName
     Exit Function
   End If
   '-------------------------------------------------------------------------
   'As the user's logon server is a domain controller, enumerate their user properties from AD.
   '-------------------------------------------------------------------------
   Set objUser = GetObject("LDAP://" & sysInfo.userName)
   If Err.Number <> 0 Then
     LogMessage 1, "Binding to user object"
   Else
     firstName = ProperCase(objUser.givenName)
     LastName = ProperCase(objUser.sn)
   End If
  On Error Goto 0
  GetUserInfo = UserName & "," & firstName & "," & lastName  
End Function
'-------------------------------------------------------------------------------
'Name    : ProperCase -> Converts a string to "Proper" case.
'Parameters : text    -> String text to be converted.
'Return   : ProperCase -> Returns the converted String in Proper case.
'-------------------------------------------------------------------------------
Function ProperCase(text)
  Dim wordArray, i
  On Error Resume Next
   wordArray = Split(text, " ")
   For i = 0 To Ubound(wordArray)
     wordArray(i) = UCase(Left(wordArray(i), 1)) & Lcase(Mid(wordArray(i), 2))
   Next
   ProperCase = Join(wordArray, " ")
  On Error Goto 0
End Function
'-------------------------------------------------------------------------------
'Name    : GetUSBModel -> Enumerates the USB Storage Device Model Name.
'Parameters : None    -> 
'Return   : GetUSBModel -> Returns the the USB Storage Device Model Name.
'-------------------------------------------------------------------------------
Function GetUSBModel
  Dim query, model, results, result
  model   = ""
  query   = "Select Model From Win32_DiskDrive Where InterfaceType = 'USB'"
  On Error Resume Next
   Set results = objWMI.ExecQuery(query)
   If Err.Number <> 0 Then
     LogMessage 1, "Executing query " & DQ(query)
     Exit Function
   End If
   For Each result In results
     model = result.model
     If Err.Number <> 0 Then
      model = ""
      Exit For
     End If
   Next
  On Error Goto 0
  GetUSBModel = model
End Function
'-------------------------------------------------------------------------------
'Name    : EjectUSBDevice -> Prompts the User and Executes a command to eject the USB device.
'Parameters : model     -> String containing the USB Device model to eject. 
'Return   : None      -> 
'-------------------------------------------------------------------------------
Function EjectUSBDevice(model)
  Dim command
  '----------------------------------------------------------------------------
  'Prompt the user then automatically eject the USB device.
  '----------------------------------------------------------------------------
  On Error Resume Next
   wshShell.Popup "Using an unapproved USB storage devices is a voilation of security policy. " & vbCrLf & _
           "Your actions are being audited. Your Administrator has been notified." & vbCrLf & vbCrLf & _
           hostName & "," & ipAddress & "," & macAddress & "," & userInfo & "," & model, 7, scriptBaseName, 48
   command = "cmd /c " & fileName & " -EjectName:" & DQ(model)
   wshShell.Run command, 0, False
   LogMessage 0, userInfo & "," & model
  On Error Goto 0
End Function
'-------------------------------------------------------------------------------
'Name    : CheckUSBDevice -> Prompts the User and Executes a command to eject the USB device.
'Parameters : model     -> String containing the USB Device model to eject. 
'Return   : CheckUSBDevice -> 
'-------------------------------------------------------------------------------
Function CheckUSBDevice(model)
  Dim approved, i
  approved = False
  '----------------------------------------------------------------------------
  'Ensure USB devices that have been approved for corporate use are not ejected.
  '----------------------------------------------------------------------------
  For i = 0 To UBound(deviceExclusions)
   If StrComp(model, deviceExclusions(i), vbTextCompare) = 0 Then
     approved = True
     Exit For
   End If
  Next
  '----------------------------------------------------------------------------
  'The device has not been approved so Eject it.
  '----------------------------------------------------------------------------
  If Not approved Then
   EjectUSBDevice model
  End If
End Function
'-------------------------------------------------------------------------------
'Name    : DQ     -> Place double quotes around a string and replace double quotes  
'      :       -> within the string with pairs of double quotes.  
'Parameters : stringValue -> String value to be double quoted  
'Return   : DQ     -> Double quoted string.  
'------------------------------------------------------------------------------- 
Function DQ (ByVal stringValue)  
  If stringValue <> "" Then 
   DQ = """" & Replace (stringValue, """", """""") & """"  
  Else 
   DQ = """""" 
  End If 
End Function
'-------------------------------------------------------------------------------
'Name    : IsoDateTimeString -> Generate an ISO date and time string from a date/time value.
'Parameters : dateValue     -> Input date/time value.
'Return   : IsoDateTimeString -> Date and time parts of the input value in "yyyy-mm-dd hh:mm:ss" format.
'-------------------------------------------------------------------------------
Function IsoDateTimeString(dateValue)
  IsoDateTimeString = IsoDateString (dateValue) & " " & IsoTimeString (dateValue)
End Function
'-------------------------------------------------------------------------------
'Name    : IsoDateString -> Generate an ISO date string from a date/time value.
'Parameters : dateValue   -> Input date/time value.
'Return   : IsoDateString -> Date part of the input value in "yyyy-mm-dd" format.
'-------------------------------------------------------------------------------
Function IsoDateString(dateValue)
  If IsDate(dateValue) Then
   IsoDateString = Right ("000" & Year (dateValue), 4) & "-" & _
           Right ( "0" & Month (dateValue), 2) & "-" & _
           Right ( "0" &  Day (dateValue), 2)
  Else
   IsoDateString = "0000-00-00"
  End If
End Function
'-------------------------------------------------------------------------------
'Name    : IsoTimeString -> Generate an ISO time string from a date/time value.
'Parameters : dateValue   -> Input date/time value.
'Return   : IsoTimeString -> Time part of the input value in "hh:mm:ss" format.
'-------------------------------------------------------------------------------
Function IsoTimeString(dateValue)
  If IsDate(dateValue) Then
   IsoTimeString = Right ("0" &  Hour (dateValue), 2) & ":" & _
           Right ("0" & Minute (dateValue), 2) & ":" & _
           Right ("0" & Second (dateValue), 2)
  Else
   IsoTimeString = "00:00:00"
  End If
End Function
'-------------------------------------------------------------------------------
'Name    : LogMessage -> Parses a message to the log file based on the messageType.  
'Parameters : messageType -> Integer representing the messageType.
'      :       -> 0 = message    (writes to a ".log" file)
'      :       -> 1 = error,    (writes to a ".err" file including information relating to the error object.)
'      :       -> 2 = error message (writes to a ".err" file without information relating to the error object.)
'      : message   -> String containing the message to write to the log file.
'Return   : None    -> 
'-------------------------------------------------------------------------------
Function LogMessage(messageType, message)
  Dim prefix, logType
  prefix = IsoDateTimeString(Now) & "," & hostName & "," & ipAddress & "," & macAddress
  Select Case messageType
   Case 0
     logType = "log"
   Case 1
     logType = "err"
     message = "Error " & Err.Number & " (Hex " & Hex(Err.Number) & ") " & message & ". " & Err.Description
   Case Else
     LogType = "err"
  End Select
  If Not LogToCentralFile(scriptLogPath & "." & logType, prefix & "," & message) Then 
   Exit Function 
  End If
End Function
'-------------------------------------------------------------------------------
'Name    : LogToCentralFile -> Attempts to Appends information to a central file.
'Parameters : logSpec     -> Folder path, file name and extension of the central log file to append to.
'      : message     -> String to include in the central log file
'Return   : LogToCentralFile -> Returns True if Successfull otherwise False.
'-------------------------------------------------------------------------------
Function LogToCentralFile(logSpec, message)
  Dim attempts, objLogFile
  LogToCentralFile = False
  '----------------------------------------------------------------------------
  'Attempt to append to the central log file up to 10 times, as it may be locked by some other system.
  '----------------------------------------------------------------------------
  attempts = 0
  On Error Resume Next
   Do
     Set objLogFile = objFSO.OpenTextFile(logSpec, ForAppending, True)
     If Err.Number = 0 Then
      objLogFile.WriteLine message
      objLogFile.Close
      LogToCentralFile = True
      Exit Function
     End If
     Randomize
     Wscript.sleep 1000 + Rnd * 100
     attempts = attempts + 1
   Loop Until attempts >= 10
  On Error Goto 0
End Function
'-------------------------------------------------------------------------------

Marked as answer by MatthewBeattie Thursday, January 27, 2011 12:02 PM

Thursday, January 27, 2011 12:01 PM

0

Sign in to vote

Matt,

Thanks so much, I deployed this out to about 500 Pc's and it worked great. I really appreciate this so much and yes I do owe you a beer or 9. lol

Thanks again.

Ron
Thanks,

Thursday, January 27, 2011 1:32 PM
0

Sign in to vote

THANK YOU VERY VERY VERY MUCH MATT!! I've been looking for something like this for quite some times. I tested it out in our environment and it worked!

I do have 1 question though. Is it possible to add some type of password authentication instead of the exclusions?

Let's say, I plug the USB device into the system, a pop up would occur asking for a password. If password is right, USB is enabled. If password is wrong, USB information is logged and device is ejected.

Thursday, January 27, 2011 9:16 PM

Hi,

No worries, always happy to share knowledge. In theory it's very easy to implement your request...however this does pose an additional security risk. Essentially the password would have to be hard coded into the script, whilst you could easily write a basic encryption algorithm to mask the password from prying eyes it won't stop anyone with intelligence decryting the password...and once it's leaked amongst your users it will spread faster than butter. Still you could always change the password on a regular basis but communicating those changes to your users will be probably be more of challenge than it's worth.

If you still wish to proceed with the idea given the security risks let me know and i'll see what i can code up for you. I'd say a simple .hta application would be the best as it can mask the password entered from other users who may be looking over their shoulder when they enter the password which would be displayed in clear text if you use the InputBox function. I'd try having the "RestrictUSBStorage.vbs" script call the .hta in system directory which (you can use the "Deploy.vbs" to copy it to your systems) would write the password to a registry key in the user's profile temporarily, then have the RestrictUSBStorage.vbs script read the registry key and compare the password, if they match then delete the registry key and exit script processing, otherwise prompt the user and eject the device.

This is by no means a secure solution and I don't recommend it. Personally I'd recommend implementing bit locker to go via group policy, as long as the data is encryted does it really matter which model of USB storage device your user's want? Anyway here is some basic code for a .hta which prompts the user for the password and writes it to a registry key in their user profile.

Cheers Matt :)

<html>  
<head>  
<title>RemoveUSBDeviceRestrictions</title>  
<hta:application id = "objHTA"  
   applicationName = "RemoveUSBDeviceRestrictions" 
   border     = "thin" 
   borderStyle   = "normal" 
   caption     = "yes" 
   maximizeButton = "no" 
   minimizeButton = "yes" 
   showInTaskbar  = "no" 
   scroll     = "no" 
   singleInstance = "yes" 
   sysmenu     = "yes" 
   version     = "1.0"/>  
</head>  
<script language="vbscript">  
'-------------------------------------------------------------------------------
'Initialization Section   
'-------------------------------------------------------------------------------
Option Explicit  
Dim wshNetwork, wshShell, userName, netBiosDomain, scriptBaseName
scriptBaseName = "RemoveUSBDeviceRestrictions"
On Error Resume Next  
  Set wshNetwork = CreateObject("WScript.Network")
  Set wshShell  = CreateObject("WScript.Shell")
  netBiosDomain = WshNetwork.UserDomain
  If Err.Number <> 0 Then 
   Wscript.Quit  
  End If 
On Error Goto 0  
CenterWindow
'-------------------------------------------------------------------------------
'Functions Processing Section   
'-------------------------------------------------------------------------------
'Name    : ProcessScript -> Primary Function that controls all other script processing.   
'Parameters : None     ->  
'Return   : None     ->   
'------------------------------------------------------------------------------- 
Function ProcessScript  
  Dim userPassword, fileSpec
  userPassword = password.value  
  On Error Resume Next
   wshShell.RegWrite "HKCU\System\" & netBiosDomain & "\Scripts\" & scriptBaseName, userPassword, "REG_SZ"
   If Err.Number <> 0 Then
     Exit Function
   End If
  On Error Goto 0
  self.Close  
End Function 
'------------------------------------------------------------------------------- 
'Name    : CenterWindow -> Centers the HTA window vertically and horizontally in the middle of the screen.  
'Parameters : None     ->   
'Return   : None     ->   
'------------------------------------------------------------------------------- 
Function CenterWindow  
  Dim wmi, results, result  
  Dim displayWidth, displayHeight, x, y  
  On Error Resume Next 
   Set wmi   = GetObject("winmgmts:\\.\root\cimv2")  
   Set results = wmi.ExecQuery("Select * From Win32_DesktopMonitor")  
   For Each result In results  
     displayWidth = result.ScreenWidth  
     displayHeight = result.ScreenHeight  
   Next 
   x = (displayWidth - 280) / 2  
   y = (displayHeight - 150) / 2  
   If x < 0 Or y < 0 Then 
     x = 0  
     y = 0  
   End If 
   window.resizeTo 280,150
   window.moveTo x, y  
  On Error Goto 0  
End Function 
'-------------------------------------------------------------------------------
</script>  
<body style = "font:8pt tahoma; color:white; background-color:#3A6EA5">  
  <table align = center width = "100%" height = "60" border = "0">  
   <caption>Please enter the password to unlock USB device restrictions</caption>
   <tr>  
     <td align = right>Password :</td>  
     <td align = left><input type = "password" align = "left" name = "password" value = "" size = "20"></td>  
   </tr>  
   <tr>  
     <td align = right></td>  
     <td align = left><input id = runbutton type = "button" name = "submitButton" value = "Submit" onClick = "ProcessScript">  
   </tr>  
  </table>  
</body>
'-------------------------------------------------------------------------------

Friday, January 28, 2011 1:37 AM

0

Sign in to vote

Matt,

I understand that the password would be hardcoded into the script and that the password will not be encrypted. If you can code up something, that would be great. Either way, you've done a great job at providing the other codes.

Thanks for providing the .hta code. I'll mess around with it. Basically, I'm just trying to find a way to prevent unauthorized users to load virus, worms, etc. by means of a USB drive. Our anti-virus, turning off auto-run, and Group Policies locks down the generic user profile pretty well but this would be an added step to USB security.

thanks!

Friday, January 28, 2011 7:25 PM

Hi,

Try this, please note the code comments "It relies on the "StringConverter.exe" utility existing within the system directory."

http://www.computerperformance.co.uk/ezine/tools.htm#StringConverter.exe

The password entered is encoded and written to the registry key:

HCKU\System\" %netBiosDomain% "\Scripts\RemoveUSBDeviceRestrictions\USBPassword

If the user views the code and attempts to enter the encoded password, then it won't match the existing encoded password when it's re-encoded. This won't stop anyone with the intelligence to decode the encoded password but atleast it's one step better than clear text! Besides the user has permissions to terminate the WScript.exe process anyway so the solution is already insecure...like i said, I'd recommend bitlocker to go managed via group policy and let user's use whatever USB device they want instead of trying to control them.

Cheers Matt :)

<html>  
<head>  
<title>RemoveUSBDeviceRestrictions</title>  
<hta:application id = "objHTA"  
   applicationName = "RemoveUSBDeviceRestrictions" 
   border     = "thin" 
   borderStyle   = "normal" 
   caption     = "yes" 
   maximizeButton = "no" 
   minimizeButton = "yes" 
   showInTaskbar  = "no" 
   scroll     = "no" 
   singleInstance = "yes" 
   sysmenu     = "yes" 
   version     = "1.0"/>  
</head>  
<script language = "vbscript">  
'-------------------------------------------------------------------------------
'Script Name : RemoveUSBDeviceRestrictions.vbs
'Author   : Matthew Beattie
'Created   : 29/01/11
'Description : This script prompts the user to enter a password and executes
'      : a command to encode the password then writes the result to the registry.
'      : It relies on the "StringConverter.exe" utility existing within the system directory.
'      :
'      : http://www.computerperformance.co.uk/ezine/tools.htm#StringConverter.exe
'-------------------------------------------------------------------------------
'Initialization Section   
'-------------------------------------------------------------------------------
Option Explicit  
Dim objFSO, wshNetwork, wshShell, systemPath
Dim userName, netBiosDomain, scriptBaseName
scriptBaseName = "RemoveUSBDeviceRestrictions"
On Error Resume Next
  Set objFSO   = CreateObject("Scripting.FileSystemObject")
  Set wshNetwork = CreateObject("WScript.Network")
  Set wshShell  = CreateObject("WScript.Shell")
  netBiosDomain = WshNetwork.UserDomain
  systemPath   = objFSO.GetSpecialFolder(1)
  CenterWindow
  If Err.Number <> 0 Then 
   Wscript.Quit  
  End If 
On Error Goto 0
'-------------------------------------------------------------------------------
'Functions Processing Section   
'-------------------------------------------------------------------------------
'Name    : ProcessScript -> Primary Function that controls all other script processing.   
'Parameters : None     ->  
'Return   : None     ->   
'------------------------------------------------------------------------------- 
Function ProcessScript  
  Dim userPassword, regKey, fileName, command, result
  fileName   = "stringconverter.exe"
  userPassword = document.input.password.value
  regKey    = "HKCU\System\" & netBiosDomain & "\Scripts\" & scriptBaseName & "\USBPassword"
  command   = "cmd /c " & fileName & " \" & DQ(userPassword & "\") & " /encode /unicode"
  '----------------------------------------------------------------------------
  'Ensure the "StringConverter.exe" file exists within the system directory.
  '----------------------------------------------------------------------------
  If Not objFSO.FileExists(systemPath & "\" & fileName) Then
   self.Close
  End If
  '----------------------------------------------------------------------------
  'Execute the command to encode the password the user has entered.
  '----------------------------------------------------------------------------
  If Not RunCommand(command, result) Then
   self.Close
  End If
  '----------------------------------------------------------------------------
  'Write the encoded password to a registry key in the user's profile.
  '----------------------------------------------------------------------------
  On Error Resume Next
   wshShell.RegWrite regKey, result, "REG_SZ"
   If Err.Number <> 0 Then
     self.Close
   End If
  On Error Goto 0
  self.Close
End Function 
'------------------------------------------------------------------------------- 
'Name    : CenterWindow -> Centers the HTA window vertically and horizontally in the middle of the screen.  
'Parameters : None     ->   
'Return   : None     ->   
'------------------------------------------------------------------------------- 
Function CenterWindow  
  Dim wmi, results, result  
  Dim displayWidth, displayHeight, x, y  
  On Error Resume Next 
   Set wmi   = GetObject("winmgmts:\\.\root\cimv2")  
   Set results = wmi.ExecQuery("Select * From Win32_DesktopMonitor")  
   For Each result In results  
     displayWidth = result.ScreenWidth  
     displayHeight = result.ScreenHeight  
   Next 
   x = (displayWidth - 280) / 2  
   y = (displayHeight - 150) / 2  
   If x < 0 Or y < 0 Then 
     x = 0  
     y = 0  
   End If 
   window.resizeTo 280,150
   window.moveTo x, y  
  On Error Goto 0  
End Function
'-------------------------------------------------------------------------------
'Name    : DQ     -> Place double quotes around a string and replace double quotes 
'      :       -> within the string with pairs of double quotes. 
'Parameters : stringValue -> String value to be double quoted 
'Return   : DQ     -> Double quoted string. 
'------------------------------------------------------------------------------- 
Function DQ (ByVal stringValue) 
  If stringValue <> "" Then 
   DQ = """" & Replace (stringValue, """", """""") & """" 
  Else 
   DQ = """""" 
  End If 
End Function
'-------------------------------------------------------------------------------
'Name    : RunCommand -> Executes a command.
'Parameters : command  -> String containting the command to execute.
'      : output   -> Input/Output : the Output resulting from the command.
'Return   : RunCommand -> Returns True if command was successful else returns False.
'-------------------------------------------------------------------------------
Function RunCommand(command, output)
  Dim objExec, waited
  RunCommand = False
  output   = ""
  On Error Resume Next
   Set objExec = wshShell.Exec(command)
   If Err.Number <> 0 Then
     Exit Function
   End If
  On Error Goto 0
  Do Until objExec.status = 1
   output = output & objExec.StdOut.ReadAll
  Loop
  RunCommand = True
End Function
'-------------------------------------------------------------------------------
</script>  
<body style = "font:8pt tahoma; color:white; background-color:#3A6EA5">
  <form name = "Input">
   <table align = center width = "100%" height = "60" border = "0">  
     <caption>Please enter the password to unlock USB device restrictions</caption>
     <tr>  
      <td align = right>Password :</td>  
      <td align = left><input type = "password" align = "left" name = "password" value = "" size = "20"></td>  
     </tr>  
     <tr>  
      <td align = right></td>  
      <td align = left><input id = runbutton type = "button" name = "submitButton" value = "Submit" onClick = "ProcessScript">  
     </tr>  
   </table>
  </form>
  <script type = "text/javascript" language = "JavaScript">
   document.forms['Input'].elements['password'].focus();
  </script>
</body>
'-------------------------------------------------------------------------------

Saturday, January 29, 2011 2:59 AM

Hi,

Taking this one step further...here is an example demonstrating how you may wish to implement a script to call the .hta, encode the password the user enters, write it to the registry and have the script that called the .hta read the registry key in a loop and compare the encoded password with an encoded string in the script.

Here is a better version of the .hta (times out after 10 seconds with no input and automatically focuses on the password field in the form)

<html> 
<head> 
<title>RemoveUSBDeviceRestrictions</title> 
<hta:application id = "objHTA" 
  applicationName = "RemoveUSBDeviceRestrictions" 
  border   = "thin" 
  borderStyle  = "normal" 
  caption   = "yes" 
  maximizeButton = "no" 
  minimizeButton = "no" 
  showInTaskbar = "no" 
  scroll   = "no" 
  singleInstance = "yes" 
  sysmenu   = "no" 
  version   = "1.0"/> 
</head> 
<script language = "vbscript"> 
'-------------------------------------------------------------------------------
'Script Name : RemoveUSBDeviceRestrictions.vbs
'Author  : Matthew Beattie
'Created  : 29/01/11
'Description : This script prompts the user to enter a password and executes
'   : a command to encode the password then writes the result to the registry.
'   : It relies on the "StringConverter.exe" utility existing within the system directory.
'   :
'   : http://www.computerperformance.co.uk/ezine/tools.htm#StringConverter.exe
'-------------------------------------------------------------------------------
'Initialization Section  
'-------------------------------------------------------------------------------
Option Explicit 
Dim objFSO, wshNetwork, wshShell, systemPath
Dim userName, netBiosDomain, scriptBaseName
scriptBaseName = "RemoveUSBDeviceRestrictions"
On Error Resume Next
 Set objFSO  = CreateObject("Scripting.FileSystemObject")
 Set wshNetwork = CreateObject("WScript.Network")
 Set wshShell = CreateObject("WScript.Shell")
 netBiosDomain = WshNetwork.UserDomain
 systemPath  = objFSO.GetSpecialFolder(1)
 CenterWindow
 If Err.Number <> 0 Then 
  Wscript.Quit 
 End If 
On Error Goto 0
'-------------------------------------------------------------------------------
'Functions Processing Section  
'-------------------------------------------------------------------------------
'Name  : ProcessScript -> Primary Function that controls all other script processing.  
'Parameters : None   -> 
'Return  : None   ->  
'------------------------------------------------------------------------------- 
Function ProcessScript 
 Dim userPassword, regKey, fileName, command, result
 fileName  = "stringconverter.exe"
 userPassword = document.input.password.value
 regKey  = "HKCU\System\" & netBiosDomain & "\Scripts\" & scriptBaseName & "\USBPassword"
 command  = "cmd /c " & fileName & " \" & DQ(userPassword & "\") & " /encode /unicode"
 '----------------------------------------------------------------------------
 'Ensure the "StringConverter.exe" file exists within the system directory.
 '----------------------------------------------------------------------------
 If Not objFSO.FileExists(systemPath & "\" & fileName) Then
  self.Close
 End If
 '----------------------------------------------------------------------------
 'Execute the command to encode the password the user has entered.
 '----------------------------------------------------------------------------
 If Not RunCommand(command, result) Then
  self.Close
 End If
 '----------------------------------------------------------------------------
 'Write the encoded password to a registry key in the user's profile.
 '----------------------------------------------------------------------------
 On Error Resume Next
  wshShell.RegWrite regKey, result, "REG_SZ"
  If Err.Number <> 0 Then
   self.Close
  End If
 On Error Goto 0
 self.Close
End Function
'-------------------------------------------------------------------------------
'Name  : CountDown -> Defines a timer for the duration the hta will be displayed.
'Parameters : None  -> 
'Return  : None  ->  
'------------------------------------------------------------------------------- 
Function CountDown
 Dim timer
 timer = window.setInterval("DisplayMessage", 10000, "VBScript")
End Function
'-------------------------------------------------------------------------------
'Name  : DisplayMessage -> Displays a timeOut message and closes the .hta
'Parameters : None   -> 
'Return  : None   ->  
'------------------------------------------------------------------------------- 
Function DisplayMessage
 wshShell.Popup "You failed to enter the password within 10 seconds", 5, scriptBaseName, 48
 self.Close
End Function
'------------------------------------------------------------------------------- 
'Name  : CenterWindow -> Centers the HTA window vertically and horizontally in the middle of the screen. 
'Parameters : None   ->  
'Return  : None   ->  
'------------------------------------------------------------------------------- 
Function CenterWindow 
 Dim wmi, results, result 
 Dim displayWidth, displayHeight, x, y 
 On Error Resume Next 
  Set wmi  = GetObject("winmgmts:\\.\root\cimv2") 
  Set results = wmi.ExecQuery("Select * From Win32_DesktopMonitor") 
  For Each result In results 
   displayWidth = result.ScreenWidth 
   displayHeight = result.ScreenHeight 
  Next 
  x = (displayWidth - 280) / 2 
  y = (displayHeight - 150) / 2 
  If x < 0 Or y < 0 Then 
   x = 0 
   y = 0 
  End If 
  window.resizeTo 280,150
  window.moveTo x, y 
 On Error Goto 0 
End Function
'-------------------------------------------------------------------------------
'Name  : DQ   -> Place double quotes around a string and replace double quotes 
'   :    -> within the string with pairs of double quotes. 
'Parameters : stringValue -> String value to be double quoted 
'Return  : DQ   -> Double quoted string. 
'------------------------------------------------------------------------------- 
Function DQ (ByVal stringValue) 
 If stringValue <> "" Then 
  DQ = """" & Replace (stringValue, """", """""") & """" 
 Else 
  DQ = """""" 
 End If 
End Function
'-------------------------------------------------------------------------------
'Name  : RunCommand -> Executes a command.
'Parameters : command -> String containting the command to execute.
'   : output  -> Input/Output : the Output resulting from the command.
'Return  : RunCommand -> Returns True if command was successful else returns False.
'-------------------------------------------------------------------------------
Function RunCommand(command, output)
 Dim objExec, waited
 RunCommand = False
 output  = ""
 On Error Resume Next
  Set objExec = wshShell.Exec(command)
  If Err.Number <> 0 Then
   Exit Function
  End If
 On Error Goto 0
 Do Until objExec.status = 1
  output = output & objExec.StdOut.ReadAll
 Loop
 RunCommand = True
End Function
'-------------------------------------------------------------------------------
</script> 
<body style = "font:8pt tahoma; color:white; background-color:#3A6EA5" onLoad = "CountDown">
 <form name = "Input">
  <table align = center width = "100%" height = "60" border = "0"> 
   <caption>Please enter the password to unlock USB device restrictions</caption>
   <tr> 
   <td align = right>Password :</td> 
   <td align = left><input type = "password" align = "left" name = "password" value = "" size = "20"></td> 
   </tr> 
   <tr> 
   <td align = right></td> 
   <td align = left><input id = runbutton type = "button" name = "submitButton" value = "Submit" onClick = "ProcessScript"> 
   </tr> 
  </table>
 </form>
 <script type = "text/javascript" language = "JavaScript">
  document.forms['Input'].elements['password'].focus();
 </script>
</body>
'-------------------------------------------------------------------------------

And here is the code that checks the encoded password:

'-------------------------------------------------------------------------------
'Script Name : CheckPassword.vbs
'Author  : Matthew Beattie
'Created  : 21/10/11
'Description : This script executes a .hta application that prompts the user to
'   : input a password. The password is then encoded, written to a
'   : registry key and compared with an encoded password string in the
'   : script. This relies on the existance of two files in the system directory.
'   :
'   : "C:\Windows\System32\RemoveUSBDeviceRestrictions.hta"
'   : "C:\Windows\System32\stringconverter.exe"
'   :
'   : download the stringconverter.exe file here:
'   :
'   : http://www.computerperformance.co.uk/ezine/tools.htm#StringConverter.exe
'   :
'   : To generate an encoded password use the following command:
'   :
'   : stringconverter.exe \"%password%\" /encode /unicode > cipher.txt
'   :
'   : Replace the value of the "cipher" variable with the content of the "cipher.txt" file.
'-------------------------------------------------------------------------------
'Initialization Section 
'-------------------------------------------------------------------------------
Option Explicit
Dim objFSO, wshShell, wshNetwork
Dim netBiosDomain, systemPath, scriptBaseName
On Error Resume Next
 Set objFSO  = CreateObject("Scripting.FileSystemObject")
 Set wshShell = CreateObject("WScript.Shell")
 Set wshNetwork = CreateObject("WScript.Network")
 systemPath  = objFSO.GetSpecialFolder(1)
 scriptBaseName = objFSO.GetBaseName(Wscript.ScriptFullName)
 netBiosDomain = wshNetwork.UserDomain
 ProcessScript
 If Err.Number <> 0 Then
  WScript.Quit
 End If
On Error Goto 0
'-------------------------------------------------------------------------------
'Functions Processing Section
'-------------------------------------------------------------------------------
'Name  : ProcessScript -> Primary Function that controls all other script processing.
'Parameters : None   ->
'Return  : None   ->
'-------------------------------------------------------------------------------
Function ProcessScript
 Dim cipher, scriptName, fileSpec
 Dim waited, allowed, regKey, result
 waited  = 0
 allowed = False
 cipher  = "IgBQAEAAcwBzAHcAMAByAGQAIQAiAA=="
 scriptName = "RemoveUSBDeviceRestrictions"
 fileSpec = systemPath & "\" & scriptName & ".hta"
 regKey  = "HKCU\System\" & netBiosDomain & "\Scripts\" & scriptName & "\USBPassword"
 '----------------------------------------------------------------------------
 'Ensure the "RemoveUSBDeviceRestrictions.hta" exists within the system directory.
 '----------------------------------------------------------------------------
 If Not objFSO.FileExists(fileSpec) Then
  Exit Function
 End If
 '----------------------------------------------------------------------------
 'Execute the .hta application to prompt the user for the password.
 '----------------------------------------------------------------------------
 On Error Resume Next
  wshShell.Run systemPath & "\" & scriptName & ".hta", 0, False
  Do Until waited >= 10
   result = wshShell.RegRead(regKey)
   If Err.Number <> 0 Then
   result = ""
   Err.Clear
   Else
   If StrComp(result, cipher, vbTextCompare) = 0 Then
    allowed = True
    Exit Do
   End If
   End If
   waited = waited + 1
   WScript.Sleep 1000
  Loop
  '-------------------------------------------------------------------------
  'Prompt the User with the appropriate response based on their input.
  '-------------------------------------------------------------------------
  If allowed Then
   MsgBox "Password correct, Access Granted.", vbInformation, scriptBaseName
   wshShell.RegDelete regKey
   Exit Function
  Else
   MsgBox "Password Incorrect. Access Denied", vbCritical, scriptBaseName
   wshShell.RegDelete regKey
   Exit Function
  End If
 On Error Goto 0
End Function
'-------------------------------------------------------------------------------

This is way beyond the scope of the origonal post...any further questions please create another thread so we don't have to keep scrolling all the way down to the bottom of the thread :)

Cheers Matt :)

Saturday, January 29, 2011 9:51 AM

0

Sign in to vote

Thanks for all your hard work Matt. I will continue to play around with the codes you provided.

Tuesday, February 1, 2011 3:57 PM
0

Sign in to vote

Hey Matt, Thanks for your help in this. I do howerver have one more question, How can I change this script to pull serial number and eject it instead of pulling device name? I know at the begining i asked for it this way and you provided and now i'm asking for more. I ran into a problem today as a client has two devices of the same name with different serials. If i approve one then both are approved. I would rather run off of serials. Thanks for your help in this. You've been great so far and i really appreciate the help. I am learning about scripting so i don't have to keep bothering you! =)

Thanks again,

Ron
Thanks, Ron

Wednesday, February 9, 2011 8:23 PM

Hi Ron,

You would have to use PNPDeviceID as the SerialNumber property is not available on USB sticks in the Win32_DiskDrive class. The deveject utility accepts -ejectId which accepts a PNPDeviceID:

Usage: deveject.exe -EjectDrive:<Drive>|-EjectName:<Name>|-EjectId:<DeviceId> [-
v] [-Debug]

Currently the script is using the -ejectName instead of -ejectID. Here is an example of how to enumerate the PNPDeviceID for your USB device:

'http://msdn.microsoft.com/en-us/library/aa394132(v=vs.85).aspx
Option Explicit
Dim wshNetwork, objWMI, hostName
On Error Resume Next
  Set wshNetwork = CreateObject("WScript.Network")
  hostName    = wshNetwork.ComputerName
  Set objWMI   = GetObject("winmgmts:\\" & hostName & "\root\cimv2")
  If Err.Number <> 0 Then
   MsgBox "An unexpected error occurred!", vbCritical
   WScript.Quit
  End If
  MsgBox GetUSBDeviceID, vbInformation
On Error Goto 0
'-------------------------------------------------------------------------------
'Name    : GetUSBDeviceID -> Enumerates the USB Storage Device PNPDeviceID.
'Parameters : None      -> 
'Return   : GetUSBDeviceID -> Returns the the USB Storage Device PNPDeviceID.
'-------------------------------------------------------------------------------
Function GetUSBDeviceID
  Dim query, deviceID, results, result
  deviceID = ""
  query  = "Select PNPDeviceID From Win32_DiskDrive Where InterfaceType = 'USB'"
  On Error Resume Next
   Set results = objWMI.ExecQuery(query)
   If Err.Number <> 0 Then
     'LogMessage 1, "Executing query " & DQ(query)
     Exit Function
   End If
   For Each result In results
     deviceID = result.PNPDeviceID
     If Err.Number <> 0 Then
      deviceID = ""
      Exit For
     End If
   Next
  On Error Goto 0
  GetUSBDeviceID = deviceID
End Function
'-------------------------------------------------------------------------------

You would need to change the code to use the GetUSBDeviceID function instead of GetUSBModel, then change the deveject command to use the -ejectID parameter and parse it the USB PNPDeviceID. Hope that helps

Cheers Matt :)

Thursday, February 10, 2011 1:42 PM

0

Sign in to vote

Hey Matt, Thanks for the reply, i added this part but i guess i have no clue as to what i'm doing because i can get it to recognize but not eject. can you look at what i have so far:

'-------------------------------------------------------------------------------
'Script Name : RestrictUSBStorageDevice.vbs
'Author   : Matthew Beattie
'Created   : 21/10/11
'Description : This script monitors for the addition of USB Storage Devices to the system. If the device is not approved
'      : the user will be notified and device will be ejected. It is "assumed" the "deveject.exe" utility available
'      : from the link below has been deployed to the system32 directory on all systems. For further documentation:
'      :
'      : http://www.microsoft.com/technet/scriptcenter/resources/scriptshop/shop0805.mspx
'      : http://www.withopf.com/tools/deveject/
'-------------------------------------------------------------------------------
'Initialization Section
'-------------------------------------------------------------------------------
Option Explicit
Const ForAppending = 8
Dim objFSO, objSink, objWMI, sysInfo, wshShell, wshNetwork, systemPath
Dim scriptBaseName, scriptPath, scriptLogPath, localLogPath, ipAddress, macAddress
Dim userExclusions, computerExclusions, deviceExclusions
Dim hostName, userName, userInfo, deviceID, fileName
On Error Resume Next
Set wshShell = CreateObject("WScript.Shell")
Set wshNetwork = CreateObject("WScript.Network")
Set objFSO   = CreateObject("Scripting.FileSystemObject")
Set sysInfo = CreateObject("ADSystemInfo")
hostName    = wshNetwork.ComputerName
Set objWMI   = GetObject("winmgmts:\\" & hostName & "\root\cimv2")
Set objSink = WScript.CreateObject("WbemScripting.SWbemSink", "Sink_")
localLogPath = wshShell.ExpandEnvironmentStrings("%temp%")
scriptBaseName = objFSO.GetBaseName(Wscript.ScriptFullName)
scriptPath   = objFSO.GetFile(Wscript.ScriptFullName).ParentFolder.Path
systemPath   = objFSO.GetSpecialFolder(1)
fileName    = "deveject.exe"
'----------------------------------------------------------------------------
'Configure the user, computer and USB Storage device exclusions here.
'----------------------------------------------------------------------------
deviceExclusions = Array("Kingston DT Elite HS 2.0 USB Device")
userExclusions   = Array("User1","User2")
computerExclusions = Array("Computer1","Computer2")
'----------------------------------------------------------------------------
'Execute the scripts primary Function.
'----------------------------------------------------------------------------
ProcessScript
If Err.Number <> 0 Then
   Wscript.Quit
End If
On Error Goto 0
'-------------------------------------------------------------------------------
'Sub Rountine Processing Section
'-------------------------------------------------------------------------------
Sub Sink_OnObjectReady(objEvent, objContext)
Dim deviceID, i
'----------------------------------------------------------------------------
'Attempt to enumerate the deviceID of the USB device up to 3 times. Windows may not have installed the driver yet!
'----------------------------------------------------------------------------
For i = 1 To 3
   GetUSBDeviceID = deviceID
   If deviceID <> "" Then
     Exit For
   Else
     WScript.Sleep 10000
   End If
Next
CheckUSBDevice deviceID
End Sub
'-------------------------------------------------------------------------------
'Functions Processing Section
'-------------------------------------------------------------------------------
'Name    : ProcessScript -> Primary Function that controls all other script processing.
'Parameters : None     ->
'Return   : None     ->
'-------------------------------------------------------------------------------
Function ProcessScript
Dim query, logonName, shareNames, shareName, i
shareNames = Array("\\test-dc-01\NetLogs$\USB_Devices")
query   = "Select * From __InstanceCreationEvent Within 5 Where " & _
        "TargetInstance Isa 'Win32_DiskDrive' And " & _
        "TargetInstance.InterfaceType = 'USB'"
'----------------------------------------------------------------------------
'Enusure the script's network log path exist otherwise define a local path.
'----------------------------------------------------------------------------
If Not SetLogPath(shareNames, scriptLogPath) Then
   scriptLogPath = localLogPath
End If
'----------------------------------------------------------------------------
'Ensure the script's Base Name folder exists within the Logs$ share.
'----------------------------------------------------------------------------
scriptLogPath = scriptLogPath & "\" & scriptBaseName
If Not objFSO.FolderExists(scriptLogPath) Then
   If Not CreateFolder(scriptLogPath) Then
    Exit Function
   End If
End If
scriptLogPath = scriptLogPath & "\" & IsoDateString(Now)
'----------------------------------------------------------------------------
'Enumerate the systems IP and MAC address for logging.
'----------------------------------------------------------------------------
If Not GetIPConfig(hostName, ipAddress, macAddress) Then
   ipAddress = "0.0.0.0"
   macAddress = "00:00:00:00:00:00"
End If
'----------------------------------------------------------------------------
'Ensure the "devEject.exe" file exist within the scripts working directory.
'----------------------------------------------------------------------------
If Not objFSO.FileExists(systemPath & "\" & fileName) Then
   LogMessage 2, DQ(systemPath & "\" & fileName) & " does not exist"
   Exit Function
End If
'----------------------------------------------------------------------------
'Enumerate the User's LogonName, FirstName and LastName for logging.
'----------------------------------------------------------------------------
userInfo = GetUserInfo
On Error Resume Next
   logonName = Split(userInfo, ",")(0)
   If Err.Number <> 0 Then
     logonName = ""
   End If
On Error Goto 0
'----------------------------------------------------------------------------
'Ensure USB storage devices which have already been inserted before script execution are enumerated.
'----------------------------------------------------------------------------
deviceID = GetUSBDeviceID
If deviceID <> "" Then
   CheckUSBDevice deviceID
End If
'----------------------------------------------------------------------------
'Ensure exclued users are not processed.
'----------------------------------------------------------------------------
For i = 0 To UBound(userExclusions)
   If StrComp(logonName, userExclusions(i), vbTextCompare) = 0 Then
     Exit Function
   End If
Next
'----------------------------------------------------------------------------
'Ensure exclued computers are not processed.
'----------------------------------------------------------------------------
For i = 0 To UBound(computerExclusions)
   If StrComp(hostName, computerExclusions(i), vbTextCompare) = 0 Then
     Exit Function
   End If
Next
'----------------------------------------------------------------------------
'Execute WMI Query to monitor USB devices. Creates "Sink_OnObjectReady" Sub Routine
'----------------------------------------------------------------------------
On Error Resume Next
   objWMI.ExecNotificationQueryAsync objSink, query
   If Err.Number <> 0 Then
     LogMessage 1, "Executing WMI Query " & DQ(query)
     Exit Function
   End If
On Error Goto 0
'----------------------------------------------------------------------------
'Process script indefinately waiting for USB Storage Device events.
'----------------------------------------------------------------------------
Do
   WScript.Sleep 5000
Loop
End Function
'-------------------------------------------------------------------------------
'Name    : SetLogPath -> Checks an Array of sharenames and sets one to the scripts log path if the default is unavailable.
'Parameters : shareNames -> A share name or array of shares names.
'      : logPath -> Input/Output : Variable assigned to a valid share name that exists and is online.
'Return   : SetLogPath -> Function returns True and a valid log path otherwise returns False.
'-------------------------------------------------------------------------------
Function SetLogPath(shareNames, logPath)
Dim shareName
SetLogPath = True
If Not IsArray(shareNames) Then
   shareNames = Array(shareNames)
End If
If objFSO.FolderExists(logPath) Then
   Exit Function
End If
For Each shareName In shareNames
   If objFSO.FolderExists(shareName) Then
     logPath = shareName
     Exit Function
   End If
Next
SetLogPath = False
End Function
'-------------------------------------------------------------------------------
'Name    : CreateFolder -> Recursive Function to Create a directory structure or single folder.
'Parameters : folderSpec -> Path of folder\folders to create.
'Return   : CreateFolder -> Returns True if the directory structure was successfully created otherwise returns False.
'-------------------------------------------------------------------------------
Function CreateFolder(folderSpec)
CreateFolder = False
If Not objFSO.FolderExists(folderSpec) Then
   If InStrRev(folderSpec, "\") <> 0 Then
     If Not CreateFolder(Left(folderSpec, InStrRev(folderSpec, "\") - 1)) Then
      Exit Function
     End If
   End If
   On Error Resume Next
     objFSO.CreateFolder folderSpec
     If Err.Number <> 0 Then
      LogMessage 1, "Creating folder " & DQ(folderSpec)
      Exit Function
     End If
   On Error Goto 0
End If
CreateFolder = True
End Function
'-------------------------------------------------------------------------------
'Name    : GetIPConfig -> Enumerates the IP & MAC Address of the system via WMI
'Parameters : hostName -> String containing the hostname of the computer to enumerate the IP configuration for.
'      : ipAddress -> Input/Output : Variable assigned to the IP Address of the system.
'Parameters : macAddress -> Input/Output : Variable assigned to the MAC Address of the system.
'Return   : GetIPConfig -> Returns True and the systems IP & MAC Address if successful otherwise returns False.
'-------------------------------------------------------------------------------
Function GetIPConfig(hostName, ipAddress, macAddress)
Dim wmi, ipConfig, query
GetIPConfig = False
ipAddress = ""
macAddress = ""
query    = "Select * From Win32_NetworkAdapterConfiguration Where IPEnabled = True"
On Error Resume Next
   Set wmi = GetObject("winmgmts:{impersonationLevel=impersonate}!\\" & hostName & "\root\cimv2")
   If Err.Number <> 0 Then
     LogMessage 1, "Creating WMI Object"
     Exit Function
   End If
   For Each ipConfig in wmi.ExecQuery(query)
     If Err.Number <> 0 Then
      LogMessage 1, "Executing WMI query " & DQ(query)
      Exit Function
     End If
     ipAddress = ipConfig.IPAddress(0)
     macAddress = ipConfig.MACAddress(0)
     If ipAddress <> "" And ipAddress <> "0.0.0.0" And MACAddress <> "" Then
      Exit For
     End If
   Next
On Error Goto 0
GetIPConfig = True
End Function
'-------------------------------------------------------------------------------
'Name    : GetUserInfo -> Attempts to Enumerate the user's LogonName, FirstName, Surname.
'Parameters : None    ->
'Return   : GetUserInfo -> Returns a comma seperate string containing the users LogonName, FirstName And Surname.
'-------------------------------------------------------------------------------
Function GetUserInfo
Dim objUser, userName, logonServer, firstName, lastName
FirstName = ""
Lastname = ""
On Error Resume Next
   userName = wshNetwork.UserName
   logonServer = wshShell.ExpandEnvironmentStrings("%logonserver%")
   '-------------------------------------------------------------------------
   'As the logonserver and hostname are identical the user must be logged on locally so don't get the properties from AD.
   '-------------------------------------------------------------------------
   If StrComp(logonServer, hostName, vbTextCompare) = 0 Then
     userInfo = userName & "," & firstName & "," & lastName
     Exit Function
   End If
   '-------------------------------------------------------------------------
   'As the user's logon server is a domain controller, enumerate their user properties from AD.
   '-------------------------------------------------------------------------
   Set objUser = GetObject("LDAP://" & sysInfo.userName)
   If Err.Number <> 0 Then
     LogMessage 1, "Binding to user object"
   Else
     firstName = ProperCase(objUser.givenName)
     LastName = ProperCase(objUser.sn)
   End If
On Error Goto 0
GetUserInfo = UserName & "," & firstName & "," & lastName
End Function
'-------------------------------------------------------------------------------
'Name    : ProperCase -> Converts a string to "Proper" case.
'Parameters : text    -> String text to be converted.
'Return   : ProperCase -> Returns the converted String in Proper case.
'-------------------------------------------------------------------------------
Function ProperCase(text)
Dim wordArray, i
On Error Resume Next
   wordArray = Split(text, " ")
   For i = 0 To Ubound(wordArray)
     wordArray(i) = UCase(Left(wordArray(i), 1)) & Lcase(Mid(wordArray(i), 2))
   Next
   ProperCase = Join(wordArray, " ")
On Error Goto 0
End Function
'-------------------------------------------------------------------------------
'Name    : GetUSBDeviceID -> Enumerates the USB Storage Device PNPDeviceID.
'Parameters : None      ->
'Return   : GetUSBDeviceID -> Returns the the USB Storage Device PNPDeviceID.
'-------------------------------------------------------------------------------
Function GetUSBDeviceID
Dim query, deviceID, results, result
deviceID = ""
query = "Select PNPDeviceID From Win32_DiskDrive Where InterfaceType = 'USB'"
On Error Resume Next
   Set results = objWMI.ExecQuery(query)
   If Err.Number <> 0 Then
     'LogMessage 1, "Executing query " & DQ(query)
     Exit Function
   End If
   For Each result In results
     deviceID = result.PNPDeviceID
     If Err.Number <> 0 Then
      deviceID = ""
      Exit For
     End If
   Next
On Error Goto 0
GetUSBDeviceID = deviceID
End Function
'-------------------------------------------------------------------------------
'Name    : EjectUSBDevice -> Prompts the User and Executes a command to eject the USB device.
'Parameters : deviceID     -> String containing the USB Device deviceID to eject.
'Return   : None      ->
'-------------------------------------------------------------------------------
Function EjectUSBDevice(deviceID)
Dim command
'----------------------------------------------------------------------------
'Prompt the user then automatically eject the USB device.
'----------------------------------------------------------------------------
On Error Resume Next
   wshShell.Popup "Using an unapproved USB storage devices is a voilation of security policy. " & vbCrLf & _
           "Your actions are being audited. Your Administrator has been notified." & vbCrLf & vbCrLf & _
           hostName & "," & ipAddress & "," & macAddress & "," & userInfo & "," & deviceID, 7, scriptBaseName, 48
   command = "cmd /c " & fileName & " -ejectID:" & DQ(deviceID)
   wshShell.Run command, 0, False
   LogMessage 0, userInfo & "," & deviceID
On Error Goto 0
End Function
'-------------------------------------------------------------------------------
'Name    : CheckUSBDevice -> Prompts the User and Executes a command to eject the USB device.
'Parameters : deviceID     -> String containing the USB Device deviceID to eject.
'Return   : CheckUSBDevice ->
'-------------------------------------------------------------------------------
Function CheckUSBDevice(deviceID)
Dim approved, i
approved = False
'----------------------------------------------------------------------------
'Ensure USB devices that have been approved for corporate use are not ejected.
'----------------------------------------------------------------------------
For i = 0 To UBound(deviceExclusions)
   If StrComp(deviceID, deviceExclusions(i), vbTextCompare) = 0 Then
     approved = True
     Exit For
   End If
Next
'----------------------------------------------------------------------------
'The device has not been approved so Eject it.
'----------------------------------------------------------------------------
If Not approved Then
   EjectUSBDevice deviceID
End If
End Function
'-------------------------------------------------------------------------------
'Name    : DQ     -> Place double quotes around a string and replace double quotes
'      :       -> within the string with pairs of double quotes.
'Parameters : stringValue -> String value to be double quoted
'Return   : DQ     -> Double quoted string.
'-------------------------------------------------------------------------------
Function DQ (ByVal stringValue)
If stringValue <> "" Then
   DQ = """" & Replace (stringValue, """", """""") & """"
Else
   DQ = """"""
End If
End Function
'-------------------------------------------------------------------------------
'Name    : IsoDateTimeString -> Generate an ISO date and time string from a date/time value.
'Parameters : dateValue     -> Input date/time value.
'Return   : IsoDateTimeString -> Date and time parts of the input value in "yyyy-mm-dd hh:mm:ss" format.
'-------------------------------------------------------------------------------
Function IsoDateTimeString(dateValue)
IsoDateTimeString = IsoDateString (dateValue) & " " & IsoTimeString (dateValue)
End Function
'-------------------------------------------------------------------------------
'Name    : IsoDateString -> Generate an ISO date string from a date/time value.
'Parameters : dateValue   -> Input date/time value.
'Return   : IsoDateString -> Date part of the input value in "yyyy-mm-dd" format.
'-------------------------------------------------------------------------------
Function IsoDateString(dateValue)
If IsDate(dateValue) Then
   IsoDateString = Right ("000" & Year (dateValue), 4) & "-" & _
           Right ( "0" & Month (dateValue), 2) & "-" & _
           Right ( "0" & Day (dateValue), 2)
Else
   IsoDateString = "0000-00-00"
End If
End Function
'-------------------------------------------------------------------------------
'Name    : IsoTimeString -> Generate an ISO time string from a date/time value.
'Parameters : dateValue   -> Input date/time value.
'Return   : IsoTimeString -> Time part of the input value in "hh:mm:ss" format.
'-------------------------------------------------------------------------------
Function IsoTimeString(dateValue)
If IsDate(dateValue) Then
   IsoTimeString = Right ("0" & Hour (dateValue), 2) & ":" & _
           Right ("0" & Minute (dateValue), 2) & ":" & _
           Right ("0" & Second (dateValue), 2)
Else
   IsoTimeString = "00:00:00"
End If
End Function
'-------------------------------------------------------------------------------
'Name    : LogMessage -> Parses a message to the log file based on the messageType.
'Parameters : messageType -> Integer representing the messageType.
'      :       -> 0 = message    (writes to a ".log" file)
'      :       -> 1 = error,    (writes to a ".err" file including information relating to the error object.)
'      :       -> 2 = error message (writes to a ".err" file without information relating to the error object.)
'      : message   -> String containing the message to write to the log file.
'Return   : None    ->
'-------------------------------------------------------------------------------
Function LogMessage(messageType, message)
Dim prefix, logType
prefix = IsoDateTimeString(Now) & "," & hostName & "," & ipAddress & "," & macAddress
Select Case messageType
   Case 0
     logType = "log"
   Case 1
     logType = "err"
     message = "Error " & Err.Number & " (Hex " & Hex(Err.Number) & ") " & message & ". " & Err.Description
   Case Else
     LogType = "err"
End Select
If Not LogToCentralFile(scriptLogPath & "." & logType, prefix & "," & message) Then
   Exit Function
End If
End Function
'-------------------------------------------------------------------------------
'Name    : LogToCentralFile -> Attempts to Appends information to a central file.
'Parameters : logSpec     -> Folder path, file name and extension of the central log file to append to.
'      : message     -> String to include in the central log file
'Return   : LogToCentralFile -> Returns True if Successfull otherwise False.
'-------------------------------------------------------------------------------
Function LogToCentralFile(logSpec, message)
Dim attempts, objLogFile
LogToCentralFile = False
'----------------------------------------------------------------------------
'Attempt to append to the central log file up to 10 times, as it may be locked by some other system.
'----------------------------------------------------------------------------
attempts = 0
On Error Resume Next
   Do
     Set objLogFile = objFSO.OpenTextFile(logSpec, ForAppending, True)
     If Err.Number = 0 Then
      objLogFile.WriteLine message
      objLogFile.Close
      LogToCentralFile = True
      Exit Function
     End If
     Randomize
     Wscript.sleep 1000 + Rnd * 100
     attempts = attempts + 1
   Loop Until attempts >= 10
On Error Goto 0
End Function
'-------------------------------------------------------------------------------

Thanks again for your help,

Ron
Thanks, Ron

Friday, February 11, 2011 3:30 PM

Hi Ron

Well rather than re post the entire script again, i'm made a cut down version for you without the logging. I did find a bug with the previous version that i've fixed for you. In the instance where a user plugs in the USB device and opens windows explorer to browse the USB drive, the first attempt to automatically eject the device fails! Therefore I've added a few functions to continually attempt to eject the device in a loop and prompt the user until successful.

Personally i don't recommend using the serial number of the USB device to configure your exclusions as this will quickly become an administrative nightmare to maintain. Your exclusions list will soon become hundreds of USB device serial numbers as your users start complaining (your problem). To get the serial number of the USB device, plug it in ensuring it is the only USB storage device connected to the system and use this:

Option Explicit
Dim objFSO, objWMI, wshNetwork, hostName, scriptBaseName
On Error Resume Next
  Set objFSO   = CreateObject("Scripting.FileSystemObject")
  Set wshNetwork = CreateObject("WScript.Network")
  hostName    = wshNetwork.ComputerName
  Set objWMI   = GetObject("winmgmts:\\" & hostName & "\root\cimv2")
  scriptBaseName = objFSO.GetBaseName(Wscript.ScriptFullName)
  ProcessScript
  If Err.Number <> 0 Then
   WScript.Quit
  End If
On Error Goto 0
'-------------------------------------------------------------------------------
'Functions Processing Section
'-------------------------------------------------------------------------------
'Name    : ProcessScript -> Primary Function that controls all other script processing.
'Parameters : None     ->
'Return   : None     ->
'-------------------------------------------------------------------------------
Function ProcessScript
  Dim deviceID, serialNumber
  deviceID   = GetUSBDeviceID
  serialNumber = GetUSBSerialNumber(deviceID)
  MsgBox SerialNumber, vbInformation, scriptBaseName
End Function
'-------------------------------------------------------------------------------
'Name    : GetUSBDeviceID -> Enumerates the USB Storage Device PNPDeviceID.
'Parameters : None      -> 
'Return   : GetUSBDeviceID -> Returns the the USB Storage Device PNPDeviceID.
'-------------------------------------------------------------------------------
Function GetUSBDeviceID
  Dim query, deviceID, results, result
  deviceID = ""
  query  = "Select PNPDeviceID From Win32_DiskDrive Where InterfaceType = 'USB'"
  On Error Resume Next
   Set results = objWMI.ExecQuery(query)
   If Err.Number <> 0 Then
     'LogMessage 1, "Executing query " & DQ(query)
     Exit Function
   End If
   For Each result In results
     deviceID = result.PNPDeviceID
     If Err.Number <> 0 Then
      deviceID = ""
      Exit For
     End If
   Next
  On Error Goto 0
  GetUSBDeviceID = deviceID
End Function
'-------------------------------------------------------------------------------
'Name    : GetUSBSerialNumber -> Extracts the Serial Number from the PNP Device ID.
'Parameters : deviceID      -> String containing the USB PNP Device ID.
'Return   : GetUSBSerialNumber -> Returns the the USB Devices Serial Number.
'-------------------------------------------------------------------------------
Function GetUSBSerialNumber(deviceID)
  Dim serialNumber
  On Error Resume Next
   serialNumber = Split(Mid(deviceID, InStrRev(deviceID, "\") +1), "&")(0)
   If Err.Number <> 0 Then
     serialNumber = ""
   End If
  On Error Goto 0
  GetUSBSerialNumber = serialNumber
End Function
'-------------------------------------------------------------------------------

For example:

USBSTOR\DISK&VEN_GENERIC&PROD_FLASH_DISK&REV_8.07\37291611&0 = "37291611"

Personally I think using the USB model name is more managable....but you asked how to do it via serial number so here you go:

'-------------------------------------------------------------------------------
'Script Name : RestrictUSBStorageDevice.vbs
'Author   : Matthew Beattie
'Created   : 21/10/11
'Modified  : 12/02/11
'Description : This script monitors for the addition of USB Storage Devices to the system. If the device is not approved
'      : the user will be notified and device will be ejected. It is "assumed" the "deveject.exe" utility available 
'      : from the link below has been deployed to the system32 directory on all systems. For further documentation:
'      :
'      : http://www.microsoft.com/technet/scriptcenter/resources/scriptshop/shop0805.mspx
'      : http://www.withopf.com/tools/deveject/
'-------------------------------------------------------------------------------
'Initialization Section 
'-------------------------------------------------------------------------------
Option Explicit
Dim objFSO, objWMI, objSink, wshShell, wshNetwork, systemPath
Dim hostName, scriptBaseName, serialNumbers, fileName
On Error Resume Next
  Set objFSO   = CreateObject("Scripting.FileSystemObject")
  Set wshShell  = CreateObject("WScript.Shell")
  Set wshNetwork = CreateObject("WScript.Network")
  hostName    = wshNetwork.ComputerName
  Set objWMI   = GetObject("winmgmts:\\" & hostName & "\root\cimv2")
  Set objSink  = WScript.CreateObject("WbemScripting.SWbemSink", "Sink_")
  scriptBaseName = objFSO.GetBaseName(Wscript.ScriptFullName)
  systemPath   = objFSO.GetSpecialFolder(1)
  fileName    = "deveject.exe"
  '----------------------------------------------------------------------------
  'Configure the USB Storage device serial Numbers to be excluded here.
  '----------------------------------------------------------------------------
  serialNumbers = Array("09001C4161235A4A")
  ProcessScript
  If Err.Number <> 0 Then
   WScript.Quit
  End If
On Error Goto 0
'-------------------------------------------------------------------------------
'Sub Rountine Processing Section
'-------------------------------------------------------------------------------
Sub Sink_OnObjectReady(objEvent, objContext)
  Dim deviceID, i
  '----------------------------------------------------------------------------
  'Attempt to enumerate the Model of the USB device up to 3 times. Windows may not have installed the driver yet!
  '----------------------------------------------------------------------------
  For i = 1 To 3
   deviceID = GetUSBDeviceID
   If deviceID <> "" Then
     Exit For
   Else
     WScript.Sleep 10000
   End If
  Next
  If deviceID <> "" Then
   CheckUSBDevice deviceID
  End If
End Sub
'-------------------------------------------------------------------------------
'Functions Processing Section
'-------------------------------------------------------------------------------
'Name    : ProcessScript -> Primary Function that controls all other script processing.
'Parameters : None     ->
'Return   : None     ->
'-------------------------------------------------------------------------------
Function ProcessScript
  Dim query, deviceID
  query = "Select * From __InstanceCreationEvent Within 5 Where " & _
      "TargetInstance Isa 'Win32_DiskDrive' And " & _
      "TargetInstance.InterfaceType = 'USB'"
  '----------------------------------------------------------------------------
  'Ensure the "devEject.exe" file exist within the scripts working directory.
  '----------------------------------------------------------------------------
  If Not objFSO.FileExists(systemPath & "\" & fileName) Then
   Exit Function
  End If
  '----------------------------------------------------------------------------
  'Ensure USB storage devices already inserted before script executed are enumerated.
  '----------------------------------------------------------------------------
  deviceID = GetUSBDeviceID
  If deviceID <> "" Then
   CheckUSBDevice deviceID
  End If
  '----------------------------------------------------------------------------
  'Execute WMI Query to monitor USB devices. Creates "Sink_OnObjectReady" Sub Routine
  '----------------------------------------------------------------------------
  On Error Resume Next
   objWMI.ExecNotificationQueryAsync objSink, query
   If Err.Number <> 0 Then
     Exit Function
   End If
  On Error Goto 0
  '----------------------------------------------------------------------------
  'Process script indefinately waiting for USB Storage Device events.
  '----------------------------------------------------------------------------
  Do
   WScript.Sleep 5000
  Loop
End Function
'-------------------------------------------------------------------------------
'Name    : CheckUSBDevice -> Prompts the User and Executes a command to eject the USB device.
'Parameters : deviceID    -> String containing the USB Device deviceID to eject.
'Return   : None      -> 
'-------------------------------------------------------------------------------
Function CheckUSBDevice(deviceID)
  Dim approved, serialNumber, devices, exists, i
  approved   = False
  serialNumber = GetUSBSerialNumber(deviceID)
  If serialNumber = "" Then
   Exit Function
  End If
  '----------------------------------------------------------------------------
  'Ensure USB devices that have been approved for corporate use are not ejected.
  '----------------------------------------------------------------------------
  For i = 0 To UBound(serialNumbers)
   If StrComp(serialNumber, serialNumbers(i), vbTextCompare) = 0 Then
     approved = True
     Exit For
   End If
  Next
  '----------------------------------------------------------------------------
  'The device has not been approved so Eject it.
  '----------------------------------------------------------------------------
  If Not approved Then
   EjectUSBDevice deviceID
   WScript.Sleep 5000
  Else
   wshShell.Popup "This USB storage device is approved for corporate use.", 3, scriptBaseName, 64
   Exit Function
  End If
  '----------------------------------------------------------------------------
  'Ensure the system continually attempts to eject the device while it still exists.
  '----------------------------------------------------------------------------
  Do While CheckDeviceExists(deviceID)
   EjectUSBDevice deviceID
  Loop
End Function
'-------------------------------------------------------------------------------
'Name    : CheckDeviceExists -> Checks for the existance of a PNP Device ID in the system.
'Parameters : deviceID     -> String containing the USB Device deviceID to eject.
'Return   : CheckDeviceExists -> Returns True if the PNP Device ID exists otherwise False.
'-------------------------------------------------------------------------------
Function CheckDeviceExists(deviceID)
  Dim devices, exists, i
  CheckDeviceExists = False
  '----------------------------------------------------------------------------
  'Enumerate the PNP DeviceID's to ensure the device has been Ejected.
  '----------------------------------------------------------------------------
  If Not GetPNPDeviceIDs(devices) Then
   Exit Function
  End If
  '----------------------------------------------------------------------------
  'Check if the DeviceID still exists.
  '----------------------------------------------------------------------------
  For i = 0 To UBound(devices)
   If StrComp(deviceID, devices(i), vbTextCompare) = 0 Then
     CheckDeviceExists = True
     wshShell.Popup "Unapproved USB storage device is still connected to the system", 3, scriptBaseName, 48
     Exit Function
   End If
  Next
End Function
'-------------------------------------------------------------------------------
'Name    : GetPNPDeviceIDs -> Enumerates the PNP Device ID's connected to the system.
'Parameters : deviceIDs    -> Input/Output : Variable assigned to an array of PNP Device ID's.
'Return   : GetPNPDeviceIDs -> Returns True if the PNP Device ID exists otherwise False.
'-------------------------------------------------------------------------------
Function GetPNPDeviceIDs(deviceIDs)
  Dim pnpDict, query, results, result
  GetPNPDeviceIDs = False
  deviceIDs    = ""
  query      = "Select deviceID From Win32_PnPEntity"
  On Error Resume Next
   Set pnpDict = NewDictionary
   Set results = objWMI.ExecQuery(query)
   If Err.Number <> 0 Then
     Exit Function
   End If
  On Error Goto 0
  For Each result In results
   pnpDict(pnpDict.Count) = result.DeviceID
  Next
  deviceIDs    = pnpDict.Items
  GetPNPDeviceIDs = True
End Function
'-------------------------------------------------------------------------------
'Name    : GetUSBDeviceID -> Enumerates the USB Storage Device PNPDeviceID.
'Parameters : None      -> 
'Return   : GetUSBDeviceID -> Returns the the USB Storage Device PNPDeviceID.
'-------------------------------------------------------------------------------
Function GetUSBDeviceID
  Dim query, deviceID, results, result
  deviceID = ""
  query  = "Select PNPDeviceID From Win32_DiskDrive Where InterfaceType = 'USB'"
  On Error Resume Next
   Set results = objWMI.ExecQuery(query)
   If Err.Number <> 0 Then
     'LogMessage 1, "Executing query " & DQ(query)
     Exit Function
   End If
   For Each result In results
     deviceID = result.PNPDeviceID
     If Err.Number <> 0 Then
      deviceID = ""
      Exit For
     End If
   Next
  On Error Goto 0
  GetUSBDeviceID = deviceID
End Function
'-------------------------------------------------------------------------------
'Name    : GetUSBSerialNumber -> Extracts the Serial Number from the PNP Device ID.
'Parameters : deviceID      -> String containing the USB PNP Device ID.
'Return   : GetUSBSerialNumber -> Returns the the USB Devices Serial Number.
'-------------------------------------------------------------------------------
Function GetUSBSerialNumber(deviceID)
  Dim serialNumber
  On Error Resume Next
   serialNumber = Split(Mid(deviceID, InStrRev(deviceID, "\") +1), "&")(0)
   If Err.Number <> 0 Then
     serialNumber = ""
   End If
  On Error Goto 0
  GetUSBSerialNumber = serialNumber
End Function
'-------------------------------------------------------------------------------
'Name    : EjectUSBDevice -> Prompts the User and Executes a command to eject the USB device.
'Parameters : deviceID    -> String containing the USB Device pnpDeviceID to eject. 
'Return   : None      -> 
'-------------------------------------------------------------------------------
Function EjectUSBDevice(deviceID)
  Dim command
  '----------------------------------------------------------------------------
  'Prompt the user then automatically eject the USB device.
  '----------------------------------------------------------------------------
  On Error Resume Next
   wshShell.Popup "The USB device has not been approved for corporate use. " & _
           "It will be automatically removed from the system.", 3, scriptBaseName, 48
   command = "cmd /c " & fileName & " -EjectId:" & DQ(deviceID)
   wshShell.Run command, 0, False
  On Error Goto 0
End Function
'-------------------------------------------------------------------------------
'Name    : NewDictionary -> Creates a new dictionary object.
'Parameters : None   ->
'Return   : NewDictionary -> Returns a dictionary object.
'-------------------------------------------------------------------------------
Function NewDictionary
  Dim dict
  Set dict     = CreateObject("scripting.Dictionary")
  dict.CompareMode = vbTextCompare
  Set NewDictionary = dict
End Function
'-------------------------------------------------------------------------------
'Name    : DQ     -> Place double quotes around a string and replace double quotes 
'      :       -> within the string with pairs of double quotes. 
'Parameters : stringValue -> String value to be double quoted 
'Return   : DQ     -> Double quoted string. 
'------------------------------------------------------------------------------- 
Function DQ (ByVal stringValue) 
  If stringValue <> "" Then 
   DQ = """" & Replace (stringValue, """", """""") & """" 
  Else 
   DQ = """""" 
  End If 
End Function
'-------------------------------------------------------------------------------

Hope that helps

Cheers Matt :)

Saturday, February 12, 2011 4:40 AM

0

Sign in to vote

Matt, You are the man! I can't thank you enough for the help and guidance that you've given to me. This script worked withouth a problem on my machines today. Thanks so much for assisting me. I owe you a few beers by now.

Thanks,

Ron
Thanks, Ron

Sunday, February 13, 2011 3:35 AM
0

Sign in to vote

Hi Ron,

No worries, happy to help. If you're ever in Sydney let me know...firstname dot lastname at gmail dot com...i'll be happy to help you drink some beer :). I think the last script i posted works better than the first version, especially now that it continues to attempt to remove the device (or annoy the user) until it's removed. You'd just need to add the other functions back in for central logging etc, i'm sure you'll figure that part out but if not let me know.

Cheers Matt :)

Sunday, February 13, 2011 4:31 AM

Matt, I'm sure you're tired of hearing from me by now, but i'm got one more question. The script below has been working fine, now we have UAC on windows 7 enterprise going. Is there anyway to put it in the script to run so that the UAC doesn't make it bomb out?

'-------------------------------------------------------------------------------
'Script Name : Deploy.vbs
'Author  : Matthew Beattie
'Created  : 22/10/11
'Description : This script deploys all files in the "SystemFiles" folder in the scripts working directory in sysvol to the 
'   : local system directory.
'-------------------------------------------------------------------------------
'Initialization Section 
'-------------------------------------------------------------------------------
Option Explicit
Dim objFSO, scriptPath, systemPath
On Error Resume Next
 Set objFSO  = CreateObject("Scripting.FileSystemObject")
 scriptPath  = objFSO.GetFile(Wscript.ScriptFullName).ParentFolder.Path
 systemPath  = objFSO.GetSpecialFolder(1)
 ProcessScript
 If Err.Number <> 0 Then
  WScript.Quit
 End If
On Error Goto 0
'-------------------------------------------------------------------------------
'Functions Processing Section
'-------------------------------------------------------------------------------
'Name  : ProcessScript -> Primary Function that controls all other script processing.
'Parameters : None   ->
'Return  : None   ->
'-------------------------------------------------------------------------------
Function ProcessScript
 Dim folderSpec, fileName
 folderSpec = scriptPath & "\SystemFiles"
 If Not objFSO.FolderExists(folderSpec) Then
  Exit Function
 End If
 '----------------------------------------------------------------------------
 'Ensure all files in the "SystemFiles" folder in the group policy in Sysvol are deployed to the local system directory.
 '----------------------------------------------------------------------------
 If Not UpdateFiles(folderSpec, systemPath) Then
  Exit Function
 End If
End Function
'-------------------------------------------------------------------------------
'Name  : UpdateFiles -> Copies or updates all files from a specified folder if required.
'Parameters : folderSpec -> String containing the Source Folder specification containing the files to update.
'Return  : UpdateFiles -> Returns True if all files were copied or are up to date otherwise returns False.
'-------------------------------------------------------------------------------
Function UpdateFiles(sourceFolder, targetFolder)
 Dim files, file, result
 UpdateFiles = False
 On Error Resume Next
  Set files = objFSO.GetFolder(sourceFolder).Files
  If Err.Number <> 0 Then
   Exit Function
  End If
 On Error Goto 0
 For Each file In files
  Do
   result = UpdateFile(file.Path, targetFolder & "\" & file.Name)
   If result <> 0 Then
   Exit Function
   End If
  Loop Until True
 Next
 UpdateFiles = True
End Function
'-------------------------------------------------------------------------------
'Name  : UpdateFile -> Copy or update a file if required.
'Parameters : sourceFile -> String containing the Source file specification.
'   : targetFile -> String containing the target file specification.
'Return  : UpdateFile -> 0 If file already up-to-date or copied successfully. Error code otherwise.
'-------------------------------------------------------------------------------
Function UpdateFile(sourceFile, targetFile)
 Dim objSource, objTarget
 On Error Resume Next
  If objFSO.FileExists(targetFile) Then
   Set objSource = objFSO.GetFile(sourceFile)
   Set objTarget = objFSO.GetFile(targetFile)
   If Err.Number = 0 Then
   If objSource.Size <> objTarget.Size Or objSource.DateLastModified <> objTarget.DateLastModified Then
    objTarget.Attributes = 0
    objSource.Copy targetFile, True
    objFSO.GetFile(targetFile).Attributes = 32 'ensure the target file is not read-only.
   End If
   End If
  Else
   objFSO.CopyFile sourceFile, targetFile
   objFSO.GetFile(targetFile).Attributes = 32  'ensure the target file is not read-only.
  End If
  If Err.Number <> 0 Then
   LogMessage 1, "Copying " & DQ(sourceFile) & " to " & DQ(targetFile)
  End If
  UpdateFile = Err.Number
 On Error Goto 0
End Function
'-------------------------------------------------------------------------------
'Name  : DQ   -> Place double quotes around a string and replace double quotes 
'   :    -> within the string with pairs of double quotes. 
'Parameters : stringValue -> String value to be double quoted 
'Return  : DQ   -> Double quoted string. 
'-------------------------------------------------------------------------------
Function DQ (ByVal stringValue) 
 If stringValue <> "" Then 
  DQ = """" & Replace (stringValue, """", """""") & """" 
 Else 
  DQ = """""" 
 End If 
End Function
'-------------------------------------------------------------------------------

If it makes you feel any better, I built a package in SCCM 2007 R2 and I get the same problem as when i run the script. Its bombs out at the UAC.

Thanks again for the help and sorry to bother you again.

Ron

Thanks, Ron

Wednesday, February 16, 2011 3:39 AM

0

Sign in to vote

Hi Ron,

If you have SCCM then there is no need to use the "Deploy.vbs" script within your package, just deploy the "deveject.exe" utility to the system32 folder on your clients. The "Deploy.vbs" script is for "poor mans" deployment and is meant to be configured as a computer startup script via group policy to ensure it is run as the local system account and therefore has access to copy the file. I haven't tested this on Windows 7, What are your UAC settings?

Cheers Matt :)

Wednesday, February 16, 2011 7:35 AM
0

Sign in to vote

Hey matt, its me again with another question asking for help again. I have been using all your scripts and everything is working wonderfully. I am trying something totally different now. I need to move some files into another location, how can i modify your deploy.vbs to make this happen? I can still use the system files folder but i need to move files into this folder: C:\Windows\System32\oobe\Info\Backgrounds. Or do you have another script that may work better? I need to move photos from a network share into that folder. any ideas on how to make that happen?

Thanks for you help and knowledge.

Ron
Thanks, Ron

Tuesday, March 1, 2011 12:38 AM

Hi Ron,

No problem, just replace the "ProcessScript" function with something like this (assuming there is a backgrounds folder within the scripts working directory containing the backgrounds you want to copy to system32\oobe\info\backgrounds directory.

Cheers Matt :)

'------------------------------------------------------------------------------
'Name : ProcessScript -> Primary Function that controls all other script processing.
'Parameters : None  ->
'Return : None  ->
'-------------------------------------------------------------------------------
Function ProcessScript
 Dim sourceSpec, targetSpec
 sourceSpec = scriptPath & "\Backgrounds"
 targetSpec = systemPath & "\oobe\Info\Backgrounds"
 If Not objFSO.FolderExists(sourceSpec) Then
  Exit Function
 End If
 If Not objFSO.FolderExists(targetSpec) Then
  Exit Function
 End If
 '----------------------------------------------------------------------------
 'Ensure all files in the "SystemFiles" folder in the group policy in Sysvol are deployed to the local system directory.
 '----------------------------------------------------------------------------
 If Not UpdateFiles(folderSpec, targetSpec) Then
  Exit Function
 End If
End Function

Edited by MatthewBeattie Tuesday, March 1, 2011 10:20 AM typo

Tuesday, March 1, 2011 10:20 AM

0

Sign in to vote

Thanks Matt for the assistance. Below is what i have and nothing happens, can you look and see if i'm doing something wrong? This is your deploy.vbs script that you sent. It works wonderful for deploying the deveject program from the sysvol. I have a folder on the sysvol now called backgrounds and i inserted your code from above and put this in a new gpo and nothing happens.

'-------------------------------------------------------------------------------
'Script Name : Deploy.vbs
'Author   : Matthew Beattie
'Created   : 22/10/11
'Description : This script deploys all files in the "SystemFiles" folder in the scripts working directory in sysvol to the
'      : local system directory.
'-------------------------------------------------------------------------------
'Initialization Section
'-------------------------------------------------------------------------------
Option Explicit
Dim objFSO, scriptPath, systemPath
On Error Resume Next
Set objFSO   = CreateObject("Scripting.FileSystemObject")
scriptPath   = objFSO.GetFile(Wscript.ScriptFullName).ParentFolder.Path
systemPath   = objFSO.GetSpecialFolder(1)
ProcessScript
If Err.Number <> 0 Then
   WScript.Quit
End If
On Error Goto 0
'-------------------------------------------------------------------------------
'Functions Processing Section
'------------------------------------------------------------------------------
'Name : ProcessScript -> Primary Function that controls all other script processing.
'Parameters : None   ->
'Return : None   ->
'-------------------------------------------------------------------------------
Function ProcessScript
Dim sourceSpec, targetSpec
sourceSpec = scriptPath & "\Backgrounds"
targetSpec = systemPath & "\oobe\Info\Backgrounds"
If Not objFSO.FolderExists(sourceSpec) Then
   Exit Function
End If
If Not objFSO.FolderExists(targetSpec) Then
   Exit Function
End If
'----------------------------------------------------------------------------
'Ensure all files in the "SystemFiles" folder in the group policy in Sysvol are deployed to the local system directory.
'----------------------------------------------------------------------------
If Not UpdateFiles(folderSpec, targetSpec) Then
   Exit Function
End If
End Function

'-------------------------------------------------------------------------------
'Name    : UpdateFiles -> Copies or updates all files from a specified folder if required.
'Parameters : folderSpec -> String containing the Source Folder specification containing the files to update.
'Return   : UpdateFiles -> Returns True if all files were copied or are up to date otherwise returns False.
'-------------------------------------------------------------------------------
Function UpdateFiles(sourceFolder, targetFolder)
Dim files, file, result
UpdateFiles = False
On Error Resume Next
   Set files = objFSO.GetFolder(sourceFolder).Files
   If Err.Number <> 0 Then
     Exit Function
   End If
On Error Goto 0
For Each file In files
   Do
     result = UpdateFile(file.Path, targetFolder & "\" & file.Name)
     If result <> 0 Then
      Exit Function
     End If
   Loop Until True
Next
UpdateFiles = True
End Function
'-------------------------------------------------------------------------------
'Name    : UpdateFile -> Copy or update a file if required.
'Parameters : sourceFile -> String containing the Source file specification.
'      : targetFile -> String containing the target file specification.
'Return   : UpdateFile -> 0 If file already up-to-date or copied successfully. Error code otherwise.
'-------------------------------------------------------------------------------
Function UpdateFile(sourceFile, targetFile)
Dim objSource, objTarget
On Error Resume Next
   If objFSO.FileExists(targetFile) Then
     Set objSource = objFSO.GetFile(sourceFile)
     Set objTarget = objFSO.GetFile(targetFile)
     If Err.Number = 0 Then
      If objSource.Size <> objTarget.Size Or objSource.DateLastModified <> objTarget.DateLastModified Then
        objTarget.Attributes = 0
        objSource.Copy targetFile, True
        objFSO.GetFile(targetFile).Attributes = 32 'ensure the target file is not read-only.
      End If
     End If
   Else
     objFSO.CopyFile sourceFile, targetFile
     objFSO.GetFile(targetFile).Attributes = 32    'ensure the target file is not read-only.
   End If
   If Err.Number <> 0 Then
     LogMessage 1, "Copying " & DQ(sourceFile) & " to " & DQ(targetFile)
   End If
   UpdateFile = Err.Number
On Error Goto 0
End Function
'-------------------------------------------------------------------------------
'Name    : DQ     -> Place double quotes around a string and replace double quotes
'      :       -> within the string with pairs of double quotes.
'Parameters : stringValue -> String value to be double quoted
'Return   : DQ     -> Double quoted string.
'-------------------------------------------------------------------------------
Function DQ (ByVal stringValue)
If stringValue <> "" Then
   DQ = """" & Replace (stringValue, """", """""") & """"
Else
   DQ = """"""
End If
End Function
'-------------------------------------------------------------------------------

Thanks,

Ron
Thanks, Ron

Tuesday, March 1, 2011 7:17 PM

Hi Ron,

Sorry i didn't notice your reply all the way down the bottom of this post. Did you check if the target folder exists? "C:\windows\system32\oobe\Info\Backgrounds", if it doesn't exist then create it...something like this should do

Cheers Matt :)

'-------------------------------------------------------------------------------
'Functions Processing Section
'------------------------------------------------------------------------------
'Name : ProcessScript -> Primary Function that controls all other script processing.
'Parameters : None  ->
'Return : None  ->
'-------------------------------------------------------------------------------
Function ProcessScript
  Dim sourceSpec, targetSpec
  sourceSpec = scriptPath & "\Backgrounds"
  targetSpec = systemPath & "\oobe\Info\Backgrounds"
  If Not objFSO.FolderExists(sourceSpec) Then
   Exit Function
  End If
  '----------------------------------------------------------------------------
  'Create the target folder if it doesn't exist.
  '----------------------------------------------------------------------------
  If Not objFSO.FolderExists(targetSpec) Then
   If Not CreateFolder(targetSpec) Then
     Exit Function
   End If
  End If
  '----------------------------------------------------------------------------
  'Ensure all files in the "SystemFiles" folder in the group policy in Sysvol are deployed to the local system directory.
  '----------------------------------------------------------------------------
  If Not UpdateFiles(folderSpec, targetSpec) Then
   Exit Function
  End If
End Function

'-------------------------------------------------------------------------------
'Name    : CreateFolder -> Recursive Function to Create a directory structure or single folder.
'Parameters : folderSpec  -> Path of folder\folders to create.
'Return   : CreateFolder -> Returns True if the directory structure was successfully created otherwise False.
'-------------------------------------------------------------------------------
Function CreateFolder(folderSpec)
  CreateFolder = False
  If Not objFSO.FolderExists(folderSpec) Then
   If InStrRev(folderSpec, "\") <> 0 Then
     If Not CreateFolder(Left(folderSpec, InStrRev(folderSpec, "\") - 1)) Then
      Exit Function
     End If
   End If
   On Error Resume Next
     objFSO.CreateFolder folderSpec
     If Err.Number <> 0 Then
      Exit Function
     End If
   On Error Goto 0
  End If
  CreateFolder = True
End Function
'-------------------------------------------------------------------------------

Wednesday, March 30, 2011 10:32 AM

0

Sign in to vote

Hey matt, thanks for all your help. Everything is working great. No problems thus far. I do however have another question for you. Do you have a script that i can run that will log users out? I'm trying to come up with a way to log users out of the machines about 8 hours of nonuse or something of that nature. Any help you can provide is great appreciated. Thanks again for all your help.

thanks,

Ron
Thanks, Ron

Monday, April 11, 2011 11:54 PM
0

Sign in to vote

Hi,

Since you're asking a different question, please start a new thread. This one is already marked answered.

Bill

Tuesday, April 12, 2011 3:12 PM

Products

Resources

Solutions

Updates

Trials

Related Sites

Training

Certifications

Other resources

Support options

More support

Not an IT pro?

Answered by:

Domain login VBS Script

Question

Answers

All replies