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
|