rndbutton.ctl

来自「吃豆子游戏的源代码。 嘿嘿」· CTL 代码 · 共 167 行

VERSION 5.00
Begin VB.UserControl RndButton 
   ClientHeight    =   3600
   ClientLeft      =   0
   ClientTop       =   0
   ClientWidth     =   4800
   ScaleHeight     =   240
   ScaleMode       =   3  'Pixel
   ScaleWidth      =   320
   Begin VB.Label ButtonText 
      Alignment       =   2  'Center
      AutoSize        =   -1  'True
      BackStyle       =   0  'Transparent
      Caption         =   "Play"
      BeginProperty Font 
         Name            =   "Comic Sans MS"
         Size            =   27.75
         Charset         =   0
         Weight          =   700
         Underline       =   0   'False
         Italic          =   0   'False
         Strikethrough   =   0   'False
      EndProperty
      Height          =   765
      Left            =   0
      TabIndex        =   0
      Top             =   0
      Width           =   2790
      WordWrap        =   -1  'True
   End
   Begin VB.Image ButtOut 
      Appearance      =   0  'Flat
      Height          =   930
      Left            =   0
      Stretch         =   -1  'True
      Top             =   0
      Visible         =   0   'False
      Width           =   2445
   End
   Begin VB.Image ButtIn 
      Height          =   1140
      Left            =   1650
      Stretch         =   -1  'True
      Top             =   1755
      Visible         =   0   'False
      Width           =   3135
   End
   Begin VB.Image Butt1 
      Height          =   1095
      Left            =   0
      Stretch         =   -1  'True
      Top             =   0
      Width           =   3210
   End
End
Attribute VB_Name = "RndButton"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = True
Attribute VB_PredeclaredId = False
Attribute VB_Exposed = False
'Event Declarations:
Event MouseMove(Button As Integer, Shift As Integer, X As Single, Y As Single) 'MappingInfo=ButtonText,ButtonText,-1,MouseMove
Attribute MouseMove.VB_Description = "Occurs when the user moves the mouse."
Event Click() 'MappingInfo=UserControl,UserControl,-1,Click
Event DblClick() 'MappingInfo=UserControl,UserControl,-1,DblClick
'the button is pressed down
Private Sub Butt1_MouseDown(Button As Integer, Shift As Integer, X As Single, Y As Single)
 Butt1.Picture = ButtIn.Picture
End Sub
'the button is relased
Private Sub Butt1_MouseUp(Button As Integer, Shift As Integer, X As Single, Y As Single)
 Butt1.Picture = ButtOut.Picture
End Sub
'the button has been clicked
Private Sub ButtonText_Click()
 UserControl_Click
End Sub
'the button has been double clicked
Private Sub ButtonText_DblClick()
 UserControl_DblClick
End Sub
'the button is pressed down
Private Sub ButtonText_MouseDown(Button As Integer, Shift As Integer, X As Single, Y As Single)
 Butt1_MouseDown Button, Shift, X, Y
End Sub
'the button is relased
Private Sub ButtonText_MouseUp(Button As Integer, Shift As Integer, X As Single, Y As Single)
 Butt1_MouseUp Button, Shift, X, Y
End Sub
'set the default to button out
Private Sub UserControl_Initialize()
 Butt1.Picture = ButtOut.Picture
End Sub
'set the default to button out
Private Sub UserControl_InitProperties()
 Butt1.Picture = ButtOut.Picture
End Sub
Private Sub UserControl_Resize() ' shape the usercontrol, so it is rounded
  Dim hReg&, R& 'dim some regions
  Butt1.Width = UserControl.ScaleWidth   '\--resize the images for button in and button out
  Butt1.Height = UserControl.ScaleHeight '/
  hReg = CreateEllipticRgn(0, 0, UserControl.ScaleWidth, UserControl.ScaleHeight) ' set the region to elliptical
  R = SetWindowRgn(UserControl.hwnd, hReg, 1) 'set the shape to the region
  hReg = DeleteObject(hReg) 'delete the region
End Sub
'raise the click event
Private Sub UserControl_Click()
    RaiseEvent Click
End Sub
'raise the double click event
Private Sub UserControl_DblClick()
    RaiseEvent DblClick
End Sub
'get the text of the button
Public Property Get Caption() As String
Attribute Caption.VB_Description = "Returns/sets the text displayed in an object's title bar or below an object's icon."
    Caption = ButtonText.Caption
End Property
'set the text of the button
Public Property Let Caption(ByVal New_Caption As String)
    ButtonText.Caption() = New_Caption
    PropertyChanged "Caption"
End Property
'get the font of the text
Public Property Get Font() As Font
Attribute Font.VB_Description = "Returns a Font object."
Attribute Font.VB_UserMemId = -512
    Set Font = ButtonText.Font
End Property
'set the font of the text
Public Property Set Font(ByVal New_Font As Font)
    Set ButtonText.Font = New_Font
    PropertyChanged "Font"
End Property
' get the colour of the text
Public Property Get ForeColor() As OLE_COLOR
Attribute ForeColor.VB_Description = "Returns/sets the foreground color used to display text and graphics in an object."
    ForeColor = ButtonText.ForeColor
End Property
' set the colour of the text
Public Property Let ForeColor(ByVal New_ForeColor As OLE_COLOR)
    ButtonText.ForeColor() = New_ForeColor
    PropertyChanged "ForeColor"
End Property
'Load property values from storage
Private Sub UserControl_ReadProperties(PropBag As PropertyBag)
    ButtonText.Caption = PropBag.ReadProperty("Caption", "Play")
    Set ButtonText.Font = PropBag.ReadProperty("Font", Ambient.Font)
    ButtonText.ForeColor = PropBag.ReadProperty("ForeColor", &H80000012)
End Sub
'Write property values to storage
Private Sub UserControl_WriteProperties(PropBag As PropertyBag)
    Call PropBag.WriteProperty("Caption", ButtonText.Caption, "Play")
    Call PropBag.WriteProperty("Font", ButtonText.Font, Ambient.Font)
    Call PropBag.WriteProperty("ForeColor", ButtonText.ForeColor, &H80000012)
End Sub
'raise the  a mouse move event
Private Sub ButtonText_MouseMove(Button As Integer, Shift As Integer, X As Single, Y As Single)
    RaiseEvent MouseMove(Button, Shift, X, Y)
End Sub
'load the usercontrols pictures
Public Sub LoadUserPic()
 LoadPic ButtIn, "GreenIn", , "usercontrols"
 LoadPic ButtOut, "GreenOut", , "usercontrols"
 Butt1.Picture = ButtOut.Picture 'set the default to button out
End Sub