clsrender.cls

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

                ByVal lSrcY As Long, _
                ByVal eFlags As RAST_FLAGS)


    BitBlt lDstDc, lDstX, lDstY, lDstWidth, lDstHeight, lSrcDc, lSrcX, lSrcY, eFlags

End Sub

Public Sub Stretch(ByVal lDstDc As Long, _
                   ByVal lDstX As Long, _
                   ByVal lDstY As Long, _
                   ByVal lDstWidth As Long, _
                   ByVal lDstHeight As Long, _
                   ByVal lSrcDc As Long, _
                   ByVal lSrcX As Long, _
                   ByVal lSrcY As Long, _
                   ByVal lSrcWidth As Long, _
                   ByVal lSrcHeight As Long, _
                   ByVal eFlags As RAST_FLAGS, _
                   Optional ByVal bPrsClr As Boolean)

    If Not bPrsClr Then
        StretchBlt lDstDc, lDstX, lDstY, lDstWidth, lDstHeight, lSrcDc, lSrcX, lSrcY, lSrcWidth, lSrcHeight, eFlags
    Else
        StretchBlt lDstDc, lDstX, lDstY, lDstWidth, lDstHeight, lSrcDc, lSrcX, lSrcY, lSrcWidth, lSrcHeight, eFlags
    End If

End Sub

Public Sub Transparent(ByVal lDstDc As Long, _
                       ByVal lDstX As Long, _
                       ByVal lDstY As Long, _
                       ByVal lDstWidth As Long, _
                       ByVal lDstHeight As Long, _
                       ByVal lSrcDc As Long, _
                       ByVal lSrcX As Long, _
                       ByVal lSrcY As Long, _
                       ByVal lSrcWidth As Long, _
                       ByVal lSrcHeight As Long, _
                       ByVal lTrsColor As Long, _
                       Optional ByVal bRemapTrans As Boolean)


    If bRemapTrans Then
        lTrsColor = RemapTrans(lSrcDc, lSrcX, lSrcY)
    End If
    If m_bWin32 Then
        TransparentBlt lDstDc, lDstX, lDstY, lDstWidth, lDstHeight, lSrcDc, lSrcX, lSrcY, lSrcWidth, lSrcHeight, lTrsColor
    Else
        TransMask lDstDc, lDstX, lDstY, lDstWidth, lDstHeight, lSrcDc, lSrcX, lSrcY, lSrcWidth, lSrcHeight, lTrsColor
    End If

End Sub

Public Function TransMask(ByVal lDstDc As Long, _
                          ByVal lDstX As Long, _
                          ByVal lDstY As Long, _
                          ByVal lDstWidth As Long, _
                          ByVal lDstHeight As Long, _
                          ByVal lSrcDc As Long, _
                          ByVal lSrcX As Long, _
                          ByVal lSrcY As Long, _
                          ByVal lSrcWidth As Long, _
                          ByVal lSrcHeight As Long, _
                          ByVal lTrsColor As Long) As Boolean

Dim lColor              As Long
Dim lTempMaskDc         As Long
Dim lMaskDc             As Long
Dim lTempDc             As Long
Dim lTrsDc              As Long
Dim lMaskBmp            As Long
Dim lMaskBmpOld         As Long
Dim lTmpMaskBmp         As Long
Dim lTmpMaskBmpOld      As Long
Dim lTmpBmp             As Long
Dim lTmpBmpOld          As Long
Dim lTrsBmp             As Long
Dim lTrsBmpOld          As Long
    
    If Not CreateDc(False, lTempMaskDc, lMaskBmp, lMaskBmpOld, lSrcWidth, lSrcHeight) Then GoTo Handler
    If Not CreateDc(True, lMaskDc, lTmpMaskBmp, lTmpMaskBmpOld, lSrcWidth, lSrcHeight) Then GoTo Handler
    If Not CreateDc(False, lTempDc, lTmpBmp, lTmpBmpOld, lDstWidth, lDstHeight) Then GoTo Handler
    
    BitBlt lTempMaskDc, 0&, 0&, lSrcWidth, lSrcHeight, lSrcDc, lSrcX, lSrcY, SRCCOPY
    If lTrsColor = &HFFFFFF Then
        BitBlt lMaskDc, 0&, 0&, lSrcWidth, lSrcHeight, lTempMaskDc, 0&, 0&, WHITENESS
        BitBlt lMaskDc, 0&, 0&, lSrcWidth, lSrcHeight, lTempMaskDc, 0&, 0&, SRCINVERT
    Else
        If CreateDc(True, lTrsDc, lTrsBmp, lTrsBmpOld, lSrcWidth, lSrcHeight) Then
            lColor = SetBkColor(lTempMaskDc, lTrsColor)
            BitBlt lTrsDc, 0&, 0&, lSrcWidth, lSrcHeight, lTempMaskDc, 0&, 0&, SRCCOPY
            SetBkColor lTempMaskDc, lColor
            BitBlt lTempMaskDc, 0&, 0&, lSrcWidth, lSrcHeight, lTrsDc, 0&, 0&, SRCPAINT
            BitBlt lMaskDc, 0&, 0&, lSrcWidth, lSrcHeight, lTempMaskDc, 0&, 0&, WHITENESS
            BitBlt lMaskDc, 0&, 0&, lSrcWidth, lSrcHeight, lTrsDc, 0&, 0&, SRCINVERT
            SelectObject lTrsDc, lTrsBmpOld
            DeleteObject lTrsBmp
            lTrsBmp = 0
            DeleteObject lTrsDc
            lTrsDc = 0
        End If
    End If
                
    BitBlt lTempDc, 0&, 0&, lDstWidth, lDstHeight, lDstDc, lDstX, lDstY, SRCCOPY
    If Not lSrcWidth = lDstWidth Or Not lSrcHeight = lDstHeight Then
        StretchBlt lTempDc, 0&, 0&, lDstWidth, lDstHeight, lMaskDc, 0&, 0&, lSrcWidth, lSrcHeight, SRCPAINT
        StretchBlt lTempDc, 0&, 0&, lDstWidth, lDstHeight, lTempMaskDc, 0&, 0&, lSrcWidth, lSrcHeight, SRCAND
    Else
        BitBlt lTempDc, 0&, 0&, lSrcWidth, lSrcHeight, lMaskDc, 0&, 0&, SRCPAINT
        BitBlt lTempDc, 0&, 0&, lSrcWidth, lSrcHeight, lTempMaskDc, 0&, 0&, SRCAND
    End If
                
    If Not BitBlt(lDstDc, lDstX, lDstY, lDstWidth, lDstHeight, lTempDc, 0&, 0&, SRCCOPY) = 0 Then
        TransMask = True
    End If
                  
