[Mek]

Всем привет.
Господа программисты, помогите пожалуйста.

Дано: Программа Эксель 2003. Некоторый файл. Расположен на сетевом ресурсе. Доступен разным пользователям.

Проблема: Человеческий фактор. Забывание закрывать файл сразу после завершения активной работы с ним. Во время работы одного из пользователей файл становится недоступным для других (доступно только чтение).

Требуется: Прикрутить к файлу Нечто. Чтобы выскакивало окошко и спрашивало: "Уважаемый пользователь! Вы уже трудитесь над этим файлом N минут. Продолжить? Закрыть?". Допустим чтобы каждые 30 минут такое окошко выскакивало. При выборе "Закрыть" при наличии изменений - стандартный запрос на сохранение. При отсутствии изменений - сразу закрывать.

Реально ли прикрутить это именно к файлу. Чтобы при открытии из любого места с любого компьютера появлялся такой запрос?

п.с. Языками программирования не владею..

[Кулик Алексей aka kpblc]

По-моему, будет проще сделать совместный доступ на файл.

[Mek]

Сообщение от Кулик Алексей aka kpblc По-моему, будет проще сделать совместный доступ на файл.

От этого пришлось отказаться. В Общий файл нельзя вставлять гиперссылки.. и еще много чего там нельзя..

[KronSerg]

Вставь такой макрос:

Public Sub Auto_open() Dim a As Byte y = ActiveWorkbook.Name 1: DoEvents i = Time j = Time k = j - i While k < 2.08333333333333E-02 DoEvents k = j - i j = Time Wend a = MsgBox("Документ открыт уже 30мин, хотите закрыть его?", vbYesNo) If a = 7 Then GoTo 1 ' Новый отсчёт If a = 6 Then Workbooks(y).Close ' Закрывает книгу End Sub

Бывалые програмеры, простите уж самоучку за такой код.

[Mek]

Сообщение от KronSerg Вставь такой макрос...

Спасибо, попробую...

Минус в том что пользователь может выбирать включать ли макросы или нет..

[KronSerg]

Создайте сертификат и подпишите макрос, окошко исчезнет.
Вот, немного доработал:

Код:

[Выделить все]

Public Sub Auto_open()
Dim a, r As Byte
Dim s, y As String
y = ActiveWorkbook.Name
r = 0
1: DoEvents
i = Time
j = Time
k = j - i
While k < 2.08333333333333E-02
DoEvents
k = j - i
j = Time
Wend
r = r + 1
s = "Документ " & y & " открыт уже " & Format(30 * r) & " мин, хотите закрыть его?"
a = MsgBox(s, vbYesNo)
If a = 7 Then GoTo 1 ' Новый отсчёт
If a = 6 Then Workbooks(y).Close ' Закрывает книгу
End Sub

[Mek]

Сообщение от KronSerg Создайте сертификат и подпишите макрос, окошко исчезнет.

Ок. Потестируем...

Сертификат создал, макрос подписал. На моем компьютере перестало блокировать макрос. Это плюс..
Открыл файл, через полчаса замигало окошко. Это плюс.
На запрос ответил "Нет". Файл остался открытым. Это плюс.
При ответе "Да" появился стандартный запрос на сохранение изменений. Ответил да, файл закрылся. Это плюс.

Минусы:
1. Невозможность открытия других файлов эксель. Тупо не открываются. (критично)
2. Перестали работать гиперссылки на документы (pdf), хотя гиперссылки выглядят как надо. Гиперссылка на переход к другому листу в этом же файле работает. (критично)
3. Если открыты другие документы эксель и еще открыть файл с макросом, то переход от одного файла к другому возможен только через меню Окно. Переключение по "Alt +Tab" не работает. Щелчки по свернутым внизу экрана ярлычкам не работают. (критично)
4. Не отображаются примечания. Отображаются только их красные треугольнички. (критично)
5. Не появляется окошко, предупреждающее о включенной защите защищенных ячеек при попытке их редактирования. Защищенные ячейки тупо не редактируются, ничего не происходит. (не критично)
6. Не работает поиcк внутри файла. Окошко поиска открывается (Ctrl+F) но ничего не ищет. (критично)

[Mikha]

>>KronSerg

Код:

[Выделить все]

While k < 2.08333333333333E-02
DoEvents
k = j - i
j = Time
Wend

Данный цикл загружает процессор на 100%
Выражение DoEvents в данном случае не спасет
Возможное решение проблемы Scheduling Events With OnTime And Windows Timers

[KronSerg]

Mikha, спасибо, вот так должно заработать:

Код:

[Выделить все]

Public y As String
Public r As Byte
Public Const cRunIntervalSeconds = 1800 'Время в секундах
Public Sub Auto_open()
y = ActiveWorkbook.Name
Call qwer
End Sub

Sub qwer()
Dim RunWhen As Double
Const cRunWhat = "qwerty"
    RunWhen = Now + TimeSerial(0, 0, cRunIntervalSeconds)
    Application.OnTime EarliestTime:=RunWhen, Procedure:=cRunWhat, _
        Schedule:=True

End Sub
Sub qwerty()
Dim a As Byte
Dim s As String
a = 7
r = r + 1
s = "Документ " & y & " открыт уже " & Format(cRunIntervalSeconds * r/60) & " мин, хотите закрыть его?"
a = MsgBox(s, vbYesNo)
If a = 7 Then Call qwer
If a = 6 Then Workbooks(y).Close
End Sub

[Mek]

