clsrender.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 = "clsRender"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = False
Attribute VB_Exposed = False
Option Explicit


Private Const VER_PLATFORM_WIN32s               As Long = 0
Private Const VER_PLATFORM_WIN32_WINDOWS        As Long = 1
Private Const VER_PLATFORM_WIN32_NT             As Long = 2
Private Const ICC_USEREX_CLASSES                As Long = &H200
Private Const AC_SRC_OVER                       As Long = &H0
Private Const AC_SRC_ALPHA                      As Long = &H1

Private Const AC_SRC_NO_PREMULT_ALPHA           As Long = &H1
Private Const AC_SRC_NO_ALPHA                   As Long = &H2
Private Const C_DST_NO_PREMULT_ALPHA            As Long = &H10
Private Const AC_DST_NO_ALPHA                   As Long = &H20

'/* StretchBlt Modes
Private Const BLACKONWHITE                      As Long = 1
Private Const WHITEONBLACK                      As Long = 2
Private Const COLORONCOLOR                      As Long = 3
Private Const HALFTONE                          As Long = 4
Private Const MAXSTRETCHBLTMODE                 As Long = 4

'/* New StretchBlt Modes
Private Const STRETCH_ANDSCANS                  As Long = BLACKONWHITE
Private Const STRETCH_ORSCANS                   As Long = WHITEONBLACK
Private Const STRETCH_DELETESCANS               As Long = COLORONCOLOR
Private Const STRETCH_HALFTONE                  As Long = HALFTONE

Private Type VERSIONINFO
    dwOSVersionInfoSize                         As Long
    dwMajorVersion                              As Long
    dwMinorVersion                              As Long
    dwBuildNumber                               As Long
    dwPlatformId                                As Long
    szCSDVersion                                As String * 128
End Type

Private Type TRIVERTEX
    x                                           As Long
    y                                           As Long
    Red                                         As Integer
    Green                                       As Integer
    Blue                                        As Integer
    alpha                                       As Integer
End Type

Private Type BLENDFUNCTION
    BlendOp                                     As Byte
    BlendFlags                                  As Byte
    SourceConstantAlpha                         As Byte
    AlphaFormat                                 As Byte
End Type

Private Type PICTDESC
    cbSize                                      As Long
    pictType                                    As Long
    hIcon                                       As Long
    hPal                                        As Long
End Type

Public Enum RAST_FLAGS
    SRCCOPY = &HCC0020
    SRCPAINT = &HEE0086
    SRCAND = &H8800C6
    SRCINVERT = &H660046
    SRCERASE = &H440328
    NOTSRCCOPY = &H330008
    NOTSRCERASE = &H1100A6
    MERGECOPY = &HC000CA
    MERGEPAINT = &HBB0226
    PATCOPYX = &HF00021
    PATPAINT = &HFB0A09
    PATINVERT = &H5A0049
    DSTINVERT = &H550009
    BLACKNESS = &H42
    WHITENESS = &HFF0062
End Enum

Private Type GRADIENT_RECT
    UpperLeft As Long
    LowerRight As Long
End Type

Public Enum GRADIENT_DIRECTION
    Fill_None = -1
    Fill_Horizontal = 0
    Fill_Vertical = 1
End Enum

Private Declare Function AlphaBlend Lib "Msimg32.dll" (ByVal DstHdc As Long, _
                                                       ByVal DstX As Long, _
                                                       ByVal DstY As Long, _
                                                       ByVal DstWidth As Long, _
                                                       ByVal DstHeight As Long, _
                                                       ByVal SrcHdc As Long, _
                                                       ByVal SrcX As Long, _
                                                       ByVal SrcY As Long, _
                                                       ByVal SrcWidth As Long, _
                                                       ByVal ScrHeight As Long, _
                                                       ByVal lpBlend As Long) As Long

Private Declare Function BitBlt Lib "gdi32" (ByVal DstHdc As Long, _
                                             ByVal DstX As Long, _
                                             ByVal DstY As Long, _
                                             ByVal DstWidth As Long, _
                                             ByVal DstHeight As Long, _
                                             ByVal SrcHdc As Long, _
                                             ByVal SrcX As Long, _
                                             ByVal SrcY As Long, _
                                             ByVal dwRop As RAST_FLAGS) As Long

Private Declare Function StretchBlt Lib "gdi32.dll" (ByVal DstHdc As Long, _
                                                     ByVal DstX As Long, _
                                                     ByVal DstY As Long, _
                                                     ByVal DstWidth As Long, _
                                                     ByVal DstHeight As Long, _
                                                     ByVal SrcHdc As Long, _
                                                     ByVal SrcX As Long, _
                                                     ByVal SrcY As Long, _
                                                     ByVal nSrcWidth As Long, _
                                                     ByVal nSrcHeight As Long, _
                                                     ByVal dwRop As RAST_FLAGS) As Long

Private Declare Function TransparentBlt Lib "Msimg32.dll" (ByVal DstHdc As Long, _
                                                           ByVal DstX As Long, _
                                                           ByVal DstY As Long, _
                                                           ByVal DstWidth As Long, _
                                                           ByVal DstHeight As Long, _
                                                           ByVal SrcHdc As Long, _
                                                           ByVal SrcX As Long, _
                                                           ByVal SrcY As Long, _
                                                           ByVal SrcWidth As Long, _
                                                           ByVal ScrHeight As Long, _
                                                           ByVal crTransparent As Long) As Boolean

