wwcheckbox.ctl

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

                    Next
                Next


                'For i = 0 To 3
                '    mSetPixel 5, Hei \ 2 - 2 + i, ColorXp
                '    DoEvents
                'Next
                'For i = 0 To 3
                '    mSetPixel 6, Hei \ 2 - 1 + i, ColorXp
                '    DoEvents
                'Next
                'For i = 0 To 3
                '    mSetPixel 7, Hei \ 2 + i, ColorXp
                '    DoEvents
                'Next
                For Ai = 8 To 14
                    For i = 0 To 3
                        mSetPixel Ai, Hei \ 2 + (9 - Ai) + i, ColorXp
                        'DoEvents
                    Next
                Next
                
                'For i = 0 To 3
                '    mSetPixel 8, Hei \ 2 + 1 + i, ColorXp
                '    DoEvents
                'Next
                'For i = 0 To 3
                '    mSetPixel 9, Hei \ 2 + i, ColorXp
                '    DoEvents
                'Next
                'For i = 0 To 3
                '    mSetPixel 10, Hei \ 2 - 1 + i, ColorXp
                '    DoEvents
                'Next
                'For i = 0 To 3
                '    mSetPixel 11, Hei \ 2 - 2 + i, ColorXp
                '    DoEvents
                'Next
                'For i = 0 To 3
                '    mSetPixel 12, Hei \ 2 - 3 + i, ColorXp
                '    DoEvents
                'Next
                'For i = 0 To 3
                '    mSetPixel 13, Hei \ 2 - 4 + i, ColorXp
                '    DoEvents
                'Next
                'For i = 0 To 3
                '    mSetPixel 14, Hei \ 2 - 5 + i, ColorXp
                '    DoEvents
                'Next
End Sub
Private Sub mSetPixelForce(ByVal BasePoint As Long, ByVal ColorForce As Long)
Dim i As Long
Dim Ai As Long
                       For Ai = 3 To 4
                           For i = 0 To 2
                               mSetPixel BasePoint + Ai, Hei \ 2 + (Ai - 4) + i, ColorForce
                               'DoEvents
                           Next
                       Next
                       'For i = 0 To 2
                       '    mSetPixel BasePoint + 3, Hei \ 2 - 1 + i, ColorForce
                       '   DoEvents
                       'Next
                       'For i = 0 To 2
                       '    mSetPixel BasePoint + 4, Hei \ 2 + i, ColorForce
                       'Next
                       For Ai = 5 To 9
                           For i = 0 To 2
                               mSetPixel BasePoint + Ai, Hei \ 2 + (6 - Ai) + i, ColorForce
                               'DoEvents
                           Next
                       Next
                       'For i = 0 To 2
                       '    mSetPixel BasePoint + 5, Hei \ 2 + 1 + i, ColorForce
                       'Next
                       'For i = 0 To 2
                       '    mSetPixel BasePoint + 6, Hei \ 2 + i, ColorForce
                       'Next
                       'For i = 0 To 2
                       '    mSetPixel BasePoint + 7, Hei \ 2 - 1 + i, ColorForce
                       'Next
                       'For i = 0 To 2
                       '    mSetPixel BasePoint + 8, Hei \ 2 - 2 + i, ColorForce
                       'Next
                       'For i = 0 To 2
                       '    mSetPixel BasePoint + 9, Hei \ 2 - 3 + i, ColorForce
                       'Next
