Страницы: 1
RSS
Принудительное изменение средствами VBA внешнего вида указателя курсора мыши при нажатии на кнопку подключенной надстройки, Подключение файла вида курсора мыши из списка, расположенного в каталоге C:\Windows\Cursors
 
Здравствуйте!
64-bit операционная система с 64-bit версией офиса (хотя, особо пока без разницы, ибо прилагающая ниже ссылка на найденный пример также выдает безуспешный результат и в 32-bit системе).
Итак, есть подключенная надстройка, представляющая из себя отдельную вкладку на ленте и содержащая кнопку.
Хочется, чтобы при нажатии на эту кнопку внешний вид курсора менялся со стандартной левонаправленной вверх стрелки на, например, вид руки с вытянутым указательным пальцем.
Вполне стандартный курсор, который можно найти в каталоге "C:\WINDOWS\Cursors\aero_link_il.cur"
Найденный в интернете пример по ссылке: http://rusproject.narod.ru/winapi/l/loadcursorfromfile.html показал на необходимость применения функций API LoadCursorFromFileA и SetCursor.
Однако ни адаптация этих функций под операционную систему 64-bit, ни прямое применение кода примера в системе 32-bit к желаемому результату не привело.
Иные поиски в инете с моделированием различных вариантов запросов по данному вопросу также не пролили свет на решение проблемы.
Предварительный код получается таким:

Код для системы 64-bit:
Код
Declare PtrSafe Function LoadCursorFromFile Lib "user32" Alias "LoadCursorFromFileA" (ByVal lpFileName As String) As LongPtr
Declare PtrSafe Function SetCursor Lib "user32" (ByVal hCursor As LongPtr) As LongPtr

Sub proba()
Dim hCursor As LongPtr

hCursor = LoadCursorFromFile("C:\WINDOWS\Cursors\aero_link_il.cur")
If hCursor = 0 Then End
SetCursor hCursor
End Sub 

Код для системы 32-bit:

Код
Declare Function LoadCursorFromFile Lib "user32" Alias "LoadCursorFromFileA" (ByVal lpFileName As String) As Long
Declare PtrSafe Function SetCursor Lib "user32" (ByVal hCursor As LongPtr) As Long

Sub proba()
Dim hCursor As Long

hCursor = LoadCursorFromFile("C:\WINDOWS\Cursors\aero_link_il.cur")
If hCursor = 0 Then End
SetCursor hCursor
End Sub 

Кто-нибудь сможет подсказать, как добиться желаемого результата?
Изменено: Владимир Баукин - 14.06.2021 07:22:43
 
Код
'Загружаем функции для просмотра курсора
Private Declare Function CopyCursor Lib "user32" Alias "CopyIcon" (ByVal hcur As Long) As Long
Private Declare Function LoadCursorFromFile Lib "user32" Alias "LoadCursorFromFileA" (ByVal lpMyFileName As String) As Long
Private Declare Function GetCursor Lib "user32" () As Long
Private Declare Function SetSystemCursor Lib "user32" (ByVal hcur As Long, ByVal id As Long) As Long
'Объявляем 2 переменные
Dim NewCur, OldCursor As Long



Sub Солнце1_Щелчок()
'Пишем откуда мы берем новый курсор
NewCur = LoadCursorFromFile(ActiveWorkbook.Path & "\Cursor.cur")
'Запоминаем прежний курсор и загружаем свой
OldCursor = GetCursor()
OldCursor = CopyCursor(OldCursor)
SetSystemCursor NewCur, 32512
End Sub

вполне себе меняет курсор
не могу показать: скрин не сохраняет курсор
но на листе ексел не работает. Там свои курсоры. А в системе работает
Изменено: Александр Моторин - 14.06.2021 07:15:21
 
В Excel выбор невелик.
Владимир
 
Александр Моторин, спасибо!

Пример действительно рабочий и для 32-х версии офиса и для 64-х битной, при правильной адаптации API функций.
Немного видоизменил код Вашего примера, сделав его универсальным как как для 64-bit версии офиса, так и для 32-bit системы, чтобы не распыляться между версиями.
Универсальный код для вышеприложенного примера:
Код
Option Explicit

