Простенький ToolBar

[timsoft]

Вот решил поделиться.
Сделал простенький ToolBar, который, несмотря на простоту, используется в нескольких коммерческих приложениях.
Может, кому пригодится.

Тут исходники (30 кб)

Доработки и замечания приветствуются.

Кому интересно, могу выложить Фотошоповский файл с исходниками кнопок.

Кстати, имеется версия, которая берет картики кнопок из ресурса (чтоб не таскать с собой ImageList)

[A.A.Z.]

Неплохо, только я бы сделал ButtonPressed не на Click, а на MouseDown

[A.A.Z.]

Кстати, а почему кнопка "вниз" не отжимается обратно?

[timsoft]

Кстати, а почему кнопка "вниз" не отжимается обратно?

а это просто демонстрация фичи типа twoStateButton (залипающая кнопка)

А почему MouseDown лучшее, чем Click?

[A.A.Z.]

Да, вот еще, лучше было бы оставлять кнопку нажатой до того, как кнопку мыши отпустят А то я эти MsgBox'ы убрал, и вообще незаметно стало, как кнопка нажимается

[A.A.Z.]

Кстати, а почему кнопка "вниз" не отжимается обратно?

а это просто демонстрация фичи типа twoStateButton (залипающая кнопка)

А, ясно Не увидел

[A.A.Z.]

Просто Click Rais'ится когда пользователь уже отпустил мышку, а хочется, чтобы кнопка выглядела нажатой тогда, когда на нее нажимают

[timsoft]

"блымать" будет (мерцать)
я кажется так пробовал...
хотя, уже и не помню

ага, вроде вспомнил
получается, что если по MouseDown произойдет ButtonPressed, и по этому событию откроется например модальная форма, то потом кнопка так и останется нажатой (ведь MouseUp потеряется) Или нет?

[A.A.Z.]

Вот, чуть-чуть изменил

Код: Выделить всё

Option Explicit

Private Enum btnState
  isPressed
  isUnpressed
End Enum

Private Type myButtonType
  name As String
  State As btnState
  TwoState As Boolean
  toolTip As String
End Type

Private m_btn() As myButtonType
Dim m_numButtons As Integer
Dim Need As Boolean
'Event Declarations:
Event ButtonPressed(sName As String)
'Default Property Values:
Const m_def_ButtonsCount = 0
Const m_def_Simple = False
Const m_def_GetNextPos = 0
'Property Variables:
Dim m_ButtonsCount As Integer
Dim m_Simple As Boolean
Dim m_GetNextPos As Single


Private Sub imgBtn_MouseDown(Index As Integer, Button As Integer, Shift As Integer, X As Single, Y As Single)
  If m_btn(Index).State = isUnpressed Then
    PressButtonIdx Index
    DoEvents
  RaiseEvent ButtonPressed(m_btn(Index).name)
  ElseIf m_btn(Index).TwoState = True And m_btn(Index).State = isPressed Then Need = True
  End If
End Sub

Private Sub imgBtn_MouseUp(Index As Integer, Button As Integer, Shift As Integer, X As Single, Y As Single)
If m_btn(Index).State = isPressed And (m_btn(Index).TwoState = False Or Need = True) Then
UnpressButton m_btn(Index).name
Need = False
DoEvents
End If
End Sub

Private Sub UserControl_Initialize()
  Set imgBG.Picture = toolImages.ListImages("TOOLBG").Picture
  imgBG.Stretch = True
  BackColor = RGB(127, 127, 127)
End Sub

Private Sub UserControl_Resize()
  Height = imgBG.Height
  imgBG.Width = Width
End Sub

