clsbutton.cls

大量优秀的vb编程

    RGBtoHSL.Sat = CInt(S)
End Function

Sub TriggerButton()
'Dim UpState As Boolean
'Do
'    DoEvents
'    If GetCapture = pHwnd And UpState = False Then
'        parentPic.Cls
'        StretchBlt parentPic.hdc, 0, 0, pWidth, pHeight, DownDC, 0, 0, DownWidth, DownHeight, vbSrcCopy
'        UpState = True
'    ElseIf GetCapture <> pHwnd And UpState = True Then
'       parentPic.Cls
'        StretchBlt parentPic.hdc, 0, 0, pWidth, pHeight, UpDC, 0, 0, UpWidth, UpHeight, vbSrcCopy
'        UpState = False
'    End If
'Loop

parentPic.Cls
StretchBlt parentPic.hdc, 0, 0, pWidth, pHeight, DownDC, 0, 0, DownWidth, DownHeight, vbSrcCopy
Do While pHwnd = GetCapture()
    DoEvents
Loop
parentPic.Cls
StretchBlt parentPic.hdc, 0, 0, pWidth, pHeight, UpDC, 0, 0, UpWidth, UpHeight, vbSrcCopy
End Sub

Private Sub Class_Initialize()
    UpDC = 0
    DownDC = 0
End Sub

Private Sub Class_Terminate()
    DestroyUP
    DestroyDown
    Set parentPic = Nothing
End Sub

Private Function GetColor(ByVal nColor As Long) As Long
    Const SYSCOLOR_BIT As Long = &H80000000
    If (nColor And SYSCOLOR_BIT) = SYSCOLOR_BIT Then
        nColor = nColor And (Not SYSCOLOR_BIT)
        GetColor = GetSysColor(nColor)
    Else
        GetColor = nColor
    End If
End Function

Private Function IsUpCreated() As Boolean
    IsUpCreated = (UpDC <> 0)
End Function



Private Function IsDownCreated() As Boolean
    IsDownCreated = (DownDC <> 0)
End Function

Private Function CreateUP(hParentDC As Long, Optional PixelWidth As Long = 1024, Optional PixelHeight As Long = 768) As Long
    Dim nHasPalette As Long
    Dim nPaletteSize As Long
    Dim LogPal As LOGPALETTE
    Dim tm As TEXTMETRIC
    Dim sFaceName As String * 80
    Dim fFont As StdFont

    If IsUpCreated Then DestroyUP

    UpParent = hParentDC
    UpWidth = PixelWidth
    UpHeight = PixelHeight

    ' Create a memory device context to use
    UpDC = CreateCompatibleDC(UpParent)

    ' Tell'em it's a picture (so drawings can be done on the DC)
    UpMemBitmap = CreateCompatibleBitmap(UpParent, UpWidth, UpHeight)
    UpBitmap = SelectObject(UpDC, UpMemBitmap)

    ' Get screen properties
    nHasPalette = GetDeviceCaps(UpParent, RASTERCAPS) And RC_PALETTE   ' Palette support
    nPaletteSize = GetDeviceCaps(UpParent, SIZEPALETTE)                ' Size of palette
    ' If the screen has a palette make a copy and realize it
    If nHasPalette And (nPaletteSize = 256) Then
        ' Create a copy of the system palette
        LogPal.palVersion = &H300
        LogPal.palNumEntries = 256
        Call GetSystemPaletteEntries(UpParent, 0&, 256, LogPal.palPalEntry(0))
        UpMemPal = CreatePalette(LogPal)
        ' Select the new palette into the memory DC and realize it
        UpPal = SelectPalette(UpDC, UpMemPal, 0&)
        Call RealizePalette(UpDC)
    End If
    Call SetBkColor(UpDC, GetBkColor(UpParent))
    UpColor = GetTextColor(UpParent)
    Call SetBkMode(UpDC, GetBkMode(UpParent))
    
    Call GetTextMetrics(UpDC, tm)
    Call GetTextFace(UpParent, 79, sFaceName)
    Set fFont = New StdFont
    With fFont
        .Bold = (tm.tmWeight > FW_NORMAL)
        .Charset = tm.tmCharSet
        .Italic = (tm.tmItalic <> 0)
        .Name = sFaceName
        .Strikethrough = (tm.tmStruckOut <> 0)
        .Underline = (tm.tmUnderlined <> 0)
        .Weight = tm.tmWeight
        .Size = (tm.tmMemoryHeight / tm.tmDigitizedAspectY) * 72 ' Size has to be calculated
    End With
    Set UPFont = fFont
    Set fFont = Nothing
    
    CreateUP = UpDC