Private Const OCR_NORMAL As Long = 32512
#If VBA7 Then
    'Загружаем функции для просмотра курсора
    Private Declare PtrSafe Function CopyCursor Lib "user32" Alias "CopyIcon" (ByVal hcur As LongPtr) As LongPtr
    Private Declare PtrSafe Function LoadCursorFromFile Lib "user32" Alias "LoadCursorFromFileA" (ByVal lpFileName As String) As LongPtr
    Private Declare PtrSafe Function GetCursor Lib "user32" () As LongPtr
    Private Declare PtrSafe Function SetSystemCursor Lib "user32" (ByVal hcur As LongPtr, ByVal id As Long) As Long
    Public Declare PtrSafe Function DestroyCursor Lib "user32" (ByVal hcur As LongPtr) As Long
#Else
    'Загружаем функции для просмотра курсора
    Private Declare Function CopyCursor Lib "user32" Alias "CopyIcon" (ByVal hcur As Long) As Long
    Private Declare Function LoadCursorFromFile Lib "user32" Alias "LoadCursorFromFileA" (ByVal lpMyFileName As String) As Long
    Private Declare Function GetCursor Lib "user32" () As Long
    Private Declare Function SetSystemCursor Lib "user32" (ByVal hcur As Long, ByVal id As Long) As Long
    Public Declare PtrSafe Function DestroyCursor Lib "user32" (ByVal hcur As Long) As Long

#End If
'Объявляем 2 переменные
Public NewCur As LongPtr, OldCursor As LongPtr



Sub Солнце1_Щелчок()
'Пишем откуда мы берем новый курсор
NewCur = LoadCursorFromFile(ActiveWorkbook.Path & "\Cursor.cur")
'Запоминаем прежний курсор и загружаем свой
'OldCursor = GetCursor()
'OldCursor = CopyCursor(OldCursor)
SetSystemCursor NewCur, OCR_NORMAL
End Sub

Sub Улыбающеесялицо3_Щелчок()
'Пишем откуда мы берем новый курсор
NewCur = LoadCursorFromFile(ActiveWorkbook.Path & "\check.cur")
'Запоминаем прежний курсор и загружаем свой
'OldCursor = GetCursor()
'OldCursor = CopyCursor(OldCursor)
SetSystemCursor NewCur, OCR_NORMAL
End Sub
Однако, экспериментируя, я не до конца сумел разобраться в целях использования переменной OldCursor.
Если закомментировать строки кода с параметром OldCursor, как в приведенном мною примере, то результат получится абсолютно таким же
Подсознательно понимаю, что она, скорее всего, необходима для возвращения стандартного вида указателя мыши, но не до конца понял, как ей правильно пользоваться, в связи с чем и соответствующий вопрос, а как вернуть при необходимости стандартный вид указателя курсора, например, используя событие листа Worksheet_SelectionChange?
То есть, пользователь нажал на кнопку вышеупомянутой в теме надстройки.
Курсор при использовании кода в приложенным Александром Моториным примере изменяет внешний вид, какой ему заложил разработчик.
Пользователь переводит курсор в границы сетки таблицы Excel.
Курсор преобразуется в курсоры самого Excel (да и бог с ним, потом разберемся...)
При выборе пользователем любой ячейки таблицы листа (срабатывание события Worksheet_SelectionChange) кликанием на ней левой клавишей мыши или задействованием клавиш навигации клавиатуры, вид курсора нужно вернуть к стандартной стрелке.
Из справочного материала самого Microsoft я понял, что для этих целей необходимо использовать функцию DestroyCursor.
Но как ее правильно применить в VBA из скудного справочного материала я решения не нашел.
Все эксперименты на авось по типу кода:
Код
Private Sub Worksheet_SelectionChange(ByVal Target As Range)
    DestroyCursor NewCur
End Sub
естественно, с треском провалились.

Как это корректно сделать?
(Прикладываю видоизмененный пример Александра Моторина)
Изменено: Владимир Баукин - 14.06.2021 19:19:13
 
