В этой статье приведён пример кода для программного управления моими универсальными надстройками,
на примере надстройки для поиска цен в Яндекс.маркет
Sub FindPricesForAllSheets() On Error Resume Next: Err.Clear Const ADDIN_NAME$ = "YandexMarket" ' задаем здесь кодовое имя надстройки Dim AddinFilename$, AddinPath$, msg$ ' проверяем, запущена ли надстройка, пытаясь получить имя файла надстройки ' Функция с именем GetAddinFilename_КодовоеИмяНадстройки есть в каждой моей программе AddinFilename$ = Application.Run("GetAddinFilename_" & ADDIN_NAME$) If Err.Number = 1004 Then ' функция GetAddinFilename_ не ответила - значит, надстройка не запущена ' считываем в реестре путь к файлу надстройки (он там есть, если программа хоть раз запускалась) AddinPath$ = GetSetting(ADDIN_NAME$, "Setup", "AddinPath", "") If AddinPath$ = "" Or Dir(AddinPath$, vbNormal) = "" Then ' если путь к надстройке в реестре не найден (надстройка не запускалась ранее) ' или путь найден, но уже недействителен (файл надстройки был удален) msg$ = "Надстройка «" & ADDIN_NAME$ & "» не найдена на этом компьютере." & vbNewLine & _ "Скачайте и запустите надстройку " & ADDIN_NAME$ & ", а потом заново запустите этот макрос." & _ vbNewLine & "Нажмите OK, чтобы открыть страницу программы на сайте ExcelVBA.ru" If MsgBox(msg, vbCritical + vbOKCancel, "Требуется запустить надстройку " & ADDIN_NAME$) = vbOK Then _ CreateObject("wscript.shell").Run "http://excelvba.ru/programmes/" & ADDIN_NAME$ Exit Sub ' выход из макроса, т.к. продолжение работы без запущенной надстройки невозможно End If Workbooks.Open AddinPath$ ' пробуем открыть (запустить) надстройку ' и снова проверяем, запустила программа или нет Err.Clear: AddinFilename$ = Application.Run("GetAddinFilename_" & ADDIN_NAME$) If Err.Number = 1004 Then ' надстройка не запустилась, или какая-то другая проблема MsgBox "Не удалось запустить надстройку «" & ADDIN_NAME$ & "»" & vbNewLine & _ "Файл надстройки повреждён, или используется старая версия" & vbNewLine & _ "Обратитесь к автору макроса", vbCritical, "Проблема при запуске надстройки" Exit Sub ' выход из макроса, т.к. продолжение работы без запущенной надстройки невозможно End If End If ' если надо проверить версию надстройки (обычно не требуется - можно удалить эти строки) Dim ver&: ver& = Application.Run("'" & AddinFilename$ & "'!GetVersion") If ver& < 2002 Then MsgBox "Требуется обновить надстройку", vbExclamation, "Продолжение невозможно": Exit Sub ' теперь мы точно знаем, что надстройка запущена, и готова к использованию
' программно меняем настройки (если надо) ' можно подгрузить набор настроек из файла XML (предварительно экспортировав настройки программы в этот файл) Dim SettingsFilename$: SettingsFilename$ = ThisWorkbook.Path & "\settings.xml" If Dir(SettingsFilename$, vbNormal) <> "" Then ' если файл настроек найден в папке с текущим файлом Excel ' применяем настройки, вызывая макрос ImportSettings ' с двумя параметрами: SettingsFilename$ - путь к файлу настроек, и TRUE - для подавления вывода уведомления Dim res As Boolean: res = Application.Run("'" & AddinFilename$ & "'!ImportSettings", SettingsFilename$, True) ' If Not res Then Exit Sub ' ошибка импорта настроек из найденного файла XML End If ' Все настройки программы сохранены в реестре по пути ' HKEY_CURRENT_USER \ Software \ VB and VBA Program Settings \ КодовоеИмяНадстройки \ Settings ' Можно менять настройки по одной, например: SaveSetting ADDIN_NAME$, "Settings", "SourceData_FirstRow", 2 ' номер первой строки с данными на листе SaveSetting ADDIN_NAME$, "Settings", "ComboBox_WP_Timeout", 6 ' таймаут запроса к сайту, 6 секунд SaveSetting ADDIN_NAME$, "Settings", "TextBox_ClearColumnsList", "3-100" ' номера очищаемых столбцов ' (по аналогии, можно изменить любые другие настройк. названия доступных опций - можно помотреть в реестре) ' приступаем к использованию надстройки Dim sh As Worksheet, RegionName$, RegionCode&, ShopsCount& For Each sh In ThisWorkbook.Worksheets ' перебираем все листы в книге ' берем название региона из имени очередного листа RegionName$ = Trim(sh.Name) ' определяем числовой код региона, вызывая функцию GetYandexRegionCode с параметром RegionName$ RegionCode& = 0 RegionCode& = Application.Run("'" & AddinFilename$ & "'!GetYandexRegionCode", RegionName$) If RegionCode& = 0 Then ' функция возвращает 0, если регион не распознан MsgBox "Не удалось распознать регион «" & RegionName$ & "»", vbExclamation, "Измените имя листа" Else ' регион распознан, - записываем код региона в настройки программы (сохраняем в реестре) SaveSetting ADDIN_NAME$, "Settings", "ComboBox_YandexRegion", RegionCode& ' активируем лист перед запуском поиска цен ThisWorkbook.Activate: sh.Activate ' определяем количество столбцов с названиями интернет-магазинов на текущем листе ShopsCount& = 0: ShopsCount& = sh.Range("c1:iv1").SpecialCells(xlCellTypeConstants).Count If ShopsCount& > 0 Then ' если в указанном диапазоне найдены заполненные ячейки ' записываем количество блоков цен в настройки программы (сохраняем в реестре) SaveSetting ADDIN_NAME$, "Settings", "ComboBox_BlocksCount", ShopsCount& ' запускаем макрос очистки листа ClearSheet из надстройки Application.Run "'" & AddinFilename$ & "'!ClearSheet" ' запускаем основной макрос поиска цен StartYandexMarketSearch из надстройки Application.Run "'" & AddinFilename$ & "'!StartYandexMarketSearch" ' выход из макроса, если в процессе поиска цен, пользователь нажал кнопку ОТМЕНА If Application.Run("'" & AddinFilename$ & "'!YandexMarketSearchCancelled") = True Then Exit Sub End If End If Next sh MsgBox "Загрузка цен завершена", vbInformation, "Готово" End Sub
Комментарии
Отправить комментарий