wwcheckbox.ctl

磁盘FAT扇区数据读写操作 Ver 1.20(更新版)

VERSION 5.00
Begin VB.UserControl wwcheck 
   AutoRedraw      =   -1  'True
   ClientHeight    =   2565
   ClientLeft      =   0
   ClientTop       =   0
   ClientWidth     =   3480
   DefaultCancel   =   -1  'True
   ScaleHeight     =   171
   ScaleMode       =   3  'Pixel
   ScaleWidth      =   232
   Begin VB.Timer Timer1 
      Enabled         =   0   'False
      Interval        =   10
      Left            =   585
      Top             =   750
   End
End
Attribute VB_Name = "wwcheck"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = True
Attribute VB_PredeclaredId = False
Attribute VB_Exposed = False
Option Explicit
Private Type RECT
        Left As Long
        Top As Long
        Right As Long
        Bottom As Long
End Type

Private Type POINTAPI
        X As Long
        Y As Long
End Type
Public Enum State
    [Unchecked] = 0
    [Checked] = 1
    [Mixed] = 2
End Enum


Public Enum CustomTypes
    [渐变] = 1
    [模糊] = 2
    [矩形] = 3
    [单色] = 4
End Enum
Public Enum CheckTypes
    [Xp Windows] = 1
    [Custom] = 2
    [Force Standard] = 3
End Enum
'Public Enum BackStyleConstants
'    Transparent = 0
'    Opaque = 1
'End Enum
Private Const DT_CENTERABS = &H65                    'CENTERABS= &H65
Const DT_WORDBREAK = &H10
Const DT_CENTER = &H1
Private Const COLOR_BTNFACE = 15
Private Const COLOR_BTNSHADOW = 16
Private Const COLOR_BTNTEXT = 18
Private Const COLOR_BTNHIGHLIGHT = 20
Private Const COLOR_BTNDKSHADOW = 21
Private Const COLOR_BTNLIGHT = 22
Private Const RGN_DIFF = 4
Private Declare Function SetPixelV Lib "gdi32" (ByVal hdc As Long, ByVal X As Long, ByVal Y As Long, ByVal crColor As Long) As Long
Private Declare Function GetPixel Lib "gdi32" (ByVal hdc As Long, ByVal X As Long, ByVal Y As Long) As Long

Private Declare Function GetSysColor Lib "user32" (ByVal nIndex As Long) As Long

