Поиск  Пользователи  Правила  Войти
Форумы "Планета Excel" » Вопросы по Microsoft Excel
Страницы: 1
RSS
Удаление книги по условию
 
#1
22.01.2020 07:06:00
Здравствуйте. Не ругайтесь на меня за столь надоедливую тему, и не посылайте на похожие темы, я их пересмотрел, в VBA ноль. Прошу о помощи выполнить следующую задачу, которую мне поставил мой  руководитель. Вот дали мне такой файл, Tips_Macro_Sheets_Rng_for_Users скачали его отсюда, нужно чтобы перед запуском "сообщения с паролем", он проверял на том компьютере находится или нет, как вот этой теме "Как защитить книгу Excel?, там есть код, который проверяет номер процессора. Если на том компьютере, то переходим к "сообщению с паролем", а если нет, то удаляем этот файл минуя корзины, как здесь КАК УДАЛИТЬ КНИГУ ИЗ САМОЙ СЕБЯ. Надеюсь понятно обрисовал ситуацию. Честно извиняюсь, за то, что прошу, о такой тяжелой помощи.
 
 
 
#2
22.01.2020 07:25:44
помощь скорее всего элементарная, но понять вас реально ОЧЕНЬ тяжело
Программисты - это люди, решающие проблемы, о существовании которых Вы не подозревали, методами, которых Вы не понимаете!
 
 
 
#3
22.01.2020 08:54:49
Так вообщем пол задачи сделано. Я скидываю на Ваш сайт файл, чтобы войти в него, Логин Иванов; пароль 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
Изменено: Feniks32 - 22.01.2020 08:55:00
 
 
 
#4
22.01.2020 09:16:27
Ну чтобы ее ни кто не скопировал
Цитата
что именно должно находиться?
Код проверяет, например по серийному номеру процессора, на каком ПК запущен, если серийный номер в коде соответствует серийному номеру процессора, то продолжаем дальше работать в книге, если нет то самоудаляется. Надо было написать "запущен" а не "находиться".
Изменено: Feniks32 - 22.01.2020 09:17:55
 
 
 
#5
22.01.2020 09:20:41
Nordheim, а чем Вам не понятен приложенный файл, и код к нему?
 
 
 
#6
22.01.2020 10:08:17
Код
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
 
 
 
#7
22.01.2020 10:21:50
МатросНаЗебре, почему то не срабатывает, я правильно сделал поместил в модуль "Эта книга"
Код
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
Изменено: Feniks32 - 22.01.2020 10:21:57
 
 
 
#8
22.01.2020 10:22:47
Код
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
Можно без дополнительной процедуры.
 
 
 
#9
22.01.2020 10:24:58
Цитата
Feniks32 написал:
почему то не срабатывает
Этот код нужно поменять.
Код
Case "12345"
А лучше посмотрите #12.
 
 
 
#10
22.01.2020 11:02:32
МатросНаЗебре извините, что туплю, я вставил Ваш код, модуль книги
Код
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
Записываю полученный номер но он все равно удаляется. Что я не так делаю?
Изменено: Feniks32 - 22.01.2020 11:02:40
 
 
 
#11
22.01.2020 11:17:31
BFEBFBFF000306C3 - На этом месте должно быть имя компьютера.
Выполните код
Код
Sub aaa()
    Debug.print Environ$("COMPUTERNAME")   
    MsgBox Environ$("COMPUTERNAME")
end sub
А процедура Sub SpecificationsProcessor() в том варианте вообще не нужна.
 
 
 
#12
22.01.2020 11:24:25
Получилось, а можно привязать не к имени компьютера, к серийнику системного диска, например, если к процессору не получается?
Изменено: Feniks32 - 22.01.2020 11:35:51
 
 
 
#13
22.01.2020 11:37:33
Код
Sub DelThisWorkbook()
    MsgBox "Имя вашего компьютреа" & vbLf & Environ$("COMPUTERNAME") & vbLf & "Он " & IIf(Environ$("COMPUTERNAME") = "WORKGROUP", "", "не") & " равен WORKGROUP", vbInformation
    Select Case Environ$("COMPUTERNAME")
    Case "WORKGROUP"
    Case Else
        Application.DisplayAlerts = False
        ThisWorkbook.ChangeFileAccess xlReadOnly
        Kill ThisWorkbook.FullName
        Application.DisplayAlerts = True
        ThisWorkbook.Close 0 'если необходимо сразу же закрыть книгу(рекомендуется)
    End Select
End Sub
Запустите этот код. Что пишет?
 
 
 
#14
22.01.2020 11:43:56
МатросНаЗебре, я раннее изменил сообщение, Вы его не увидели. Просьба пожалуйста, если не сложно, можно привязать не к имени компьютера, к серийнику системного диска, например, если к процессору не получается?
 
 
 
#15
22.01.2020 11:48:14
Цитата
Feniks32 написал:
если к процессору не получается
Получается. Выше почти есть ответ. Достаточно поправить условие.
Код
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
 
 
 
#16
22.01.2020 11:54:00
Огромнейшее Вам спасибо, добрый человек, дай Бог Вам здоровья
 
 
 
Страницы: 1
Наверх