clsstoredc.cls

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

VERSION 1.0 CLASS
BEGIN
  MultiUse = -1  'True
  Persistable = 0  'NotPersistable
  DataBindingBehavior = 0  'vbNone
  DataSourceBehavior  = 0  'vbNone
  MTSTransactionMode  = 0  'NotAnMTSObject
END
Attribute VB_Name = "clsStoreDc"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = False
Attribute VB_Exposed = False
Option Explicit


Private Const DIB_RGB_COLORS                    As Long = &H0
Private Const BI_RGB                            As Long = &H0

Private Type SAFEARRAYBOUND
    cElements                                   As Long
    lLbound                                     As Long
End Type

Private Type SAFEARRAYID
    cDims                                       As Integer
    fFeatures                                   As Integer
    cbElements                                  As Long
    cLocks                                      As Long
    pvData                                      As Long
    Bounds                                      As SAFEARRAYBOUND
End Type

Private Type SAFEARRAY2D
    cDims                                       As Integer
    fFeatures                                   As Integer
    cbElements                                  As Long
    cLocks                                      As Long
    pvData                                      As Long
    Bounds(0 To 1)                              As SAFEARRAYBOUND
End Type

Private Type BITMAP
    bmType                                      As Long
    bmWidth                                     As Long
    bmHeight                                    As Long
    bmWidthBytes                                As Long
    bmPlanes                                    As Integer
    bmBitsPixel                                 As Integer
    bmBits                                      As Long
End Type

Private Type BITMAPINFOHEADER
    biSize                                      As Long
    biWidth                                     As Long
    biHeight                                    As Long
    biPlanes                                    As Integer
    biBitCount                                  As Integer
    biCompression                               As Long
    biSizeImage                                 As Long
    biXPelsPerMeter                             As Long
    biYPelsPerMeter                             As Long
    biClrUsed                                   As Long
    biClrImportant  As Long
End Type

Private Type RGBQUAD
    rgbBlue                                     As Byte
    rgbGreen                                    As Byte
    rgbRed                                      As Byte
    rgbReserved                                 As Byte
End Type

Private Type BITMAPINFO
    bmiHeader                                   As BITMAPINFOHEADER
    bmiColors                                   As RGBQUAD
End Type

Private Type GUID
    Data1                                       As Long
    Data2                                       As Integer
    Data3                                       As Integer
    Data4(7)                                    As Byte
End Type


Private Type PICTUREINFO
    Size                                        As Long
    type                                        As Long
    hBmp                                        As Long
    hPal                                        As Long
    reserved                                    As Long
End Type


Private Declare Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" (lpDst As Any, _
                                                                     lpSrc As Any, _
                                                                     ByVal Length As Long)

Private Declare Sub ZeroMemory Lib "kernel32" Alias "RtlZeroMemory" (lpDst As Any, _
                                                                     ByVal Length As Long)

Private Declare Function CreateDCAsNull Lib "gdi32" Alias "CreateDCA" (ByVal lpDriverName As String, _
                                                                       lpDeviceName As Any, _
                                                                       lpOutput As Any, _
                                                                       lpInitData As Any) As Long

Private Declare Function CreateCompatibleDC Lib "gdi32" (ByVal hdc As Long) As Long

Private Declare Function CreateCompatibleBitmap Lib "gdi32" (ByVal hdc As Long, _
                                                             ByVal nWidth As Long, _
                                                             ByVal nHeight As Long) As Long

Private Declare Function DeleteDC Lib "gdi32" (ByVal hdc As Long) As Long

Private Declare Function SelectObject Lib "gdi32" (ByVal hdc As Long, _
                                                   ByVal hObject As Long) As Long

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

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 GetObjectAPI Lib "gdi32" Alias "GetObjectA" (ByVal hObject As Long, _
                                                                      ByVal nCount As Long, _
                                                                      lpObject As Any) As Long

Private Declare Function CreateDIBSection Lib "gdi32" (ByVal hdc As Long, _
                                                       pBitmapInfo As Any, _
                                                       ByVal un As Long, _
                                                       lpVoid As Any, _
                                                       ByVal Handle As Long, _
                                                       ByVal dw As Long) As Long

