userctl1.ctl

我大学时候用vb做的物业管理系统

VERSION 5.00
Begin VB.UserControl GurhanCoolButton 
   AutoRedraw      =   -1  'True
   ClientHeight    =   1470
   ClientLeft      =   0
   ClientTop       =   0
   ClientWidth     =   4080
   BeginProperty Font 
      Name            =   "Arial"
      Size            =   12
      Charset         =   162
      Weight          =   400
      Underline       =   0   'False
      Italic          =   0   'False
      Strikethrough   =   0   'False
   EndProperty
   MousePointer    =   99  'Custom
   ScaleHeight     =   1470
   ScaleWidth      =   4080
   ToolboxBitmap   =   "UserCtl1.ctx":0000
   Begin VB.Timer Timer1 
      Enabled         =   0   'False
      Interval        =   1
      Left            =   2760
      Top             =   600
   End
   Begin VB.Image IMAGERESTORE 
      Enabled         =   0   'False
      Height          =   480
      Left            =   1680
      Top             =   120
      Visible         =   0   'False
      Width           =   480
   End
   Begin VB.Image IMAGEMOUSEOVER 
      Enabled         =   0   'False
      Height          =   480
      Left            =   840
      Top             =   120
      Visible         =   0   'False
      Width           =   480
   End
   Begin VB.Image IMAGE_INITIAL 
      Enabled         =   0   'False
      Height          =   480
      Left            =   120
      Top             =   120
      Width           =   480
   End
End
Attribute VB_Name = "GurhanCoolButton"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = True
Attribute VB_PredeclaredId = False
Attribute VB_Exposed = False
'Code by GURHAN KARTAL
'http://gurhankartal.com
'[e-mail]
'
'You can find the brief explanation in the Readme.txt included in the
'zipped file so I will cut it short here. Some of the Sub, function, and
'Type names are in Turkish, hope this won't be a problem for you.
'Not all the code here belongs to me but the idea of creating this
'code belongs to me. I benefited from Mr.Klaus H. Probst regarding the
'DrawEdge API.
'
'You can use it in your projects but can not sell any part of this work.
'
'Hope you'll enjoy....and Don't forget to send me feedback  :)


Option Explicit
Private Declare Function DRAWTHETEXT Lib "gdi32" Alias "TextOutA" (ByVal hdc As Long, ByVal X As Long, ByVal Y As Long, ByVal lpString As String, ByVal nCount As Long) As Long
Private Declare Function GETTEXTDIM Lib "gdi32" Alias "GetTextExtentPoint32A" (ByVal hdc As Long, ByVal lpsz As String, ByVal cbString As Long, lpSize As BOYUT) As Long
Private Type BOYUT
    BOYUT_X As Long
    BOYUT_Y As Long
End Type
Private TEXT_LEFT As Long
Private TEXT_TOP As Long
Dim TAMUSTUNDE As Boolean
Dim BASILMISDURUMDA As Boolean
Dim imgCurr_Left_Pos, imgCurr_Top_Pos As Double
Const m_def_UseBorders = 1
Private Const defKAPSIYON = "GurhanButton"
Dim m_UseBorders As Boolean
Dim m_KAPSIYON As String
Private Const sKAPSIYONE = "CaptionTitle"
Event CLICKED() 'MappingInfo=UserControl,UserControl,-1,MouseUp
Event OnMouseLeave()
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."
Event MouseDown(Button As Integer, Shift As Integer, X As Single, Y As Single) 'MappingInfo=UserControl,UserControl,-1,MouseDown
Attribute MouseDown.VB_Description = "Occurs when the user presses the mouse button while an object has the focus."
Event MouseUp(Button As Integer, Shift As Integer, X As Single, Y As Single) 'MappingInfo=UserControl,UserControl,-1,MouseUp
Attribute MouseUp.VB_Description = "Occurs when the user releases the mouse button while an object has the focus."
'Default Property Values:
Const m_def_ButtonTextColor = 0
'Property Variables:
Dim m_ButtonTextColor As OLE_COLOR


Private Sub Timer1_Timer()
    GetCursorPos Pnt
    ScreenToClient hWnd, Pnt
    ' Are we still hovering?
    If Pnt.X < UserControl.ScaleLeft Or _
        Pnt.Y < UserControl.ScaleTop Or _
            Pnt.X > UserControl.ScaleLeft + UserControl.Width / 15 Or _
            Pnt.Y > UserControl.ScaleTop + UserControl.Height / 15 Then
            TAMUSTUNDE = False
            IMAGE_INITIAL.Picture = IMAGERESTORE.Picture
            'Raise the mouse leave Event Because we are outta control :)
            RaiseEvent OnMouseLeave
            UserControl_Resize
             Timer1.Enabled = False
    End If
