command.ctl

vb源码之家界面源码,非常详细的说明和代码

        
        ' Bottom left corner.
        PSet (1, .ScaleHeight - 3), FourthCornerPixelX
        PSet (2, .ScaleHeight - 2), FourthCornerPixelX
        
        ' Bottom right corner.
        PSet (.ScaleWidth - 3, .ScaleHeight - 2), FourthCornerPixelX
        PSet (.ScaleWidth - 2, .ScaleHeight - 3), FourthCornerPixelX
        
        ' Top right corner.
        PSet (.ScaleWidth - 3, 1), FourthCornerPixelX
        PSet (.ScaleWidth - 2, 2), FourthCornerPixelX
    End With
    '------------------------------------------------
    Exit Sub
    '----------------
ToExit:
    Resume Next
End Sub

Private Sub DrawIdle()
    On Error GoTo ToExit '打开错误陷阱
    '------------------------------------------------
    Dim Gradient As New Collection, X As Long
    
    With UserControl
    ' Draws border lines (not corners)
        Line (3, 0)-(.ScaleWidth - 3, 0), BorderColorLines
        Line (0, 3)-(0, .ScaleHeight - 3), BorderColorLines
        Line (3, .ScaleHeight - 1)-(.ScaleWidth - 3, .ScaleHeight - 1), BorderColorLines
        Line (.ScaleWidth - 1, 3)-(.ScaleWidth - 1, .ScaleHeight - 3), BorderColorLines
    
    ' Draws the fade at the bottom
        Line (1, .ScaleHeight - 4)-(.ScaleWidth - 1, .ScaleHeight - 4), FirstBottomLine
        Line (2, .ScaleHeight - 3)-(.ScaleWidth - 2, .ScaleHeight - 3), SecondBottomLine
        Line (3, ScaleHeight - 2)-(.ScaleWidth - 3, .ScaleHeight - 2), ThirdBottomLine
        
    ' Draws the background gradient
        Set Gradient = CreateFade(FromColorFade, ToColorFade, .ScaleHeight - 5)
        
        For X = 1 To Gradient.Count
            Select Case X
                Case 1
                    Line (3, X + 1)-(.ScaleWidth - 4, X + 1), Gradient(X)
                Case 2
                    Line (2, X + 1)-(.ScaleWidth - 3, X + 1), Gradient(X)
                Case Else
                    Line (1, X + 1)-(.ScaleWidth - 2, X + 1), Gradient(X)
            End Select
        Next
        
    ' Draws corners
    ' First set of pixels
        ' Upper Left Corner
        PSet (2, 0), FirstCornerPixel
        PSet (0, 2), FirstCornerPixel
        
        ' Bottom left corner
        PSet (0, .ScaleHeight - 3), FirstCornerPixel
        PSet (2, .ScaleHeight - 1), FirstCornerPixel
        
        ' Top right corner
        PSet (.ScaleWidth - 1, 2), FirstCornerPixel
        PSet (.ScaleWidth - 3, 0), FirstCornerPixel
        
        ' Bottom right corner
        PSet (.ScaleWidth - 3, .ScaleHeight - 1), FirstCornerPixel
        PSet (.ScaleWidth - 1, .ScaleHeight - 3), FirstCornerPixel
        
    ' Second set of pixels
        ' Upper Left Corner
        PSet (1, 0), SecondCornerPixel
        PSet (0, 1), SecondCornerPixel
        
        ' Bottom left corner
        PSet (0, .ScaleHeight - 2), SecondCornerPixel
        PSet (1, .ScaleHeight - 1), SecondCornerPixel
        
        ' Top right corner
        PSet (.ScaleWidth - 1, 1), SecondCornerPixel
        PSet (.ScaleWidth - 2, 0), SecondCornerPixel
        
        ' Bottom right corner
        PSet (.ScaleWidth - 2, .ScaleHeight - 1), SecondCornerPixel
        PSet (.ScaleWidth - 1, .ScaleHeight - 2), SecondCornerPixel
    
    ' Third set of pixels
        PSet (1, 1), ThirdCornerPixel
        PSet (1, .ScaleHeight - 2), ThirdCornerPixel
        PSet (.ScaleWidth - 2, 1), ThirdCornerPixel
        PSet (.ScaleWidth - 2, .ScaleHeight - 2), ThirdCornerPixel
    
    ' Fourth set of pixels
        ' Upper left corner
        PSet (2, 1), FourthCornerPixel
        PSet (1, 2), FourthCornerPixel
        
        ' Bottom left corner
        PSet (1, .ScaleHeight - 3), FourthCornerPixel
        PSet (2, .ScaleHeight - 2), FourthCornerPixel
        
        ' Bottom right corner
        PSet (.ScaleWidth - 3, .ScaleHeight - 2), FourthCornerPixel
        PSet (.ScaleWidth - 2, .ScaleHeight - 3), FourthCornerPixel
        
        ' Top right corner
        PSet (.ScaleWidth - 3, 1), FourthCornerPixel
        PSet (.ScaleWidth - 2, 2), FourthCornerPixel
    End With
    '------------------------------------------------
    Exit Sub
    '----------------
