Здравствуйте, помогите написать макрос. Есть файл. В нем 7 открытых листов и больше 10 очень скрытых. Отличная идея Права доступа , но здесь на каждого пользователя определенная страница, как сделать чтоб происходила проверка имени компьютера и если оно совпадает, то он отображает те 7 открытых листов, если нет, то он все скрывает. Заранее говорю, что в макросах не силен, поэтому желательно подробно. Спасибо.
Здравствуйте, помогите написать макрос. Есть файл. В нем 7 открытых листов и больше 10 очень скрытых. Отличная идея Права доступа , но здесь на каждого пользователя определенная страница, как сделать чтоб происходила проверка имени компьютера и если оно совпадает, то он отображает те 7 открытых листов, если нет, то он все скрывает. Заранее говорю, что в макросах не силен, поэтому желательно подробно. Спасибо.romanus7
Сообщение отредактировал romanus7 - Среда, 08.07.2015, 09:23
скрыть все листы нельзя, можно скрыть книгу, и, если имя ПК не то - закрыть книгу.
[vba]
Код
#If VBA7 Then Private Declare PtrSafe Function GetComputerNameA Lib "kernel32" (ByVal lpBuffer As String, nSize As LongPtr) As LongPtr Private Declare PtrSafe Function WNetGetUserA Lib "mpr.dll" (ByVal lpName As String, ByVal lpUserName As String, lpnLength As LongPtr) As LongPtr #Else Private Declare Function GetComputerNameA Lib "kernel32" (ByVal lpBuffer As String, nSize As Long) As Long Private Declare Function WNetGetUserA Lib "mpr.dll" (ByVal lpName As String, ByVal lpUserName As String, lpnLength As Long) As Long #End If
Function GetComputerName() As String Dim sBuffer As String * 255 If GetComputerNameA(sBuffer, 255&) <> 0 Then GetComputerName = Left$(sBuffer, InStr(sBuffer, vbNullChar) - 1) End Function
[/vba]
Проверка при открытии файла (в "Эта книга"):[vba]
Код
Private Sub Workbook_Open() Dim arrVisibleSheets, arrHiddenSheets Windows(ThisWorkbook.Name).Visible = False 'скрываем книгу 'If Environ("UserName") <> "USER" Then 'Имя пользователя If GetComputerName <> "COMP" Then 'Имя компьютера With Application .DisplayAlerts = False ThisWorkbook.Close .DisplayAlerts = True End With Else arrVisibleSheets = Array(Лист1, Лист2, Лист3) 'Видимые листы arrHiddenSheets = Array(Лист4, Лист5, Лист6) 'Скрытые листы For Each sh In arrVisibleSheets sh.Visible = xlSheetVisible Next sh For Each sh In arrHiddenSheets sh.Visible = xlSheetVeryHidden Next sh Windows(ThisWorkbook.Name).Visible = True End If End Sub
скрыть все листы нельзя, можно скрыть книгу, и, если имя ПК не то - закрыть книгу.
[vba]
Код
#If VBA7 Then Private Declare PtrSafe Function GetComputerNameA Lib "kernel32" (ByVal lpBuffer As String, nSize As LongPtr) As LongPtr Private Declare PtrSafe Function WNetGetUserA Lib "mpr.dll" (ByVal lpName As String, ByVal lpUserName As String, lpnLength As LongPtr) As LongPtr #Else Private Declare Function GetComputerNameA Lib "kernel32" (ByVal lpBuffer As String, nSize As Long) As Long Private Declare Function WNetGetUserA Lib "mpr.dll" (ByVal lpName As String, ByVal lpUserName As String, lpnLength As Long) As Long #End If
Function GetComputerName() As String Dim sBuffer As String * 255 If GetComputerNameA(sBuffer, 255&) <> 0 Then GetComputerName = Left$(sBuffer, InStr(sBuffer, vbNullChar) - 1) End Function
[/vba]
Проверка при открытии файла (в "Эта книга"):[vba]
Код
Private Sub Workbook_Open() Dim arrVisibleSheets, arrHiddenSheets Windows(ThisWorkbook.Name).Visible = False 'скрываем книгу 'If Environ("UserName") <> "USER" Then 'Имя пользователя If GetComputerName <> "COMP" Then 'Имя компьютера With Application .DisplayAlerts = False ThisWorkbook.Close .DisplayAlerts = True End With Else arrVisibleSheets = Array(Лист1, Лист2, Лист3) 'Видимые листы arrHiddenSheets = Array(Лист4, Лист5, Лист6) 'Скрытые листы For Each sh In arrVisibleSheets sh.Visible = xlSheetVisible Next sh For Each sh In arrHiddenSheets sh.Visible = xlSheetVeryHidden Next sh Windows(ThisWorkbook.Name).Visible = True End If End Sub
Manyasha, огромное спасибо помогли, но есть еще одна загвоздка, если макросы отключены, книга спокойно открывается, как защитить, если даже макросы выключены и если не правильное имя компьютера книга закрывается или такое невозможно?
Manyasha, огромное спасибо помогли, но есть еще одна загвоздка, если макросы отключены, книга спокойно открывается, как защитить, если даже макросы выключены и если не правильное имя компьютера книга закрывается или такое невозможно?romanus7
Сообщение отредактировал romanus7 - Среда, 08.07.2015, 13:56
Я обычно делаю (если делаю)подобное не по имени компьютера (оно может совпадать), а по серийному номеру диска Сначала запускаем в любом файле вот такой макрос [vba]
Код
Sub tt() [a1] = CreateObject("Scripting.FileSystemObject").GetDrive("C").SerialNumber End Sub
[/vba] Он напишет в ячейке А1 серийник. Списываем его оттуда на бумажку. А в файле в модуле книги вот так примерно (кусок с массивом нужных листов взял у Маняши). Там принцип такой же, как и по ссылке Маняши, но реализовано немного иначе. [vba]
Код
Private Sub Workbook_BeforeClose(Cancel As Boolean) Application.ScreenUpdating = 0 Лист8.Visible = xlSheetVisible sn_ = ThisWorkbook.Sheets.Count For i = 1 To sn_ If Sheets(i).CodeName <> "Лист8" Then Sheets(i).Visible = xlSheetVeryHidden End If Next i End Sub Private Sub Workbook_Open() nn_ = InputBox("Введи пароль") If nn_ = CreateObject("Scripting.FileSystemObject").GetDrive("C").SerialNumber & "" Then Da_ = Array(Лист1, Лист2, Лист3) 'Видимые листы For Each sh In Da_ sh.Visible = xlSheetVisible Next sh Лист8.Visible = xlSheetVeryHidden Лист1.Activate End If End Sub
[/vba]
Я обычно делаю (если делаю)подобное не по имени компьютера (оно может совпадать), а по серийному номеру диска Сначала запускаем в любом файле вот такой макрос [vba]
Код
Sub tt() [a1] = CreateObject("Scripting.FileSystemObject").GetDrive("C").SerialNumber End Sub
[/vba] Он напишет в ячейке А1 серийник. Списываем его оттуда на бумажку. А в файле в модуле книги вот так примерно (кусок с массивом нужных листов взял у Маняши). Там принцип такой же, как и по ссылке Маняши, но реализовано немного иначе. [vba]
Код
Private Sub Workbook_BeforeClose(Cancel As Boolean) Application.ScreenUpdating = 0 Лист8.Visible = xlSheetVisible sn_ = ThisWorkbook.Sheets.Count For i = 1 To sn_ If Sheets(i).CodeName <> "Лист8" Then Sheets(i).Visible = xlSheetVeryHidden End If Next i End Sub Private Sub Workbook_Open() nn_ = InputBox("Введи пароль") If nn_ = CreateObject("Scripting.FileSystemObject").GetDrive("C").SerialNumber & "" Then Da_ = Array(Лист1, Лист2, Лист3) 'Видимые листы For Each sh In Da_ sh.Visible = xlSheetVisible Next sh Лист8.Visible = xlSheetVeryHidden Лист1.Activate End If End Sub
Ты телевизор смотришь? Я в Сочи был. Как раз тогда, когда там дождик шел. Сейчас-то уже обратно приехал. Загорелый и накупавшийся - за 2 недели целый один день на пляже был.
Ты телевизор смотришь? Я в Сочи был. Как раз тогда, когда там дождик шел. Сейчас-то уже обратно приехал. Загорелый и накупавшийся - за 2 недели целый один день на пляже был.
_Boroda_, При вставке серийного номера, почему то никакой реакции, остается на листе 8, а также пытался менять код при вводе серийного номера вообще любого, все видимые листы открываются, может что то не так в коде?
_Boroda_, При вставке серийного номера, почему то никакой реакции, остается на листе 8, а также пытался менять код при вводе серийного номера вообще любого, все видимые листы открываются, может что то не так в коде?
Как у Вас выглядит серийный номер? Должно быть что-то типа 942324669. Если он отображается в ячейке А1 в виде 9,42Е+08, то просто ширину ячейки сделайте побольше. Или копируйте его из строки формул. Кстати, в своей книге кусок с макросом tt сотрите, вернее, перенесите этот макрос в другую книгу, чтобы оттуда можно было списать, если забудете.
Чтобы не увеличивать ширину руками, макрос tt можно переписать так [vba]
Код
Sub tt() [a1] = CreateObject("Scripting.FileSystemObject").GetDrive("C").SerialNumber Columns("A:A").EntireColumn.AutoFit End Sub
[/vba]
Как у Вас выглядит серийный номер? Должно быть что-то типа 942324669. Если он отображается в ячейке А1 в виде 9,42Е+08, то просто ширину ячейки сделайте побольше. Или копируйте его из строки формул. Кстати, в своей книге кусок с макросом tt сотрите, вернее, перенесите этот макрос в другую книгу, чтобы оттуда можно было списать, если забудете.
Чтобы не увеличивать ширину руками, макрос tt можно переписать так [vba]
Код
Sub tt() [a1] = CreateObject("Scripting.FileSystemObject").GetDrive("C").SerialNumber Columns("A:A").EntireColumn.AutoFit End Sub
_Boroda_, с серийным номером разобрался, я для примера произвольный написал, вопрос вот в чем. Правильно ли я его вставил? Туда куда надо? Заранее спасибо. И серийник начинается -2459..... С минуса.
_Boroda_, с серийным номером разобрался, я для примера произвольный написал, вопрос вот в чем. Правильно ли я его вставил? Туда куда надо? Заранее спасибо. И серийник начинается -2459..... С минуса.romanus7
Сообщение отредактировал romanus7 - Четверг, 09.07.2015, 01:19
А я и не заметил, что Вы его в код прописали. Не, в том-то и фишка, что вовнутрь кода номер ни в коем случае нельзя записывать. Он должен быть у Вас где-то в другом месте и Вы каждый раз его должны заводить. Хотя, я так подумал-подумал - и так нормально. Ну а если так, для поиграться, то замените <> на = И, если уж Вы убрали кусок & "", то номер пишите без кавычек [vba]
Код
If CreateObject("Scripting.FileSystemObject").GetDrive("C").SerialNumber = 988888889 Then
[/vba]
А я и не заметил, что Вы его в код прописали. Не, в том-то и фишка, что вовнутрь кода номер ни в коем случае нельзя записывать. Он должен быть у Вас где-то в другом месте и Вы каждый раз его должны заводить. Хотя, я так подумал-подумал - и так нормально. Ну а если так, для поиграться, то замените <> на = И, если уж Вы убрали кусок & "", то номер пишите без кавычек [vba]
Код
If CreateObject("Scripting.FileSystemObject").GetDrive("C").SerialNumber = 988888889 Then
Вход
Регистрация
Напомнить пароль
Автосумма
Часто используемые
ВПР
ЕСЛИ
СУММЕСЛИ
Финансовые
Логические
Текстовые
Даты и времени 
Ссылки и массивы 
Математические
Другие функции
Проверка свойств и значений
Баз данных
Математические
Обработки массивов
Обработки строк
Преобразования типов данных 
Загрузки данных
Работы с файлами
Обработки системных параметров
Обработки цвета
Работы с датами и временем
Преобразования в системы счисления
Финансовые
Хотя дождем должно было и смыть всю грязюку. 