'WARNING! DO NOT REMOVE OR MODIFY THE FOLLOWING COMMENTED LINES!
'MemberInfo=0
Public Sub AddButton(sName As String, Optional sToolTip As String = "", Optional lLeft As Long = 0, Optional bTwoState As Boolean = False, Optional sKey As String = "")
  Dim tTip As String
  m_numButtons = m_numButtons + 1
  ReDim Preserve m_btn(m_numButtons)
  m_btn(m_numButtons).name = sName
  m_btn(m_numButtons).State = isUnpressed
  m_btn(m_numButtons).TwoState = bTwoState
  Load imgBtn(m_numButtons)
  Load imgBtn_A(m_numButtons)
  Load imgBtn_B(m_numButtons)
  Set imgBtn_A(m_numButtons).Picture = toolImages.ListImages(sName & "_A").Picture
  Set imgBtn_B(m_numButtons).Picture = toolImages.ListImages(sName & "_B").Picture
  Set imgBtn(m_numButtons).Picture = imgBtn_A(m_numButtons).Picture
  If lLeft = 0 Then
    If m_numButtons = 1 Then
      imgBtn(m_numButtons).Left = Screen.TwipsPerPixelX * 5
    Else
      imgBtn(m_numButtons).Left = imgBtn(m_numButtons - 1).Left + imgBtn(m_numButtons - 1).Width + Screen.TwipsPerPixelX * 3
    End If
  Else
    imgBtn(m_numButtons).Left = lLeft
  End If
  If m_Simple Then
    imgBtn(m_numButtons).Top = Screen.TwipsPerPixelY
  Else
    imgBtn(m_numButtons).Top = 12 * Screen.TwipsPerPixelY
  End If
  m_GetNextPos = imgBtn(m_numButtons).Left + imgBtn(m_numButtons).Width
 
  imgBtn(m_numButtons).Visible = True
  imgBtn(m_numButtons).ZOrder
  If sToolTip <> "" Then
    imgBtn(m_numButtons).ToolTipText = " " & sToolTip & sKey & " "
    m_btn(m_numButtons).toolTip = sToolTip
  End If
End Sub

'WARNING! DO NOT REMOVE OR MODIFY THE FOLLOWING COMMENTED LINES!
'MemberInfo=0
Public Sub UnpressButton(sName As String)
  Dim i As Integer
  For i = 1 To m_numButtons
    If m_btn(i).name = sName Then
      If m_btn(i).State = isPressed Then
        Set imgBtn(i).Picture = imgBtn_A(i).Picture
        imgBtn(i).Left = imgBtn(i).Left - Screen.TwipsPerPixelX
        imgBtn(i).Top = imgBtn(i).Top - Screen.TwipsPerPixelY
      End If
      m_btn(i).State = isUnpressed
      Exit For
    End If
  Next i
End Sub

'WARNING! DO NOT REMOVE OR MODIFY THE FOLLOWING COMMENTED LINES!
'MemberInfo=12,1,2,0
Public Property Get GetNextPos() As Single
  GetNextPos = m_GetNextPos
End Property

'Initialize Properties for User Control
Private Sub UserControl_InitProperties()
  m_GetNextPos = m_def_GetNextPos
  m_Simple = m_def_Simple
  m_ButtonsCount = m_def_ButtonsCount
End Sub

'Load property values from storage
Private Sub UserControl_ReadProperties(PropBag As PropertyBag)
  m_GetNextPos = PropBag.ReadProperty("GetNextPos", m_def_GetNextPos)
  m_Simple = PropBag.ReadProperty("Simple", m_def_Simple)
  If m_Simple Then
    imgBG.Stretch = False
    Set imgBG.Picture = LoadPicture
    Set imgBG.Picture = toolImages.ListImages("TOOLBG1").Picture
    imgBG.Stretch = True
  Else
    imgBG.Stretch = False
    Set imgBG.Picture = LoadPicture
    Set imgBG.Picture = toolImages.ListImages("TOOLBG").Picture
    imgBG.Stretch = True
  End If
  m_ButtonsCount = PropBag.ReadProperty("ButtonsCount", m_def_ButtonsCount)
End Sub

'Write property values to storage
Private Sub UserControl_WriteProperties(PropBag As PropertyBag)
  Call PropBag.WriteProperty("GetNextPos", m_GetNextPos, m_def_GetNextPos)
  Call PropBag.WriteProperty("Simple", m_Simple, m_def_Simple)
  Call PropBag.WriteProperty("ButtonsCount", m_ButtonsCount, m_def_ButtonsCount)
End Sub

'WARNING! DO NOT REMOVE OR MODIFY THE FOLLOWING COMMENTED LINES!
'MemberInfo=0,0,0,false
Public Property Get Simple() As Boolean
  Simple = m_Simple
End Property