Private Declare Function GradientFill Lib "Msimg32.dll" (ByVal hdc As Long, _
                                                         pVertex As TRIVERTEX, _
                                                         ByVal dwNumVertex As Long, _
                                                         pMesh As GRADIENT_RECT, _
                                                         ByVal dwNumMesh As Long, _
                                                         ByVal dwMode As Long) As Long

Private Declare Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" (pDest As Any, _
                                                                     pSrc As Any, _
                                                                     ByVal ByteLen As Long)

Private Declare Function ReleaseDC Lib "USER32" (ByVal hWnd As Long, _
                                                 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 OleTranslateColor Lib "olepro32" (ByVal OLE_COLOR As Long, _
                                                           ByVal HPALETTE As Long, _
                                                           ColorRef As Long) As Long

Private Declare Function SetBrushOrgEx Lib "gdi32" (ByVal hdc As Long, _
                                                    ByVal nXOrg As Long, _
                                                    ByVal nYOrg As Long, _
                                                    lppt As Any) As Long

Private Declare Function GetVersionEx Lib "kernel32" Alias "GetVersionExA" (lpVersion As VERSIONINFO) As Long

Private Declare Function SetBkColor Lib "gdi32" (ByVal hdc As Long, _
                                                 ByVal crColor As Long) 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 GetDC Lib "USER32" (ByVal hWnd As Long) As Long

Private Declare Function GetDesktopWindow Lib "USER32" () As Long

Private Declare Function GetPixel Lib "gdi32" (ByVal hdc As Long, _
                                               ByVal x As Long, _
                                               ByVal y As Long) As Long

Private Declare Function OleCreatePictureIndirect Lib "olepro32.dll" (lpPictDesc As PICTDESC, _
                                                                      riid As Any, _
                                                                      ByVal fOwn As Long, _
                                                                      IPic As IPicture) As Long

Private m_bWin32        As Boolean
Private m_lMaskColor    As Long


Private Sub Class_Initialize()

    '/* os check & default mask
    m_bWin32 = Compatability_Check
    m_lMaskColor = &HFF00FF

End Sub

Public Property Get Mask() As Long
    Mask = m_lMaskColor
End Property

Public Property Let Mask(PropVal As Long)
    m_lMaskColor = PropVal
End Property

Public Sub AlphaBlit(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 lTrsIdx As Byte)

 
 Dim tBlend     As BLENDFUNCTION
 Dim lBfPtr     As Long

    If (lTrsIdx = 0) Or (lTrsIdx > 255) Then
        lTrsIdx = 200
    End If
    With tBlend
        .BlendOp = AC_SRC_OVER
        .BlendFlags = 0
        .SourceConstantAlpha = lTrsIdx
        .AlphaFormat = 0
    End With
    
    CopyMemory lBfPtr, tBlend, 4
    AlphaBlend lDstDc, lDstX, lDstY, lDstWidth, lDstHeight, lSrcDc, lSrcX, lSrcY, lSrcWidth, lSrcHeight, lBfPtr
    
End Sub

Public Sub AlphaPixel(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 lTrsIdx As Long)

 Dim tBlend     As BLENDFUNCTION
 Dim lBfPtr     As Long

    If (lTrsIdx = 0) Or (lTrsIdx > 255) Then
        lTrsIdx = 200
    End If
    With tBlend
        .BlendOp = AC_SRC_OVER
        .BlendFlags = 0
        .SourceConstantAlpha = lTrsIdx
        .AlphaFormat = AC_SRC_ALPHA
    End With
    
    CopyMemory lBfPtr, tBlend, 4
    AlphaBlend lDstDc, lDstX, lDstY, lDstWidth, lDstHeight, lSrcDc, lSrcX, lSrcY, lSrcWidth, lSrcHeight, lBfPtr

End Sub

Public Property Get BlendColor(ByVal oColorFrom As OLE_COLOR, _
                               ByVal oColorTo As OLE_COLOR, _
                               Optional ByVal lAlpha As Long = 128) As Long

Dim lCFrom As Long
Dim lCTo   As Long
Dim lSrcR  As Long
Dim lSrcG  As Long
Dim lSrcB  As Long
Dim lDstR  As Long
Dim lDstG  As Long
Dim lDstB  As Long

    lCFrom = TranslateColor(oColorFrom)
    lCTo = TranslateColor(oColorTo)
    lSrcR = lCFrom And &HFF
    lSrcG = (lCFrom And &HFF00&) \ &H100&
    lSrcB = (lCFrom And &HFF0000) \ &H10000
    lDstR = lCTo And &HFF
    lDstG = (lCTo And &HFF00&) \ &H100&
    lDstB = (lCTo And &HFF0000) \ &H10000

    BlendColor = RGB(((lSrcR * lAlpha) / 255) + ((lDstR * (255 - lAlpha)) / 255), ((lSrcG * lAlpha) / 255) + ((lDstG * (255 - lAlpha)) / 255), ((lSrcB * lAlpha) / 255) + ((lDstB * (255 - lAlpha)) / 255))

End Property

Public Sub Blit(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 eFlags As RAST_FLAGS)


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

End Sub


Public Function IconToPicture(ByVal lhIcon As Long) As Picture

Dim Pic             As PICTDESC
Dim GUID(0 To 3)    As Long

    With Pic
        .cbSize = Len(Pic)
        .pictType = vbPicTypeIcon
        .hIcon = lhIcon
    End With
    GUID(0) = &H7BF80980
    GUID(1) = &H101ABF32
    GUID(2) = &HAA00BB8B
    GUID(3) = &HAB0C3000
    OleCreatePictureIndirect Pic, GUID(0), True, IconToPicture

End Function


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)