Надстройки Excel - Microsoft Office Excel

Skif-F · 22.09.2010, 09:21

Пытаюсь создать самоустанавливающуюся надстройку:

Код:

Option Explicit             'Все переменные должны быть объявлены
Private Const ThisName = "НадстройкиExcel.xla"

Private Sub Workbook_Open()
    Install 'Устанавливаем надстройку
End Sub

Sub Install()   'Устанавливаем надстройку
    Dim ad As AddIn, UserLibraryPath As String, TWB As Workbook, MyName As String
    Dim FN As String, MBR As VbMsgBoxResult, fso, flag As Boolean
    
    Set fso = CreateObject("Scripting.FileSystemObject")  'Объект для работы с файлами

    Set TWB = ThisWorkbook
    FN = TWB.FullName
    MyName = Right(FN, Len(FN) - InStrRev(FN, "\"))
    flag = False
    For Each ad In Application.AddIns   'Перебираем надстройки
        If ad.Name = ThisName Then      'Если имя надстройки совпадает с нашим
            If ad.FullName = TWB.FullName Then Exit Sub 'Проверяем, "не мы ли это"
            'Если не мы, то советуемся с пользователем:
            MBR = MsgBox("Надстройка " + ThisName + " существует. Заменить?", vbYesNo, "Внимание!")
            If MBR = vbNo Then Exit Sub 'Если заменять не надо
            ad.Installed = False        'Отключаем
            flag = True                 'Сигналим, что такая надстройка была
            Kill ad.FullName            'Удаляем файл
            Exit For
        End If
    Next ad
    UserLibraryPath = Application.AddIns.Parent.UserLibraryPath 'Путь до надстроек
    fso.CopyFile TWB.FullName, UserLibraryPath + ThisName, True 'Копируем свой файл в каталог надстроек
    If Not flag Then     'Если надстройки ранее не было, добавляем её
        Set ad = AddIns.Add(Filename:=ThisName, CopyFile:=True) 'Если такой надстройки не было, подключаем её
        AddIns(ThisName).Installed = True   'Включаем свою надстройку
    Else
        ad.Installed = True         'Включаем свою надстройку
    End If
End Sub

Проблемы в следующем: если такая надстройка ранее не стояла, то при выполнении команды

Код:

AddIns.Add(Filename:=ThisName, CopyFile:=True)

получаем ошибку: Run-time error 1004: Невозможно получить свойство Add класса AddIns
В чём может быть причина?

EducatedFool · 22.09.2010, 09:31

Я думал, надо указывать ПОЛНЫЙ путь к файлу надстроек...

Skif-F · 22.09.2010, 09:34

Я тоже так думал:

Код:

UserLibraryPath = Application.AddIns.Parent.UserLibraryPath 'Путь до надстроек
fso.CopyFile TWB.FullName, UserLibraryPath + ThisName, True 'Копируем свой файл в каталог надстроек
Set ad = AddIns.Add(Filename:=UserLibraryPath +ThisName, CopyFile:=True) 'Если такой надстройки не было, подключаем её

не помогло...

EducatedFool · 22.09.2010, 09:45

Перед тем, как пробовать это:

Код:

Sub Install()   'Устанавливаем надстройку
    ' ...
    UserLibraryPath = Application.AddIns.Parent.UserLibraryPath
    Set ad = Application.AddIns.Add(Filename:=UserLibraryPath & ThisName)
End Sub

не забудьте создать новую (или открыть любую существующую) книгу Excel.
Если окон у Excel никаких не открыто, установка надстроек выдаёт ошибку.

Как я делал раньше:

Код:

Sub test()
    Application.ScreenUpdating = False
    Dim wb As Workbook: Set wb = Workbooks.Add
    ' установка надстройки
    wb.Close False
End Sub

PS: Хоть в вашем макросе и вылетает ошибка, надстройка, тем не менее, устанавливается.
Может, просто отключить вывод останов при ошибках? On Error Resume Next

Skif-F · 22.09.2010, 11:13

Я попробую Ваш вариант, как будет время.
А надстройка не устанавливается, а копируется командой:

Код:

 fso.CopyFile TWB.FullName, UserLibraryPath + ThisName, True 'Копируем свой файл в каталог надстроек

поскольку AddIns.Add(..) копирует не всегда, а только с внешних носителей, да и то не со всех (у меня с флэшки копировать не стал)

Skif-F · 22.09.2010, 15:31

Получилось:

Код:

Option Explicit             'Все переменные должны быть объявлены
Private Const ThisName = "НадстройкиExcel.xla"

Private Sub Workbook_Open()
    Application.ScreenUpdating = False
    Install 'Устанавливаем надстройку
    Application.ScreenUpdating = True
End Sub

Sub Install()   'Устанавливаем надстройку
    Dim ad As AddIn, UserLibraryPath As String, TWB As Workbook, MyName As String
    Dim FN As String, MBR As VbMsgBoxResult, fso, flag As Boolean, wb As Workbook
    
    Set fso = CreateObject("Scripting.FileSystemObject")  'Объект для работы с файлами

    Set TWB = ThisWorkbook
    FN = TWB.FullName
    MyName = Right(FN, Len(FN) - InStrRev(FN, "\"))
    flag = False
    For Each ad In Application.AddIns   'Перебираем надстройки
        If ad.Name = ThisName Then      'Если имя надстройки совпадает с нашим
            If ad.FullName = TWB.FullName Then Exit Sub 'Проверяем, "не мы ли это"
            'Если не мы, то советуемся с пользователем:
            MBR = MsgBox("Надстройка " + ThisName + " существует. Заменить?", vbYesNo, "Внимание!")
            If MBR = vbNo Then Exit Sub 'Если заменять не надо
            ad.Installed = False        'Отключаем
            flag = True                 'Сигналим, что такая надстройка была
            On Error Resume Next
                Kill ad.FullName            'Удаляем файл
            On Error GoTo 0
            Exit For
        End If
    Next ad
    UserLibraryPath = Application.AddIns.Parent.UserLibraryPath 'Путь до надстроек
    fso.CopyFile TWB.FullName, UserLibraryPath + ThisName, True 'Копируем свой файл
    Set wb = Workbooks.Add 'Создаём новую книгу (надо для работы AddIns.Add)
    If Not flag Then
        Set ad = AddIns.Add(Filename:=UserLibraryPath & ThisName, CopyFile:=True) 'Если такой надстройки не было, подключаем её
    End If
    ad.Installed = True         'Включаем свою надстройку
    wb.Close False  'Закрываем созданную книгу за ненадобностью
End Sub

EducatedFool, спасибо!

SrgKord · 24.10.2017, 15:39

Цитата:

Сообщение от Skif-F

Получилось:

Код:

Option Explicit             'Все переменные должны быть объявлены
Private Const ThisName = "НадстройкиExcel.xla"

Private Sub Workbook_Open()
    Application.ScreenUpdating = False
    Install 'Устанавливаем надстройку
    Application.ScreenUpdating = True
End Sub

Sub Install()   'Устанавливаем надстройку
    Dim ad As AddIn, UserLibraryPath As String, TWB As Workbook, MyName As String
    Dim FN As String, MBR As VbMsgBoxResult, fso, flag As Boolean, wb As Workbook
    
    Set fso = CreateObject("Scripting.FileSystemObject")  'Объект для работы с файлами

    Set TWB = ThisWorkbook
    FN = TWB.FullName
    MyName = Right(FN, Len(FN) - InStrRev(FN, "\"))
    flag = False
    For Each ad In Application.AddIns   'Перебираем надстройки
        If ad.Name = ThisName Then      'Если имя надстройки совпадает с нашим
            If ad.FullName = TWB.FullName Then Exit Sub 'Проверяем, "не мы ли это"
            'Если не мы, то советуемся с пользователем:
            MBR = MsgBox("Надстройка " + ThisName + " существует. Заменить?", vbYesNo, "Внимание!")
            If MBR = vbNo Then Exit Sub 'Если заменять не надо
            ad.Installed = False        'Отключаем
            flag = True                 'Сигналим, что такая надстройка была
            On Error Resume Next
                Kill ad.FullName            'Удаляем файл
            On Error GoTo 0
            Exit For
        End If
    Next ad
    UserLibraryPath = Application.AddIns.Parent.UserLibraryPath 'Путь до надстроек
    fso.CopyFile TWB.FullName, UserLibraryPath + ThisName, True 'Копируем свой файл
    Set wb = Workbooks.Add 'Создаём новую книгу (надо для работы AddIns.Add)
    If Not flag Then
        Set ad = AddIns.Add(Filename:=UserLibraryPath & ThisName, CopyFile:=True) 'Если такой надстройки не было, подключаем её
    End If
    ad.Installed = True         'Включаем свою надстройку
    wb.Close False  'Закрываем созданную книгу за ненадобностью
End Sub

EducatedFool, спасибо!

Попытался повторить. В самом конце, где ad.installed = true у меня ошибка выходит, говорится, что мол нельзя установить свойство installed класса addin. И всё, и никто не знает, что делать с этим.

Аватар · 24.10.2017, 16:12

Цитата:

И всё, и никто не знает, что делать с этим.

Так уж никто и не знает. Вот здесь, например, знают

SrgKord · 29.10.2017, 05:11

Цитата:

Сообщение от Аватар

Так уж никто и не знает. Вот здесь, например, знают

Цитата:

Сообщение от Аватар

Так уж никто и не знает. Вот здесь, например, знают

Точно! Дело, оказалось, в событии Workbook_open при выполнении Addins.Add
Проблема решена, благодарю!

22.09.2010, 09:31	#2
EducatedFool Программист VBA СуперМодератор Регистрация: 13.07.2008 Сообщений: 6,858	Я думал, надо указывать ПОЛНЫЙ путь к файлу надстроек... __Полезные надстройки для Excel. Парсинг сайтов и файлов. Макросы любой сложности на заказ. Мониторинг цен конкурентов

22.09.2010, 09:45	#4
EducatedFool Программист VBA СуперМодератор Регистрация: 13.07.2008 Сообщений: 6,858	Перед тем, как пробовать это: Код: `Sub Install() 'Устанавливаем надстройку ' ... UserLibraryPath = Application.AddIns.Parent.UserLibraryPath Set ad = Application.AddIns.Add(Filename:=UserLibraryPath & ThisName) End Sub` не забудьте создать новую (или открыть любую существующую) книгу Excel. Если окон у Excel никаких не открыто, установка надстроек выдаёт ошибку. Как я делал раньше: Код: `Sub test() Application.ScreenUpdating = False Dim wb As Workbook: Set wb = Workbooks.Add ' установка надстройки wb.Close False End Sub` PS: Хоть в вашем макросе и вылетает ошибка, надстройка, тем не менее, устанавливается. Может, просто отключить вывод останов при ошибках? On Error Resume Next __Полезные надстройки для Excel. Парсинг сайтов и файлов. Макросы любой сложности на заказ. Мониторинг цен конкурентов

22.09.2010, 11:13	#5
Skif-F Форумчанин Регистрация: 24.03.2010 Сообщений: 349	Я попробую Ваш вариант, как будет время. А надстройка не устанавливается, а копируется командой: Код: `fso.CopyFile TWB.FullName, UserLibraryPath + ThisName, True 'Копируем свой файл в каталог надстроек` поскольку AddIns.Add(..) копирует не всегда, а только с внешних носителей, да и то не со всех (у меня с флэшки копировать не стал) Нет нерешаемых задач - есть недостаток времени и данных!

Похожие темы
Тема	Автор	Раздел	Ответов	Последнее сообщение
запуск надстройки XPPort из макроса	lkbb	Microsoft Office Excel	0	23.08.2010 09:12
Надстройки Excel	Skif-F	Microsoft Office Excel	10	15.07.2010 17:20
Гавённость надстройки поиск решения	eugrita	Microsoft Office Excel	3	01.04.2010 14:12
автоматизировать установку надстройки	alvazor	Microsoft Office Excel	4	01.10.2009 12:56
Проблема с программным запуском надстройки Solver	kovalevskivf	Microsoft Office Excel	5	22.05.2009 19:53