wwbutton.ctl

一个自写的VB按钮控件

   ElseIf (KeyCode = 37) Or (KeyCode = 38) Then 'left and up arrows
       SendKeys "+{Tab}"
   End If
End If
End Sub

Private Sub UserControl_KeyPress(KeyAscii As Integer)
If isEnabled = True Then
   RaiseEvent KeyPress(KeyAscii)
End If
End Sub

Private Sub UserControl_KeyUp(KeyCode As Integer, Shift As Integer)
If isEnabled = True Then
   RaiseEvent KeyUp(KeyCode, Shift)

   If (KeyCode = 32) And (LastKeyDown = 32) Then 'spacebar pressed
       Call UserControl_MouseUp(1, 1, 1, 1)
       LastButton = 1
       Call UserControl_Click
   End If
End If
End Sub

Private Sub UserControl_LostFocus()
hasFocus = False
Call Redraw(lastStat, True)
End Sub


Private Sub UserControl_Click()
   If isEnabled = True Then
      If (LastButton = 1) Then
          lastStat = 0
          'Call Redraw(lastStat, True)                                '####(0, True) 'be sure that the normal status is drawn

      End If
          Call Redraw(lastStat, True)
          UserControl.Refresh
          RaiseEvent Click
    End If
End Sub


Private Sub UserControl_MouseDown(Button As Integer, Shift As Integer, x As Single, y As Single)
If isEnabled = True Then

   'Else
   
      LastButton = Button
      If Button <> 2 Then lastStat = 2                    '####Call Redraw(2, False)
   'End If
   Call Redraw(lastStat, True)
   RaiseEvent MouseDown(Button, Shift, x, y)
End If
End Sub
Private Sub UserControl_MouseUp(Button As Integer, Shift As Integer, x As Single, y As Single)
If isEnabled = True Then

     If Button <> 2 Then lastStat = 0                    '####Call Redraw(0, False)

  Call Redraw(lastStat, True)
  RaiseEvent MouseUp(Button, Shift, x, y)
End If
End Sub

Private Sub UserControl_MouseMove(Button As Integer, Shift As Integer, x As Single, y As Single)
If Button < 2 And isEnabled = True Then
  
    Timer1.Enabled = True
    If x >= 0 And y >= 0 And _
       x <= UserControl.ScaleWidth And y <= UserControl.ScaleHeight Then
       '在按钮内部
        RaiseEvent MouseMove(Button, Shift, x, y)
        If Button = vbLeftButton Then
            Call Redraw(2, False)
            
        Else
             If disyellowrect = True Then
                Exit Sub
             Else
                disyellowrect = True
             End If
             Call Redraw(0, True)
        End If
    End If
  
End If

End Sub

Private Sub UserControl_Resize()
    He = UserControl.ScaleHeight
    Wi = UserControl.ScaleWidth
    Rc.Bottom = He: Rc.Right = Wi
    rc2.Bottom = He: rc2.Right = Wi
    rc3.Left = 2: rc3.Top = 2: rc3.Right = Wi - 2: rc3.Bottom = He - 2
    
    DeleteObject rgnNorm
    Call MakeRegion
    SetWindowRgn UserControl.hWnd, rgnNorm, True
    
    Call Redraw(lastStat, True)                                '####(0, True)
End Sub

Private Sub UserControl_Terminate()
    DeleteObject rgnNorm
End Sub

'按钮重画子程序

Private Sub Redraw(ByVal curStat As Byte, ByVal Force As Boolean)
   Dim I As Long, stepXP1 As Single, XPface As Long
   Dim preFocusValue As Boolean
   Dim lens As Integer
   Dim iunicode As Integer
   Dim ii As Integer, NumLine As Long       'rcText As RECT,
   'Dim pt As POINTAPI
If Force = False Then 'check drawing redundancy
    If (curStat = lastStat) And (TE = m_Caption) Then Exit Sub
End If

If He = 0 Then Exit Sub 'we don't want errors

   lastStat = curStat
   TE = m_Caption
   preFocusValue = hasFocus '保存焦点状态
If hasFocus = True Then hasFocus = ShowFocusRect

With UserControl
     .Cls
     DrawRectangle 0, 0, Wi, He, cFace
     allcount = LenB(StrConv(m_Caption, vbFromUnicode))  '此段为中英文显示判断
     
If isEnabled = True Then
    SetTextColor .hdc, cText 'restore font color
    If curStat = 0 Then
