button.ctl

这是一个教育系统的源码许多人都是从写这种学生管理系统而进入编程界的,所以我觉得初学者应该多学习一下本源码的语法,与设计思想,感谢为中国软件业贡献的人们!

VERSION 5.00
Begin VB.UserControl Button 
   AutoRedraw      =   -1  'True
   BackColor       =   &H0000C0C0&
   ClientHeight    =   1080
   ClientLeft      =   0
   ClientTop       =   0
   ClientWidth     =   2220
   BeginProperty Font 
      Name            =   "MS Sans Serif"
      Size            =   12
      Charset         =   0
      Weight          =   700
      Underline       =   0   'False
      Italic          =   0   'False
      Strikethrough   =   0   'False
   EndProperty
   ForeColor       =   &H000000FF&
   MouseIcon       =   "Button.ctx":0000
   MousePointer    =   99  'Custom
   PaletteMode     =   0  'Halftone
   PropertyPages   =   "Button.ctx":030A
   ScaleHeight     =   72
   ScaleMode       =   3  'Pixel
   ScaleWidth      =   148
   ToolboxBitmap   =   "Button.ctx":033D
End
Attribute VB_Name = "Button"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = True
Attribute VB_PredeclaredId = False
Attribute VB_Exposed = False
Private Declare Function CreateRoundRectRgn Lib "gdi32" (ByVal X1 As Long, ByVal Y1 As Long, ByVal X2 As Long, ByVal Y2 As Long, ByVal X3 As Long, ByVal Y3 As Long) As Long
Private Declare Function SetWindowRgn Lib "user32" (ByVal hWnd As Long, ByVal hRgn As Long, ByVal bRedraw As Boolean) As Long
Private Declare Function PaintRgn Lib "gdi32" (ByVal hdc As Long, ByVal hRgn As Long) As Long
Private Declare Function CreateEllipticRgn Lib "gdi32" (ByVal X1 As Long, ByVal Y1 As Long, ByVal X2 As Long, ByVal Y2 As Long) As Long
Private Type POINTAPI
        X As Long
        Y As Long
End Type
Dim hRgn As Long, pt As POINTAPI
Private Declare Function DeleteObject Lib "gdi32" (ByVal hObject As Long) As Long
Private Declare Function Ellipse Lib "gdi32" (ByVal hdc As Long, ByVal X1 As Long, ByVal Y1 As Long, ByVal X2 As Long, ByVal Y2 As Long) As Long
Dim X1, Y1, X2, Y2
Dim BCaption As String
'Event Declarations:
Event Click() 'MappingInfo=UserControl,UserControl,-1,Click
Attribute Click.VB_Description = "Occurs when the user presses and then releases a mouse button over an object."
Event MouseMove(Button As Integer, Shift As Integer, X As Single, Y As Single) 'MappingInfo=UserControl,UserControl,-1,MouseMove
Attribute MouseMove.VB_Description = "Occurs when the user moves the mouse."
'Default Property Values:
Const m_def_TextColor = 255
Const m_def_Caption = "Button"
'Property Variables:
Dim m_TextColor As OLE_COLOR
Dim m_Caption As String
Dim FColor As Long


Private Sub UserControl_Initialize()
X1 = 1
Y1 = 1
X2 = UserControl.ScaleWidth - 1
Y2 = UserControl.ScaleHeight - 1
hRgn = CreateEllipticRgn(X1, Y1, X2, Y2)
SetWindowRgn UserControl.hWnd, hRgn, 0
BCaption = m_Caption
'Usercontrol.Font.Name = "Arial Black"
'UserControl.Font.Size = 10
'UserControl.FontBold = True
DrawUserControl 1, m_TextColor
UserControl.Refresh
'hRgn = CreateRoundRectRgn(x1, y1, x2, y2, x2 / 2, y2 / 2)
End Sub

Private Sub UserControl_KeyDown(KeyCode As Integer, Shift As Integer)
If KeyCode = vbKeySpace Or KeyCode = vbKeyReturn Then
    UserControl_MouseDown 1, 0, 1, 1
End If
End Sub
Private Sub UserControl_KeyUp(KeyCode As Integer, Shift As Integer)
If KeyCode = vbKeySpace Or KeyCode = vbKeyReturn Then
    Usercontrol_MouseUp 1, 0, 1, 1
    RaiseEvent Click
End If
End Sub

Private Sub Usercontrol_GotFocus()
Dim T As Long
T = UserControl.ForeColor

UserControl.DrawMode = vbXorPen
UserControl.DrawWidth = 2
UserControl.ForeColor = m_TextColor
Ellipse UserControl.hdc, X1 + 1, Y1 + 1, X2 - 1, Y2 - 1
'Ellipse Usercontrol.hdc, X1 + 1, Y1 + 1, X2 - 1, Y2 - 1
UserControl.Refresh
UserControl.DrawMode = vbCopyPen
'Debug.Print "Got Focus"

 UserControl.ForeColor = T

End Sub