End Sub
Private Sub mSetPixelTexture(ByVal xBasePoint As Long) '画模糊点
Dim cdc As Long
Dim i As Long
Dim ii As Long
Dim Red As Long, Blue As Long, Green As Long
Dim rd As Long, be As Long, gn As Long
    Blue = ((m_FillColor \ &H10000) Mod &H100)
    Green = ((m_FillColor \ &H100) Mod &H100)
    Red = (m_FillColor And &HFF)
   
    mSetPixel xBasePoint, Hei \ 2, RGB(255, 255, 255)
    For ii = 1 To 4
        cdc = ShiftColorCustom(m_FillColor, (255 - Red) * (5 - ii) / 5, (255 - Green) * (5 - ii) / 5, (255 - Blue) * (5 - ii) / 5, RGB(255, 255, 255))
        mSetPixel xBasePoint - ii, Hei \ 2, cdc
        be = Blue + (255 - Blue) * (5 - ii) / 5
        gn = Green + (255 - Green) * (5 - ii) / 5
        rd = Red + (255 - Red) * (5 - ii) / 5
       
        For i = 4 To 1 Step -1
            mSetPixel xBasePoint - ii, Hei \ 2 + i, ShiftColorCustom(cdc, -(rd - Red) * i / 5, -(gn - Green) * i / 5, -(be - Blue) * i / 5, RGB(255, 255, 255))
            mSetPixel xBasePoint - ii, Hei \ 2 - i, ShiftColorCustom(cdc, -(rd - Red) * i / 5, -(gn - Green) * i / 5, -(be - Blue) * i / 5, RGB(255, 255, 255))
            'DoEvents
        Next
    Next
    
    For i = 1 To 4
        cdc = ShiftColorCustom(m_FillColor, (255 - Red) * (5 - i) / 5, (255 - Green) * (5 - i) / 5, (255 - Blue) * (5 - i) / 5, RGB(255, 255, 255))
        mSetPixel xBasePoint, Hei \ 2 + i, cdc
        mSetPixel xBasePoint, Hei \ 2 - i, cdc
        'DoEvents
    Next
    
    For ii = 1 To 4
        cdc = ShiftColorCustom(m_FillColor, (255 - Red) * (5 - ii) / 5, (255 - Green) * (5 - ii) / 5, (255 - Blue) * (5 - ii) / 5, RGB(255, 255, 255))
        mSetPixel xBasePoint + ii, Hei \ 2, cdc
        be = Blue + (255 - Blue) * (5 - ii) / 5
        gn = Green + (255 - Green) * (5 - ii) / 5
        rd = Red + (255 - Red) * (5 - ii) / 5
       
        For i = 4 To 1 Step -1
            mSetPixel xBasePoint + ii, Hei \ 2 + i, ShiftColorCustom(cdc, -(rd - Red) * i / 5, -(gn - Green) * i / 5, -(be - Blue) * i / 5, RGB(255, 255, 255))
            mSetPixel xBasePoint + ii, Hei \ 2 - i, ShiftColorCustom(cdc, -(rd - Red) * i / 5, -(gn - Green) * i / 5, -(be - Blue) * i / 5, RGB(255, 255, 255))
            'DoEvents
        Next
    Next
End Sub

'**************************************************************************
Private Sub DrawFocusR()                                           '画焦点框
    SetTextColor UserControl.hdc, ccText
    DrawFocusRect UserControl.hdc, rc3                                      'rc3
End Sub
Private Sub SetColors()

   ccFace = BackCol
    ccText = ForeCol
    
If m_CheckType = [Custom] Then                                               '
    
ElseIf m_CheckType = [Force Standard] Then
    ccShadow = GetSysColor(COLOR_BTNSHADOW)
    ccLight = GetSysColor(COLOR_BTNLIGHT)
    ccDarkShadow = GetSysColor(COLOR_BTNDKSHADOW)
    ccHighLight = GetSysColor(COLOR_BTNHIGHLIGHT)
           'GetSysColor(COLOR_BTNTEXT)
ElseIf m_CheckType = [Xp Windows] Then
   
Else
'if MyColorType is 1 or has not been set then use windows colors
    ccFace = GetSysColor(COLOR_BTNFACE)
    ccShadow = GetSysColor(COLOR_BTNSHADOW)
    ccLight = GetSysColor(COLOR_BTNLIGHT)
    ccDarkShadow = GetSysColor(COLOR_BTNDKSHADOW)
    ccHighLight = GetSysColor(COLOR_BTNHIGHLIGHT)

End If
End Sub

Private Sub MakeRegion()
Dim rgn1 As Long, rgn2 As Long
    
    DeleteObject rgnNorml
    rgnNorml = CreateRectRgn(0, 0, Wid, Hei)
    rgn2 = CreateRectRgn(0, 0, 0, 0)

        rgn1 = CreateRectRgn(0, 0, 1, 1)
        CombineRgn rgn2, rgnNorml, rgn1, RGN_DIFF
        DeleteObject rgn1
        rgn1 = CreateRectRgn(0, Hei, 1, Hei - 1)
        CombineRgn rgnNorml, rgn2, rgn1, RGN_DIFF
        DeleteObject rgn1
        rgn1 = CreateRectRgn(Wid, 0, Wid - 1, 1)
        CombineRgn rgn2, rgnNorml, rgn1, RGN_DIFF
        DeleteObject rgn1
        rgn1 = CreateRectRgn(Wid, Hei, Wid - 1, Hei - 1)
        CombineRgn rgnNorml, rgn2, rgn1, RGN_DIFF
        DeleteObject rgn1
