clsmemdc.cls

VB做的报表设计源程序,非常不错,可以自定义模版

Public Sub DrawPicture(oPicture As StdPicture, lLeft As Long, lTop As Long, _
    lWidth As Long, lHeight As Long, Optional bKeepRatio As Boolean = True, _
    Optional bVCenter As Boolean = True, Optional bHCenter As Boolean = True)
    On Error GoTo ERR_H
    Dim LhDCTemp As Long
    Dim LhOldPalette As Long
    Dim LhOldBitmap As Long
    Dim LrPoint As POINTAPI
    Dim LrReal As RECT
    
#Const USE_PALETTE = True
#Const USE_DISPLAY = False
#Const USE_BITBLT = True
#Const USE_BKMODE = False
#Const USE_HALFTONE = False
'    Dim LnOrigW As Long
'    Dim LnOrigH As Long
    Dim LrBitmap As BITMAP
    #If USE_HALFTONE Then
    Dim LnOldStrMode As Long
    #End If
    'Validate that a bitmap was passed in
    If oPicture.Type = vbPicTypeBitmap Then
        With oPicture
            ' get bitmap info
            GetObject .Handle, Len(LrBitmap), LrBitmap   'dest
            'Create a DC to select bitmap into
            #If USE_DISPLAY Then
            Dim LhDC As Long
            LhDC = CreateDCAsNull("DISPLAY", ByVal 0&, ByVal 0&, ByVal 0&)
            LhDCTemp = CreateCompatibleDC(LhDC)
            DeleteDC LhDC
            #Else
            LhDCTemp = CreateCompatibleDC(m_hWorkDC)
            #End If
            #If USE_PALETTE Then
            LhOldPalette = SelectPalette(LhDCTemp, .hPal, True)
            RealizePalette LhDCTemp
            #End If
            'Select bitmap into DC
            LhOldBitmap = SelectObject(LhDCTemp, .Handle)
        End With
        #If USE_BITBLT Then
        If ((lWidth = LrBitmap.bmWidth) And (lHeight = LrBitmap.bmHeight)) Then
            #If USE_HALFTONE Then
            LnOldStrMode = SetStretchBltMode(m_hWorkDC, HALFTONE)
            #End If
            BitBlt m_hWorkDC, lLeft, lTop, lWidth, lHeight, LhDCTemp, 0, 0, SRCCOPY
            #If USE_HALFTONE Then
            LnOldStrMode = SetStretchBltMode(m_hWorkDC, LnOldStrMode)
            #End If
        Else
        #Else
        If True Then
        #End If
            With LrReal
                If bKeepRatio Then
                    Dim LnRatio As Single
                    Dim LnDrwRatio As Single
                    Dim LnImgRatio As Single
                    
                    With LrBitmap
                        LnDrwRatio = (lHeight / lWidth)
                        LnImgRatio = (.bmHeight / .bmWidth)
                        If (LnDrwRatio > LnImgRatio) Then
                            LnRatio = (lWidth / .bmWidth)
                        Else
                            LnRatio = (lHeight / .bmHeight)
                        End If
                    End With
                    ' Used for width & height
                    .Right = (LrBitmap.bmWidth * LnRatio)
                    .Bottom = (LrBitmap.bmHeight * LnRatio)
                    ' Left & Top positions
                    If bHCenter Then
                        .Left = (lLeft + ((lWidth - .Right) / 2))
                    Else
                        .Left = lLeft
                    End If
                    If bVCenter Then
                        .Top = (lTop + ((lHeight - .Bottom) / 2))
                    Else
                        .Top = lTop
                    End If
                Else
                    .Left = lLeft
                    .Top = lTop
                    ' Used for width & height
                    .Right = lWidth
                    .Bottom = lHeight
                End If
                'Copy to destination DC
                #If USE_BKMODE Then
                Dim LnOldBkColor As Long
                LnOldBkColor = SetBkColor(m_hWorkDC, 0&)
                #End If
                #If USE_HALFTONE Then
                LnOldStrMode = SetStretchBltMode(m_hWorkDC, HALFTONE)
                #End If
                Call SetBrushOrgEx(m_hWorkDC, 0, 0, LrPoint)
                Call StretchBlt(m_hWorkDC, .Left, .Top, .Right, .Bottom, LhDCTemp, 0, 0, LrBitmap.bmWidth, LrBitmap.bmHeight, SRCCOPY)
                #If USE_BKMODE Then
                LnOldBkColor = SetBkColor(m_hWorkDC, LnOldBkColor)
                #End If
                #If USE_HALFTONE Then
                LnOldStrMode = SetStretchBltMode(m_hWorkDC, LnOldStrMode)
                #End If
            End With
        End If
        'Cleanup
        SelectObject LhDCTemp, LhOldBitmap
        #If USE_PALETTE Then
        SelectPalette LhDCTemp, LhOldPalette, True
        RealizePalette LhDCTemp
        #End If
        DeleteDC LhDCTemp
    Else
        Me.RaiseErr ecInvalidObjType, "DrawPicture", "Invalid picture format."
    End If
    Exit Sub
ERR_H:
    Me.RaiseErr Err.Number, "DrawPicture"
End Sub

Friend Sub Cls()
    Dim r As RECT
    Dim lOldBackColor As Long
    Dim lBackColor As Long
'   ***** puts the dimensions into a rect structure
    r.Left = 0
    r.Top = 0
    r.Bottom = m_lHeight
    r.Right = m_lWidth
