Здравствуйте. Не ругайтесь на меня за столь надоедливую тему, и не посылайте на похожие темы, я их пересмотрел, в VBA ноль. Прошу о помощи выполнить следующую задачу, которую мне поставил мой руководитель. Вот дали мне такой файл, Tips_Macro_Sheets_Rng_for_Users скачали его отсюда, нужно чтобы перед запуском "сообщения с паролем", он проверял на том компьютере находится или нет, как вот этой теме "Как защитить книгу Excel?, там есть код, который проверяет номер процессора. Если на том компьютере, то переходим к "сообщению с паролем", а если нет, то удаляем этот файл минуя корзины, как здесь КАК УДАЛИТЬ КНИГУ ИЗ САМОЙ СЕБЯ. Надеюсь понятно обрисовал ситуацию. Честно извиняюсь, за то, что прошу, о такой тяжелой помощи.
Так вообщем пол задачи сделано. Я скидываю на Ваш сайт файл, чтобы войти в него, Логин Иванов; пароль 1. В модуле эта книга размещен такой код:
Код
Option Explicit
Private Sub Workbook_BeforeClose(Cancel As Boolean)
Application.ScreenUpdating = False
Dim wsSh As Worksheet
Sheets("WARNING").Visible = -1
For Each wsSh In ThisWorkbook.Sheets
If wsSh.Name <> "WARNING" Then wsSh.Visible = 2
Next wsSh
Application.ScreenUpdating = 1
ThisWorkbook.Save
End Sub
Private Sub Workbook_Open()
Application.ScreenUpdating = False
ThisWorkbook.Sheets("Main").Visible = -1
ThisWorkbook.Sheets("WARNING").Visible = 2
DelThisWorkbook
frmIndicateUser.Show
Application.ScreenUpdating = 1
End Sub
Sub DelThisWorkbook()
If Date > #12/30/2020# Then
Application.DisplayAlerts = False
ThisWorkbook.ChangeFileAccess xlReadOnly
Kill ThisWorkbook.FullName
Application.DisplayAlerts = True
ThisWorkbook.Close 0 'если необходимо сразу же закрыть книгу(рекомендуется)
End If
End Sub
то есть, если мы в
Код
Sub DelThisWorkbook()
If Date > #12/30/2020# Then
поменяем дату на "12/30/2019", сохраним, то после открытия файл самоуничтожится минуя корзины, а если останется дата "12/30/2020", то выскочит поле с вводом логина и пароля. Просьба подкорректируйте код так, чтобы он проверял не по дате, а по номеру процессора вот код:
Код
Sub SpecificationsProcessor()
Dim strComputer As String
Dim objWMIService As Object, colProcessor As Object, objProcessor As Object
strComputer = "."
Set objWMIService = GetObject("winmgmts:{impersonationLevel=impersonate}!\\" & strComputer & "\root\cimv2")
Set colProcessor = objWMIService.ExecQuery("SELECT * FROM Win32_Processor")
For Each objProcessor In colProcessor
Debug.Print "ProcessorId: " & objProcessor.ProcessorId
MsgBox "ProcessorId: " & objProcessor.ProcessorId
Next
End Sub
Код проверяет, например по серийному номеру процессора, на каком ПК запущен, если серийный номер в коде соответствует серийному номеру процессора, то продолжаем дальше работать в книге, если нет то самоудаляется. Надо было написать "запущен" а не "находиться".
Sub DelThisWorkbook()
Select Case SpecificationsProcessor
Case "12345"
Application.DisplayAlerts = False
ThisWorkbook.ChangeFileAccess xlReadOnly
Kill ThisWorkbook.FullName
Application.DisplayAlerts = True
ThisWorkbook.Close 0 'если необходимо сразу же закрыть книгу(рекомендуется)
End Select
End Sub
'
Function SpecificationsProcessor() As String
Dim strComputer As String
Dim objWMIService As Object, colProcessor As Object, objProcessor As Object
strComputer = "."
Set objWMIService = GetObject("winmgmts:{impersonationLevel=impersonate}!\\" & strComputer & "\root\cimv2")
Set colProcessor = objWMIService.ExecQuery("SELECT * FROM Win32_Processor")
For Each objProcessor In colProcessor
SpecificationsProcessor = objProcessor.ProcessorId
Next
End Function
МатросНаЗебре, почему то не срабатывает, я правильно сделал поместил в модуль "Эта книга"
Код
Option Explicit
Private Sub Workbook_Open()
DelThisWorkbook
End Sub
Sub DelThisWorkbook()
Select Case SpecificationsProcessor
Case "12345"
Application.DisplayAlerts = False
ThisWorkbook.ChangeFileAccess xlReadOnly
Kill ThisWorkbook.FullName
Application.DisplayAlerts = True
ThisWorkbook.Close 0 'если необходимо сразу же закрыть книгу(рекомендуется)
End Select
End Sub
'
Function SpecificationsProcessor() As String
Dim strComputer As String
Dim objWMIService As Object, colProcessor As Object, objProcessor As Object
strComputer = "."
Set objWMIService = GetObject("winmgmts:{impersonationLevel=impersonate}!\\" & strComputer & "\root\cimv2")
Set colProcessor = objWMIService.ExecQuery("SELECT * FROM Win32_Processor")
For Each objProcessor In colProcessor
SpecificationsProcessor = objProcessor.ProcessorId
Next
End Function
Sub DelThisWorkbook()
Select Case Environ$("COMPUTERNAME")
Case "ВАШ ПИСЬЮК"
Case Else
Application.DisplayAlerts = False
ThisWorkbook.ChangeFileAccess xlReadOnly
Kill ThisWorkbook.FullName
Application.DisplayAlerts = True
ThisWorkbook.Close 0 'если необходимо сразу же закрыть книгу(рекомендуется)
End Select
End Sub
МатросНаЗебре извините, что туплю, я вставил Ваш код, модуль книги
Код
Option Explicit
Private Sub Workbook_Open()
DelThisWorkbook
End Sub
Sub DelThisWorkbook()
Select Case Environ$("COMPUTERNAME")
Case "BFEBFBFF000306C3"
Case Else
Application.DisplayAlerts = False
ThisWorkbook.ChangeFileAccess xlReadOnly
Kill ThisWorkbook.FullName
Application.DisplayAlerts = True
ThisWorkbook.Close 0 'если необходимо сразу же закрыть книгу(рекомендуется)
End Select
End Sub
'
Function SpecificationsProcessor() As String
Dim strComputer As String
Dim objWMIService As Object, colProcessor As Object, objProcessor As Object
strComputer = "."
Set objWMIService = GetObject("winmgmts:{impersonationLevel=impersonate}!\\" & strComputer & "\root\cimv2")
Set colProcessor = objWMIService.ExecQuery("SELECT * FROM Win32_Processor")
For Each objProcessor In colProcessor
SpecificationsProcessor = objProcessor.ProcessorId
Next
End Function
Чтобы проверить процессор компьютера, я использую этот код
Код
Sub SpecificationsProcessor()
Dim strComputer As String
Dim objWMIService As Object, colProcessor As Object, objProcessor As Object
strComputer = "."
Set objWMIService = GetObject("winmgmts:{impersonationLevel=impersonate}!\\" & strComputer & "\root\cimv2")
Set colProcessor = objWMIService.ExecQuery("SELECT * FROM Win32_Processor")
For Each objProcessor In colProcessor
Debug.Print "ProcessorId: " & objProcessor.ProcessorId
MsgBox "ProcessorId: " & objProcessor.ProcessorId
Next
End Sub
Записываю полученный номер но он все равно удаляется. Что я не так делаю?
МатросНаЗебре, я раннее изменил сообщение, Вы его не увидели. Просьба пожалуйста, если не сложно, можно привязать не к имени компьютера, к серийнику системного диска, например, если к процессору не получается?
Получается. Выше почти есть ответ. Достаточно поправить условие.
Код
Sub DelThisWorkbook()
Select Case SpecificationsProcessor
Case "BFEBFBFF000306C3"
Case else
Application.DisplayAlerts = False
ThisWorkbook.ChangeFileAccess xlReadOnly
Kill ThisWorkbook.FullName
Application.DisplayAlerts = True
ThisWorkbook.Close 0 'если необходимо сразу же закрыть книгу(рекомендуется)
End Select
End Sub