На главную Наши проекты:
Журнал   ·   Discuz!ML   ·   Wiki   ·   DRKB   ·   Помощь проекту
ПРАВИЛА FAQ Помощь Участники Календарь Избранное RSS
msm.ru
! Правила раздела Visual Basic: Общие вопросы
Здесь обсуждаются вопросы по языку Visual Basic 1-6 (а так же по схожим языкам, как, например, PowerBASIC).
Вопросы по Visual Basic .NET (это который входит в состав Visual Studio 2002/2003/2005/2008+, для тех, кто не в курсе) обсуждаются в разделе .NET.

Обратите внимание:
1. Прежде чем начать новую тему или отправить сообщение, убедитесь, что Вы не нарушаете правил форума!
2. Обязательно воспользуйтесь поиском. Возможно, Ваш вопрос уже обсуждали. Полезные ссылки приведены ниже.
3. Темы с просьбой выполнить какую-либо работу за автора в этом разделе не обсуждаются. Студенты, вам сюда: ПОМОЩЬ СТУДЕНТАМ!
4. Используйте теги [ code=vba ] ...текст программы... [ /code ] для выделения текста программы подсветкой.
5. Помните, здесь телепатов нет. Формулируйте свой вопрос максимально грамотно и чётко: Как правильно задавать вопросы
6. Запрещено отвечать в темы месячной (и более) давности, без веских на то причин.

Полезные ссылки:
user posted image FAQ Сайта user posted image FAQ Раздела user posted image Кладовка user posted image Наши Исходники user posted image API-Guide user posted image Поиск по Разделу user posted image MSDN Library Online user posted image Google

Ваше мнение о модераторах: user posted image SCINER, user posted image B.V.
Модераторы: SCINER, B.V.
  
> Включение и отключение микрофона и вебкамеры
    Здравствуйте!
    Подскажите, пожалуйста, как осуществить программное включение и отключение микрофона и вебкамеры?
    В интернете читал про батники, но там через сторонние программы как-то это делается.
    Нельзя ли обойтись стандартными средствами?
      Нашёл в интернете пример.
      Как с помощью него отключить камеру, не знаю.
      Микрофон можно как отключить, так и включить, я очень рад!
      Прикреплённый файлПрикреплённый файл________________.part01.rar (200 Кбайт, скачиваний: 67)
      Прикреплённый файлПрикреплённый файл________________.part02.rar (200 Кбайт, скачиваний: 70)
      Прикреплённый файлПрикреплённый файл________________.part03.rar (114,97 Кбайт, скачиваний: 65)
        Через WMI - находишь соотв. Win32_PnPEntity, у которого должны быть методы Disable/Enable...
          Akina, спасибо большое
          также дали ссылку на пример ASM через WINAPI: https://www.manhunter.ru/assembler/813_kak_...assemblere.html
            Цитата salieri @
            Микрофон можно как отключить, так и включить, я очень рад!

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

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

              ?? то есть даже отключенный в диспетчере оборудования микрофон - включает?
                Akina, нет, в диспетчере не включает, конечно
                поэтому задача и стоит, отключить микрофон в самом диспетчере устройств
                  Цитата salieri @
                  отключить микрофон в самом диспетчере устройств

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

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

                      ExpandedWrap disabled
                        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 -
                        Цитата Akina @
                        Через WMI - находишь соотв. Win32_PnPEntity, у которого должны быть методы Disable/Enable


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

                        ExpandedWrap disabled
                          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
                            Я думаю, это немного поможет:
                            Скрытый текст

                            ExpandedWrap disabled
                              '-------------------------------------------------------------------------------
                              '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 -
                              Bubaylo, спасибо большое, но это очень сложный путь, тем более для моей скромной задачи
                              может проще в реестре поменять 1 параметр всего?
                              дело только в том, что раздел HKCU меняется без вопросов, а HKLM не получается изменить программно
                                0 пользователей читают эту тему (0 гостей и 0 скрытых пользователей)
                                0 пользователей:


                                Рейтинг@Mail.ru
                                [ Script execution time: 0,0524 ]   [ 18 queries used ]   [ Generated: 26.05.24, 18:44 GMT ]