Последний раз редактировалось Кулик Алексей aka kpblc, Сегодня в 02:39. Причина: Исправил косяк

О каком косяке речь? Вчера вечером создал макрос с этим кодом. ("Косяк" был исправлен позже) Вроде заработало все как надо..

[Кулик Алексей aka kpblc]

Mek, я тэги менял с quote на code.

[KronSerg]

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

[Mek]

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

Макрос у меня в редакторе выглядит иначе, чем выглядит код в сообщении №9. Картинку прилагаю. Отличия начинаются с пятой строки..
Вроде работает.. Потестю еще..

[KronSerg]

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

[Mek]

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

Поменял. Всё работает. Фантастика!

Готов перечислить скромную сумму на счет мобильного телефона автору макроса. Номер мобилы, город и оператора сообщите в пагер...

[Дерия]

Подскажите пожалуйста. Стала использовать этот код. Вылетает ошибка "Не удается выполнить макрос С:......\Книга1.xls'!qwerty. Возможно этот макрос отсутствует в текущей книги либо все макросы отключены."
Получается он не видит третью процедуру. Не подскажите в чем проблема может быть?

[KronSerg]

Макрос подписала, настройки безопасности макросов проверила?

[Дерия]

Да. Я даже попробовала просто включить все макросы. Все равно не видит. Причем первую же процу запускает, вторую через OnTime нет.

[KronSerg]

вторую через OnTime нет

В смысле ждёт 1800 сек и выдаёт ошибку?

[Дерия]

Аха. Только я уменьшила до 10 секунд

[KronSerg]

попробуй поменять qwerty (в двух местах) на другое имя, через надстройку загрузить, на другом компе попробуй, в общем, не знаю я.

[Дерия]

Все отлично заработало. Пересоздала заного модуль и стало все нормально. Не знаю чего там было если честно.

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

[KronSerg]

Дерия, если хотите ответ пишите новое сообщение, о редактировании старого уведомление не приходит. Перенастройте безопасность макросов на компе в сети и примите с него сертификат. Да, я что зашёл-то, пока суть да дело ещё недочёт исправил:

Код:

[Выделить все]

Public Const cRunIntervalSeconds = 1800 'Время в секундах
Public y As String
Public r As Byte
Public Const cRunWhat = "qwerty"
Public RunWhen As Double
Public Sub Auto_open()
y = ActiveWorkbook.Name
Call qwer
End Sub

Sub qwer()
 RunWhen = Now + TimeSerial(0, 0, cRunIntervalSeconds)
    Application.OnTime EarliestTime:=RunWhen, Procedure:=cRunWhat, _
        Schedule:=True
End Sub
Sub qwerty()
Dim a As Byte
Dim s As String
a = 7
r = r + 1
s = "Документ " & y & " открыт уже " & Format(cRunIntervalSeconds * r / 60, "0.0") & " мин, хотите закрыть его?"
a = MsgBox(s, vbYesNo)
If a = 7 Then Call qwer
If a = 6 Then Workbooks(y).Close
End Sub
Sub Auto_Close()
On Error GoTo 0
Application.OnTime EarliestTime:=RunWhen, Procedure:=cRunWhat, _
        Schedule:=False
End Sub

[Mek]

Да, я что зашёл-то, пока суть да дело ещё недочёт исправил:

Дайте-ка угадаю. Недочет был в том что при свернутом Экселе не было видно как выскакивает окошко? Как раз хотел об этом сказать..

п.с Привет с банкомата получен?

[KronSerg]

При свёрнутом Excel, его вкладка начинает мигать жёлтым, разворачивать окно при появлении сообщения или нет решает Виндовс. Косяк был хитрый, если не закрывая сам Excel, закрыть файлик, а потом его ещё раз открыть, сообщения выскакивали и по таймеру первого открытия и по таймеру второго.

п.с Привет с банкомата получен?

Ах вот что это было не понял сразу.
PS Попробую поискать решение для нового косяка.

[Mek]

Сообщение от KronSerg PS Попробую поискать решение для нового косяка.

Сейчас окошко выскакивает даже если эксель свернут. Это в том, предыдущем, не выскакивало.. Так что с этим все нормально..
При установке времени на 10 секунд чего-то бухтит.. какое то предупреждение. ошибка 1004.. но вроде все равно работает.
Если ставить 60 секунд то ошибки вроде нету...

[KronSerg]

Всё, поторопился с первым постом, готовый код с устранённым 1004 и разворачивающий окно:

Код:

[Выделить все]

Public Const cRunIntervalSeconds = 1800 'Время в секундах
Public y As String
Public r As Byte
Public Const cRunWhat = "qwerty"
Public RunWhen As Double
Public Sub Auto_open()
y = ActiveWorkbook.Name
Call qwer
End Sub

Sub qwer()
 RunWhen = Now + TimeSerial(0, 0, cRunIntervalSeconds)
    Application.OnTime EarliestTime:=RunWhen, Procedure:=cRunWhat, _
        Schedule:=True
End Sub
Sub qwerty()
Dim a As Byte
Dim s As String
a = 7
r = r + 1
s = "Документ " & y & " открыт уже " & Format(cRunIntervalSeconds * r / 60, "0.0") & " мин, хотите закрыть его?"
Application.WindowState = xlMaximized
a = MsgBox(s, vbYesNo)
If a = 7 Then Call qwer
If a = 6 Then Workbooks(y).Close
End Sub
Sub Auto_Close()
On Error Resume Next
Application.OnTime EarliestTime:=RunWhen, Procedure:=cRunWhat, _
        Schedule:=False
End Sub