mail mail
Нужен макрос для Excel?
Сделайте заказ прямо сейчас!
Ищете готовое решение?
Выбирайте и покупайте!
У вас есть интернет-магазин?
Настроим парсер под любой сайт!

Макрос для установки (замены) пароля на открытие, для все файлов Excel в заданной папке

Макрос предназначен для замены паролей на открытие, для большого количества файлов Excel.

В качестве исходных данных, задаётся старый и новый пароли.

Если поле «старый пароль» - пустое, подразумевается, что у файлов нет пароля.
Если поле «новый пароль» - пустое, подразумевается, что с файлов снимается пароль.

Нажимаем кнопку, - появляется диалоговое окно выбора папки, - после чего макрос в цикле открывает всё файлы,
и пересохраняет их с новым паролем.

Возможно, у некоторых файлов не получится изменить пароль
(например, у тех, где пароль на открытие отличается от заданного в поле «Старый пароль»)
Список таких файлов программа выводит в таблицу, в виде гиперссылок.

ВНИМАНИЕ: Это очень опасный макрос, - если вы случайно забудете, какой пароль вы установили на файлы,
- все обработанные макросом файлы Excel станут недоступны!

Так что, пользуйтесь макросом на свой страх и риск.

Напоминаю: снять (сбросить) пароль н а открытие файла невозможно!
(только полным перебором, - а это очень долго)

Часть кода макроса: (см. прикреплённый файл)

Sub ChangePasswords()
    On Error Resume Next
    PassOld$ = shs.Range("PassOld").Text
    PassNew$ = shs.Range("PassNew").Text
 
    folder$ = GetFolder(777, True)        ' запрашиваем имя папки
    If folder$ = "" Then Exit Sub        ' выход, если пользователь отказался от выбора папки

    Dim coll As Collection
    ' считываем в колекцию coll имена файлов XLS*
    Set coll = FilenamesCollection(folder$, "*.xls*")
    If coll.Count = 0 Then
        MsgBox "В выбранной папке не найдено ни одного файла Excel", vbExclamation
        Exit Sub
    End If
 
    Dim WB As Workbook, nOK&, nErr&
    ' очистка таблицы ошибок
    Intersect(shs.UsedRange, shs.Range("b11:b" & shs.Rows.Count)).ClearContents
    Application.ScreenUpdating = False        ' отключаем обновление экрана

    For Each Filename In coll        ' перебираем найденные в папке файлы
        Err.Clear: Set WB = Nothing
        Set WB = Workbooks.Open(Filename, , , , PassOld$)        ' пробуем открыть очередной файл
        If Not WB Is Nothing Then        ' если файл открылся
            WB.Password = PassNew$        ' ставим новый пароль
            WB.Close True        ' закрываем файл с сохранением изменений
            nOK& = nOK& - (Err = 0)        ' считаем количество успешно сохранённых файлов

        Else        ' файл не открылся - выводим в список ошибок
            nErr& = nErr& + 1
            With shs.Range("b" & 10 + nErr&)
                .Value = Filename
                .Hyperlinks.Add .Resize(, 1), Filename, "", "Попробовать открыть файл вручную"
            End With
        End If
        DoEvents
    Next
 
    Application.ScreenUpdating = True
    msg$ = "Найдено файлов в папке: " & coll.Count & vbNewLine & _
           "Удалось заменить пароли на файлах: " & nOK&
    MsgBox msg, vbInformation, "Готово"
End Sub

ВложениеРазмерЗагрузкиПоследняя загрузка
SetPasswords.xlsb27.69 КБ567 недель 6 дней назад

Комментарии

Настройки просмотра комментариев

Выберите нужный метод показа комментариев и нажмите "Сохранить установки".

Вотя я и был неправ )) перебором он очень долго будет ломать )) автору спасибо

А за макрос спасибо он очень выручает

насчет того что долго сбрасывать пароль несогласен ) есть коллекция ломалок от элкомсофта так они без проблем хакают пароли офиса

Это лучший макрос в моей жизни!

Отправить комментарий

Содержание этого поля является приватным и не предназначено к показу.
CAPTCHA
Подтвердите, пожалуйста, что вы - человек:
      _                  ____            _     
| | _ __ __ _ | __ ) _ __ | |__
_ | | | '__| / _` | | _ \ | '_ \ | '_ \
| |_| | | | | (_| | | |_) | | | | | | |_) |
\___/ |_| \__, | |____/ |_| |_| |_.__/
|_|
Введите код, изображенный в стиле ASCII-арт.

Не получается применить макрос? Не удаётся изменить код под свои нужды?

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