mon_advanced_checkbox.ctl

一款另类的彩色图形复选框控件源代码(CheckBox2009) (v3)

VERSION 5.00
Begin VB.UserControl mm_checkbox 
   AutoRedraw      =   -1  'True
   BackColor       =   &H00FFFFFF&
   ClientHeight    =   1110
   ClientLeft      =   0
   ClientTop       =   0
   ClientWidth     =   2055
   ClipBehavior    =   0  '无
   BeginProperty Font 
      Name            =   "Tahoma"
      Size            =   8.25
      Charset         =   0
      Weight          =   400
      Underline       =   0   'False
      Italic          =   0   'False
      Strikethrough   =   0   'False
   EndProperty
   KeyPreview      =   -1  'True
   ScaleHeight     =   74
   ScaleMode       =   3  'Pixel
   ScaleWidth      =   137
   ToolboxBitmap   =   "mon_advanced_checkbox.ctx":0000
   Begin VB.PictureBox pic_des_small_uncheck_avec_caption 
      AutoRedraw      =   -1  'True
      AutoSize        =   -1  'True
      BorderStyle     =   0  'None
      Height          =   225
      Left            =   1530
      Picture         =   "mon_advanced_checkbox.ctx":0312
      ScaleHeight     =   225
      ScaleWidth      =   375
      TabIndex        =   5
      Top             =   1815
      Width           =   375
   End
   Begin VB.PictureBox pic_des_small_check_avec_caption 
      AutoRedraw      =   -1  'True
      AutoSize        =   -1  'True
      BorderStyle     =   0  'None
      Height          =   225
      Left            =   1035
      Picture         =   "mon_advanced_checkbox.ctx":07C8
      ScaleHeight     =   225
      ScaleWidth      =   375
      TabIndex        =   4
      Top             =   1800
      Width           =   375
   End
   Begin VB.PictureBox picarcsmall 
      AutoRedraw      =   -1  'True
      AutoSize        =   -1  'True
      BorderStyle     =   0  'None
      Height          =   225
      Left            =   630
      Picture         =   "mon_advanced_checkbox.ctx":0C7E
      ScaleHeight     =   225
      ScaleWidth      =   45
      TabIndex        =   3
      Top             =   720
      Visible         =   0   'False
      Width           =   45
   End
   Begin VB.PictureBox picarc 
      AutoRedraw      =   -1  'True
      AutoSize        =   -1  'True
      BorderStyle     =   0  'None
      Height          =   435
      Left            =   1530
      Picture         =   "mon_advanced_checkbox.ctx":0D74
      ScaleHeight     =   435
      ScaleWidth      =   105
      TabIndex        =   2
      Top             =   180
      Visible         =   0   'False
      Width           =   105
   End
   Begin VB.PictureBox picbig 
      Appearance      =   0  'Flat
      AutoRedraw      =   -1  'True
      AutoSize        =   -1  'True
      BackColor       =   &H80000005&
      BorderStyle     =   0  'None
      ForeColor       =   &H80000008&
      Height          =   435
      Left            =   780
      Picture         =   "mon_advanced_checkbox.ctx":106E
      ScaleHeight     =   435
      ScaleWidth      =   720
      TabIndex        =   1
      Top             =   180
      Visible         =   0   'False
      Width           =   720
   End
   Begin VB.PictureBox picsmall 
      Appearance      =   0  'Flat
      AutoRedraw      =   -1  'True
      AutoSize        =   -1  'True
      BackColor       =   &H80000005&
      BorderStyle     =   0  'None
      ForeColor       =   &H80000008&
      Height          =   225
      Left            =   225
      Picture         =   "mon_advanced_checkbox.ctx":2100
      ScaleHeight     =   225
      ScaleWidth      =   345
      TabIndex        =   0
      Top             =   750
      Visible         =   0   'False
      Width           =   345
   End
   Begin VB.Image pic_des_big_check_avec_caption 
      Height          =   435
      Left            =   120
      Picture         =   "mon_advanced_checkbox.ctx":257A
      Top             =   2730
      Width           =   780
   End
   Begin VB.Image pic_des_big_uncheck_avec_caption 
      Height          =   435
      Left            =   945
      Picture         =   "mon_advanced_checkbox.ctx":3768
      Top             =   2745
      Width           =   780
   End
   Begin VB.Image pic_des_small_check 
      Height          =   225
      Left            =   210
      Picture         =   "mon_advanced_checkbox.ctx":4956
      Top             =   1785
      Width           =   345
   End
   Begin VB.Image pic_des_small_uncheck 
      Height          =   225
      Left            =   600
      Picture         =   "mon_advanced_checkbox.ctx":4DD0
      Top             =   1800
      Width           =   345
   End
   Begin VB.Image pic_des_big_uncheck 
      Height          =   435
      Left            =   915
      Picture         =   "mon_advanced_checkbox.ctx":524A
      Top             =   2130
      Width           =   720
   End
   Begin VB.Image pic_des_big_check 
      Height          =   435
      Left            =   135
      Picture         =   "mon_advanced_checkbox.ctx":62DC
      Top             =   2115
      Width           =   720
   End
