Автосохранение надстройки в папке Addins

В некоторых случаях, при запуске файла Excel с макросами (к примеру, надстройки Excel), для обеспечения работы макросов требуется, чтобы был полный доступ к файлу (а не "только чтение"), или же файл был сохранён в заданной папке.

Полный доступ к файлу необходим, например, для работы автоматического обновления надстройки,
а постоянный путь может потребоваться, если вы хотите использовать опцию автоматического запуска файла вместе с Excel

В этом вам поможет макрос SaveAddinToPermanentPath, который проверяет, из какой папки запущен файл, и предлагает, в случае необходимости, переместить файл в постоянную папку

В качестве постоянной папки макрос использует папку «UserLibrary», путь к которой можно получить из свойства Application.UserLibraryPath

На моём компьютере, эта папка расположена по пути
C:\Documents and Settings\<имя пользователя>\Application Data\Microsoft\AddIns\

Код макроса SaveAddinToPermanentPath:

Sub SaveAddinToPermanentPath()
    ' макрос проверяет, откуда (из какой папки) запущен файл,
    ' и предлагает, в случае необходимости, переместить файл в постоянную папку
    On Error Resume Next
    Dim SaveFileInAddinsFolder As Boolean
    AddinsFolder$ = Replace(Application.UserLibraryPath & "\", "\\", "\")
    If Dir(AddinsFolder$, vbDirectory) = "" Then Exit Sub    ' если вдруг нет такой папки

    If ThisWorkbook.Path Like Environ("temp") & "*" Then
        ' файл запущен из архива (без предварительного извлечения), или из папки TEMP
        SaveFileInAddinsFolder = True    ' сохраняем в папке Addins без лишних вопросов
    Else
        If ThisWorkbook.ReadOnly Then    ' файл открыт в режиме «только чтение»
            ' пробуем получить полный доступ к файлу
            Err.Clear
            SetAttr ThisWorkbook.FullName, vbNormal
            ThisWorkbook.ChangeFileAccess xlReadWrite
 
            If Err <> 0 Or ThisWorkbook.ReadOnly Then    ' полный доступ получить не удалось по каким-то причинам
                ' спрашиваем пользователя, перекинуть ли файл в другую папку
                msg$ = "Файл «" & PROJECT_NAME$ & "» открыт в режиме «только чтение»" & vbNewLine & _
                       "из папки """ & ThisWorkbook.Path & """" & vbNewLine & vbNewLine & _
                       "Переместить файл «" & PROJECT_NAME$ & "» в папку «Addins»?" & vbNewLine & _
                       "(новый путь: """ & AddinsFolder$ & """)"
                ttl$ = "Требуется пересохранить файл, для его корректной работы"
                SaveFileInAddinsFolder = MsgBox(msg$, vbQuestion + vbOKCancel, ttl$) = vbOK
            End If
        End If
    End If
 
    If SaveFileInAddinsFolder Then
        ' сохраняем файл по новому пути, старый файл пробуем удалить
        OldFilename$ = ThisWorkbook.FullName: Err.Clear
        ThisWorkbook.SaveAs AddinsFolder$ & ThisWorkbook.Name
        If Dir(ThisWorkbook.FullName, vbNormal) <> "" Then    ' если сохранение прошло успешно
            SetAttr OldFilename$, vbNormal
            Kill OldFilename$    ' пробуем удалить старый файл
        End If
    End If
End Sub

26888 просмотров

Автосохранение надстройки в папке Addins

Комментарии

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

НАДСТРОЙКИ ДЛЯ EXCEL