Public Property Let Simple(ByVal New_Simple As Boolean)
  m_Simple = New_Simple
  If m_Simple Then
    imgBG.Stretch = False
    Set imgBG.Picture = LoadPicture
    Set imgBG.Picture = toolImages.ListImages("TOOLBG1").Picture
    imgBG.Stretch = True
  Else
    imgBG.Stretch = False
    Set imgBG.Picture = LoadPicture
    Set imgBG.Picture = toolImages.ListImages("TOOLBG").Picture
    imgBG.Stretch = True
  End If
  PropertyChanged "Simple"
End Property

Private Sub PressButtonIdx(i As Integer)
  If m_btn(i).State = isUnpressed Then
    Set imgBtn(i).Picture = imgBtn_B(i).Picture
    m_btn(i).State = isPressed
    imgBtn(i).Left = imgBtn(i).Left + Screen.TwipsPerPixelX
    imgBtn(i).Top = imgBtn(i).Top + Screen.TwipsPerPixelY
  End If
  DoEvents
  RaiseEvent ButtonPressed(m_btn(i).name)
End Sub

'WARNING! DO NOT REMOVE OR MODIFY THE FOLLOWING COMMENTED LINES!
'MemberInfo=14
Public Sub PressButton(sName As String)
  Dim i As Integer
  For i = 1 To m_numButtons
    If m_btn(i).name = sName Then
      If m_btn(i).State = isUnpressed Then
        Set imgBtn(i).Picture = imgBtn_B(i).Picture
        m_btn(i).State = isPressed
        imgBtn(i).Left = imgBtn(i).Left + Screen.TwipsPerPixelX
        imgBtn(i).Top = imgBtn(i).Top + Screen.TwipsPerPixelY
      End If
      Exit For
    End If
  Next i
  RaiseEvent ButtonPressed(sName)
  If Not m_btn(i).TwoState Then
    UnpressButton sName
  End If
End Sub

'WARNING! DO NOT REMOVE OR MODIFY THE FOLLOWING COMMENTED LINES!
'MemberInfo=13
Public Function GetToolTipText(idx As Integer) As String
  GetToolTipText = m_btn(idx).toolTip
End Function

'WARNING! DO NOT REMOVE OR MODIFY THE FOLLOWING COMMENTED LINES!
'MemberInfo=7,1,2,0
Public Property Get ButtonsCount() As Integer
  ButtonsCount = m_numButtons
End Property

Вроде не блымает

[A.A.Z.]

получается, что если по MouseDown произойдет ButtonPressed, и по этому событию откроется например модальная форма, то потом кнопка так и останется нажатой (ведь MouseUp потеряется) Или нет?

Не знаю, надо проверить...

[timsoft]

О, я понял
Надо райзить ивент в MouseUp

[A.A.Z.]

Ага, теряется Тогда так:

Код: Выделить всё

Option Explicit

Private Enum btnState
  isPressed
  isUnpressed
End Enum

Private Type myButtonType
  name As String
  State As btnState
  TwoState As Boolean
  toolTip As String
End Type

Private m_btn() As myButtonType
Dim m_numButtons As Integer
Dim Need As Boolean
'Event Declarations:
Event ButtonPressed(sName As String)
'Default Property Values:
Const m_def_ButtonsCount = 0
Const m_def_Simple = False
Const m_def_GetNextPos = 0
'Property Variables:
Dim m_ButtonsCount As Integer
Dim m_Simple As Boolean
Dim m_GetNextPos As Single

Private Sub imgBtn_MouseDown(Index As Integer, Button As Integer, Shift As Integer, X As Single, Y As Single)
  If m_btn(Index).State = isUnpressed Then
    PressButtonIdx Index
    DoEvents
  ElseIf m_btn(Index).TwoState = True And m_btn(Index).State = isPressed Then Need = True
  End If
End Sub

Private Sub imgBtn_MouseUp(Index As Integer, Button As Integer, Shift As Integer, X As Single, Y As Single)
If m_btn(Index).State = isPressed And (m_btn(Index).TwoState = False Or Need = True) Then
UnpressButton m_btn(Index).name
RaiseEvent ButtonPressed(m_btn(Index).name)
Need = False
DoEvents
End If
End Sub