End Function
Private Property Get UPFont() As StdFont
    If Not IsUpCreated Then Exit Property

    On Local Error Resume Next

    Dim tm As TEXTMETRIC
    Dim sFaceName As String * 80

    Call GetTextMetrics(UpDC, tm)
    Call GetTextFace(UpDC, 79, sFaceName)

    Set UPFont = New StdFont

    With UPFont
        .Bold = (tm.tmWeight > FW_NORMAL)
        .Charset = tm.tmCharSet
        .Italic = (tm.tmItalic <> 0)
        .Name = sFaceName 'StrConv(sFaceName, vbUnicode)
        .Strikethrough = (tm.tmStruckOut <> 0)
        .Underline = (tm.tmUnderlined <> 0)
        .Weight = tm.tmWeight
        .Size = (tm.tmMemoryHeight / tm.tmDigitizedAspectY) * 72 ' Size has to be calculated
    End With
End Property
Private Property Get DOWNFont() As StdFont
    If Not IsDownCreated Then Exit Property

    On Local Error Resume Next

    Dim tm As TEXTMETRIC
    Dim sFaceName As String * 80

    Call GetTextMetrics(DownDC, tm)
    Call GetTextFace(DownDC, 79, sFaceName)

    Set DOWNFont = New StdFont

    With DOWNFont
        .Bold = (tm.tmWeight > FW_NORMAL)
        .Charset = tm.tmCharSet
        .Italic = (tm.tmItalic <> 0)
        .Name = sFaceName 'StrConv(sFaceName, vbUnicode)
        .Strikethrough = (tm.tmStruckOut <> 0)
        .Underline = (tm.tmUnderlined <> 0)
        .Weight = tm.tmWeight
        .Size = (tm.tmMemoryHeight / tm.tmDigitizedAspectY) * 72 ' Size has to be calculated
    End With
End Property

Private Property Set UPFont(ByVal NewFont As StdFont)
    If Not IsUpCreated Then Exit Property

    On Local Error Resume Next

    Dim nName() As Byte, i As Byte, nSize As Byte
    Dim tFont As LOGFONT

    ' Font name is a byte array and is in ANSI (DOS) format (1 byte = 1 character)
    nName = StrConv(NewFont.Name & Chr$(0), vbFromUnicode)
    nSize = UBound(nName)
    If nSize > LF_FACESIZE Then nSize = LF_FACESIZE
    For i = 0 To nSize
        tFont.lfFaceName(i) = nName(i)
    Next

    With tFont
        .lfCharSet = NewFont.Charset
        .lfClipPrecision = CLIP_DEFAULT_PRECIS
        .lfEscapement = 0                       ' Angle to print
        .lfOrientation = .lfEscapement
        .lfWidth = 0#
        .lfItalic = IIf(NewFont.Italic, 1, 0)
        .lfOutPrecision = OUT_DEFAULT_PRECIS
        .lfPitchAndFamily = DEFAULT_PITCH
        .lfQuality = DEFAULT_QUALITY
        .lfStrikeOut = IIf(NewFont.Strikethrough, 1, 0)
        .lfUnderline = IIf(NewFont.Underline, 1, 0)
        .lfWeight = NewFont.Weight
        ' Font size (height) has to be calculated
        .lfHeight = MulDiv(NewFont.Size, GetDeviceCaps(UpDC, LOGPIXELSY), 72)
    End With

    ' Set environment (remember previous settings)
    If UpMemoryFont <> 0 Then
        ' Reset environment
        Call SelectObject(UpDC, UpOrginalFont)
        Call DeleteObject(UpMemoryFont)
    End If
    UpMemoryFont = CreateFontIndirect(tFont)
    UpOrginalFont = SelectObject(UpDC, UpMemoryFont)
End Property

Private Property Set DOWNFont(ByVal NewFont As StdFont)
    If Not IsDownCreated Then Exit Property

    On Local Error Resume Next

    Dim nName() As Byte, i As Byte, nSize As Byte
    Dim tFont As LOGFONT

    ' Font name is a byte array and is in ANSI (DOS) format (1 byte = 1 character)
    nName = StrConv(NewFont.Name & Chr$(0), vbFromUnicode)
    nSize = UBound(nName)
    If nSize > LF_FACESIZE Then nSize = LF_FACESIZE
    For i = 0 To nSize
        tFont.lfFaceName(i) = nName(i)
    Next

    With tFont
        .lfCharSet = NewFont.Charset
        .lfClipPrecision = CLIP_DEFAULT_PRECIS
        .lfEscapement = 0                       ' Angle to print
        .lfOrientation = .lfEscapement
        .lfWidth = 0#
        .lfItalic = IIf(NewFont.Italic, 1, 0)
        .lfOutPrecision = OUT_DEFAULT_PRECIS
        .lfPitchAndFamily = DEFAULT_PITCH
        .lfQuality = DEFAULT_QUALITY
        .lfStrikeOut = IIf(NewFont.Strikethrough, 1, 0)
        .lfUnderline = IIf(NewFont.Underline, 1, 0)
        .lfWeight = NewFont.Weight
        ' Font size (height) has to be calculated
        .lfHeight = MulDiv(NewFont.Size, GetDeviceCaps(DownDC, LOGPIXELSY), 72)
    End With

    ' Set environment (remember previous settings)
    If DownMemoryFont <> 0 Then
        ' Reset environment
        Call SelectObject(DownDC, DownOrginalFont)
        Call DeleteObject(DownMemoryFont)
    End If
    DownMemoryFont = CreateFontIndirect(tFont)
    DownOrginalFont = SelectObject(DownDC, DownMemoryFont)
