Создаём крутую кнопку на Visual Basic

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

Сначала создадим новый элемент ActiveX и назовём его "CoolButton", а проект "CoolBTN". Установим свойство элемента "AutoRedraw" = True. Теперь добавим на контрол четыре элемента PictureBox, назовём их "picUP", "picDown", "picMove" и "picDisabled". Они будут хранить картинки различных состояний кнопки. Завершим работу с элементами - установим свойства элементов PictureBox "AutoRedraw" = True и "Visible" = False. Запустим мастер "ActiveX Control Interface Wizard" и добавим следующие свойства и методы:

Теперь перейдём в код нашего элемента. Для определения положения курсора и некоторых графических операций нам потребуются следующие API функции, добавьте их в код элемента:

Private Declare Function GetCapture Lib "user32" () As Long
Private Declare Function SetCapture Lib "user32" (ByVal hwnd As Long) As Long 
Private Declare Function ReleaseCapture Lib "user32" () As Long 
Private Declare Function DrawEdge Lib "user32" (ByVal hdc As Long, qrc As RECT, ByVal edge As Long, ByVal grfFlags As Long) As Long 
Private Declare Function DrawText Lib "user32" Alias "DrawTextA" (ByVal hdc As Long, ByVal lpStr As String, ByVal nCount As Long, lpRect As RECT, ByVal wFormat As Long) As Long
Private Declare Function SetTextColor Lib "gdi32" (ByVal hdc As Long, ByVal crColor As Long) As Long

Функция GetCapture получает окно, которое принимает сообщения мышки, а функция SetCapture, соответственно, устанавливает, какому окну получать мышиные сообщения. Чтобы мышиные сообщения получало окно, над которым действительно находится курсор, будем использовать эту функцию. Для рисования рамки кнопки нам потребуется API функция DrawRect, необходимые для неё структура и константы перечислены ниже. При рисовании текста с помощью функции DrawText нам будет необходима функция SetTextColor, чтобы установить цвет текста. Значение свойства "ForeColor" элемента ActiveX не будет влиять на цвет текста, нарисованный функцией DrawText.

Private Const BDR_RAISEDINNER = &H4
Private Const BDR_SUNKENOUTER = &H2
Private Const BF_BOTTOM = &H8
Private Const BF_LEFT = &H1
Private Const BF_TOP = &H2 
Private Const BF_RIGHT = &H4
Private Const BF_RECT = (BF_LEFT Or BF_TOP Or BF_RIGHT Or BF_BOTTOM)
Private Const BDR_RAISEDOUTER = &H1 
Private Const BDR_SUNKEN = &HA 
Private Const BDR_RAISED = &H5 
Private Const DT_LEFT = &H0 
Private Const DT_CENTER = &H1

Private Type RECT
Left As Long
Top As Long
Right As Long
Bottom As Long
End Type

Сделаем у нашей кнопки несколько стилей бордюра (добавим перечисление этих стилей):

Public Enum ButtonStyle
None = 0
FlatUp = 1
FlatDown = 2
Standart = 3 
End Enum

Для того, чтобы пользователь мог выбрать один из этих стилей поправьте тип данных в процедурах Let и Get каждого совойства Style...:

Public Property Get StyleUp() As ButtonStyle
StyleUp = m_StyleUp
End Property

Public Property Let StyleUp(ByVal New_StyleUp As ButtonStyle)
m_StyleUp = New_StyleUp
PropertyChanged "StyleUp"
RenderUP
End Propert

Для отрисовки кнопки нам необходимы процедуры для каждого состояния кнопки, рассмотрим одну из них:

