locked
Domain login VBS Script RRS feed

  • Question

  • 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

  • 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
  • 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
  • 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
  • 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
  • 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
  • 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
  • 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
  • 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
  • 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
  • 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
  • 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
  • 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
    '-------------------------------------------------------------------------------
    Saturday, January 22, 2011 6:39 AM
  • 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:

    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
  • 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
  • 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
  • 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
  • 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
  • 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
  • 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
  • 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
  • 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
  • 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
  • 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
  • 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
  • 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
  • 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
  • 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
  • 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
  • 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
    
    
    Tuesday, March 1, 2011 10:20 AM
  • 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
  • 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
  • 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