Как добиться адаптивного эффекта наведения мыши на элементы управления в немодальной пользовательской форме vba на большом рабочем листе - PullRequest
Новая
       6

Как добиться адаптивного эффекта наведения мыши на элементы управления в немодальной пользовательской форме vba на большом рабочем листе

1 голос
/ 05 ноября 2019

У меня есть следующий код, который прекрасно работает на обычной пользовательской форме VBA: всякий раз, когда указатель мыши находится где-нибудь над меткой, цвет упомянутой метки красный, в противном случае - белый. Этот эффект очень отзывчив и делает ярлык очень похожим на кнопку.

Код пользовательской формы с 1 ярлыком на нем: 

Dim active As Boolean

Private Sub Label1_MouseMove(ByVal Button As Integer, ByVal Shift As Integer, ByVal X As Single, ByVal Y As Single)
    If active = False Then
        Label1.BackColor = RGB(255, 0, 0)
        active = True
    End If
End Sub

Private Sub UserForm_MouseMove(ByVal Button As Integer, ByVal Shift As Integer, ByVal X As Single, ByVal Y As Single)
    If active = True Then
        Label1.BackColor = RGB(255, 255, 255)
        active = False
    End If
End Sub

Если я изменю пользовательскую форму, чтобы она называлась немодальной,из модуля, подобного этому: 

Sub loader()
    UserForm1.Show vbModeless
End Sub

Эффект наведения мыши все еще работает, но он становится очень вялым и не отвечает. Похоже, что скорость обновления значительно снизилась.

Редактировать : я обнаружил, что эта проблема появляется только тогда, когда активная рабочая таблица является большой, что, очевидно, немного замедляет все. Лист, который вызывает у меня головную боль, имеет около 1000 строк и 50 столбцов со множеством ячеек, содержащих более длинные строки. Я думаю, что сам лист составляет около 1 МБ данных. Forumlas настроены только на ручное обновление. Я на ноутбуке с i7 8550U и 8 ГБ оперативной памяти, используя Office 32 bit.

Мой вопрос:

Можно ли добиться поведения модальной пользовательской формы в немодальной? Я искал способы управления скоростью обновления немодальной пользовательской формы, но не смог найти ничего полезного.

Альтернативным решением было бы сделать возможной прокрутку на рабочем листе, пока пользовательская форма отображается в модальном режиме.

Другое решение может заключаться в том, чтобы сделать пользовательскую форму модальной, когда на ней находится мышь, и она немодальна, когда мышь покидает определенную область (границы пользовательской формы). Это возможно?

1 Ответ

0 голосов
/ 05 ноября 2019

РЕДАКТИРОВАТЬ: я нашел простое решение после дня проб и ошибок Теперь я опишу простое решение и оставлю сложное решение, которое я нашел до этого ниже, просто в качестве альтернативы.

Простое решение: 1-й, нам нужно получить функцию сна из Windows API: 

#If Win64 Then
    Public Declare PtrSafe Sub Sleep Lib "kernel32" (ByVal dwMilliseconds As Long)
#If Win32 Then
    Public Declare Sub Sleep Lib "kernel32" (ByVal lngMilliSeconds As Long)
#End If

Примечание: протестировано только для 32-битного Office, но должно работать с 64-битнымaswell

Во-вторых, мы объявляем логическое значение, которое будет указывать, является ли пользовательская форма открытой или закрытой: 

Public UF1open As Boolean

И наконец, мы включаем следующий код в событие активации пользовательских форм: 

Private Sub UserForm_Activate()
    UF1open = True
    Do
        Sleep 1  'this correlates to the "refresh rate" of the mouseover effect, sleep 100 leads to sluggish behaviour
        DoEvents
    Loop Until UF1open = False
End Sub

И следующее в пользовательском событии завершения: 

Private Sub UserForm_Terminate()
    UF1open = False
End Sub

Ниже приводится сложное и трудное первое решение, которое я придумал:

Это решает проблему, используя последнюю из предложенных мной идей решения. Я заставил пользовательскую форму автоматически переходить в модальное положение, когда мышь находится в области пользовательской формы, и автоматически отключался, когда мышь покидает область пользовательской формы. Для этого требуется множество функций API. Следующее, к сожалению, является спагетти-кодом и не очень стабильным (небрежная обработка ошибок), но подтверждает концепцию:

Это модуль для вызова пользовательской формы: 

Option Explicit


#If Win32 Then
    Public Declare Function GetCursorPos Lib "user32" (lpPoint As PointAPI) As Long
    Public Declare Function GetTickCount Lib "kernel32.dll" () As Long
    Private Declare Sub Sleep Lib "kernel32" (ByVal lngMilliSeconds As Long)
    Declare Function GetDC Lib "user32" (ByVal hWnd As Long) As Long
    Declare Function GetDeviceCaps Lib "Gdi32" (ByVal hDC As Long, ByVal nIndex As Long) As Long
    Declare Function ReleaseDC Lib "user32" (ByVal hWnd As Long, ByVal hDC As Long) As Long
#End If

Const LogPixelsX = 88
Const LogPixelsY = 90
Public Type PointAPI
    x As Long
    y As Long
End Type

Public ufXposScreen As Long
Public ufYposScreen As Long
Public ufXposVBA As Long
Public ufYposVBA As Long
Public ufXpos2Screen As Long
Public ufYpos2Screen As Long
Public ufXpos2VBA As Long
Public ufYpos2VBA As Long

