Включение и отключение микрофона и вебкамеры

[salieri]

Здравствуйте!
Подскажите, пожалуйста, как осуществить программное включение и отключение микрофона и вебкамеры?
В интернете читал про батники, но там через сторонние программы как-то это делается.
Нельзя ли обойтись стандартными средствами?

[salieri]

Нашёл в интернете пример.
Как с помощью него отключить камеру, не знаю.
Микрофон можно как отключить, так и включить, я очень рад!
Прикреплённый файл________________.part01.rar (200 Кбайт, скачиваний: 64)
Прикреплённый файл________________.part02.rar (200 Кбайт, скачиваний: 66)
Прикреплённый файл________________.part03.rar (114,97 Кбайт, скачиваний: 62)

[Akina]

Через WMI - находишь соотв. Win32_PnPEntity, у которого должны быть методы Disable/Enable...

[salieri]

Akina, спасибо большое
также дали ссылку на пример ASM через WINAPI: https://www.manhunter.ru/assembler/813_kak_...assemblere.html

[salieri]

Цитата salieri @ 01.02.22, 04:54

Микрофон можно как отключить, так и включить, я очень рад!

я пришёл к выводу, что микрофон отключается, но когда запускаешь программу видеоконференций Zoom, то он тут же включается, как с этим быть?

нужно микрофон выключить из системы, а не громкость отключить, чтобы сторонние программы не определяли его
как это осуществить, подскажите, пожалуйста.

[Akina]

Цитата salieri @ 06.04.22, 09:03

микрофон отключается, но когда запускаешь программу видеоконференций Zoom, то он тут же включается

?? то есть даже отключенный в диспетчере оборудования микрофон - включает?

[salieri]

Akina, нет, в диспетчере не включает, конечно
поэтому задача и стоит, отключить микрофон в самом диспетчере устройств

[Alexei]

Цитата salieri @ 06.04.22, 12:58

отключить микрофон в самом диспетчере устройств

Так отключите!
Я , например, когда не знаю что делать , имитирую действия пользователя. Есть такая штука WinAPI.
Его функциями можно открывать нужные приложения, находить окна, посылать им сообщения.
В ВБ это несколько заморочисто, но есть толстая книжка Эпплман Д. Win32 API и Visual Basic.

[salieri]

Alexei, спасибо большое!

[salieri]

Нашёл пример на VB.NET.
Помогите, пожалуйста, его перевести на VB6, если не затруднит.

Источник: http://rsdn.org/forum/gdn.common/1373155.hot

Private UnknownDevice As String = "<Unknown Device>"
Private hDevInfo As IntPtr
Public DeviceList As New DeviceCollection()
'получение списка всех устройств
 
Public Function RefreshDevices() As Boolean
Dim i, Status, Problem As Integer
Dim DeviceInfoData As IntPtr
Dim dev_data As SP_DEVINFO_DATA
dev_data.init()
hDevInfo = SetupDiGetClassDevs(IntPtr.Zero, IntPtr.Zero, 0, DIGCF_PRESENT Or DIGCF_ALLCLASSES)
If hDevInfo.ToInt32 < 0 Then
MsgBox ("Hе удаётся получить информацию об устройствах")
Return False
End If
'// Clean off all the items in a TreeView.
DeviceList.Clear()
'// Enumerate though all the devices.
DeviceInfoData = Marshal.AllocHGlobal(Marshal.SizeOf(dev_data))
Marshal.StructureToPtr(dev_data, DeviceInfoData, True)
i = 0
While SetupDiEnumDeviceInfo(hDevInfo, i, DeviceInfoData)
dev_data = Marshal.PtrToStructure(DeviceInfoData, GetType(SP_DEVINFO_DATA))
' // Should we display this device, or move onto the next one.
If CR_SUCCESS <> CM_Get_DevNode_Status(Status, Problem, dev_data.DevInst, 0) Then
'MsgBox("Get_DevNode_Status")
GoTo EndWhile
End If
Dim buf As String = UnknownDevice
ConstructDeviceName(hDevInfo, DeviceInfoData, buf, buf.Length)
Dim idx As Integer = DeviceList.Add(New Device())
DeviceList(idx).dev_data = dev_data
DeviceList(idx).Name = buf
DeviceList(idx).State = Config.eState.Uncknown
If IsDisabled(dev_data) Then
DeviceList(idx).State = Config.eState.Off
ElseIf IsDisableable(dev_data) Then
DeviceList(idx).State = Config.eState.On
End If
EndWhile:
i += 1
End While
Marshal.FreeHGlobal (DeviceInfoData)
Return True
End Function
 