End
Attribute VB_Name = "mm_checkbox"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = True
Attribute VB_PredeclaredId = False
Attribute VB_Exposed = True
Attribute VB_Ext_KEY = "PropPageWizardRun" ,"Yes"
'****************************************************************************
'人人为我，我为人人
'枕善居汉化收藏整理
'发布日期：2009/04/18
'描    述：彩色图形复选框(CheckBox2009) (v3)
'网    站：http://www.Mndsoft.com/  (VB6源码博客)
'网    站：http://www.VbDnet.com/   (VB.NET源码博客,主要基于.NET2005)
'e-mail  ：[e-mail]
'e-mail  ：[e-mail]
'OICQ    ：88382850
'          如果您有新的好的代码别忘记给枕善居哦!
'****************************************************************************
'
Option Explicit

'EVENTS.
Public Event Click()
Public Event DoubleClick()
Public Event KeyDown(KeyCode As Integer, Shift As Integer)
Public Event KeyPress(KeyAscii As Integer)
Public Event KeyUp(KeyCode As Integer, Shift As Integer)
Public Event MouseDown(Button As Integer, Shift As Integer, X As Single, Y As Single)
Public Event MouseMove(Button As Integer, Shift As Integer, X As Single, Y As Single)
Public Event MouseUp(Button As Integer, Shift As Integer, X As Single, Y As Single)
Public Event MouseEnters(ByVal X As Long, ByVal Y As Long)
Public Event MouseLeaves(ByVal X As Long, ByVal Y As Long)


Private udtPoint As POINTAPI
Private bolMouseDown As Boolean
Private bolMouseOver As Boolean
'Private bolHasFocus As Boolean
Private bolEnabled As Boolean
Private bolChecked As Boolean
Private bolSmall As Boolean
Private lonRoundValue As Long
Private lonRect As Long
Private button_clique As Integer

Private Type POINTAPI
        X As Long
        Y As Long
End Type
Private Type RECT
        Left As Long
        Top As Long
        Right As Long
        Bottom As Long
End Type