Private Declare Function SetTextColor Lib "gdi32" (ByVal hdc As Long, ByVal crColor 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 Declare Function CreateSolidBrush Lib "gdi32" (ByVal crColor As Long) As Long
Private Declare Function FillRect Lib "user32" (ByVal hdc As Long, lpRect As RECT, ByVal hBrush As Long) As Long
Private Declare Function FrameRect Lib "user32" (ByVal hdc As Long, lpRect As RECT, ByVal hBrush As Long) As Long
Private Declare Function DrawFocusRect Lib "user32" (ByVal hdc As Long, lpRect As RECT) As Long

Private Declare Function DeleteObject Lib "gdi32" (ByVal hObject As Long) As Long

Private Declare Function MoveToEx Lib "gdi32" (ByVal hdc As Long, ByVal X As Long, ByVal Y As Long, lpPoint As POINTAPI) As Long
Private Declare Function LineTo Lib "gdi32" (ByVal hdc As Long, ByVal X As Long, ByVal Y As Long) As Long

Private Declare Function CreateRectRgn Lib "gdi32" (ByVal X1 As Long, ByVal Y1 As Long, ByVal X2 As Long, ByVal Y2 As Long) As Long
Private Declare Function CombineRgn Lib "gdi32" (ByVal hDestRgn As Long, ByVal hSrcRgn1 As Long, ByVal hSrcRgn2 As Long, ByVal nCombineMode As Long) As Long
Private Declare Function SetWindowRgn Lib "user32" (ByVal hwnd As Long, ByVal hRgn As Long, ByVal bRedraw As Long) As Long
Private Declare Function GetCursorPos Lib "user32" (lpPoint As POINTAPI) As Long
Private Declare Function ScreenToClient Lib "user32" (ByVal hwnd As Long, lpPoint As POINTAPI) As Long
Private Declare Function OleTranslateColor Lib "oleaut32.dll" (ByVal lOleColor As Long, ByVal lHPalette As Long, lColorRef As Long) As Long

'属性变量:
Dim m_CheckType As CheckTypes
Dim m_CustomType As CustomTypes
Private Hei As Long  'wwcheck的高度
Private Wid As Long  'wwcheck的宽度
Dim allcount As Long                       'caption字节总数
Private BackCol As Long 'back color
Private ForeCol As Long 'fore color

Private m_Caption As String     'current caption  变量
Private TextFont As StdFont 'current font

Private rc As RECT, rc2 As RECT, rc3 As RECT
Private rgnNorml As Long                           '正常区域句柄

Private LastButton As Byte, LastKeyDown As Byte         '上一次按钮状态和上一次键盘按下状态
Private isEnabled As Boolean
Private hasFocus As Boolean                         '焦点标志
Private disyellowrect As Boolean                         '鼠标移入时显示黄色圆角矩形标志
Private ccFace As Long, ccLight As Long, ccHighLight As Long, ccShadow As Long, ccDarkShadow As Long, ccText As Long

Private lastStat As Byte, Te As String '        保存状态，消除不必要的重画
Private m_HookColor As Long
Private m_FrameColor As Long
Private m_FillColor As Long
Dim m_Value As State
Dim m_hWnd As Long
Private m_BackStyle As BackStyleConstants
Dim showFocusR As Boolean

Dim ccrgb As Long
Dim ccrgb1 As Long
'缺省属性值:

Const m_def_Value = [Unchecked]
Const m_def_Enabled = True
Const m_def_hWnd = 0
Const m_def_Caption = "wwcheck"
Const m_def_HookColor = &HBC5C2C
Const m_def_FrameColor = &HBC5C2C
Const m_def_FillColor = &HF5BC8E
Const m_def_CheckType = [Xp Windows]
Const m_def_CustomType = [渐变]
Const m_def_ShowFocusRect = True
Const m_def_BackStyle = Opaque

'事件声明:

Event Click()
Event KeyDown(KeyCode As Integer, Shift As Integer)
Event KeyPress(KeyAscii As Integer)
Event KeyUp(KeyCode As Integer, Shift As Integer)
Event MouseDown(Button As Integer, Shift As Integer, X As Single, Y As Single)
Event MouseMove(Button As Integer, Shift As Integer, X As Single, Y As Single)
Event MouseUp(Button As Integer, Shift As Integer, X As Single, Y As Single)
Event MouseOut()
'********************************************************************************
Public Property Get BackStyle() As BackStyleConstants
BackStyle = m_BackStyle
End Property
Public Property Let BackStyle(BackStyle As BackStyleConstants)
m_BackStyle = BackStyle
UserControl.BackStyle = BackStyle
'bNotOk = False
' UserControl_Paint
Call Redraw(lastStat, True)
PropertyChanged "BackStyle"
End Property

'********************************************************************************
'注意！不要删除或修改下列被注释的行！
'MemberInfo=10,0,0,0
Public Property Get BackColor() As OLE_COLOR
Attribute BackColor.VB_Description = "返回/设置控件的背景色。"
    BackColor = BackCol
End Property

Public Property Let BackColor(ByVal New_BackColor As OLE_COLOR)
    BackCol = New_BackColor
    Call SetColors
    Call Redraw(lastStat, True)
    PropertyChanged "BackColor"
End Property

'***********************************************************************************
'********************************************************************************
'注意！不要删除或修改下列被注释的行！
'MemberInfo=10,0,0,0
Public Property Get ForeColor() As OLE_COLOR
Attribute ForeColor.VB_Description = "返回/设置Check控件的前景色。"
    ForeColor = ForeCol
End Property

Public Property Let ForeColor(ByVal New_ForeColor As OLE_COLOR)
    ForeCol = New_ForeColor
    Call SetColors
    Call Redraw(lastStat, True)
    PropertyChanged "ForeColor"
End Property

'**********************************************************************************
'**************************************************************************************
'注意！不要删除或修改下列被注释的行！
'MemberInfo=0,0,0,0
Public Property Get Enabled() As Boolean
Attribute Enabled.VB_Description = "返回/设置Check控件的Enabled属性。"
    Enabled = isEnabled
End Property

Public Property Let Enabled(ByVal New_Enabled As Boolean)
    isEnabled = New_Enabled
    Call Redraw(0, True)                                           '####(0, True)
    UserControl.Enabled = isEnabled
    PropertyChanged "Enabled"
End Property
'********************************************************************************

'********************************************************************************
'注意！不要删除或修改下列被注释的行！
'MemberInfo=6,0,0,0
Public Property Get Font() As Font
Attribute Font.VB_Description = "返回/设置Check控件的字体。"
    Set Font = TextFont
End Property

Public Property Set Font(ByVal New_Font As Font)
    Set TextFont = New_Font
    Set UserControl.Font = TextFont
    Call Redraw(0, True)                                         '####(0, True)
    PropertyChanged "Font"
End Property

'**********************************************************************************
'************************************************************************************
'注意！不要删除或修改下列被注释的行！
'MemberInfo=8,0,0,0
Public Property Get hwnd() As Long
Attribute hwnd.VB_Description = "返回Check控件的句柄。"
    hwnd = UserControl.hwnd
End Property
'
Public Property Let hwnd(ByVal New_hWnd As Long)
    If Ambient.UserMode = False Then Err.Raise 387
    If Ambient.UserMode Then Err.Raise 382
    m_hWnd = New_hWnd
    PropertyChanged "hWnd"
End Property
''***********************************************************************************

'**************************************************************************************
'注意！不要删除或修改下列被注释的行！
'MemberInfo=13,0,0,0
Public Property Get Caption() As String
Attribute Caption.VB_Description = "返回/设置控件的Caption属性。"
    Caption = m_Caption
End Property

Public Property Let Caption(ByVal New_Caption As String)
    m_Caption = New_Caption
    Call SetAccessKeys
    Call UserControl_Resize
    PropertyChanged "Caption"
End Property
'******************************************************************************************
Public Property Get HookColor() As OLE_COLOR
Attribute HookColor.VB_Description = "返回/设置Check控件的钩的颜色。（CheckType要设置成Custom风格）"
    HookColor = m_HookColor
End Property
Public Property Let HookColor(ByVal New_HookColor As OLE_COLOR)
    m_HookColor = New_HookColor
    Call UserControl_Resize
    PropertyChanged "HookColor"
End Property
Public Property Get FrameColor() As OLE_COLOR
Attribute FrameColor.VB_Description = "返回/设置Check控件的外框颜色。（CheckType要设置成Custom风格）"
    FrameColor = m_FrameColor
End Property
Public Property Let FrameColor(ByVal New_FrameColor As OLE_COLOR)
    m_FrameColor = New_FrameColor
    Call UserControl_Resize
    PropertyChanged "FrameColor"
End Property
Public Property Get FillColor() As OLE_COLOR
Attribute FillColor.VB_Description = "返回/设置Check控件的内部填充色。（CheckType要设置成Custom风格）"
    FillColor = m_FillColor
End Property
Public Property Let FillColor(ByVal New_FillColor As OLE_COLOR)
    m_FillColor = New_FillColor
    Call UserControl_Resize
    PropertyChanged "FillColor"
End Property
'''*********************************************************************************************

'注意！不要删除或修改下列被注释的行！
'MemberInfo=21,0,0,1
Public Property Get CheckType() As CheckTypes
Attribute CheckType.VB_Description = "返回/设置Check控件的风格种类。（1-XP风格；2-自定义风格；3-标准风格）"
    CheckType = m_CheckType
End Property

Public Property Let CheckType(ByVal New_CheckType As CheckTypes)
    m_CheckType = New_CheckType
    Call SetColors
    Call UserControl_Resize
    
    PropertyChanged "CheckType"
End Property
Public Property Get CustomType() As CustomTypes
Attribute CustomType.VB_Description = "返回/设置CheckType在Custom风格下的自定义种类。（1-渐变风格；2-模糊风格；3-矩形风格；4-单色风格）"
    CustomType = m_CustomType
End Property

Public Property Let CustomType(ByVal New_CustomType As CustomTypes)
    m_CustomType = New_CustomType
    If m_CustomType = [模糊] Then
       m_FrameColor = RGB(131, 131, 131)
       m_FillColor = RGB(169, 196, 213)
       m_HookColor = &HFF0000