ToExit:
    Resume Next
End Sub

Private Sub DrawHot()
    On Error GoTo ToExit '打开错误陷阱
    '------------------------------------------------
    Dim Gradient As New Collection, X As Long

    With UserControl
    ' Draws border lines (not corners)
        Line (3, 0)-(.ScaleWidth - 3, 0), BorderColorLinesH
        Line (0, 3)-(0, .ScaleHeight - 3), BorderColorLinesH
        Line (3, .ScaleHeight - 1)-(.ScaleWidth - 3, .ScaleHeight - 1), BorderColorLinesH
        Line (.ScaleWidth - 1, 3)-(.ScaleWidth - 1, .ScaleHeight - 3), BorderColorLinesH
    
    ' Draws the fade at the bottom
        Line (1, .ScaleHeight - 4)-(.ScaleWidth - 1, .ScaleHeight - 4), FirstBottomLineH
        Line (2, .ScaleHeight - 3)-(.ScaleWidth - 2, .ScaleHeight - 3), SecondBottomLineH
        Line (3, ScaleHeight - 2)-(.ScaleWidth - 3, .ScaleHeight - 2), ThirdBottomLineH
        
    'Draws the background gradient
        Set Gradient = CreateFade(FromColorFadeH, ToColorFadeH, .ScaleHeight - 5)
        
        For X = 1 To Gradient.Count
            Select Case X
                Case 1
                    Line (3, X + 1)-(.ScaleWidth - 4, X + 1), FirstTopLineH
                Case 2
                    Line (2, X + 1)-(.ScaleWidth - 3, X + 1), SecondTopLineH
                Case Else
                    Line (1, X + 1)-(.ScaleWidth - 2, X + 1), Gradient(X)
            End Select
        Next

    ' Draws side gradients
        Set Gradient = CreateFade(SideFromColorFadeH, SideToColorFadeH, .ScaleHeight - 7)
        
        For X = 1 To Gradient.Count
            PSet (1, X + 3), Gradient(X)
            PSet (2, X + 3), Gradient(X)
            
            PSet (.ScaleWidth - 2, X + 3), Gradient(X)
            PSet (.ScaleWidth - 3, X + 3), Gradient(X)
        Next
        
    ' Draws corners
    ' First set of pixels
        ' Upper Left Corner
        PSet (2, 0), FirstCornerPixelH
        PSet (0, 2), FirstCornerPixelH
        
        ' Bottom left corner
        PSet (0, .ScaleHeight - 3), FirstCornerPixelH
        PSet (2, .ScaleHeight - 1), FirstCornerPixelH
        
        ' Top right corner
        PSet (.ScaleWidth - 1, 2), FirstCornerPixelH
        PSet (.ScaleWidth - 3, 0), FirstCornerPixelH
        
        ' Bottom right corner
        PSet (.ScaleWidth - 3, .ScaleHeight - 1), FirstCornerPixelH
        PSet (.ScaleWidth - 1, .ScaleHeight - 3), FirstCornerPixelH
        
    ' Second set of pixels
        ' Upper Left Corner
        PSet (1, 0), SecondCornerPixelH
        PSet (0, 1), SecondCornerPixelH
        
        ' Bottom left corner
        PSet (0, .ScaleHeight - 2), SecondCornerPixelH
        PSet (1, .ScaleHeight - 1), SecondCornerPixelH
        
        ' Top right corner
        PSet (.ScaleWidth - 1, 1), SecondCornerPixelH
        PSet (.ScaleWidth - 2, 0), SecondCornerPixelH
        
        ' Bottom right corner
        PSet (.ScaleWidth - 2, .ScaleHeight - 1), SecondCornerPixelH
        PSet (.ScaleWidth - 1, .ScaleHeight - 2), SecondCornerPixelH
    
    ' Third set of pixels
        PSet (1, 1), ThirdCornerPixelH
        PSet (1, .ScaleHeight - 2), ThirdCornerPixelH
        PSet (.ScaleWidth - 2, 1), ThirdCornerPixelH
        PSet (.ScaleWidth - 2, .ScaleHeight - 2), ThirdCornerPixelH
    
    ' Fourth set of pixels
        ' Upper left corner
        PSet (2, 1), FourthCornerPixelH
        PSet (1, 2), FourthCornerPixelH
        
        ' Bottom left corner
        PSet (1, .ScaleHeight - 3), FourthCornerPixelH
        PSet (2, .ScaleHeight - 2), FourthCornerPixelH
        
        ' Bottom right corner
        PSet (.ScaleWidth - 3, .ScaleHeight - 2), FourthCornerPixelH
        PSet (.ScaleWidth - 2, .ScaleHeight - 3), FourthCornerPixelH
        
        ' Top right corner
        PSet (.ScaleWidth - 3, 1), FourthCornerPixelH
        PSet (.ScaleWidth - 2, 2), FourthCornerPixelH
    End With
    '------------------------------------------------
    Exit Sub
    '----------------