Dim mon_rect As RECT

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 GetCursorPos Lib "user32" (lpPoint As POINTAPI) As Long
Private Declare Function WindowFromPoint Lib "user32" (ByVal xPoint As Long, ByVal yPoint As Long) As Long
Private Declare Function RoundRect Lib "gdi32" (ByVal hdc As Long, 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 SetRect Lib "user32" (lpRect As RECT, ByVal X1 As Long, ByVal Y1 As Long, ByVal X2 As Long, ByVal Y2 As Long) As Long

Private Declare Function SetCapture Lib "user32" (ByVal hWnd As Long) As Long
Private Declare Function ReleaseCapture Lib "user32" () As Long


'pour le gradient (le petit circle)
Dim AA1 As New LineGS 'DrawRadial

Private m_Activecolor As OLE_COLOR
Private m_desActivecolor As OLE_COLOR
Private m_Caption As String
Private fntFont As Font 'Caption font.
Private m_CaptionColor As OLE_COLOR


Private Declare Function BitBlt Lib "gdi32" (ByVal hDestDC As Long, ByVal X As Long, ByVal Y As Long, ByVal nWidth As Long, ByVal nHeight As Long, ByVal hSrcDC As Long, ByVal xSrc As Long, ByVal ySrc As Long, ByVal dwRop As Long) As Long
Private Declare Function StretchBlt Lib "gdi32" (ByVal hdc As Long, ByVal X As Long, ByVal Y As Long, ByVal nWidth As Long, ByVal nHeight As Long, ByVal hSrcDC As Long, ByVal xSrc As Long, ByVal ySrc As Long, ByVal nSrcWidth As Long, ByVal nSrcHeight As Long, ByVal dwRop As Long) As Long

Private Declare Function DrawText Lib "user32" Alias "DrawTextA" (ByVal hdc As Long, ByVal lpStr As String, ByVal nCount As Long, lpRect As RECT, ByVal wFormat As Long) As Long
Private Const DT_WORDBREAK = &H10
Private Const DT_CENTER = &H1 Or DT_WORDBREAK Or &H4

Sub mon_gradient(mcolor As Long, X As Integer, Y As Integer, iCircle As Integer)
   Dim I As Integer
       
   'UserControl.Cls
   UserControl.DrawStyle = 5
   UserControl.FillStyle = 0
                                                      '|                                            |
    
      With UserControl
         'Copier DIBits dans un array
         AA1.DIB .hdc, .Image.Handle, .ScaleWidth, .ScaleHeight
      End With
   
   '1er cercle en gris
    If Not Small Then
        'bordure
        'For I = 1 To 2
        '    AA1.CircleDIB UserControl.ScaleWidth / 2, UserControl.ScaleHeight / 2, UserControl.ScaleWidth - 28 - I, UserControl.ScaleHeight - 15 - I, vbWhite '&HDAD4CE
        'Next I
        For I = 5 To 6
            'AA1.DIB .hdc, .Image.Handle, .ScaleWidth, .ScaleHeight
            AA1.CircleDIB X, Y, iCircle + I, iCircle + I, &HDAD4CE  'RGB(128, 128, 128) 'vbRed ''100, 100, I * 0.75, I * 0.75, vbRed
            'AA1.Array2Pic
        Next I
    Else
        'For I = 3 To 4
            AA1.CircleDIB X, Y, iCircle + 3, iCircle + 3, &HDAD4CE  'RGB(128, 128, 128) 'vbRed ''100, 100, I * 0.75, I * 0.75, vbRed
            'AA1.Array2Pic
        'Next I
    End If
   
'    'simulate a circle with blendcolor
    AA1.CircleDIB X, Y, iCircle + 1, iCircle + 1, BlendColor(mcolor, vbWhite, 100) '&HDAD4CE    'RGB(128, 128, 128) 'vbRed ''100, 100, I * 0.75, I * 0.75, vbRed
    AA1.CircleDIB X, Y, iCircle + 2, iCircle + 2, BlendColor(mcolor, vbWhite, 50) '&HDAD4CE    'RGB(128, 128, 128) 'vbRed ''100, 100, I * 0.75, I * 0.75, vbRed

      For I = iCircle To 0 Step -1
        AA1.CircleDIB X, Y, I, I, BlendColor(mcolor, vbWhite, I * (255 / iCircle))
     Next I
     
     'refresh picture for usercontrol
      AA1.Array2Pic
      
End Sub

Public Sub About()
Attribute About.VB_UserMemId = -552
    dlgAbout.Show 1
End Sub


Private Function PointInControl(X As Single, Y As Single) As Boolean
  If X >= 0 And X <= UserControl.ScaleWidth And _
    Y >= 0 And Y <= UserControl.ScaleHeight Then
    PointInControl = True
  End If
End Function

Private Sub PaintControl()
    
Dim rc As RECT

    UserControl.Refresh
    UserControl.Picture = LoadPicture("")
    UserControl.Refresh
    UserControl.Cls
    
    'If bolEnabled Then
        pic_des_small_check.Top = -200
        pic_des_small_uncheck.Top = -200
        pic_des_big_check.Top = -200
        pic_des_big_uncheck.Top = -200
        pic_des_small_check_avec_caption.Top = -200
        pic_des_small_uncheck_avec_caption.Top = -200
        pic_des_big_uncheck_avec_caption.Top = -200
        pic_des_big_check_avec_caption.Top = -200
        
    'Else
    If Not bolEnabled Then
        If bolSmall Then
            If Checked Then
                If m_Caption <> "" Then
                    pic_des_small_check_avec_caption.Top = 0
                    pic_des_small_check_avec_caption.Left = 0
                Else
                    pic_des_small_check.Top = 0
                    pic_des_small_check.Left = 0
                End If
            Else
                If m_Caption <> "" Then
                    pic_des_small_uncheck_avec_caption.Top = 0
                    pic_des_small_uncheck_avec_caption.Left = 0
                Else
                    pic_des_small_uncheck.Top = 0
                    pic_des_small_uncheck.Left = 0
                End If
            End If
        Else
            If Checked Then
                If m_Caption <> "" Then
                    pic_des_big_check_avec_caption.Top = 0