Private Sub UserControl_Initialize()
  Set imgBG.Picture = toolImages.ListImages("TOOLBG").Picture
  imgBG.Stretch = True
  BackColor = RGB(127, 127, 127)
End Sub

Private Sub UserControl_Resize()
  Height = imgBG.Height
  imgBG.Width = Width
End Sub

'WARNING! DO NOT REMOVE OR MODIFY THE FOLLOWING COMMENTED LINES!
'MemberInfo=0
Public Sub AddButton(sName As String, Optional sToolTip As String = "", Optional lLeft As Long = 0, Optional bTwoState As Boolean = False, Optional sKey As String = "")
  Dim tTip As String
  m_numButtons = m_numButtons + 1
  ReDim Preserve m_btn(m_numButtons)
  m_btn(m_numButtons).name = sName
  m_btn(m_numButtons).State = isUnpressed
  m_btn(m_numButtons).TwoState = bTwoState
  Load imgBtn(m_numButtons)
  Load imgBtn_A(m_numButtons)
  Load imgBtn_B(m_numButtons)
  Set imgBtn_A(m_numButtons).Picture = toolImages.ListImages(sName & "_A").Picture
  Set imgBtn_B(m_numButtons).Picture = toolImages.ListImages(sName & "_B").Picture
  Set imgBtn(m_numButtons).Picture = imgBtn_A(m_numButtons).Picture
  If lLeft = 0 Then
    If m_numButtons = 1 Then
      imgBtn(m_numButtons).Left = Screen.TwipsPerPixelX * 5
    Else
      imgBtn(m_numButtons).Left = imgBtn(m_numButtons - 1).Left + imgBtn(m_numButtons - 1).Width + Screen.TwipsPerPixelX * 3
    End If
  Else
    imgBtn(m_numButtons).Left = lLeft
  End If
  If m_Simple Then
    imgBtn(m_numButtons).Top = Screen.TwipsPerPixelY
  Else
    imgBtn(m_numButtons).Top = 12 * Screen.TwipsPerPixelY
  End If
  m_GetNextPos = imgBtn(m_numButtons).Left + imgBtn(m_numButtons).Width
 
  imgBtn(m_numButtons).Visible = True
  imgBtn(m_numButtons).ZOrder
  If sToolTip <> "" Then
    imgBtn(m_numButtons).ToolTipText = " " & sToolTip & sKey & " "
    m_btn(m_numButtons).toolTip = sToolTip
  End If
End Sub

'WARNING! DO NOT REMOVE OR MODIFY THE FOLLOWING COMMENTED LINES!
'MemberInfo=0
Public Sub UnpressButton(sName As String)
  Dim i As Integer
  For i = 1 To m_numButtons
    If m_btn(i).name = sName Then
      If m_btn(i).State = isPressed Then
        Set imgBtn(i).Picture = imgBtn_A(i).Picture
        imgBtn(i).Left = imgBtn(i).Left - Screen.TwipsPerPixelX
        imgBtn(i).Top = imgBtn(i).Top - Screen.TwipsPerPixelY
      End If
      m_btn(i).State = isUnpressed
      Exit For
    End If
  Next i
End Sub

'WARNING! DO NOT REMOVE OR MODIFY THE FOLLOWING COMMENTED LINES!
'MemberInfo=12,1,2,0
Public Property Get GetNextPos() As Single
  GetNextPos = m_GetNextPos
End Property

'Initialize Properties for User Control
Private Sub UserControl_InitProperties()
  m_GetNextPos = m_def_GetNextPos
  m_Simple = m_def_Simple
  m_ButtonsCount = m_def_ButtonsCount
End Sub

'Load property values from storage
Private Sub UserControl_ReadProperties(PropBag As PropertyBag)
  m_GetNextPos = PropBag.ReadProperty("GetNextPos", m_def_GetNextPos)
  m_Simple = PropBag.ReadProperty("Simple", m_def_Simple)
  If m_Simple Then
    imgBG.Stretch = False
    Set imgBG.Picture = LoadPicture
    Set imgBG.Picture = toolImages.ListImages("TOOLBG1").Picture
    imgBG.Stretch = True
  Else
    imgBG.Stretch = False
    Set imgBG.Picture = LoadPicture
    Set imgBG.Picture = toolImages.ListImages("TOOLBG").Picture
    imgBG.Stretch = True
  End If
  m_ButtonsCount = PropBag.ReadProperty("ButtonsCount", m_def_ButtonsCount)