ToExit:
    Resume Next
End Sub

Private Sub UserControl_DblClick()
    If PropEnabled = False Then
        Exit Sub
    End If
    RaiseEvent DblClick
End Sub

Private Sub UserControl_EnterFocus()
    HasFocus = True
    Redraw
End Sub

Private Sub UserControl_ExitFocus()
    HasFocus = False
    Redraw
End Sub

Private Sub UserControl_InitProperties()
    Caption = Ambient.DisplayName
    Set Font = UserControl.Parent.Font
    Enabled = True
    ForeColor = vbBlack
End Sub

Private Sub UserControl_MouseDown(Button As Integer, Shift As Integer, X As Single, Y As Single)
    MouseDown = True
    Redraw
    RaiseEvent MouseDown(Button, Shift, X, Y)
End Sub

Private Sub UserControl_MouseMove(Button As Integer, Shift As Integer, X As Single, Y As Single)
    Dim DrawIt As Boolean
    
    SetCapture UserControl.hwnd
    
    If X < 0 Or X > UserControl.ScaleWidth Or Y < 0 Or Y > UserControl.ScaleHeight Then
        ReleaseCapture
        MouseOver = False
        MouseDown = False
        Redraw
    Else
        If MouseOver = False Then DrawIt = True
        MouseOver = True
        If DrawIt = True Then Redraw
    End If
    
    RaiseEvent MouseMove(Button, Shift, X, Y)
End Sub

Private Sub UserControl_MouseUp(Button As Integer, Shift As Integer, X As Single, Y As Single)
    If PropEnabled = False Then
        Exit Sub
    End If
    RaiseEvent Click
    MouseDown = False
    Redraw
    RaiseEvent MouseUp(Button, Shift, X, Y)
End Sub

Private Sub UserControl_ReadProperties(PropBag As PropertyBag)
    Caption = PropBag.ReadProperty("Caption", Ambient.DisplayName)
    Set Font = PropBag.ReadProperty("Font", UserControl.Parent.Font)
    Enabled = PropBag.ReadProperty("Enabled", True)
    ForeColor = PropBag.ReadProperty("ForeColor", vbBlack)
    mDotBackColor = PropBag.ReadProperty("DotBackColor", vbBlack)
End Sub

Private Sub UserControl_Resize()
    Redraw
End Sub

Private Sub UserControl_WriteProperties(PropBag As PropertyBag)
    PropBag.WriteProperty "Caption", PropCaption, Ambient.DisplayName
    PropBag.WriteProperty "Font", UserControl.Font, UserControl.Parent.Font
    PropBag.WriteProperty "Enabled", PropEnabled, True
    PropBag.WriteProperty "ForeColor", PropForeColor, vbBlack
    PropBag.WriteProperty "DotBackColor", mDotBackColor, vbBlack
End Sub