Public UFname As String
Public JustStarted As Boolean 'to catch the first time a function is called
Public ModleS As Boolean 'indicate whether the UF is currently moedless or not


Sub loader()
#If Win64 Then
    MsgBox "Sorry 64 bit not supported"
    Exit Sub
#End If
    ModleS = False
    JustStarted = True
    UserForm1.Show

End Sub


Public Function IsLoaded(formName As String) As Boolean 'returns if UF is currently loaded or not
Dim frm As Object
For Each frm In VBA.UserForms
    If frm.Name = formName Then
        IsLoaded = True
        Exit Function
    End If
Next frm
IsLoaded = False
End Function
Public Function pointsPerPixelX() As Double 'Used for transforming windows API Mouse-coordinates to vba coordinates
    Dim hDC As Long
    hDC = GetDC(0)
    pointsPerPixelX = 72 / GetDeviceCaps(hDC, LogPixelsX)
    ReleaseDC 0, hDC
End Function
Public Function pointsPerPixelY() As Double 'Used for transforming windows API Mouse-coordinates to vba coordinates
    Dim hDC As Long
    hDC = GetDC(0)
    pointsPerPixelY = 72 / GetDeviceCaps(hDC, LogPixelsY)
    ReleaseDC 0, hDC
End Function
Public Function GetX() As Long 'Get current X coordinate of Mouse
    Dim n As PointAPI
    GetCursorPos n
    GetX = n.x
End Function
Public Function GetY() As Long 'Get current y coordinate of Mouse
    Dim n As PointAPI
    GetCursorPos n
    GetY = n.y
End Function
Public Sub WaitSeconds(sngSeconds As Single) 'sub pausing application for given value of seconds
    On Error GoTo errHand
    Dim s As Single
    s = Timer + sngSeconds
    Do
        Sleep 1  'this correlates to the "refresh rate" of the mouseover effect, sleep 100 leads to sluggish behaviour
        DoEvents
    Loop Until Timer >= s

Done:
    Exit Sub

errHand:
    MsgBox "Error: " & Err.Number & ". " & Err.Description, , "modDateTime.WaitSeconds"
    Resume Done
End Sub
Public Sub RunAllTime(ByRef UF As Object)
            '// this sub is called in the uf_activate event and loops
            '// all the time. if the mouse leaves the uf area if makes
            '// the userform go modeless, if the mouse reenters the area
            '// the sub exits, but not before using uf.show to make the
            '// uf modal again. uf.show automatically recalls this sub
            '// because of the activate event.

Dim x As Long
Dim y As Long

If JustStarted Then
    UFname = UF.Name
    JustStarted = False
End If

Do
    WaitSeconds 0.5

    If IsLoaded(UFname) = False Then
        End
    End If

    x = GetX()
    y = GetY()

    With UF
        If .Left <> ufXposVBA Or .Top <> ufYposVBA Or (.Left + .Width) <> ufXpos2VBA Or (.Top + .Height) <> ufYpos2VBA Then
            ufXposVBA = .Left
            ufYposVBA = .Top
            ufXposScreen = .Left / pointsPerPixelX()
            ufYposScreen = .Top / pointsPerPixelY()
            ufXpos2VBA = .Left + .Width
            ufYpos2VBA = .Top + .Height
            ufXpos2Screen = (.Left + .Width) / pointsPerPixelX()
            ufYpos2Screen = (.Top + .Height) / pointsPerPixelY()
        End If
        If ModleS = False Then
            If x < ufXposScreen Or x > ufXpos2Screen Or y < ufYposScreen Or y > ufYpos2Screen Then
                UF.Hide
                UF.Show vbModeless
                ModleS = True
            End If
        Else
            If x > ufXposScreen And x < ufXpos2Screen And y > ufYposScreen And y < ufYpos2Screen Then
                UF.Hide
                ModleS = False
                UF.Show
                Exit Sub
            End If
        End If
    End With
Loop

End Sub

И это кодформа пользователя: 

Dim active As Boolean

Private Sub UserForm_Initialize()
    With UserForm1
        ufXposVBA = .Left
        ufYposVBA = .Top
        ufXposScreen = .Left / pointsPerPixelX()
        ufYposScreen = .Top / pointsPerPixelY()
        ufXpos2VBA = .Left + .Width
        ufYpos2VBA = .Top + .Height
        ufXpos2Screen = (.Left + .Width) / pointsPerPixelX()
        ufYpos2Screen = (.Top + .Height) / pointsPerPixelY()
    End With
End Sub

Private Sub UserForm_Activate()
    RunAllTime UserForm1
End Sub

Private Sub Label1_MouseMove(ByVal Button As Integer, ByVal Shift As Integer, ByVal x As Single, ByVal y As Single)
    If active = False Then
        Label1.BackColor = RGB(255, 0, 0)
        active = True
    End If
End Sub

Private Sub UserForm_MouseMove(ByVal Button As Integer, ByVal Shift As Integer, ByVal x As Single, ByVal y As Single)
    If active = True Then
        Label1.BackColor = RGB(255, 255, 255)
        active = False
    End If
End Sub

Если кто-то заинтересован в этом и сможет найти лучшее решение или сможет улучшить мой код, пожалуйста, опубликуйте его здесь.

...