clsmemdc.cls

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

            MoveToEx m_hWorkDC, LrBox.Left + LineOffset, LrBox.Top, LrPos
            LineTo m_hWorkDC, LrBox.Right - LineOffset, LrBox.Top
            MoveToEx m_hWorkDC, LrBox.Right, LrBox.Top + LineOffset, LrPos
            LineTo m_hWorkDC, LrBox.Right, LrBox.Bottom - LineOffset
            MoveToEx m_hWorkDC, LrBox.Right - LineOffset, LrBox.Bottom, LrPos
            LineTo m_hWorkDC, LrBox.Left + LineOffset - 1, LrBox.Bottom
            MoveToEx m_hWorkDC, LrBox.Left, LrBox.Bottom - LineOffset, LrPos
            LineTo m_hWorkDC, LrBox.Left, LrBox.Top + LineOffset - 1
        
            Arc m_hWorkDC, LrBox.Right - ArcDiam, LrBox.Top, LrBox.Right, LrBox.Top + ArcDiam, _
            LrBox.Right, LrBox.Top + LineOffset, LrBox.Right - LineOffset, LrBox.Top
            
            Arc m_hWorkDC, LrBox.Right - ArcDiam, LrBox.Bottom - ArcDiam, LrBox.Right, LrBox.Bottom, _
            LrBox.Right - LineOffset, LrBox.Bottom, LrBox.Right, LrBox.Bottom - LineOffset
            
            Arc m_hWorkDC, LrBox.Left, LrBox.Bottom - ArcDiam, LrBox.Left + ArcDiam, LrBox.Bottom, _
            LrBox.Left, LrBox.Bottom - LineOffset, LrBox.Left + LineOffset, LrBox.Bottom
            
            Arc m_hWorkDC, LrBox.Left, LrBox.Top, LrBox.Left + ArcDiam, LrBox.Top + ArcDiam, _
            LrBox.Left + LineOffset, LrBox.Top, LrBox.Left, LrBox.Top + LineOffset
        
            If lhPen Then
                Call SelectObject(m_hWorkDC, LhOldPen)
                Call DeleteObject(lhPen)
            End If
        End If
    
    End If
    
    Exit Sub

ERR_H:
    Me.RaiseErr Err.Number, "DrawShape"
End Sub

Public Sub DrawCheckBox(ByVal iType As Integer, ByVal blnChecked As Boolean, ByVal lLeft As Long, ByVal lTop As Long, _
    ByVal lWidth As Long, ByVal lHeight As Long, lfColor As OLE_COLOR, Optional lbColor As OLE_COLOR = -1, _
    Optional iLineWidth As Integer = 1, Optional blnSunken As Boolean)
    
