clsstoredc.cls

一款Grid表格控件源代码,非常棒.不下你一定会后悔

                            ByVal lHeight As Long) As Boolean
    
    m_lDibDC = CreateCompatibleDC(0)
    If Not (m_lDibDC = 0) Then
        If (CreateDIB(m_lHdc, lWidth, lHeight, m_hDIb)) Then
            m_hDibOld = SelectObject(m_lDibDC, m_hDIb)
            BitBlt m_lDibDC, 0, 0, Width, Height, m_lHdc, 0, 0, &HCC0020
            CreateDIBDc = True
        Else
            DeleteObject m_lDibDC
            m_lDibDC = 0
        End If
    End If

End Function

Private Function CreateDIB(ByVal lHdc As Long, _
                           ByVal lWidth As Long, _
                           ByVal lHeight As Long, _
                           ByRef hDib As Long) As Boolean
    
    With m_tBI.bmiHeader
        .biSize = Len(m_tBI.bmiHeader)
        .biWidth = lWidth
        .biHeight = lHeight
        .biPlanes = 1
        .biBitCount = 24
        .biCompression = BI_RGB
        .biSizeImage = BytesPerScanLine * .biHeight
    End With
    
    hDib = CreateDIBSection(lHdc, m_tBI, DIB_RGB_COLORS, m_lPtr, 0, 0)
    CreateDIB = Not (hDib = 0)

End Function

Public Sub CreateFromPicture(oPicture As StdPicture)

Dim lhDCC       As Long
Dim lHdc        As Long
Dim lhBmpOld    As Long
Dim tBmp        As BITMAP

    If oPicture Is Nothing Then Exit Sub
    GetObjectAPI oPicture.Handle, Len(tBmp), tBmp
    
    With tBmp
        Width = .bmWidth
        Height = .bmHeight
        lhDCC = CreateDCAsNull("DISPLAY", ByVal 0&, ByVal 0&, ByVal 0&)
        lHdc = CreateCompatibleDC(lhDCC) 'here
        '/* use bitmap with alpha channel
        If m_bUseAlpha Then
            m_lHandle = ConvertTo32(oPicture.Handle, tBmp, 255)
            If Not m_lHandle = 0 Then
                lhBmpOld = SelectObject(lHdc, m_lHandle)
            '/* default on failure
            Else
                lhBmpOld = SelectObject(lHdc, oPicture.Handle)
            End If
        Else
            lhBmpOld = SelectObject(lHdc, oPicture.Handle)
        End If
        '/* blit the image into dc
        BitBlt hdc, 0&, 0&, .bmWidth, .bmHeight, lHdc, 0&, 0&, vbSrcCopy
    End With
    
    SelectObject lHdc, lhBmpOld
    DeleteDC lHdc
    DeleteDC lhDCC

End Sub

Public Function ExtractHandle() As Long

    If Not m_hBmp = 0 Then
        ExtractHandle = m_hBmp
    End If

End Function

Public Function ExtractBitmap() As Long

    If Not m_hBmpOld = 0 Then
        SelectObject m_lHdc, m_hBmpOld
        m_hBmpOld = 0
    End If
    If Not m_lHdc = 0 Then
        DeleteDC m_lHdc
        m_lHdc = 0
    End If
    ExtractBitmap = m_hBmp
    m_hBmp = 0
    m_bInit = True

End Function

Private Sub ImageCreate(ByVal lW As Long, _
                        ByVal lH As Long)

Dim lHdc    As Long

    ImageDestroy
    lHdc = CreateDCAsNull("DISPLAY", ByVal 0&, ByVal 0&, ByVal 0&)
    m_lHdc = CreateCompatibleDC(lHdc)
    m_hBmp = CreateCompatibleBitmap(lHdc, lW, lH)
    m_hBmpOld = SelectObject(m_lHdc, m_hBmp)
    If m_hBmpOld = 0 Then
        ImageDestroy
    Else
        m_lWidth = lW
        m_lHeight = lH
    End If
    DeleteDC lHdc

End Sub

Public Sub InjectBitmap(ByVal lhBmp As Long)

Dim tbm As BITMAP

    ImageDestroy
    GetObjectAPI lhBmp, Len(tbm), tbm
    With tbm
        Width = .bmWidth
        Height = .bmHeight
    End With
    If m_bUseAlpha Then
        m_lHandle = ConvertTo32(lhBmp, tbm, 255)
    End If
    Init lhBmp

    m_bInit = False

End Sub

Private Function Init(Optional ByVal hBmp As Long = 0) As Boolean

Dim hDCDisp     As Long

    If m_bMono Then
        If m_lHdc = 0 Then
            m_lHdc = CreateCompatibleDC(0)
        End If
    Else
        hDCDisp = CreateDCAsNull("DISPLAY", ByVal 0&, ByVal 0&, ByVal 0&)
        If Not hDCDisp = 0 Then
            If m_lHdc = 0 Then
                m_lHdc = CreateCompatibleDC(hDCDisp)
                If m_lHdc = 0 Then
                    Exit Function
                End If
            End If
        Else
            Exit Function
        End If
    End If

    If Not m_lHdc = 0 Then
        If Not m_hBmpOld = 0 Then
            SelectObject m_lHdc, m_hBmpOld
            m_hBmpOld = 0
        End If
        If Not m_hBmp = 0 Then
            DeleteObject m_hBmp
            m_hBmp = 0
        End If
        If hBmp = 0 Then
            If m_bMono Then
                m_hBmp = CreateCompatibleBitmap(m_lHdc, m_lSizeX, m_lSizeY)
            Else
                m_hBmp = CreateCompatibleBitmap(hDCDisp, m_lSizeX, m_lSizeY)
            End If
        Else
            m_hBmp = hBmp
        End If
        If m_hBmp = 0 Then
            DeleteDC hDCDisp
            hDCDisp = 0
        Else
            m_hBmpOld = SelectObject(m_lHdc, m_hBmp)
            Init = True
        End If
    Else
        DeleteDC hDCDisp
        hDCDisp = 0
    End If

    If Not (hDCDisp = 0) Then
        DeleteDC hDCDisp
    End If