DeleteObject rgn2
End Sub

Private Sub SetAccessKeys()
'设置访问键
Dim ampersandPos As Long

If Len(m_Caption) > 1 Then
    ampersandPos = InStr(1, m_Caption, "&", vbTextCompare)
    If (ampersandPos < Len(m_Caption)) And (ampersandPos > 0) Then
        If Mid(m_Caption, ampersandPos + 1, 1) <> "&" Then 'if text is sonething like && then no access key should be assigned, so continue searching
            UserControl.AccessKeys = LCase(Mid(m_Caption, ampersandPos + 1, 1))
        Else 'do only a second pass to find another ampersand character
            ampersandPos = InStr(ampersandPos + 2, m_Caption, "&", vbTextCompare)
            If Mid(m_Caption, ampersandPos + 1, 1) <> "&" Then
                UserControl.AccessKeys = LCase(Mid(m_Caption, ampersandPos + 1, 1))
            Else
                UserControl.AccessKeys = ""
            End If
        End If
    Else
        UserControl.AccessKeys = ""
    End If
Else
    UserControl.AccessKeys = ""
End If
End Sub

Private Function ShiftColor(ByVal Color As Long, ByVal Value As Long, Optional isXP As Boolean = False) As Long

Dim Red As Long, Blue As Long, Green As Long

If isXP = False Then
    Blue = ((Color \ &H10000) Mod &H100) + Value
Else
    Blue = ((Color \ &H10000) Mod &H100)
    Blue = Blue + ((Blue * Value) \ &HC0)
End If
Green = ((Color \ &H100) Mod &H100) + Value
Red = (Color And &HFF) + Value
    
    'check red
    If Red < 0 Then
        Red = 0
    ElseIf Red > 255 Then
        Red = 255
    End If
    'check green
    If Green < 0 Then
        Green = 0
    ElseIf Green > 255 Then
        Green = 255
    End If
    'check blue
    If Blue < 0 Then
        Blue = 0
    ElseIf Blue > 255 Then
        Blue = 255
    End If

ShiftColor = RGB(Red, Green, Blue)
End Function

Private Function ShiftColorCustom(ByVal Color As Long, ByVal Rcl As Long, ByVal Gcl As Long, ByVal Bcl As Long, ByVal Color1 As Long) As Long
Dim Red As Long, Blue As Long, Green As Long
Dim Red1 As Long, Blue1 As Long, Green1 As Long

Blue = ((Color \ &H10000) Mod &H100) + Bcl
Green = ((Color \ &H100) Mod &H100) + Gcl
Red = (Color And &HFF) + Rcl
Blue1 = ((Color1 \ &H10000) Mod &H100)
Green1 = ((Color1 \ &H100) Mod &H100)
Red1 = (Color1 And &HFF)
    'check red
    If Red < 0 Then
        Red = 0
    ElseIf Red > Red1 Then
        Red = Red1
    End If
    'check green
    If Green < 0 Then
        Green = 0
    ElseIf Green > Green1 Then
        Green = Green1
    End If
    'check blue
    If Blue < 0 Then
        Blue = 0
    ElseIf Blue > Blue1 Then
        Blue = Blue1
    End If

ShiftColorCustom = RGB(Red, Green, Blue)
End Function
'**************************************************************************
'     timer事件处理鼠标移出
'＊＊＊＊＊＊＊＊＊＊＊＊＊＊＊＊＊＊＊＊＊＊＊＊＊＊＊＊＊＊＊＊＊＊＊＊＊
Private Sub Timer1_Timer()
    Dim pnt As POINTAPI
    GetCursorPos pnt
    ScreenToClient UserControl.hwnd, pnt

    If pnt.X < UserControl.ScaleLeft Or _
       pnt.Y < UserControl.ScaleTop Or _
       pnt.X > (UserControl.ScaleLeft + UserControl.ScaleWidth) Or _
       pnt.Y > (UserControl.ScaleTop + UserControl.ScaleHeight) Then
       
        Timer1.Enabled = False
        RaiseEvent MouseOut
        disyellowrect = False
        Call Redraw(0, True)                                          'True
    End If
End Sub