'Note from RG (04/08/2006)
'   This is a new sub I added to draw 3 different styles of check box
'   Type 0 is a standard box with a check mark
'   Type 1 is a radio (option) button
'   Type 2 is a box with an 'X' in it
'   The sub gets the checked value when called and draws appropriately
    
    On Error GoTo ERR_H
    Dim LnTop As Long
    Dim LnLeft As Long
    Dim LrBox As RECT
    Dim LrPos As POINTAPI
    Dim lhPen As Long
    Dim LhOldPen As Long
    Dim LhBrush As Long
    
    If iType = 0 Then       'box with check mark
        With LrBox
            .Left = lLeft
            .Top = lTop + (lHeight * 0.1875)
            .Right = lLeft + lWidth
            .Bottom = lTop + lHeight
        End With
        
        If (lbColor <> -1) Then
            
            LhBrush = CreateSolidBrush(lbColor)
            Call FillRect(m_hWorkDC, LrBox, LhBrush)
            Call DeleteObject(LhBrush)
        End If
    
        lhPen = CreatePen(PS_SOLID, iLineWidth, lfColor)
        If (lhPen <> 0) Then
            LhOldPen = SelectObject(m_hWorkDC, lhPen)
        End If
        If blnSunken Then
            MoveToEx m_hWorkDC, lLeft + 1, lTop + (lHeight * 0.9375), LrPos
            LineTo m_hWorkDC, lLeft + 1, lTop + (lHeight * 0.25)
            LineTo m_hWorkDC, lLeft + 11, lTop + (lHeight * 0.25)
        End If
        With LrBox
            MoveToEx m_hWorkDC, .Left, .Top, LrPos
            LineTo m_hWorkDC, .Right, .Top
            LineTo m_hWorkDC, .Right, .Bottom
            LineTo m_hWorkDC, .Left, .Bottom
            LineTo m_hWorkDC, .Left, .Top
        End With
        
        If blnChecked Then
            lhPen = CreatePen(PS_SOLID, iLineWidth * 3, lfColor)
            If (lhPen <> 0) Then
                LhOldPen = SelectObject(m_hWorkDC, lhPen)
            End If
            MoveToEx m_hWorkDC, lLeft + (lWidth * 0.25), lTop + (lHeight * 0.4375), LrPos
            LineTo m_hWorkDC, lLeft + (lWidth * 0.5), lTop + (lHeight * 0.8125)
            LineTo m_hWorkDC, lLeft + (lWidth * 0.833), lTop
        End If
        
    ElseIf iType = 1 Then       'round radio button with center dot
        With LrBox
            .Left = lLeft
            .Top = lTop
            .Right = lLeft + (lWidth * 1.0833)
            .Bottom = lTop + (lHeight * 0.8125)
        End With
        
        Dim lEllReg As Long
        If (lbColor <> -1) Then
            lEllReg = CreateEllipticRgn(LrBox.Left, LrBox.Top, LrBox.Right, LrBox.Bottom)
            LhBrush = CreateSolidBrush(lbColor)
            Call FillRgn(m_hWorkDC, lEllReg, LhBrush)
            Call DeleteObject(LhBrush)
        End If
        
        lhPen = CreatePen(PS_SOLID, iLineWidth * 2, lfColor)
        If (lhPen <> 0) Then
            LhOldPen = SelectObject(m_hWorkDC, lhPen)
        End If

        Call Arc(m_hWorkDC, LrBox.Left, LrBox.Top, LrBox.Right, LrBox.Bottom, _
        LrBox.Left + (lWidth * 0.5), LrBox.Top, LrBox.Left + (lWidth * 0.5), LrBox.Top)
        
        If blnSunken Then
            Call Arc(m_hWorkDC, LrBox.Left + (lWidth * 0.0833), LrBox.Top + (lHeight * 0.0625), LrBox.Right, LrBox.Bottom, _
            LrBox.Left + (lWidth * 0.5), LrBox.Top, LrBox.Left + (lWidth * 0.5), LrBox.Top)
        End If

        If blnChecked Then
            With LrBox
                .Left = lLeft + (lWidth * 0.25)
                .Top = lTop + (lWidth * 0.25)
                .Right = lLeft + (lWidth * 0.9167)
                .Bottom = lTop + (lHeight * 0.6875)
                lEllReg = CreateEllipticRgn(.Left, .Top, .Right, .Bottom)
            End With
            LhBrush = CreateSolidBrush(lfColor)
            Call FillRgn(m_hWorkDC, lEllReg, LhBrush)
            Call DeleteObject(LhBrush)
        End If
        
    ElseIf iType = 2 Then       'box with X in it
        With LrBox
            .Left = lLeft
            .Top = lTop
            .Right = lLeft + lWidth
            .Bottom = lTop + lHeight * 0.75
        End With
        
        If (lbColor <> -1) Then
            LhBrush = CreateSolidBrush(lbColor)
            Call FillRect(m_hWorkDC, LrBox, LhBrush)
            Call DeleteObject(LhBrush)
        End If
    
        lhPen = CreatePen(PS_SOLID, iLineWidth, lfColor)
        If (lhPen <> 0) Then
            LhOldPen = SelectObject(m_hWorkDC, lhPen)
        End If
        
        If blnSunken Then
            MoveToEx m_hWorkDC, lLeft + (lWidth * 0.0833), lTop + (lHeight * 0.75), LrPos
            LineTo m_hWorkDC, lLeft + (lWidth * 0.0833), lTop + (lHeight * 0.0625)
            LineTo m_hWorkDC, lLeft + (lWidth * 0.9167), lTop + (lHeight * 0.0625)
        End If
        
        With LrBox
            MoveToEx m_hWorkDC, .Left, .Top, LrPos
            LineTo m_hWorkDC, .Right, .Top
            LineTo m_hWorkDC, .Right, .Bottom
            LineTo m_hWorkDC, .Left, .Bottom
            LineTo m_hWorkDC, .Left, .Top
        End With
        
        If blnChecked Then
            lhPen = CreatePen(PS_SOLID, iLineWidth * 2, lfColor)
            If (lhPen <> 0) Then
                LhOldPen = SelectObject(m_hWorkDC, lhPen)
            End If
            MoveToEx m_hWorkDC, lLeft + (lWidth * 0.25), lTop + (lWidth * 0.25), LrPos
            LineTo m_hWorkDC, lLeft + (lWidth * 0.833), lTop + (lHeight * 0.625)
            MoveToEx m_hWorkDC, lLeft + (lWidth * 0.25), lTop + (lHeight * 0.625), LrPos
            LineTo m_hWorkDC, lLeft + (lWidth * 0.833), lTop + (lHeight * 0.1875)
        End If
        
    End If
    
    If lhPen Then
        Call SelectObject(m_hWorkDC, LhOldPen)
        Call DeleteObject(lhPen)
    End If
    
    Exit Sub