'   *****
    lOldBackColor = SetBkColor(m_hWorkDC, BackColor) ' set the back color of the dc
    ' fills the rect with the back color. Using ExtTextOut (without text) is quicker than FillRect
    ExtTextOut m_hWorkDC, 0, 0, ETO_CLIPPED Or ETO_OPAQUE, r, "", 0, 0
    SetBkColor m_hWorkDC, lOldBackColor ' reset the old backcolor
End Sub


Public Property Get hDC() As Long
   hDC = m_hWorkDC
End Property

Public Sub SetFont(sFaceName As String, nSize As Single, Optional bBold As Boolean, _
    Optional bItalic As Boolean, Optional bStrikeOut As Boolean, Optional bUnderline As Boolean, _
    Optional iRotation As Integer = 0)
    Dim LrFont As LOGFONT
    Dim LaTempArray() As Byte ' byte array to hold the fontname
    Dim LnIdx As Integer
    Dim LhFont As Long
    
    ' Restores original font
    If (Not (m_lOldFont = 0)) Then
        SelectObject m_hWorkDC, m_lOldFont
        m_lOldFont = 0
    End If
    With LrFont
        ' All but two properties are very straight-forward,
        ' even with rotation, and map directly.
        .lfHeight = -(nSize * GetDeviceCaps(m_hWorkDC, LOGPIXELSY)) / TWIPS_PER_POINT
        .lfWidth = 0
        .lfEscapement = (iRotation * 10)
        .lfOrientation = .lfEscapement
        If bBold Then ' if true set the weight to the appropriate value
            .lfWeight = FW_BOLD
        Else
            .lfWeight = FW_NORMAL
        End If
        .lfItalic = Abs(bItalic)
        .lfUnderline = Abs(bUnderline)
        .lfStrikeOut = Abs(bStrikeOut)
        .lfClipPrecision = CLIP_DEFAULT_PRECIS
        .lfQuality = PROOF_QUALITY
        .lfPitchAndFamily = DEFAULT_PITCH Or FF_DONTCARE
        ' OEM fonts can't rotate, and we must force
        ' substitution with something ANSI.
        .lfCharSet = DEFAULT_CHARSET
        If .lfCharSet = OEM_CHARSET Then
            If (iRotation <> 0) Then
                .lfCharSet = ANSI_CHARSET
            End If
        End If
        ' Only TrueType fonts can rotate, so we must
        ' specify TT-only if angle is not zero.
        If (iRotation <> 0) Then
            .lfOutPrecision = OUT_TT_ONLY_PRECIS
        Else
            .lfOutPrecision = OUT_DEFAULT_PRECIS
        End If
        ' converts the font name from unicode
        LaTempArray = StrConv(sFaceName & vbNullChar, vbFromUnicode)
    '   ***** puts the font name into the byte array for face name
        For LnIdx = 0 To UBound(LaTempArray)
            .lfFaceName(LnIdx) = LaTempArray(LnIdx)
        Next LnIdx
    End With
    LhFont = CreateFontIndirect(LrFont)
    m_lOldFont = SelectObject(m_hWorkDC, LhFont)
End Sub

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

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


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

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


Friend Sub Create(ByVal lWidth As Long, ByVal lHeight As Long)
' Creates the memory DC
    Dim LhDC As Long
    
    prvDestroy
    LhDC = CreateDCAsNull("DISPLAY", ByVal 0&, ByVal 0&, ByVal 0&)
    m_hWorkDC = CreateCompatibleDC(LhDC)
    m_hBmp = CreateCompatibleBitmap(LhDC, lWidth, lHeight)
    m_hBmpOld = SelectObject(m_hWorkDC, m_hBmp)
    If (m_hBmpOld = 0) Then
        prvDestroy
    Else
        m_lWidth = lWidth
        m_lHeight = lHeight
        Cls
    End If
    DeleteDC LhDC
End Sub

Private Sub prvDestroy()
    ' Restores original font
    If (Not (m_lOldFont = 0)) Then
        SelectObject m_hWorkDC, m_lOldFont
        m_lOldFont = 0
    End If
    ' Restores original bitmap
    If (Not (m_hBmpOld = 0)) Then
        SelectObject m_hWorkDC, m_hBmpOld
        m_hBmpOld = 0
    End If
    ' Destroy created bitmap
    If (Not (m_hBmp = 0)) Then
        DeleteObject m_hBmp
        m_hBmp = 0
    End If
    ' Resets Width & Height
    m_lWidth = 0
    m_lHeight = 0
    ' Destroy created memory DC
    If (Not (m_hWorkDC = 0)) Then
        DeleteDC m_hWorkDC
        m_hWorkDC = 0
    End If
End Sub

Private Sub Class_Initialize()
    BackColor = vbWhite
    m_iScaleMode = vbInches
'    m_iMFactor=
End Sub

Public Property Let ScaleMode(iUnits As ScaleModeConstants)
'    On Error GoTo ERR_H
'    m_iScaleMode = iUnits
'    Select Case iUnits
'        Case vbPixels
'            m_iMFactor = TWIPS_PER_PIXEL
'        Case rdCentimeters
'            m_iMFactor = TWIPS_PER_CENTIMETER
'        Case rdPoints
'            m_iMFactor = TWIPS_PER_POINT
'        Case rdTwips
'            m_iMFactor = TWIPS_PER_TWIP
'        Case Else ' rdInches
'            m_iMFactor = TWIPS_PER_INCHE
'    End Select
'    m_iMFactor = (m_iMFactor / TWIPS_PER_PIXEL)
'    Exit Property
'ERR_H:
'    Me.RaiseErr Err.Number, "ScaleMode[Let]", Err.Description
End Property


Private Sub Class_Terminate()
   prvDestroy
End Sub