'#@#@#@#@#@# 按钮在正常状态 #@#@#@#@#@#
        
        Select Case MyButtonType

            Case 1 'Windows XP
                 If MyColorType = 2 Or MyColorType = 3 Then
                    stepXP1 = 25 / He
                    XPface = ShiftColor(cFace, &H30, True)
                    For I = 1 To He - 2
                        DrawLine 0, I, Wi, I, ShiftColor(XPface, -stepXP1 * I, True)
                    Next
                  Else
                    Select Case MyXpType
                         Case 1      '银色风格
                              DrawJianBian 198, 197, 215, He - 2, 1, -1 'XP银色效果
                         Case 2               '翠色风格
                              stepXP1 = 25 / He
                              XPface = RGB(242, 237, 218)
                              For I = He - 2 To 1 Step -1
                                  XPface = ShiftColor(XPface, 1, False)
                                  DrawLine 1, I, Wi - 2, I, XPface
                              Next
                         Case 3      '蓝色风格
                               DrawJianBian 236, 235, 230, He - 2, 1, -1   '蓝色风格
                     End Select
                  End If
                  'SetTextColor UserControl.hdc, cText
                  DrawXPFrame &H733C00, &H7B4D10
                If (hasFocus = True) Or ((Ambient.DisplayAsDefault = True) And (showFocusR = True)) Then
                      If disyellowrect = True Then
                           If MyXpType = 2 Then
                              XPface = RGB(228, 144, 80)
                           Else
                              XPface = m_rectcolor
                           End If                                                     '鼠标移入时显示黄色框
                           DrawRectangle 2, 1, Wi - 4, He - 2, XPface, True
                           DrawLine 1, 2, 1, He - 2, XPface
                           DrawLine 3, 2, Wi - 3, 2, XPface
                           DrawLine Wi - 2, 2, Wi - 2, He - 2, XPface
                           DrawLine 3, He - 3, Wi - 3, He - 3, XPface
                      Else
                           Select Case MyXpType
                                  Case 1, 3
                                       DrawRectangle 1, 2, Wi - 2, He - 4, &HE7AE8C, True
                                       DrawLine 2, He - 2, Wi - 2, He - 2, &HEF826B
                                       DrawLine 2, 1, Wi - 2, 1, &HFFE7CE
                                       DrawLine 2, 2, Wi - 2, 2, &HF7D7BD
                                       DrawLine 2, 3, 2, He - 3, &HF0D1B5
                                       DrawLine Wi - 3, 3, Wi - 3, He - 3, &HF0D1B5
                                   Case 2
                                       DrawRectangle 1, 2, Wi - 2, He - 4, &H62B87A, True
                                       DrawLine 2, He - 2, Wi - 2, He - 2, &H62B87A
                                       DrawLine 2, 1, Wi - 2, 1, &H62B87A
                                       DrawLine 2, 2, Wi - 2, 2, &H62B87A
                                       DrawLine 2, 3, 2, He - 3, &H62B87A                           ' FF00&
                                       DrawLine Wi - 3, 3, Wi - 3, He - 3, &H62B87A                 ' &HABF15E
                           End Select
                           DrawFocusR
                      End If
                Else
                     If disyellowrect = True Then
                          If MyXpType = 2 Then                                          '
                             XPface = RGB(228, 144, 80)
                          Else
                             XPface = m_rectcolor '
                          End If                                                        '
                          DrawRectangle 2, 1, Wi - 4, He - 2, XPface, True                '鼠标移入时显示黄色框
                          DrawLine 1, 2, 1, He - 2, XPface                                 '
                          DrawLine 3, 2, Wi - 3, 2, XPface                                 '
                          DrawLine Wi - 2, 2, Wi - 2, He - 2, XPface                      '
                          DrawLine 3, He - 3, Wi - 3, He - 3, XPface                       '
                    
                     End If
                End If
            Case 2 'Mac
                      DrawRectangle 1, 1, Wi - 2, He - 2, cLight
                      DrawLine 2, 0, Wi - 2, 0, cDarkShadow
                      DrawLine 2, He - 1, Wi - 2, He - 1, cDarkShadow
                      DrawLine 0, 2, 0, He - 2, cDarkShadow
                      DrawLine Wi - 1, 2, Wi - 1, He - 2, cDarkShadow
                      mSetPixel 1, 1, cDarkShadow
                      mSetPixel 1, He - 2, cDarkShadow
                      mSetPixel Wi - 2, 1, cDarkShadow
                      mSetPixel Wi - 2, He - 2, cDarkShadow
                      mSetPixel 1, 2, cFace
                      mSetPixel 2, 1, cFace
                      DrawLine 3, 2, Wi - 3, 2, cHighLight
                      DrawLine 2, 2, 2, He - 3, cHighLight
                      mSetPixel 3, 3, cHighLight
                      DrawLine Wi - 3, 1, Wi - 3, He - 3, cFace
                      DrawLine 1, He - 3, Wi - 3, He - 3, cFace
                      mSetPixel Wi - 4, He - 4, cFace
                      DrawLine Wi - 2, 3, Wi - 2, He - 2, cShadow
                      DrawLine 3, He - 2, Wi - 2, He - 2, cShadow
                      mSetPixel Wi - 3, He - 3, cShadow
                      mSetPixel 2, He - 2, cFace
                      mSetPixel 2, He - 3, cLight
                      mSetPixel Wi - 2, 2, cFace
                      mSetPixel Wi - 3, 2, cLight
                If (hasFocus = True) Or ((Ambient.DisplayAsDefault = True) And (showFocusR = True)) Then
                    If disyellowrect = True Then
                       DrawRectangle 2, 1, Wi - 4, He - 2, m_rectcolor, True                ''鼠标移入时显示黄色框
                       DrawLine 1, 2, 1, He - 2, m_rectcolor                                 '
                       DrawLine 3, 2, Wi - 3, 2, m_rectcolor                                 '
                       DrawLine Wi - 2, 2, Wi - 2, He - 2, m_rectcolor                       '
                       DrawLine 3, He - 3, Wi - 3, He - 3, m_rectcolor
                    Else
                       DrawRectangle 1, 2, Wi - 2, He - 4, &HE7AE8C, True
                       DrawLine 2, He - 2, Wi - 2, He - 2, &HEF826B
                       DrawLine 2, 1, Wi - 2, 1, &HFFE7CE
                       DrawLine 1, 2, Wi - 1, 2, &HF7D7BD
                       DrawLine 2, 3, 2, He - 3, &HF0D1B5
                       DrawLine Wi - 3, 3, Wi - 3, He - 3, &HF0D1B5
                    End If
                Else
                     If disyellowrect = True Then
                        DrawRectangle 2, 1, Wi - 4, He - 2, m_rectcolor, True                ''鼠标移入时显示黄色框
                        DrawLine 1, 2, 1, He - 2, m_rectcolor                                 '
                        DrawLine 3, 2, Wi - 3, 2, m_rectcolor                                 '
                        DrawLine Wi - 2, 2, Wi - 2, He - 2, m_rectcolor                       '
                        DrawLine 3, He - 3, Wi - 3, He - 3, m_rectcolor
                    End If
                End If

             Case 3                                         '[Mac OS] = 8

                  If MyColorType = 1 Then
                      DrawMacOS m_MidColor, RGB(183, 183, 183), m_EndColor, m_Percent
                  Else
                      DrawMacOS m_MidColor, RGB(1, 109, 1), m_EndColor, m_Percent
                  End If
                    If disyellowrect = True Then
                          If MyColorType = 1 Then
                             DrawMacOS m_MouseMoveMidColor, RGB(82, 134, 182), m_MouseMoveEndColor, m_Percent
                          Else
                             DrawMacOS m_MouseMoveMidColor, RGB(1, 109, 1), m_MouseMoveEndColor, m_Percent
                          End If
                         
                     End If
                If (hasFocus = True) Or ((Ambient.DisplayAsDefault = True) And (showFocusR = True)) Then
                     DrawFocusR
                End If
                
             Case 4                                               '[Longhorn] = 4
                    If disyellowrect = True Then
                         DrawLonghorn m_MouseMoveMidColor, RGB(81, 107, 148), m_MouseMoveEndColor, m_Percent
                    Else
                         DrawLonghorn m_MidColor, RGB(81, 107, 148), m_EndColor, m_Percent
                    End If
                    If (hasFocus = True) Or ((Ambient.DisplayAsDefault = True) And (showFocusR = True)) Then
                        DrawFocusR
                    End If
             Case 5
                  If disyellowrect = True Then
                     DrawRectangle 0, 0, Wi, He, m_OfficeXpMousemoveFrameColor, True
                     DrawRectangle 1, 1, Wi - 2, He - 2, m_OfficeXpMousemoveFillColor
                  Else
                     DrawRectangle 0, 0, Wi, He, m_OfficeXpFrameColor, True
                     DrawRectangle 1, 1, Wi - 2, He - 2, m_OfficeXpFillColor
                  End If
                  If hasFocus = True Then DrawFocusR
        End Select
        SetTextColor .hdc, cText 'restore font color

        If UserControl.TextWidth(m_Caption) <= Wi Then
           DrawText .hdc, m_Caption, -1, Rc, DT_CENTERABS
        Else
           NumLine = (UserControl.TextWidth(m_Caption) \ Wi) + 1
           Rc.Top = (He - UserControl.TextHeight(m_Caption) * NumLine) \ 2
           DrawText .hdc, m_Caption, -1, Rc, DT_CENTER Or DT_WORDBREAK '
        End If

    ElseIf curStat = 2 Then