End Function

Private Sub MapDIBits(uSA As SAFEARRAYID, _
                      aBits() As Byte, _
                      ByVal lpData As Long, _
                      ByVal lSize As Long)

On Error GoTo Handler

    With uSA
        .cbElements = 1
        .cDims = 1
        .Bounds.lLbound = 0
        .Bounds.cElements = lSize
        .pvData = lpData
    End With
    Call CopyMemory(ByVal VarPtrArray(aBits()), VarPtr(uSA), 4)

Handler:
    On Error GoTo 0

End Sub

Private Sub UnmapDIBits(aBits() As Byte)

On Error GoTo Handler

    Call CopyMemory(ByVal VarPtrArray(aBits()), 0&, 4&)

Handler:
    On Error GoTo 0

End Sub

Public Sub LongToRgb(ByVal lngColor As Long, _
                     ByRef lngRed As Long, _
                     ByRef lngGreen As Long, _
                     ByRef lngBlue As Long)

'Converts Long Color to RGB
lngRed = lngColor And &HFF
lngGreen = (lngColor And &HFF00&) \ &H100&
lngBlue = (lngColor And &HFF0000) \ &H10000

End Sub

Public Sub RGBToHLS(ByVal R As Long, _
                    ByVal g As Long, _
                    ByVal b As Long, _
                    h As Single, _
                    s As Single, _
                    l As Single)

Dim Max     As Single
Dim Min     As Single
Dim delta   As Single
Dim rR      As Single
Dim rG      As Single
Dim rB      As Single

    rR = R / 255: rG = g / 255: rB = b / 255
    Max = Maximum(rR, rG, rB)
    Min = Minimum(rR, rG, rB)
    l = (Max + Min) / 2
    If Max = Min Then
        s = 0
        h = 0
    Else
        If l <= 0.5 Then
            s = (Max - Min) / (Max + Min)
        Else
            s = (Max - Min) / (2 - Max - Min)
        End If
        delta = Max - Min
        If rR = Max Then
            h = (rG - rB) / delta
        ElseIf rG = Max Then
            h = 2 + (rB - rR) / delta
        ElseIf rB = Max Then
            h = 4 + (rR - rG) / delta
        End If
    End If

End Sub

Public Sub HLSToRGB(ByVal h As Single, _
                    ByVal s As Single, _
                    ByVal l As Single, _
                    R As Long, _
                    g As Long, _
                    b As Long)

Dim rR      As Single
Dim rG      As Single
Dim rB      As Single
Dim Min     As Single
Dim Max     As Single

    If s = 0 Then
        rR = l: rG = l: rB = l
    Else
        If l <= 0.5 Then
            Min = l * (1 - s)
        Else
            Min = l - s * (1 - l)
        End If
        Max = 2 * l - Min
        If (h < 1) Then
            rR = Max
            If (h < 0) Then
                rG = Min
                rB = rG - h * (Max - Min)
            Else
                rB = Min
                rG = h * (Max - Min) + rB
            End If
        ElseIf (h < 3) Then
            rG = Max
            If (h < 2) Then
                rB = Min
                rR = rB - (h - 2) * (Max - Min)
            Else
                rR = Min
                rB = (h - 2) * (Max - Min) + rR
            End If
        Else
            rB = Max
            If (h < 4) Then
                rR = Min
                rG = rR - (h - 4) * (Max - Min)
            Else
                rG = Min
                rR = (h - 4) * (Max - Min) + rG
            End If
        End If
    End If
    R = rR * 255: g = rG * 255: b = rB * 255

End Sub

Private Function Maximum(rR As Single, _
                         rG As Single, _
                         rB As Single) As Single
   
    If (rR > rG) Then
        If (rR > rB) Then
            Maximum = rR
        Else
            Maximum = rB
        End If
    Else
        If (rB > rG) Then
            Maximum = rB
        Else
            Maximum = rG
        End If
    End If

End Function

Private Function Minimum(rR As Single, _
                         rG As Single, _
                         rB As Single) As Single

    If (rR < rG) Then
        If (rR < rB) Then
            Minimum = rR
        Else
            Minimum = rB
        End If
    Else
        If (rB < rG) Then
            Minimum = rB
        Else
            Minimum = rG
        End If
    End If
   
End Function

Private Sub ImageDestroy()

    If Not (m_hDIb = 0) Then
        SelectObject m_lDibDC, m_hDibOld
        DeleteObject m_hDIb
        DeleteDC m_lDibDC
    End If
    If Not m_hBmpOld = 0 Then
        SelectObject m_lHdc, m_hBmpOld
        m_hBmpOld = 0
    End If
    If Not m_hBmp = 0 Then
        DeleteObject m_hBmp
        m_hBmp = 0
    End If
    If Not m_lHdc = 0 Then
        DeleteDC m_lHdc
        m_lHdc = 0
    End If
    If Not m_lHandle = 0 Then
        DeleteObject m_lHandle
    End If
    If Not m_tBIH.biBitCount = 0 Then
        ZeroMemory m_tBIH, Len(m_tBIH)
    End If
    m_lpBits = 0
    m_lWidth = 0
    m_lHeight = 0
    m_lHdc = 0
    m_hDIb = 0
    m_hDibOld = 0
    m_lPtr = 0
    
End Sub

Private Sub Class_Terminate()
    ImageDestroy
End Sub