End Property
Private Function CreateDOWN(hParentDC As Long, Optional PixelWidth As Long = 1024, Optional PixelHeight As Long = 768) As Long
    Dim nHasPalette As Long
    Dim nPaletteSize As Long
    Dim LogPal As LOGPALETTE
    Dim tm As TEXTMETRIC
    Dim sFaceName As String * 80
    Dim fFont As StdFont

    If IsDownCreated Then DestroyDown

    DownParent = hParentDC
    DownWidth = PixelWidth
    DownHeight = PixelHeight

    ' Create a memory device context to use
    DownDC = CreateCompatibleDC(DownParent)

    ' Tell'em it's a picture (so drawings can be done on the DC)
    DownMemBitmap = CreateCompatibleBitmap(DownParent, DownWidth, DownHeight)
    DownBitmap = SelectObject(DownDC, DownMemBitmap)

    ' Get screen properties
    nHasPalette = GetDeviceCaps(DownParent, RASTERCAPS) And RC_PALETTE   ' Palette sDOWNport
    nPaletteSize = GetDeviceCaps(DownParent, SIZEPALETTE)                ' Size of palette
    ' If the screen has a palette make a copy and realize it
    If nHasPalette And (nPaletteSize = 256) Then
        ' Create a copy of the system palette
        LogPal.palVersion = &H300
        LogPal.palNumEntries = 256
        Call GetSystemPaletteEntries(DownParent, 0&, 256, LogPal.palPalEntry(0))
        DownMemPal = CreatePalette(LogPal)
        ' Select the new palette into the memory DC and realize it
        DownPal = SelectPalette(DownDC, DownMemPal, 0&)
        Call RealizePalette(DownDC)
    End If
    Call SetBkColor(DownDC, GetBkColor(DownParent))
    DownColor = GetTextColor(DownParent)
    Call SetBkMode(DownDC, GetBkMode(DownParent))
    
    Call GetTextMetrics(DownDC, tm)
    Call GetTextFace(DownParent, 79, sFaceName)
    Set fFont = New StdFont
    With fFont
        .Bold = (tm.tmWeight > FW_NORMAL)
        .Charset = tm.tmCharSet
        .Italic = (tm.tmItalic <> 0)
        .Name = sFaceName
        .Strikethrough = (tm.tmStruckOut <> 0)
        .Underline = (tm.tmUnderlined <> 0)
        .Weight = tm.tmWeight
        .Size = (tm.tmMemoryHeight / tm.tmDigitizedAspectY) * 72 ' Size has to be calculated
    End With
    Set DOWNFont = fFont
    Set fFont = Nothing
    
    CreateDOWN = DownDC
End Function
Private Sub DestroyUP()
    If Not IsUpCreated Then Exit Sub

    '
    Call SelectObject(UpDC, UpBitmap)
    Call DeleteObject(UpMemBitmap)
    Call DeleteDC(UpDC)
    '
    UpDC = -1
End Sub

Private Sub DestroyDown()
    If Not IsDownCreated Then Exit Sub

    '
    Call SelectObject(DownDC, DownBitmap)
    Call DeleteObject(DownMemBitmap)
    Call DeleteDC(DownDC)
    '
    DownDC = -1
End Sub

Public Property Get hdcUP() As Long
    hdcUP = UpDC
End Property

Public Property Get hdcDOWN() As Long
    hdcDOWN = DownDC
End Property



Public Sub ClsUP(cColor As Long)
    Dim hBrush As Long
    Dim tRect As RECT

    hBrush = CreateSolidBrush(cColor)
    With tRect
        .Left = 0
        .Top = 0
        .Right = UpWidth
        .Bottom = UpHeight
    End With

    Call FillRect(UpDC, tRect, hBrush)
    Call DeleteObject(hBrush)
End Sub
Public Sub ClsDOWN(cColor As Long)
    Dim hBrush As Long
    Dim tRect As RECT

    hBrush = CreateSolidBrush(cColor)
    With tRect
        .Left = 0
        .Top = 0
        .Right = DownWidth
        .Bottom = DownHeight
    End With

    Call FillRect(DownDC, tRect, hBrush)
    Call DeleteObject(hBrush)
End Sub