clsrender.cls

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

    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
        If Not CreateDc(True, lMaskDc, lTmpMaskBmp, lTmpMaskBmpOld, lSrcWidth, lSrcHeight) Then
            If Not CreateDc(False, lTempDc, lTmpBmp, lTmpBmpOld, lDstWidth, lDstHeight) Then
                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
            End If
        End If
    End If

    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 lWidth As Long, _
                    ByVal lTop As Long, _
                    ByVal lHeight 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

    '/* Init vertices : Set Position : Define Size
    With tVert(0)
        If bJuxtapose Then
            .x = lLeft
            .y = lTop
        Else
            .x = lLeft + lWidth
            .y = lTop + lHeight
        End If
    End With
    With tVert(1)
        If bJuxtapose Then
            .x = lLeft + lWidth
            .y = lTop + lHeight
        Else
            .x = lLeft
            .y = lTop
        End If
    End With
        
    '/* 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

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