Private Sub RenderUP() 'рисуем кнопку в нормальном состоянии
If Enabled = False Then RenderDisabled: Exit Sub 'на всякий случай, если элемент ActiveX дезактивирован, то выходим от сюда на ... :)
Dim RT As RECT, y As Long 'объявляем структуру для отрисовки бордюра и текста.
Line (0, 0)-(ScaleWidth, ScaleHeight), BackColor, BF 'очищаем элмент, закрашивая его цветом поверхности самого элмента. Используем Line вместо Cls, чтобы избежать мерцания
If picUP.Picture = Empty Then 'рисуем кнопку, если картинка для нормального состояния не указана.
RT.Left = 0
RT.Right = (ScaleWidth \ 15)
RT.Top = (ScaleHeight \ 30) - TextHeight(Caption) \ 30 'центрируем положения текста
RT.Bottom = (ScaleHeight \ 15)
DrawText hdc, Caption & vbNullString, Len(Caption), RT, DT_CENTER 'рисуем текст
Else 'а если у нас картинка установлена...
y = (ScaleHeight \ 30) - (picUP.ScaleHeight \ 30) 'это значение необходимо, чтобы нарисовать картинку центрально по вертикали
RT.Left = 4 + (picUP.ScaleWidth \ 15) 'смещаем текст от картинки
RT.Right = (ScaleWidth \ 15)
RT.Top = (ScaleHeight \ 30) - TextHeight(Caption) \ 30
RT.Bottom = (ScaleHeight \ 15)
DrawText hdc, Caption & vbNullString, Len(Caption), RT, DT_CENTER
DrawPicture picUP, hdc, 4, y 'для отрисовки картинки я создал специальный модуль с этой функцией (посмотрите в исходнике).
End If
RT.Top = 0
RT.Left = 0
RT.Right = (ScaleWidth \ 15)
RT.Bottom = (ScaleHeight \ 15)
Select Case m_StyleUp 'здесь всё просто - рисуем рамку в зависимости значения свойства StyleUp
Case FlatUp
DrawEdge hdc, RT, BDR_RAISEDINNER, BF_RECT
Case FlatDown
DrawEdge hdc, RT, BDR_SUNKENOUTER, BF_RECT
Case Standart
DrawEdge hdc, RT, BDR_RAISED, BF_RECT
End Select
End Sub

Вызывать процедуры отрисовки мы будем в мышиных событиях (также в событиях UserControl_Resize и UserControl_Show):

Private Sub UserControl_MouseMove(Button As Integer, Shift As Integer, x As Single, y As Single)
RaiseEvent MouseMove(Button, Shift, x, y) 'генерируем событие для владельца нашей кнопки
If GetCapture hwnd Then SetCapture (hwnd) 'переводим мышиные события на наш элемент
If Button vbLeftButton Then
If x > 0 And x < ScaleWidth And y > 0 And y < ScaleHeight Then
RenderMove 'отрисовываемся, если курсор находится над кнопкой
Else
ReleaseCapture 'если курсор не над кнопкой, освобождаем мышь и рисуем её нормальное состояние
RenderUP
End If
Else
If x > 0 And x < ScaleWidth And y > 0 And y < ScaleHeight Then 'а если ещё и нажата кнопка...
RenderDown
Else
RenderUP
End If
End If
End Sub

Private Sub UserControl_MouseDown(Button As Integer, Shift As Integer, x As Single, y As Single)
RaiseEvent MouseDown(Button, Shift, x, y)
If Button = vbLeftButton Then
RenderDown
Else
End If
End Sub

Private Sub UserControl_MouseUp(Button As Integer, Shift As Integer, x As Single, y As Single)
If Button = vbLeftButton And x > 0 And x < ScaleWidth And y > 0 And y < ScaleHeight Then
RaiseEvent MouseUp(Button, Shift, x, y)
End If
RenderUP 
End Sub

В событиях MouseDown и MouseUp думаю, что нет ничего сложного и их не надо объяснять. Процедуры отрисовки кнопки в других состояних аналогичны процедуре RenderUp, за исключением некоторых особенностей. В этой статье я рассмотрел основу работы нашей кнопки.

Источник: http://hiprog.com 

16.02.2006