Private Sub Usercontrol_LostFocus()
Dim T As Long
T = UserControl.ForeColor

UserControl.DrawMode = vbXorPen
UserControl.DrawWidth = 2
'Usercontrol.ForeColor = vbMagenta
UserControl.ForeColor = m_TextColor
Ellipse UserControl.hdc, X1 + 1, Y1 + 1, X2 - 1, Y2 - 1
'Ellipse Usercontrol.hdc, X1 + 1, Y1 + 1, X2 - 1, Y2 - 1
UserControl.Refresh
UserControl.DrawMode = vbCopyPen
'Debug.Print "Lost Focus"
UserControl.ForeColor = T
End Sub


Private Sub UserControl_MouseDown(Button1 As Integer, Shift As Integer, X As Single, Y As Single)
If Button1 = 1 Then
    Bpress = 1
    DrawUserControl 0, ForeColor
End If

End Sub

Private Sub Usercontrol_MouseMove(Button1 As Integer, Shift As Integer, X As Single, Y As Single)
    RaiseEvent MouseMove(Button1, Shift, X, Y)
    'If Button1 = 0 Then DrawUserControl 2, vbRed: UserControl.Refresh
End Sub
'Private Sub Form_MouseMove(Button1 As Integer, Shift As Integer, X As Single, Y As Single)
'    If UserControl.ForeColor <> vbBlack Then DrawUserControl 2, vbBlack
'End Sub

Private Sub Usercontrol_MouseUp(Button1 As Integer, Shift As Integer, X As Single, Y As Single)
If Button1 = 1 Then
    DrawUserControl 1, ForeColor
End If
End Sub

Private Sub DrawUserControl(ByVal n As Integer, ByVal n1 As Long)
Dim s1 As Integer
Dim T As Long
T = UserControl.ForeColor
UserControl.DrawWidth = 1
With UserControl
If n = 1 Then
    
        '.DrawMode = vbCopyPen
        j = 3
        st = (255 / (X2 / 2))
        sy = (Y2 / (X2))
        s1 = 100
        s2 = s1
        For i = 3 To (X2 / 2) Step 1
            s1 = s1 + st
            s2 = IIf(s2 < s1, s1, s2)
            j = j + sy
            UserControl.ForeColor = RGB(s1 + 30, Abs(s1), 0)
            Ellipse UserControl.hdc, X1 + i, Y1 + j, X2 - i, Y2 - j
        Next
ElseIf n = 0 Then
        '.DrawMode = vbCopyPen
        j = 3
        st = (150 / (X2 / 2))
        sy = (Y2 / (X2))
        's1 = 200
        s1 = 150
        s2 = s1
        
        For i = 3 To (X2 / 2) Step 1
            s1 = s1 - st
            's2 = IIf(s2 < s1, s1, s2)
            j = j + sy
            UserControl.ForeColor = RGB(s1 + 30, Abs(s1), 0)
            Ellipse UserControl.hdc, X1 + i, Y1 + j, X2 - i, Y2 - j
        Next
    
End If
        .DrawMode = vbCopyPen
         tx = .TextWidth(m_Caption)
         th = .TextHeight(m_Caption)
        .CurrentX = (.ScaleWidth / 2) - (tx / 2) + IIf(n = 0, 2, 0)
        .CurrentY = (.ScaleHeight / 2) - (th / 2) + IIf(n = 0, 2, 0)
        '.FontSize = (IIf(n < 1, .FontSize - 1, .FontSize))
        .ForeColor = m_TextColor
        UserControl.Print m_Caption
         'Caption = s2
       ' .FontSize = (IIf(n < 1, .FontSize + 1, .FontSize))
End With
UserControl.ForeColor = T
End Sub

Private Sub UserControl_Resize()
X1 = 1
Y1 = 1
If UserControl.Width < 133 * 15 Then UserControl.Width = 133 * 15
If UserControl.Height < 60 * 15 Then UserControl.Height = 60 * 15

'UserControl.BackColor = vbYellow
X2 = UserControl.ScaleWidth - 2
Y2 = UserControl.ScaleHeight - 2
hRgn = CreateEllipticRgn(X1, Y1, X2, Y2)
SetWindowRgn UserControl.hWnd, hRgn, 1
BCaption = m_Caption
'Usercontrol.Font.Name = "Arial Black"
'UserControl.Font.Size = 10
'UserControl.FontBold = True
UserControl.Cls
DrawUserControl 1, ForeColor
UserControl.Refresh
'hRgn = CreateRoundRectRgn(x1, y1, x2, y2, x2 / 2, y2 / 2)
End Sub

Private Sub UserControl_Terminate()
DeleteObject hRgn
End Sub
'WARNING! DO NOT REMOVE OR MODIFY THE FOLLOWING COMMENTED LINES!
'MappingInfo=UserControl,UserControl,-1,BackColor
Public Property Get BackColor() As OLE_COLOR
Attribute BackColor.VB_Description = "Returns/sets the background color used to display text and graphics in an object."
    BackColor = UserControl.BackColor
End Property