End Sub

'Write property values to storage
Private Sub UserControl_WriteProperties(PropBag As PropertyBag)
  Call PropBag.WriteProperty("GetNextPos", m_GetNextPos, m_def_GetNextPos)
  Call PropBag.WriteProperty("Simple", m_Simple, m_def_Simple)
  Call PropBag.WriteProperty("ButtonsCount", m_ButtonsCount, m_def_ButtonsCount)
End Sub

'WARNING! DO NOT REMOVE OR MODIFY THE FOLLOWING COMMENTED LINES!
'MemberInfo=0,0,0,false
Public Property Get Simple() As Boolean
  Simple = m_Simple
End Property

Public Property Let Simple(ByVal New_Simple As Boolean)
  m_Simple = New_Simple
  If m_Simple Then
    imgBG.Stretch = False
    Set imgBG.Picture = LoadPicture
    Set imgBG.Picture = toolImages.ListImages("TOOLBG1").Picture
    imgBG.Stretch = True
  Else
    imgBG.Stretch = False
    Set imgBG.Picture = LoadPicture
    Set imgBG.Picture = toolImages.ListImages("TOOLBG").Picture
    imgBG.Stretch = True
  End If
  PropertyChanged "Simple"
End Property

Private Sub PressButtonIdx(i As Integer)
  If m_btn(i).State = isUnpressed Then
    Set imgBtn(i).Picture = imgBtn_B(i).Picture
    m_btn(i).State = isPressed
    imgBtn(i).Left = imgBtn(i).Left + Screen.TwipsPerPixelX
    imgBtn(i).Top = imgBtn(i).Top + Screen.TwipsPerPixelY
  End If
  DoEvents
End Sub

'WARNING! DO NOT REMOVE OR MODIFY THE FOLLOWING COMMENTED LINES!
'MemberInfo=14
Public Sub PressButton(sName As String)
  Dim i As Integer
  For i = 1 To m_numButtons
    If m_btn(i).name = sName Then
      If m_btn(i).State = isUnpressed Then
        Set imgBtn(i).Picture = imgBtn_B(i).Picture
        m_btn(i).State = isPressed
        imgBtn(i).Left = imgBtn(i).Left + Screen.TwipsPerPixelX
        imgBtn(i).Top = imgBtn(i).Top + Screen.TwipsPerPixelY
      End If
      Exit For
    End If
  Next i
  RaiseEvent ButtonPressed(sName)
  If Not m_btn(i).TwoState Then
    UnpressButton sName
  End If
End Sub

'WARNING! DO NOT REMOVE OR MODIFY THE FOLLOWING COMMENTED LINES!
'MemberInfo=13
Public Function GetToolTipText(idx As Integer) As String
  GetToolTipText = m_btn(idx).toolTip
End Function

'WARNING! DO NOT REMOVE OR MODIFY THE FOLLOWING COMMENTED LINES!
'MemberInfo=7,1,2,0
Public Property Get ButtonsCount() As Integer
  ButtonsCount = m_numButtons
End Property

[A.A.Z.]

Да, в MouseUp, и при этом убрать его из PressButtonIdx

[timsoft]

круто, только с такой поправкой

Код: Выделить всё

Private Sub imgBtn_MouseUp(Index As Integer, Button As Integer, Shift As Integer, X As Single, Y As Single)
RaiseEvent ButtonPressed(m_btn(Index).name)
If m_btn(Index).State = isPressed And (m_btn(Index).TwoState = False Or Need = True) Then
UnpressButton m_btn(Index).name
Need = False
DoEvents
End If
End Sub


[A.A.Z.]

Да, ты прав Забыл

[timsoft]

Благодаря помощи уважаемого A.A.Z. получилась вторая версия, переработанная и дополненная.

вот тут она и лежит

(теперь придется свои проги перекомпилировать и рассылать юзерам обновления)

[snov]

А почему не проверяется какая нажата кнопка у мыши?