ERR_H:
    Me.RaiseErr Err.Number, "DrawCheckBox"

End Sub

Public Sub DrawLine(lX1 As Long, lY1 As Long, lX2 As Long, lY2 As Long, _
    lColor As OLE_COLOR, Optional lWidth As Long = 1, Optional lPen As Long)
    
    On Error GoTo ERR_H
    Dim LrPos As POINTAPI
    Dim lhPen As Long
    Dim LhOldPen As Long
    
    If (lWidth = 0) Then
        lhPen = CreatePen(PS_DOT, 1, lColor)
    Else
        lhPen = CreatePen(lPen, lWidth, lColor)
    End If
    If lhPen Then
        LhOldPen = SelectObject(m_hWorkDC, lhPen)
    End If
    ' Draws box lines
    MoveToEx m_hWorkDC, lX1, lY1, LrPos
    LineTo m_hWorkDC, lX2, lY2
    If lhPen Then
        Call SelectObject(m_hWorkDC, LhOldPen)
        Call DeleteObject(lhPen)
    End If
    Exit Sub

ERR_H:
    Me.RaiseErr Err.Number, "DrawLine"

End Sub


Public Sub DrawText(ByVal sText As String, ByVal lLeft As Long, ByVal lTop As Long, _
    ByVal lWidth As Long, ByVal lHeight As Long, ByVal lfColor As OLE_COLOR, _
    ByVal lbColor As OLE_COLOR, ByVal lFlags As Long)
    On Error GoTo ERR_H
    Dim lBrush As Long
    Dim LnOldBMode As Long
    Dim LrBox As RECT
'////////////////////////////////////////
'///      Coordenates Calculation
'////////////////////////////////////////
    With LrBox
        .Left = lLeft
        .Top = lTop
        .Right = (.Left + lWidth)
        .Bottom = (.Top + lHeight)
    End With
'////////////////////////////////////////
'///       Defaults Resolution
'////////////////////////////////////////
    If (lFlags = 0) Then
        lFlags = (DT_WORDBREAK Or DT_LEFT)
    ElseIf (lFlags = 1) Then
        lFlags = (DT_WORDBREAK Or DT_RIGHT)
    ElseIf (lFlags = 2) Then
        lFlags = (DT_WORDBREAK Or DT_CENTER)
    End If
    If (lfColor = -1) Then
        lfColor = vbBlack
    End If
'////////////////////////////////////////
'///         Background Drawing
'///_____________________________________
'/// If background is not transparent
'/// (<> -1) then draws it...
'////////////////////////////////////////
    If (lbColor <> -1) Then
        lBrush = CreateSolidBrush(lbColor)
        Call FillRect(m_hWorkDC, LrBox, lBrush)
        DeleteObject (lBrush)
    End If
'////////////////////////////////////////
'///           Text Drawing
'////////////////////////////////////////
    LnOldBMode = SetBkMode(m_hWorkDC, BKMODE_TRANSPARENT)
    Call SetTextColor(m_hWorkDC, lfColor)
    DrawTextAPI m_hWorkDC, sText, Len(sText), LrBox, lFlags Or DT_NOPREFIX
    Call SetBkMode(m_hWorkDC, LnOldBMode)
    Exit Sub
ERR_H:
    Me.RaiseErr Err.Number, "DrawText"
End Sub

Friend Sub RaiseErr(ByVal lErrNum As RSErrorCode, Optional sRoutineName As String, _
    Optional sDescription As String)
    RaiseError lErrNum, TypeName(Me), sRoutineName, sDescription, Erl
End Sub


Public Sub BlitImage(lDestDC As Long, lLeft As Long, lTop As Long, _
    lWidth As Long, lHeight As Long, Optional bNormal As Boolean = True)
    
    If ((m_lWidth = lWidth) And (m_lHeight = lHeight)) Then
        BitBlt lDestDC, lLeft, lTop, lWidth, lHeight, m_hWorkDC, 0, 0, SRCCOPY
    Else
        Dim LrPA As POINTAPI
        Dim LnOldMode As Long
        Dim LnOldPalette As Long
        'Copy to destination DC
        Call SetBrushOrgEx(lDestDC, 0, 0, LrPA)
        Call StretchBlt(lDestDC, lLeft, lTop, lWidth, lHeight, m_hWorkDC, _
             0, 0, m_lWidth, m_lHeight, SRCCOPY)
        If Not bNormal Then
            Dither lDestDC
        End If
    End If
End Sub