On Error GoTo 0

Handler:
    If Not lTempDc = 0 Then
        SelectObject lTempDc, lTmpBmpOld
        DeleteObject lTmpBmp
        DeleteObject lTempDc
    End If
    
    If Not lMaskDc = 0 Then
        SelectObject lMaskDc, lTmpMaskBmpOld
        DeleteObject lTmpMaskBmp
        DeleteObject lMaskDc
    End If
    
    If Not lTempMaskDc = 0 Then
        SelectObject lTempMaskDc, lMaskBmpOld
        DeleteObject lMaskBmp
        DeleteObject lTempMaskDc
    End If
    
End Function

Public Sub Tile(ByVal lDstDc As Long, _
                ByVal lDstX As Long, _
                ByVal lDstY As Long, _
                ByVal lDstWidth As Long, _
                ByVal lDstHeight As Long, _
                ByVal lSrcDc As Long, _
                ByVal lSrcWidth As Long, _
                ByVal lSrcHeight As Long, _
                Optional ByVal lOffsetX As Long, _
                Optional ByVal lOffsetY As Long)

Dim SrcWidth            As Long
Dim SrcHeight           As Long
Dim lSrcX               As Long
Dim lSrcY               As Long
Dim lSrcStartX          As Long
Dim lSrcStartY          As Long
Dim lSrcStartWidth      As Long
Dim lSrcStartHeight     As Long
Dim lNDestX             As Long
Dim lNDestY             As Long
Dim lNDestWidth         As Long
Dim lNDestHeight        As Long

    SrcWidth = lSrcWidth
    SrcHeight = lSrcHeight
    lSrcStartX = ((lDstX + lOffsetX) Mod SrcWidth)
    lSrcStartY = ((lDstY + lOffsetY) Mod SrcHeight)
    lSrcStartWidth = (SrcWidth - lSrcStartX)
    lSrcStartHeight = (SrcHeight - lSrcStartY)
    lSrcX = lSrcStartX
    lSrcY = lSrcStartY
    lNDestY = lDstY
    lNDestHeight = lSrcStartHeight

    Do While lNDestY < (lDstY + lDstHeight)
        If (lNDestY + lNDestHeight) > (lDstY + lDstHeight) Then
            lNDestHeight = lDstY + lDstHeight - lNDestY
        End If
        lNDestWidth = lSrcStartWidth
        lNDestX = lDstX
        lSrcX = lSrcStartX
        Do While lNDestX < (lDstX + lDstWidth)
            If (lNDestX + lNDestWidth) > (lDstX + lDstWidth) Then
                lNDestWidth = lDstX + lDstWidth - lNDestX
                If lNDestWidth = 0 Then
                    lNDestWidth = 4
                End If
            End If
            Blit lDstDc, lNDestX, lNDestY, lNDestWidth, lNDestHeight, lSrcDc, lSrcX, lSrcY, vbSrcCopy
            lNDestX = lNDestX + lNDestWidth
            lSrcX = 0
            lNDestWidth = SrcWidth
        Loop
        lNDestY = lNDestY + lNDestHeight
        lSrcY = 0
        lNDestHeight = SrcHeight
    Loop

End Sub

Private Function CreateDc(ByVal bMono As Boolean, _
                          ByRef lHdc As Long, _
                          ByRef lBitmap As Long, _
                          ByRef lBitmapOld As Long, _
                          ByVal lWidth As Long, _
                          ByVal lHeight As Long) As Boolean
  