Private Declare Function VarPtrArray Lib "msvbvm60" Alias "VarPtr" (Ptr() As Any) As Long

Private Declare Function OleCreatePictureIndirect Lib "olepro32.dll" (PicDesc As PICTUREINFO, _
                                                                      RefIID As GUID, _
                                                                      ByVal fPictureOwnsHandle As Long, _
                                                                      IPic As IPicture) As Long

Private m_bUseAlpha                             As Boolean
Private m_bInit                                 As Boolean
Private m_bMono                                 As Boolean
Private m_lHdc                                  As Long
Private m_hBmpOld                               As Long
Private m_hBmp                                  As Long
Private m_lHandle                               As Long
Private m_hDIb                                  As Long
Private m_lpBits                                As Long
Private m_lWidth                                As Long
Private m_lHeight                               As Long
Private m_lSizeX                                As Long
Private m_lSizeY                                As Long
Private m_lDibDC                                As Long
Private m_hDibOld                               As Long
Private m_lPtr                                  As Long
Private m_tBI                                   As BITMAPINFO
Private m_tBIH                                  As BITMAPINFOHEADER


'/* use 32bit image
Public Property Get UseAlpha() As Boolean
    UseAlpha = m_bUseAlpha
End Property

Public Property Let UseAlpha(PropVal As Boolean)
    m_bUseAlpha = PropVal
End Property

Public Property Get hdc() As Long
    hdc = m_lHdc
End Property

Public Property Get Handle() As Long
    Handle = m_hBmp
End Property

Public Property Get Handle32() As Long
    Handle32 = m_lHandle
End Property

Public Property Get Bits() As Long
    Bits = m_lpBits
End Property

Public Property Let Bits(ByVal PropVal As Long)
    m_lpBits = PropVal
End Property

Public Property Get BytesPerScanLine() As Long
    '/* scans must align on dword boundaries m_lDibDC
    BytesPerScanLine = (m_tBI.bmiHeader.biWidth * 3 + 3) And &HFFFFFFFC
End Property

Public Property Get hDib() As Long
    hDib = m_hDIb
End Property

Public Property Get DibDc() As Long
    DibDc = m_lDibDC
End Property

Public Property Get DIBSectionBitsPtr() As Long
    DIBSectionBitsPtr = m_lPtr
End Property

Public Property Get Height() As Long
    Height = m_lHeight
End Property

Public Property Let Height(ByVal lH As Long)
    If lH > m_lHeight Then
        ImageCreate m_lWidth, lH
    End If
End Property

Public Property Get Width() As Long
    Width = m_lWidth
End Property

Public Property Let Width(ByVal lW As Long)
    If lW > m_lWidth Then
        ImageCreate lW, m_lHeight
    End If
End Property

Public Property Get Mono() As Boolean
    Mono = m_bMono
End Property

Public Property Let Mono(ByVal bState As Boolean)

    If Not (m_bMono = bState) Then
        m_bInit = True
    End If
    m_bMono = bState
    
End Property

Public Function ColorizeImage(ByVal lColor As Long, _
                              Optional ByVal lStOveride As Single)

Dim lRed    As Long
Dim lGreen  As Long
Dim lBlue   As Long
Dim lHue    As Single
Dim lSat    As Single
Dim lLum    As Single

    If CreateDIBDc(Width, Height) Then
        LongToRgb lColor, lRed, lGreen, lBlue
        RGBToHLS lRed, lGreen, lBlue, lHue, lSat, lLum
        If Not lStOveride = 0 Then
            Colourise lHue, lStOveride
        Else
            Colourise lHue, lSat
        End If
        BitBlt m_lHdc, 0, 0, Width, Height, m_lDibDC, 0, 0, &HCC0020
    End If
    
End Function

Private Sub Colourise(ByVal fHue As Single, _
                      ByVal fSaturation As Single)