End Sub
Public Sub SUANKI_IMAGE_POZISYONU() 'Find Image's current left and top
imgCurr_Left_Pos = IMAGE_INITIAL.Left
imgCurr_Top_Pos = IMAGE_INITIAL.Top
End Sub

Private Sub UserControl_MouseDown(Button As Integer, Shift As Integer, X As Single, Y As Single)
If Button = vbLeftButton Then 'Normally, the regular Commandbuttons are pressed
'                               when the left button is pressed. This is what
'                               we are doing here: Display the pressed image of the
'                               button when the left mouse button is pressed.
SUANKI_IMAGE_POZISYONU 'Find out the image's currrent position because we are
'                       gonna use it in the 'BASILI' sub when moving the image.
BASILI
BASILMISDURUMDA = True
DRAWDOWN
End If
RaiseEvent MouseDown(Button, Shift, X, Y)
End Sub
Private Sub BASILI()
UserControl.Cls
Call DRAWTHETEXT(UserControl.hdc, TEXT_LEFT + 1, TEXT_TOP + 1, CaptionTitle, Len(CaptionTitle))
IMAGE_INITIAL.Move imgCurr_Left_Pos + 15, imgCurr_Top_Pos + 15
End Sub
Private Sub UserControl_MouseMove(Button As Integer, Shift As Integer, X As Single, Y As Single)
GetCursorPos Pnt
ScreenToClient hWnd, Pnt
'If already pressed and mouse is not over the control then
'we need to exit sub. Otherwise the button flickers
     If Pnt.X < UserControl.ScaleLeft Or Pnt.Y < UserControl.ScaleTop Or _
       Pnt.X > UserControl.ScaleLeft + UserControl.Width / 15 Or _
       Pnt.Y > UserControl.ScaleTop + UserControl.Height / 15 _
    Then Exit Sub
'If pressed and over the button then we are safe to continue
   If TAMUSTUNDE Then Exit Sub 'We are already over the button...so exit
    TAMUSTUNDE = True
If IMAGEMOUSEOVER.Picture <> 0 Then
      IMAGE_INITIAL.Picture = IMAGEMOUSEOVER.Picture 'Is the 2nd image smaller?
      IMAGE_INITIAL.Move 45, (UserControl.Height / 2) - IMAGE_INITIAL.Height / 2
      UserControl_Resize
End If
If BASILMISDURUMDA = True Then 'If pressed then
             BASILI
             DRAWDOWN
Else 'If not pressed then
          DRAWUP
End If
 Timer1.Enabled = True
 'Ok mouse is not pressed and we are over the button
RaiseEvent MouseMove(Button, Shift, X, Y)
End Sub
Private Sub UserControl_MouseUp(Button As Integer, Shift As Integer, X As Single, Y As Single)
GetCursorPos Pnt
ScreenToClient hWnd, Pnt
'If pressed AND the mouse is not over the buton then do NOT draw up!
'Where is the mouse pointer?
If Pnt.X < UserControl.ScaleLeft Or _
    Pnt.Y < UserControl.ScaleTop Or _
        Pnt.X > UserControl.ScaleLeft + UserControl.Width / 15 Or _
        Pnt.Y > UserControl.ScaleTop + UserControl.Height / 15 Then
        BASILMISDURUMDA = False
        Exit Sub
End If
BASILMISDURUMDA = False
If TAMUSTUNDE = False Then Exit Sub
If Button = vbLeftButton Then
 UserControl_Resize 'raise
 DRAWUP 'we are over the button and mouse is up so raise the button
 RaiseEvent CLICKED
End If
RaiseEvent MouseUp(Button, Shift, X, Y)
End Sub
'WARNING! DO NOT REMOVE OR MODIFY THE FOLLOWING COMMENTED LINES!
'MemberInfo=13,0,0,GurhanButton
Public Property Get CaptionTitle() As String
    CaptionTitle = m_KAPSIYON
End Property
Public Property Let CaptionTitle(ByVal New_KAPSIYON As String)
    m_KAPSIYON = New_KAPSIYON
    PropertyChanged sKAPSIYONE
    UserControl_Resize
End Property