Private Function ConstructDeviceName(ByVal DeviceInfoSet As IntPtr, ByVal DeviceInfoData As IntPtr, ByRef Buffer As String, ByVal Length As Int32) As Boolean
'If Not GetRegistryProperty(DeviceInfoSet, DeviceInfoData, SPDRP_FRIENDLYNAME, Buffer, Length) Then
If Not GetRegistryProperty(DeviceInfoSet, DeviceInfoData, SPDRP_DEVICEDESC, Buffer, Length) Then
If Not GetRegistryProperty(DeviceInfoSet, DeviceInfoData, SPDRP_CLASS, Buffer, Length) Then
If Not GetRegistryProperty(DeviceInfoSet, DeviceInfoData, SPDRP_CLASSGUID, Buffer, Length) Then
End If
End If
End If
'End If
Return True
End Function
 
Private Function GetRegistryProperty(ByVal DeviceInfoSet As IntPtr, ByVal DeviceInfoData As IntPtr, ByVal Prop As Int32, ByRef Buffer As String, ByVal Length As Int32) As Boolean
Dim RecLen As Int32
While Not SetupDiGetDeviceRegistryProperty(DeviceInfoSet, DeviceInfoData, Prop, vbNull, Buffer, Buffer.Length, RecLen)
If (GetLastError() = ERROR_INSUFFICIENT_BUFFER) Then
'// We need to change the buffer size.
Buffer &= Space(RecLen — Buffer.Length)
Else
'// Unknown Failure.
If (GetLastError() <> ERROR_INVALID_DATA) Then
'MsgBox("GetDeviceRegistryProperty")
Return False
End If
End If
End While
Return RecLen
End Function
 
Private Function IsDisabled(ByVal dev_data As SP_DEVINFO_DATA) As Boolean
Dim Status, Problem As Integer
If CR_SUCCESS <> CM_Get_DevNode_Status(Status, Problem, dev_data.DevInst, 0) Then
MsgBox ("Get_DevNode_Status")
Return False
End If
Return (Status And DN_HAS_PROBLEM) And (CM_PROB_DISABLED = Problem)
End Function
 
Private Function IsDisableable(ByVal dev_data As SP_DEVINFO_DATA) As Boolean
Dim Status, Problem As Integer
If CR_SUCCESS <> CM_Get_DevNode_Status(Status, Problem, dev_data.DevInst, 0) Then
MsgBox ("Get_DevNode_Status")
Return False
End If
Return (Status And DN_DISABLEABLE) And (CM_PROB_HARDWARE_DISABLED <> Problem)
End Function
 
'включение
Public Function setOn(ByVal cGuid As Guid) As Boolean
Dim idx As Integer = FindIndex(cGuid)
If idx < 0 Then Return False
Return StateChange(DICS_ENABLE, CType(DeviceList(idx).Dev_Data, SP_DEVINFO_DATA))
End Function
 
'выключение
Public Function setOff(ByVal cGuid As Guid) As Boolean
Dim idx As Integer = FindIndex(cGuid)
If idx < 0 Then Return False
Return StateChange(DICS_DISABLE, CType(DeviceList(idx).Dev_Data, SP_DEVINFO_DATA))
End Function
 
Private Function StateChange(ByVal NewState As Int32, ByVal dev_data As SP_DEVINFO_DATA) As Boolean
Dim PropChangeParams As SP_PROPCHANGE_PARAMS
PropChangeParams.init()
'// Set the PropChangeParams structure.
PropChangeParams.ClassInstallHeader.InstallFunction = DIF_PROPERTYCHANGE
PropChangeParams.Scope = DICS_FLAG_GLOBAL
PropChangeParams.StateChange = NewState
Dim DeviceInfoData As IntPtr = Marshal.AllocHGlobal(Marshal.SizeOf(dev_data))
Marshal.StructureToPtr(dev_data, DeviceInfoData, True)
Dim PropParams As IntPtr = Marshal.AllocHGlobal(Marshal.SizeOf(PropChangeParams))
Marshal.StructureToPtr(PropChangeParams, PropParams, True)
If Not SetupDiSetClassInstallParamsW(hDevInfo, DeviceInfoData, PropParams, Marshal.SizeOf(PropChangeParams)) Then
MsgBox ("SetClassInstallParams")
Return False
End If
'// Call the ClassInstaller and perform the change.
If Not SetupDiCallClassInstaller(DIF_PROPERTYCHANGE, hDevInfo, DeviceInfoData) Then
MsgBox ("SetClassInstallParams")
Return False
End If
Marshal.FreeHGlobal (DeviceInfoData)
Marshal.FreeHGlobal (PropParams)
RefreshDevices()
Return True
End Function
 