OldCursor использовался в другой процедуре для возврата старого курсора
Это был пример в VB6
Код
'Объявляем 2 переменные
Dim NewCursor, OldCursor As Long

Private Sub Command1_Click()
    'Пишем откуда мы берем новый курсор
    NewCur = LoadCursorFromFile(App.Path & "\Cursor.cur")
    'Запоминаем прежний курсор и загружаем свой
    OldCursor = GetCursor()
    OldCursor = CopyCursor(OldCursor)
    SetSystemCursor NewCur, 32512
End Sub


Private Sub Form_Unload(Cancel As Integer)
    If OldCursor <> 0 Then SetSystemCursor OldCursor, 32512
End Sub
Изменено: Александр Моторин - 15.06.2021 13:39:02
 
Возвращаясь к теме, предварительно всех приветствую!

В принципе, удалось найти подход для решения данной задачи.
Суть решения заключается в заполнении видимой области клиентской части книги Excel полностью прозрачной формой.
Безусловно, я не перехватываю управление курсором самого приложения, а лишь визуально обманываю пользователя, когда он перемещает курсор в клиентской части, и курсор имеет форму, который задан разработчиком.
И только после того, как пользователь выбирает какую-то ячейку, кликнет на ней мышью, форма курсора изменится на стандартную левонаправленную вверх стрелку.
При этом, в координаты, в которых располагался курсор на момент клика левой кнопкой мыши пользователем будет вставлен объект ActiveV, которому будет прописано действие при последующей инициации пользователем его события Click (то есть пользователь, увидев появившийся объект кликнет по нему мышкой).

Следует отметить следующие  недостатки данного способа решения задачи.
1. В конечном итоге форма курсора восстанавливается до стандартной левонаправленной  вверх стрелки, что может не соответствовать изначально установленной форме курсора и поэтому привести в замешательство пользователя, заставив его вручную через параметры заново переопределять удобную для него форму курсора.
Но, к сожалению, я не сумел пока понять как запомнить изначальную форму, где ее хранить, поскольку архитектура исполняемого кода не является непрерывной процедурой.
2. Возникновение передергивания экрана в процессе выполнения кода.

