Click and move on Userform

[Euler]

Đối với lập trình VBA, có lẽ không thể không nói tới Userform. Đây là nơi thiết kế nên giao diện cho một chương trình trông có vẻ bắt mắt và đẹp hơn.
Bài viết này mình chia sẻ với mọi người một đoạn code dùng để kéo thả label trên Userform.

Bạn cần đăng nhập để thấy hình ảnh

'Code cho Label 1:
Private PosX As Double, PosY As Double
Private Sub Label1_MouseDown(ByVal Button As Integer, ByVal Shift As Integer, ByVal X As Single, ByVal Y As Single)
  PosX = X: PosY = Y
End Sub
Private Sub Label1_MouseMove(ByVal Button As Integer, ByVal Shift As Integer, ByVal X As Single, ByVal Y As Single)
  If Button > 0 Then 'Khi tay còn click chuột thì còn làm việc dưới đây
    Me.Label1.Left = Me.Label1.Left + X - PosX 'PosX la vi tri cua con tro khi di chuyen, tinh toi mep trai Left
    Me.Label1.Top = Me.Label1.Top + Y - PosY 'PosY la vi tri cua con tro khi di chuyen, tinh toi mep tren Top
  End If
End Sub

Giải thích: Tọa độ Label được xác định thông qua hai thông số quan trọng là Left và Top.
Giả thiết ta click chuột và kéo tới vị trí Label màu vàng như hình vẽ dưới đây.
Lúc này ta cần tính lại Left và Top cho Label ở vị trí mới dựa vào tọa độ click chuột. Ngay khi ta click chuột ta được Left và Top tại vị trí click chuột là POST X và POST Y. Khi tới vị trí mới, vị trí ta nhả chuột cũng là nơi cuối cùng ta còn click chuột, lúc ấy tọa độ của chuột là X và Y.
Và như vậy công thức tọa độ mới cho label ở vị trí mới (màu vàng) được tính như ở code trên.

Bạn cần đăng nhập để thấy đính kèm

 

[vbano1]

Nếu kết hợp với đoạn code dưới đây, ta sẽ có một label vừa chuyển động lại mang phong cách internet Explorer:

'==========================================================================

Private Sub Label1_MouseDown(ByVal Button As Integer, _
    ByVal Shift As Integer, ByVal X As Single, ByVal Y As Single)
' lam cho label lõm xuống khi ấn xuống
Label1.SpecialEffect = fmSpecialEffectSunken
End Sub

Private Sub Label1_MouseUp(ByVal Button As Integer, _
    ByVal Shift As Integer, ByVal X As Single, ByVal Y As Single)
'Trả lại hình dạng ban đầu cho label
Label1.SpecialEffect = fmSpecialEffectEtched
End Sub
'==========================================================================

Nguồn:

Bạn cần đăng nhập để thấy link