Public Function Verify(ByVal Dev As Guid) As Boolean
Dim i As Integer
For i = 0 To DeviceList.Count — 1
If _config.Name = DeviceList(i).Name Then
If CType(DeviceList(i).Dev_Data, SP_DEVINFO_DATA).ClassGuid.CompareTo(dev) Then Return True
End If
Next
Return False
End Function
 
Public Function FindIndex(ByVal Dev As Guid) As Integer
Dim i As Integer
For i = 0 To DeviceList.Count — 1
If CType(DeviceList(i).dev_data, SP_DEVINFO_DATA).ClassGuid.CompareTo(Dev) Then
Return i
End If
Next
Return -1
End Function
 
Public Function FreeHandle()
Marshal.FreeHGlobal (hDevInfo)
DeviceList.Clear()
DeviceList = Nothing
End Function
End Module

Сообщение отредактировано: salieri - 16.04.22, 21:35

[salieri]

Цитата Akina @ 02.02.22, 06:25

Через WMI - находишь соотв. Win32_PnPEntity, у которого должны быть методы Disable/Enable

Здравствуйте!
Еле-еле сделал отключение, микрофон в диспетчере задач отключается, это видно, но из списка не удаляется, в итоге, продолжает работать.
Как быть?

Public Function EnableDevice(lEnumerator As Long, ByVal bEnable As Boolean) As Boolean
 
    Dim changeParams As SP_PROPCHANGE_PARAMS
    Dim hDevInfo     As Long
    Dim DevInfo      As SP_DEVINFO_DATA
    Dim tGUID        As GUID
 
    hDevInfo = SetupDiGetClassDevs(tGUID, vbNullString, 0, DEVICEFLAGS.DIGCF_PRESENT Or DEVICEFLAGS.DIGCF_ALLCLASSES)
    DevInfo.cbSize = LenB(DevInfo)
 
    If SetupDiEnumDeviceInfo(hDevInfo, lEnumerator, DevInfo) = 0 Then
        SetupDiDestroyDeviceInfoList hDevInfo
        Exit Function
    End If
 
    With changeParams
        .ClassInstallHeader.cbSize = LenB(.ClassInstallHeader)
        .ClassInstallHeader.InstallFunction = DIF_PROPERTYCHANGE
        .Scope = DICS_FLAG_CONFIGSPECIFIC    'DICS_FLAG_GLOBAL Or
        .StateChange = IIf(bEnable, DICS_ENABLE, DICS_DISABLE)
        .HwProfile = 0
    End With
 
    If SetupDiSetClassInstallParams(hDevInfo, DevInfo, changeParams.ClassInstallHeader, LenB(changeParams)) = 1 Then
        EnableDevice = (SetupDiChangeState(hDevInfo, DevInfo) = 1)
    End If
    
    
    
    SendMessage HWND_BROADCAST, WM_SETTINGCHANGE, 0, 0
    
 
End Function

[salieri]

Скажите, пожалуйста, вообще, в какую сторону копать, чтобы полностью отключить драйвер устройства микрофона?

[Bubaylo]

salieri
Я думаю, это немного поможет:

Скрытый текст

'-------------------------------------------------------------------------------
'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
'-------------------------------------------------------------------------------

брал вот тут

Правда это вб скрипт, но разница не большая.

Сообщение отредактировано: Bubaylo - 08.06.22, 06:09

[salieri]

Bubaylo, спасибо большое, но это очень сложный путь, тем более для моей скромной задачи
может проще в реестре поменять 1 параметр всего?
дело только в том, что раздел HKCU меняется без вопросов, а HKLM не получается изменить программно

[Akina]

https://habr.com/ru/company/globalsign/blog/670442/