Также стоит обратить внимание, что при использовании данного способа решения задачи, для предотвращения ошибок, связанных с программным обращениям к компонентам VBAProject, необходимо предварительно произвести некоторые модификации установок в центре управления безопасностью приложения Excel и в самом VBAProject, а именно:
1.  Подключаем в VBProject основного файла с исполняем кодом библиотеку VBIDE (Tools -> Referense ->  Microsoft Visual Basic  for Application Exctensibility 5.3.
2. В Центре управления безопасностью параметров приложения Excel устанавливаем ссылку на вышеуказанную библиотеку.
(Файл -> Параметры -> Центр управления безопасностью -> Параметры центра управления безопасностью -> Надежные расположения -> Добавить новое расположение -> выбираем путь к библиотеке WBEGEXT.OLB (VBE6)
(у меня она располагается по адресу: C:\Program Files (x86)\Common Files\Microsoft Shared\VBA\VBA6\)
3. Очень важно не забыть перейти потом на вкладку "Параметры макросов" в "Параметрах центра управления безопасностью" и убедиться, что в разделе "Параметры макросов для разработчика" активирован флажок "Доверять доступ к объектной модели проектов VBA".
4. Рекомендую сохранить настройки и перезапустить приложение.
Доступ к компонентам VBProject открыт.

Теперь выкладываю полный исполняемый код при тестировании решения со своими комментариями.

Код основного модуля:
Код
Option Explicit

Sub Proba()
    Dim RngVis As Range
    Dim PosLeftObj As Integer, PosTopObj As Integer, WDTHObj As Integer, HGHTObj As Integer
    
    'Определяем объект Range, представляющий видимый диапазон клиентской области книги Excel
    Set RngVis = Application.ActiveWindow.VisibleRange
    'Считываем из него необходимые координаты и размеры в пунктах для определения стартовых координат и размера UserForm, которая заполнит виlимую область клиентской части рабочей книги
    With RngVis
        PosLeftObj = .Cells(1, 1).Left
        PosTopObj = .Cells(1, 1).Top
        WDTHObj = .Cells(.Rows.Count, .Columns.Count).Left + .Cells(.Rows.Count, .Columns.Count).Width - PosLeftObj
        HGHTObj = .Cells(.Rows.Count, .Columns.Count).Top + .Cells(.Rows.Count, .Columns.Count).Height - PosTopObj
    End With
    MyForm.Left = PosLeftObj
    MyForm.Top = PosTopObj
    MyForm.Width = WDTHObj
    MyForm.Height = HGHTObj
    MyForm.Show
End Sub

Код копируемого в нужную книгу модуля, содержащего процедуры/функции, которые задействуются при клике на добавленном в интересуемую книгу объекте ActiveX:
Код
Option Explicit

Sub Res()
    MsgBox "Макрос скопирован и работает"
End Sub

Код вспомогательной формы:
Предварительные настройки формы с использованием окна свойств следующие:
BackColor = &H80000005&
Caption =""
PictureAligment=fmPictureAligmentCenter
ShowModal=False
Код
Option Explicit

Private Const OCR_NORMAL As Long = 32512
Private Const IDC_APPSTARTING As Long = 32650
Private Const IMAGE_CURSOR As Long = 2
Private Const PathCursor As String = "c:\Windows\Cursors\"
Private Const GenNameMacros As String = "Res"

#If VBA7 Then
    'Функция копирования текущего значка указателя курсора мыши
    Private Declare PtrSafe Function CopyCursor Lib "user32" Alias "CopyIcon" (ByVal hcur As LongPtr) As LongPtr
    'Функция создания значка указателя курсора мыши на основе данных из файла, к которому обращается функция
    Private Declare PtrSafe Function LoadCursorFromFile Lib "user32" Alias "LoadCursorFromFileA" (ByVal lpFileName As String) As LongPtr
    'Функция извлечения дескриптора (ручки) текущего курсора
    Private Declare PtrSafe Function GetCursor Lib "user32" () As LongPtr
    'Функция настройки системного курсора. Заменяет содержимое системного курсора, определенного параметром ID содержимым курсора, определенным его дескриптором (ручкой)
    Private Declare PtrSafe Function SetSystemCursor Lib "user32" (ByVal hcur As LongPtr, ByVal id As Long) As Long
    'Функция считывания положения курсора в указанных координаты экрана (результат в пикселях)
    Private Declare PtrSafe Function GetCursorPos Lib "user32" (lpPoint As POINTAPI) As Long
    'Функция извлечения дескриптора (ручки) интересуемого окна
    Private Declare PtrSafe Function FindWindow Lib "user32" Alias "FindWindowA" (ByVal ClassName As String, ByVal WindowName As String) As LongPtr
    'Функция считывания информации об интересуемом окне
    Private Declare PtrSafe Function GetWindowLong Lib "user32" Alias "GetWindowLongPtrA" (ByVal hwnd As LongPtr, ByVal nIndex As Long) As LongPtr
    'Функция изменения атрибутов интересуемого окна
    Private Declare PtrSafe Function SetWindowLong Lib "user32" Alias "SetWindowLongPtrA" (ByVal hwnd As LongPtr, ByVal nIndex As Long, ByVal dwNewLong As LongPtr) As LongPtr
    'Функция регулирования прозрачности окна
    Private Declare PtrSafe Function SetLayeredWindowAttributes Lib "user32" (ByVal hwnd As LongPtr, ByVal crKey As Integer, ByVal bAlpha As Integer, ByVal dwFlags As Long) As Long
    'Функция подавления визуализации окна стороннего задействуемого в коде приложения другого приложения
    Private Declare PtrSafe Function LockWindowUpdate Lib "user32" (ByVal hWndLock As LongPtr) As Long
    
    'Переменные, используемые для преобразования вспомогательной формы в прозрачную
    Private hwnd As LongPtr
    Private lStyle As LongPtr
    'Объявляем 3 переменные
    Private NewCur As LongPtr, OldCursor As LongPtr, VBEHwnd As LongPtr
    'Определяем файл, соответствующий виду конечного курсора мыши
    Private Const NameFileCurEnd As String = "aero_arrow.cur"
    'Определяем файл, соответствующий виду промежуточного курсора мыши
    Private Const NameFileCurTMP As String = "lperson.cur"
#Else
    Private Declare Function CopyCursor Lib "user32" Alias "CopyIcon" (ByVal hcur As Long) As Long
    Private Declare Function LoadCursorFromFile Lib "user32" Alias "LoadCursorFromFileA" (ByVal lpMyFileName As String) As Long
    Private Declare Function GetCursor Lib "user32" () As Long
    Private Declare Function SetSystemCursor Lib "user32" (ByVal hcur As Long, ByVal id As Long) As Long
    Private Declare Function GetCursorPos Lib "user32" (lpPoint As POINTAPI) As Long
    Private Declare Function FindWindow Lib "user32" Alias "FindWindowA" (ByVal ClassName As String, ByVal WindowName As String) As Long
    Private Declare Function GetWindowLong Lib "user32" Alias "GetWindowLongA" (ByVal hwnd As Long, ByVal nIndex As Long) As Long
    Private Declare Function SetWindowLong Lib "user32" Alias "SetWindowLongA" (ByVal hwnd As Long, ByVal nIndex As Long, ByVal dwNewLong As Long) As Long
    Private Declare Function SetLayeredWindowAttributes Lib "user32" (ByVal hwnd As Long, ByVal crKey As Integer, ByVal bAlpha As Integer, ByVal dwFlags As Long) As Long
    Private Declare Function LockWindowUpdate Lib "user32" (ByVal hWndLock As Long) As Long
    
    Private hwnd As Long
    Private lStyle As Long
    Private NewCur As Long, OldCursor As Long, VBEHwnd As Long
    Private Const NameFileCurEnd As String = "arrow_l.cur"
    Private Const NameFileCurTMP As String = "handapst.ani"
    
#End If

'Тип данных - координаты курсора в пунктах
Private Type POINTAPI
    X As Long
    Y As Long
End Type

Private pntPos As POINTAPI

'Значение константы пересчета значения в пунктах в значение в пикселях
Private Const PNTINPX As Single = 1.3281472327365
'Значение константы пересчета значения в пикселях в значение в пунктах
Private Const PXINPNT As Single = 0.75292857248934

'Константы, используемые для преобразования вспомогательной формы в прозрачную
Private Const WS_EX_LAYERED = &H80000
Private Const LWA_ALPHA = &H2
Private Const GWL_EXSTYLE = &HFFEC

Private Sub UserForm_Click()
    Dim ButtonOLEObj As OLEObject, LeftPos As Integer, TopPos As Integer
    Dim lLineNum As Long
    'Переменные значении смещения координат объектов клиентской области относительно координат окна приложения
    Dim SHFTX As Long, SHFTY As Long
    
    'Определяем координаты (в пикселях) смещения расположения первой ячейки клиентской области относительно координат окна приложения
    SHFTX = ActiveWindow.PointsToScreenPixelsX(0)
    SHFTY = ActiveWindow.PointsToScreenPixelsY(0)
    'Считываем координаты (в пикселях) текущего положения указателя мыши
    GetCursorPos pntPos
    'Определяем координаты (в пунктах) расположения добавляемого объекта ActiveX
    If Round((pntPos.X - SHFTX) * PXINPNT) - 20 <= 0 Then
        LeftPos = 0
    Else
        LeftPos = Round((pntPos.X - SHFTX) * PXINPNT) - 20
    End If
    If Round((pntPos.Y - SHFTY) * PXINPNT) - 20 <= 0 Then
        TopPos = 0
    Else
        TopPos = Round((pntPos.Y - SHFTY) * PXINPNT) - 20
    End If
    'Добавляем в лист дополнительный объект ActiveX (кнопку)
    Set ButtonOLEObj = ActiveWorkbook.ActiveSheet.OLEObjects.Add( _
        ClassType:="Forms.CommandButton.1", _
        DisplayAsIcon:=False, _
        Left:=LeftPos, _
        Top:=TopPos, _
        Width:=40, _
        Height:=40 _
    )
    With ButtonOLEObj
        .Object.Caption = ""
        'Вставляем в добавленный в активный лист объект ActiveX изображение и центрируем ее относительно размера объекта
        If Dir(ThisWorkbook.Path & "\Smiling face.jpg") <> "" Then .Object.Picture = LoadPicture(ThisWorkbook.Path & "\Smiling face.jpg")
        .Object.PicturePosition = fmPicturePositionCenter
    End With
    'Активируем ячейку активного листа, которая включает в свой размер левую и верхнюю координату добавленного объекта ActiveX
    ActiveWorkbook.ActiveSheet.Range(ButtonOLEObj.TopLeftCell.Address).Select
    'Отключаем переключение на окно VBAProject
    On Error GoTo ErrH:
    Application.VBE.MainWindow.Visible = False
    VBEHwnd = FindWindow("wndclass_desked_gsk", Application.VBE.MainWindow.Caption)
    If VBEHwnd Then
        LockWindowUpdate VBEHwnd
    End If
    'Вызываем функцию проверки наличия в активной книге необходимых модулей, требуемых для корректного срабатывания события Click добавленного объекта ActiveX ButtonOLEObj
    'и копирования этих модулей в активную книгу при их отсутствии
    Dim RunReplace As Boolean, Res As Integer, TextErr As String, NumbErr As Integer
    'Функции передан аргумент, определяющий, требуется ли замена содержимого модуля, предназначенного для вставки в активную книгу, при его обнаружении в активной книге
    RunReplace = False
    Res = CopyVBComponent("ModuleRun", "", ThisWorkbook, ActiveWorkbook, RunReplace)
    'Если необходимый модуль обнаружен в активной книге
    If Res = 0 Or Res = 1 Then
        'Определяем количество заполненных строк в интересуемом модуле
        lLineNum = ActiveWorkbook.VBProject.VBComponents(ActiveWorkbook.ActiveSheet.Name).CodeModule.CountOfLines + 1
        'Для нового добавленного объекта ActiveX создаем событие Click
        With ActiveWorkbook.VBProject.VBComponents(ActiveWorkbook.ActiveSheet.Name).CodeModule
            lLineNum = .CreateEventProc("Click", ButtonOLEObj.Name)
            lLineNum = lLineNum + 1
            .InsertLines lLineNum, GenNameMacros
        End With
    'Если в процессе выполнения функции произошла ошибка
    Else
        Select Case NumbErr
            Case 2
                TextErr = "Код ошибки 2: в книге исполняемого кода " & ThisWorkbook.Name & " не обнаружен проект VBA"
            Case 3
                TextErr = "Код ошибки 3: книга с исполняемым кодом " & ThisWorkbook.Name & " запаролирована"
            Case 4
                TextErr = "Код ошибки 4: Активная книга не содержит проект VBA"
            Case 5
                TextErr = "Код ошибки 5: проект VBA активной книги запаролирован"
            Case 6
                TextErr = "Код ошибки 6: не задано/неверно задано имя копируемого модуля"
            Case 7
                TextErr = "Код ошибки 7: в книге исполняемого кода не обнаружен заданный модуль"
            Case 8
                TextErr = "Код ошибки 8: ошибка удаления экспортированного файла модуля из временной папки"
            Case 9
                TextErr = "Код ошибки 9: неизвестная ошибка"
        End Select
        MsgBox "В процессе выполнения произошла ошибка на этапе модификации данных VBAProject" & Chr(13) & _
                TextErr, vbInformation + vbOKOnly, "Ошибка"
        'Удаляем добавленный объект ActiveX
        ButtonOLEObj.Delete
    End If
    Application.VBE.MainWindow.Visible = False
    'Устанавливаем форму стандартного системного курсора
    If Dir(PathCursor & NameFileCurEnd) <> "" Then
        NewCur = LoadCursorFromFile(PathCursor & NameFileCurEnd)
        SetSystemCursor NewCur, OCR_NORMAL
    End If
ErrH:
    LockWindowUpdate 0&
    Unload Me
End Sub

Private Sub UserForm_Initialize()
'    'Запоминаем прежний курсор и загружаем свой
'    OldCursor = GetCursor()
'    OldCursor = CopyCursor(OldCursor)
    If Dir(PathCursor & NameFileCurTMP, vbNormal) <> "" Then
        NewCur = LoadCursorFromFile(PathCursor & NameFileCurTMP)
        SetSystemCursor NewCur, OCR_NORMAL
    End If
    'Устанавливаем окно формы полностью прозрачным
    hwnd = FindWindow(vbNullString, Me.Caption)
    lStyle = GetWindowLong(hwnd, GWL_EXSTYLE)
    SetWindowLong hwnd, GWL_EXSTYLE, lStyle Or WS_EX_LAYERED
    SetLayeredWindowAttributes hwnd, 0, 2.55, LWA_ALPHA
End Sub

'Функция копирования компонента VBAProject из одной книги в другую
'Параметры функции:
'wbFromFrom - Книга, компонент из VBA-проекта которой необходимо копировать
'wbFromTo - Книга, в VBA-проект которой необходимо копировать компонент
'sModuleName - Имя модуля, который необходимо копировать
'sModuleToName - Имя модуля, в который необходимо копировать
'bOverwriteExistModule: Если True или 1, то при наличии в конечной книге компонента с именем sModuleName - он будет удален, а вместо него импортирован копируемый
                        'Если False, то при наличии в конечной книге компонента с именем sModuleName сам компонент не будет скопирован в VBAProject конечной книги
'Возвращаемые значения: 0 - Модуль успешно добавлен в VBAProject конечной (активной) книги;
                        '1 - интересуемый модуль обнаружен в конечной книге и его принудительная замена не требуется
                        'Ошибки, выявленные в ходе выполнения функции, не позволяющие дальнейшее ее корректное выполнение
                        '2 - в книге, из которой копируем, нет проекта VBA
                        '3 - в книге, из которой копируем, для проекта VBA установлен пароль
                        '4 - в книге, в которую копируем, нет проекта VBA
                        '5 - в книге, в которую копируем, для проекта VBA установлен пароль
                        '6 - не задано/неверно задано имя копируемого модуля
                        '7 - в книге, из которой копируем, не найден заданный модуль
                        '8 - ошибка удаления экспортированного файла модуля из временной папки
                        '9 - неизвестная ошибка
Private Function CopyVBComponent(sModuleName As String, ByVal sModuleToName As String, wbFromFrom As Workbook, wbFromTo As Workbook, bOverwriteExistModule As Boolean) As Integer

    Dim objVBProjFrom As Object, objVBProjTo As Object
    Dim objVBComp As Object, objTmpVBComp As Object
    Dim sTmpFolderPath As String, sVBCompName As String, sModuleCode As String
    
    'Проверяем корректность указанных параметров
    On Error Resume Next
    Set objVBProjFrom = wbFromFrom.VBProject
    Set objVBProjTo = wbFromTo.VBProject
    
    'если в книге, из которой копируем, нет проекта VBA
    If objVBProjFrom Is Nothing Then
        CopyVBComponent = 2: Exit Function
    End If
    'если в книге, из которой копируем, для проекта VBA установлен пароль
    If objVBProjFrom.Protection = 1 Then
        CopyVBComponent = 3: Exit Function
    End If
    
    'если в книге, в которую копируем, нет проекта VBA
    If objVBProjTo Is Nothing Then
        CopyVBComponent = 4: Exit Function
    End If
    'если в книге, в которую копируем, для проекта VBA установлен пароль
    If objVBProjTo.Protection = 1 Then
        CopyVBComponent = 5: Exit Function
    End If
    
    'если не задано имя копируемого модуля
    If Trim(sModuleName) = "" Then
        CopyVBComponent = 6: Exit Function
    End If
    'если не задано имя модуля для вставки кода, используем имя копируемого
    If Trim(sModuleToName) = "" Then
        sModuleToName = sModuleName
    End If
    
    'проверяем, существует ли в книге, из которой копируем, заданный модуль
    Set objVBComp = objVBProjFrom.VBComponents(sModuleName)
    'модуля нет, выходим из функции
    If objVBComp Is Nothing Then
        CopyVBComponent = 7: Exit Function
    End If
    
    'полный путь для экспорта/импорта модуля. К папке должен быть доступ на запись/чтение
    sTmpFolderPath = Environ("Temp") & "\" & sModuleToName & ".bas" '"
    'Если bOverwriteExistModule = True (принудительная замена модуля в конечной книге на новую версию), удаляем из временной папки и из конечного проекта модуль с указанным именем
    If bOverwriteExistModule Then
        'удаляем файл модуля из временной папки
        If Dir(sTmpFolderPath, 6) <> "" Then
            Err.Clear
            Kill sTmpFolderPath
            'удалить не удалось, модуль не сохранен. Выход из функции
            If Err.Number <> 0 Then
                CopyVBComponent = 8: Exit Function
            End If
        End If
        'удаляем модуль из конечной книги
        With objVBProjTo.VBComponents
            Set objVBComp = Nothing
            Set objVBComp = .Item(sModuleToName)
            'только если это не модуль листа или книги(их можно только очистить, но не удалять)
            If objVBComp.Type <> 100 Then
                .Remove .Item(sModuleToName)
            End If
        End With
    'Если установлен параметр bOverwriteExistModule, обозначающий, что принудительное обновление содержимого интересуемого модуля не требуется
    Else
        Err.Clear
        Set objVBComp = objVBProjTo.VBComponents(sModuleToName)
        'Если интересуемого модуля в конечной книге не обнаружено
        If Err.Number <> 0 Then
            'Err.Number 9 - отсутствие указанного компонента, что нам не мешает.
            'Если ошибка другая - выход из функции
            If Err.Number <> 9 Then
                CopyVBComponent = 9: Exit Function
            End If
        'если интересуемый модуль в конечной книге обнаружен
        Else
            CopyVBComponent = 1: Exit Function
        End If
    End If
    
    'Экспорт/Импорт компонента во временную директорию
    objVBProjFrom.VBComponents(sModuleName).Export sTmpFolderPath
    'копируем
    Set objVBComp = Nothing
    Set objVBComp = objVBProjTo.VBComponents(sModuleToName)
    If objVBComp Is Nothing Then
        objVBProjTo.VBComponents.Import sTmpFolderPath
    Else
        'Если компонент - модуль листа или книги, его нельзя удалить. Поэтому удаляем из него весь код и добавляем код из копируемого компонента
        If objVBComp.Type = 100 Then
            'для простоты обращения в коде делаем ссылку на копируемый модуль
            Set objTmpVBComp = objVBProjFrom.VBComponents(sModuleName)
            'копируем из него код
             With objVBComp.CodeModule
                .DeleteLines 1, .CountOfLines
                sModuleCode = objTmpVBComp.CodeModule.Lines(1, objTmpVBComp.CodeModule.CountOfLines)
                .InsertLines 1, sModuleCode
            End With
        End If
    End If
    'удаляем временный файл компонента
    Kill sTmpFolderPath
    CopyVBComponent = 0
End Function

Если абстрагироваться от вышеуказанных недостатков, то в системах 64-bit и 32-bit с установленным офисом 64-bit данное решение работает вполне корректно и при желании, если файл с исполняемым кодом оформить в виде надстройки, поместить ее в группу на ленте, где располагаются элементы Active X отдельной дополнительной группой, получится вполне приемлемый для использования уникальный пользовательский объект.
Прилагаю для ознакомления пример с описанным исполняемым кодом. Достаточно загрузить приложение Excel, открыть любую книгу Excel или просто создать новую и вызвать на исполнение макрос из прилагаемого файла формата .xlsm Proba.

Спасибо за внимание!
Любые замечания, идеи, конструктивная критика приветствуются.

С Уважением!  
Изменено: Владимир Баукин - 11.07.2021 06:01:56
Страницы: 1
Наверх