Dim bDib()      As Byte
Dim X           As Long
Dim Y           As Long
Dim xMax        As Long
Dim yMax        As Long
Dim lb          As Long
Dim lg          As Long
Dim lR          As Long
Dim h           As Single
Dim s           As Single
Dim l           As Single
Dim tSA         As SAFEARRAY2D
    
    '/* fHue runs from -1 to 5...
    '/* have the local matrix point to bitmap pixels
    With tSA
        .cbElements = 1
        .cDims = 2
        .Bounds(0).lLbound = 0
        .Bounds(0).cElements = Height
        .Bounds(1).lLbound = 0
        .Bounds(1).cElements = BytesPerScanLine
        .pvData = DIBSectionBitsPtr
    End With
    CopyMemory ByVal VarPtrArray(bDib), VarPtr(tSA), 4
        
    yMax = Height - 1
    xMax = Width - 1

    For X = 0 To (xMax * 3) Step 3
        For Y = 0 To yMax
            RGBToHLS bDib(X + 2, Y), bDib(X + 1, Y), bDib(X, Y), h, s, l
            s = fSaturation
            h = fHue
            HLSToRGB h, s, l, lR, lg, lb
            bDib(X, Y) = lb
            bDib(X + 1, Y) = lg
            bDib(X + 2, Y) = lR
        Next Y
    Next X
    CopyMemory ByVal VarPtrArray(bDib), 0&, 4
    
End Sub

Private Function ConvertTo32(ByVal lHsource As Long, _
                             ByRef tBmp As BITMAP, _
                             ByRef gAlpha As Byte) As Long

Dim aSBits()    As Byte
Dim i           As Long
Dim lHDC        As Long
Dim lhDIB       As Long
Dim hDIBold     As Long
Dim thDC        As Long
Dim tOldBmp     As Long
Dim uBIH        As BITMAPINFOHEADER
Dim uSSA        As SAFEARRAYID

    With uBIH
        .biBitCount = 32
        .biHeight = tBmp.bmHeight
        .biWidth = tBmp.bmWidth
        .biPlanes = 1
        .biSize = Len(uBIH)
    End With
    
    '/* create dib section
    With tBmp
        .bmWidthBytes = 4 * .bmWidth
    End With
    lHDC = CreateCompatibleDC(0)
    If lHDC = 0 Then Exit Function
    lhDIB = CreateDIBSection(lHDC, uBIH, DIB_RGB_COLORS, tBmp.bmBits, 0&, 0&)
    If lhDIB = 0 Then Exit Function
    m_lpBits = tBmp.bmBits
    
    thDC = CreateCompatibleDC(0)
    If thDC = 0 Then
        DeleteObject lhDIB
        lhDIB = 0
    Else
        hDIBold = SelectObject(lHDC, lhDIB)
        tOldBmp = SelectObject(thDC, lHsource)
        With tBmp
            BitBlt lHDC, 0&, 0&, .bmWidth, .bmHeight, thDC, 0&, 0&, vbSrcCopy
        End With
        '/* clean up
        SelectObject lHDC, hDIBold
        SelectObject thDC, tOldBmp
        DeleteDC thDC
        '/* build to 32bit
        If Not tBmp.bmBitsPixel = 32 Then
            With tBmp
                MapDIBits uSSA, aSBits(), .bmBits, .bmWidthBytes * .bmHeight
            End With
            For i = 3 To UBound(aSBits) Step 4
                aSBits(i) = gAlpha
            Next
            Call UnmapDIBits(aSBits)
            gAlpha = 255
        End If
    End If

    DeleteDC lHDC
    ConvertTo32 = lhDIB
    
End Function

Public Function CreateBitmap(ByVal hBmp As Long, _
                             Optional ByVal hPal As Long = 0) As Picture

Dim R               As Long
Dim Pic             As PICTUREINFO
Dim IPic            As IPicture
Dim IID_IDispatch   As GUID

    'Fill GUID info
    With IID_IDispatch
        .Data1 = &H20400
        .Data4(0) = &HC0
        .Data4(7) = &H46
    End With

    'Fill picture info
    With Pic
        .Size = Len(Pic) ' Length of structure
        .type = vbPicTypeBitmap ' Type of Picture (bitmap)
        .hBmp = hBmp ' Handle to bitmap
        .hPal = hPal ' Handle to palette (may be null)
    End With

    'Create the picture
    R = OleCreatePictureIndirect(Pic, IID_IDispatch, 1, IPic)
    'Return the new picture
    Set CreateBitmap = IPic

End Function

Public Function CreateDIBDc(ByVal lWidth As Long, _