Dim lWndDc  As Long
Dim lHwnd   As Long

    lHdc = 0
    lBitmap = 0
    lBitmapOld = 0

    If bMono Then
        lWndDc = 0
    Else
        lHwnd = GetDesktopWindow
        lWndDc = GetDC(lHwnd)
    End If
    lHdc = CreateCompatibleDC(lWndDc)
    If bMono Then
        lWndDc = lHdc
    End If
    
    If Not lHdc = 0 Then
        lBitmap = CreateCompatibleBitmap(lWndDc, lWidth, lHeight)
        If Not lBitmap = 0 Then
            lBitmapOld = SelectObject(lHdc, lBitmap)
            CreateDc = True
        End If
    End If

    If Not bMono Then
        ReleaseDC lHwnd, lWndDc
    End If

End Function

Public Sub Gradient(ByVal lHdc As Long, _
                    ByVal lLeft As Long, _
                    ByVal lRight As Long, _
                    ByVal lTop As Long, _
                    ByVal lBottom As Long, _
                    ByVal lStartColor As Long, _
                    ByVal lEndColor As Long, _
                    ByVal eDirection As GRADIENT_DIRECTION, _
                    Optional ByVal bJuxtapose As Boolean)

Dim btClrs(3)           As Byte
Dim btVert(7)           As Byte
Dim tGradRect           As GRADIENT_RECT
Dim tVert(1)            As TRIVERTEX

On Error GoTo Handler
    
    '/* Check If the Fill is From Left to Right
    If bJuxtapose Then
        '/* Init vertices : Set Position : Define Size
        tVert(0).x = lLeft: tVert(1).x = lLeft + lRight
        tVert(0).y = lTop: tVert(1).y = lTop + lBottom
    Else
        '/* Init vertices : Set Position : Define Size
        tVert(0).x = lLeft + lRight: tVert(1).x = lLeft
        tVert(0).y = lTop + lBottom: tVert(1).y = lTop
    End If
        
    '/* Init vertices :colors, initial
    CopyMemory btClrs(0), lEndColor, &H4
    '/* Red
    btVert(1) = btClrs(0)
    '/* Green
    btVert(3) = btClrs(1)
    '/* Blue
    btVert(5) = btClrs(2)
    CopyMemory tVert(0).Red, btVert(0), &H8
    '/* Init vertices :colors, final
    CopyMemory btClrs(0), lStartColor, &H4
    '/* Red
    btVert(1) = btClrs(0)
    '/* Green
    btVert(3) = btClrs(1)
    '/* Blue
    btVert(5) = btClrs(2)
    CopyMemory tVert(1).Red, btVert(0), &H8
    '/* Init gradient rect
    With tGradRect
        .UpperLeft = 0
        .LowerRight = 1
    End With
    '/* Fill the DC
    GradientFill lHdc, tVert(0), 2, tGradRect, 1, eDirection
    
Handler:
    On Error GoTo 0

End Sub

Public Function XPShift(ByVal lColor As Long, _
                        Optional ByVal Base As Long = &HB0) As Long

Dim lRed        As Long
Dim lBlue       As Long
Dim lGreen      As Long
Dim lDelta      As Long

    lBlue = ((lColor \ &H10000) Mod &H100)
    lGreen = ((lColor \ &H100) Mod &H100)
    lRed = (lColor And &HFF)
    lDelta = &HFF - Base

    lBlue = Base + lBlue * lDelta \ &HFF
    lGreen = Base + lGreen * lDelta \ &HFF
    lRed = Base + lRed * lDelta \ &HFF

    If lRed > 255 Then lRed = 255
    If lGreen > 255 Then lGreen = 255
    If lBlue > 255 Then lBlue = 255

    XPShift = lRed + 256& * lGreen + 65536 * lBlue

End Function

Public Function TranslateColor(ByVal oColor As OLE_COLOR, _
                               Optional ByVal lhPal As Long = 0) As Long
                        
    If OleTranslateColor(oColor, lhPal, TranslateColor) Then
        TranslateColor = -1
    End If
    
End Function

Private Function RemapTrans(ByVal lHdc As Long, _
                            ByVal lSrcX As Long, _
                            ByVal lSrcY As Long) As Long

    RemapTrans = GetPixel(lHdc, lSrcX, lSrcY)
    
End Function

Public Sub SetBrushOrigin(ByVal hdc As Long, _
                          ByVal xPixels As Long, _
                          ByVal yPixels As Long, _
                          ByVal lWidth As Long, _
                          ByVal lHeight As Long)

   SetBrushOrgEx hdc, -xPixels And lWidth, -yPixels And lHeight, ByVal 0&
   
End Sub

Public Function GetBlendVal(ByVal sTransparency As Single) As Long

  If sTransparency < 0 Then sTransparency = 0
  If sTransparency > 250 Then sTransparency = 255
  GetBlendVal = CLng(sTransparency / 100 * 255) * &H10000
  
End Function

Private Function Compatability_Check() As Boolean

Dim tVer  As VERSIONINFO

    tVer.dwOSVersionInfoSize = Len(tVer)
    GetVersionEx tVer
    If tVer.dwMajorVersion >= 5 Then
        Compatability_Check = True
    End If

End Function